{- 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

{-# LANGUAGE LambdaCase #-}

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) -> Double -> ℝ2 -> ℝ2 -> TriSquare
Sq (ℝ3, ℝ3, ℝ3)
x Double
y ℝ2
z ℝ2
q | Sq (ℝ3, ℝ3, ℝ3)
x Double
y ℝ2
z ℝ2
q <- [TriSquare]
sqTris ]

        -- Collect squares that are on the same plane.
        planeAligned :: [[TriSquare]]
planeAligned = forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith
          (\case
            (Sq (ℝ3, ℝ3, ℝ3)
basis Double
z ℝ2
_ ℝ2
_) -> ((ℝ3, ℝ3, ℝ3)
basis,Double
z)
            (Tris TriangleMesh
_) -> forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected Tris"
          ) [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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ( forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [TriSquare] -> [TriSquare]
joinXaligned forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith
                (\case
                  (Sq (ℝ3, ℝ3, ℝ3)
_ Double
_ ℝ2
xS ℝ2
_) -> ℝ2
xS
                  (Tris TriangleMesh
_) -> forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected Tris"
                )
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [TriSquare] -> [TriSquare]
joinYaligned forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith
                (\case
                  (Sq (ℝ3, ℝ3, ℝ3)
_ Double
_ ℝ2
_ ℝ2
yS) -> ℝ2
yS
                  (Tris TriangleMesh
_) -> forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected Tris"
                )
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [TriSquare] -> [TriSquare]
joinXaligned forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith
                (\case
                  (Sq (ℝ3, ℝ3, ℝ3)
_ Double
_ ℝ2
xS ℝ2
_) -> ℝ2
xS
                  (Tris TriangleMesh
_) -> forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected Tris"
                )
            )
            [[TriSquare]]
planeAligned
        -- Merge them back together, and we have the desired reult!
        finishedSquares :: [TriSquare]
finishedSquares = 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 forall a b. (a -> b) -> a -> b
$ [Triangle]
triTriangles forall a. Semigroup a => a -> a -> a
<> 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 Double
z ℝ2
xS ℝ2
_):[TriSquare]
_) =
    let
        orderedQuads :: [TriSquare]
orderedQuads = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy
            (\TriSquare
i TriSquare
j -> case (TriSquare
i, TriSquare
j) of
                (Sq (ℝ3, ℝ3, ℝ3)
_ Double
_ ℝ2
_ (V2 Double
ya Double
_), Sq (ℝ3, ℝ3, ℝ3)
_ Double
_ ℝ2
_ (V2 Double
yb Double
_)) -> forall a. Ord a => a -> a -> Ordering
compare Double
ya Double
yb
                (TriSquare, TriSquare)
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected Tris"
            )
            [TriSquare]
quads
        mergeAdjacent :: [TriSquare] -> [TriSquare]
mergeAdjacent (pres :: TriSquare
pres@(Sq (ℝ3, ℝ3, ℝ3)
_ Double
_ ℝ2
_ (V2 Double
y1a Double
y2a)) : next :: TriSquare
next@(Sq (ℝ3, ℝ3, ℝ3)
_ Double
_ ℝ2
_ (V2 Double
y1b Double
y2b)) : [TriSquare]
others)
          | Double
y2a forall a. Eq a => a -> a -> Bool
== Double
y1b = [TriSquare] -> [TriSquare]
mergeAdjacent ((ℝ3, ℝ3, ℝ3) -> Double -> ℝ2 -> ℝ2 -> TriSquare
Sq (ℝ3, ℝ3, ℝ3)
b Double
z ℝ2
xS (forall a. a -> a -> V2 a
V2 Double
y1a Double
y2b) forall a. a -> [a] -> [a]
: [TriSquare]
others)
          | Double
y1a forall a. Eq a => a -> a -> Bool
== Double
y2b = [TriSquare] -> [TriSquare]
mergeAdjacent ((ℝ3, ℝ3, ℝ3) -> Double -> ℝ2 -> ℝ2 -> TriSquare
Sq (ℝ3, ℝ3, ℝ3)
b Double
z ℝ2
xS (forall a. a -> a -> V2 a
V2 Double
y1b Double
y2a) forall a. a -> [a] -> [a]
: [TriSquare]
others)
          | Bool
otherwise  = TriSquare
pres forall a. a -> [a] -> [a]
: [TriSquare] -> [TriSquare]
mergeAdjacent (TriSquare
next forall a. a -> [a] -> [a]
: [TriSquare]
others)
        mergeAdjacent [TriSquare]
a = [TriSquare]
a
    in
        [TriSquare] -> [TriSquare]
mergeAdjacent [TriSquare]
orderedQuads
joinXaligned (Tris TriangleMesh
_:[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 Double
z ℝ2
_ ℝ2
yS):[TriSquare]
_) =
    let
        orderedQuads :: [TriSquare]
orderedQuads = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy
            (\TriSquare
i TriSquare
j -> case (TriSquare
i, TriSquare
j) of
                (Sq (ℝ3, ℝ3, ℝ3)
_ Double
_ (V2 Double
xa Double
_) ℝ2
_, Sq (ℝ3, ℝ3, ℝ3)
_ Double
_ (V2 Double
xb Double
_) ℝ2
_) -> forall a. Ord a => a -> a -> Ordering
compare Double
xa Double
xb
                (TriSquare, TriSquare)
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected Tris"
            )
            [TriSquare]
quads
        mergeAdjacent :: [TriSquare] -> [TriSquare]
mergeAdjacent (pres :: TriSquare
pres@(Sq (ℝ3, ℝ3, ℝ3)
_ Double
_ (V2 Double
x1a Double
x2a) ℝ2
_) : next :: TriSquare
next@(Sq (ℝ3, ℝ3, ℝ3)
_ Double
_ (V2 Double
x1b Double
x2b) ℝ2
_) : [TriSquare]
others)
          | Double
x2a forall a. Eq a => a -> a -> Bool
== Double
x1b = [TriSquare] -> [TriSquare]
mergeAdjacent ((ℝ3, ℝ3, ℝ3) -> Double -> ℝ2 -> ℝ2 -> TriSquare
Sq (ℝ3, ℝ3, ℝ3)
b Double
z (forall a. a -> a -> V2 a
V2 Double
x1a Double
x2b) ℝ2
yS forall a. a -> [a] -> [a]
: [TriSquare]
others)
          | Double
x1a forall a. Eq a => a -> a -> Bool
== Double
x2b = [TriSquare] -> [TriSquare]
mergeAdjacent ((ℝ3, ℝ3, ℝ3) -> Double -> ℝ2 -> ℝ2 -> TriSquare
Sq (ℝ3, ℝ3, ℝ3)
b Double
z (forall a. a -> a -> V2 a
V2 Double
x1b Double
x2a) ℝ2
yS forall a. a -> [a] -> [a]
: [TriSquare]
others)
          | Bool
otherwise  = TriSquare
pres forall a. a -> [a] -> [a]
: [TriSquare] -> [TriSquare]
mergeAdjacent (TriSquare
next forall a. a -> [a] -> [a]
: [TriSquare]
others)
        mergeAdjacent [TriSquare]
a = [TriSquare]
a
    in
        [TriSquare] -> [TriSquare]
mergeAdjacent [TriSquare]
orderedQuads
joinYaligned (Tris TriangleMesh
_:[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) Double
z (V2 Double
x1 Double
x2) (V2 Double
y1 Double
y2)) =
    let
        zV :: ℝ3
zV = ℝ3
b3 forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Double
z
        (ℝ3
x1V, ℝ3
x2V) = (Double
x1 forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ℝ3
b1, Double
x2 forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ℝ3
b1)
        (ℝ3
y1V, ℝ3
y2V) = (Double
y1 forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ℝ3
b2, Double
y2 forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ℝ3
b2)
        a :: ℝ3
a = ℝ3
zV forall a. Num a => a -> a -> a
+ ℝ3
x1V forall a. Num a => a -> a -> a
+ ℝ3
y1V
        b :: ℝ3
b = ℝ3
zV forall a. Num a => a -> a -> a
+ ℝ3
x2V forall a. Num a => a -> a -> a
+ ℝ3
y1V
        c :: ℝ3
c = ℝ3
zV forall a. Num a => a -> a -> a
+ ℝ3
x1V forall a. Num a => a -> a -> a
+ ℝ3
y2V
        d :: ℝ3
d = ℝ3
zV forall a. Num a => a -> a -> a
+ ℝ3
x2V 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