{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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)
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
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)
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 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
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
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
"]"
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]
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]
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."
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]
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
]
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."
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] []