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

-- Make string litearls more polymorphic, so we can use them with Builder.
{-# LANGUAGE OverloadedStrings #-}

-- This module exposes three functions, which convert a triangle mesh to an output file.
module Graphics.Implicit.Export.TriangleMeshFormats (stl, binaryStl, jsTHREE) where

import Prelude ((-), Float, Eq, Bool, ($), (+), (.), toEnum, length, zip, pure, (==), (||), (&&), filter, not, (<>))

import Graphics.Implicit.Definitions (Triangle(Triangle), TriangleMesh(TriangleMesh, getTriangles), ℕ, ℝ3, ℝ, fromℝtoFloat)
import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, toLazyText, bf, buildℕ)

import Blaze.ByteString.Builder (toLazyByteString, fromByteString, fromWord32le, fromWord16le)
import qualified Data.ByteString.Builder as BI (Builder, floatLE)

import Data.Foldable(fold, foldMap)

import Data.ByteString (replicate)
import Data.ByteString.Lazy (ByteString)

import Linear (normalize, cross, V3(V3))

normal :: (ℝ3,ℝ3,ℝ3) -> ℝ3
normal :: (ℝ3, ℝ3, ℝ3) -> ℝ3
normal (ℝ3
a,ℝ3
b,ℝ3
c) =
    ℝ3 -> ℝ3
forall a (f :: * -> *).
(Floating a, Metric f, Epsilon a) =>
f a -> f a
normalize (ℝ3 -> ℝ3) -> ℝ3 -> ℝ3
forall a b. (a -> b) -> a -> b
$ (ℝ3
b ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
- ℝ3
a) ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => V3 a -> V3 a -> V3 a
`cross` (ℝ3
c ℝ3 -> ℝ3 -> ℝ3
forall a. Num a => a -> a -> a
- ℝ3
a)

-- | Removes triangles that are empty when converting their positions to Float resolution.
cleanupTris :: TriangleMesh -> TriangleMesh
cleanupTris :: TriangleMesh -> TriangleMesh
cleanupTris TriangleMesh
tris =
    let
        floatPoint :: V3 ℝ -> (Float, Float, Float)
        floatPoint :: ℝ3 -> (Float, Float, Float)
floatPoint (V3 ℝ
a ℝ
b ℝ
c) = (ℝ -> Float
toFloat ℝ
a, ℝ -> Float
toFloat ℝ
b, ℝ -> Float
toFloat ℝ
c)

        -- Does this triangle fail because it is constrained on two axises?
        isDegenerateTri2Axis :: Eq a => ((a, a, a),(a, a, a),(a, a, a)) -> Bool
        isDegenerateTri2Axis :: ((a, a, a), (a, a, a), (a, a, a)) -> Bool
isDegenerateTri2Axis ((a, a, a), (a, a, a), (a, a, a))
tri = (((a, a, a), (a, a, a), (a, a, a)) -> Bool
forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
ysame ((a, a, a), (a, a, a), (a, a, a))
tri Bool -> Bool -> Bool
&& ((a, a, a), (a, a, a), (a, a, a)) -> Bool
forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
xsame ((a, a, a), (a, a, a), (a, a, a))
tri) Bool -> Bool -> Bool
|| (((a, a, a), (a, a, a), (a, a, a)) -> Bool
forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
zsame ((a, a, a), (a, a, a), (a, a, a))
tri Bool -> Bool -> Bool
&& ((a, a, a), (a, a, a), (a, a, a)) -> Bool
forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
ysame ((a, a, a), (a, a, a), (a, a, a))
tri) Bool -> Bool -> Bool
|| (((a, a, a), (a, a, a), (a, a, a)) -> Bool
forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
zsame ((a, a, a), (a, a, a), (a, a, a))
tri Bool -> Bool -> Bool
&& ((a, a, a), (a, a, a), (a, a, a)) -> Bool
forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
xsame ((a, a, a), (a, a, a), (a, a, a))
tri)
          where
            same :: Eq a => (a, a, a) -> Bool
            same :: (a, a, a) -> Bool
same (a
n1, a
n2, a
n3) = a
n1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
n2 Bool -> Bool -> Bool
&& a
n2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
n3
            xsame :: Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
            xsame :: ((a, a, a), (a, a, a), (a, a, a)) -> Bool
xsame ((a
x1,a
_,a
_),(a
x2,a
_,a
_),(a
x3,a
_,a
_)) = (a, a, a) -> Bool
forall a. Eq a => (a, a, a) -> Bool
same (a
x1, a
x2, a
x3)
            ysame :: Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
            ysame :: ((a, a, a), (a, a, a), (a, a, a)) -> Bool
ysame ((a
_,a
y1,a
_),(a
_,a
y2,a
_),(a
_,a
y3,a
_)) = (a, a, a) -> Bool
forall a. Eq a => (a, a, a) -> Bool
same (a
y1, a
y2, a
y3)
            zsame :: Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
            zsame :: ((a, a, a), (a, a, a), (a, a, a)) -> Bool
zsame ((a
_,a
_,a
z1),(a
_,a
_,a
z2),(a
_,a
_,a
z3)) = (a, a, a) -> Bool
forall a. Eq a => (a, a, a) -> Bool
same (a
z1, a
z2, a
z3)
        isDegenerateTri :: Triangle -> Bool
        isDegenerateTri :: Triangle -> Bool
isDegenerateTri (Triangle (ℝ3
a, ℝ3
b, ℝ3
c)) = ((Float, Float, Float), (Float, Float, Float),
 (Float, Float, Float))
-> Bool
forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
isDegenerateTri2Axis ((Float, Float, Float), (Float, Float, Float),
 (Float, Float, Float))
floatTri
          where
            floatTri :: ((Float, Float, Float), (Float, Float, Float),
 (Float, Float, Float))
floatTri = (ℝ3 -> (Float, Float, Float)
floatPoint ℝ3
a, ℝ3 -> (Float, Float, Float)
floatPoint ℝ3
b, ℝ3 -> (Float, Float, Float)
floatPoint ℝ3
c)
    in [Triangle] -> TriangleMesh
TriangleMesh ([Triangle] -> TriangleMesh) -> [Triangle] -> TriangleMesh
forall a b. (a -> b) -> a -> b
$ (Triangle -> Bool) -> [Triangle] -> [Triangle]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Triangle -> Bool) -> Triangle -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Triangle -> Bool
isDegenerateTri) (TriangleMesh -> [Triangle]
getTriangles TriangleMesh
tris)

-- | Generate an STL file is ASCII format.
stl :: TriangleMesh -> Text
stl :: TriangleMesh -> Text
stl TriangleMesh
triangles = Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Builder
stlHeader Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Triangle -> Builder) -> [Triangle] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Triangle -> Builder
triangle (TriangleMesh -> [Triangle]
getTriangles (TriangleMesh -> [Triangle]) -> TriangleMesh -> [Triangle]
forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriangleMesh
cleanupTris TriangleMesh
triangles) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
stlFooter
    where
        stlHeader :: Builder
        stlHeader :: Builder
stlHeader = Builder
"solid ImplictCADExport\n"
        stlFooter :: Builder
        stlFooter :: Builder
stlFooter = Builder
"endsolid ImplictCADExport\n"
        vector :: ℝ3 -> Builder
        vector :: ℝ3 -> Builder
vector (V3 ℝ
x ℝ
y ℝ
z) = ℝ -> Builder
bf ℝ
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf ℝ
y Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf ℝ
z
        vertex :: ℝ3 -> Builder
        vertex :: ℝ3 -> Builder
vertex ℝ3
v = Builder
"vertex " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ3 -> Builder
vector ℝ3
v
        triangle :: Triangle -> Builder
        triangle :: Triangle -> Builder
triangle (Triangle (ℝ3
a,ℝ3
b,ℝ3
c)) =
                Builder
"facet normal " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ3 -> Builder
vector ((ℝ3, ℝ3, ℝ3) -> ℝ3
normal (ℝ3
a,ℝ3
b,ℝ3
c)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"outer loop\n"
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ3 -> Builder
vertex ℝ3
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ3 -> Builder
vertex ℝ3
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ3 -> Builder
vertex ℝ3
c
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\nendloop\nendfacet\n"

-- | convert from ℝ to Float.
toFloat :: ℝ -> Float
toFloat :: ℝ -> Float
toFloat = ℝ -> Float
fromℝtoFloat

-- | Generate an STL file in it's binary format.
binaryStl :: TriangleMesh -> ByteString
binaryStl :: TriangleMesh -> ByteString
binaryStl TriangleMesh
triangles = Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder
header Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
lengthField Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Triangle -> Builder) -> [Triangle] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Triangle -> Builder
triangle (TriangleMesh -> [Triangle]
getTriangles (TriangleMesh -> [Triangle]) -> TriangleMesh -> [Triangle]
forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriangleMesh
cleanupTris TriangleMesh
triangles)
    where header :: Builder
header = ByteString -> Builder
fromByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
replicate Int
80 Word8
0
          lengthField :: Builder
lengthField = Word32 -> Builder
fromWord32le (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a. Enum a => Int -> a
toEnum (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ [Triangle] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Triangle] -> Int) -> [Triangle] -> Int
forall a b. (a -> b) -> a -> b
$ TriangleMesh -> [Triangle]
getTriangles (TriangleMesh -> [Triangle]) -> TriangleMesh -> [Triangle]
forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriangleMesh
cleanupTris TriangleMesh
triangles
          triangle :: Triangle -> Builder
triangle (Triangle (ℝ3
a,ℝ3
b,ℝ3
c)) = (ℝ3, ℝ3, ℝ3) -> Builder
normalV (ℝ3
a,ℝ3
b,ℝ3
c) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ3 -> Builder
point ℝ3
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ3 -> Builder
point ℝ3
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ3 -> Builder
point ℝ3
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
fromWord16le Word16
0
          point :: ℝ3 -> BI.Builder
          point :: ℝ3 -> Builder
point (V3 ℝ
x ℝ
y ℝ
z) = Float -> Builder
BI.floatLE (ℝ -> Float
toFloat ℝ
x) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Float -> Builder
BI.floatLE (ℝ -> Float
toFloat ℝ
y) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Float -> Builder
BI.floatLE (ℝ -> Float
toFloat ℝ
z)
          normalV :: (ℝ3, ℝ3, ℝ3) -> Builder
normalV (ℝ3, ℝ3, ℝ3)
ps = ℝ3 -> Builder
point (ℝ3 -> Builder) -> ℝ3 -> Builder
forall a b. (a -> b) -> a -> b
$ (ℝ3, ℝ3, ℝ3) -> ℝ3
normal (ℝ3, ℝ3, ℝ3)
ps

jsTHREE :: TriangleMesh -> Text
jsTHREE :: TriangleMesh -> Text
jsTHREE TriangleMesh
triangles = Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Builder
header Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
vertcode Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
facecode Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
footer
        where
                -- some dense JS. Let's make helper functions so that we don't repeat code each line
                header :: Builder
                header :: Builder
header = Builder
"var Shape = function(){\n"
                         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"var s = this;\n"
                         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"THREE.Geometry.call(this);\n"
                         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"function vec(x,y,z){return new THREE.Vector3(x,y,z);}\n"
                         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"function v(x,y,z){s.vertices.push(vec(x,y,z));}\n"
                         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"function f(a,b,c){"
                         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"s.faces.push(new THREE.Face3(a,b,c));"
                         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"}\n"
                footer :: Builder
                footer :: Builder
footer = Builder
"}\n"
                         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Shape.prototype = new THREE.Geometry();\n"
                         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Shape.prototype.constructor = Shape;\n"
                -- A vertex line; v (0.0, 0.0, 1.0) = "v(0.0,0.0,1.0);\n"
                v :: ℝ3 -> Builder
                v :: ℝ3 -> Builder
v (V3 ℝ
x ℝ
y ℝ
z) = Builder
"v(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf ℝ
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf ℝ
y Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf ℝ
z Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
");\n"
                -- A face line
                f :: ℕ -> ℕ -> ℕ -> Builder
                f :: ℕ -> ℕ -> ℕ -> Builder
f ℕ
posa ℕ
posb ℕ
posc =
                        Builder
"f(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℕ -> Builder
buildℕ ℕ
posa Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℕ -> Builder
buildℕ ℕ
posb Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℕ -> Builder
buildℕ ℕ
posc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
");"
                verts :: [ℝ3]
verts = do
                        -- extract the vertices for each triangle
                        -- recall that a normed triangle is of the form ((vert, norm), ...)
                        (Triangle (ℝ3
a,ℝ3
b,ℝ3
c)) <- TriangleMesh -> [Triangle]
getTriangles (TriangleMesh -> [Triangle]) -> TriangleMesh -> [Triangle]
forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriangleMesh
cleanupTris TriangleMesh
triangles
                        -- The vertices from each triangle take up 3 position in the resulting list
                        [ℝ3
a,ℝ3
b,ℝ3
c]
                vertcode :: Builder
vertcode = (ℝ3 -> Builder) -> [ℝ3] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ℝ3 -> Builder
v [ℝ3]
verts
                facecode :: Builder
facecode = [Builder] -> Builder
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ do
                        (ℕ
n,Triangle
_) <- [ℕ] -> [Triangle] -> [(ℕ, Triangle)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ℕ
0, ℕ
3 ..] ([Triangle] -> [(ℕ, Triangle)]) -> [Triangle] -> [(ℕ, Triangle)]
forall a b. (a -> b) -> a -> b
$ TriangleMesh -> [Triangle]
getTriangles (TriangleMesh -> [Triangle]) -> TriangleMesh -> [Triangle]
forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriangleMesh
cleanupTris TriangleMesh
triangles
                        let
                            (ℕ
posa, ℕ
posb, ℕ
posc) = (ℕ
n, ℕ
nℕ -> ℕ -> ℕ
forall a. Num a => a -> a -> a
+ℕ
1, ℕ
nℕ -> ℕ -> ℕ
forall a. Num a => a -> a -> a
+ℕ
2) :: (ℕ, ℕ, ℕ)
                        Builder -> [Builder]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> [Builder]) -> Builder -> [Builder]
forall a b. (a -> b) -> a -> b
$ ℕ -> ℕ -> ℕ -> Builder
f ℕ
posa ℕ
posb ℕ
posc