{- 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.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.Export.Render.Definitions (TriSquare(Tris))

import Graphics.Implicit.Export.Util (centroid)

import Data.List (genericLength)
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]] -> [TriSquare]
tesselateLoop ℝ
_ Obj3
_ [] = []

tesselateLoop ℝ
_ Obj3
_ [[ℝ3
a,ℝ3
b],[ℝ3
_,ℝ3
c],[ℝ3
_,ℝ3
_]] = [TriangleMesh -> TriSquare
Tris (TriangleMesh -> TriSquare) -> TriangleMesh -> TriSquare
forall a b. (a -> b) -> a -> b
$ [Triangle] -> TriangleMesh
TriangleMesh [(ℝ3, ℝ3, ℝ3) -> Triangle
Triangle (ℝ3
a,ℝ3
b,ℝ3
c)]]

{-
   #____#     #____#
   |    |     |    |
   #    #  -> #____#
   |    |     |    |
   #____#     #____#
-}

tesselateLoop ℝ
res Obj3
obj [[ℝ3
_,ℝ3
_], as :: [ℝ3]
as@(ℝ3
_:ℝ3
_:ℝ3
_:[ℝ3]
_),[ℝ3
_,ℝ3
_], bs :: [ℝ3]
bs@(ℝ3
_:ℝ3
_:ℝ3
_:[ℝ3]
_)] | [ℝ3] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ℝ3]
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ℝ3] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ℝ3]
bs =
    ([[ℝ3]] -> [TriSquare]) -> [[[ℝ3]]] -> [TriSquare]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ℝ -> Obj3 -> [[ℝ3]] -> [TriSquare]
tesselateLoop ℝ
res Obj3
obj)
        [[[ℝ3
a1,ℝ3
b1],[ℝ3
b1,ℝ3
b2],[ℝ3
b2,ℝ3
a2],[ℝ3
a2,ℝ3
a1]] | ((ℝ3
a1,ℝ3
b1),(ℝ3
a2,ℝ3
b2)) <- [(ℝ3, ℝ3)] -> [(ℝ3, ℝ3)] -> [((ℝ3, ℝ3), (ℝ3, ℝ3))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([(ℝ3, ℝ3)] -> [(ℝ3, ℝ3)]
forall a. [a] -> [a]
init [(ℝ3, ℝ3)]
pairs) ([(ℝ3, ℝ3)] -> [(ℝ3, ℝ3)]
forall a. [a] -> [a]
tail [(ℝ3, ℝ3)]
pairs)]
            where pairs :: [(ℝ3, ℝ3)]
pairs = [ℝ3] -> [ℝ3] -> [(ℝ3, ℝ3)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([ℝ3] -> [ℝ3]
forall a. [a] -> [a]
reverse [ℝ3]
as) [ℝ3]
bs

tesselateLoop ℝ
res Obj3
obj [as :: [ℝ3]
as@(ℝ3
_:ℝ3
_:ℝ3
_:[ℝ3]
_),[ℝ3
_,ℝ3
_], bs :: [ℝ3]
bs@(ℝ3
_:ℝ3
_:ℝ3
_:[ℝ3]
_), [ℝ3
_,ℝ3
_] ] | [ℝ3] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ℝ3]
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ℝ3] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ℝ3]
bs =
    ([[ℝ3]] -> [TriSquare]) -> [[[ℝ3]]] -> [TriSquare]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ℝ -> Obj3 -> [[ℝ3]] -> [TriSquare]
tesselateLoop ℝ
res Obj3
obj)
        [[[ℝ3
a1,ℝ3
b1],[ℝ3
b1,ℝ3
b2],[ℝ3
b2,ℝ3
a2],[ℝ3
a2,ℝ3
a1]] | ((ℝ3
a1,ℝ3
b1),(ℝ3
a2,ℝ3
b2)) <- [(ℝ3, ℝ3)] -> [(ℝ3, ℝ3)] -> [((ℝ3, ℝ3), (ℝ3, ℝ3))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([(ℝ3, ℝ3)] -> [(ℝ3, ℝ3)]
forall a. [a] -> [a]
init [(ℝ3, ℝ3)]
pairs) ([(ℝ3, ℝ3)] -> [(ℝ3, ℝ3)]
forall a. [a] -> [a]
tail [(ℝ3, ℝ3)]
pairs)]
            where pairs :: [(ℝ3, ℝ3)]
pairs = [ℝ3] -> [ℝ3] -> [(ℝ3, ℝ3)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([ℝ3] -> [ℝ3]
forall a. [a] -> [a]
reverse [ℝ3]
as) [ℝ3]
bs

{-
   #__#
   |  |  -> if parallegram then 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) ]
-}

{-
   #__#      #__#
   |  |  ->  | /|
   #__#      #/_#
-}
-- | Create a pair of triangles from a quad.
-- FIXME: magic number
tesselateLoop ℝ
res Obj3
obj [[ℝ3
a,ℝ3
_],[ℝ3
b,ℝ3
_],[ℝ3
c,ℝ3
_],[ℝ3
d,ℝ3
_]] | Obj3
obj ([ℝ3] -> ℝ3
forall a (t :: * -> *) (f :: * -> *).
(Fractional a, Foldable t, Applicative f, Num (f a)) =>
t (f a) -> f a
centroid [ℝ3
a,ℝ3
c]) ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< ℝ
resℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
30 =
    TriSquare -> [TriSquare]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TriSquare -> [TriSquare]) -> TriSquare -> [TriSquare]
forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriSquare
Tris (TriangleMesh -> TriSquare) -> TriangleMesh -> TriSquare
forall a b. (a -> b) -> a -> b
$ [Triangle] -> TriangleMesh
TriangleMesh [(ℝ3, ℝ3, ℝ3) -> Triangle
Triangle (ℝ3
a,ℝ3
b,ℝ3
c), (ℝ3, ℝ3, ℝ3) -> Triangle
Triangle (ℝ3
a,ℝ3
c,ℝ3
d)]

-- Fallback case: make fans

-- FIXME: magic numbers.
tesselateLoop ℝ
res Obj3
obj [[ℝ3]]
pathSides = TriSquare -> [TriSquare]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TriSquare -> [TriSquare]) -> TriSquare -> [TriSquare]
forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriSquare
Tris (TriangleMesh -> TriSquare) -> TriangleMesh -> TriSquare
forall a b. (a -> b) -> a -> b
$ [Triangle] -> TriangleMesh
TriangleMesh ([Triangle] -> TriangleMesh) -> [Triangle] -> TriangleMesh
forall a b. (a -> b) -> a -> b
$
    let
        path' :: [ℝ3]
path' = ([ℝ3] -> [ℝ3]) -> [[ℝ3]] -> [ℝ3]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [ℝ3] -> [ℝ3]
forall a. [a] -> [a]
init [[ℝ3]]
pathSides
        ([Triangle]
early_tris,[ℝ3]
path) = ℕ -> [ℝ3] -> ℝ -> Obj3 -> ([Triangle], [ℝ3])
shrinkLoop ℕ
0 [ℝ3]
path' ℝ
res Obj3
obj
    in if [ℝ3] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ℝ3]
path
    then [Triangle]
early_tris
    else let
        mid :: ℝ3
mid = [ℝ3] -> ℝ3
forall a (t :: * -> *) (f :: * -> *).
(Fractional a, Foldable t, Applicative f, Num (f a)) =>
t (f a) -> f a
centroid [ℝ3]
path
        midval :: ℝ
midval = Obj3
obj ℝ3
mid
        preNormal :: ℝ3
preNormal = [ℝ3] -> ℝ3
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
            [ ℝ3
a ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => V3 a -> V3 a -> V3 a
`cross` ℝ3
b | (ℝ3
a,ℝ3
b) <- [ℝ3] -> [ℝ3] -> [(ℝ3, ℝ3)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ℝ3]
path ([ℝ3] -> [ℝ3]
forall a. [a] -> [a]
tail [ℝ3]
path [ℝ3] -> [ℝ3] -> [ℝ3]
forall a. Semigroup a => a -> a -> a
<> [[ℝ3] -> ℝ3
forall a. [a] -> a
head [ℝ3]
path]) ]
        preNormalNorm :: ℝ
preNormalNorm = Obj3
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm ℝ3
preNormal
        normal :: ℝ3
normal = ℝ3
preNormal ℝ3 -> ℝ -> ℝ3
forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ ℝ
preNormalNorm
        deriv :: ℝ
deriv = (Obj3
obj (ℝ3
mid ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
+ (ℝ3
normal ℝ3 -> ℝ -> ℝ3
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* (ℝ
resℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
100)) ) ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
midval)ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
resℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*ℝ
100
        mid' :: ℝ3
mid' = ℝ3
mid ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
- ℝ3
normal ℝ3 -> ℝ -> ℝ3
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* (ℝ
midvalℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
deriv)
        midval' :: ℝ
midval' = Obj3
obj ℝ3
mid'
        isCloserToSurface :: Bool
isCloserToSurface = ℝ -> ℝ
forall a. Num a => a -> a
abs ℝ
midval' ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< ℝ -> ℝ
forall a. Num a => a -> a
abs ℝ
midval
        isNearby :: Bool
isNearby = Obj3
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (ℝ3
mid ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
- ℝ3
mid') ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< ℝ
2 ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
* ℝ -> ℝ
forall a. Num a => a -> a
abs ℝ
midval
    in if Bool
isCloserToSurface Bool -> Bool -> Bool
&& Bool
isNearby
        then [Triangle]
early_tris [Triangle] -> [Triangle] -> [Triangle]
forall a. Semigroup a => a -> a -> a
<> [(ℝ3, ℝ3, ℝ3) -> Triangle
Triangle (ℝ3
a,ℝ3
b,ℝ3
mid') | (ℝ3
a,ℝ3
b) <- [ℝ3] -> [ℝ3] -> [(ℝ3, ℝ3)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ℝ3]
path ([ℝ3] -> [ℝ3]
forall a. [a] -> [a]
tail [ℝ3]
path [ℝ3] -> [ℝ3] -> [ℝ3]
forall a. Semigroup a => a -> a -> a
<> [[ℝ3] -> ℝ3
forall a. [a] -> a
head [ℝ3]
path]) ]
        else [Triangle]
early_tris [Triangle] -> [Triangle] -> [Triangle]
forall a. Semigroup a => a -> a -> a
<> [(ℝ3, ℝ3, ℝ3) -> Triangle
Triangle (ℝ3
a,ℝ3
b,ℝ3
mid) | (ℝ3
a,ℝ3
b) <- [ℝ3] -> [ℝ3] -> [(ℝ3, ℝ3)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ℝ3]
path ([ℝ3] -> [ℝ3]
forall a. [a] -> [a]
tail [ℝ3]
path [ℝ3] -> [ℝ3] -> [ℝ3]
forall a. Semigroup a => a -> a -> a
<> [[ℝ3] -> ℝ3
forall a. [a] -> a
head [ℝ3]
path]) ]

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

shrinkLoop :: ℕ -> [ℝ3] -> ℝ -> Obj3 -> ([Triangle], [ℝ3])
shrinkLoop ℕ
_ path :: [ℝ3]
path@[ℝ3
a,ℝ3
b,ℝ3
c] ℝ
res Obj3
obj =
    if   ℝ -> ℝ
forall a. Num a => a -> a
abs (Obj3
obj Obj3 -> Obj3
forall a b. (a -> b) -> a -> b
$ [ℝ3] -> ℝ3
forall a (t :: * -> *) (f :: * -> *).
(Fractional a, Foldable t, Applicative f, Num (f a)) =>
t (f a) -> f a
centroid [ℝ3
a,ℝ3
b,ℝ3
c]) ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< ℝ
resℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
50
    then
        ( [(ℝ3, ℝ3, ℝ3) -> Triangle
Triangle (ℝ3
a,ℝ3
b,ℝ3
c)], [])
    else
        ([], [ℝ3]
path)

-- FIXME: magic number.
shrinkLoop ℕ
n path :: [ℝ3]
path@(ℝ3
a:ℝ3
b:ℝ3
c:[ℝ3]
xs) ℝ
res Obj3
obj | ℕ
n ℕ -> ℕ -> Bool
forall a. Ord a => a -> a -> Bool
< [ℝ3] -> ℕ
forall i a. Num i => [a] -> i
genericLength [ℝ3]
path =
    if ℝ -> ℝ
forall a. Num a => a -> a
abs (Obj3
obj ([ℝ3] -> ℝ3
forall a (t :: * -> *) (f :: * -> *).
(Fractional a, Foldable t, Applicative f, Num (f a)) =>
t (f a) -> f a
centroid [ℝ3
a,ℝ3
c])) ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< ℝ
resℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
50
    then
        let ([Triangle]
tris,[ℝ3]
remainder) = ℕ -> [ℝ3] -> ℝ -> Obj3 -> ([Triangle], [ℝ3])
shrinkLoop ℕ
0 (ℝ3
aℝ3 -> [ℝ3] -> [ℝ3]
forall a. a -> [a] -> [a]
:ℝ3
cℝ3 -> [ℝ3] -> [ℝ3]
forall a. a -> [a] -> [a]
:[ℝ3]
xs) ℝ
res Obj3
obj
        in ((ℝ3, ℝ3, ℝ3) -> Triangle
Triangle (ℝ3
a,ℝ3
b,ℝ3
c)Triangle -> [Triangle] -> [Triangle]
forall a. a -> [a] -> [a]
:[Triangle]
tris, [ℝ3]
remainder)
    else
        ℕ -> [ℝ3] -> ℝ -> Obj3 -> ([Triangle], [ℝ3])
shrinkLoop (ℕ
nℕ -> ℕ -> ℕ
forall a. Num a => a -> a -> a
+ℕ
1) (ℝ3
bℝ3 -> [ℝ3] -> [ℝ3]
forall a. a -> [a] -> [a]
:ℝ3
cℝ3 -> [ℝ3] -> [ℝ3]
forall a. a -> [a] -> [a]
:[ℝ3]
xs [ℝ3] -> [ℝ3] -> [ℝ3]
forall a. Semigroup a => a -> a -> a
<> [ℝ3
a]) ℝ
res Obj3
obj

shrinkLoop ℕ
_ [ℝ3]
path ℝ
_ Obj3
_ = ([],[ℝ3]
path)