44
55module Graphics.Implicit.Export.Render.HandleSquares (mergedSquareTris ) where
66
7- import Prelude ((+) , foldMap , (<>) , ($) , fmap , concat , (.) , (==) , compare , error , otherwise , concatMap )
7+ import Prelude ((+) , foldMap , (<>) , ($) , fmap , concat , (.) , (==) , compare , error , otherwise , concatMap , Bool ( .. ) )
88
9- import Graphics.Implicit.Definitions (TriangleMesh (TriangleMesh ), Triangle (Triangle ))
9+ import Graphics.Implicit.Definitions (TriangleMesh (TriangleMesh ), Triangle (Triangle ), AnnotatedTriangleMesh ( AnnotatedTriangleMesh , unAnnotatedTriangleMesh ), TriangleProvenance ( .. ) )
1010
11- import Graphics.Implicit.Export.Render.Definitions (TriSquare (Tris , Sq ))
11+ import Graphics.Implicit.Export.Render.Definitions (TriSquare (Tris , Sq ), AnnotatedTriSquare ( AnnotatedTris , AnnotatedSq ) )
1212import Linear ( V2 (V2 ), (*^) , (^*) )
1313
1414import GHC.Exts (groupWith )
@@ -57,75 +57,75 @@ import Data.List (sortBy)
5757
5858-}
5959
60- mergedSquareTris :: [TriSquare ] -> TriangleMesh
60+ mergedSquareTris :: [AnnotatedTriSquare TriangleProvenance ] -> AnnotatedTriangleMesh TriangleProvenance
6161mergedSquareTris sqTris =
6262 let
6363 -- We don't need to do any work on triangles. They'll just be part of
6464 -- the list of triangles we give back. So, the triangles coming from
6565 -- triangles...
66- triTriangles :: [Triangle ]
67- triTriangles = [tri | Tris tris <- sqTris, tri <- unmesh tris ]
66+ triTriangles :: [( Triangle , TriangleProvenance ) ]
67+ triTriangles = [tri | AnnotatedTris tris <- sqTris, tri <- unAnnotatedTriangleMesh tris ]
6868 -- We actually want to work on the quads, so we find those
69- squaresFromTris :: [TriSquare ]
70- squaresFromTris = [ Sq x y z q | Sq x y z q <- sqTris ]
69+ squaresFromTris :: [AnnotatedTriSquare TriangleProvenance ]
70+ squaresFromTris = [ AnnotatedSq x y z q a | AnnotatedSq x y z q a <- sqTris ]
7171
7272 unmesh (TriangleMesh m) = m
7373
7474 -- Collect squares that are on the same plane.
75- planeAligned = groupWith (\ (Sq basis z _ _) -> (basis,z)) squaresFromTris
75+ planeAligned = groupWith (\ (AnnotatedSq basis z _ _ a ) -> (basis,z,a )) squaresFromTris
7676 -- For each plane:
7777 -- Select for being the same range on X and then merge them on Y
7878 -- Then vice versa.
79- joined :: [[TriSquare ]]
79+ joined :: [[AnnotatedTriSquare TriangleProvenance ]]
8080 joined = fmap
81- ( concatMap joinXaligned . groupWith (\ (Sq _ _ xS _) -> xS)
82- . concatMap joinYaligned . groupWith (\ (Sq _ _ _ yS) -> yS)
83- . concatMap joinXaligned . groupWith (\ (Sq _ _ xS _) -> xS))
81+ ( concatMap joinXaligned . groupWith (\ (AnnotatedSq _ _ xS _ _) -> xS)
82+ . concatMap joinYaligned . groupWith (\ (AnnotatedSq _ _ _ yS _ ) -> yS)
83+ . concatMap joinXaligned . groupWith (\ (AnnotatedSq _ _ xS _ _) -> xS))
8484 planeAligned
8585 -- Merge them back together, and we have the desired reult!
8686 finishedSquares = concat joined
8787
8888 in
8989 -- merge them to triangles, and combine with the original triangles.
90- TriangleMesh $ triTriangles <> foldMap squareToTri finishedSquares
90+ AnnotatedTriangleMesh $ triTriangles <> foldMap squareToTri finishedSquares
9191
9292-- And now for the helper functions that do the heavy lifting...
9393
94- joinXaligned :: [TriSquare ] -> [TriSquare ]
95- joinXaligned quads@ ((Sq b z xS _): _) =
94+ joinXaligned :: [AnnotatedTriSquare TriangleProvenance ] -> [AnnotatedTriSquare TriangleProvenance ]
95+ joinXaligned quads@ ((AnnotatedSq b z xS _ _): _) =
9696 let
9797 orderedQuads = sortBy
98- (\ (Sq _ _ _ (V2 ya _)) (Sq _ _ _ (V2 yb _)) -> compare ya yb)
98+ (\ (AnnotatedSq _ _ _ (V2 ya _) _ ) (AnnotatedSq _ _ _ (V2 yb _) _ ) -> compare ya yb)
9999 quads
100- mergeAdjacent (pres@ (Sq _ _ _ (V2 y1a y2a)) : next@ (Sq _ _ _ (V2 y1b y2b)) : others)
101- | y2a == y1b = mergeAdjacent (Sq b z xS (V2 y1a y2b) : others)
102- | y1a == y2b = mergeAdjacent (Sq b z xS (V2 y1b y2a) : others)
100+ mergeAdjacent (pres@ (AnnotatedSq _ _ _ (V2 y1a y2a) a1 ) : next@ (AnnotatedSq _ _ _ (V2 y1b y2b) a2 ) : others)
101+ | y2a == y1b = mergeAdjacent (AnnotatedSq b z xS (V2 y1a y2b) ( TriangleProvenance_JoinXAligned a1 a2 ) : others)
102+ | y1a == y2b = mergeAdjacent (AnnotatedSq b z xS (V2 y1b y2a) ( TriangleProvenance_JoinXAligned a1 a2 ) : others)
103103 | otherwise = pres : mergeAdjacent (next : others)
104104 mergeAdjacent a = a
105105 in
106106 mergeAdjacent orderedQuads
107- joinXaligned (Tris _: _) = error " Tried to join y aligned triangles."
107+ joinXaligned (AnnotatedTris _: _) = error " Tried to join y aligned triangles."
108108joinXaligned [] = []
109109
110- joinYaligned :: [TriSquare ] -> [TriSquare ]
111- joinYaligned quads@ ((Sq b z _ yS): _) =
110+ joinYaligned :: [AnnotatedTriSquare TriangleProvenance ] -> [AnnotatedTriSquare TriangleProvenance ]
111+ joinYaligned quads@ ((AnnotatedSq b z _ yS _ ): _) =
112112 let
113113 orderedQuads = sortBy
114- (\ (Sq _ _ (V2 xa _) _) (Sq _ _ (V2 xb _) _) -> compare xa xb)
114+ (\ (AnnotatedSq _ _ (V2 xa _) _ _ ) (AnnotatedSq _ _ (V2 xb _) _ _) -> compare xa xb)
115115 quads
116- mergeAdjacent (pres@ (Sq _ _ (V2 x1a x2a) _) : next@ (Sq _ _ (V2 x1b x2b) _) : others)
117- | x2a == x1b = mergeAdjacent (Sq b z (V2 x1a x2b) yS : others)
118- | x1a == x2b = mergeAdjacent (Sq b z (V2 x1b x2a) yS : others)
116+ mergeAdjacent (pres@ (AnnotatedSq _ _ (V2 x1a x2a) _ a1 ) : next@ (AnnotatedSq _ _ (V2 x1b x2b) _ a2 ) : others)
117+ | x2a == x1b = mergeAdjacent (AnnotatedSq b z (V2 x1a x2b) yS ( TriangleProvenance_JoinYAligned a1 a2) : others)
118+ | x1a == x2b = mergeAdjacent (AnnotatedSq b z (V2 x1b x2a) yS ( TriangleProvenance_JoinYAligned a1 a2) : others)
119119 | otherwise = pres : mergeAdjacent (next : others)
120120 mergeAdjacent a = a
121121 in
122122 mergeAdjacent orderedQuads
123- joinYaligned (Tris _: _) = error " Tried to join y aligned triangles."
123+ joinYaligned (AnnotatedTris _: _) = error " Tried to join y aligned triangles."
124124joinYaligned [] = []
125125
126126-- Deconstruct a square into two triangles.
127- squareToTri :: TriSquare -> [Triangle ]
128- squareToTri (Sq (b1,b2,b3) z (V2 x1 x2) (V2 y1 y2)) =
127+ squareToTri :: AnnotatedTriSquare TriangleProvenance -> [( Triangle , TriangleProvenance ) ]
128+ squareToTri (AnnotatedSq (b1,b2,b3) z (V2 x1 x2) (V2 y1 y2) ann ) =
129129 let
130130 zV = b3 ^* z
131131 (x1V, x2V) = (x1 *^ b1, x2 *^ b1)
@@ -135,8 +135,8 @@ squareToTri (Sq (b1,b2,b3) z (V2 x1 x2) (V2 y1 y2)) =
135135 c = zV + x1V + y2V
136136 d = zV + x2V + y2V
137137 in
138- [Triangle (a,b,c), Triangle (c,b,d)]
139- squareToTri (Tris t) = unmesh t
138+ [( Triangle (a,b,c), TriangleProvenance_SquareToTri False ann), ( Triangle (c,b,d), TriangleProvenance_SquareToTri True ann )]
139+ squareToTri (AnnotatedTris t) = unmesh t
140140 where
141- unmesh (TriangleMesh a) = a
141+ unmesh (AnnotatedTriangleMesh a) = a
142142
0 commit comments