From a57a6b55532587a4d8ecc93bea21e5c85a986c1f Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Tue, 30 Jul 2019 20:21:03 -0400
Subject: Fixed interval masking.

---
 Mask.hs | 86 ++++++++++++++++++++++++++++++++---------------------------------
 1 file changed, 43 insertions(+), 43 deletions(-)

(limited to 'Mask.hs')

diff --git a/Mask.hs b/Mask.hs
index 0b91e42..81de4d7 100644
--- a/Mask.hs
+++ b/Mask.hs
@@ -1,54 +1,50 @@
+{-# LANGUAGE CPP #-}
 module Mask where
 
+import Control.Monad
+import Debug.Trace
 import Data.Int
+import qualified Data.List as List
+import Data.List.Merge
 
+-- Start index , count
 newtype Mask = Mask [(Int32,Int32)]
  deriving (Eq,Ord,Show)
 
-{-
-merge ((x0,x):xs) ((y0,y):ys) =
-    if x0 <= y0
-        then case compare x y0 of
-            LT -> (x0 x) (y0 y)
-            EQ -> (x0 x=y0 y)
-            GT -> if x <= y then -> (x0 y0 x y)
-                            else -> (x0 y0 y x)
-        else case compare x0 y of
-            LT -> if x <= y then (y0 x0 x y)
-                            else (y0 x0 y x)
-            EQ -> (y0 y=x0 x)
-            GT -> (y0 y) (x0 x)
--}
-
-subtr [] ys = []
-subtr xs [] = xs
-subtr ((x0,x):xs) ((y0,y):ys) =
-    if x0 <= y0
-        then case compare x y0 of
-            LT -> subtr ((x0,x):xs) ys
-            EQ -> (x0,x) : subtr xs ((y0,y):ys)
-            GT -> if x <= y then (if x0<y0 then ((x0,y0) :) else id) $ subtr xs ((y0,y):ys)
-                            else (if x0<y0 then ((x0,y0) :) else id) $ subtr ((y,x):xs) ys
-        else case compare x0 y of
-            LT -> if x <= y then subtr xs ((y0,y):ys)
-                            else subtr ((y,x):xs) ys
-            EQ -> subtr ((x0,x):xs) ys
-            GT -> subtr ((x0,x):xs) ys
+subtr xs ys =
+    let xxs = concatMap (\(a,b) -> [(a,1),(b,2)]) xs
+        yys = concatMap (\(a,b) -> [(a,4),(b,3)]) ys
+        zzs = mergeL xxs yys -- xxx: we really want (comparing fst)
+        zs = foldr subtr4 (const []) zzs (False,False)
+    in filter (uncurry (/=)) $ pairs zs
+
+subtr4 (x,1) f (False,iny)  = (if not iny then (x:) else id) $ f (True,iny)
+subtr4 (x,2) f (True,iny)   = (if not iny then (x:) else id) $ f (False,iny)
+subtr4 (x,3) f (inx,True)   = (if inx then (x:) else id) $ f (inx,False)
+subtr4 (x,4) f (inx,False)  = (if inx then (x:) else id) $ f (inx,True)
+subtr4 _     f inxy         = f inxy
+
+pairs :: [a] -> [(a,a)]
+pairs (x:y:ys) = (x,y) : pairs ys
+pairs _ = []
+
+
+union1 ab [] = (ab,[])
+union1 (a,b) ((x0,x):xs) =
+    if x0 <= b
+        then union1 (a,max x b) xs
+        else ((a,b),(x0,x):xs)
 
 union [] ys = ys
 union xs [] = xs
-union ((x0,x):xs) ((y0,y):ys) =
-    if x0 <= y0
-        then case compare x y0 of
-            LT -> (x0,x) : union xs ((y0,y):ys)
-            EQ -> (x0,y) : union xs ys
-            GT -> if x <= y then union xs ((x0,y):ys)
-                            else union ((x0,x):xs) ys
-        else case compare x0 y of
-            LT -> if x <= y then union xs ((y0,y):ys)
-                            else union ((y0,x):xs) ys
-            EQ -> (y0,x) : union xs ys
-            GT -> (y0,y) : union ((x0,x):xs) ys
+union xs@((x0,_):_) ys@((y0,_):_) | y0<x0 = union ys xs
+union (x:xs) ys =
+    let (x',ys') = union1 x ys
+        (z@(_,e),xs') = union1 x' xs
+    in if all (\(f,_) -> e < f) (take 1 ys' ++ take 1 xs')
+        then z : union xs' ys'
+        else union (z:xs') ys'
+
 
 endpts :: (Int32,Int32) -> (Int32,Int32)
 endpts (x0,sz) = (x0,x0 + sz)
@@ -57,7 +53,11 @@ sized :: (Int32,Int32) -> (Int32,Int32)
 sized (x0,x) = (x0, x - x0)
 
 maskPlus :: Mask -> Mask -> Mask
-maskPlus (Mask xs) (Mask ys) = Mask $ sized <$> union (endpts <$> xs) (endpts <$> ys)
+maskPlus (Mask xs) (Mask ys) =
+    let zs = sized <$> union (endpts <$> xs) (endpts <$> ys)
+    in Mask zs
 
 maskSubtract :: Mask -> Mask -> Mask
-maskSubtract (Mask xs) (Mask ys) = Mask $ sized <$> subtr (endpts <$> xs) (endpts <$> ys)
+maskSubtract (Mask xs) (Mask ys) =
+    let zs = sized <$> subtr (endpts <$> xs) (endpts <$> ys)
+    in Mask zs
-- 
cgit v1.2.3