-- 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 #-}

-- allow us to select what package to import what module from. We don't care, but our examples do.
{-# LANGUAGE PackageImports #-}

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

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

import Graphics.Implicit.Definitions(ℝ, SymbolicObj2(RectR, Circle, PolygonR, Complement2, UnionR2, DifferenceR2, IntersectR2, Translate2, Scale2, Rotate2, Outset2, Shell2, EmbedBoxedObj2), SymbolicObj3(Rect3R, Sphere, Cylinder, Complement3, UnionR3, IntersectR3, DifferenceR3, Translate3, Scale3, Rotate3, Rotate3V, Outset3, Shell3, ExtrudeR, ExtrudeRotateR, ExtrudeRM, EmbedBoxedObj3, RotateExtrude, ExtrudeOnEdgeOf))
import Graphics.Implicit.Export.TextBuilderUtils(Text, Builder, toLazyText, fromLazyText, bf)

import "monads-tf" Control.Monad.Reader (Reader, runReader, ask)

import Data.List (intersperse)
import Data.Function (fix)
import Data.Foldable(fold, foldMap)

default (ℝ)

scad2 :: ℝ -> SymbolicObj2 -> Text
scad2 res obj = toLazyText $ runReader (buildS2 obj) res

scad3 :: ℝ -> SymbolicObj3 -> Text
scad3 res obj = toLazyText $ runReader (buildS3 obj) res

-- used by rotate2 and rotate3
rad2deg :: ℝ -> ℝ
rad2deg r = r * (180/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 cs name args []    = pure $ name <> buildArgs cs args <> ";"
callToken cs name args [obj] = fmap ((name <> buildArgs cs args) <>) obj
callToken cs name args objs  = do
  objs' <- foldMap (<> "\n") <$> sequenceA objs
  pure $! name <> buildArgs cs args <> "{\n" <> objs' <> "}\n"

buildArgs :: (Text, Text) -> [Builder] -> Builder
buildArgs _ [] = "()"
buildArgs (c1, c2) args = "(" <> fromLazyText c1 <> fold (intersperse "," args) <> fromLazyText c2 <> ")"

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

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

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

buildS3 (Rect3R r (x1,y1,z1) (x2,y2,z2)) | r == 0 = call "translate" [bf x1, bf y1, bf z1] [
                                            call "cube" [bf $ x2 - x1, bf $ y2 - y1, bf $ z2 - z1] []
                                           ]

buildS3 (Sphere r) = callNaked "sphere" ["r = " <> bf r] []

buildS3 (Cylinder h r1 r2) = callNaked "cylinder" [
                              "r1 = " <> bf r1
                             ,"r2 = " <> bf r2
                             , bf h
                             ] []

buildS3 (Complement3 obj) = call "complement" [] [buildS3 obj]

buildS3 (UnionR3 r objs) | r == 0 = call "union" [] $ fmap buildS3 objs

buildS3 (IntersectR3 r objs) | r == 0 = call "intersection" [] $ fmap buildS3 objs

buildS3 (DifferenceR3 r objs) | r == 0 = call "difference" [] $ fmap buildS3 objs

buildS3 (Translate3 (x,y,z) obj) = call "translate" [bf x, bf y, bf z] [buildS3 obj]

buildS3 (Scale3 (x,y,z) obj) = call "scale" [bf x, bf y, bf z] [buildS3 obj]

buildS3 (Rotate3 (x,y,z) obj) = call "rotate" [bf (rad2deg x), bf (rad2deg y), bf (rad2deg z)] [buildS3 obj]

buildS3  Rotate3V{} = error "Rotate3V not implemented."

buildS3 (Outset3 r obj) | r == 0 = call "outset" [] [buildS3 obj]

buildS3 (Shell3 r obj) | r == 0 = call "shell" [] [buildS3 obj]

-- FIXME: where is EmbedBoxedObj3?

buildS3 (ExtrudeR r obj h) | r == 0 = callNaked "linear_extrude" ["height = " <> bf h] [buildS2 obj]

buildS3 (ExtrudeRotateR r twist obj h) | r == 0 = callNaked "linear_extrude" ["height = " <> bf h, "twist = " <> bf twist] [buildS2 obj]

-- FIXME: handle scale, center.
buildS3 (ExtrudeRM r twist (Left scale) (Left translate) obj (Left height)) | r == 0 && scale == 1 && translate == (0,0) = do
  res <- ask
  let
    twist' = case twist of
               Left twval  -> const twval
               Right twfun -> twfun
  call "union" [] [
             call "rotate" ["0","0", bf $ twist' h] [
                        callNaked "linear_extrude" ["height = " <> bf res, "twist = " <> bf (twist' (h+res) - twist' h)][
                                   buildS2 obj
                                  ]
                       ] |  h <- take (floor (res / height)) $ fix (\f x -> x : f (x+res)) 0
            ]

-- FIXME: where are RotateExtrude, ExtrudeOnEdgeOf?

buildS3 Rect3R{} = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS3(UnionR3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS3(IntersectR3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS3(DifferenceR3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS3(Outset3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS3(Shell3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS3 ExtrudeR{} = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS3 ExtrudeRotateR {} = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS3 ExtrudeRM{} = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS3(EmbedBoxedObj3 _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS3 RotateExtrude{} = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS3(ExtrudeOnEdgeOf _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."

-- Now the 2D objects/transforms.

buildS2 :: SymbolicObj2 -> Reader ℝ Builder

buildS2 (RectR r (x1,y1) (x2,y2)) | r == 0 = call "translate" [bf x1, bf y1] [
                                    call "cube" [bf $ x2 - x1, bf $ y2 - y1] []
                                   ]

buildS2 (Circle r) = call "circle" [bf r] []

buildS2 (PolygonR r points) | r == 0 = call "polygon" [buildVector [x,y] | (x,y) <- points] []
    where buildVector comps = "[" <> fold (intersperse "," $ fmap bf comps) <> "]"

buildS2 (Complement2 obj) = call "complement" [] [buildS2 obj]

buildS2 (UnionR2 r objs) | r == 0 = call "union" [] $ fmap buildS2 objs

buildS2 (DifferenceR2 r objs) | r == 0 = call "difference" [] $ fmap buildS2 objs

buildS2 (IntersectR2 r objs) | r == 0 = call "intersection" [] $ fmap buildS2 objs

buildS2 (Translate2 (x,y) obj) = call "translate" [bf x, bf y] [buildS2 obj]

buildS2 (Scale2 (x,y) obj)     = call "scale" [bf x, bf y] [buildS2 obj]

buildS2 (Rotate2 r obj)     = call "rotate" [bf (rad2deg r)] [buildS2 obj]

buildS2 (Outset2 r obj) | r == 0 = call "outset" [] [buildS2 obj]

buildS2 (Shell2 r obj) | r == 0 =  call "shell" [] [buildS2 obj]

-- Generate errors for rounding requests. OpenSCAD does not support rounding.
buildS2 RectR{} = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS2 (PolygonR _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS2 (UnionR2 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS2 (DifferenceR2 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS2 (IntersectR2 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS2 (Outset2 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
buildS2 (Shell2 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."

-- FIXME: missing EmbedBoxedObj2?
buildS2 (EmbedBoxedObj2 _) = error "EmbedBoxedObj2 not implemented."