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

-- Definitions of the types used when modeling, and a few operators.
module Graphics.Implicit.Definitions (
    module F,
    module N,
    ℝ,
    ℝ2,
    ℝ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,
    )
where

import GHC.Generics (Generic)

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

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)

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

-- | 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) = Int -> ℝ
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 = ℝ -> Float
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
(⋯*) = (ℝ -> ℝ -> ℝ) -> ℝ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
(⋯/) = (ℝ -> ℝ -> ℝ) -> ℝ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
    ⋯* :: ℝ3 -> ℝ3 -> ℝ3
(⋯*) = (ℝ -> ℝ -> ℝ) -> ℝ3 -> ℝ3 -> ℝ3
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 (⋯*) #-}
    ⋯/ :: ℝ3 -> ℝ3 -> ℝ3
(⋯/) = (ℝ -> ℝ -> ℝ) -> ℝ3 -> ℝ3 -> ℝ3
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 ((ℝ3
a, ℝ3
na), (ℝ3
b, ℝ3
nb), (ℝ3
c, ℝ3
nc))) = ((ℝ3, ℝ3), (ℝ3, ℝ3), (ℝ3, ℝ3)) -> ()
forall a. NFData a => a -> ()
rnf ((ℝ3
a, ℝ3
na), (ℝ3
b, ℝ3
nb), (ℝ3
c, ℝ3
nc))

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

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

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

instance NFData Polyline where
  rnf :: Polyline -> ()
rnf (Polyline [ℝ2]
xs) = [ℝ2] -> ()
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 x. SharedObj obj f a -> Rep (SharedObj obj f a) x)
-> (forall x. Rep (SharedObj obj f a) x -> SharedObj obj f a)
-> Generic (SharedObj obj f a)
forall x. Rep (SharedObj obj f a) x -> SharedObj obj f a
forall x. SharedObj obj f a -> Rep (SharedObj obj f a) x
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 = (SharedObj obj f a -> Int -> ShowS)
-> Int -> SharedObj obj f a -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SharedObj obj f a -> Int -> ShowS)
 -> Int -> SharedObj obj f a -> ShowS)
-> (SharedObj obj f a -> Int -> ShowS)
-> Int
-> SharedObj obj f a
-> ShowS
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"   (Int -> ShowS) -> obj -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     UnionR ℝ
0 [obj]
l_obj          -> String -> Int -> ShowS
showCon String
"union"        (Int -> ShowS) -> [obj] -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [obj]
l_obj
     UnionR ℝ
r [obj]
l_obj          -> String -> Int -> ShowS
showCon String
"unionR"       (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   (Int -> ShowS) -> [obj] -> Int -> ShowS
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"   (Int -> ShowS) -> obj -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj (Int -> ShowS) -> [obj] -> Int -> ShowS
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"  (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   (Int -> ShowS) -> obj -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj (Int -> ShowS) -> [obj] -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [obj]
l_obj
     IntersectR ℝ
0 [obj]
l_obj      -> String -> Int -> ShowS
showCon String
"intersect"    (Int -> ShowS) -> [obj] -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [obj]
l_obj
     IntersectR ℝ
r [obj]
l_obj      -> String -> Int -> ShowS
showCon String
"intersectR"   (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   (Int -> ShowS) -> [obj] -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [obj]
l_obj
     Translate f a
vec obj
obj       -> String -> Int -> ShowS
showCon String
"translate"    (Int -> ShowS) -> f a -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| f a
vec (Int -> ShowS) -> obj -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     Scale f a
vec obj
obj           -> String -> Int -> ShowS
showCon String
"scale"        (Int -> ShowS) -> f a -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| f a
vec (Int -> ShowS) -> obj -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     Mirror f a
vec obj
obj          -> String -> Int -> ShowS
showCon String
"mirror"       (Int -> ShowS) -> f a -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| f a
vec (Int -> ShowS) -> obj -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     Outset ℝ
r obj
obj            -> String -> Int -> ShowS
showCon String
"outset"       (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   (Int -> ShowS) -> obj -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     Shell ℝ
r obj
obj             -> String -> Int -> ShowS
showCon String
"shell"        (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   (Int -> ShowS) -> obj -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| obj
obj
     EmbedBoxedObj (f a -> a, (f a, f a))
_         -> String -> Int -> ShowS
showCon String
"implicit"     (Int -> ShowS) -> Blackhole -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| Blackhole
Blackhole
     WithRounding ℝ
r obj
obj      -> String -> Int -> ShowS
showCon String
"withRounding" (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r   (Int -> ShowS) -> obj -> Int -> ShowS
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
(ObjectContext -> ObjectContext -> Bool)
-> (ObjectContext -> ObjectContext -> Bool) -> Eq ObjectContext
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
Eq ObjectContext
-> (ObjectContext -> ObjectContext -> Ordering)
-> (ObjectContext -> ObjectContext -> Bool)
-> (ObjectContext -> ObjectContext -> Bool)
-> (ObjectContext -> ObjectContext -> Bool)
-> (ObjectContext -> ObjectContext -> Bool)
-> (ObjectContext -> ObjectContext -> ObjectContext)
-> (ObjectContext -> ObjectContext -> ObjectContext)
-> Ord 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
$cp1Ord :: Eq ObjectContext
Ord, Int -> ObjectContext -> ShowS
[ObjectContext] -> ShowS
ObjectContext -> String
(Int -> ObjectContext -> ShowS)
-> (ObjectContext -> String)
-> ([ObjectContext] -> ShowS)
-> Show ObjectContext
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 :: ℝ -> ObjectContext
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. SymbolicObj2 -> Rep SymbolicObj2 x)
-> (forall x. Rep SymbolicObj2 x -> SymbolicObj2)
-> Generic SymbolicObj2
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 = (SymbolicObj2 -> Int -> ShowS) -> Int -> SymbolicObj2 -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SymbolicObj2 -> Int -> ShowS) -> Int -> SymbolicObj2 -> ShowS)
-> (SymbolicObj2 -> Int -> ShowS) -> Int -> SymbolicObj2 -> ShowS
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"     (Int -> ShowS) -> Bool -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| Bool
False (Int -> ShowS) -> ℝ2 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ2
sz
    Circle ℝ
r         -> String -> Int -> ShowS
showCon String
"circle"     (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r
    Polygon [ℝ2]
ps       -> String -> Int -> ShowS
showCon String
"polygon"    (Int -> ShowS) -> [ℝ2] -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| [ℝ2]
ps
    Rotate2 ℝ
v SymbolicObj2
obj    -> String -> Int -> ShowS
showCon String
"rotate"     (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
v     (Int -> ShowS) -> SymbolicObj2 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
obj
    Transform2 M33 ℝ
m SymbolicObj2
obj -> String -> Int -> ShowS
showCon String
"transform2" (Int -> ShowS) -> M33 ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| M33 ℝ
m     (Int -> ShowS) -> SymbolicObj2 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
obj
    Shared2 SharedObj SymbolicObj2 V2 ℝ
obj   -> (Int -> SharedObj SymbolicObj2 V2 ℝ -> ShowS)
-> SharedObj SymbolicObj2 V2 ℝ -> Int -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> SharedObj SymbolicObj2 V2 ℝ -> ShowS
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 (ℝ -> [SymbolicObj2] -> SharedObj SymbolicObj2 V2 ℝ
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 SharedObj SymbolicObj2 V2 ℝ
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. SymbolicObj3 -> Rep SymbolicObj3 x)
-> (forall x. Rep SymbolicObj3 x -> SymbolicObj3)
-> Generic SymbolicObj3
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 = (SymbolicObj3 -> Int -> ShowS) -> Int -> SymbolicObj3 -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SymbolicObj3 -> Int -> ShowS) -> Int -> SymbolicObj3 -> ShowS)
-> (SymbolicObj3 -> Int -> ShowS) -> Int -> SymbolicObj3 -> ShowS
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 ℝ3
sz -> String -> Int -> ShowS
showCon String
"cube" (Int -> ShowS) -> Bool -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| Bool
False (Int -> ShowS) -> ℝ3 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ3
sz
    Sphere ℝ
d -> String -> Int -> ShowS
showCon String
"sphere" (Int -> ShowS) -> ℝ -> Int -> ShowS
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 ℝ -> ℝ -> Bool
forall a. Eq a => a -> a -> Bool
== ℝ
r2 ->
      String -> Int -> ShowS
showCon String
"cylinder" (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r1 (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
h
    Cylinder ℝ
h ℝ
r1 ℝ
r2 ->
      String -> Int -> ShowS
showCon String
"cylinder2" (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r1 (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r2 (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
h
    Rotate3 Quaternion ℝ
qd SymbolicObj3
s -> String -> Int -> ShowS
showCon String
"rotate3" (Int -> ShowS) -> (ℝ, ℝ, ℝ) -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| Quaternion ℝ -> (ℝ, ℝ, ℝ)
forall a. RealFloat a => Quaternion a -> (a, a, a)
quaternionToEuler Quaternion ℝ
qd (Int -> ShowS) -> SymbolicObj3 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj3
s
    Transform3 M44 ℝ
m SymbolicObj3
s -> String -> Int -> ShowS
showCon String
"transform3" (Int -> ShowS) -> String -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| M44 ℝ -> String
forall a. Show a => a -> String
show M44 ℝ
m (Int -> ShowS) -> SymbolicObj3 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj3
s
    Extrude SymbolicObj2
s ℝ
d2 -> String -> Int -> ShowS
showCon String
"extrude" (Int -> ShowS) -> SymbolicObj2 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
s (Int -> ShowS) -> ℝ -> Int -> ShowS
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" (Int -> ShowS) -> Either ℝ (ℝ -> ℝ) -> Int -> ShowS
forall a b c.
Show a =>
(Int -> ShowS) -> Either a (b -> c) -> Int -> ShowS
@|| Either ℝ (ℝ -> ℝ)
edfdd (Int -> ShowS) -> ExtrudeMScale -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ExtrudeMScale
e (Int -> ShowS) -> Either ℝ2 (ℝ -> ℝ2) -> Int -> ShowS
forall a b c.
Show a =>
(Int -> ShowS) -> Either a (b -> c) -> Int -> ShowS
@|| Either ℝ2 (ℝ -> ℝ2)
ep_ddfdp_dd (Int -> ShowS) -> SymbolicObj2 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
s (Int -> ShowS) -> Either ℝ (ℝ2 -> ℝ) -> Int -> ShowS
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" (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
d (Int -> ShowS) -> Either ℝ2 (ℝ -> ℝ2) -> Int -> ShowS
forall a b c.
Show a =>
(Int -> ShowS) -> Either a (b -> c) -> Int -> ShowS
@|| Either ℝ2 (ℝ -> ℝ2)
ep_ddfdp_dd (Int -> ShowS) -> Either ℝ (ℝ -> ℝ) -> Int -> ShowS
forall a b c.
Show a =>
(Int -> ShowS) -> Either a (b -> c) -> Int -> ShowS
@|| Either ℝ (ℝ -> ℝ)
edfdd (Int -> ShowS) -> SymbolicObj2 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
s
    ExtrudeOnEdgeOf SymbolicObj2
s SymbolicObj2
s1 ->
      String -> Int -> ShowS
showCon String
"extrudeOnEdgeOf" (Int -> ShowS) -> SymbolicObj2 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
s (Int -> ShowS) -> SymbolicObj2 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| SymbolicObj2
s1
    Shared3 SharedObj SymbolicObj3 V3 ℝ
s -> (Int -> SharedObj SymbolicObj3 V3 ℝ -> ShowS)
-> SharedObj SymbolicObj3 V3 ℝ -> Int -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> SharedObj SymbolicObj3 V3 ℝ -> ShowS
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 @|| :: (Int -> ShowS) -> Either a (b -> c) -> Int -> ShowS
@|| Either a (b -> c)
x = (Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
showApp Int -> ShowS
showF ((Int -> ShowS) -> Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
forall a b. (a -> b) -> a -> b
$ case Either a (b -> c)
x of
  Left a
a  -> String -> Int -> ShowS
showCon String
"Left" (Int -> ShowS) -> a -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| a
a
  Right b -> c
_ -> String -> Int -> ShowS
showCon String
"Right" (Int -> ShowS) -> Blackhole -> Int -> ShowS
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 (ℝ -> [SymbolicObj3] -> SharedObj SymbolicObj3 V3 ℝ
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 SharedObj SymbolicObj3 V3 ℝ
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. ExtrudeMScale -> Rep ExtrudeMScale x)
-> (forall x. Rep ExtrudeMScale x -> ExtrudeMScale)
-> Generic ExtrudeMScale
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 = (ExtrudeMScale -> Int -> ShowS) -> Int -> ExtrudeMScale -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ExtrudeMScale -> Int -> ShowS) -> Int -> ExtrudeMScale -> ShowS)
-> (ExtrudeMScale -> Int -> ShowS) -> Int -> ExtrudeMScale -> ShowS
forall a b. (a -> b) -> a -> b
$ \case
    C1 ℝ
r  -> String -> Int -> ShowS
showCon String
"C1" (Int -> ShowS) -> ℝ -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ
r
    C2 ℝ2
r2 -> String -> Int -> ShowS
showCon String
"C2" (Int -> ShowS) -> ℝ2 -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| ℝ2
r2
    Fn ℝ -> Either ℝ ℝ2
_  -> String -> Int -> ShowS
showCon String
"Fn" (Int -> ShowS) -> Blackhole -> Int -> ShowS
forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| Blackhole
Blackhole

toScaleFn :: ExtrudeMScale -> ℝ -> ℝ2
toScaleFn :: ExtrudeMScale -> ℝ -> ℝ2
toScaleFn (C1 ℝ
s) ℝ
_ = ℝ -> ℝ -> ℝ2
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 -> ℝ -> ℝ -> ℝ2
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 -> (a, a, a)
quaternionToEuler :: Quaternion a -> (a, a, a)
quaternionToEuler (Quaternion a
w (V3 a
x a
y a
z))=
  let sinr_cosp :: a
sinr_cosp = a
2 a -> a -> a
forall a. Num a => a -> a -> a
* (a
w a -> a -> a
forall a. Num a => a -> a -> a
* a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
y a -> a -> a
forall a. Num a => a -> a -> a
* a
z)
      cosr_cosp :: a
cosr_cosp = a
1 a -> a -> a
forall a. Num a => a -> a -> a
- a
2 a -> a -> a
forall a. Num a => a -> a -> a
* (a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
y a -> a -> a
forall a. Num a => a -> a -> a
* a
y)
      sinp :: a
sinp = a
2 a -> a -> a
forall a. Num a => a -> a -> a
* (a
w a -> a -> a
forall a. Num a => a -> a -> a
* a
y a -> a -> a
forall a. Num a => a -> a -> a
- a
z a -> a -> a
forall a. Num a => a -> a -> a
* a
x);
      siny_cosp :: a
siny_cosp = a
2 a -> a -> a
forall a. Num a => a -> a -> a
* (a
w a -> a -> a
forall a. Num a => a -> a -> a
* a
z a -> a -> a
forall a. Num a => a -> a -> a
+ a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
y);
      cosy_cosp :: a
cosy_cosp = a
1 a -> a -> a
forall a. Num a => a -> a -> a
- a
2 a -> a -> a
forall a. Num a => a -> a -> a
* (a
y a -> a -> a
forall a. Num a => a -> a -> a
* a
y a -> a -> a
forall a. Num a => a -> a -> a
+ a
z a -> a -> a
forall a. Num a => a -> a -> a
* a
z);
      pitch :: a
pitch = if a -> a
forall a. Num a => a -> a
abs a
sinp a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
1
              then a -> a
forall a. Num a => a -> a
signum a
sinp a -> a -> a
forall a. Num a => a -> a -> a
* a
forall a. Floating a => a
pi a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
2
              else a -> a
forall a. Floating a => a -> a
asin a
sinp
      roll :: a
roll = a -> a -> a
forall a. RealFloat a => a -> a -> a
atan2 a
sinr_cosp a
cosr_cosp
      yaw :: a
yaw = a -> a -> a
forall a. RealFloat a => a -> a -> a
atan2 a
siny_cosp a
cosy_cosp
   in (a
roll, a
pitch, a
yaw)