{- 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 = 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
    , forall a. a -> a -> V2 a
V2 ℝ
x1 ℝ
y2
    , forall a. a -> a -> V2 a
V2 ℝ
x2 ℝ
y1
    , ℝ2
p2
    ]
  pointwise :: (ℝ -> ℝ -> ℝ) -> ℝ2 -> ℝ2 -> ℝ2
pointwise = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
  elements :: ℝ2 -> [ℝ]
elements = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  {-# INLINABLE uniformV #-}
  {-# INLINABLE pointwise #-}
  {-# INLINABLE elements #-}
  {-# INLINABLE corners #-}

instance VectorStuff ℝ3 where
  uniformV :: ℝ -> ℝ3
uniformV = 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
    , forall a. a -> a -> a -> V3 a
V3 ℝ
x1 ℝ
y2 ℝ
z1
    , forall a. a -> a -> a -> V3 a
V3 ℝ
x2 ℝ
y2 ℝ
z1
    , forall a. a -> a -> a -> V3 a
V3 ℝ
x2 ℝ
y1 ℝ
z1
    , forall a. a -> a -> a -> V3 a
V3 ℝ
x1 ℝ
y1 ℝ
z2
    , forall a. a -> a -> a -> V3 a
V3 ℝ
x2 ℝ
y1 ℝ
z2
    , forall a. a -> a -> a -> V3 a
V3 ℝ
x1 ℝ
y2 ℝ
z2
    , ℝ3
p2
    ]
  pointwise :: (ℝ -> ℝ -> ℝ) -> ℝ3 -> ℝ3 -> ℝ3
pointwise = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
  elements :: ℝ3 -> [ℝ]
elements  = 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 :: forall a. VectorStuff a => [(a, a)] -> (a, a)
intersectBoxes [] = forall vec. VectorStuff vec => (vec, vec)
fullBox
intersectBoxes ((a, a)
b : [(a, a)]
boxes)
  = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c d e f.
(a -> b -> c) -> (d -> e -> f) -> (a, d) -> (b, e) -> (c, f)
biapp (forall vec. VectorStuff vec => (ℝ -> ℝ -> ℝ) -> vec -> vec -> vec
pointwise forall a. Ord a => a -> a -> a
max) (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 :: forall a b c d e f.
(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 :: forall (f :: * -> *) a. (Applicative f, Num a) => (f a, f a)
emptyBox = (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
0, forall (f :: * -> *) a. Applicative f => a -> f a
pure a
0)
{-# INLINABLE emptyBox #-}

-- | A full box.
fullBox :: (VectorStuff vec) => (vec, vec)
fullBox :: forall vec. VectorStuff vec => (vec, vec)
fullBox = (forall vec. VectorStuff vec => ℝ -> vec
uniformV (-forall t. Fractional t => t
infty), 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 :: forall (f :: * -> *) a.
(Applicative f, Num a, VectorStuff (f a)) =>
[f a] -> (f a, f a)
pointsBox [] = forall (f :: * -> *) a. (Applicative f, Num a) => (f a, f a)
emptyBox
pointsBox (f a
a : [f a]
as) = (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall vec. VectorStuff vec => (ℝ -> ℝ -> ℝ) -> vec -> vec -> vec
pointwise forall a. Ord a => a -> a -> a
min) f a
a [f a]
as, forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall vec. VectorStuff vec => (ℝ -> ℝ -> ℝ) -> vec -> vec -> vec
pointwise forall a. Ord a => a -> a -> a
max) f a
a [f a]
as)
{-# INLINABLE pointsBox #-}

------------------------------------------------------------------------------
-- | 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 :: 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
  = forall a. (VectorStuff a, Num a) => ℝ -> (a, a) -> (a, a)
outsetBox ℝ
r
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
(Applicative f, Num a, VectorStuff (f a)) =>
[f a] -> (f a, f a)
pointsBox
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall vec. VectorStuff vec => (vec, vec) -> [vec]
corners
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
(Eq (f a), Applicative f, Num a, Num (f a)) =>
(f a, f a) -> Bool
isEmpty)
{-# INLINABLE unionBoxes #-}

-- | Is a box empty?
isEmpty :: (Eq (f a), Applicative f, Num a, Num (f a)) => (f a, f a) -> Bool
isEmpty :: forall (f :: * -> *) a.
(Eq (f a), Applicative f, Num a, Num (f a)) =>
(f a, f a) -> Bool
isEmpty (f a
v1, f a
v2) = (f a
v1 forall a. Num a => a -> a -> a
- f a
v2) forall a. Eq a => a -> a -> Bool
== 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 :: forall a. (VectorStuff a, Num a) => ℝ -> (a, a) -> (a, a)
outsetBox ℝ
r (a
a, a
b) = (a
a forall a. Num a => a -> a -> a
- forall vec. VectorStuff vec => ℝ -> vec
uniformV ℝ
r, a
b forall a. Num 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)
{-# INLINABLE getBoxShared #-}
-- Primitives
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)
getBoxShared SharedObj obj f a
Empty = forall (f :: * -> *) a. (Applicative f, Num a) => (f a, f a)
emptyBox
getBoxShared SharedObj obj f a
Full  = forall vec. VectorStuff vec => (vec, vec)
fullBox
-- (Rounded) CSG
getBoxShared (Complement obj
_) = forall vec. VectorStuff vec => (vec, vec)
fullBox
getBoxShared (UnionR ℝ
r [obj]
symbObjs) = 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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox [obj]
symbObjs
getBoxShared (DifferenceR ℝ
_ obj
symbObj [obj]
_)  = forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
getBoxShared (IntersectR ℝ
_ [obj]
symbObjs) =
  forall a. VectorStuff a => [(a, a)] -> (a, a)
intersectBoxes forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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) = forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
     in (f a
a forall a. Num a => a -> a -> a
+ f a
v, f a
b 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) = forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
        sa :: f a
sa = f a
s forall a. ComponentWiseMultable a => a -> a -> a
⋯* f a
a
        sb :: f a
sb = f a
s forall a. ComponentWiseMultable a => a -> a -> a
⋯* f a
b
     in 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) =
  forall (f :: * -> *) a.
(Applicative f, Num a, VectorStuff (f a)) =>
[f a] -> (f a, f a)
pointsBox forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a.
(Num (f a), Fractional a, Metric f) =>
f a -> f a -> f a
reflect f a
v) forall a b. (a -> b) -> a -> b
$ forall vec. VectorStuff vec => (vec, vec) -> [vec]
corners forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
-- Boundary mods
getBoxShared (Shell ℝ
w obj
symbObj) =
    forall a. (VectorStuff a, Num a) => ℝ -> (a, a) -> (a, a)
outsetBox (ℝ
wforall a. Fractional a => a -> a -> a
/ℝ
2) forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
getBoxShared (Outset ℝ
d obj
symbObj) =
    forall a. (VectorStuff a, Num a) => ℝ -> (a, a) -> (a, a)
outsetBox ℝ
d forall a b. (a -> b) -> a -> b
$ forall obj (f :: * -> *) a. Object obj f a => obj -> (f a, f a)
getBox obj
symbObj
-- Misc
getBoxShared (WithRounding ℝ
_ obj
obj) = 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