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

-- | This module implements canonicalization pass that
-- * eliminates identities
-- * merges consecutive transformations like transform . transform into one
-- * prevents invalid transformations like scaling by zero that would
--   otherwise result in NaNs down the pipe
-- * turns degenerate objects into empty space (i.e. circle 0, cube (pure 0))

{-# LANGUAGE Rank2Types #-}
-- pattern Shared
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

module Graphics.Implicit.Canon
  ( canonicalize2
  , canonicalize3
  , fmapObj2
  , fmapObj3
  , fmapSharedObj
  , rewriteUntilIrreducible
  , EqObj((=^=))
  ) where

import Linear
  ( V2(V2)
  , V3(V3)
  , V4(V4)
  )

import Prelude
  ( Bool
      ( False
      , True
      )
  , Either(Left)
  , Eq((==))
  , Maybe(Just)
  , Num
      ( (*)
      , (+)
      )
  , Ord((<))
  , length
  , ($)
  , (&&)
  , (<$>)
  )

import Graphics.Implicit.Definitions
  ( ExtrudeMScale
      ( C1
      , C2
      , Fn
      )
  , SharedObj
      ( Complement
      , DifferenceR
      , EmbedBoxedObj
      , Empty
      , Full
      , IntersectR
      , Mirror
      , Outset
      , Scale
      , Shell
      , Translate
      , UnionR
      , WithRounding
      )
  , SymbolicObj2
      ( Circle
      , Polygon
      , Rotate2
      , Shared2
      , Square
      , Transform2
      )
  , SymbolicObj3
      ( Cube
      , Cylinder
      , Extrude
      , ExtrudeM
      , ExtrudeOnEdgeOf
      , Rotate3
      , RotateExtrude
      , Shared3
      , Sphere
      , Transform3
      )
  , hasZeroComponent
  )
import {-# SOURCE #-} Graphics.Implicit.Primitives
  ( Object(_Shared)
  , emptySpace
  , fullSpace
  )

import Control.Lens
  ( preview
  , (#)
  )

-- | A pattern that abstracts over 'Shared2' and 'Shared3'.
-- Can't be in hs-boot https://gitlab.haskell.org/ghc/ghc/-/issues/14478
-- so we duplicate it here
pattern Shared :: (Object obj f a) => SharedObj obj f a -> obj
pattern $bShared :: forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
$mShared :: forall {r} {obj} {f :: * -> *} {a}.
Object obj f a =>
obj -> (SharedObj obj f a -> r) -> ((# #) -> r) -> r
Shared v <- (preview _Shared -> Just v)
  where
    Shared SharedObj obj f a
v = forall obj (f :: * -> *) a.
Object obj f a =>
Prism' obj (SharedObj obj f a)
_Shared forall t b. AReview t b -> b -> t
# SharedObj obj f a
v

-- | Map over @SharedObj@ and its underlying objects
--
-- This resembles bimap from Bifunctor but the structure
-- of SharedObj doesn't allow us to define Bifunctor instance
-- as we need to map over the first type argument (obj) and not f and a.
fmapSharedObj
  :: forall obj f a
   . (Object obj f a)
  => (obj -> obj)
  -> (obj -> obj)
  -> obj
  -> obj
{-# INLINABLE fmapSharedObj #-}
fmapSharedObj :: forall obj (f :: * -> *) a.
Object obj f a =>
(obj -> obj) -> (obj -> obj) -> obj -> obj
fmapSharedObj obj -> obj
_ obj -> obj
g (Shared SharedObj obj f a
Empty) = obj -> obj
g forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
fmapSharedObj obj -> obj
_ obj -> obj
g (Shared SharedObj obj f a
Full) = obj -> obj
g forall obj (f :: * -> *) a. Object obj f a => obj
fullSpace
fmapSharedObj obj -> obj
f obj -> obj
g (Shared (Complement obj
o)) = obj -> obj
g forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. obj -> SharedObj obj f a
Complement (obj -> obj
f obj
o)
fmapSharedObj obj -> obj
f obj -> obj
g (Shared (UnionR ℝ
r [obj]
os)) = obj -> obj
g forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. ℝ -> [obj] -> SharedObj obj f a
UnionR ℝ
r forall a b. (a -> b) -> a -> b
$ obj -> obj
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [obj]
os
fmapSharedObj obj -> obj
f obj -> obj
g (Shared (DifferenceR ℝ
r obj
o [obj]
os)) = obj -> obj
g forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. ℝ -> obj -> [obj] -> SharedObj obj f a
DifferenceR ℝ
r (obj -> obj
f obj
o) forall a b. (a -> b) -> a -> b
$ obj -> obj
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [obj]
os
fmapSharedObj obj -> obj
f obj -> obj
g (Shared (IntersectR ℝ
r [obj]
os)) = obj -> obj
g forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. ℝ -> [obj] -> SharedObj obj f a
IntersectR ℝ
r forall a b. (a -> b) -> a -> b
$ obj -> obj
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [obj]
os
fmapSharedObj obj -> obj
f obj -> obj
g (Shared (Translate f a
by obj
o)) = obj -> obj
g forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. f a -> obj -> SharedObj obj f a
Translate f a
by (obj -> obj
f obj
o)
fmapSharedObj obj -> obj
f obj -> obj
g (Shared (Scale f a
by obj
o)) = obj -> obj
g forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. f a -> obj -> SharedObj obj f a
Scale f a
by (obj -> obj
f obj
o)
fmapSharedObj obj -> obj
f obj -> obj
g (Shared (Mirror f a
by obj
o)) = obj -> obj
g forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. f a -> obj -> SharedObj obj f a
Mirror f a
by (obj -> obj
f obj
o)
fmapSharedObj obj -> obj
f obj -> obj
g (Shared (Outset ℝ
by obj
o)) = obj -> obj
g forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. ℝ -> obj -> SharedObj obj f a
Outset ℝ
by (obj -> obj
f obj
o)
fmapSharedObj obj -> obj
f obj -> obj
g (Shared (Shell ℝ
by obj
o)) = obj -> obj
g forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. ℝ -> obj -> SharedObj obj f a
Shell ℝ
by (obj -> obj
f obj
o)
fmapSharedObj obj -> obj
_ obj -> obj
g (Shared (EmbedBoxedObj (f a -> a, (f a, f a))
fun)) = obj -> obj
g forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
(f a -> a, (f a, f a)) -> SharedObj obj f a
EmbedBoxedObj (f a -> a, (f a, f a))
fun
fmapSharedObj obj -> obj
f obj -> obj
g (Shared (WithRounding ℝ
r obj
o)) = obj -> obj
g forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. ℝ -> obj -> SharedObj obj f a
WithRounding ℝ
r (obj -> obj
f obj
o)
fmapSharedObj obj -> obj
f obj -> obj
_ obj
o = obj -> obj
f obj
o

-- | Map over @SymbolicObj2@ and its underlying shared objects
--
-- This function is co-recursive with @fmapSharedObj@ to achieve
-- deep mapping over objects nested in @Shared2@ constructor
fmapObj2
  :: (SymbolicObj2 -> SymbolicObj2) -- ^ SymbolicObj2 transformation
  -> (SymbolicObj3 -> SymbolicObj3) -- ^ SymbolicObj3 transformation
  -> (forall obj f a . (Object obj f a) => obj -> obj) -- ^ Shared2|3 transformation
  -> SymbolicObj2
  -> SymbolicObj2
fmapObj2 :: (SymbolicObj2 -> SymbolicObj2)
-> (SymbolicObj3 -> SymbolicObj3)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj2
-> SymbolicObj2
fmapObj2 SymbolicObj2 -> SymbolicObj2
f SymbolicObj3 -> SymbolicObj3
_ forall obj (f :: * -> *) a. Object obj f a => obj -> obj
_ (Square ℝ2
v)       = SymbolicObj2 -> SymbolicObj2
f forall a b. (a -> b) -> a -> b
$ ℝ2 -> SymbolicObj2
Square ℝ2
v
fmapObj2 SymbolicObj2 -> SymbolicObj2
f SymbolicObj3 -> SymbolicObj3
_ forall obj (f :: * -> *) a. Object obj f a => obj -> obj
_ (Circle ℝ
r)       = SymbolicObj2 -> SymbolicObj2
f forall a b. (a -> b) -> a -> b
$ ℝ -> SymbolicObj2
Circle ℝ
r
fmapObj2 SymbolicObj2 -> SymbolicObj2
f SymbolicObj3 -> SymbolicObj3
_ forall obj (f :: * -> *) a. Object obj f a => obj -> obj
_ (Polygon [ℝ2]
ps)     = SymbolicObj2 -> SymbolicObj2
f forall a b. (a -> b) -> a -> b
$ [ℝ2] -> SymbolicObj2
Polygon [ℝ2]
ps
fmapObj2 SymbolicObj2 -> SymbolicObj2
f SymbolicObj3 -> SymbolicObj3
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (Rotate2 ℝ
r SymbolicObj2
o)    = SymbolicObj2 -> SymbolicObj2
f forall a b. (a -> b) -> a -> b
$ ℝ -> SymbolicObj2 -> SymbolicObj2
Rotate2 ℝ
r ((SymbolicObj2 -> SymbolicObj2)
-> (SymbolicObj3 -> SymbolicObj3)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj2
-> SymbolicObj2
fmapObj2 SymbolicObj2 -> SymbolicObj2
f SymbolicObj3 -> SymbolicObj3
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s SymbolicObj2
o)
fmapObj2 SymbolicObj2 -> SymbolicObj2
f SymbolicObj3 -> SymbolicObj3
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (Transform2 M33 ℝ
m SymbolicObj2
o) = SymbolicObj2 -> SymbolicObj2
f forall a b. (a -> b) -> a -> b
$ M33 ℝ -> SymbolicObj2 -> SymbolicObj2
Transform2 M33 ℝ
m ((SymbolicObj2 -> SymbolicObj2)
-> (SymbolicObj3 -> SymbolicObj3)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj2
-> SymbolicObj2
fmapObj2 SymbolicObj2 -> SymbolicObj2
f SymbolicObj3 -> SymbolicObj3
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s SymbolicObj2
o)
fmapObj2 SymbolicObj2 -> SymbolicObj2
f SymbolicObj3 -> SymbolicObj3
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (Shared2 SharedObj SymbolicObj2 V2 ℝ
o)      = forall obj (f :: * -> *) a.
Object obj f a =>
(obj -> obj) -> (obj -> obj) -> obj -> obj
fmapSharedObj ((SymbolicObj2 -> SymbolicObj2)
-> (SymbolicObj3 -> SymbolicObj3)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj2
-> SymbolicObj2
fmapObj2 SymbolicObj2 -> SymbolicObj2
f SymbolicObj3 -> SymbolicObj3
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s) forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (SharedObj SymbolicObj2 V2 ℝ -> SymbolicObj2
Shared2 SharedObj SymbolicObj2 V2 ℝ
o)

-- | Map over @SymbolicObj3@ and its underlying shared objects
--
-- This function is co-recursive with @fmapSharedObj@ to achieve
-- deep mapping over objects nested in @Shared3@ constructor
fmapObj3
  :: (SymbolicObj3 -> SymbolicObj3) -- ^ SymbolicObj3 transformation
  -> (SymbolicObj2 -> SymbolicObj2) -- ^ SymbolicObj2 transformation
  -> (forall obj f a . (Object obj f a) => obj -> obj) -- ^ Shared2|3 transformation
  -> SymbolicObj3
  -> SymbolicObj3
fmapObj3 :: (SymbolicObj3 -> SymbolicObj3)
-> (SymbolicObj2 -> SymbolicObj2)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj3
-> SymbolicObj3
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
_ forall obj (f :: * -> *) a. Object obj f a => obj -> obj
_ (Cube ℝ3
v) = SymbolicObj3 -> SymbolicObj3
f forall a b. (a -> b) -> a -> b
$ ℝ3 -> SymbolicObj3
Cube ℝ3
v
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
_ forall obj (f :: * -> *) a. Object obj f a => obj -> obj
_ (Sphere ℝ
r) = SymbolicObj3 -> SymbolicObj3
f forall a b. (a -> b) -> a -> b
$ ℝ -> SymbolicObj3
Sphere ℝ
r
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
_ forall obj (f :: * -> *) a. Object obj f a => obj -> obj
_ (Cylinder ℝ
r1 ℝ
r2 ℝ
h) = SymbolicObj3 -> SymbolicObj3
f forall a b. (a -> b) -> a -> b
$ ℝ -> ℝ -> ℝ -> SymbolicObj3
Cylinder ℝ
r1 ℝ
r2 ℝ
h
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (Rotate3 Quaternion ℝ
q SymbolicObj3
o) = SymbolicObj3 -> SymbolicObj3
f forall a b. (a -> b) -> a -> b
$ Quaternion ℝ -> SymbolicObj3 -> SymbolicObj3
Rotate3 Quaternion ℝ
q ((SymbolicObj3 -> SymbolicObj3)
-> (SymbolicObj2 -> SymbolicObj2)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj3
-> SymbolicObj3
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s SymbolicObj3
o)
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (Transform3 M44 ℝ
m SymbolicObj3
o) = SymbolicObj3 -> SymbolicObj3
f forall a b. (a -> b) -> a -> b
$ M44 ℝ -> SymbolicObj3 -> SymbolicObj3
Transform3 M44 ℝ
m ((SymbolicObj3 -> SymbolicObj3)
-> (SymbolicObj2 -> SymbolicObj2)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj3
-> SymbolicObj3
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s SymbolicObj3
o)
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (Extrude SymbolicObj2
o2 ℝ
h) = SymbolicObj3 -> SymbolicObj3
f forall a b. (a -> b) -> a -> b
$ SymbolicObj2 -> ℝ -> SymbolicObj3
Extrude ((SymbolicObj2 -> SymbolicObj2)
-> (SymbolicObj3 -> SymbolicObj3)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj2
-> SymbolicObj2
fmapObj2 SymbolicObj2 -> SymbolicObj2
g SymbolicObj3 -> SymbolicObj3
f forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s SymbolicObj2
o2) ℝ
h
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (ExtrudeM Either ℝ (ℝ -> ℝ)
twist ExtrudeMScale
sc Either ℝ2 (ℝ -> ℝ2)
tr SymbolicObj2
o2 Either ℝ (ℝ2 -> ℝ)
h) = SymbolicObj3 -> SymbolicObj3
f (Either ℝ (ℝ -> ℝ)
-> ExtrudeMScale
-> Either ℝ2 (ℝ -> ℝ2)
-> SymbolicObj2
-> Either ℝ (ℝ2 -> ℝ)
-> SymbolicObj3
ExtrudeM Either ℝ (ℝ -> ℝ)
twist ExtrudeMScale
sc Either ℝ2 (ℝ -> ℝ2)
tr ((SymbolicObj2 -> SymbolicObj2)
-> (SymbolicObj3 -> SymbolicObj3)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj2
-> SymbolicObj2
fmapObj2 SymbolicObj2 -> SymbolicObj2
g SymbolicObj3 -> SymbolicObj3
f forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s SymbolicObj2
o2) Either ℝ (ℝ2 -> ℝ)
h)
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (RotateExtrude ℝ
angle Either ℝ2 (ℝ -> ℝ2)
tr Either ℝ (ℝ -> ℝ)
rot SymbolicObj2
o2) = SymbolicObj3 -> SymbolicObj3
f (ℝ
-> Either ℝ2 (ℝ -> ℝ2)
-> Either ℝ (ℝ -> ℝ)
-> SymbolicObj2
-> SymbolicObj3
RotateExtrude ℝ
angle Either ℝ2 (ℝ -> ℝ2)
tr Either ℝ (ℝ -> ℝ)
rot ((SymbolicObj2 -> SymbolicObj2)
-> (SymbolicObj3 -> SymbolicObj3)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj2
-> SymbolicObj2
fmapObj2 SymbolicObj2 -> SymbolicObj2
g SymbolicObj3 -> SymbolicObj3
f forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s SymbolicObj2
o2))
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (ExtrudeOnEdgeOf SymbolicObj2
o2a SymbolicObj2
o2b) = SymbolicObj3 -> SymbolicObj3
f (SymbolicObj2 -> SymbolicObj2 -> SymbolicObj3
ExtrudeOnEdgeOf ((SymbolicObj2 -> SymbolicObj2)
-> (SymbolicObj3 -> SymbolicObj3)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj2
-> SymbolicObj2
fmapObj2 SymbolicObj2 -> SymbolicObj2
g SymbolicObj3 -> SymbolicObj3
f forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s SymbolicObj2
o2a) ((SymbolicObj2 -> SymbolicObj2)
-> (SymbolicObj3 -> SymbolicObj3)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj2
-> SymbolicObj2
fmapObj2 SymbolicObj2 -> SymbolicObj2
g SymbolicObj3 -> SymbolicObj3
f forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s SymbolicObj2
o2b))
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (Shared3 SharedObj SymbolicObj3 V3 ℝ
o) = forall obj (f :: * -> *) a.
Object obj f a =>
(obj -> obj) -> (obj -> obj) -> obj -> obj
fmapSharedObj ((SymbolicObj3 -> SymbolicObj3)
-> (SymbolicObj2 -> SymbolicObj2)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj3
-> SymbolicObj3
fmapObj3 SymbolicObj3 -> SymbolicObj3
f SymbolicObj2 -> SymbolicObj2
g forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s) forall obj (f :: * -> *) a. Object obj f a => obj -> obj
s (SharedObj SymbolicObj3 V3 ℝ -> SymbolicObj3
Shared3 SharedObj SymbolicObj3 V3 ℝ
o)

-- | We have to define our own variant of Eq
-- which compares objects when possible
-- and returns True when we cannot compare
-- things like functions
class EqObj a where
  (=^=) :: a -> a -> Bool

instance EqObj a => EqObj [a] where
  []     =^= :: [a] -> [a] -> Bool
=^= []     = Bool
True
  (a
x:[a]
xs) =^= (a
y:[a]
ys) = a
x forall a. EqObj a => a -> a -> Bool
=^= a
y Bool -> Bool -> Bool
&& [a]
xs forall a. EqObj a => a -> a -> Bool
=^= [a]
ys
  [a]
_xs    =^= [a]
_ys    = Bool
False

instance (EqObj obj , Eq (f a)) => EqObj (SharedObj obj f a) where
  SharedObj obj f a
Empty =^= :: SharedObj obj f a -> SharedObj obj f a -> Bool
=^= SharedObj obj f a
Empty = Bool
True
  SharedObj obj f a
Full =^= SharedObj obj f a
Full = Bool
True
  Complement obj
a =^= Complement obj
b = obj
a forall a. EqObj a => a -> a -> Bool
=^= obj
b
  UnionR ℝ
r1 [obj]
a =^= UnionR ℝ
r2 [obj]
b = ℝ
r1 forall a. Eq a => a -> a -> Bool
== ℝ
r2 Bool -> Bool -> Bool
&& [obj]
a forall a. EqObj a => a -> a -> Bool
=^= [obj]
b
  DifferenceR ℝ
r1 obj
a [obj]
x =^= DifferenceR ℝ
r2 obj
b [obj]
y = ℝ
r1 forall a. Eq a => a -> a -> Bool
== ℝ
r2 Bool -> Bool -> Bool
&& obj
a forall a. EqObj a => a -> a -> Bool
=^= obj
b Bool -> Bool -> Bool
&& [obj]
x forall a. EqObj a => a -> a -> Bool
=^= [obj]
y
  IntersectR ℝ
r1 [obj]
a =^= IntersectR ℝ
r2 [obj]
b = ℝ
r1 forall a. Eq a => a -> a -> Bool
== ℝ
r2 Bool -> Bool -> Bool
&& [obj]
a forall a. EqObj a => a -> a -> Bool
=^= [obj]
b
  Translate f a
x obj
a =^= Translate f a
y obj
b = f a
x forall a. Eq a => a -> a -> Bool
== f a
y Bool -> Bool -> Bool
&& obj
a forall a. EqObj a => a -> a -> Bool
=^= obj
b
  Scale f a
x obj
a =^= Scale f a
y obj
b = f a
x forall a. Eq a => a -> a -> Bool
== f a
y Bool -> Bool -> Bool
&& obj
a forall a. EqObj a => a -> a -> Bool
=^= obj
b
  Mirror f a
x obj
a =^= Mirror f a
y obj
b = f a
x forall a. Eq a => a -> a -> Bool
== f a
y Bool -> Bool -> Bool
&& obj
a forall a. EqObj a => a -> a -> Bool
=^= obj
b
  Outset ℝ
x obj
a =^= Outset ℝ
y obj
b = ℝ
x forall a. Eq a => a -> a -> Bool
== ℝ
y Bool -> Bool -> Bool
&& obj
a forall a. EqObj a => a -> a -> Bool
=^= obj
b
  Shell ℝ
x obj
a =^= Shell ℝ
y obj
b = ℝ
x forall a. Eq a => a -> a -> Bool
== ℝ
y Bool -> Bool -> Bool
&& obj
a forall a. EqObj a => a -> a -> Bool
=^= obj
b
  EmbedBoxedObj (f a -> a
_fA, (f a, f a)
a) =^= EmbedBoxedObj (f a -> a
_fB, (f a, f a)
b) = (f a, f a)
a forall a. Eq a => a -> a -> Bool
== (f a, f a)
b
  WithRounding ℝ
x obj
a =^= WithRounding ℝ
y obj
b = ℝ
x forall a. Eq a => a -> a -> Bool
== ℝ
y Bool -> Bool -> Bool
&& obj
a forall a. EqObj a => a -> a -> Bool
=^= obj
b
  SharedObj obj f a
_ =^= SharedObj obj f a
_ = Bool
False

instance EqObj ExtrudeMScale where
  C1 ℝ
x =^= :: ExtrudeMScale -> ExtrudeMScale -> Bool
=^= C1 ℝ
y = ℝ
x forall a. Eq a => a -> a -> Bool
== ℝ
y
  C2 ℝ2
x =^= C2 ℝ2
y = ℝ2
x forall a. Eq a => a -> a -> Bool
== ℝ2
y
  Fn ℝ -> Either ℝ ℝ2
_ =^= Fn ℝ -> Either ℝ ℝ2
_ = Bool
True
  ExtrudeMScale
_ =^= ExtrudeMScale
_ = Bool
False

instance EqObj SymbolicObj2 where
  Square ℝ2
a =^= :: SymbolicObj2 -> SymbolicObj2 -> Bool
=^= Square ℝ2
b = ℝ2
a forall a. Eq a => a -> a -> Bool
== ℝ2
b
  Circle ℝ
a =^= Circle ℝ
b = ℝ
a forall a. Eq a => a -> a -> Bool
== ℝ
b
  Polygon [ℝ2]
a =^= Polygon [ℝ2]
b = [ℝ2]
a forall a. Eq a => a -> a -> Bool
== [ℝ2]
b
  Rotate2 ℝ
x SymbolicObj2
a =^= Rotate2 ℝ
y SymbolicObj2
b = ℝ
x forall a. Eq a => a -> a -> Bool
== ℝ
y Bool -> Bool -> Bool
&& SymbolicObj2
a forall a. EqObj a => a -> a -> Bool
=^= SymbolicObj2
b
  Transform2 M33 ℝ
x SymbolicObj2
a =^= Transform2 M33 ℝ
y SymbolicObj2
b = M33 ℝ
x forall a. Eq a => a -> a -> Bool
== M33 ℝ
y Bool -> Bool -> Bool
&& SymbolicObj2
a forall a. EqObj a => a -> a -> Bool
=^= SymbolicObj2
b
  Shared2 SharedObj SymbolicObj2 V2 ℝ
a =^= Shared2 SharedObj SymbolicObj2 V2 ℝ
b = SharedObj SymbolicObj2 V2 ℝ
a forall a. EqObj a => a -> a -> Bool
=^= SharedObj SymbolicObj2 V2 ℝ
b
  SymbolicObj2
_ =^= SymbolicObj2
_ = Bool
False

instance EqObj SymbolicObj3 where
  Cube ℝ3
a =^= :: SymbolicObj3 -> SymbolicObj3 -> Bool
=^= Cube ℝ3
b = ℝ3
a forall a. Eq a => a -> a -> Bool
== ℝ3
b
  Sphere ℝ
a =^= Sphere ℝ
b = ℝ
a forall a. Eq a => a -> a -> Bool
== ℝ
b
  Cylinder ℝ
r1a ℝ
r2a ℝ
ha =^= Cylinder ℝ
r1b ℝ
r2b ℝ
hb = ℝ
r1a forall a. Eq a => a -> a -> Bool
== ℝ
r1b Bool -> Bool -> Bool
&& ℝ
r2a forall a. Eq a => a -> a -> Bool
== ℝ
r2b Bool -> Bool -> Bool
&& ℝ
ha forall a. Eq a => a -> a -> Bool
== ℝ
hb
  Rotate3 Quaternion ℝ
x SymbolicObj3
a =^= Rotate3 Quaternion ℝ
y SymbolicObj3
b = Quaternion ℝ
x forall a. Eq a => a -> a -> Bool
== Quaternion ℝ
y Bool -> Bool -> Bool
&& SymbolicObj3
a forall a. EqObj a => a -> a -> Bool
=^= SymbolicObj3
b
  Transform3 M44 ℝ
x SymbolicObj3
a =^= Transform3 M44 ℝ
y SymbolicObj3
b = M44 ℝ
x forall a. Eq a => a -> a -> Bool
== M44 ℝ
y Bool -> Bool -> Bool
&& SymbolicObj3
a forall a. EqObj a => a -> a -> Bool
=^= SymbolicObj3
b
  Extrude SymbolicObj2
a ℝ
x =^= Extrude SymbolicObj2
b ℝ
y = ℝ
x forall a. Eq a => a -> a -> Bool
== ℝ
y Bool -> Bool -> Bool
&& SymbolicObj2
a forall a. EqObj a => a -> a -> Bool
=^= SymbolicObj2
b

  ExtrudeM (Left ℝ
twa) ExtrudeMScale
ma (Left ℝ2
ta) SymbolicObj2
a (Left ℝ
ha)
    =^=
    ExtrudeM (Left ℝ
twb) ExtrudeMScale
mb (Left ℝ2
tb) SymbolicObj2
b (Left ℝ
hb)
      = ℝ
twa forall a. Eq a => a -> a -> Bool
== ℝ
twb Bool -> Bool -> Bool
&& ExtrudeMScale
ma forall a. EqObj a => a -> a -> Bool
=^= ExtrudeMScale
mb Bool -> Bool -> Bool
&& ℝ2
ta forall a. Eq a => a -> a -> Bool
== ℝ2
tb Bool -> Bool -> Bool
&& ℝ
ha forall a. Eq a => a -> a -> Bool
== ℝ
hb Bool -> Bool -> Bool
&& SymbolicObj2
a forall a. EqObj a => a -> a -> Bool
=^= SymbolicObj2
b
  ExtrudeM {} =^= ExtrudeM {} = Bool
True

  RotateExtrude ℝ
ra (Left ℝ2
ta) (Left ℝ
rota) SymbolicObj2
a
    =^=
    RotateExtrude ℝ
rb (Left ℝ2
tb) (Left ℝ
rotb) SymbolicObj2
b
      = ℝ
ra forall a. Eq a => a -> a -> Bool
== ℝ
rb Bool -> Bool -> Bool
&& ℝ2
ta forall a. Eq a => a -> a -> Bool
== ℝ2
tb Bool -> Bool -> Bool
&& ℝ
rota forall a. Eq a => a -> a -> Bool
== ℝ
rotb Bool -> Bool -> Bool
&& SymbolicObj2
a forall a. EqObj a => a -> a -> Bool
=^= SymbolicObj2
b
  RotateExtrude {} =^= RotateExtrude {} = Bool
True

  ExtrudeOnEdgeOf SymbolicObj2
a SymbolicObj2
x =^= ExtrudeOnEdgeOf SymbolicObj2
b SymbolicObj2
y = SymbolicObj2
a forall a. EqObj a => a -> a -> Bool
=^= SymbolicObj2
b Bool -> Bool -> Bool
&& SymbolicObj2
x forall a. EqObj a => a -> a -> Bool
=^= SymbolicObj2
y
  Shared3 SharedObj SymbolicObj3 V3 ℝ
a =^= Shared3 SharedObj SymbolicObj3 V3 ℝ
b = SharedObj SymbolicObj3 V3 ℝ
a forall a. EqObj a => a -> a -> Bool
=^= SharedObj SymbolicObj3 V3 ℝ
b
  SymbolicObj3
_ =^= SymbolicObj3
_ = Bool
False

-- | Rewrite the object tree until it cannot be reduced further
rewriteUntilIrreducible
  :: ( Object obj f a
     , EqObj obj)
  => (obj -> obj) -- ^ SymbolicObjN transformation
  -> obj
  -> obj
rewriteUntilIrreducible :: forall obj (f :: * -> *) a.
(Object obj f a, EqObj obj) =>
(obj -> obj) -> obj -> obj
rewriteUntilIrreducible obj -> obj
fRew obj
ast =
  let
    step :: obj
step = obj -> obj
fRew obj
ast
  in
    if obj
step forall a. EqObj a => a -> a -> Bool
=^= obj
ast
    then obj
step
    else forall obj (f :: * -> *) a.
(Object obj f a, EqObj obj) =>
(obj -> obj) -> obj -> obj
rewriteUntilIrreducible obj -> obj
fRew obj
step

-- | Canonicalize @SymbolicObj2@ tree
canonicalize2 :: SymbolicObj2 -> SymbolicObj2
canonicalize2 :: SymbolicObj2 -> SymbolicObj2
canonicalize2 = forall obj (f :: * -> *) a.
(Object obj f a, EqObj obj) =>
(obj -> obj) -> obj -> obj
rewriteUntilIrreducible forall a b. (a -> b) -> a -> b
$ (SymbolicObj2 -> SymbolicObj2)
-> (SymbolicObj3 -> SymbolicObj3)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj2
-> SymbolicObj2
fmapObj2 SymbolicObj2 -> SymbolicObj2
canon2 SymbolicObj3 -> SymbolicObj3
canon3 forall obj (f :: * -> *) a. Object obj f a => obj -> obj
canonShared

-- | Canonicalize @SymbolicObj3@ tree
canonicalize3 :: SymbolicObj3 -> SymbolicObj3
canonicalize3 :: SymbolicObj3 -> SymbolicObj3
canonicalize3 = forall obj (f :: * -> *) a.
(Object obj f a, EqObj obj) =>
(obj -> obj) -> obj -> obj
rewriteUntilIrreducible forall a b. (a -> b) -> a -> b
$ (SymbolicObj3 -> SymbolicObj3)
-> (SymbolicObj2 -> SymbolicObj2)
-> (forall obj (f :: * -> *) a. Object obj f a => obj -> obj)
-> SymbolicObj3
-> SymbolicObj3
fmapObj3 SymbolicObj3 -> SymbolicObj3
canon3 SymbolicObj2 -> SymbolicObj2
canon2 forall obj (f :: * -> *) a. Object obj f a => obj -> obj
canonShared

{-# ANN canon2 "HLint: ignore Use record patterns" #-}
{-# ANN canon3 "HLint: ignore Use record patterns" #-}

-- | Rewrite rules for @SymbolicObj2@
canon2 :: SymbolicObj2 -> SymbolicObj2
canon2 :: SymbolicObj2 -> SymbolicObj2
canon2 (Square ℝ2
v) | forall (f :: * -> *) a. (Foldable f, Num a, Eq a) => f a -> Bool
hasZeroComponent ℝ2
v = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canon2 (Circle ℝ
0) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canon2 (Polygon [ℝ2]
ps) | forall (t :: * -> *) a. Foldable t => t a -> Int
length [ℝ2]
ps forall a. Ord a => a -> a -> Bool
< Int
3 = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canon2 (Rotate2 ℝ
0 SymbolicObj2
o) = SymbolicObj2
o
-- TOOD(srk): this "fixes" (more like hides) the problem
-- with polygon under rotation described in #449
-- so we keep it disabled for now
-- needs import Data.Fixed (mod') and Prelude (pi)
-- canon2 (Rotate2 θ o) | θ `mod'` (2*pi) == 0 = o

-- ignore if zeroes, TODO(srk): produce warning
-- TODO(srk): produce warning and ignore if we get a non-invertible matrix
canon2 (Transform2
         (V3 (V3 ℝ
x ℝ
_ ℝ
_)
             (V3 ℝ
_ ℝ
y ℝ
_)
             (V3 ℝ
_ ℝ
_ ℝ
_)
         )
         SymbolicObj2
o) | forall (f :: * -> *) a. (Foldable f, Num a, Eq a) => f a -> Bool
hasZeroComponent (forall a. a -> a -> V2 a
V2 ℝ
x ℝ
y) = SymbolicObj2
o
canon2 SymbolicObj2
x = SymbolicObj2
x

-- | Rewrite rules for @SymbolicObj3@
canon3 :: SymbolicObj3 -> SymbolicObj3
canon3 :: SymbolicObj3 -> SymbolicObj3
canon3 (Cube ℝ3
v) | forall (f :: * -> *) a. (Foldable f, Num a, Eq a) => f a -> Bool
hasZeroComponent ℝ3
v = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canon3 (Sphere ℝ
0) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canon3 (Cylinder ℝ
0 ℝ
_ ℝ
_) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canon3 (Extrude SymbolicObj2
_o2 ℝ
0) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canon3 (Rotate3 Quaternion ℝ
0 SymbolicObj3
o) = SymbolicObj3
o
canon3 (RotateExtrude ℝ
0 Either ℝ2 (ℝ -> ℝ2)
_t Either ℝ (ℝ -> ℝ)
_r SymbolicObj2
_o) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canon3 (RotateExtrude ℝ
_theta Either ℝ2 (ℝ -> ℝ2)
_t Either ℝ (ℝ -> ℝ)
_r (Shared SharedObj SymbolicObj2 V2 ℝ
Empty)) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
-- ignore if zeroes, TODO(srk): produce warning
-- TODO(srk): produce warning and ignore if we get a non-invertible matrix
canon3 (Transform3
         (V4 (V4 ℝ
x ℝ
_ ℝ
_ ℝ
_)
             (V4 ℝ
_ ℝ
y ℝ
_ ℝ
_)
             (V4 ℝ
_ ℝ
_ ℝ
z ℝ
_)
             (V4 ℝ
_ ℝ
_ ℝ
_ ℝ
_)
         )
         SymbolicObj3
o) | forall (f :: * -> *) a. (Foldable f, Num a, Eq a) => f a -> Bool
hasZeroComponent (forall a. a -> a -> a -> V3 a
V3 ℝ
x ℝ
y ℝ
z) = SymbolicObj3
o
canon3 SymbolicObj3
x = SymbolicObj3
x

-- | Rewrite rules for @SharedObj@
canonShared
  :: forall obj f a
   . (Object obj f a)
  => obj
  -> obj
canonShared :: forall obj (f :: * -> *) a. Object obj f a => obj -> obj
canonShared (Shared (Scale f a
1 obj
o)) = obj
o
canonShared (Shared (Scale f a
v1 (Shared (Scale f a
v2 obj
o)))) = forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. f a -> obj -> SharedObj obj f a
Scale (f a
v1 forall a. Num a => a -> a -> a
* f a
v2) obj
o
canonShared (Shared (Scale f a
_ s :: obj
s@(Shared SharedObj obj f a
Empty))) = obj
s
canonShared (Shared (Scale f a
_ s :: obj
s@(Shared SharedObj obj f a
Full))) = obj
s
-- ignore if zeroes, TODO(srk): produce warning
canonShared (Shared (Scale f a
s obj
o)) | forall (f :: * -> *) a. (Foldable f, Num a, Eq a) => f a -> Bool
hasZeroComponent f a
s = obj
o
canonShared (Shared (Translate f a
0 obj
o)) = obj
o
canonShared (Shared (Translate f a
_ s :: obj
s@(Shared SharedObj obj f a
Empty))) = obj
s
canonShared (Shared (Translate f a
_ s :: obj
s@(Shared SharedObj obj f a
Full))) = obj
s
canonShared (Shared (Translate f a
v1 (Shared (Translate f a
v2 obj
o)))) = forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. f a -> obj -> SharedObj obj f a
Translate (f a
v1 forall a. Num a => a -> a -> a
+ f a
v2) obj
o

canonShared (Shared (Mirror f a
_ (Shared SharedObj obj f a
Empty))) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canonShared (Shared (Mirror f a
_ (Shared SharedObj obj f a
Full))) = forall obj (f :: * -> *) a. Object obj f a => obj
fullSpace
canonShared (Shared (Outset ℝ
0 obj
s)) = obj
s
canonShared (Shared (Outset ℝ
0 (Shared SharedObj obj f a
Empty))) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canonShared (Shared (Outset ℝ
0 (Shared SharedObj obj f a
Full))) = forall obj (f :: * -> *) a. Object obj f a => obj
fullSpace
canonShared (Shared (Outset ℝ
v1 (Shared (Outset ℝ
v2 obj
o)))) = forall obj (f :: * -> *) a.
Object obj f a =>
SharedObj obj f a -> obj
Shared forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. ℝ -> obj -> SharedObj obj f a
Outset (ℝ
v1 forall a. Num a => a -> a -> a
+ ℝ
v2) obj
o
canonShared (Shared (Shell ℝ
_ (Shared SharedObj obj f a
Full))) = forall obj (f :: * -> *) a. Object obj f a => obj
fullSpace
canonShared (Shared (Shell ℝ
_ (Shared SharedObj obj f a
Empty))) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canonShared (Shared (Shell ℝ
_ (Shared SharedObj obj f a
Full))) = forall obj (f :: * -> *) a. Object obj f a => obj
fullSpace
canonShared (Shared (UnionR ℝ
_ [])) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canonShared (Shared (UnionR ℝ
_ [obj
s])) = obj
s
canonShared (Shared (DifferenceR ℝ
_ obj
s [])) = obj
s
canonShared (Shared (DifferenceR ℝ
_ (Shared SharedObj obj f a
Empty) [obj]
_)) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canonShared (Shared (IntersectR ℝ
_ [])) = forall obj (f :: * -> *) a. Object obj f a => obj
emptySpace
canonShared (Shared (IntersectR ℝ
_ [obj
s])) = obj
s
canonShared obj
x = obj
x