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

-- Required. FIXME: why?
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- required by makeWrapped
{-# LANGUAGE TypeOperators #-}

-- Definitions of the types used when modeling, and a few operators.
module Graphics.Implicit.Definitions (
    module F,
    module N,
    ℝ,
    ℝ2,
    ℝ3,
    ℝ3' (ℝ3'),
    minℝ,
    ComponentWiseMultable,
    (⋯*),
    (⋯/),
    Polyline(Polyline, getSegments),
    Polytri(Polytri),
    Triangle(Triangle),
    NormedTriangle(NormedTriangle),
    TriangleMesh(TriangleMesh, getTriangles),
    NormedTriangleMesh(NormedTriangleMesh, getNormedTriangles),
    Obj2,
    Obj3,
    Box2,
    Box3,
    Boxed2,
    Boxed3,
    BoxedObj2,
    BoxedObj3,
    SharedObj(..),
    V2(..),
    V3(..),
    SymbolicObj2(
        Square,
        Circle,
        Polygon,
        Rotate2,
        Transform2,
        Shared2),
    SymbolicObj3(
        Cube,
        Sphere,
        Cylinder,
        Rotate3,
        Transform3,
        Extrude,
        ExtrudeM,
        ExtrudeOnEdgeOf,
        RotateExtrude,
        Shared3),
    ExtrudeMScale(C1, C2, Fn),
    ObjectContext(..),
    defaultObjectContext,
    fromℕtoℝ,
    fromFastℕtoℝ,
    fromℝtoFloat,
    toScaleFn,
    isScaleID,
    quaternionToEuler,
    hasZeroComponent,
    )
where

import GHC.Generics (Generic)

import Prelude (Foldable, Num, Ord, Eq, atan2, asin, pi, (>=), signum, abs, (+), (-), RealFloat, (==), ($), flip, Semigroup((<>)), Monoid (mempty), Double, Either(Left, Right), Bool(True, False), (*), (/), fromIntegral, Float, realToFrac, (&&), RealFloat(isNaN), (||), any)

import Graphics.Implicit.FastIntUtil as F (Fastℕ(Fastℕ), fromFastℕ, toFastℕ)

import Graphics.Implicit.IntegralUtil as N (ℕ, fromℕ, toℕ)

import Control.DeepSeq (NFData, rnf)

import Linear (M33, M44, V2(V2), V3(V3))

import Linear.Quaternion (Quaternion(Quaternion))

import Control.Applicative (Applicative(liftA2))

import Text.Show.Combinators
    ( Show(showsPrec, show), (@|), showApp, showCon, PrecShowS)
import Control.Lens (makeWrapped)

-- | A type synonym for 'Double'. When used in the context of positions or
-- sizes, measured in units of millimeters. When used as in the context of
-- a rotation, measured in radians.
type ℝ = Double

-- | A pair of two 'Double's. When used as an area or position vector, measured
-- in millimeters squared.
type ℝ2 = V2 ℝ

-- | A triple of 'Double's. When used as a volume or position vector, measured
-- in millimeters cubed. When used as a rotation, interpreted as Euler angles
-- measured in radians.
type ℝ3 = V3 ℝ

-- ℝ3 except that we also check if values are NaN because those aren't
-- equal under the normal floating point equivalence.
newtype ℝ3' = ℝ3' (V3 ℝ)
$(makeWrapped ''ℝ3')
instance Eq ℝ3' where
  ℝ3' V3 ℝ
a == :: ℝ3' -> ℝ3' -> Bool
== ℝ3' V3 ℝ
b = V3 ℝ -> V3 ℝ -> Bool
eqNaNs V3 ℝ
a V3 ℝ
b

eqNaNs :: ℝ3 -> ℝ3 -> Bool
eqNaNs :: V3 ℝ -> V3 ℝ -> Bool
eqNaNs (V3 ℝ
a ℝ
b ℝ
c) (V3 ℝ
a' ℝ
b' ℝ
c') =
    forall a. RealFloat a => a -> a -> Bool
eqNaN ℝ
a ℝ
a' Bool -> Bool -> Bool
&& forall a. RealFloat a => a -> a -> Bool
eqNaN ℝ
b ℝ
b' Bool -> Bool -> Bool
&& forall a. RealFloat a => a -> a -> Bool
eqNaN ℝ
c ℝ
c'
eqNaN :: RealFloat a => a -> a -> Bool
eqNaN :: forall a. RealFloat a => a -> a -> Bool
eqNaN a
a a
b = (forall a. RealFloat a => a -> Bool
isNaN a
a Bool -> Bool -> Bool
&& forall a. RealFloat a => a -> Bool
isNaN a
b) Bool -> Bool -> Bool
|| (a
a forall a. Eq a => a -> a -> Bool
== a
b)

-- | A give up point for dividing ℝs, and for the maximum difference between abs(n) and abs(-n).
minℝ :: ℝ
-- for Doubles.
minℝ :: ℝ
minℝ = ℝ
0.0000000000000002
-- for Floats.
--minℝ = 0.00000011920928955078125 * 2

-- Wrap the functions that convert datatypes.

-- | Convert from our Integral to our Rational.
fromℕtoℝ :: ℕ -> ℝ
fromℕtoℝ :: ℕ -> ℝ
fromℕtoℝ = forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINABLE fromℕtoℝ #-}

-- | Convert from our Fast Integer (int32) to ℝ.
fromFastℕtoℝ :: Fastℕ -> ℝ
fromFastℕtoℝ :: Fastℕ -> ℝ
fromFastℕtoℝ (Fastℕ Int
a) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a
{-# INLINABLE fromFastℕtoℝ #-}

-- | Convert from our rational to a float, for output to a file.
fromℝtoFloat :: ℝ -> Float
fromℝtoFloat :: ℝ -> Float
fromℝtoFloat = forall a b. (Real a, Fractional b) => a -> b
realToFrac
{-# INLINABLE fromℝtoFloat #-}

-- TODO: Find a better way to do this?
-- | Add multiply and divide operators for two ℝ2s or ℝ3s.
class ComponentWiseMultable a where
    (⋯*) :: a -> a -> a
    (⋯/) :: a -> a -> a
instance ComponentWiseMultable ℝ2 where
    ⋯* :: ℝ2 -> ℝ2 -> ℝ2
(⋯*) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Num a => a -> a -> a
(*)
    {-# INLINABLE (⋯*) #-}
    ⋯/ :: ℝ2 -> ℝ2 -> ℝ2
(⋯/) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Fractional a => a -> a -> a
(/)
    {-# INLINABLE (⋯/) #-}
instance ComponentWiseMultable ℝ3 where
    ⋯* :: V3 ℝ -> V3 ℝ -> V3 ℝ
(⋯*) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Num a => a -> a -> a
(*)
    {-# INLINABLE (⋯*) #-}
    ⋯/ :: V3 ℝ -> V3 ℝ -> V3 ℝ
(⋯/) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Fractional a => a -> a -> a
(/)
    {-# INLINABLE (⋯/) #-}

-- | A chain of line segments, as in SVG or DXF.
-- eg. [(0,0), (0.5,1), (1,0)] ---> /\
-- FIXME: May not be empty. expose to type system.
newtype Polyline = Polyline { Polyline -> [ℝ2]
getSegments :: [ℝ2] }

-- | A triangle in 2D space (a,b,c).
newtype Polytri = Polytri (ℝ2, ℝ2, ℝ2)

-- | A triangle in 3D space (a,b,c) = a triangle with vertices a, b and c
newtype Triangle = Triangle (ℝ3, ℝ3, ℝ3)

-- | A triangle ((v1,n1),(v2,n2),(v3,n3)) has vertices v1, v2, v3
--   with corresponding normals n1, n2, and n3
newtype NormedTriangle = NormedTriangle ((ℝ3, ℝ3), (ℝ3, ℝ3), (ℝ3, ℝ3))

-- | A triangle mesh is a bunch of triangles, attempting to be a surface.
newtype TriangleMesh = TriangleMesh { TriangleMesh -> [Triangle]
getTriangles :: [Triangle] }

-- | A normed triangle mesh is a mesh of normed triangles.
newtype NormedTriangleMesh = NormedTriangleMesh { NormedTriangleMesh -> [NormedTriangle]
getNormedTriangles :: [NormedTriangle] }

instance NFData NormedTriangle where
  rnf :: NormedTriangle -> ()
rnf (NormedTriangle ((V3 ℝ
a, V3 ℝ
na), (V3 ℝ
b, V3 ℝ
nb), (V3 ℝ
c, V3 ℝ
nc))) = forall a. NFData a => a -> ()
rnf ((V3 ℝ
a, V3 ℝ
na), (V3 ℝ
b, V3 ℝ
nb), (V3 ℝ
c, V3 ℝ
nc))

instance NFData Triangle where
  rnf :: Triangle -> ()
rnf (Triangle (V3 ℝ
a,V3 ℝ
b,V3 ℝ
c)) = forall a. NFData a => a -> ()
rnf (V3 ℝ
a,V3 ℝ
b,V3 ℝ
c)

instance NFData TriangleMesh where
  rnf :: TriangleMesh -> ()
rnf (TriangleMesh [Triangle]
xs) = forall a. NFData a => a -> ()
rnf [Triangle]
xs

instance NFData Polytri where
  rnf :: Polytri -> ()
rnf (Polytri (ℝ2
a,ℝ2
b,ℝ2
c)) = forall a. NFData a => a -> ()
rnf (ℝ2
a,ℝ2
b,ℝ2
c)

instance NFData Polyline where
  rnf :: Polyline -> ()
rnf (Polyline [ℝ2]
xs) = forall a. NFData a => a -> ()
rnf [ℝ2]
xs

-- | A 2D object.
type Obj2 = (ℝ2 -> ℝ)

-- | A 3D object.
type Obj3 = (ℝ3 -> ℝ)

-- | A 2D box.
type Box2 = (ℝ2, ℝ2)

-- | A 3D box.
type Box3 = (ℝ3, ℝ3)

-- | A Box containing a 2D object.
type Boxed2 a = (a, Box2)

-- | A Box containing a 3D object.
type Boxed3 a = (a, Box3)

-- | A Boxed 2D object
type BoxedObj2 = Boxed2 Obj2
--instance Show BoxedObj2 where
--    show _ = "<BoxedObj2>"

-- | A Boxed 3D object
type BoxedObj3 = Boxed3 Obj3
--instance Show BoxedObj3 where
--    show _ = "<BoxedObj3>"

-- | Means of constructing symbolic objects that are common between the 2D and
-- 3D case. This type is parameterized on @obj@ and @vec@ so that
-- 'SymbolicObj2' and 'SymbolicObj3' can instantiate it for their own purposes.
data SharedObj obj f a
  = Empty  -- ^ The empty object
  | Full   -- ^ The entirely full object
  | Complement obj
  | UnionR ℝ [obj]
  | DifferenceR ℝ obj [obj]
  | IntersectR ℝ [obj]
  | Translate (f a) obj
  | Scale (f a) obj
  | Mirror (f a) obj -- ^ Mirror across the line whose normal is defined by the vector
  | Outset ℝ obj
  | Shell ℝ obj
  | EmbedBoxedObj (f a -> a, (f a, f a))
  | WithRounding ℝ obj
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall obj (f :: * -> *) a x.
Rep (SharedObj obj f a) x -> SharedObj obj f a
forall obj (f :: * -> *) a x.
SharedObj obj f a -> Rep (SharedObj obj f a) x
$cto :: forall obj (f :: * -> *) a x.
Rep (SharedObj obj f a) x -> SharedObj obj f a
$cfrom :: forall obj (f :: * -> *) a x.
SharedObj obj f a -> Rep (SharedObj obj f a) x
Generic)

instance (Show obj, Show (f a)) => Show (SharedObj obj f a) where
  showsPrec :: Int -> SharedObj obj f a -> ShowS
showsPrec = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ \case
     SharedObj obj f a
Empty                   -> String -> Int -> ShowS
showCon String
"emptySpace"
     SharedObj obj f a
Full                    -> String -> Int -> ShowS
showCon String
"fullSpace"
     Complement obj
obj          -> String -> Int -> ShowS
showCon String
"complement"   forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     UnionR ℝ
0 [obj]
l_obj          -> String -> Int -> ShowS
showCon String
"union"        forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [obj]
l_obj
     UnionR ℝ
r [obj]
l_obj          -> String -> Int -> ShowS
showCon String
"unionR"       forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [obj]
l_obj
     DifferenceR ℝ
0 obj
obj [obj]
l_obj -> String -> Int -> ShowS
showCon String
"difference"   forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [obj]
l_obj
     DifferenceR ℝ
r obj
obj [obj]
l_obj -> String -> Int -> ShowS
showCon String
"differenceR"  forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [obj]
l_obj
     IntersectR ℝ
0 [obj]
l_obj      -> String -> Int -> ShowS
showCon String
"intersect"    forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [obj]
l_obj
     IntersectR ℝ
r [obj]
l_obj      -> String -> Int -> ShowS
showCon String
"intersectR"   forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [obj]
l_obj
     Translate f a
vec obj
obj       -> String -> Int -> ShowS
showCon String
"translate"    forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| f a
vec forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     Scale f a
vec obj
obj           -> String -> Int -> ShowS
showCon String
"scale"        forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| f a
vec forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     Mirror f a
vec obj
obj          -> String -> Int -> ShowS
showCon String
"mirror"       forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| f a
vec forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     Outset ℝ
r obj
obj            -> String -> Int -> ShowS
showCon String
"outset"       forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     Shell ℝ
r obj
obj             -> String -> Int -> ShowS
showCon String
"shell"        forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     EmbedBoxedObj (f a -> a
_, (f a, f a)
box)  -> String -> Int -> ShowS
showCon String
"implicit"     forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| Blackhole
Blackhole forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| (f a, f a)
box
     WithRounding ℝ
r obj
obj      -> String -> Int -> ShowS
showCon String
"withRounding" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj

------------------------------------------------------------------------------
-- | A type whose show instance is a hole @_@. Used for giving 'Show' instances
-- to data types which contain functions or other unshowable things.
data Blackhole = Blackhole

instance Show Blackhole where
  show :: Blackhole -> String
show Blackhole
_ = String
"_"

newtype ObjectContext = ObjectContext
  { ObjectContext -> ℝ
objectRounding :: ℝ
  } deriving (ObjectContext -> ObjectContext -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ObjectContext -> ObjectContext -> Bool
$c/= :: ObjectContext -> ObjectContext -> Bool
== :: ObjectContext -> ObjectContext -> Bool
$c== :: ObjectContext -> ObjectContext -> Bool
Eq, Eq ObjectContext
ObjectContext -> ObjectContext -> Bool
ObjectContext -> ObjectContext -> Ordering
ObjectContext -> ObjectContext -> ObjectContext
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ObjectContext -> ObjectContext -> ObjectContext
$cmin :: ObjectContext -> ObjectContext -> ObjectContext
max :: ObjectContext -> ObjectContext -> ObjectContext
$cmax :: ObjectContext -> ObjectContext -> ObjectContext
>= :: ObjectContext -> ObjectContext -> Bool
$c>= :: ObjectContext -> ObjectContext -> Bool
> :: ObjectContext -> ObjectContext -> Bool
$c> :: ObjectContext -> ObjectContext -> Bool
<= :: ObjectContext -> ObjectContext -> Bool
$c<= :: ObjectContext -> ObjectContext -> Bool
< :: ObjectContext -> ObjectContext -> Bool
$c< :: ObjectContext -> ObjectContext -> Bool
compare :: ObjectContext -> ObjectContext -> Ordering
$ccompare :: ObjectContext -> ObjectContext -> Ordering
Ord, Int -> ObjectContext -> ShowS
[ObjectContext] -> ShowS
ObjectContext -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ObjectContext] -> ShowS
$cshowList :: [ObjectContext] -> ShowS
show :: ObjectContext -> String
$cshow :: ObjectContext -> String
showsPrec :: Int -> ObjectContext -> ShowS
$cshowsPrec :: Int -> ObjectContext -> ShowS
Show)

defaultObjectContext :: ObjectContext
defaultObjectContext :: ObjectContext
defaultObjectContext = ObjectContext
  { objectRounding :: ℝ
objectRounding = ℝ
0
  }

-- | A symbolic 2D object format.
--   We want to have symbolic objects so that we can
--   accelerate rendering & give ideal meshes for simple
--   cases.
data SymbolicObj2 =
    -- Primitives
      Square ℝ2     -- size.
    | Circle ℝ      -- radius.
    | Polygon [ℝ2]  -- points.
    -- Simple transforms
    | Rotate2 ℝ SymbolicObj2
    | Transform2 (M33 ℝ) SymbolicObj2
    -- Lifting common objects
    | Shared2 (SharedObj SymbolicObj2 V2 ℝ)
    deriving (forall x. Rep SymbolicObj2 x -> SymbolicObj2
forall x. SymbolicObj2 -> Rep SymbolicObj2 x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SymbolicObj2 x -> SymbolicObj2
$cfrom :: forall x. SymbolicObj2 -> Rep SymbolicObj2 x
Generic)

instance Show SymbolicObj2 where
  showsPrec :: Int -> SymbolicObj2 -> ShowS
showsPrec = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ \case
    -- NB: The False here is the centering argument, which has already been
    -- transformed into a translate. The 'Square' constructor itself is never
    -- centered.
    Square ℝ2
sz        -> String -> Int -> ShowS
showCon String
"square"     forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| Bool
False forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ2
sz
    Circle ℝ
r         -> String -> Int -> ShowS
showCon String
"circle"     forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r
    Polygon [ℝ2]
ps       -> String -> Int -> ShowS
showCon String
"polygon"    forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [ℝ2]
ps
    Rotate2 ℝ
v SymbolicObj2
obj    -> String -> Int -> ShowS
showCon String
"rotate"     forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
v     forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
obj
    Transform2 M33 ℝ
m SymbolicObj2
obj -> String -> Int -> ShowS
showCon String
"transform"  forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| M33 ℝ
m     forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
obj
    Shared2 SharedObj SymbolicObj2 V2 ℝ
obj   -> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Show a => Int -> a -> ShowS
showsPrec SharedObj SymbolicObj2 V2 ℝ
obj

-- | Semigroup under 'Graphic.Implicit.Primitives.union'.
instance Semigroup SymbolicObj2 where
  SymbolicObj2
a <> :: SymbolicObj2 -> SymbolicObj2 -> SymbolicObj2
<> SymbolicObj2
b = SharedObj SymbolicObj2 V2 ℝ -> SymbolicObj2
Shared2 (forall obj (f :: * -> *) a. ℝ -> [obj] -> SharedObj obj f a
UnionR ℝ
0 [SymbolicObj2
a, SymbolicObj2
b])

-- | Monoid under 'Graphic.Implicit.Primitives.union'.
instance Monoid SymbolicObj2 where
  mempty :: SymbolicObj2
mempty = SharedObj SymbolicObj2 V2 ℝ -> SymbolicObj2
Shared2 forall obj (f :: * -> *) a. SharedObj obj f a
Empty

-- | A symbolic 3D format!
data SymbolicObj3 =
    -- Primitives
      Cube ℝ3 -- rounding, size.
    | Sphere ℝ -- radius
    | Cylinder ℝ ℝ ℝ --
    -- Simple transforms
    | Rotate3 (Quaternion ℝ) SymbolicObj3
    | Transform3 (M44 ℝ) SymbolicObj3
    -- 2D based
    | Extrude SymbolicObj2 ℝ
    | ExtrudeM
        (Either ℝ (ℝ -> ℝ))   -- twist
        ExtrudeMScale         -- scale
        (Either ℝ2 (ℝ -> ℝ2)) -- translate
        SymbolicObj2          -- object to extrude
        (Either ℝ (ℝ2 -> ℝ))  -- height to extrude to
    | RotateExtrude
        ℝ                     -- Angle to sweep to
        (Either ℝ2 (ℝ -> ℝ2)) -- translate
        (Either ℝ  (ℝ -> ℝ )) -- rotate
        SymbolicObj2          -- object to extrude
    | ExtrudeOnEdgeOf SymbolicObj2 SymbolicObj2
    | Shared3 (SharedObj SymbolicObj3 V3 ℝ)
    deriving (forall x. Rep SymbolicObj3 x -> SymbolicObj3
forall x. SymbolicObj3 -> Rep SymbolicObj3 x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SymbolicObj3 x -> SymbolicObj3
$cfrom :: forall x. SymbolicObj3 -> Rep SymbolicObj3 x
Generic)

instance Show SymbolicObj3 where
  showsPrec :: Int -> SymbolicObj3 -> ShowS
showsPrec = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ \case
    -- NB: The False here is the centering argument, which has already been
    -- transformed into a translate. The 'Cube' constructor itself is never
    -- centered.
    Cube V3 ℝ
sz -> String -> Int -> ShowS
showCon String
"cube" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| Bool
False forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| V3 ℝ
sz
    Sphere ℝ
d -> String -> Int -> ShowS
showCon String
"sphere" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
d
    -- NB: The arguments to 'Cylinder' are backwards compared to 'cylinder' and
    -- 'cylinder2'.
    Cylinder ℝ
h ℝ
r1 ℝ
r2 | ℝ
r1 forall a. Eq a => a -> a -> Bool
== ℝ
r2 ->
      String -> Int -> ShowS
showCon String
"cylinder" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r1 forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
h
    Cylinder ℝ
h ℝ
r1 ℝ
r2 ->
      String -> Int -> ShowS
showCon String
"cylinder2" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r1 forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r2 forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
h
    Rotate3 Quaternion ℝ
qd SymbolicObj3
s -> String -> Int -> ShowS
showCon String
"rotate3" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| forall a. RealFloat a => Quaternion a -> V3 a
quaternionToEuler Quaternion ℝ
qd forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj3
s
    Transform3 M44 ℝ
m SymbolicObj3
s -> String -> Int -> ShowS
showCon String
"transform3" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| M44 ℝ
m forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj3
s
    Extrude SymbolicObj2
s ℝ
d2 -> String -> Int -> ShowS
showCon String
"extrude" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
s forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
d2
    ExtrudeM Either ℝ (ℝ -> ℝ)
edfdd ExtrudeMScale
e Either ℝ2 (ℝ -> ℝ2)
ep_ddfdp_dd SymbolicObj2
s Either ℝ (ℝ2 -> ℝ)
edfp_ddd ->
      String -> Int -> ShowS
showCon String
"extrudeM" forall a b c.
Show a =>
(Int -> ShowS) -> Either a (b -> c) -> Int -> ShowS
@|| Either ℝ (ℝ -> ℝ)
edfdd forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ExtrudeMScale
e forall a b c.
Show a =>
(Int -> ShowS) -> Either a (b -> c) -> Int -> ShowS
@|| Either ℝ2 (ℝ -> ℝ2)
ep_ddfdp_dd forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
s forall a b c.
Show a =>
(Int -> ShowS) -> Either a (b -> c) -> Int -> ShowS
@|| Either ℝ (ℝ2 -> ℝ)
edfp_ddd
    RotateExtrude ℝ
d Either ℝ2 (ℝ -> ℝ2)
ep_ddfdp_dd Either ℝ (ℝ -> ℝ)
edfdd SymbolicObj2
s ->
      String -> Int -> ShowS
showCon String
"rotateExtrude" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
d forall a b c.
Show a =>
(Int -> ShowS) -> Either a (b -> c) -> Int -> ShowS
@|| Either ℝ2 (ℝ -> ℝ2)
ep_ddfdp_dd forall a b c.
Show a =>
(Int -> ShowS) -> Either a (b -> c) -> Int -> ShowS
@|| Either ℝ (ℝ -> ℝ)
edfdd forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
s
    ExtrudeOnEdgeOf SymbolicObj2
s SymbolicObj2
s1 ->
      String -> Int -> ShowS
showCon String
"extrudeOnEdgeOf" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
s forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
s1
    Shared3 SharedObj SymbolicObj3 V3 ℝ
s -> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Show a => Int -> a -> ShowS
showsPrec SharedObj SymbolicObj3 V3 ℝ
s

infixl 2 @||
------------------------------------------------------------------------------
-- | ImplicitCAD uses the pattern @Either a (b -> c)@ for many of its
-- higher-order arguments. The left case is for constant values, but the right
-- side is for things that should vary. Since we can't show functions, ths
-- combinator works like '(@|)' except that it shows the left case and uses
-- a hole for the right.
(@||) :: Show a => PrecShowS -> Either a (b -> c) -> PrecShowS
Int -> ShowS
showF @|| :: forall a b c.
Show a =>
(Int -> ShowS) -> Either a (b -> c) -> Int -> ShowS
@|| Either a (b -> c)
x = (Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
showApp Int -> ShowS
showF forall a b. (a -> b) -> a -> b
$ case Either a (b -> c)
x of
  Left a
a  -> String -> Int -> ShowS
showCon String
"Left" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| a
a
  Right b -> c
_ -> String -> Int -> ShowS
showCon String
"Right" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| Blackhole
Blackhole

-- | Semigroup under 'Graphic.Implicit.Primitives.union'.
instance Semigroup SymbolicObj3 where
  SymbolicObj3
a <> :: SymbolicObj3 -> SymbolicObj3 -> SymbolicObj3
<> SymbolicObj3
b = SharedObj SymbolicObj3 V3 ℝ -> SymbolicObj3
Shared3 (forall obj (f :: * -> *) a. ℝ -> [obj] -> SharedObj obj f a
UnionR ℝ
0 [SymbolicObj3
a, SymbolicObj3
b])

-- | Monoid under 'Graphic.Implicit.Primitives.union'.
instance Monoid SymbolicObj3 where
  mempty :: SymbolicObj3
mempty = SharedObj SymbolicObj3 V3 ℝ -> SymbolicObj3
Shared3 forall obj (f :: * -> *) a. SharedObj obj f a
Empty

data ExtrudeMScale =
      C1 ℝ                  -- constant ℝ
    | C2 ℝ2                 -- constant ℝ2
    | Fn (ℝ -> Either ℝ ℝ2) -- function mapping height to either ℝ or ℝ2
    deriving (forall x. Rep ExtrudeMScale x -> ExtrudeMScale
forall x. ExtrudeMScale -> Rep ExtrudeMScale x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ExtrudeMScale x -> ExtrudeMScale
$cfrom :: forall x. ExtrudeMScale -> Rep ExtrudeMScale x
Generic)

instance Show ExtrudeMScale where
  showsPrec :: Int -> ExtrudeMScale -> ShowS
showsPrec = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ \case
    C1 ℝ
r  -> String -> Int -> ShowS
showCon String
"C1" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r
    C2 ℝ2
r2 -> String -> Int -> ShowS
showCon String
"C2" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ2
r2
    Fn ℝ -> Either ℝ ℝ2
_  -> String -> Int -> ShowS
showCon String
"Fn" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| Blackhole
Blackhole

toScaleFn :: ExtrudeMScale -> ℝ -> ℝ2
toScaleFn :: ExtrudeMScale -> ℝ -> ℝ2
toScaleFn (C1 ℝ
s) ℝ
_ = forall a. a -> a -> V2 a
V2 ℝ
s ℝ
s
toScaleFn (C2 ℝ2
s) ℝ
_ = ℝ2
s
toScaleFn (Fn ℝ -> Either ℝ ℝ2
f) ℝ
z = case ℝ -> Either ℝ ℝ2
f ℝ
z of
    Left ℝ
s -> forall a. a -> a -> V2 a
V2 ℝ
s ℝ
s
    Right ℝ2
s -> ℝ2
s

isScaleID :: ExtrudeMScale -> Bool
isScaleID :: ExtrudeMScale -> Bool
isScaleID (C1 ℝ
1) = Bool
True
isScaleID (C2 (V2 ℝ
1 ℝ
1)) = Bool
True
isScaleID ExtrudeMScale
_ = Bool
False

-- | Convert a 'Quaternion' to its constituent euler angles.
--
-- From https://en.wikipedia.org/wiki/Conversion_between_quaternions_and_Euler_angles#Source_code_2
quaternionToEuler :: RealFloat a => Quaternion a -> V3 a
quaternionToEuler :: forall a. RealFloat a => Quaternion a -> V3 a
quaternionToEuler (Quaternion a
w (V3 a
x a
y a
z))=
  let sinr_cosp :: a
sinr_cosp = a
2 forall a. Num a => a -> a -> a
* (a
w forall a. Num a => a -> a -> a
* a
x forall a. Num a => a -> a -> a
+ a
y forall a. Num a => a -> a -> a
* a
z)
      cosr_cosp :: a
cosr_cosp = a
1 forall a. Num a => a -> a -> a
- a
2 forall a. Num a => a -> a -> a
* (a
x forall a. Num a => a -> a -> a
* a
x forall a. Num a => a -> a -> a
+ a
y forall a. Num a => a -> a -> a
* a
y)
      sinp :: a
sinp = a
2 forall a. Num a => a -> a -> a
* (a
w forall a. Num a => a -> a -> a
* a
y forall a. Num a => a -> a -> a
- a
z forall a. Num a => a -> a -> a
* a
x);
      siny_cosp :: a
siny_cosp = a
2 forall a. Num a => a -> a -> a
* (a
w forall a. Num a => a -> a -> a
* a
z forall a. Num a => a -> a -> a
+ a
x forall a. Num a => a -> a -> a
* a
y);
      cosy_cosp :: a
cosy_cosp = a
1 forall a. Num a => a -> a -> a
- a
2 forall a. Num a => a -> a -> a
* (a
y forall a. Num a => a -> a -> a
* a
y forall a. Num a => a -> a -> a
+ a
z forall a. Num a => a -> a -> a
* a
z);
      pitch :: a
pitch = if forall a. Num a => a -> a
abs a
sinp forall a. Ord a => a -> a -> Bool
>= a
1
              then forall a. Num a => a -> a
signum a
sinp forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi forall a. Fractional a => a -> a -> a
/ a
2
              else forall a. Floating a => a -> a
asin a
sinp
      roll :: a
roll = forall a. RealFloat a => a -> a -> a
atan2 a
sinr_cosp a
cosr_cosp
      yaw :: a
yaw = forall a. RealFloat a => a -> a -> a
atan2 a
siny_cosp a
cosy_cosp
   in forall a. a -> a -> a -> V3 a
V3 a
roll a
pitch a
yaw
{-# INLINABLE quaternionToEuler #-}

-- | Returns True if any component of a foldable functor is zero
hasZeroComponent
    :: (Foldable f, Num a, Eq a)
    => f a
    -> Bool
{-# INLINABLE hasZeroComponent #-}
hasZeroComponent :: forall (f :: * -> *) a. (Foldable f, Num a, Eq a) => f a -> Bool
hasZeroComponent =  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
==a
0)