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

module Graphics.Implicit.ObjectUtil.GetBoxShared (VectorStuff(uniformV, elements, corners), intersectBoxes, emptyBox, pointsBox, unionBoxes, outsetBox, getBoxShared) where

import Prelude (Num, (-), (+), pure, (==), max, min, foldr, (/), ($), fmap, (.), not, filter, foldMap, Fractional, Bool, Eq)
import {-# SOURCE #-} Graphics.Implicit.Primitives
    ( Object(getBox) )
import Graphics.Implicit.Definitions
    ( SharedObj(Empty, Full, Complement, UnionR, DifferenceR, IntersectR, Translate, Scale, Mirror, Shell, Outset, EmbedBoxedObj, WithRounding), ComponentWiseMultable((⋯*)), ℝ3, ℝ2, ℝ )
import Graphics.Implicit.MathUtil (infty,  reflect )
import Linear (Metric, V2(V2), V3(V3))
import Data.Foldable (Foldable(toList))
import Control.Applicative (Applicative(liftA2))

------------------------------------------------------------------------------
-- | Ad-hoc methods we need to share code between 2D and 3D. With the exception
-- of 'corners', these are actually all standard methods of other classes,
-- which we don't have access to due to the choice representation for R2 and
-- R3.
--
-- This class is unnecessary if we were to implement #283.
class VectorStuff vec where
  -- | Equivalent to 'Prelude.pure'
  uniformV :: ℝ -> vec
  -- | Equivalent to 'Control.Applicative.liftA2'
  pointwise :: (ℝ -> ℝ -> ℝ) -> vec -> vec -> vec
  -- | Equivalent to 'Data.Foldable.toList'
  elements :: vec -> [ℝ]
  -- | Given a bounding box, produce the points at each corner.
  corners :: (vec, vec) -> [vec]

instance VectorStuff ℝ2 where
  uniformV :: ℝ -> ℝ2
uniformV = ℝ -> ℝ2
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  corners :: (ℝ2, ℝ2) -> [ℝ2]
corners (p1 :: ℝ2
p1@(V2 ℝ
x1 ℝ
y1), p2 :: ℝ2
p2@(V2 ℝ
x2 ℝ
y2)) =
    [ ℝ2
p1
    , ℝ -> ℝ -> ℝ2
forall a. a -> a -> V2 a
V2 ℝ
x1 ℝ
y2
    , ℝ -> ℝ -> ℝ2
forall a. a -> a -> V2 a
V2 ℝ
x2 ℝ
y1
    , ℝ2
p2
    ]
  pointwise :: (ℝ -> ℝ -> ℝ) -> ℝ2 -> ℝ2 -> ℝ2
pointwise = (ℝ -> ℝ -> ℝ) -> ℝ2 -> ℝ2 -> ℝ2
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
  elements :: ℝ2 -> [ℝ]
elements = ℝ2 -> [ℝ]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  {-# INLINABLE uniformV #-}
  {-# INLINABLE pointwise #-}
  {-# INLINABLE elements #-}
  {-# INLINABLE corners #-}

instance VectorStuff ℝ3 where
  uniformV :: ℝ -> ℝ3
uniformV = ℝ -> ℝ3
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  corners :: (ℝ3, ℝ3) -> [ℝ3]
corners (p1 :: ℝ3
p1@(V3 ℝ
x1 ℝ
y1 ℝ
z1), p2 :: ℝ3
p2@(V3 ℝ
x2 ℝ
y2 ℝ
z2)) =
    [ ℝ3
p1
    , ℝ -> ℝ -> ℝ -> ℝ3
forall a. a -> a -> a -> V3 a
V3 ℝ
x1 ℝ
y2 ℝ
z1
    , ℝ -> ℝ -> ℝ -> ℝ3
forall a. a -> a -> a -> V3 a
V3 ℝ
x2 ℝ
y2 ℝ
z1
    , ℝ -> ℝ -> ℝ -> ℝ3
forall a. a -> a -> a -> V3 a
V3 ℝ
x2 ℝ
y1 ℝ
z1
    , ℝ -> ℝ -> ℝ -> ℝ3
forall a. a -> a -> a -> V3 a
V3 ℝ
x1 ℝ
y1 ℝ
z2
    , ℝ -> ℝ -> ℝ -> ℝ3
forall a. a -> a -> a -> V3 a
V3 ℝ
x2 ℝ
y1 ℝ
z2
    , ℝ -> ℝ -> ℝ -> ℝ3
forall a. a -> a -> a -> V3 a
V3 ℝ
x1 ℝ
y2 ℝ
z2
    , ℝ3
p2
    ]
  pointwise :: (ℝ -> ℝ -> ℝ) -> ℝ3 -> ℝ3 -> ℝ3
pointwise = (ℝ -> ℝ -> ℝ) -> ℝ3 -> ℝ3 -> ℝ3
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
  elements :: ℝ3 -> [ℝ]
elements  = ℝ3 -> [ℝ]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  {-# INLINABLE uniformV #-}
  {-# INLINABLE pointwise #-}
  {-# INLINABLE elements #-}
  {-# INLINABLE corners #-}

------------------------------------------------------------------------------
-- | Compute the intersection of dimensionality-polymorphic bounding boxes.
intersectBoxes
    :: (VectorStuff a) => [(a, a)] -> (a, a)
intersectBoxes :: [(a, a)] -> (a, a)
intersectBoxes [] = (a, a)
forall vec. VectorStuff vec => (vec, vec)
fullBox
intersectBoxes ((a, a)
b : [(a, a)]
boxes)
  = ((a, a) -> (a, a) -> (a, a)) -> (a, a) -> [(a, a)] -> (a, a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((a -> a -> a) -> (a -> a -> a) -> (a, a) -> (a, a) -> (a, a)
forall a b c d e f.
(a -> b -> c) -> (d -> e -> f) -> (a, d) -> (b, e) -> (c, f)
biapp ((ℝ -> ℝ -> ℝ) -> a -> a -> a
forall vec. VectorStuff vec => (ℝ -> ℝ -> ℝ) -> vec -> vec -> vec
pointwise ℝ -> ℝ -> ℝ
forall a. Ord a => a -> a -> a
max) ((ℝ -> ℝ -> ℝ) -> a -> a -> a
forall vec. VectorStuff vec => (ℝ -> ℝ -> ℝ) -> vec -> vec -> vec
pointwise ℝ -> ℝ -> ℝ
forall a. Ord a => a -> a -> a
min)) (a, a)
b [(a, a)]
boxes
{-# INLINABLE intersectBoxes #-}

------------------------------------------------------------------------------
-- | Apply two functions elementwise across pairs. This is the biapplicative
-- operation specialized to pairs.
biapp
    :: (a -> b -> c)
    -> (d -> e -> f)
    -> (a, d)
    -> (b, e)
    -> (c, f)
biapp :: (a -> b -> c) -> (d -> e -> f) -> (a, d) -> (b, e) -> (c, f)
biapp a -> b -> c
f d -> e -> f
g (a
a1, d
b1) (b
a2, e
b2) = (a -> b -> c
f a
a1 b
a2, d -> e -> f
g d
b1 e
b2)
{-# INLINABLE biapp #-}

-- | An empty box.
emptyBox :: (Applicative f, Num a) => (f a, f a)
emptyBox :: (f a, f a)
emptyBox = (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
0, a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
0)
{-# INLINABLE emptyBox #-}

-- | A full box.
fullBox :: (VectorStuff vec) => (vec, vec)
fullBox :: (vec, vec)
fullBox = (ℝ -> vec
forall vec. VectorStuff vec => ℝ -> vec
uniformV (-ℝ
forall t. Fractional t => t
infty), ℝ -> vec
forall vec. VectorStuff vec => ℝ -> vec
uniformV ℝ
forall t. Fractional t => t
infty)
{-# INLINABLE fullBox #-}

-- | Define a box around all of the given points.
pointsBox :: (Applicative f, Num a, VectorStuff (f a)) => [f a] -> (f a, f a)
pointsBox :: [f a] -> (f a, f a)
pointsBox [] = (f a, f a)
forall (f :: * -> *) a. (Applicative f, Num a) => (f a, f a)
emptyBox
pointsBox (f a
a : [f a]
as) = ((f a -> f a -> f a) -> f a -> [f a] -> f a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((ℝ -> ℝ -> ℝ) -> f a -> f a -> f a
forall vec. VectorStuff vec => (ℝ -> ℝ -> ℝ) -> vec -> vec -> vec
pointwise ℝ -> ℝ -> ℝ
forall a. Ord a => a -> a -> a
min) f a
a [f a]
as, (f a -> f a -> f a) -> f a -> [f a] -> f a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((ℝ -> ℝ -> ℝ) -> f a -> f a -> f a
forall vec. VectorStuff vec => (ℝ -> ℝ -> ℝ) -> vec -> vec -> vec
pointwise ℝ -> ℝ -> ℝ
forall a. Ord a => a -> a -> a
max) f a
a [f a]
as)

------------------------------------------------------------------------------
-- | Compute the intersection of dimensionality-polymorphic bounding boxes.
unionBoxes :: (VectorStuff (f a), Applicative f, Eq (f a), Num a, Num (f a)) => ℝ -> [(f a, f a)] -> (f a, f a)
unionBoxes :: ℝ -> [(f a, f a)] -> (f a, f a)
unionBoxes ℝ
r
  = ℝ -> (f a, f a) -> (f a, f a)
forall a. (VectorStuff a, Num a) => ℝ -> (a, a) -> (a, a)
outsetBox ℝ
r
  ((f a, f a) -> (f a, f a))
-> ([(f a, f a)] -> (f a, f a)) -> [(f a, f a)] -> (f a, f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [f a] -> (f a, f a)
forall (f :: * -> *) a.
(Applicative f, Num a, VectorStuff (f a)) =>
[f a] -> (f a, f a)
pointsBox
  ([f a] -> (f a, f a))
-> ([(f a, f a)] -> [f a]) -> [(f a, f a)] -> (f a, f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((f a, f a) -> [f a]) -> [(f a, f a)] -> [f a]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (f a, f a) -> [f a]
forall vec. VectorStuff vec => (vec, vec) -> [vec]
corners
  ([(f a, f a)] -> [f a])
-> ([(f a, f a)] -> [(f a, f a)]) -> [(f a, f a)] -> [f a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((f a, f a) -> Bool) -> [(f a, f a)] -> [(f a, f a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((f a, f a) -> Bool) -> (f a, f a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a, f a) -> Bool
forall (f :: * -> *) a.
(Eq (f a), Applicative f, Num a, Num (f a)) =>
(f a, f a) -> Bool
isEmpty)

-- | Is a box empty?
isEmpty :: (Eq (f a), Applicative f, Num a, Num (f a)) => (f a, f a) -> Bool
isEmpty :: (f a, f a) -> Bool
isEmpty (f a
v1, f a
v2) = (f a
v1 f a -> f a -> f a
forall a. Num a => a -> a -> a
- f a
v2) f a -> f a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
0

-- | Increase a boxes size by a rounding value.
outsetBox :: (VectorStuff a, Num a) => ℝ -> (a, a) -> (a, a)
outsetBox :: ℝ -> (a, a) -> (a, a)
outsetBox ℝ
r (a
a, a
b) = (a
a a -> a -> a
forall a. Num a => a -> a -> a
- ℝ -> a
forall vec. VectorStuff vec => ℝ -> vec
uniformV ℝ
r, a
b a -> a -> a
forall a. Num a => a -> a -> a
+ ℝ -> a
forall vec. VectorStuff vec => ℝ -> vec
uniformV ℝ
r)

-- Get a box around the given object.
getBoxShared
    :: forall obj f a
     .  ( Object obj f a, VectorStuff (f a), ComponentWiseMultable (f a), Fractional a, Metric f)
    => SharedObj obj f a
    -> (f a, f a)
-- Primitives
getBoxShared :: SharedObj obj f a -> (f a, f a)
getBoxShared SharedObj obj f a
Empty = (f a, f a)
forall (f :: * -> *) a. (Applicative f, Num a) => (f a, f a)
emptyBox
getBoxShared SharedObj obj f a
Full  = (f a, f a)
forall vec. VectorStuff vec => (vec, vec)
fullBox
-- (Rounded) CSG
getBoxShared (Complement obj
_) = (f a, f a)
forall vec. VectorStuff vec => (vec, vec)
fullBox
getBoxShared (UnionR ℝ
r [obj]
symbObjs) = ℝ -> [(f a, f a)] -> (f a, f a)
forall (f :: * -> *) a.
(VectorStuff (f a), Applicative f, Eq (f a), Num a, Num (f a)) =>
ℝ -> [(f a, f a)] -> (f a, f a)
unionBoxes ℝ
r ([(f a, f a)] -> (f a, f a)) -> [(f a, f a)] -> (f a, f a)
forall a b. (a -> b) -> a -> b
$ (obj -> (f a, f a)) -> [obj] -> [(f a, f a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap obj -> (f a, f a)
forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox [obj]
symbObjs
getBoxShared (DifferenceR ℝ
_ obj
symbObj [obj]
_)  = obj -> (f a, f a)
forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
getBoxShared (IntersectR ℝ
_ [obj]
symbObjs) =
  [(f a, f a)] -> (f a, f a)
forall a. VectorStuff a => [(a, a)] -> (a, a)
intersectBoxes ([(f a, f a)] -> (f a, f a)) -> [(f a, f a)] -> (f a, f a)
forall a b. (a -> b) -> a -> b
$
    (obj -> (f a, f a)) -> [obj] -> [(f a, f a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap obj -> (f a, f a)
forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox [obj]
symbObjs
-- -- Simple transforms
getBoxShared (Translate f a
v obj
symbObj) =
    let (f a
a :: f a, f a
b) = obj -> (f a, f a)
forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
     in (f a
a f a -> f a -> f a
forall a. Num a => a -> a -> a
+ f a
v, f a
b f a -> f a -> f a
forall a. Num a => a -> a -> a
+ f a
v)
getBoxShared (Scale f a
s obj
symbObj) =
    let
        (f a
a :: f a, f a
b) = obj -> (f a, f a)
forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
        sa :: f a
sa = f a
s f a -> f a -> f a
forall a. ComponentWiseMultable a => a -> a -> a
⋯* f a
a
        sb :: f a
sb = f a
s f a -> f a -> f a
forall a. ComponentWiseMultable a => a -> a -> a
⋯* f a
b
     in [f a] -> (f a, f a)
forall (f :: * -> *) a.
(Applicative f, Num a, VectorStuff (f a)) =>
[f a] -> (f a, f a)
pointsBox [f a
sa, f a
sb]
getBoxShared (Mirror f a
v obj
symbObj) =
  [f a] -> (f a, f a)
forall (f :: * -> *) a.
(Applicative f, Num a, VectorStuff (f a)) =>
[f a] -> (f a, f a)
pointsBox ([f a] -> (f a, f a)) -> [f a] -> (f a, f a)
forall a b. (a -> b) -> a -> b
$ (f a -> f a) -> [f a] -> [f a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f a -> f a -> f a
forall (f :: * -> *) a.
(Num (f a), Fractional a, Metric f) =>
f a -> f a -> f a
reflect f a
v) ([f a] -> [f a]) -> [f a] -> [f a]
forall a b. (a -> b) -> a -> b
$ (f a, f a) -> [f a]
forall vec. VectorStuff vec => (vec, vec) -> [vec]
corners ((f a, f a) -> [f a]) -> (f a, f a) -> [f a]
forall a b. (a -> b) -> a -> b
$ obj -> (f a, f a)
forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
-- Boundary mods
getBoxShared (Shell ℝ
w obj
symbObj) =
    ℝ -> (f a, f a) -> (f a, f a)
forall a. (VectorStuff a, Num a) => ℝ -> (a, a) -> (a, a)
outsetBox (ℝ
wℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
2) ((f a, f a) -> (f a, f a)) -> (f a, f a) -> (f a, f a)
forall a b. (a -> b) -> a -> b
$ obj -> (f a, f a)
forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
getBoxShared (Outset ℝ
d obj
symbObj) =
    ℝ -> (f a, f a) -> (f a, f a)
forall a. (VectorStuff a, Num a) => ℝ -> (a, a) -> (a, a)
outsetBox ℝ
d ((f a, f a) -> (f a, f a)) -> (f a, f a) -> (f a, f a)
forall a b. (a -> b) -> a -> b
$ obj -> (f a, f a)
forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
-- Misc
getBoxShared (WithRounding ℝ
_ obj
obj) = obj -> (f a, f a)
forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
obj
getBoxShared (EmbedBoxedObj (f a -> a
_,(f a, f a)
box)) = (f a, f a)
box