Merge some squares

Graphics/Implicit/Definitions.hs

@@ -177,13 +177,15 @@ newtype Polytri = Polytri (ℝ2, ℝ2, ℝ2)
 
 -- | A triangle in 3D space (a,b,c) = a triangle with vertices a, b and c
 newtype Triangle = Triangle (ℝ3, ℝ3, ℝ3)
+  deriving (Show, Eq)
 
 -- | A triangle ((v1,n1),(v2,n2),(v3,n3)) has vertices v1, v2, v3
 --   with corresponding normals n1, n2, and n3
 newtype NormedTriangle = NormedTriangle ((ℝ3, ℝ3), (ℝ3, ℝ3), (ℝ3, ℝ3))
 
 -- | A triangle mesh is a bunch of triangles, attempting to be a surface.
 newtype TriangleMesh = TriangleMesh { getTriangles :: [Triangle] }
+  deriving (Show, Eq)
 
 -- | A normed triangle mesh is a mesh of normed triangles.
 newtype NormedTriangleMesh = NormedTriangleMesh { getNormedTriangles :: [NormedTriangle] }

Graphics/Implicit/Export/Render/Definitions.hs

@@ -4,17 +4,25 @@
 -- We want a type that can represent squares/quads and triangles.
 module Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq)) where
 
+import Prelude (Show, Eq)
+
 -- Points/Numbers, and the concept of an array of triangles.
 import Graphics.Implicit.Definitions(ℝ, ℝ2, ℝ3, TriangleMesh)
 
 -- So we can use Parallel on this type.
 import Control.DeepSeq (NFData, rnf)
 
 data TriSquare =
-      Sq (ℝ3,ℝ3,ℝ3) ℝ ℝ2 ℝ2
+      Sq {
+           _basis :: (ℝ3,ℝ3,ℝ3)
+         , _zOffset :: ℝ
+         , _xInterval :: ℝ2
+         , _yInterval :: ℝ2
+         , _origCoords :: (ℝ3,ℝ3,ℝ3,ℝ3)}
     | Tris TriangleMesh
+  deriving (Show, Eq)
 
 instance NFData TriSquare where
-    rnf (Sq b z xS yS) = rnf (b,z,xS,yS)
+    rnf (Sq b z xS yS coords) = rnf (b,z,xS,yS,coords)
     rnf (Tris tris) = rnf tris
 

Graphics/Implicit/Export/Render/HandleSquares.hs

@@ -6,19 +6,20 @@
 
 module Graphics.Implicit.Export.Render.HandleSquares (mergedSquareTris) where
 
-import Prelude((+), foldMap, (<>), ($), fmap, concat, (.), (==), compare, error, otherwise, concatMap)
+import Prelude(abs, show, until, (<$>), (&&), (-), (<), foldMap, (<>), ($), concat, (.), (==), compare, error, otherwise, concatMap)
 
-import Graphics.Implicit.Definitions (TriangleMesh(TriangleMesh, getTriangles), Triangle(Triangle))
+import Graphics.Implicit.Definitions (ℝ, TriangleMesh(TriangleMesh, getTriangles), Triangle(Triangle))
 
 import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq))
-import Linear ( V2(V2), (*^), (^*) )
+
+-- Our linear algebra library.
+import Linear (distance, V2(V2))
 
 import GHC.Exts (groupWith)
 import Data.List (sortBy)
 
--- We want small meshes. Essential to this, is getting rid of triangles.
--- We specifically mark quads in tesselation (refer to Graphics.Implicit.
--- Export.Render.Definitions, Graphics.Implicit.Export.Render.TesselateLoops)
+-- We want small meshes. Essential to accomplishing this, is getting rid of triangles.
+-- We specifically mark quads in tesselation (refer to Graphics.Implicit.Export.Render.Definitions, Graphics.Implicit.Export.Render.TesselateLoops)
 -- So that we can try and merge them together.
 
 {- Core idea of mergedSquareTris:
@@ -69,96 +70,89 @@ mergedSquareTris sqTris =
         triTriangles = [tri | Tris tris <- sqTris, tri <- getTriangles tris ]
         -- We actually want to work on the quads, so we find those
         squaresFromTris :: [TriSquare]
-        squaresFromTris = [ Sq x y z q | Sq x y z q <- sqTris ]
+        squaresFromTris = [ Sq x y z q p | Sq x y z q p <- sqTris ]
 
         -- Collect squares that are on the same plane.
         planeAligned = groupWith
           (\case
-            (Sq basis z _ _) -> (basis,z)
+            (Sq basis z _ _ _) -> (basis,z)
             (Tris _) -> error "Unexpected Tris"
           ) squaresFromTris
 
         -- For each plane:
         -- Select for being the same range on X and then merge them on Y
-        -- Then vice versa.
-        joined :: [[TriSquare]]
-        joined = fmap
-            ( concatMap joinXaligned . groupWith
-                (\case
-                  (Sq _ _ xS _) -> xS
-                  (Tris _) -> error "Unexpected Tris"
-                )
-            . concatMap joinYaligned . groupWith
-                (\case
-                  (Sq _ _ _ yS) -> yS
-                  (Tris _) -> error "Unexpected Tris"
-                )
-            . concatMap joinXaligned . groupWith
-                (\case
-                  (Sq _ _ xS _) -> xS
-                  (Tris _) -> error "Unexpected Tris"
-                )
-            )
-            planeAligned
+        -- Then repeat.
+        finishedSquares :: [TriSquare]
+        finishedSquares = concat $ until (\xs -> attemptJoin xs == xs) attemptJoin <$> planeAligned
         -- Merge them back together, and we have the desired reult!
-        finishedSquares = concat joined
-
+        attemptJoin :: [TriSquare] -> [TriSquare]
+        attemptJoin = concatMap joinYaligned . groupWith
+                      (\case
+                          (Sq _ _ _ yS _) -> yS
+                          (Tris _) -> error "Unexpected Tris"
+                      )
+                      . concatMap joinXaligned . groupWith
+                      (\case
+                          (Sq _ _ xS _ _) -> xS
+                          (Tris _) -> error "Unexpected Tris"
+                      )
     in
         -- merge them to triangles, and combine with the original triangles.
         TriangleMesh $ triTriangles <> foldMap squareToTri finishedSquares
 
--- And now for the helper functions that do the heavy lifting...
-
+-- Join two X aligned squares.
 joinXaligned :: [TriSquare] -> [TriSquare]
-joinXaligned quads@((Sq b z xS _):_) =
-    let
+joinXaligned quads@((Sq b z xS _ _):_) = mergeAdjacent orderedQuads
+  where
         orderedQuads = sortBy
             (\i j -> case (i, j) of
-                (Sq _ _ _ (V2 ya _), Sq _ _ _ (V2 yb _)) -> compare ya yb
+                (Sq _ _ _ (V2 ya _) _, Sq _ _ _ (V2 yb _) _) -> compare ya yb
                 _ -> error "Unexpected Tris"
             )
             quads
-        mergeAdjacent (pres@(Sq _ _ _ (V2 y1a y2a)) : next@(Sq _ _ _ (V2 y1b y2b)) : others)
-          | y2a == y1b = mergeAdjacent (Sq b z xS (V2 y1a y2b) : others)
-          | y1a == y2b = mergeAdjacent (Sq b z xS (V2 y1b y2a) : others)
+        mergeAdjacent :: [TriSquare] -> [TriSquare]
+        mergeAdjacent (pres@(Sq _ _ _ (V2 y1a y2a) (pa1, pa2, pa3, pa4)) : next@(Sq _ _ _ (V2 y1b y2b) (pb1, pb2, pb3, pb4)) : others)
+            -- Merge two squares, sharing an edge, with approximately the same angle.
+          | y2a ~= y1b && pa3 .= pb2 && pa4 .= pb1 = mergeAdjacent (Sq b z xS (V2 y1a y2b) (pa1, pa2, pb3, pb4) : others)
+          -- Note: we used to have two cases here, was the other one just not needed?
+          | y1a ~= y2b = error $ "Other path chosen.\n" <> show pres <> "\n" <> show next <> "\n"
           | otherwise  = pres : mergeAdjacent (next : others)
+          where
+            (~=) v w = abs (v-w) < eps
+            (.=) v w = distance v w < eps
+            eps :: ℝ
+            eps = 1e-6
         mergeAdjacent a = a
-    in
-        mergeAdjacent orderedQuads
 joinXaligned (Tris _:_) = error "Tried to join y aligned triangles."
 joinXaligned [] = []
 
+-- Join two Y aligned squares.
 joinYaligned :: [TriSquare] -> [TriSquare]
-joinYaligned quads@((Sq b z _ yS):_) =
-    let
+joinYaligned quads@((Sq b z _ yS _):_) = mergeAdjacent orderedQuads
+  where
         orderedQuads = sortBy
             (\i j -> case (i, j) of
-                (Sq _ _ (V2 xa _) _, Sq _ _ (V2 xb _) _) -> compare xa xb
+                (Sq _ _ (V2 xa _) _ _, Sq _ _ (V2 xb _) _ _) -> compare xa xb
                 _ -> error "Unexpected Tris"
             )
             quads
-        mergeAdjacent (pres@(Sq _ _ (V2 x1a x2a) _) : next@(Sq _ _ (V2 x1b x2b) _) : others)
-          | x2a == x1b = mergeAdjacent (Sq b z (V2 x1a x2b) yS : others)
-          | x1a == x2b = mergeAdjacent (Sq b z (V2 x1b x2a) yS : others)
+        mergeAdjacent :: [TriSquare] -> [TriSquare]
+        mergeAdjacent (pres@(Sq _ _ (V2 x1a x2a) _ (pa1, pa2, pa3, pa4)) : next@(Sq _ _ (V2 x1b x2b) _ (pb1, pb2, pb3, pb4)) : others)
+          -- Note: we used to have two cases here, was the other one just not needed?
+          | x2a ~= x1b && pa1 .= pb2 && pb3 .= pa4 = mergeAdjacent (Sq b z (V2 x1a x2b) yS (pb1, pa2, pa3, pb4) : others)
+          | x1a ~= x2b = error $ "Other path chosen.\n" <> show pres <> "\n" <> show next <> "\n"
           | otherwise  = pres : mergeAdjacent (next : others)
+          where
+            (~=) v w = abs (v-w) < eps
+            (.=) v w = distance v w < eps
+            eps :: ℝ
+            eps = 1e-6
         mergeAdjacent a = a
-    in
-        mergeAdjacent orderedQuads
 joinYaligned (Tris _:_) = error "Tried to join y aligned triangles."
 joinYaligned [] = []
 
 -- Deconstruct a square into two triangles.
 squareToTri :: TriSquare -> [Triangle]
-squareToTri (Sq (b1,b2,b3) z (V2 x1 x2) (V2 y1 y2)) =
-    let
-        zV = b3 ^* z
-        (x1V, x2V) = (x1 *^ b1, x2 *^ b1)
-        (y1V, y2V) = (y1 *^ b2, y2 *^ b2)
-        a = zV + x1V + y1V
-        b = zV + x2V + y1V
-        c = zV + x1V + y2V
-        d = zV + x2V + y2V
-    in
-        [Triangle (a,b,c), Triangle (c,b,d)]
+squareToTri (Sq _ _ _ _ (a,b,c,d)) = [Triangle (a,b,c), Triangle (a,c,d)]
 squareToTri (Tris t) = getTriangles t
 

Graphics/Implicit/Export/Render/TesselateLoops.hs

@@ -4,16 +4,16 @@
 
 module Graphics.Implicit.Export.Render.TesselateLoops (tesselateLoop) where
 
-import Prelude(sum, (-), pure, ($), length, (==), zip, init, reverse, (<), (/), null, (<>), (*), abs, (+), foldMap, (&&), drop, Int)
+import Prelude(max, min, sum, (-), pure, ($), length, (==), zip, init, reverse, (<), (<=), (/), null, (<>), (*), abs, (+), foldMap, (&&), drop, Int)
 
 import Graphics.Implicit.Definitions (ℝ, ℕ, Obj3, ℝ3, TriangleMesh(TriangleMesh), Triangle(Triangle))
 
-import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris))
+import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris,Sq))
 
 import Graphics.Implicit.Export.Util (centroid)
 
 import Data.List (genericLength)
-import Linear ( cross, Metric(norm), (^*), (^/) )
+import Linear ( cross, dot, normalize, quadrance, Metric(norm), (^*), (^/), V2(V2))
 
 tail :: [a] -> [a]
 tail = drop 1
@@ -46,20 +46,33 @@ tesselateLoop res obj [as@(_:_:_:_),[_,_], bs@(_:_:_:_), [_,_] ] | length as ==
 
 {-
    #__#
-   |  |  -> if parallegram then quad
+   |  |  -> if we find a rectangle then construct a quad.
    #__#
 -}
-
--- FIXME: this function is definately broken, resulting in floating squares. see https://github.com/colah/ImplicitCAD/issues/98
-
-{-
-tesselateLoop _ _ [[a,_],[b,_],[c,_],[d,_]] | centroid [a,c] == centroid [b,d] =
-    let
-        b1 = normalized $ a - b
-        b2 = normalized $ c - b
-        b3 = b1 `cross3` b2
-    in [Sq (b1,b2,b3) (a ⋅ b3) (a ⋅ b1, c ⋅ b1) (a ⋅ b2, c ⋅ b2) ]
--}
+tesselateLoop _ _ [[a,_],[b,_],[c,_],[d,_]] | centroid [a,c] ~= centroid [b,d] = [Sq (b1,b2,b3) z xR yR (a,b,c,d)]
+  where
+    -- Basis vectors.
+    b1 = normalize $ a - b
+    -- Note: We re-reflect B2 against B3 here to ensure it's perpendicular to B1. This is to encourage matches, and work around floating point error.
+    b2 = normalize $ b3u `cross` b1
+    b3u = normalize $ b1 `cross` b2r
+    -- The un-reflected b2
+    b2r = c - b
+    b3 = normalize $ b1 `cross` b2
+    -- Z height
+    z = a `dot` b3
+    -- Ranges of surface covered by square
+    xR = V2 (min x1 x2) (max x1 x2)
+    yR = V2 (min y1 y2) (max y1 y2)
+    x1 = a `dot` b1
+    x2 = c `dot` b1
+    y1 = a `dot` b2
+    y2 = c `dot` b2
+    -- Equivalency checking for our center position of the two lines segments crossing the (hopefully) parallelogram.
+    (~=) u v = quadrance (u - v) <= eps
+    -- Our fudge factor.
+    eps :: ℝ
+    eps = 1e-8
 
 {-
    #__#      #__#