Skip to content

Commit

Permalink
Add some basic provenance tracking for triangles
Browse files Browse the repository at this point in the history
  • Loading branch information
ryantrinkle committed Feb 7, 2021
1 parent a13d8fb commit 420815d
Show file tree
Hide file tree
Showing 6 changed files with 105 additions and 60 deletions.
26 changes: 25 additions & 1 deletion Graphics/Implicit/Definitions.hs
Expand Up @@ -27,6 +27,8 @@ module Graphics.Implicit.Definitions (
Triangle(Triangle),
NormedTriangle(NormedTriangle),
TriangleMesh(TriangleMesh),
AnnotatedTriangleMesh(AnnotatedTriangleMesh, unAnnotatedTriangleMesh),
TriangleProvenance(..),
NormedTriangleMesh(NormedTriangleMesh),
Obj2,
Obj3,
Expand Down Expand Up @@ -64,12 +66,13 @@ module Graphics.Implicit.Definitions (
toScaleFn,
isScaleID,
quaternionToEuler,
removeTriangleMeshAnnotations,
)
where

import GHC.Generics (Generic)

import Prelude (Ord, Eq, atan2, asin, pi, (>=), signum, abs, (+), (-), RealFloat, (==), ($), flip, Semigroup((<>)), Monoid (mempty), Double, Either(Left, Right), Bool(True, False), (*), (/), fromIntegral, Float, realToFrac)
import Prelude (Ord, Eq, atan2, asin, pi, (>=), signum, abs, (+), (-), RealFloat, (==), ($), flip, Semigroup((<>)), Monoid (mempty), Double, Either(Left, Right), Bool(True, False), (*), (/), fromIntegral, Float, realToFrac, map, fst, Int, seq)

import Graphics.Implicit.FastIntUtil as F (Fastℕ(Fastℕ), fromFastℕ, toFastℕ)

Expand Down Expand Up @@ -162,6 +165,18 @@ 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 [Triangle]

newtype AnnotatedTriangleMesh a = AnnotatedTriangleMesh { unAnnotatedTriangleMesh :: [(Triangle, a)] }

removeTriangleMeshAnnotations :: AnnotatedTriangleMesh a -> TriangleMesh
removeTriangleMeshAnnotations (AnnotatedTriangleMesh l) = TriangleMesh $ map fst l

data TriangleProvenance
= TriangleProvenance_SquareToTri Bool TriangleProvenance
| TriangleProvenance_JoinXAligned TriangleProvenance TriangleProvenance
| TriangleProvenance_JoinYAligned TriangleProvenance TriangleProvenance
| TriangleProvenance_TesselateLoop Int
deriving (Show, Eq, Ord)

-- | A normed triangle mesh is a mesh of normed triangles.
newtype NormedTriangleMesh = NormedTriangleMesh [NormedTriangle]

Expand All @@ -174,6 +189,15 @@ instance NFData Triangle where
instance NFData TriangleMesh where
rnf (TriangleMesh xs) = rnf xs

instance NFData a => NFData (AnnotatedTriangleMesh a) where
rnf (AnnotatedTriangleMesh xs) = rnf xs

instance NFData TriangleProvenance where
rnf (TriangleProvenance_SquareToTri b p) = rnf b `seq` rnf p
rnf (TriangleProvenance_JoinXAligned a b) = rnf a `seq` rnf b
rnf (TriangleProvenance_JoinYAligned a b) = rnf a `seq` rnf b
rnf (TriangleProvenance_TesselateLoop n) = rnf n

instance NFData Polytri where
rnf (Polytri (a,b,c)) = rnf (a,b,c)

Expand Down
11 changes: 8 additions & 3 deletions Graphics/Implicit/Export/Render.hs
Expand Up @@ -6,11 +6,11 @@
{-# LANGUAGE ParallelListComp #-}

-- export getContour and getMesh, which returns the edge of a 2D object, or the surface of a 3D object, respectively.
module Graphics.Implicit.Export.Render (getMesh, getContour) where
module Graphics.Implicit.Export.Render (getMesh, getAnnotatedMesh, getContour) where

import Prelude(error, (-), ceiling, ($), (+), (*), max, div, tail, fmap, reverse, (.), foldMap, min, Int, (<>), (<$>))

import Graphics.Implicit.Definitions (, , Fastℕ, ℝ2, ℝ3, TriangleMesh, Obj2, SymbolicObj2, Obj3, SymbolicObj3, Polyline(Polyline), (⋯/), fromℕtoℝ, fromℕ)
import Graphics.Implicit.Definitions (, , Fastℕ, ℝ2, ℝ3, TriangleMesh, Obj2, SymbolicObj2, Obj3, SymbolicObj3, Polyline(Polyline), (⋯/), fromℕtoℝ, fromℕ, AnnotatedTriangleMesh, removeTriangleMeshAnnotations, TriangleProvenance(..))

import Graphics.Implicit.Export.Symbolic.Rebound2 (rebound2)

Expand All @@ -21,6 +21,8 @@ import Graphics.Implicit.ObjectUtil (getBox2, getBox3)
import Data.Foldable(fold)
import Linear ( V3(V3), V2(V2) )

import GHC.Stack

-- Here's the plan for rendering a cube (the 2D case is trivial):

-- (1) We calculate midpoints using interpolate.
Expand Down Expand Up @@ -75,7 +77,10 @@ import Graphics.Implicit.Primitives (getImplicit)
default (, Fastℕ, )

getMesh :: ℝ3 -> SymbolicObj3 -> TriangleMesh
getMesh res@(V3 xres yres zres) symObj =
getMesh res symObj = removeTriangleMeshAnnotations $ getAnnotatedMesh res symObj

getAnnotatedMesh :: ℝ3 -> SymbolicObj3 -> AnnotatedTriangleMesh TriangleProvenance
getAnnotatedMesh res@(V3 xres yres zres) symObj =
let
-- Grow bounds a little to avoid sampling at exact bounds
(obj, (p1@(V3 x1 y1 z1), p2)) = rebound3 (getImplicit symObj, getBox3 symObj)
Expand Down
13 changes: 11 additions & 2 deletions Graphics/Implicit/Export/Render/Definitions.hs
Expand Up @@ -2,10 +2,12 @@
-- Released under the GNU AGPLV3+, see LICENSE

-- We want a type that can represent squares/quads and triangles.
module Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq)) where
module Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq), AnnotatedTriSquare(AnnotatedSq, AnnotatedTris)) where

import Prelude (seq)

-- Points/Numbers, and the concept of an array of triangles.
import Graphics.Implicit.Definitions(, ℝ2, ℝ3, TriangleMesh)
import Graphics.Implicit.Definitions(, ℝ2, ℝ3, TriangleMesh, AnnotatedTriangleMesh)

-- So we can use Parallel on this type.
import Control.DeepSeq (NFData, rnf)
Expand All @@ -14,7 +16,14 @@ data TriSquare =
Sq (ℝ3,ℝ3,ℝ3) ℝ2 ℝ2
| Tris TriangleMesh

data AnnotatedTriSquare a =
AnnotatedSq (ℝ3,ℝ3,ℝ3) ℝ2 ℝ2 a
| AnnotatedTris (AnnotatedTriangleMesh a)

instance NFData TriSquare where
rnf (Sq b z xS yS) = rnf (b,z,xS,yS)
rnf (Tris tris) = rnf tris

instance NFData a => NFData (AnnotatedTriSquare a) where
rnf (AnnotatedSq b z xS yS a) = rnf (b,z,xS,yS) `seq` rnf a
rnf (AnnotatedTris tris) = rnf tris
66 changes: 33 additions & 33 deletions Graphics/Implicit/Export/Render/HandleSquares.hs
Expand Up @@ -4,11 +4,11 @@

module Graphics.Implicit.Export.Render.HandleSquares (mergedSquareTris) where

import Prelude((+), foldMap, (<>), ($), fmap, concat, (.), (==), compare, error, otherwise, concatMap)
import Prelude((+), foldMap, (<>), ($), fmap, concat, (.), (==), compare, error, otherwise, concatMap, Bool(..))

import Graphics.Implicit.Definitions (TriangleMesh(TriangleMesh), Triangle(Triangle))
import Graphics.Implicit.Definitions (TriangleMesh(TriangleMesh), Triangle(Triangle), AnnotatedTriangleMesh (AnnotatedTriangleMesh, unAnnotatedTriangleMesh), TriangleProvenance(..))

import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq))
import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq), AnnotatedTriSquare(AnnotatedTris, AnnotatedSq))
import Linear ( V2(V2), (*^), (^*) )

import GHC.Exts (groupWith)
Expand Down Expand Up @@ -57,75 +57,75 @@ import Data.List (sortBy)
-}

mergedSquareTris :: [TriSquare] -> TriangleMesh
mergedSquareTris :: [AnnotatedTriSquare TriangleProvenance] -> AnnotatedTriangleMesh TriangleProvenance
mergedSquareTris sqTris =
let
-- We don't need to do any work on triangles. They'll just be part of
-- the list of triangles we give back. So, the triangles coming from
-- triangles...
triTriangles :: [Triangle]
triTriangles = [tri | Tris tris <- sqTris, tri <- unmesh tris ]
triTriangles :: [(Triangle, TriangleProvenance)]
triTriangles = [tri | AnnotatedTris tris <- sqTris, tri <- unAnnotatedTriangleMesh 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 :: [AnnotatedTriSquare TriangleProvenance]
squaresFromTris = [ AnnotatedSq x y z q a | AnnotatedSq x y z q a <- sqTris ]

unmesh (TriangleMesh m) = m

-- Collect squares that are on the same plane.
planeAligned = groupWith (\(Sq basis z _ _) -> (basis,z)) squaresFromTris
planeAligned = groupWith (\(AnnotatedSq basis z _ _ a) -> (basis,z,a)) squaresFromTris
-- For each plane:
-- Select for being the same range on X and then merge them on Y
-- Then vice versa.
joined :: [[TriSquare]]
joined :: [[AnnotatedTriSquare TriangleProvenance]]
joined = fmap
( concatMap joinXaligned . groupWith (\(Sq _ _ xS _) -> xS)
. concatMap joinYaligned . groupWith (\(Sq _ _ _ yS) -> yS)
. concatMap joinXaligned . groupWith (\(Sq _ _ xS _) -> xS))
( concatMap joinXaligned . groupWith (\(AnnotatedSq _ _ xS _ _) -> xS)
. concatMap joinYaligned . groupWith (\(AnnotatedSq _ _ _ yS _) -> yS)
. concatMap joinXaligned . groupWith (\(AnnotatedSq _ _ xS _ _) -> xS))
planeAligned
-- Merge them back together, and we have the desired reult!
finishedSquares = concat joined

in
-- merge them to triangles, and combine with the original triangles.
TriangleMesh $ triTriangles <> foldMap squareToTri finishedSquares
AnnotatedTriangleMesh $ triTriangles <> foldMap squareToTri finishedSquares

-- And now for the helper functions that do the heavy lifting...

joinXaligned :: [TriSquare] -> [TriSquare]
joinXaligned quads@((Sq b z xS _):_) =
joinXaligned :: [AnnotatedTriSquare TriangleProvenance] -> [AnnotatedTriSquare TriangleProvenance]
joinXaligned quads@((AnnotatedSq b z xS _ _):_) =
let
orderedQuads = sortBy
(\(Sq _ _ _ (V2 ya _)) (Sq _ _ _ (V2 yb _)) -> compare ya yb)
(\(AnnotatedSq _ _ _ (V2 ya _) _) (AnnotatedSq _ _ _ (V2 yb _) _) -> compare ya yb)
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 (pres@(AnnotatedSq _ _ _ (V2 y1a y2a) a1) : next@(AnnotatedSq _ _ _ (V2 y1b y2b) a2) : others)
| y2a == y1b = mergeAdjacent (AnnotatedSq b z xS (V2 y1a y2b) (TriangleProvenance_JoinXAligned a1 a2) : others)
| y1a == y2b = mergeAdjacent (AnnotatedSq b z xS (V2 y1b y2a) (TriangleProvenance_JoinXAligned a1 a2) : others)
| otherwise = pres : mergeAdjacent (next : others)
mergeAdjacent a = a
in
mergeAdjacent orderedQuads
joinXaligned (Tris _:_) = error "Tried to join y aligned triangles."
joinXaligned (AnnotatedTris _:_) = error "Tried to join y aligned triangles."
joinXaligned [] = []

joinYaligned :: [TriSquare] -> [TriSquare]
joinYaligned quads@((Sq b z _ yS):_) =
joinYaligned :: [AnnotatedTriSquare TriangleProvenance] -> [AnnotatedTriSquare TriangleProvenance]
joinYaligned quads@((AnnotatedSq b z _ yS _):_) =
let
orderedQuads = sortBy
(\(Sq _ _ (V2 xa _) _) (Sq _ _ (V2 xb _) _) -> compare xa xb)
(\(AnnotatedSq _ _ (V2 xa _) _ _) (AnnotatedSq _ _ (V2 xb _) _ _) -> compare xa xb)
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 (pres@(AnnotatedSq _ _ (V2 x1a x2a) _ a1) : next@(AnnotatedSq _ _ (V2 x1b x2b) _ a2) : others)
| x2a == x1b = mergeAdjacent (AnnotatedSq b z (V2 x1a x2b) yS (TriangleProvenance_JoinYAligned a1 a2) : others)
| x1a == x2b = mergeAdjacent (AnnotatedSq b z (V2 x1b x2a) yS (TriangleProvenance_JoinYAligned a1 a2) : others)
| otherwise = pres : mergeAdjacent (next : others)
mergeAdjacent a = a
in
mergeAdjacent orderedQuads
joinYaligned (Tris _:_) = error "Tried to join y aligned triangles."
joinYaligned (AnnotatedTris _:_) = 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)) =
squareToTri :: AnnotatedTriSquare TriangleProvenance -> [(Triangle, TriangleProvenance)]
squareToTri (AnnotatedSq (b1,b2,b3) z (V2 x1 x2) (V2 y1 y2) ann) =
let
zV = b3 ^* z
(x1V, x2V) = (x1 *^ b1, x2 *^ b1)
Expand All @@ -135,8 +135,8 @@ squareToTri (Sq (b1,b2,b3) z (V2 x1 x2) (V2 y1 y2)) =
c = zV + x1V + y2V
d = zV + x2V + y2V
in
[Triangle (a,b,c), Triangle (c,b,d)]
squareToTri (Tris t) = unmesh t
[(Triangle (a,b,c), TriangleProvenance_SquareToTri False ann), (Triangle (c,b,d), TriangleProvenance_SquareToTri True ann)]
squareToTri (AnnotatedTris t) = unmesh t
where
unmesh (TriangleMesh a) = a
unmesh (AnnotatedTriangleMesh a) = a

22 changes: 11 additions & 11 deletions Graphics/Implicit/Export/Render/TesselateLoops.hs
Expand Up @@ -6,9 +6,9 @@ module Graphics.Implicit.Export.Render.TesselateLoops (tesselateLoop) where

import Prelude(sum, (-), pure, ($), length, (==), zip, init, tail, reverse, (<), (/), null, (<>), head, (*), abs, (>), (&&), (+), foldMap)

import Graphics.Implicit.Definitions (, , Obj3, ℝ3, TriangleMesh(TriangleMesh), Triangle(Triangle))
import Graphics.Implicit.Definitions (, , Obj3, ℝ3, TriangleMesh(TriangleMesh), Triangle(Triangle), AnnotatedTriangleMesh(AnnotatedTriangleMesh), TriangleProvenance(..))

import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris))
import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris), AnnotatedTriSquare(AnnotatedTris))

import Graphics.Implicit.Export.Util (centroid)

Expand All @@ -17,11 +17,11 @@ import Linear ( cross, Metric(norm), (^*), (^/) )

-- de-compose a loop into a series of triangles or squares.
-- FIXME: res should be ℝ3.
tesselateLoop :: -> Obj3 -> [[ℝ3]] -> [TriSquare]
tesselateLoop :: -> Obj3 -> [[ℝ3]] -> [AnnotatedTriSquare TriangleProvenance]

tesselateLoop _ _ [] = []

tesselateLoop _ _ [[a,b],[_,c],[_,_]] = [Tris $ TriangleMesh [Triangle (a,b,c)]]
tesselateLoop _ _ [[a,b],[_,c],[_,_]] = [AnnotatedTris $ AnnotatedTriangleMesh [(Triangle (a,b,c), TriangleProvenance_TesselateLoop 0)]]


{-
Expand Down Expand Up @@ -67,12 +67,12 @@ tesselateLoop _ _ [[a,_],[b,_],[c,_],[d,_]] | centroid [a,c] == centroid [b,d] =
-- | Create a pair of triangles from a quad.
-- FIXME: magic number
tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | obj (centroid [a,c]) < res/30 =
pure $ Tris $ TriangleMesh [Triangle (a,b,c), Triangle (a,c,d)]
pure $ AnnotatedTris $ AnnotatedTriangleMesh [(Triangle (a,b,c), TriangleProvenance_TesselateLoop 1), (Triangle (a,c,d), TriangleProvenance_TesselateLoop 2)]

-- Fallback case: make fans

-- FIXME: magic numbers.
tesselateLoop res obj pathSides = pure $ Tris $ TriangleMesh $
tesselateLoop res obj pathSides = pure $ AnnotatedTris $ AnnotatedTriangleMesh $
let
path' = foldMap init pathSides
(early_tris,path) = shrinkLoop 0 path' res obj
Expand All @@ -89,16 +89,16 @@ tesselateLoop res obj pathSides = pure $ Tris $ TriangleMesh $
mid' = mid - normal ^* (midval/deriv)
midval' = obj mid'
in if abs midval' < abs midval
then early_tris <> [Triangle (a,b,mid') | (a,b) <- zip path (tail path <> [head path]) ]
else early_tris <> [Triangle (a,b,mid) | (a,b) <- zip path (tail path <> [head path]) ]
then early_tris <> [(Triangle (a,b,mid'), TriangleProvenance_TesselateLoop 3) | (a,b) <- zip path (tail path <> [head path]) ]
else early_tris <> [(Triangle (a,b,mid), TriangleProvenance_TesselateLoop 4) | (a,b) <- zip path (tail path <> [head path]) ]


shrinkLoop :: -> [ℝ3] -> -> Obj3 -> ([Triangle], [ℝ3])
shrinkLoop :: -> [ℝ3] -> -> Obj3 -> ([(Triangle, TriangleProvenance)], [ℝ3])

shrinkLoop _ path@[a,b,c] res obj =
if abs (obj $ centroid [a,b,c]) < res/50
then
( [Triangle (a,b,c)], [])
( [(Triangle (a,b,c), TriangleProvenance_TesselateLoop 5)], [])
else
([], path)

Expand All @@ -107,7 +107,7 @@ shrinkLoop n path@(a:b:c:xs) res obj | n < genericLength path =
if abs (obj (centroid [a,c])) < res/50
then
let (tris,remainder) = shrinkLoop 0 (a:c:xs) res obj
in (Triangle (a,b,c):tris, remainder)
in ((Triangle (a,b,c), TriangleProvenance_TesselateLoop 6):tris, remainder)
else
shrinkLoop (n+1) (b:c:xs <> [a]) res obj

Expand Down
27 changes: 17 additions & 10 deletions Graphics/Implicit/Export/SymbolicObj3.hs
Expand Up @@ -5,19 +5,26 @@
-- The purpose of this function is to symbolicaly compute triangle meshes using the symbolic system where possible.
-- Otherwise we coerce it into an implicit function and apply our modified marching cubes algorithm.

module Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh) where
module Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh, symbolicGetAnnotatedMesh) where

import Prelude(pure, zip, length, filter, (>), ($), null, (<>), foldMap, (.), (<$>))
import Prelude(pure, zip, length, filter, (>), ($), null, (<>), foldMap, (.), (<$>), unlines, zipWith, show, map, snd)

import Graphics.Implicit.Definitions (, ℝ3, SymbolicObj3(Shared3), SharedObj(UnionR), Triangle, TriangleMesh(TriangleMesh))
import Graphics.Implicit.Export.Render (getMesh)
import Graphics.Implicit.Definitions (, ℝ3, SymbolicObj3(Shared3), SharedObj(UnionR), Triangle, TriangleMesh(TriangleMesh), AnnotatedTriangleMesh(AnnotatedTriangleMesh,unAnnotatedTriangleMesh), removeTriangleMeshAnnotations, TriangleProvenance)
import Graphics.Implicit.Export.Render (getAnnotatedMesh)
import Graphics.Implicit.ObjectUtil (getBox3)
import Graphics.Implicit.MathUtil(box3sWithin)

import Control.Arrow(first, second)

import Debug.Trace

symbolicGetMesh :: -> SymbolicObj3 -> TriangleMesh
symbolicGetMesh res inputObj@(Shared3 (UnionR r objs)) = TriangleMesh $
symbolicGetMesh res inputObj = removeTriangleMeshAnnotations $ trace annotations mesh
where mesh = symbolicGetAnnotatedMesh res inputObj
annotations = unlines $ zipWith (\n a -> show n <> "\t" <> show a) [1..] $ map snd $ unAnnotatedTriangleMesh mesh

symbolicGetAnnotatedMesh :: -> SymbolicObj3 -> AnnotatedTriangleMesh TriangleProvenance
symbolicGetAnnotatedMesh res inputObj@(Shared3 (UnionR r objs)) = AnnotatedTriangleMesh $
let
boxes = getBox3 <$> objs
boxedObjs = zip boxes objs
Expand All @@ -31,14 +38,14 @@ symbolicGetMesh res inputObj@(Shared3 (UnionR r objs)) = TriangleMesh $

(dependants, independents) = sepFree boxedObjs
in if null independents
then unmesh $ getMesh (pure res) inputObj
then unAnnotatedTriangleMesh $ getAnnotatedMesh (pure res) inputObj
else if null dependants
then foldMap (unmesh . symbolicGetMesh res) independents
else foldMap (unmesh . symbolicGetMesh res) independents
<> unmesh (symbolicGetMesh res (Shared3 (UnionR r dependants)))
then foldMap (unAnnotatedTriangleMesh . symbolicGetAnnotatedMesh res) independents
else foldMap (unAnnotatedTriangleMesh . symbolicGetAnnotatedMesh res) independents
<> unAnnotatedTriangleMesh (symbolicGetAnnotatedMesh res (Shared3 (UnionR r dependants)))

-- | If all that fails, coerce and apply marching cubes :(
symbolicGetMesh res obj = getMesh (pure res) obj
symbolicGetAnnotatedMesh res obj = getAnnotatedMesh (pure res) obj

unmesh :: TriangleMesh -> [Triangle]
unmesh (TriangleMesh m) = m

0 comments on commit 420815d

Please sign in to comment.