summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-07-30 20:21:03 -0400
committerJoe Crayne <joe@jerkface.net>2019-07-31 02:28:24 -0400
commita57a6b55532587a4d8ecc93bea21e5c85a986c1f (patch)
treead37d4c52707d9f023e331951bd23581f428e9cb
parente0698ec0a20507442fc448a293dd68796c7c1b97 (diff)
Fixed interval masking.
-rw-r--r--Data/List/Merge.hs78
-rw-r--r--LoadMesh.hs8
-rw-r--r--Mask.hs86
-rw-r--r--lambda-gtk.cabal2
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 @@
1module Data.List.Merge where
2
3-- | Ordinary Ord-based sorted list merge.
4--
5-- TODO: verify fusion.
6mergeL :: Ord a => [a] -> [a] -> [a]
7mergeL 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.
11mergeLists :: [(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
16mergeLists ((n,LT):os) f xs ys = ls ++ mergeLists os f xs' ys
17 where
18 (ls,xs') = splitAt n xs
19mergeLists ((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
24mergeLists ((n,GT):os) f xs ys = gs ++ mergeLists os f xs ys'
25 where
26 (gs,ys') = splitAt n ys
27mergeLists [] _ [] ys = ys
28mergeLists [] _ xs [] = xs
29mergeLists [] _ _ _ = 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.
33splitLists :: [(Int,Ordering)] -> [a] -> ([a],[a])
34splitLists ((n,LT):os) xs = (ls ++ lls, rrs)
35 where
36 (ls,xs') = splitAt n xs
37 (lls,rrs) = splitLists os xs'
38splitLists ((n,EQ):os) xs = (es ++ lls, es ++ rrs)
39 where
40 (es,xs') = splitAt n xs
41 (lls,rrs) = splitLists os xs'
42splitLists ((n,GT):os) xs = (lls, rs ++ rrs)
43 where
44 (rs,xs') = splitAt n xs
45 (lls,rrs) = splitLists os xs'
46splitLists [] 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.
63mergeData :: (a -> a -> Ordering) -> [a] -> [a] -> [(Int,Ordering)]
64mergeData 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
74mergeData _ [] [] = []
75mergeData _ [] ys = (length ys, GT) : []
76mergeData _ 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
13import Control.Arrow 13import Control.Arrow
14import Control.Monad 14import Control.Monad
15import Data.Functor
16import Data.Int
17import Data.List as List 15import Data.List as List
18import Data.Maybe 16import Data.Maybe
19import Data.Map (Map) 17import Data.Map (Map)
20import qualified Data.Map as Map 18import qualified Data.Map as Map
21import qualified Data.Vector as V 19import qualified Data.Vector as V
22import qualified Data.Vector.Storable as StorableV 20import qualified Data.Vector.Storable as StorableV
23import qualified Data.ByteString as SB
24import qualified Data.ByteString.Lazy.Char8 as L 21import qualified Data.ByteString.Lazy.Char8 as L
25import Data.Text (unpack,Text,pack) 22import Data.Text (unpack,Text,pack)
26import Data.List (groupBy,nub) 23import Data.List (groupBy,nub)
@@ -30,7 +27,6 @@ import System.FilePath
30import Codec.Picture as Juicy 27import Codec.Picture as Juicy
31import Wavefront 28import Wavefront
32import Wavefront.Types 29import Wavefront.Types
33import Data.Aeson
34import Mask 30import Mask
35 31
36data MaterialMesh m = MaterialMesh 32data 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
diff --git a/Mask.hs b/Mask.hs
index 0b91e42..81de4d7 100644
--- a/Mask.hs
+++ b/Mask.hs
@@ -1,54 +1,50 @@
1{-# LANGUAGE CPP #-}
1module Mask where 2module Mask where
2 3
4import Control.Monad
5import Debug.Trace
3import Data.Int 6import Data.Int
7import qualified Data.List as List
8import Data.List.Merge
4 9
10-- Start index , count
5newtype Mask = Mask [(Int32,Int32)] 11newtype Mask = Mask [(Int32,Int32)]
6 deriving (Eq,Ord,Show) 12 deriving (Eq,Ord,Show)
7 13
8{- 14subtr xs ys =
9merge ((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) 21subtr4 (x,1) f (False,iny) = (if not iny then (x:) else id) $ f (True,iny)
16 else case compare x0 y of 22subtr4 (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) 23subtr4 (x,3) f (inx,True) = (if inx then (x:) else id) $ f (inx,False)
18 else (y0 x0 y x) 24subtr4 (x,4) f (inx,False) = (if inx then (x:) else id) $ f (inx,True)
19 EQ -> (y0 y=x0 x) 25subtr4 _ f inxy = f inxy
20 GT -> (y0 y) (x0 x) 26
21-} 27pairs :: [a] -> [(a,a)]
22 28pairs (x:y:ys) = (x,y) : pairs ys
23subtr [] ys = [] 29pairs _ = []
24subtr xs [] = xs 30
25subtr ((x0,x):xs) ((y0,y):ys) = 31
26 if x0 <= y0 32union1 ab [] = (ab,[])
27 then case compare x y0 of 33union1 (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
38union [] ys = ys 38union [] ys = ys
39union xs [] = xs 39union xs [] = xs
40union ((x0,x):xs) ((y0,y):ys) = 40union xs@((x0,_):_) ys@((y0,_):_) | y0<x0 = union ys xs
41 if x0 <= y0 41union (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
53endpts :: (Int32,Int32) -> (Int32,Int32) 49endpts :: (Int32,Int32) -> (Int32,Int32)
54endpts (x0,sz) = (x0,x0 + sz) 50endpts (x0,sz) = (x0,x0 + sz)
@@ -57,7 +53,11 @@ sized :: (Int32,Int32) -> (Int32,Int32)
57sized (x0,x) = (x0, x - x0) 53sized (x0,x) = (x0, x - x0)
58 54
59maskPlus :: Mask -> Mask -> Mask 55maskPlus :: Mask -> Mask -> Mask
60maskPlus (Mask xs) (Mask ys) = Mask $ sized <$> union (endpts <$> xs) (endpts <$> ys) 56maskPlus (Mask xs) (Mask ys) =
57 let zs = sized <$> union (endpts <$> xs) (endpts <$> ys)
58 in Mask zs
61 59
62maskSubtract :: Mask -> Mask -> Mask 60maskSubtract :: Mask -> Mask -> Mask
63maskSubtract (Mask xs) (Mask ys) = Mask $ sized <$> subtr (endpts <$> xs) (endpts <$> ys) 61maskSubtract (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,