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

-- FIXME: describe why we need this.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- output SCAD code, AKA an implicitcad to openscad converter.
module Graphics.Implicit.Export.SymbolicFormats (scad2, scad3) where

import Prelude((.), fmap, Either(Left, Right), ($), (*), ($!), (-), (/), pi, error, (+), (==), take, floor, (&&), const, pure, (<>), sequenceA, (<$>))

import Graphics.Implicit.Definitions(, SymbolicObj2(Shared2, Square, Circle, Polygon, Rotate2, Transform2), SymbolicObj3(Shared3, Cube, Sphere, Cylinder, Rotate3, Transform3, Extrude, ExtrudeM, RotateExtrude, ExtrudeOnEdgeOf), isScaleID, SharedObj(Empty, Full, Complement, UnionR, IntersectR, DifferenceR, Translate, Scale, Mirror, Outset, Shell, EmbedBoxedObj, WithRounding), quaternionToEuler)
import Graphics.Implicit.Export.TextBuilderUtils(Text, Builder, toLazyText, fromLazyText, bf)

import Control.Monad.Reader (Reader, runReader, ask)

-- For constructing vectors of ℝs.
import Linear (V2(V2), V3(V3), V4(V4))

import Data.List (intersperse)
import Data.Function (fix)
import Data.Foldable(fold, foldMap, toList)
import Graphics.Implicit.ObjectUtil.GetBoxShared (VectorStuff(elements))

default ()

scad2 ::  -> SymbolicObj2 -> Text
scad2 :: ℝ -> SymbolicObj2 -> Text
scad2 res SymbolicObj2
obj = Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ forall r a. Reader r a -> r -> a
runReader (SymbolicObj2 -> Reader ℝ Builder
buildS2 SymbolicObj2
obj) res

scad3 ::  -> SymbolicObj3 -> Text
scad3 :: ℝ -> SymbolicObj3 -> Text
scad3 res SymbolicObj3
obj = Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ forall r a. Reader r a -> r -> a
runReader (SymbolicObj3 -> Reader ℝ Builder
buildS3 SymbolicObj3
obj) res

-- used by rotate2 and rotate3
rad2deg ::  -> 
rad2deg :: ℝ -> ℝ
rad2deg r = r forall a. Num a => a -> a -> a
* (180forall a. Fractional a => a -> a -> a
/forall a. Floating a => a
pi)

-- | Format an openscad call given that all the modified objects are in the Reader monad...
callToken :: (Text, Text) -> Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
callToken :: forall a.
(Text, Text)
-> Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
callToken (Text, Text)
cs Builder
name [Builder]
args []    = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Builder
name forall a. Semigroup a => a -> a -> a
<> (Text, Text) -> [Builder] -> Builder
buildArgs (Text, Text)
cs [Builder]
args forall a. Semigroup a => a -> a -> a
<> Builder
";"
callToken (Text, Text)
cs Builder
name [Builder]
args [Reader a Builder
obj] = ((Builder
name forall a. Semigroup a => a -> a -> a
<> (Text, Text) -> [Builder] -> Builder
buildArgs (Text, Text)
cs [Builder]
args) forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reader a Builder
obj
callToken (Text, Text)
cs Builder
name [Builder]
args [Reader a Builder]
objs  = do
  Builder
objs' <- forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Semigroup a => a -> a -> a
<> Builder
"\n") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Reader a Builder]
objs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! Builder
name forall a. Semigroup a => a -> a -> a
<> (Text, Text) -> [Builder] -> Builder
buildArgs (Text, Text)
cs [Builder]
args forall a. Semigroup a => a -> a -> a
<> Builder
"{\n" forall a. Semigroup a => a -> a -> a
<> Builder
objs' forall a. Semigroup a => a -> a -> a
<> Builder
"}\n"

buildArgs :: (Text, Text) -> [Builder] -> Builder
buildArgs :: (Text, Text) -> [Builder] -> Builder
buildArgs (Text, Text)
_ [] = Builder
"()"
buildArgs (Text
c1, Text
c2) [Builder]
args = Builder
"(" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromLazyText Text
c1 forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. a -> [a] -> [a]
intersperse Builder
"," [Builder]
args) forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromLazyText Text
c2 forall a. Semigroup a => a -> a -> a
<> Builder
")"

call :: Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call :: forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call = forall a.
(Text, Text)
-> Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
callToken (Text
"[", Text
"]")

callNaked :: Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
callNaked :: forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
callNaked = forall a.
(Text, Text)
-> Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
callToken (Text
"", Text
"")

------------------------------------------------------------------------------
-- | Class which allows us to build the contained objects in 'buildShared'.
class Build obj where
  build :: obj -> Reader  Builder

instance Build SymbolicObj2 where
  build :: SymbolicObj2 -> Reader ℝ Builder
build = SymbolicObj2 -> Reader ℝ Builder
buildS2

instance Build SymbolicObj3 where
  build :: SymbolicObj3 -> Reader ℝ Builder
build = SymbolicObj3 -> Reader ℝ Builder
buildS3

------------------------------------------------------------------------------
-- | Unpack a dimensionality-polymorphic vector into multiple arguments.
vectAsArgs :: VectorStuff vec => vec -> [Builder]
vectAsArgs :: forall vec. VectorStuff vec => vec -> [Builder]
vectAsArgs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ℝ -> Builder
bf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall vec. VectorStuff vec => vec -> [ℝ]
elements

------------------------------------------------------------------------------
-- | Unpack a dimensionality-polymorphic vector into a single argument.
bvect :: VectorStuff vec => vec -> Builder
bvect :: forall vec. VectorStuff vec => vec -> Builder
bvect vec
v = Builder
"[" forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. a -> [a] -> [a]
intersperse Builder
"," forall a b. (a -> b) -> a -> b
$ forall vec. VectorStuff vec => vec -> [Builder]
vectAsArgs vec
v) forall a. Semigroup a => a -> a -> a
<> Builder
"]"

------------------------------------------------------------------------------
-- | Build the common combinators.
buildShared :: forall obj f a. (Build obj, VectorStuff (f a)) => SharedObj obj f a -> Reader  Builder

buildShared :: forall obj (f :: * -> *) a.
(Build obj, VectorStuff (f a)) =>
SharedObj obj f a -> Reader ℝ Builder
buildShared SharedObj obj f a
Empty = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"union" [] []

buildShared SharedObj obj f a
Full = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"difference" [] [forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"union" [] []]

buildShared (Complement obj
obj) = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"complement" [] [forall obj. Build obj => obj -> Reader ℝ Builder
build obj
obj]

buildShared (UnionR r [obj]
objs) | r forall a. Eq a => a -> a -> Bool
== 0 = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"union" [] forall a b. (a -> b) -> a -> b
$ forall obj. Build obj => obj -> Reader ℝ Builder
build forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [obj]
objs

buildShared (IntersectR r [obj]
objs) | r forall a. Eq a => a -> a -> Bool
== 0 = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"intersection" [] forall a b. (a -> b) -> a -> b
$ forall obj. Build obj => obj -> Reader ℝ Builder
build forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [obj]
objs

buildShared (DifferenceR r obj
obj [obj]
objs) | r forall a. Eq a => a -> a -> Bool
== 0 = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"difference" [] forall a b. (a -> b) -> a -> b
$ forall obj. Build obj => obj -> Reader ℝ Builder
build forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> obj
obj forall a. a -> [a] -> [a]
: [obj]
objs

buildShared (Translate f a
v obj
obj) = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"translate" (ℝ -> Builder
bf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall vec. VectorStuff vec => vec -> [ℝ]
elements f a
v) [forall obj. Build obj => obj -> Reader ℝ Builder
build obj
obj]

buildShared (Scale f a
v obj
obj) = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"scale" (ℝ -> Builder
bf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall vec. VectorStuff vec => vec -> [ℝ]
elements f a
v) [forall obj. Build obj => obj -> Reader ℝ Builder
build obj
obj]

buildShared (Mirror f a
v obj
obj) = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
callNaked Builder
"mirror" [ Builder
"v=" forall a. Semigroup a => a -> a -> a
<> forall vec. VectorStuff vec => vec -> Builder
bvect f a
v ] [forall obj. Build obj => obj -> Reader ℝ Builder
build obj
obj]

-- NOTE(sandy): This @r == 0@ guard says we only emit "outset" if it has r = 0,
-- erroring otherwise saying "cannot provide roundness." But this is not
-- a roundness parameter!
buildShared (Outset r obj
obj) | r forall a. Eq a => a -> a -> Bool
== 0 = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"outset" [] [forall obj. Build obj => obj -> Reader ℝ Builder
build obj
obj]

-- NOTE(sandy): This @r == 0@ guard says we only emit "shell" if it has r = 0,
-- erroring otherwise saying "cannot provide roundness." But this is not
-- a roundness parameter!
buildShared (Shell r obj
obj) | r forall a. Eq a => a -> a -> Bool
== 0 = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"shell" [] [forall obj. Build obj => obj -> Reader ℝ Builder
build obj
obj]

buildShared (WithRounding r obj
obj) | r forall a. Eq a => a -> a -> Bool
== 0 = forall obj. Build obj => obj -> Reader ℝ Builder
build obj
obj

buildShared(UnionR _ [obj]
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"cannot provide roundness when exporting openscad; unsupported in target format."
buildShared(IntersectR _ [obj]
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"cannot provide roundness when exporting openscad; unsupported in target format."
buildShared(DifferenceR {}) = forall a. HasCallStack => [Char] -> a
error [Char]
"cannot provide roundness when exporting openscad; unsupported in target format."
buildShared(Outset _ obj
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"cannot provide roundness when exporting openscad; unsupported in target format."
buildShared(Shell _ obj
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"cannot provide roundness when exporting openscad; unsupported in target format."
buildShared(EmbedBoxedObj (f a -> a, (f a, f a))
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"cannot provide roundness when exporting openscad; unsupported in target format."
buildShared (WithRounding _ obj
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"cannot provide roundness when exporting openscad; unsupported in target format."

-- | First, the 3D objects.
buildS3 :: SymbolicObj3 -> Reader  Builder

buildS3 :: SymbolicObj3 -> Reader ℝ Builder
buildS3 (Shared3 SharedObj SymbolicObj3 V3 ℝ
obj) = forall obj (f :: * -> *) a.
(Build obj, VectorStuff (f a)) =>
SharedObj obj f a -> Reader ℝ Builder
buildShared SharedObj SymbolicObj3 V3 ℝ
obj

buildS3 (Cube (V3 w d h)) = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"cube" [ℝ -> Builder
bf w, ℝ -> Builder
bf d, ℝ -> Builder
bf h] []

buildS3 (Sphere r) = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
callNaked Builder
"sphere" [Builder
"r = " forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf r] []

buildS3 (Cylinder h r1 r2) = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
callNaked Builder
"cylinder" [
                              Builder
"r1 = " forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf r1
                             ,Builder
"r2 = " forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf r2
                             , ℝ -> Builder
bf h
                             ] []
buildS3 (Rotate3 Quaternion ℝ
q SymbolicObj3
obj) =
  let (V3 x y z) = forall a. RealFloat a => Quaternion a -> V3 a
quaternionToEuler Quaternion ℝ
q
   in forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"rotate" [ℝ -> Builder
bf (ℝ -> ℝ
rad2deg x), ℝ -> Builder
bf (ℝ -> ℝ
rad2deg y), ℝ -> Builder
bf (ℝ -> ℝ
rad2deg z)] [SymbolicObj3 -> Reader ℝ Builder
buildS3 SymbolicObj3
obj]

buildS3 (Transform3 M44 ℝ
m SymbolicObj3
obj) =
    forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"multmatrix"
      ((\Builder
x -> Builder
"["forall a. Semigroup a => a -> a -> a
<>Builder
xforall a. Semigroup a => a -> a -> a
<>Builder
"]") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse Builder
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ℝ -> Builder
bf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList M44 ℝ
m)
      [SymbolicObj3 -> Reader ℝ Builder
buildS3 SymbolicObj3
obj]

buildS3 (Extrude SymbolicObj2
obj h) = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
callNaked Builder
"linear_extrude" [Builder
"height = " forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf h] [SymbolicObj2 -> Reader ℝ Builder
buildS2 SymbolicObj2
obj]

-- FIXME: handle scale, center.
buildS3 (ExtrudeM Either ℝ (ℝ -> ℝ)
twist ExtrudeMScale
scale (Left V2 ℝ
translate) SymbolicObj2
obj (Left height)) |ExtrudeMScale -> Bool
isScaleID ExtrudeMScale
scale Bool -> Bool -> Bool
&& V2 ℝ
translate forall a. Eq a => a -> a -> Bool
== forall a. a -> a -> V2 a
V2 0 0 = do
  res <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let
    twist' :: ℝ -> ℝ
twist' = case Either ℝ (ℝ -> ℝ)
twist of
               Left twval  -> forall a b. a -> b -> a
const twval
               Right ℝ -> ℝ
twfun -> ℝ -> ℝ
twfun
  forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"union" [] [
             forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"rotate" [Builder
"0",Builder
"0", ℝ -> Builder
bf forall a b. (a -> b) -> a -> b
$ ℝ -> ℝ
twist' h] [
                        forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
callNaked Builder
"linear_extrude" [Builder
"height = " forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf res, Builder
"twist = " forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf (ℝ -> ℝ
twist' (hforall a. Num a => a -> a -> a
+res) forall a. Num a => a -> a -> a
- ℝ -> ℝ
twist' h)][
                                   SymbolicObj2 -> Reader ℝ Builder
buildS2 SymbolicObj2
obj
                                  ]
                       ] |  h <- forall a. Int -> [a] -> [a]
take (forall a b. (RealFrac a, Integral b) => a -> b
floor (res forall a. Fractional a => a -> a -> a
/ height)) forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a
fix (\ℝ -> [ℝ]
f x -> x forall a. a -> [a] -> [a]
: ℝ -> [ℝ]
f (xforall a. Num a => a -> a -> a
+res)) 0
            ]

-- FIXME: where are RotateExtrude, ExtrudeOnEdgeOf?

buildS3 ExtrudeM{} = forall a. HasCallStack => [Char] -> a
error [Char]
"cannot provide roundness when exporting openscad; unsupported in target format."
buildS3 RotateExtrude{} = forall a. HasCallStack => [Char] -> a
error [Char]
"cannot provide roundness when exporting openscad; unsupported in target format."
buildS3(ExtrudeOnEdgeOf SymbolicObj2
_ SymbolicObj2
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"cannot provide roundness when exporting openscad; unsupported in target format."

-- Now the 2D objects/transforms.

buildS2 :: SymbolicObj2 -> Reader  Builder

buildS2 :: SymbolicObj2 -> Reader ℝ Builder
buildS2 (Shared2 SharedObj SymbolicObj2 V2 ℝ
obj) = forall obj (f :: * -> *) a.
(Build obj, VectorStuff (f a)) =>
SharedObj obj f a -> Reader ℝ Builder
buildShared SharedObj SymbolicObj2 V2 ℝ
obj

buildS2 (Circle r) = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"circle" [ℝ -> Builder
bf r] []

buildS2 (Polygon [V2 ℝ]
points) = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"polygon" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall vec. VectorStuff vec => vec -> Builder
bvect [V2 ℝ]
points) []

buildS2 (Rotate2 r SymbolicObj2
obj)     = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"rotate" [ℝ -> Builder
bf (ℝ -> ℝ
rad2deg r)] [SymbolicObj2 -> Reader ℝ Builder
buildS2 SymbolicObj2
obj]

buildS2 (Transform2 M33 ℝ
m SymbolicObj2
obj) =
    let toM44 :: V3 (V3 a) -> V4 (V4 a)
toM44 (V3 (V3 a
a a
b a
c) (V3 a
d a
e a
f) (V3 a
g a
h a
i)) =
          forall a. a -> a -> a -> a -> V4 a
V4 (forall a. a -> a -> a -> a -> V4 a
V4 a
a a
b a
c a
0)
             (forall a. a -> a -> a -> a -> V4 a
V4 a
d a
e a
f a
0)
             (forall a. a -> a -> a -> a -> V4 a
V4 a
g a
h a
i a
0)
             (forall a. a -> a -> a -> a -> V4 a
V4 a
0 a
0 a
0 a
1)
    in
    forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"multmatrix"
      ((\Builder
x -> Builder
"["forall a. Semigroup a => a -> a -> a
<>Builder
xforall a. Semigroup a => a -> a -> a
<>Builder
"]") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse Builder
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ℝ -> Builder
bf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall {a}. Num a => V3 (V3 a) -> V4 (V4 a)
toM44 M33 ℝ
m))
      [SymbolicObj2 -> Reader ℝ Builder
buildS2 SymbolicObj2
obj]

buildS2 (Square (V2 w h)) = forall a.
Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
call Builder
"square" [ℝ -> Builder
bf w, ℝ -> Builder
bf h] []