diff options
author | Joe Crayne <joe@jerkface.net> | 2019-07-30 20:21:03 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-07-31 02:28:24 -0400 |
commit | a57a6b55532587a4d8ecc93bea21e5c85a986c1f (patch) | |
tree | ad37d4c52707d9f023e331951bd23581f428e9cb | |
parent | e0698ec0a20507442fc448a293dd68796c7c1b97 (diff) |
Fixed interval masking.
-rw-r--r-- | Data/List/Merge.hs | 78 | ||||
-rw-r--r-- | LoadMesh.hs | 8 | ||||
-rw-r--r-- | Mask.hs | 86 | ||||
-rw-r--r-- | lambda-gtk.cabal | 2 |
4 files changed, 125 insertions, 49 deletions
diff --git a/Data/List/Merge.hs b/Data/List/Merge.hs new file mode 100644 index 0000000..30853d9 --- /dev/null +++ b/Data/List/Merge.hs | |||
@@ -0,0 +1,78 @@ | |||
1 | module Data.List.Merge where | ||
2 | |||
3 | -- | Ordinary Ord-based sorted list merge. | ||
4 | -- | ||
5 | -- TODO: verify fusion. | ||
6 | mergeL :: Ord a => [a] -> [a] -> [a] | ||
7 | mergeL as bs = mergeLists (mergeData compare as bs) const as bs | ||
8 | |||
9 | -- | Merge lists based on pre-computed comparison results. Use 'mergeData' to | ||
10 | -- perform the comparisons. | ||
11 | mergeLists :: [(Int,Ordering)] -- ^ comparison results. | ||
12 | -> (a -> a -> a) -- ^ combining function applied when 'EQ' is encountered. | ||
13 | -> [a] -- ^ sorted list | ||
14 | -> [a] -- ^ sorted list | ||
15 | -> [a] -- ^ merged sorted list | ||
16 | mergeLists ((n,LT):os) f xs ys = ls ++ mergeLists os f xs' ys | ||
17 | where | ||
18 | (ls,xs') = splitAt n xs | ||
19 | mergeLists ((n,EQ):os) f xs ys = es ++ mergeLists os f xs' ys' | ||
20 | where | ||
21 | (les,xs') = splitAt n xs | ||
22 | (res,ys') = splitAt n ys | ||
23 | es = zipWith f les res | ||
24 | mergeLists ((n,GT):os) f xs ys = gs ++ mergeLists os f xs ys' | ||
25 | where | ||
26 | (gs,ys') = splitAt n ys | ||
27 | mergeLists [] _ [] ys = ys | ||
28 | mergeLists [] _ xs [] = xs | ||
29 | mergeLists [] _ _ _ = error "mergeLists: insufficient data." -- xs ++ ys | ||
30 | |||
31 | -- | Inverse to 'mergeLists': given a list of comparison results, partition a | ||
32 | -- list into the parts necessary for 'mergeLists' to recreate it. | ||
33 | splitLists :: [(Int,Ordering)] -> [a] -> ([a],[a]) | ||
34 | splitLists ((n,LT):os) xs = (ls ++ lls, rrs) | ||
35 | where | ||
36 | (ls,xs') = splitAt n xs | ||
37 | (lls,rrs) = splitLists os xs' | ||
38 | splitLists ((n,EQ):os) xs = (es ++ lls, es ++ rrs) | ||
39 | where | ||
40 | (es,xs') = splitAt n xs | ||
41 | (lls,rrs) = splitLists os xs' | ||
42 | splitLists ((n,GT):os) xs = (lls, rs ++ rrs) | ||
43 | where | ||
44 | (rs,xs') = splitAt n xs | ||
45 | (lls,rrs) = splitLists os xs' | ||
46 | splitLists [] xs = (xs,xs) | ||
47 | |||
48 | |||
49 | -- | mergeData | ||
50 | -- | ||
51 | -- > mergeData compare [1,3,5] [2,2,4,6] ==> [(1,LT),(2,GT),(1,LT),(1,GT),(1,LT),(1,GT)] | ||
52 | -- | ||
53 | -- Given a comparison function and two sorted lists, 'mergeData' will return | ||
54 | -- a RLE compressed (run-length encoded) list of the comparison results | ||
55 | -- encountered while merging the lists. | ||
56 | -- | ||
57 | -- This data is enough information to perform the merge without doing the | ||
58 | -- comparisons or to reverse a merged list back to two sorted lists. | ||
59 | -- | ||
60 | -- When one list is exhausted, the length of the remaining list is returned | ||
61 | -- as a run-length for LT or GT depending on whether the left list or the | ||
62 | -- right list has elements. | ||
63 | mergeData :: (a -> a -> Ordering) -> [a] -> [a] -> [(Int,Ordering)] | ||
64 | mergeData comp (x:xs) (y:ys) | ||
65 | | comp x y == LT = case mergeData comp xs (y:ys) of | ||
66 | (n,LT):zs -> let n'=n+1 in n' `seq` (n',LT):zs | ||
67 | zs -> (1,LT):zs | ||
68 | | comp x y == EQ = case mergeData comp xs ys of | ||
69 | (n,EQ):zs -> let n'=n+1 in n' `seq` (n',EQ):zs | ||
70 | zs -> (1,EQ):zs | ||
71 | | otherwise = case mergeData comp (x:xs) ys of | ||
72 | (n,GT):zs -> let n'=n+1 in n' `seq` (n',GT):zs | ||
73 | zs -> (1,GT):zs | ||
74 | mergeData _ [] [] = [] | ||
75 | mergeData _ [] ys = (length ys, GT) : [] | ||
76 | mergeData _ xs [] = (length xs, LT) : [] | ||
77 | |||
78 | |||
diff --git a/LoadMesh.hs b/LoadMesh.hs index bb0f5b0..423630f 100644 --- a/LoadMesh.hs +++ b/LoadMesh.hs | |||
@@ -12,15 +12,12 @@ import MtlParser | |||
12 | 12 | ||
13 | import Control.Arrow | 13 | import Control.Arrow |
14 | import Control.Monad | 14 | import Control.Monad |
15 | import Data.Functor | ||
16 | import Data.Int | ||
17 | import Data.List as List | 15 | import Data.List as List |
18 | import Data.Maybe | 16 | import Data.Maybe |
19 | import Data.Map (Map) | 17 | import Data.Map (Map) |
20 | import qualified Data.Map as Map | 18 | import qualified Data.Map as Map |
21 | import qualified Data.Vector as V | 19 | import qualified Data.Vector as V |
22 | import qualified Data.Vector.Storable as StorableV | 20 | import qualified Data.Vector.Storable as StorableV |
23 | import qualified Data.ByteString as SB | ||
24 | import qualified Data.ByteString.Lazy.Char8 as L | 21 | import qualified Data.ByteString.Lazy.Char8 as L |
25 | import Data.Text (unpack,Text,pack) | 22 | import Data.Text (unpack,Text,pack) |
26 | import Data.List (groupBy,nub) | 23 | import Data.List (groupBy,nub) |
@@ -30,7 +27,6 @@ import System.FilePath | |||
30 | import Codec.Picture as Juicy | 27 | import Codec.Picture as Juicy |
31 | import Wavefront | 28 | import Wavefront |
32 | import Wavefront.Types | 29 | import Wavefront.Types |
33 | import Data.Aeson | ||
34 | import Mask | 30 | import Mask |
35 | 31 | ||
36 | data MaterialMesh m = MaterialMesh | 32 | data MaterialMesh m = MaterialMesh |
@@ -251,8 +247,10 @@ elementIndices els = (spans,map snd ts) | |||
251 | ts = map ((elGroups &&& elValue) . fmap triangulate) els | 247 | ts = map ((elGroups &&& elValue) . fmap triangulate) els |
252 | rs = List.scanl' go ((0,0),[]) ts -- scanl :: (b -> a -> b) -> b -> [a] -> [b] | 248 | rs = List.scanl' go ((0,0),[]) ts -- scanl :: (b -> a -> b) -> b -> [a] -> [b] |
253 | go ((start,len),_) (gs,vs) = ((start+len,length vs),gs) | 249 | go ((start,len),_) (gs,vs) = ((start+len,length vs),gs) |
254 | spans = fmap (Mask . map (fromIntegral***fromIntegral)) | 250 | spans = fmap (foldr (maskPlus . Mask . (:[])) (Mask []) |
251 | . map (fromIntegral***fromIntegral)) | ||
255 | $ foldr (Map.unionWith (++)) Map.empty $ map singletonSpan rs | 252 | $ foldr (Map.unionWith (++)) Map.empty $ map singletonSpan rs |
253 | |||
256 | singletonSpan (span,gnames) = Map.fromList $ map (, [span]) gnames | 254 | singletonSpan (span,gnames) = Map.fromList $ map (, [span]) gnames |
257 | 255 | ||
258 | 256 | ||
@@ -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 | ||
diff --git a/lambda-gtk.cabal b/lambda-gtk.cabal index 02dbc85..da4c751 100644 --- a/lambda-gtk.cabal +++ b/lambda-gtk.cabal | |||
@@ -50,7 +50,7 @@ executable meshsketch | |||
50 | other-modules: InfinitePlane LambdaCubeWidget GLWidget LambdaCube.Gtk TimeKeeper | 50 | other-modules: InfinitePlane LambdaCubeWidget GLWidget LambdaCube.Gtk TimeKeeper |
51 | LoadMesh MtlParser Matrix LambdaCube.GL.HMatrix | 51 | LoadMesh MtlParser Matrix LambdaCube.GL.HMatrix |
52 | Animator MeshSketch CubeMap AttributeData GPURing MaskableStream | 52 | Animator MeshSketch CubeMap AttributeData GPURing MaskableStream |
53 | RingBuffer SmallRing VectorRing Camera Bezier FitCurves Mask | 53 | RingBuffer SmallRing VectorRing Camera Bezier FitCurves Mask Data.List.Merge |
54 | extensions: NondecreasingIndentation | 54 | extensions: NondecreasingIndentation |
55 | other-extensions: OverloadedLabels, OverloadedLists, OverloadedStrings | 55 | other-extensions: OverloadedLabels, OverloadedLists, OverloadedStrings |
56 | build-depends: base, containers >=0.5 && <0.6, bytestring >=0.10 && <0.11, | 56 | build-depends: base, containers >=0.5 && <0.6, bytestring >=0.10 && <0.11, |