{- 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 :: (V3 ℝ, V3 ℝ, V3 ℝ) -> V3 ℝ
normal (V3 ℝ
a,V3 ℝ
b,V3 ℝ
c) =
    forall a (f :: * -> *).
(Floating a, Metric f, Epsilon a) =>
f a -> f a
normalize forall a b. (a -> b) -> a -> b
$ (V3 ℝ
b forall a. Num a => a -> a -> a
- V3 ℝ
a) forall a. Num a => V3 a -> V3 a -> V3 a
`cross` (V3 ℝ
c forall a. Num a => a -> a -> a
- V3 ℝ
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 :: V3 ℝ -> (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 :: forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
isDegenerateTri2Axis ((a, a, a), (a, a, a), (a, a, a))
tri = (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
&& 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
|| (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
&& 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
|| (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
&& 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 :: forall a. Eq a => (a, a, a) -> Bool
same (a
n1, a
n2, a
n3) = a
n1 forall a. Eq a => a -> a -> Bool
== a
n2 Bool -> Bool -> Bool
&& a
n2 forall a. Eq a => a -> a -> Bool
== a
n3
            xsame :: Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
            xsame :: forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
xsame ((a
x1,a
_,a
_),(a
x2,a
_,a
_),(a
x3,a
_,a
_)) = 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 :: forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
ysame ((a
_,a
y1,a
_),(a
_,a
y2,a
_),(a
_,a
y3,a
_)) = 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 :: forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
zsame ((a
_,a
_,a
z1),(a
_,a
_,a
z2),(a
_,a
_,a
z3)) = forall a. Eq a => (a, a, a) -> Bool
same (a
z1, a
z2, a
z3)
        isDegenerateTri :: Triangle -> Bool
        isDegenerateTri :: Triangle -> Bool
isDegenerateTri (Triangle (V3 ℝ
a, V3 ℝ
b, V3 ℝ
c)) = 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 = (V3 ℝ -> (Float, Float, Float)
floatPoint V3 ℝ
a, V3 ℝ -> (Float, Float, Float)
floatPoint V3 ℝ
b, V3 ℝ -> (Float, Float, Float)
floatPoint V3 ℝ
c)
    in [Triangle] -> TriangleMesh
TriangleMesh forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not 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 forall a b. (a -> b) -> a -> b
$ Builder
stlHeader forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Triangle -> Builder
triangle (TriangleMesh -> [Triangle]
getTriangles forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriangleMesh
cleanupTris TriangleMesh
triangles) 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 :: V3 ℝ -> Builder
vector (V3 ℝ
x ℝ
y ℝ
z) = ℝ -> Builder
bf ℝ
x forall a. Semigroup a => a -> a -> a
<> Builder
" " forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf ℝ
y forall a. Semigroup a => a -> a -> a
<> Builder
" " forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf ℝ
z
        vertex :: ℝ3 -> Builder
        vertex :: V3 ℝ -> Builder
vertex V3 ℝ
v = Builder
"vertex " forall a. Semigroup a => a -> a -> a
<> V3 ℝ -> Builder
vector V3 ℝ
v
        triangle :: Triangle -> Builder
        triangle :: Triangle -> Builder
triangle (Triangle (V3 ℝ
a,V3 ℝ
b,V3 ℝ
c)) =
                Builder
"facet normal " forall a. Semigroup a => a -> a -> a
<> V3 ℝ -> Builder
vector ((V3 ℝ, V3 ℝ, V3 ℝ) -> V3 ℝ
normal (V3 ℝ
a,V3 ℝ
b,V3 ℝ
c)) forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
                forall a. Semigroup a => a -> a -> a
<> Builder
"outer loop\n"
                forall a. Semigroup a => a -> a -> a
<> V3 ℝ -> Builder
vertex V3 ℝ
a forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
                forall a. Semigroup a => a -> a -> a
<> V3 ℝ -> Builder
vertex V3 ℝ
b forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
                forall a. Semigroup a => a -> a -> a
<> V3 ℝ -> Builder
vertex V3 ℝ
c
                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 forall a b. (a -> b) -> a -> b
$ Builder
header forall a. Semigroup a => a -> a -> a
<> Builder
lengthField forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Triangle -> Builder
triangle (TriangleMesh -> [Triangle]
getTriangles forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriangleMesh
cleanupTris TriangleMesh
triangles)
    where header :: Builder
header = ByteString -> Builder
fromByteString forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
replicate Int
80 Word8
0
          lengthField :: Builder
lengthField = Word32 -> Builder
fromWord32le forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ TriangleMesh -> [Triangle]
getTriangles forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriangleMesh
cleanupTris TriangleMesh
triangles
          triangle :: Triangle -> Builder
triangle (Triangle (V3 ℝ
a,V3 ℝ
b,V3 ℝ
c)) = (V3 ℝ, V3 ℝ, V3 ℝ) -> Builder
normalV (V3 ℝ
a,V3 ℝ
b,V3 ℝ
c) forall a. Semigroup a => a -> a -> a
<> V3 ℝ -> Builder
point V3 ℝ
a forall a. Semigroup a => a -> a -> a
<> V3 ℝ -> Builder
point V3 ℝ
b forall a. Semigroup a => a -> a -> a
<> V3 ℝ -> Builder
point V3 ℝ
c forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
fromWord16le Word16
0
          point :: ℝ3 -> BI.Builder
          point :: V3 ℝ -> Builder
point (V3 ℝ
x ℝ
y ℝ
z) = Float -> Builder
BI.floatLE (ℝ -> Float
toFloat ℝ
x) forall a. Semigroup a => a -> a -> a
<> Float -> Builder
BI.floatLE (ℝ -> Float
toFloat ℝ
y) forall a. Semigroup a => a -> a -> a
<> Float -> Builder
BI.floatLE (ℝ -> Float
toFloat ℝ
z)
          normalV :: (V3 ℝ, V3 ℝ, V3 ℝ) -> Builder
normalV (V3 ℝ, V3 ℝ, V3 ℝ)
ps = V3 ℝ -> Builder
point forall a b. (a -> b) -> a -> b
$ (V3 ℝ, V3 ℝ, V3 ℝ) -> V3 ℝ
normal (V3 ℝ, V3 ℝ, V3 ℝ)
ps

jsTHREE :: TriangleMesh -> Text
jsTHREE :: TriangleMesh -> Text
jsTHREE TriangleMesh
triangles = Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ Builder
header forall a. Semigroup a => a -> a -> a
<> Builder
vertcode forall a. Semigroup a => a -> a -> a
<> Builder
facecode 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"
                         forall a. Semigroup a => a -> a -> a
<> Builder
"var s = this;\n"
                         forall a. Semigroup a => a -> a -> a
<> Builder
"THREE.Geometry.call(this);\n"
                         forall a. Semigroup a => a -> a -> a
<> Builder
"function vec(x,y,z){return new THREE.Vector3(x,y,z);}\n"
                         forall a. Semigroup a => a -> a -> a
<> Builder
"function v(x,y,z){s.vertices.push(vec(x,y,z));}\n"
                         forall a. Semigroup a => a -> a -> a
<> Builder
"function f(a,b,c){"
                         forall a. Semigroup a => a -> a -> a
<> Builder
"s.faces.push(new THREE.Face3(a,b,c));"
                         forall a. Semigroup a => a -> a -> a
<> Builder
"}\n"
                footer :: Builder
                footer :: Builder
footer = Builder
"}\n"
                         forall a. Semigroup a => a -> a -> a
<> Builder
"Shape.prototype = new THREE.Geometry();\n"
                         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 :: V3 ℝ -> Builder
v (V3 ℝ
x ℝ
y ℝ
z) = Builder
"v(" forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf ℝ
x forall a. Semigroup a => a -> a -> a
<> Builder
"," forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf ℝ
y forall a. Semigroup a => a -> a -> a
<> Builder
"," forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf ℝ
z forall a. Semigroup a => a -> a -> a
<> Builder
");\n"
                -- A face line
                f :: ℕ -> ℕ -> ℕ -> Builder
                f :: ℕ -> ℕ -> ℕ -> Builder
f ℕ
posa ℕ
posb ℕ
posc =
                        Builder
"f(" forall a. Semigroup a => a -> a -> a
<> ℕ -> Builder
buildℕ ℕ
posa forall a. Semigroup a => a -> a -> a
<> Builder
"," forall a. Semigroup a => a -> a -> a
<> ℕ -> Builder
buildℕ ℕ
posb forall a. Semigroup a => a -> a -> a
<> Builder
"," forall a. Semigroup a => a -> a -> a
<> ℕ -> Builder
buildℕ ℕ
posc forall a. Semigroup a => a -> a -> a
<> Builder
");"
                verts :: [V3 ℝ]
verts = do
                        -- extract the vertices for each triangle
                        -- recall that a normed triangle is of the form ((vert, norm), ...)
                        (Triangle (V3 ℝ
a,V3 ℝ
b,V3 ℝ
c)) <- TriangleMesh -> [Triangle]
getTriangles 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
                        [V3 ℝ
a,V3 ℝ
b,V3 ℝ
c]
                vertcode :: Builder
vertcode = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap V3 ℝ -> Builder
v [V3 ℝ]
verts
                facecode :: Builder
facecode = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ do
                        (ℕ
n,Triangle
_) <- forall a b. [a] -> [b] -> [(a, b)]
zip [ℕ
0, ℕ
3 ..] forall a b. (a -> b) -> a -> b
$ TriangleMesh -> [Triangle]
getTriangles forall a b. (a -> b) -> a -> b
$ TriangleMesh -> TriangleMesh
cleanupTris TriangleMesh
triangles
                        let
                            (ℕ
posa, ℕ
posb, ℕ
posc) = (ℕ
n, ℕ
nforall a. Num a => a -> a -> a
+ℕ
1, ℕ
nforall a. Num a => a -> a -> a
+ℕ
2) :: (ℕ, ℕ, ℕ)
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ℕ -> ℕ -> ℕ -> Builder
f ℕ
posa ℕ
posb ℕ
posc