diff options
Diffstat (limited to 'Mask.hs')
-rw-r--r-- | Mask.hs | 86 |
1 files changed, 43 insertions, 43 deletions
@@ -1,54 +1,50 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
1 | module Mask where | 2 | module Mask where |
2 | 3 | ||
4 | import Control.Monad | ||
5 | import Debug.Trace | ||
3 | import Data.Int | 6 | import Data.Int |
7 | import qualified Data.List as List | ||
8 | import Data.List.Merge | ||
4 | 9 | ||
10 | -- Start index , count | ||
5 | newtype Mask = Mask [(Int32,Int32)] | 11 | newtype Mask = Mask [(Int32,Int32)] |
6 | deriving (Eq,Ord,Show) | 12 | deriving (Eq,Ord,Show) |
7 | 13 | ||
8 | {- | 14 | subtr xs ys = |
9 | merge ((x0,x):xs) ((y0,y):ys) = | 15 | let xxs = concatMap (\(a,b) -> [(a,1),(b,2)]) xs |
10 | if x0 <= y0 | 16 | yys = concatMap (\(a,b) -> [(a,4),(b,3)]) ys |
11 | then case compare x y0 of | 17 | zzs = mergeL xxs yys -- xxx: we really want (comparing fst) |
12 | LT -> (x0 x) (y0 y) | 18 | zs = foldr subtr4 (const []) zzs (False,False) |
13 | EQ -> (x0 x=y0 y) | 19 | in filter (uncurry (/=)) $ pairs zs |
14 | GT -> if x <= y then -> (x0 y0 x y) | 20 | |
15 | else -> (x0 y0 y x) | 21 | subtr4 (x,1) f (False,iny) = (if not iny then (x:) else id) $ f (True,iny) |
16 | else case compare x0 y of | 22 | subtr4 (x,2) f (True,iny) = (if not iny then (x:) else id) $ f (False,iny) |
17 | LT -> if x <= y then (y0 x0 x y) | 23 | subtr4 (x,3) f (inx,True) = (if inx then (x:) else id) $ f (inx,False) |
18 | else (y0 x0 y x) | 24 | subtr4 (x,4) f (inx,False) = (if inx then (x:) else id) $ f (inx,True) |
19 | EQ -> (y0 y=x0 x) | 25 | subtr4 _ f inxy = f inxy |
20 | GT -> (y0 y) (x0 x) | 26 | |
21 | -} | 27 | pairs :: [a] -> [(a,a)] |
22 | 28 | pairs (x:y:ys) = (x,y) : pairs ys | |
23 | subtr [] ys = [] | 29 | pairs _ = [] |
24 | subtr xs [] = xs | 30 | |
25 | subtr ((x0,x):xs) ((y0,y):ys) = | 31 | |
26 | if x0 <= y0 | 32 | union1 ab [] = (ab,[]) |
27 | then case compare x y0 of | 33 | union1 (a,b) ((x0,x):xs) = |
28 | LT -> subtr ((x0,x):xs) ys | 34 | if x0 <= b |
29 | EQ -> (x0,x) : subtr xs ((y0,y):ys) | 35 | then union1 (a,max x b) xs |
30 | GT -> if x <= y then (if x0<y0 then ((x0,y0) :) else id) $ subtr xs ((y0,y):ys) | 36 | else ((a,b),(x0,x):xs) |
31 | else (if x0<y0 then ((x0,y0) :) else id) $ subtr ((y,x):xs) ys | ||
32 | else case compare x0 y of | ||
33 | LT -> if x <= y then subtr xs ((y0,y):ys) | ||
34 | else subtr ((y,x):xs) ys | ||
35 | EQ -> subtr ((x0,x):xs) ys | ||
36 | GT -> subtr ((x0,x):xs) ys | ||
37 | 37 | ||
38 | union [] ys = ys | 38 | union [] ys = ys |
39 | union xs [] = xs | 39 | union xs [] = xs |
40 | union ((x0,x):xs) ((y0,y):ys) = | 40 | union xs@((x0,_):_) ys@((y0,_):_) | y0<x0 = union ys xs |
41 | if x0 <= y0 | 41 | union (x:xs) ys = |
42 | then case compare x y0 of | 42 | let (x',ys') = union1 x ys |
43 | LT -> (x0,x) : union xs ((y0,y):ys) | 43 | (z@(_,e),xs') = union1 x' xs |
44 | EQ -> (x0,y) : union xs ys | 44 | in if all (\(f,_) -> e < f) (take 1 ys' ++ take 1 xs') |
45 | GT -> if x <= y then union xs ((x0,y):ys) | 45 | then z : union xs' ys' |
46 | else union ((x0,x):xs) ys | 46 | else union (z:xs') ys' |
47 | else case compare x0 y of | 47 | |
48 | LT -> if x <= y then union xs ((y0,y):ys) | ||
49 | else union ((y0,x):xs) ys | ||
50 | EQ -> (y0,x) : union xs ys | ||
51 | GT -> (y0,y) : union ((x0,x):xs) ys | ||
52 | 48 | ||
53 | endpts :: (Int32,Int32) -> (Int32,Int32) | 49 | endpts :: (Int32,Int32) -> (Int32,Int32) |
54 | endpts (x0,sz) = (x0,x0 + sz) | 50 | endpts (x0,sz) = (x0,x0 + sz) |
@@ -57,7 +53,11 @@ sized :: (Int32,Int32) -> (Int32,Int32) | |||
57 | sized (x0,x) = (x0, x - x0) | 53 | sized (x0,x) = (x0, x - x0) |
58 | 54 | ||
59 | maskPlus :: Mask -> Mask -> Mask | 55 | maskPlus :: Mask -> Mask -> Mask |
60 | maskPlus (Mask xs) (Mask ys) = Mask $ sized <$> union (endpts <$> xs) (endpts <$> ys) | 56 | maskPlus (Mask xs) (Mask ys) = |
57 | let zs = sized <$> union (endpts <$> xs) (endpts <$> ys) | ||
58 | in Mask zs | ||
61 | 59 | ||
62 | maskSubtract :: Mask -> Mask -> Mask | 60 | maskSubtract :: Mask -> Mask -> Mask |
63 | maskSubtract (Mask xs) (Mask ys) = Mask $ sized <$> subtr (endpts <$> xs) (endpts <$> ys) | 61 | maskSubtract (Mask xs) (Mask ys) = |
62 | let zs = sized <$> subtr (endpts <$> xs) (endpts <$> ys) | ||
63 | in Mask zs | ||