{- ORMOLU_DISABLE -}
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)
-- Released under the GNU AGPLV3+, see LICENSE

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

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

import Graphics.Implicit.Definitions (TriangleMesh(TriangleMesh, getTriangles), Triangle(Triangle))

import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq))
import Linear ( 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)
-- So that we can try and merge them together.

{- Core idea of mergedSquareTris:

  Many Quads on Plane
   ____________
  |    |    |  |
  |____|____|  |
  |____|____|__|

   | joinXaligned
   v
   ____________
  |         |  |
  |_________|__|
  |_________|__|

   | joinYaligned
   v
   ____________
  |         |  |
  |         |  |
  |_________|__|

   | joinXaligned
   v
   ____________
  |            |
  |            |
  |____________|

   | squareToTri
   v
   ____________
  |\           |
  | ---------- |
  |___________\|

-}

mergedSquareTris :: [TriSquare] -> TriangleMesh
mergedSquareTris :: [TriSquare] -> TriangleMesh
mergedSquareTris [TriSquare]
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 :: [Triangle]
triTriangles = [Triangle
tri | Tris TriangleMesh
tris <- [TriSquare]
sqTris, Triangle
tri <- TriangleMesh -> [Triangle]
getTriangles TriangleMesh
tris ]
        -- We actually want to work on the quads, so we find those
        squaresFromTris :: [TriSquare]
        squaresFromTris :: [TriSquare]
squaresFromTris = [ (ℝ3, ℝ3, ℝ3) -> ℝ -> ℝ2 -> ℝ2 -> TriSquare
Sq (ℝ3, ℝ3, ℝ3)
x ℝ
y ℝ2
z ℝ2
q | Sq (ℝ3, ℝ3, ℝ3)
x ℝ
y ℝ2
z ℝ2
q <- [TriSquare]
sqTris ]

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

    in
        -- merge them to triangles, and combine with the original triangles.
        [Triangle] -> TriangleMesh
TriangleMesh ([Triangle] -> TriangleMesh) -> [Triangle] -> TriangleMesh
forall a b. (a -> b) -> a -> b
$ [Triangle]
triTriangles [Triangle] -> [Triangle] -> [Triangle]
forall a. Semigroup a => a -> a -> a
<> (TriSquare -> [Triangle]) -> [TriSquare] -> [Triangle]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TriSquare -> [Triangle]
squareToTri [TriSquare]
finishedSquares

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

joinXaligned :: [TriSquare] -> [TriSquare]
joinXaligned :: [TriSquare] -> [TriSquare]
joinXaligned quads :: [TriSquare]
quads@((Sq (ℝ3, ℝ3, ℝ3)
b ℝ
z ℝ2
xS ℝ2
_):[TriSquare]
_) =
    let
        orderedQuads :: [TriSquare]
orderedQuads = (TriSquare -> TriSquare -> Ordering) -> [TriSquare] -> [TriSquare]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy
            (\(Sq (ℝ3, ℝ3, ℝ3)
_ ℝ
_ ℝ2
_ (V2 ℝ
ya ℝ
_)) (Sq (ℝ3, ℝ3, ℝ3)
_ ℝ
_ ℝ2
_ (V2 ℝ
yb ℝ
_)) -> ℝ -> ℝ -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ℝ
ya ℝ
yb)
            [TriSquare]
quads
        mergeAdjacent :: [TriSquare] -> [TriSquare]
mergeAdjacent (pres :: TriSquare
pres@(Sq (ℝ3, ℝ3, ℝ3)
_ ℝ
_ ℝ2
_ (V2 ℝ
y1a ℝ
y2a)) : next :: TriSquare
next@(Sq (ℝ3, ℝ3, ℝ3)
_ ℝ
_ ℝ2
_ (V2 ℝ
y1b ℝ
y2b)) : [TriSquare]
others)
          | ℝ
y2a ℝ -> ℝ -> Bool
forall a. Eq a => a -> a -> Bool
== ℝ
y1b = [TriSquare] -> [TriSquare]
mergeAdjacent ((ℝ3, ℝ3, ℝ3) -> ℝ -> ℝ2 -> ℝ2 -> TriSquare
Sq (ℝ3, ℝ3, ℝ3)
b ℝ
z ℝ2
xS (ℝ -> ℝ -> ℝ2
forall a. a -> a -> V2 a
V2 ℝ
y1a ℝ
y2b) TriSquare -> [TriSquare] -> [TriSquare]
forall a. a -> [a] -> [a]
: [TriSquare]
others)
          | ℝ
y1a ℝ -> ℝ -> Bool
forall a. Eq a => a -> a -> Bool
== ℝ
y2b = [TriSquare] -> [TriSquare]
mergeAdjacent ((ℝ3, ℝ3, ℝ3) -> ℝ -> ℝ2 -> ℝ2 -> TriSquare
Sq (ℝ3, ℝ3, ℝ3)
b ℝ
z ℝ2
xS (ℝ -> ℝ -> ℝ2
forall a. a -> a -> V2 a
V2 ℝ
y1b ℝ
y2a) TriSquare -> [TriSquare] -> [TriSquare]
forall a. a -> [a] -> [a]
: [TriSquare]
others)
          | Bool
otherwise  = TriSquare
pres TriSquare -> [TriSquare] -> [TriSquare]
forall a. a -> [a] -> [a]
: [TriSquare] -> [TriSquare]
mergeAdjacent (TriSquare
next TriSquare -> [TriSquare] -> [TriSquare]
forall a. a -> [a] -> [a]
: [TriSquare]
others)
        mergeAdjacent [TriSquare]
a = [TriSquare]
a
    in
        [TriSquare] -> [TriSquare]
mergeAdjacent [TriSquare]
orderedQuads
joinXaligned (Tris TriangleMesh
_:[TriSquare]
_) = [Char] -> [TriSquare]
forall a. HasCallStack => [Char] -> a
error [Char]
"Tried to join y aligned triangles."
joinXaligned [] = []

joinYaligned :: [TriSquare] -> [TriSquare]
joinYaligned :: [TriSquare] -> [TriSquare]
joinYaligned quads :: [TriSquare]
quads@((Sq (ℝ3, ℝ3, ℝ3)
b ℝ
z ℝ2
_ ℝ2
yS):[TriSquare]
_) =
    let
        orderedQuads :: [TriSquare]
orderedQuads = (TriSquare -> TriSquare -> Ordering) -> [TriSquare] -> [TriSquare]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy
            (\(Sq (ℝ3, ℝ3, ℝ3)
_ ℝ
_ (V2 ℝ
xa ℝ
_) ℝ2
_) (Sq (ℝ3, ℝ3, ℝ3)
_ ℝ
_ (V2 ℝ
xb ℝ
_) ℝ2
_) -> ℝ -> ℝ -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ℝ
xa ℝ
xb)
            [TriSquare]
quads
        mergeAdjacent :: [TriSquare] -> [TriSquare]
mergeAdjacent (pres :: TriSquare
pres@(Sq (ℝ3, ℝ3, ℝ3)
_ ℝ
_ (V2 ℝ
x1a ℝ
x2a) ℝ2
_) : next :: TriSquare
next@(Sq (ℝ3, ℝ3, ℝ3)
_ ℝ
_ (V2 ℝ
x1b ℝ
x2b) ℝ2
_) : [TriSquare]
others)
          | ℝ
x2a ℝ -> ℝ -> Bool
forall a. Eq a => a -> a -> Bool
== ℝ
x1b = [TriSquare] -> [TriSquare]
mergeAdjacent ((ℝ3, ℝ3, ℝ3) -> ℝ -> ℝ2 -> ℝ2 -> TriSquare
Sq (ℝ3, ℝ3, ℝ3)
b ℝ
z (ℝ -> ℝ -> ℝ2
forall a. a -> a -> V2 a
V2 ℝ
x1a ℝ
x2b) ℝ2
yS TriSquare -> [TriSquare] -> [TriSquare]
forall a. a -> [a] -> [a]
: [TriSquare]
others)
          | ℝ
x1a ℝ -> ℝ -> Bool
forall a. Eq a => a -> a -> Bool
== ℝ
x2b = [TriSquare] -> [TriSquare]
mergeAdjacent ((ℝ3, ℝ3, ℝ3) -> ℝ -> ℝ2 -> ℝ2 -> TriSquare
Sq (ℝ3, ℝ3, ℝ3)
b ℝ
z (ℝ -> ℝ -> ℝ2
forall a. a -> a -> V2 a
V2 ℝ
x1b ℝ
x2a) ℝ2
yS TriSquare -> [TriSquare] -> [TriSquare]
forall a. a -> [a] -> [a]
: [TriSquare]
others)
          | Bool
otherwise  = TriSquare
pres TriSquare -> [TriSquare] -> [TriSquare]
forall a. a -> [a] -> [a]
: [TriSquare] -> [TriSquare]
mergeAdjacent (TriSquare
next TriSquare -> [TriSquare] -> [TriSquare]
forall a. a -> [a] -> [a]
: [TriSquare]
others)
        mergeAdjacent [TriSquare]
a = [TriSquare]
a
    in
        [TriSquare] -> [TriSquare]
mergeAdjacent [TriSquare]
orderedQuads
joinYaligned (Tris TriangleMesh
_:[TriSquare]
_) = [Char] -> [TriSquare]
forall a. HasCallStack => [Char] -> a
error [Char]
"Tried to join y aligned triangles."
joinYaligned [] = []

-- Deconstruct a square into two triangles.
squareToTri :: TriSquare -> [Triangle]
squareToTri :: TriSquare -> [Triangle]
squareToTri (Sq (ℝ3
b1,ℝ3
b2,ℝ3
b3) ℝ
z (V2 ℝ
x1 ℝ
x2) (V2 ℝ
y1 ℝ
y2)) =
    let
        zV :: ℝ3
zV = ℝ3
b3 ℝ3 -> ℝ -> ℝ3
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* ℝ
z
        (ℝ3
x1V, ℝ3
x2V) = (ℝ
x1 ℝ -> ℝ3 -> ℝ3
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ℝ3
b1, ℝ
x2 ℝ -> ℝ3 -> ℝ3
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ℝ3
b1)
        (ℝ3
y1V, ℝ3
y2V) = (ℝ
y1 ℝ -> ℝ3 -> ℝ3
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ℝ3
b2, ℝ
y2 ℝ -> ℝ3 -> ℝ3
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ℝ3
b2)
        a :: ℝ3
a = ℝ3
zV ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
+ ℝ3
x1V ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
+ ℝ3
y1V
        b :: ℝ3
b = ℝ3
zV ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
+ ℝ3
x2V ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
+ ℝ3
y1V
        c :: ℝ3
c = ℝ3
zV ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
+ ℝ3
x1V ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
+ ℝ3
y2V
        d :: ℝ3
d = ℝ3
zV ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
+ ℝ3
x2V ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
+ ℝ3
y2V
    in
        [(ℝ3, ℝ3, ℝ3) -> Triangle
Triangle (ℝ3
a,ℝ3
b,ℝ3
c), (ℝ3, ℝ3, ℝ3) -> Triangle
Triangle (ℝ3
c,ℝ3
b,ℝ3
d)]
squareToTri (Tris TriangleMesh
t) = TriangleMesh -> [Triangle]
getTriangles TriangleMesh
t