{- 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 -> [[V3 ℝ]] -> [TriSquare]
tesselateLoop ℝ
_ Obj3
_ [] = []

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

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

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

tesselateLoop ℝ
res Obj3
obj [as :: [V3 ℝ]
as@(V3 ℝ
_:V3 ℝ
_:V3 ℝ
_:[V3 ℝ]
_),[V3 ℝ
_,V3 ℝ
_], bs :: [V3 ℝ]
bs@(V3 ℝ
_:V3 ℝ
_:V3 ℝ
_:[V3 ℝ]
_), [V3 ℝ
_,V3 ℝ
_] ] | forall (t :: * -> *) a. Foldable t => t a -> Int
length [V3 ℝ]
as forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [V3 ℝ]
bs =
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ℝ -> Obj3 -> [[V3 ℝ]] -> [TriSquare]
tesselateLoop ℝ
res Obj3
obj)
        [[[V3 ℝ
a1,V3 ℝ
b1],[V3 ℝ
b1,V3 ℝ
b2],[V3 ℝ
b2,V3 ℝ
a2],[V3 ℝ
a2,V3 ℝ
a1]] | ((V3 ℝ
a1,V3 ℝ
b1),(V3 ℝ
a2,V3 ℝ
b2)) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
init [(V3 ℝ, V3 ℝ)]
pairs) (forall a. [a] -> [a]
tail [(V3 ℝ, V3 ℝ)]
pairs)]
            where pairs :: [(V3 ℝ, V3 ℝ)]
pairs = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
reverse [V3 ℝ]
as) [V3 ℝ]
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 [[V3 ℝ
a,V3 ℝ
_],[V3 ℝ
b,V3 ℝ
_],[V3 ℝ
c,V3 ℝ
_],[V3 ℝ
d,V3 ℝ
_]] | Obj3
obj (forall a (t :: * -> *) (f :: * -> *).
(Fractional a, Foldable t, Applicative f, Num (f a)) =>
t (f a) -> f a
centroid [V3 ℝ
a,V3 ℝ
c]) forall a. Ord a => a -> a -> Bool
< ℝ
resforall a. Fractional a => a -> a -> a
/ℝ
30 =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriSquare
Tris forall a b. (a -> b) -> a -> b
$ [Triangle] -> TriangleMesh
TriangleMesh [(V3 ℝ, V3 ℝ, V3 ℝ) -> Triangle
Triangle (V3 ℝ
a,V3 ℝ
b,V3 ℝ
c), (V3 ℝ, V3 ℝ, V3 ℝ) -> Triangle
Triangle (V3 ℝ
a,V3 ℝ
c,V3 ℝ
d)]

-- Fallback case: make fans

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

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

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

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

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