From a57a6b55532587a4d8ecc93bea21e5c85a986c1f Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Tue, 30 Jul 2019 20:21:03 -0400 Subject: Fixed interval masking. --- Data/List/Merge.hs | 78 +++++++++++++++++++++++++++++++++++++++++++++++++ LoadMesh.hs | 8 ++--- Mask.hs | 86 +++++++++++++++++++++++++++--------------------------- lambda-gtk.cabal | 2 +- 4 files changed, 125 insertions(+), 49 deletions(-) create mode 100644 Data/List/Merge.hs 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 @@ +module Data.List.Merge where + +-- | Ordinary Ord-based sorted list merge. +-- +-- TODO: verify fusion. +mergeL :: Ord a => [a] -> [a] -> [a] +mergeL as bs = mergeLists (mergeData compare as bs) const as bs + +-- | Merge lists based on pre-computed comparison results. Use 'mergeData' to +-- perform the comparisons. +mergeLists :: [(Int,Ordering)] -- ^ comparison results. + -> (a -> a -> a) -- ^ combining function applied when 'EQ' is encountered. + -> [a] -- ^ sorted list + -> [a] -- ^ sorted list + -> [a] -- ^ merged sorted list +mergeLists ((n,LT):os) f xs ys = ls ++ mergeLists os f xs' ys + where + (ls,xs') = splitAt n xs +mergeLists ((n,EQ):os) f xs ys = es ++ mergeLists os f xs' ys' + where + (les,xs') = splitAt n xs + (res,ys') = splitAt n ys + es = zipWith f les res +mergeLists ((n,GT):os) f xs ys = gs ++ mergeLists os f xs ys' + where + (gs,ys') = splitAt n ys +mergeLists [] _ [] ys = ys +mergeLists [] _ xs [] = xs +mergeLists [] _ _ _ = error "mergeLists: insufficient data." -- xs ++ ys + +-- | Inverse to 'mergeLists': given a list of comparison results, partition a +-- list into the parts necessary for 'mergeLists' to recreate it. +splitLists :: [(Int,Ordering)] -> [a] -> ([a],[a]) +splitLists ((n,LT):os) xs = (ls ++ lls, rrs) + where + (ls,xs') = splitAt n xs + (lls,rrs) = splitLists os xs' +splitLists ((n,EQ):os) xs = (es ++ lls, es ++ rrs) + where + (es,xs') = splitAt n xs + (lls,rrs) = splitLists os xs' +splitLists ((n,GT):os) xs = (lls, rs ++ rrs) + where + (rs,xs') = splitAt n xs + (lls,rrs) = splitLists os xs' +splitLists [] xs = (xs,xs) + + +-- | mergeData +-- +-- > mergeData compare [1,3,5] [2,2,4,6] ==> [(1,LT),(2,GT),(1,LT),(1,GT),(1,LT),(1,GT)] +-- +-- Given a comparison function and two sorted lists, 'mergeData' will return +-- a RLE compressed (run-length encoded) list of the comparison results +-- encountered while merging the lists. +-- +-- This data is enough information to perform the merge without doing the +-- comparisons or to reverse a merged list back to two sorted lists. +-- +-- When one list is exhausted, the length of the remaining list is returned +-- as a run-length for LT or GT depending on whether the left list or the +-- right list has elements. +mergeData :: (a -> a -> Ordering) -> [a] -> [a] -> [(Int,Ordering)] +mergeData comp (x:xs) (y:ys) + | comp x y == LT = case mergeData comp xs (y:ys) of + (n,LT):zs -> let n'=n+1 in n' `seq` (n',LT):zs + zs -> (1,LT):zs + | comp x y == EQ = case mergeData comp xs ys of + (n,EQ):zs -> let n'=n+1 in n' `seq` (n',EQ):zs + zs -> (1,EQ):zs + | otherwise = case mergeData comp (x:xs) ys of + (n,GT):zs -> let n'=n+1 in n' `seq` (n',GT):zs + zs -> (1,GT):zs +mergeData _ [] [] = [] +mergeData _ [] ys = (length ys, GT) : [] +mergeData _ xs [] = (length xs, LT) : [] + + diff --git a/LoadMesh.hs b/LoadMesh.hs index bb0f5b0..423630f 100644 --- a/LoadMesh.hs +++ b/LoadMesh.hs @@ -12,15 +12,12 @@ import MtlParser import Control.Arrow import Control.Monad -import Data.Functor -import Data.Int import Data.List as List import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Vector as V import qualified Data.Vector.Storable as StorableV -import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy.Char8 as L import Data.Text (unpack,Text,pack) import Data.List (groupBy,nub) @@ -30,7 +27,6 @@ import System.FilePath import Codec.Picture as Juicy import Wavefront import Wavefront.Types -import Data.Aeson import Mask data MaterialMesh m = MaterialMesh @@ -251,8 +247,10 @@ elementIndices els = (spans,map snd ts) ts = map ((elGroups &&& elValue) . fmap triangulate) els rs = List.scanl' go ((0,0),[]) ts -- scanl :: (b -> a -> b) -> b -> [a] -> [b] go ((start,len),_) (gs,vs) = ((start+len,length vs),gs) - spans = fmap (Mask . map (fromIntegral***fromIntegral)) + spans = fmap (foldr (maskPlus . Mask . (:[])) (Mask []) + . map (fromIntegral***fromIntegral)) $ foldr (Map.unionWith (++)) Map.empty $ map singletonSpan rs + singletonSpan (span,gnames) = Map.fromList $ map (, [span]) gnames 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 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 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 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 other-modules: InfinitePlane LambdaCubeWidget GLWidget LambdaCube.Gtk TimeKeeper LoadMesh MtlParser Matrix LambdaCube.GL.HMatrix Animator MeshSketch CubeMap AttributeData GPURing MaskableStream - RingBuffer SmallRing VectorRing Camera Bezier FitCurves Mask + RingBuffer SmallRing VectorRing Camera Bezier FitCurves Mask Data.List.Merge extensions: NondecreasingIndentation other-extensions: OverloadedLabels, OverloadedLists, OverloadedStrings build-depends: base, containers >=0.5 && <0.6, bytestring >=0.10 && <0.11, -- cgit v1.2.3