{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.ThreeD.Shapes
-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Various three-dimensional shapes.
--
-----------------------------------------------------------------------------

module Diagrams.ThreeD.Shapes
  (
    -- * Skinned class
    Skinned(..)

    -- * Basic 3D shapes
  , Ellipsoid(..)
  , sphere

  , Box(..)
  , cube

  , Frustum(..)
  , frustum
  , cone
  , cylinder

    -- * Constructive solid geometry
  , CSG(..)
  , union
  , intersection
  , difference
  ) where

import           Control.Lens              (review, (^.), _1)
import           Data.Typeable

import           Data.Semigroup
import           Diagrams.Angle
import           Diagrams.Core
import           Diagrams.Core.Trace
import           Diagrams.Points
import           Diagrams.Query
import           Diagrams.Solve.Polynomial
import           Diagrams.ThreeD.Types
import           Diagrams.ThreeD.Vector

import           Linear.Affine
import           Linear.Metric
import           Linear.Vector

data Ellipsoid n = Ellipsoid (Transformation V3 n)
  deriving Typeable

type instance V (Ellipsoid n) = V3
type instance N (Ellipsoid n) = n

instance Fractional n => Transformable (Ellipsoid n) where
  transform :: Transformation (V (Ellipsoid n)) (N (Ellipsoid n))
-> Ellipsoid n -> Ellipsoid n
transform Transformation (V (Ellipsoid n)) (N (Ellipsoid n))
t1 (Ellipsoid Transformation V3 n
t2) = forall n. Transformation V3 n -> Ellipsoid n
Ellipsoid (Transformation (V (Ellipsoid n)) (N (Ellipsoid n))
t1 forall a. Semigroup a => a -> a -> a
<> Transformation V3 n
t2)

instance Fractional n => Renderable (Ellipsoid n) NullBackend where
  render :: NullBackend
-> Ellipsoid n
-> Render NullBackend (V (Ellipsoid n)) (N (Ellipsoid n))
render NullBackend
_ Ellipsoid n
_ = forall a. Monoid a => a
mempty

instance OrderedField n => Enveloped (Ellipsoid n) where
  getEnvelope :: Ellipsoid n -> Envelope (V (Ellipsoid n)) (N (Ellipsoid n))
getEnvelope (Ellipsoid Transformation V3 n
tr) = forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation V3 n
tr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. (v n -> n) -> Envelope v n
mkEnvelope forall a b. (a -> b) -> a -> b
$ \V3 n
v -> n
1 forall a. Fractional a => a -> a -> a
/ forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm V3 n
v

instance OrderedField n => Traced (Ellipsoid n) where
  getTrace :: Ellipsoid n -> Trace (V (Ellipsoid n)) (N (Ellipsoid n))
getTrace (Ellipsoid Transformation V3 n
tr) = forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation V3 n
tr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Point v n -> v n -> SortedList n) -> Trace v n
mkTrace forall a b. (a -> b) -> a -> b
$ \(P V3 n
p) V3 n
v -> let
    a :: n
a  =    V3 n
v forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V3 n
v
    b :: n
b  = n
2 forall a. Num a => a -> a -> a
* (V3 n
p forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V3 n
v)
    c :: n
c  =    (V3 n
p forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V3 n
p) forall a. Num a => a -> a -> a
- n
1
    in
     forall a. Ord a => [a] -> SortedList a
mkSortedList forall a b. (a -> b) -> a -> b
$ forall d. (Floating d, Ord d) => d -> d -> d -> [d]
quadForm n
a n
b n
c

-- | A sphere of radius 1 with its center at the origin.
sphere :: Num n => Ellipsoid n
sphere :: forall n. Num n => Ellipsoid n
sphere = forall n. Transformation V3 n -> Ellipsoid n
Ellipsoid forall a. Monoid a => a
mempty

data Box n = Box (Transformation V3 n)
  deriving Typeable

type instance V (Box n) = V3
type instance N (Box n) = n

instance Fractional n => Transformable (Box n) where
  transform :: Transformation (V (Box n)) (N (Box n)) -> Box n -> Box n
transform Transformation (V (Box n)) (N (Box n))
t1 (Box Transformation V3 n
t2) = forall n. Transformation V3 n -> Box n
Box (Transformation (V (Box n)) (N (Box n))
t1 forall a. Semigroup a => a -> a -> a
<> Transformation V3 n
t2)

instance Fractional n => Renderable (Box n) NullBackend where
  render :: NullBackend -> Box n -> Render NullBackend (V (Box n)) (N (Box n))
render NullBackend
_ Box n
_ = forall a. Monoid a => a
mempty

instance OrderedField n => Enveloped (Box n) where
  getEnvelope :: Box n -> Envelope (V (Box n)) (N (Box n))
getEnvelope (Box Transformation V3 n
tr) = forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation V3 n
tr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. (v n -> n) -> Envelope v n
mkEnvelope forall a b. (a -> b) -> a -> b
$ \V3 n
v ->
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map (V3 n
v forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot`) [V3 n]
corners) forall a. Fractional a => a -> a -> a
/ forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance V3 n
v where
      corners :: [V3 n]
corners = forall n. n -> n -> n -> V3 n
mkR3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [n
0,n
1] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [n
0,n
1] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [n
0,n
1]

instance (Fractional n, Ord n) => Traced (Box n) where
  getTrace :: Box n -> Trace (V (Box n)) (N (Box n))
getTrace (Box Transformation V3 n
tr) = forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation V3 n
tr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Point v n -> v n -> SortedList n) -> Trace v n
mkTrace forall a b. (a -> b) -> a -> b
$ \Point V3 n
p V3 n
v -> let
    (n
x0, n
y0, n
z0) = forall n. P3 n -> (n, n, n)
unp3 Point V3 n
p
    (n
vx, n
vy, n
vz) = forall n. V3 n -> (n, n, n)
unr3 V3 n
v
    intersections :: a -> a -> [a]
intersections a
f a
d = case a
d of
      a
0 -> []
      a
_ -> [-a
fforall a. Fractional a => a -> a -> a
/a
d, (a
1forall a. Num a => a -> a -> a
-a
f)forall a. Fractional a => a -> a -> a
/a
d]
    ts :: [n]
ts = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. (Eq a, Fractional a) => a -> a -> [a]
intersections [n
x0,n
y0,n
z0] [n
vx,n
vy,n
vz]
    atT :: n -> Point V3 n
atT n
t = Point V3 n
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (n
tforall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^V3 n
v)
    range :: P3 a -> Bool
range P3 a
u = forall (t :: * -> *). Foldable t => t Bool -> Bool
and [a
x forall a. Ord a => a -> a -> Bool
>= a
0, a
x forall a. Ord a => a -> a -> Bool
<= a
1, a
y forall a. Ord a => a -> a -> Bool
>= a
0, a
y forall a. Ord a => a -> a -> Bool
<= a
1, a
z forall a. Ord a => a -> a -> Bool
>= a
0, a
z forall a. Ord a => a -> a -> Bool
<= a
1] where
      (a
x, a
y, a
z) = forall n. P3 n -> (n, n, n)
unp3 P3 a
u
    in
     -- ts gives all intersections with the planes forming the box
     -- filter keeps only those actually on the box surface
     forall a. Ord a => [a] -> SortedList a
mkSortedList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall {a}. (Ord a, Num a) => P3 a -> Bool
range forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Point V3 n
atT) forall a b. (a -> b) -> a -> b
$ [n]
ts where

-- | A cube with side length 1, in the positive octant, with one
-- vertex at the origin.
cube :: Num n => Box n
cube :: forall n. Num n => Box n
cube = forall n. Transformation V3 n -> Box n
Box forall a. Monoid a => a
mempty

data Frustum n = Frustum n n (Transformation V3 n)
  deriving Typeable

type instance V (Frustum n) = V3
type instance N (Frustum n) = n

instance Fractional n => Transformable (Frustum n) where
  transform :: Transformation (V (Frustum n)) (N (Frustum n))
-> Frustum n -> Frustum n
transform Transformation (V (Frustum n)) (N (Frustum n))
t1 (Frustum n
r0 n
r1 Transformation V3 n
t2) = forall n. n -> n -> Transformation V3 n -> Frustum n
Frustum n
r0 n
r1 (Transformation (V (Frustum n)) (N (Frustum n))
t1 forall a. Semigroup a => a -> a -> a
<> Transformation V3 n
t2)

instance Fractional n => Renderable (Frustum n) NullBackend where
  render :: NullBackend
-> Frustum n -> Render NullBackend (V (Frustum n)) (N (Frustum n))
render NullBackend
_ Frustum n
_ = forall a. Monoid a => a
mempty

instance (OrderedField n, RealFloat n) => Enveloped (Frustum n) where
  -- The plane containing v and the z axis intersects the frustum in a trapezoid
  -- Test the four corners of this trapezoid; one must determine the Envelope
  getEnvelope :: Frustum n -> Envelope (V (Frustum n)) (N (Frustum n))
getEnvelope (Frustum n
r0 n
r1 Transformation V3 n
tr) = forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation V3 n
tr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. (v n -> n) -> Envelope v n
mkEnvelope forall a b. (a -> b) -> a -> b
$ \V3 n
v ->let
    θ :: Angle n
θ = V3 n
v forall s a. s -> Getting a s a -> a
^. forall (t :: * -> *) n.
(HasTheta t, RealFloat n) =>
Lens' (t n) (Angle n)
_theta
    corners :: [(n, Angle n, n)]
corners = [(n
r1,Angle n
θ,n
1), (-n
r1,Angle n
θ,n
1), (n
r0,Angle n
θ,n
0), (-n
r0,Angle n
θ,n
0)]
    in
     forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) a.
(Metric v, Fractional a) =>
v a -> v a -> v a
project V3 n
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review forall n. RealFloat n => Iso' (V3 n) (n, Angle n, n)
r3CylindricalIso) forall a b. (a -> b) -> a -> b
$ [(n, Angle n, n)]
corners

instance (RealFloat n, Ord n) => Traced (Frustum n) where
  -- The trace can intersect the sides of the cone or one of the end
  -- caps The sides are described by a quadric equation; substitute
  -- in the parametric form of the ray but disregard any
  -- intersections outside z = [0,1] Similarly, find intersections
  -- with the planes z=0, z=1, but disregard any r>r0, r>r1
  getTrace :: Frustum n -> Trace (V (Frustum n)) (N (Frustum n))
getTrace (Frustum n
r0 n
r1 Transformation V3 n
tr) = forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation V3 n
tr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Point v n -> v n -> SortedList n) -> Trace v n
mkTrace forall a b. (a -> b) -> a -> b
$ \Point V3 n
p V3 n
v -> let
    (n
px, n
py, n
pz) = forall n. P3 n -> (n, n, n)
unp3 Point V3 n
p
    (n
vx, n
vy, n
vz) = forall n. V3 n -> (n, n, n)
unr3 V3 n
v
    ray :: n -> Point V3 n
ray n
t = Point V3 n
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ n
t forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ V3 n
v
    dr :: n
dr = n
r1 forall a. Num a => a -> a -> a
- n
r0
    a :: n
a = n
vxforall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
+ n
vyforall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
- n
vzforall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
* n
drforall a. Floating a => a -> a -> a
**n
2
    b :: n
b = n
2 forall a. Num a => a -> a -> a
* (n
px forall a. Num a => a -> a -> a
* n
vx forall a. Num a => a -> a -> a
+ n
py forall a. Num a => a -> a -> a
* n
vy forall a. Num a => a -> a -> a
- (n
r0forall a. Num a => a -> a -> a
+n
pzforall a. Num a => a -> a -> a
*n
dr) forall a. Num a => a -> a -> a
* n
dr  forall a. Num a => a -> a -> a
* n
vz)
    c :: n
c = n
pxforall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
+ n
pyforall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
- (n
r0 forall a. Num a => a -> a -> a
+ n
drforall a. Num a => a -> a -> a
*n
pz)forall a. Floating a => a -> a -> a
**n
2
    zbounds :: n -> Bool
zbounds n
t = n -> Point V3 n
ray n
t forall s a. s -> Getting a s a -> a
^. forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z forall a. Ord a => a -> a -> Bool
>= n
0
         Bool -> Bool -> Bool
&& n -> Point V3 n
ray n
t forall s a. s -> Getting a s a -> a
^. forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z forall a. Ord a => a -> a -> Bool
<= n
1
    ends :: [n]
ends = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap n -> [n]
cap [n
0,n
1]
    cap :: n -> [n]
cap n
z = [ n
t | n -> Point V3 n
ray n
t forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *) a (g :: * -> *) b.
Lens (Point f a) (Point g b) (f a) (g b)
lensP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. RealFloat n => Iso' (V3 n) (n, Angle n, n)
r3CylindricalIso forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall a. Ord a => a -> a -> Bool
< n
r0 forall a. Num a => a -> a -> a
+ n
z forall a. Num a => a -> a -> a
* n
dr ]
      where
      t :: n
t = (n
z forall a. Num a => a -> a -> a
- n
pz) forall a. Fractional a => a -> a -> a
/ n
vz
    in
     forall a. Ord a => [a] -> SortedList a
mkSortedList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter n -> Bool
zbounds (forall d. (Floating d, Ord d) => d -> d -> d -> [d]
quadForm n
a n
b n
c) forall a. [a] -> [a] -> [a]
++ [n]
ends

-- | A frustum of a right circular cone.  It has height 1 oriented
-- along the positive z axis, and radii r0 and r1 at Z=0 and Z=1.
-- 'cone' and 'cylinder' are special cases.
frustum :: Num n => n -> n -> Frustum n
frustum :: forall n. Num n => n -> n -> Frustum n
frustum n
r0 n
r1 = forall n. n -> n -> Transformation V3 n -> Frustum n
Frustum n
r0 n
r1 forall a. Monoid a => a
mempty

-- | A cone with its base centered on the origin, with radius 1 at the
-- base, height 1, and it's apex on the positive Z axis.
cone :: Num n => Frustum n
cone :: forall n. Num n => Frustum n
cone = forall n. Num n => n -> n -> Frustum n
frustum n
1 n
0

-- | A circular cylinder of radius 1 with one end cap centered on the
-- origin, and extending to Z=1.
cylinder :: Num n => Frustum n
cylinder :: forall n. Num n => Frustum n
cylinder = forall n. Num n => n -> n -> Frustum n
frustum n
1 n
1

-- | Types which can be rendered as 3D Diagrams.
class Skinned t where
  skin :: (Renderable t b, N t ~ n, TypeableFloat n) => t -> QDiagram b V3 n Any

instance (Num n, Ord n) => HasQuery (Ellipsoid n) Any where
  getQuery :: Ellipsoid n -> Query (V (Ellipsoid n)) (N (Ellipsoid n)) Any
getQuery (Ellipsoid Transformation V3 n
tr) = forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation V3 n
tr forall a b. (a -> b) -> a -> b
$
    forall (v :: * -> *) n m. (Point v n -> m) -> Query v n m
Query forall a b. (a -> b) -> a -> b
$ \Point (V (Ellipsoid n)) (N (Ellipsoid n))
v -> Bool -> Any
Any forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance (Point (V (Ellipsoid n)) (N (Ellipsoid n))
v forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin) forall a. Ord a => a -> a -> Bool
<= n
1

instance OrderedField n => Skinned (Ellipsoid n) where
  skin :: forall b n.
(Renderable (Ellipsoid n) b, N (Ellipsoid n) ~ n,
 TypeableFloat n) =>
Ellipsoid n -> QDiagram b V3 n Any
skin Ellipsoid n
s = forall b (v :: * -> *) n m.
Prim b v n
-> Envelope v n
-> Trace v n
-> SubMap b v n m
-> Query v n m
-> QDiagram b v n m
mkQD (forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim Ellipsoid n
s) (forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Ellipsoid n
s) (forall a. Traced a => a -> Trace (V a) (N a)
getTrace Ellipsoid n
s) forall a. Monoid a => a
mempty (forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery Ellipsoid n
s)

instance (Num n, Ord n) => HasQuery (Box n) Any where
  getQuery :: Box n -> Query (V (Box n)) (N (Box n)) Any
getQuery (Box Transformation V3 n
tr) = forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation V3 n
tr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n m. (Point v n -> m) -> Query v n m
Query forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Ord a, Num a) => P3 a -> Bool
range where
    range :: P3 a -> Bool
range P3 a
u = forall (t :: * -> *). Foldable t => t Bool -> Bool
and [a
x forall a. Ord a => a -> a -> Bool
>= a
0, a
x forall a. Ord a => a -> a -> Bool
<= a
1, a
y forall a. Ord a => a -> a -> Bool
>= a
0, a
y forall a. Ord a => a -> a -> Bool
<= a
1, a
z forall a. Ord a => a -> a -> Bool
>= a
0, a
z forall a. Ord a => a -> a -> Bool
<= a
1] where
      (a
x, a
y, a
z) = forall n. P3 n -> (n, n, n)
unp3 P3 a
u

instance OrderedField n => Skinned (Box n) where
  skin :: forall b n.
(Renderable (Box n) b, N (Box n) ~ n, TypeableFloat n) =>
Box n -> QDiagram b V3 n Any
skin Box n
s = forall b (v :: * -> *) n m.
Prim b v n
-> Envelope v n
-> Trace v n
-> SubMap b v n m
-> Query v n m
-> QDiagram b v n m
mkQD (forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim Box n
s) (forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Box n
s) (forall a. Traced a => a -> Trace (V a) (N a)
getTrace Box n
s) forall a. Monoid a => a
mempty (forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery Box n
s)

instance (OrderedField n) => HasQuery (Frustum n) Any where
  getQuery :: Frustum n -> Query (V (Frustum n)) (N (Frustum n)) Any
getQuery (Frustum n
r0 n
r1 Transformation V3 n
tr)= forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation V3 n
tr forall a b. (a -> b) -> a -> b
$
    forall (v :: * -> *) n m. (Point v n -> m) -> Query v n m
Query forall a b. (a -> b) -> a -> b
$ \Point (V (Frustum n)) (N (Frustum n))
p -> let
      z :: n
z = Point (V (Frustum n)) (N (Frustum n))
pforall s a. s -> Getting a s a -> a
^.forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z
      r :: n
r = n
r0 forall a. Num a => a -> a -> a
+ (n
r1 forall a. Num a => a -> a -> a
- n
r0)forall a. Num a => a -> a -> a
*n
z
      v :: Diff (Point V3) n
v = Point (V (Frustum n)) (N (Frustum n))
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin
      a :: n
a = forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *} {a}.
(Metric f, Fractional a, R3 f) =>
f a -> f a
projectXY Diff (Point V3) n
v
      projectXY :: f a -> f a
projectXY f a
u = f a
u forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ forall (v :: * -> *) a.
(Metric v, Fractional a) =>
v a -> v a -> v a
project forall (v :: * -> *) n. (R3 v, Additive v, Num n) => v n
unitZ f a
u
      in
       Bool -> Any
Any forall a b. (a -> b) -> a -> b
$ n
z forall a. Ord a => a -> a -> Bool
>= n
0 Bool -> Bool -> Bool
&& n
z forall a. Ord a => a -> a -> Bool
<= n
1 Bool -> Bool -> Bool
&& n
a forall a. Ord a => a -> a -> Bool
<= n
r

instance Skinned (Frustum n) where
  skin :: forall b n.
(Renderable (Frustum n) b, N (Frustum n) ~ n, TypeableFloat n) =>
Frustum n -> QDiagram b V3 n Any
skin Frustum n
s = forall b (v :: * -> *) n m.
Prim b v n
-> Envelope v n
-> Trace v n
-> SubMap b v n m
-> Query v n m
-> QDiagram b v n m
mkQD (forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim Frustum n
s) (forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Frustum n
s) (forall a. Traced a => a -> Trace (V a) (N a)
getTrace Frustum n
s) forall a. Monoid a => a
mempty (forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery Frustum n
s)

-- The CSG type needs to form a tree to be useful.  This
-- implementation requires Backends to support all the included
-- primitives.  If that turns out to be a problem, we have several
-- options:
-- a) accept runtime errors for unsupported primitives
-- b) carry the set of primitives in a row type in the CSG type
-- c) implement CSG in Haskell, so Backends supporting triangle meshes
--    can fall back to those.
-- (c) is worth doing anyway; I'm ambivalent about the others.  -DMB

-- | A tree of Constructive Solid Geometry operations and the primitives that
-- can be used in them.
data CSG n
  = CsgEllipsoid (Ellipsoid n)
  | CsgBox (Box n)
  | CsgFrustum (Frustum n)
  | CsgUnion [CSG n]
  | CsgIntersection [CSG n]
  | CsgDifference (CSG n) (CSG n)
  deriving Typeable

type instance V (CSG n) = V3
type instance N (CSG n) = n

instance Fractional n => Transformable (CSG n) where
  transform :: Transformation (V (CSG n)) (N (CSG n)) -> CSG n -> CSG n
transform Transformation (V (CSG n)) (N (CSG n))
t (CsgEllipsoid Ellipsoid n
p) = forall n. Ellipsoid n -> CSG n
CsgEllipsoid forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (CSG n)) (N (CSG n))
t Ellipsoid n
p
  transform Transformation (V (CSG n)) (N (CSG n))
t (CsgBox Box n
p) = forall n. Box n -> CSG n
CsgBox forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (CSG n)) (N (CSG n))
t Box n
p
  transform Transformation (V (CSG n)) (N (CSG n))
t (CsgFrustum Frustum n
p) = forall n. Frustum n -> CSG n
CsgFrustum forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (CSG n)) (N (CSG n))
t Frustum n
p
  transform Transformation (V (CSG n)) (N (CSG n))
t (CsgUnion [CSG n]
ps) = forall n. [CSG n] -> CSG n
CsgUnion forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (CSG n)) (N (CSG n))
t) [CSG n]
ps
  transform Transformation (V (CSG n)) (N (CSG n))
t (CsgIntersection [CSG n]
ps) = forall n. [CSG n] -> CSG n
CsgIntersection forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (CSG n)) (N (CSG n))
t) [CSG n]
ps
  transform Transformation (V (CSG n)) (N (CSG n))
t (CsgDifference CSG n
p1 CSG n
p2) = forall n. CSG n -> CSG n -> CSG n
CsgDifference (forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (CSG n)) (N (CSG n))
t CSG n
p1) (forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (CSG n)) (N (CSG n))
t CSG n
p2)

-- | The Envelope for an Intersection or Difference is simply the
-- Envelope of the Union.  This is wrong but easy to implement.
instance RealFloat n => Enveloped (CSG n) where
  getEnvelope :: CSG n -> Envelope (V (CSG n)) (N (CSG n))
getEnvelope (CsgEllipsoid Ellipsoid n
p)      = forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Ellipsoid n
p
  getEnvelope (CsgBox Box n
p)            = forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Box n
p
  getEnvelope (CsgFrustum Frustum n
p)        = forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Frustum n
p
  getEnvelope (CsgUnion [CSG n]
ps)         = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope [CSG n]
ps
  getEnvelope (CsgIntersection [CSG n]
ps)  = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope [CSG n]
ps
  getEnvelope (CsgDifference CSG n
p1 CSG n
p2) = forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope CSG n
p1 forall a. Semigroup a => a -> a -> a
<> forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope CSG n
p2
-- TODO after implementing some approximation scheme, calculate
-- correct (approximate) envelopes for intersections and difference.

instance (Floating n, Ord n) => HasQuery (CSG n) Any where
  getQuery :: CSG n -> Query (V (CSG n)) (N (CSG n)) Any
getQuery (CsgEllipsoid Ellipsoid n
prim) = forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery Ellipsoid n
prim
  getQuery (CsgBox Box n
prim) = forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery Box n
prim
  getQuery (CsgFrustum Frustum n
prim) = forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery Frustum n
prim
  getQuery (CsgUnion [CSG n]
ps) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery [CSG n]
ps
  getQuery (CsgIntersection [CSG n]
ps) =
    Bool -> Any
Any forall b c a. (b -> c) -> (a -> b) -> a -> c
. All -> Bool
getAll forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> All
All forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Bool
getAny) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery) [CSG n]
ps
  getQuery (CsgDifference CSG n
p1 CSG n
p2) = Any -> Any -> Any
inOut forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery CSG n
p1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery CSG n
p2 where
    inOut :: Any -> Any -> Any
inOut (Any Bool
a) (Any Bool
b) = Bool -> Any
Any forall a b. (a -> b) -> a -> b
$ Bool
a Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
b

instance (RealFloat n, Ord n) => Traced (CSG n) where
  getTrace :: CSG n -> Trace (V (CSG n)) (N (CSG n))
getTrace (CsgEllipsoid Ellipsoid n
p) = forall a. Traced a => a -> Trace (V a) (N a)
getTrace Ellipsoid n
p
  getTrace (CsgBox Box n
p) = forall a. Traced a => a -> Trace (V a) (N a)
getTrace Box n
p
  getTrace (CsgFrustum Frustum n
p) = forall a. Traced a => a -> Trace (V a) (N a)
getTrace Frustum n
p
  -- on surface of some p, and not inside any of the others
  getTrace (CsgUnion []) = forall a. Monoid a => a
mempty
  getTrace (CsgUnion (CSG n
s:[CSG n]
ss)) = forall (v :: * -> *) n.
(Point v n -> v n -> SortedList n) -> Trace v n
mkTrace Point V3 n -> V3 n -> SortedList n
t where
    t :: Point V3 n -> V3 n -> SortedList n
t Point V3 n
pt V3 n
v = forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList (forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ CSG n -> n -> Bool
without CSG n
s) (forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (forall a. Traced a => a -> Trace (V a) (N a)
getTrace (forall n. [CSG n] -> CSG n
CsgUnion [CSG n]
ss)) Point V3 n
pt V3 n
v)
         forall a. Semigroup a => a -> a -> a
<> forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList (forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ CSG n -> n -> Bool
without (forall n. [CSG n] -> CSG n
CsgUnion [CSG n]
ss)) (forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (forall a. Traced a => a -> Trace (V a) (N a)
getTrace CSG n
s) Point V3 n
pt V3 n
v) where
      newPt :: n -> Point V3 n
newPt n
dist = Point V3 n
pt forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V3 n
v forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* n
dist
      without :: CSG n -> n -> Bool
without CSG n
prim = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. HasQuery t Any => t -> Point (V t) (N t) -> Bool
inquire CSG n
prim forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Point V3 n
newPt
  -- on surface of some p, and inside all the others
  getTrace (CsgIntersection []) = forall a. Monoid a => a
mempty
  getTrace (CsgIntersection (CSG n
s:[CSG n]
ss)) = forall (v :: * -> *) n.
(Point v n -> v n -> SortedList n) -> Trace v n
mkTrace Point V3 n -> V3 n -> SortedList n
t where
    t :: Point V3 n -> V3 n -> SortedList n
t Point V3 n
pt V3 n
v = forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList (forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ CSG n -> n -> Bool
within CSG n
s) (forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (forall a. Traced a => a -> Trace (V a) (N a)
getTrace (forall n. [CSG n] -> CSG n
CsgIntersection [CSG n]
ss)) Point V3 n
pt V3 n
v)
         forall a. Semigroup a => a -> a -> a
<> forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList (forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ CSG n -> n -> Bool
within (forall n. [CSG n] -> CSG n
CsgIntersection [CSG n]
ss)) (forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (forall a. Traced a => a -> Trace (V a) (N a)
getTrace CSG n
s) Point V3 n
pt V3 n
v) where
      newPt :: n -> Point V3 n
newPt n
dist = Point V3 n
pt forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V3 n
v forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* n
dist
      within :: CSG n -> n -> Bool
within CSG n
prim = forall t. HasQuery t Any => t -> Point (V t) (N t) -> Bool
inquire CSG n
prim forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Point V3 n
newPt
  -- on surface of p1, outside p2, or on surface of p2, inside p1
  getTrace (CsgDifference CSG n
s1 CSG n
s2) = forall (v :: * -> *) n.
(Point v n -> v n -> SortedList n) -> Trace v n
mkTrace Point V3 n -> V3 n -> SortedList n
t where
    t :: Point V3 n -> V3 n -> SortedList n
t Point V3 n
pt V3 n
v = forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList (forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSG n -> n -> Bool
within CSG n
s2) (forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (forall a. Traced a => a -> Trace (V a) (N a)
getTrace CSG n
s1) Point V3 n
pt V3 n
v)
         forall a. Semigroup a => a -> a -> a
<> forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList (forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ CSG n -> n -> Bool
within CSG n
s1) (forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (forall a. Traced a => a -> Trace (V a) (N a)
getTrace CSG n
s2) Point V3 n
pt V3 n
v) where
      newPt :: n -> Point V3 n
newPt n
dist = Point V3 n
pt forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V3 n
v forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* n
dist
      within :: CSG n -> n -> Bool
within CSG n
prim = forall t. HasQuery t Any => t -> Point (V t) (N t) -> Bool
inquire CSG n
prim forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Point V3 n
newPt

instance (RealFloat n, Ord n) => Skinned (CSG n) where
  skin :: forall b n.
(Renderable (CSG n) b, N (CSG n) ~ n, TypeableFloat n) =>
CSG n -> QDiagram b V3 n Any
skin CSG n
s = forall b (v :: * -> *) n m.
Prim b v n
-> Envelope v n
-> Trace v n
-> SubMap b v n m
-> Query v n m
-> QDiagram b v n m
mkQD (forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim CSG n
s) (forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope CSG n
s) (forall a. Traced a => a -> Trace (V a) (N a)
getTrace CSG n
s) forall a. Monoid a => a
mempty (forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery CSG n
s)

-- | Types which can be included in CSG trees.
class CsgPrim a where
  toCsg :: a n -> CSG n

instance CsgPrim Ellipsoid where
  toCsg :: forall n. Ellipsoid n -> CSG n
toCsg = forall n. Ellipsoid n -> CSG n
CsgEllipsoid

instance CsgPrim Box where
  toCsg :: forall n. Box n -> CSG n
toCsg = forall n. Box n -> CSG n
CsgBox

instance CsgPrim Frustum where
  toCsg :: forall n. Frustum n -> CSG n
toCsg = forall n. Frustum n -> CSG n
CsgFrustum

instance CsgPrim CSG where
  toCsg :: forall n. CSG n -> CSG n
toCsg = forall a. a -> a
id

union :: (CsgPrim a, CsgPrim b) => a n -> b n -> CSG n
union :: forall (a :: * -> *) (b :: * -> *) n.
(CsgPrim a, CsgPrim b) =>
a n -> b n -> CSG n
union a n
a b n
b = forall n. [CSG n] -> CSG n
CsgUnion [forall (a :: * -> *) n. CsgPrim a => a n -> CSG n
toCsg a n
a, forall (a :: * -> *) n. CsgPrim a => a n -> CSG n
toCsg b n
b]

intersection :: (CsgPrim a, CsgPrim b) => a n -> b n -> CSG n
intersection :: forall (a :: * -> *) (b :: * -> *) n.
(CsgPrim a, CsgPrim b) =>
a n -> b n -> CSG n
intersection a n
a b n
b = forall n. [CSG n] -> CSG n
CsgIntersection [forall (a :: * -> *) n. CsgPrim a => a n -> CSG n
toCsg a n
a, forall (a :: * -> *) n. CsgPrim a => a n -> CSG n
toCsg b n
b]

difference :: (CsgPrim a, CsgPrim b) => a n -> b n -> CSG n
difference :: forall (a :: * -> *) (b :: * -> *) n.
(CsgPrim a, CsgPrim b) =>
a n -> b n -> CSG n
difference a n
a b n
b = forall n. CSG n -> CSG n -> CSG n
CsgDifference (forall (a :: * -> *) n. CsgPrim a => a n -> CSG n
toCsg a n
a) (forall (a :: * -> *) n. CsgPrim a => a n -> CSG n
toCsg b n
b)