{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeFamilies          #-}
{-# 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) = Transformation V3 n -> Ellipsoid n
forall n. Transformation V3 n -> Ellipsoid n
Ellipsoid (Transformation (V (Ellipsoid n)) (N (Ellipsoid n))
Transformation V3 n
t1 Transformation V3 n -> Transformation V3 n -> Transformation V3 n
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
_ = Render NullBackend (V (Ellipsoid n)) (N (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) = Transformation (V (Envelope V3 n)) (N (Envelope V3 n))
-> Envelope V3 n -> Envelope V3 n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Envelope V3 n)) (N (Envelope V3 n))
Transformation V3 n
tr (Envelope V3 n -> Envelope V3 n)
-> ((V3 n -> n) -> Envelope V3 n) -> (V3 n -> n) -> Envelope V3 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V3 n -> n) -> Envelope V3 n
forall (v :: * -> *) n. (v n -> n) -> Envelope v n
mkEnvelope ((V3 n -> n) -> Envelope V3 n) -> (V3 n -> n) -> Envelope V3 n
forall a b. (a -> b) -> a -> b
$ \V3 n
v -> n
1 n -> n -> n
forall a. Fractional a => a -> a -> a
/ V3 n -> n
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) = Transformation (V (Trace V3 n)) (N (Trace V3 n))
-> Trace V3 n -> Trace V3 n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Trace V3 n)) (N (Trace V3 n))
Transformation V3 n
tr (Trace V3 n -> Trace V3 n)
-> ((Point V3 n -> V3 n -> SortedList n) -> Trace V3 n)
-> (Point V3 n -> V3 n -> SortedList n)
-> Trace V3 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point V3 n -> V3 n -> SortedList n) -> Trace V3 n
forall (v :: * -> *) n.
(Point v n -> v n -> SortedList n) -> Trace v n
mkTrace ((Point V3 n -> V3 n -> SortedList n) -> Trace V3 n)
-> (Point V3 n -> V3 n -> SortedList n) -> Trace V3 n
forall a b. (a -> b) -> a -> b
$ \(P V3 n
p) V3 n
v -> let
    a :: n
a  =    V3 n
v V3 n -> V3 n -> n
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V3 n
v
    b :: n
b  = n
2 n -> n -> n
forall a. Num a => a -> a -> a
* (V3 n
p V3 n -> V3 n -> n
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V3 n
v)
    c :: n
c  =    (V3 n
p V3 n -> V3 n -> n
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V3 n
p) n -> n -> n
forall a. Num a => a -> a -> a
- n
1
    in
     [n] -> SortedList n
forall a. Ord a => [a] -> SortedList a
mkSortedList ([n] -> SortedList n) -> [n] -> SortedList n
forall a b. (a -> b) -> a -> b
$ n -> n -> n -> [n]
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 :: Ellipsoid n
sphere = Transformation V3 n -> Ellipsoid n
forall n. Transformation V3 n -> Ellipsoid n
Ellipsoid Transformation V3 n
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) = Transformation V3 n -> Box n
forall n. Transformation V3 n -> Box n
Box (Transformation (V (Box n)) (N (Box n))
Transformation V3 n
t1 Transformation V3 n -> Transformation V3 n -> Transformation V3 n
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
_ = Render NullBackend (V (Box n)) (N (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) = Transformation (V (Envelope V3 n)) (N (Envelope V3 n))
-> Envelope V3 n -> Envelope V3 n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Envelope V3 n)) (N (Envelope V3 n))
Transformation V3 n
tr (Envelope V3 n -> Envelope V3 n)
-> ((V3 n -> n) -> Envelope V3 n) -> (V3 n -> n) -> Envelope V3 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V3 n -> n) -> Envelope V3 n
forall (v :: * -> *) n. (v n -> n) -> Envelope v n
mkEnvelope ((V3 n -> n) -> Envelope V3 n) -> (V3 n -> n) -> Envelope V3 n
forall a b. (a -> b) -> a -> b
$ \V3 n
v ->
    [n] -> n
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((V3 n -> n) -> [V3 n] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (V3 n
v V3 n -> V3 n -> n
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot`) [V3 n]
corners) n -> n -> n
forall a. Fractional a => a -> a -> a
/ V3 n -> n
forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance V3 n
v where
      corners :: [V3 n]
corners = n -> n -> n -> V3 n
forall n. n -> n -> n -> V3 n
mkR3 (n -> n -> n -> V3 n) -> [n] -> [n -> n -> V3 n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [n
0,n
1] [n -> n -> V3 n] -> [n] -> [n -> V3 n]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [n
0,n
1] [n -> V3 n] -> [n] -> [V3 n]
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) = Transformation (V (Trace V3 n)) (N (Trace V3 n))
-> Trace V3 n -> Trace V3 n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Trace V3 n)) (N (Trace V3 n))
Transformation V3 n
tr (Trace V3 n -> Trace V3 n)
-> ((Point V3 n -> V3 n -> SortedList n) -> Trace V3 n)
-> (Point V3 n -> V3 n -> SortedList n)
-> Trace V3 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point V3 n -> V3 n -> SortedList n) -> Trace V3 n
forall (v :: * -> *) n.
(Point v n -> v n -> SortedList n) -> Trace v n
mkTrace ((Point V3 n -> V3 n -> SortedList n) -> Trace V3 n)
-> (Point V3 n -> V3 n -> SortedList n) -> Trace V3 n
forall a b. (a -> b) -> a -> b
$ \Point V3 n
p V3 n
v -> let
    (n
x0, n
y0, n
z0) = Point V3 n -> (n, n, n)
forall n. P3 n -> (n, n, n)
unp3 Point V3 n
p
    (n
vx, n
vy, n
vz) = V3 n -> (n, n, n)
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
fa -> a -> a
forall a. Fractional a => a -> a -> a
/a
d, (a
1a -> a -> a
forall a. Num a => a -> a -> a
-a
f)a -> a -> a
forall a. Fractional a => a -> a -> a
/a
d]
    ts :: [n]
ts = [[n]] -> [n]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[n]] -> [n]) -> [[n]] -> [n]
forall a b. (a -> b) -> a -> b
$ (n -> n -> [n]) -> [n] -> [n] -> [[n]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith n -> n -> [n]
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 Point V3 n -> Diff (Point V3) n -> Point V3 n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (n
tn -> V3 n -> V3 n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^V3 n
v)
    range :: P3 a -> Bool
range P3 a
u = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0, a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1, a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0, a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1, a
z a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0, a
z a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1] where
      (a
x, a
y, a
z) = P3 a -> (a, a, a)
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
     [n] -> SortedList n
forall a. Ord a => [a] -> SortedList a
mkSortedList ([n] -> SortedList n) -> ([n] -> [n]) -> [n] -> SortedList n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Bool) -> [n] -> [n]
forall a. (a -> Bool) -> [a] -> [a]
filter (Point V3 n -> Bool
forall a. (Ord a, Num a) => P3 a -> Bool
range (Point V3 n -> Bool) -> (n -> Point V3 n) -> n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Point V3 n
atT) ([n] -> SortedList n) -> [n] -> SortedList n
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 :: Box n
cube = Transformation V3 n -> Box n
forall n. Transformation V3 n -> Box n
Box Transformation V3 n
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) = n -> n -> Transformation V3 n -> Frustum n
forall n. n -> n -> Transformation V3 n -> Frustum n
Frustum n
r0 n
r1 (Transformation (V (Frustum n)) (N (Frustum n))
Transformation V3 n
t1 Transformation V3 n -> Transformation V3 n -> Transformation V3 n
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
_ = Render NullBackend (V (Frustum n)) (N (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) = Transformation (V (Envelope V3 n)) (N (Envelope V3 n))
-> Envelope V3 n -> Envelope V3 n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Envelope V3 n)) (N (Envelope V3 n))
Transformation V3 n
tr (Envelope V3 n -> Envelope V3 n)
-> ((V3 n -> n) -> Envelope V3 n) -> (V3 n -> n) -> Envelope V3 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V3 n -> n) -> Envelope V3 n
forall (v :: * -> *) n. (v n -> n) -> Envelope v n
mkEnvelope ((V3 n -> n) -> Envelope V3 n) -> (V3 n -> n) -> Envelope V3 n
forall a b. (a -> b) -> a -> b
$ \V3 n
v ->let
    θ :: Angle n
θ = V3 n
v V3 n -> Getting (Angle n) (V3 n) (Angle n) -> Angle n
forall s a. s -> Getting a s a -> a
^. Getting (Angle n) (V3 n) (Angle n)
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
     [n] -> n
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([n] -> n) -> ([(n, Angle n, n)] -> [n]) -> [(n, Angle n, n)] -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((n, Angle n, n) -> n) -> [(n, Angle n, n)] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (V3 n -> n
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (V3 n -> n) -> ((n, Angle n, n) -> V3 n) -> (n, Angle n, n) -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V3 n -> V3 n -> V3 n
forall (v :: * -> *) a.
(Metric v, Fractional a) =>
v a -> v a -> v a
project V3 n
v (V3 n -> V3 n)
-> ((n, Angle n, n) -> V3 n) -> (n, Angle n, n) -> V3 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AReview (V3 n) (n, Angle n, n) -> (n, Angle n, n) -> V3 n
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview (V3 n) (n, Angle n, n)
forall n. RealFloat n => Iso' (V3 n) (n, Angle n, n)
r3CylindricalIso) ([(n, Angle n, n)] -> n) -> [(n, Angle n, n)] -> n
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) = Transformation (V (Trace V3 n)) (N (Trace V3 n))
-> Trace V3 n -> Trace V3 n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Trace V3 n)) (N (Trace V3 n))
Transformation V3 n
tr (Trace V3 n -> Trace V3 n)
-> ((Point V3 n -> V3 n -> SortedList n) -> Trace V3 n)
-> (Point V3 n -> V3 n -> SortedList n)
-> Trace V3 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point V3 n -> V3 n -> SortedList n) -> Trace V3 n
forall (v :: * -> *) n.
(Point v n -> v n -> SortedList n) -> Trace v n
mkTrace ((Point V3 n -> V3 n -> SortedList n) -> Trace V3 n)
-> (Point V3 n -> V3 n -> SortedList n) -> Trace V3 n
forall a b. (a -> b) -> a -> b
$ \Point V3 n
p V3 n
v -> let
    (n
px, n
py, n
pz) = Point V3 n -> (n, n, n)
forall n. P3 n -> (n, n, n)
unp3 Point V3 n
p
    (n
vx, n
vy, n
vz) = V3 n -> (n, n, n)
forall n. V3 n -> (n, n, n)
unr3 V3 n
v
    ray :: n -> Point V3 n
ray n
t = Point V3 n
p Point V3 n -> Diff (Point V3) n -> Point V3 n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ n
t n -> V3 n -> V3 n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ V3 n
v
    dr :: n
dr = n
r1 n -> n -> n
forall a. Num a => a -> a -> a
- n
r0
    a :: n
a = n
vxn -> n -> n
forall a. Floating a => a -> a -> a
**n
2 n -> n -> n
forall a. Num a => a -> a -> a
+ n
vyn -> n -> n
forall a. Floating a => a -> a -> a
**n
2 n -> n -> n
forall a. Num a => a -> a -> a
- n
vzn -> n -> n
forall a. Floating a => a -> a -> a
**n
2 n -> n -> n
forall a. Num a => a -> a -> a
* n
drn -> n -> n
forall a. Floating a => a -> a -> a
**n
2
    b :: n
b = n
2 n -> n -> n
forall a. Num a => a -> a -> a
* (n
px n -> n -> n
forall a. Num a => a -> a -> a
* n
vx n -> n -> n
forall a. Num a => a -> a -> a
+ n
py n -> n -> n
forall a. Num a => a -> a -> a
* n
vy n -> n -> n
forall a. Num a => a -> a -> a
- (n
r0n -> n -> n
forall a. Num a => a -> a -> a
+n
pzn -> n -> n
forall a. Num a => a -> a -> a
*n
dr) n -> n -> n
forall a. Num a => a -> a -> a
* n
dr  n -> n -> n
forall a. Num a => a -> a -> a
* n
vz)
    c :: n
c = n
pxn -> n -> n
forall a. Floating a => a -> a -> a
**n
2 n -> n -> n
forall a. Num a => a -> a -> a
+ n
pyn -> n -> n
forall a. Floating a => a -> a -> a
**n
2 n -> n -> n
forall a. Num a => a -> a -> a
- (n
r0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
drn -> n -> n
forall a. Num a => a -> a -> a
*n
pz)n -> n -> n
forall a. Floating a => a -> a -> a
**n
2
    zbounds :: n -> Bool
zbounds n
t = n -> Point V3 n
ray n
t Point V3 n -> Getting n (Point V3 n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (Point V3 n) n
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
0
         Bool -> Bool -> Bool
&& n -> Point V3 n
ray n
t Point V3 n -> Getting n (Point V3 n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (Point V3 n) n
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
1
    ends :: [n]
ends = (n -> [n]) -> [n] -> [n]
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 Point V3 n -> Getting n (Point V3 n) n -> n
forall s a. s -> Getting a s a -> a
^. (V3 n -> Const n (V3 n)) -> Point V3 n -> Const n (Point V3 n)
forall (g :: * -> *) a. Lens' (Point g a) (g a)
lensP ((V3 n -> Const n (V3 n)) -> Point V3 n -> Const n (Point V3 n))
-> ((n -> Const n n) -> V3 n -> Const n (V3 n))
-> Getting n (Point V3 n) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((n, Angle n, n) -> Const n (n, Angle n, n))
-> V3 n -> Const n (V3 n)
forall n. RealFloat n => Iso' (V3 n) (n, Angle n, n)
r3CylindricalIso (((n, Angle n, n) -> Const n (n, Angle n, n))
 -> V3 n -> Const n (V3 n))
-> ((n -> Const n n) -> (n, Angle n, n) -> Const n (n, Angle n, n))
-> (n -> Const n n)
-> V3 n
-> Const n (V3 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Const n n) -> (n, Angle n, n) -> Const n (n, Angle n, n)
forall s t a b. Field1 s t a b => Lens s t a b
_1 n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
r0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
z n -> n -> n
forall a. Num a => a -> a -> a
* n
dr ]
      where
      t :: n
t = (n
z n -> n -> n
forall a. Num a => a -> a -> a
- n
pz) n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
vz
    in
     [n] -> SortedList n
forall a. Ord a => [a] -> SortedList a
mkSortedList ([n] -> SortedList n) -> [n] -> SortedList n
forall a b. (a -> b) -> a -> b
$ (n -> Bool) -> [n] -> [n]
forall a. (a -> Bool) -> [a] -> [a]
filter n -> Bool
zbounds (n -> n -> n -> [n]
forall d. (Floating d, Ord d) => d -> d -> d -> [d]
quadForm n
a n
b n
c) [n] -> [n] -> [n]
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 :: n -> n -> Frustum n
frustum n
r0 n
r1 = n -> n -> Transformation V3 n -> Frustum n
forall n. n -> n -> Transformation V3 n -> Frustum n
Frustum n
r0 n
r1 Transformation V3 n
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 :: Frustum n
cone = n -> n -> Frustum n
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 :: Frustum n
cylinder = n -> n -> Frustum n
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) = Transformation (V (Query V3 n Any)) (N (Query V3 n Any))
-> Query V3 n Any -> Query V3 n Any
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Query V3 n Any)) (N (Query V3 n Any))
Transformation V3 n
tr (Query V3 n Any -> Query V3 n Any)
-> Query V3 n Any -> Query V3 n Any
forall a b. (a -> b) -> a -> b
$
    (Point V3 n -> Any) -> Query V3 n Any
forall (v :: * -> *) n m. (Point v n -> m) -> Query v n m
Query ((Point V3 n -> Any) -> Query V3 n Any)
-> (Point V3 n -> Any) -> Query V3 n Any
forall a b. (a -> b) -> a -> b
$ \Point V3 n
v -> Bool -> Any
Any (Bool -> Any) -> Bool -> Any
forall a b. (a -> b) -> a -> b
$ V3 n -> n
forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance (Point V3 n
v Point V3 n -> Point V3 n -> Diff (Point V3) n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V3 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin) n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
1

instance OrderedField n => Skinned (Ellipsoid n) where
  skin :: Ellipsoid n -> QDiagram b V3 n Any
skin Ellipsoid n
s = Prim b V3 n
-> Envelope V3 n
-> Trace V3 n
-> SubMap b V3 n Any
-> Query V3 n Any
-> QDiagram b V3 n Any
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 (Ellipsoid n -> Prim b (V (Ellipsoid n)) (N (Ellipsoid n))
forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim Ellipsoid n
s) (Ellipsoid n -> Envelope (V (Ellipsoid n)) (N (Ellipsoid n))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Ellipsoid n
s) (Ellipsoid n -> Trace (V (Ellipsoid n)) (N (Ellipsoid n))
forall a. Traced a => a -> Trace (V a) (N a)
getTrace Ellipsoid n
s) SubMap b V3 n Any
forall a. Monoid a => a
mempty (Ellipsoid n -> Query (V (Ellipsoid n)) (N (Ellipsoid n)) Any
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) = Transformation (V (Query V3 n Any)) (N (Query V3 n Any))
-> Query V3 n Any -> Query V3 n Any
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Query V3 n Any)) (N (Query V3 n Any))
Transformation V3 n
tr (Query V3 n Any -> Query V3 n Any)
-> ((Point V3 n -> Any) -> Query V3 n Any)
-> (Point V3 n -> Any)
-> Query V3 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point V3 n -> Any) -> Query V3 n Any
forall (v :: * -> *) n m. (Point v n -> m) -> Query v n m
Query ((Point V3 n -> Any) -> Query V3 n Any)
-> (Point V3 n -> Any) -> Query V3 n Any
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any (Bool -> Any) -> (Point V3 n -> Bool) -> Point V3 n -> Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point V3 n -> Bool
forall a. (Ord a, Num a) => P3 a -> Bool
range where
    range :: P3 a -> Bool
range P3 a
u = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0, a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1, a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0, a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1, a
z a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0, a
z a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1] where
      (a
x, a
y, a
z) = P3 a -> (a, a, a)
forall n. P3 n -> (n, n, n)
unp3 P3 a
u

instance OrderedField n => Skinned (Box n) where
  skin :: Box n -> QDiagram b V3 n Any
skin Box n
s = Prim b V3 n
-> Envelope V3 n
-> Trace V3 n
-> SubMap b V3 n Any
-> Query V3 n Any
-> QDiagram b V3 n Any
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 (Box n -> Prim b (V (Box n)) (N (Box n))
forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim Box n
s) (Box n -> Envelope (V (Box n)) (N (Box n))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Box n
s) (Box n -> Trace (V (Box n)) (N (Box n))
forall a. Traced a => a -> Trace (V a) (N a)
getTrace Box n
s) SubMap b V3 n Any
forall a. Monoid a => a
mempty (Box n -> Query (V (Box n)) (N (Box n)) Any
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)= Transformation (V (Query V3 n Any)) (N (Query V3 n Any))
-> Query V3 n Any -> Query V3 n Any
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Query V3 n Any)) (N (Query V3 n Any))
Transformation V3 n
tr (Query V3 n Any -> Query V3 n Any)
-> Query V3 n Any -> Query V3 n Any
forall a b. (a -> b) -> a -> b
$
    (Point V3 n -> Any) -> Query V3 n Any
forall (v :: * -> *) n m. (Point v n -> m) -> Query v n m
Query ((Point V3 n -> Any) -> Query V3 n Any)
-> (Point V3 n -> Any) -> Query V3 n Any
forall a b. (a -> b) -> a -> b
$ \Point V3 n
p -> let
      z :: n
z = Point V3 n
pPoint V3 n -> Getting n (Point V3 n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (Point V3 n) n
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z
      r :: n
r = n
r0 n -> n -> n
forall a. Num a => a -> a -> a
+ (n
r1 n -> n -> n
forall a. Num a => a -> a -> a
- n
r0)n -> n -> n
forall a. Num a => a -> a -> a
*n
z
      v :: Diff (Point V3) n
v = Point V3 n
p Point V3 n -> Point V3 n -> Diff (Point V3) n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V3 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin
      a :: n
a = V3 n -> n
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (V3 n -> n) -> V3 n -> n
forall a b. (a -> b) -> a -> b
$ V3 n -> V3 n
forall (v :: * -> *) a.
(Metric v, Fractional a, R3 v) =>
v a -> v a
projectXY Diff (Point V3) n
V3 n
v
      projectXY :: v a -> v a
projectXY v a
u = v a
u v a -> v a -> v a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ v a -> v a -> v a
forall (v :: * -> *) a.
(Metric v, Fractional a) =>
v a -> v a -> v a
project v a
forall (v :: * -> *) n. (R3 v, Additive v, Num n) => v n
unitZ v a
u
      in
       Bool -> Any
Any (Bool -> Any) -> Bool -> Any
forall a b. (a -> b) -> a -> b
$ n
z n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
0 Bool -> Bool -> Bool
&& n
z n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
1 Bool -> Bool -> Bool
&& n
a n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
r

instance Skinned (Frustum n) where
  skin :: Frustum n -> QDiagram b V3 n Any
skin Frustum n
s = Prim b V3 n
-> Envelope V3 n
-> Trace V3 n
-> SubMap b V3 n Any
-> Query V3 n Any
-> QDiagram b V3 n Any
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 (Frustum n -> Prim b (V (Frustum n)) (N (Frustum n))
forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim Frustum n
s) (Frustum n -> Envelope (V (Frustum n)) (N (Frustum n))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Frustum n
s) (Frustum n -> Trace (V (Frustum n)) (N (Frustum n))
forall a. Traced a => a -> Trace (V a) (N a)
getTrace Frustum n
s) SubMap b V3 n Any
forall a. Monoid a => a
mempty (Frustum n -> Query (V (Frustum n)) (N (Frustum n)) Any
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) = Ellipsoid n -> CSG n
forall n. Ellipsoid n -> CSG n
CsgEllipsoid (Ellipsoid n -> CSG n) -> Ellipsoid n -> CSG n
forall a b. (a -> b) -> a -> b
$ Transformation (V (Ellipsoid n)) (N (Ellipsoid n))
-> Ellipsoid n -> Ellipsoid n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (CSG n)) (N (CSG n))
Transformation (V (Ellipsoid n)) (N (Ellipsoid n))
t Ellipsoid n
p
  transform Transformation (V (CSG n)) (N (CSG n))
t (CsgBox Box n
p) = Box n -> CSG n
forall n. Box n -> CSG n
CsgBox (Box n -> CSG n) -> Box n -> CSG n
forall a b. (a -> b) -> a -> b
$ Transformation (V (Box n)) (N (Box n)) -> Box n -> Box n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (CSG n)) (N (CSG n))
Transformation (V (Box n)) (N (Box n))
t Box n
p
  transform Transformation (V (CSG n)) (N (CSG n))
t (CsgFrustum Frustum n
p) = Frustum n -> CSG n
forall n. Frustum n -> CSG n
CsgFrustum (Frustum n -> CSG n) -> Frustum n -> CSG n
forall a b. (a -> b) -> a -> b
$ Transformation (V (Frustum n)) (N (Frustum n))
-> Frustum n -> Frustum n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (CSG n)) (N (CSG n))
Transformation (V (Frustum n)) (N (Frustum n))
t Frustum n
p
  transform Transformation (V (CSG n)) (N (CSG n))
t (CsgUnion [CSG n]
ps) = [CSG n] -> CSG n
forall n. [CSG n] -> CSG n
CsgUnion ([CSG n] -> CSG n) -> [CSG n] -> CSG n
forall a b. (a -> b) -> a -> b
$ (CSG n -> CSG n) -> [CSG n] -> [CSG n]
forall a b. (a -> b) -> [a] -> [b]
map (Transformation (V (CSG n)) (N (CSG n)) -> CSG n -> CSG n
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) = [CSG n] -> CSG n
forall n. [CSG n] -> CSG n
CsgIntersection ([CSG n] -> CSG n) -> [CSG n] -> CSG n
forall a b. (a -> b) -> a -> b
$ (CSG n -> CSG n) -> [CSG n] -> [CSG n]
forall a b. (a -> b) -> [a] -> [b]
map (Transformation (V (CSG n)) (N (CSG n)) -> CSG n -> CSG n
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) = CSG n -> CSG n -> CSG n
forall n. CSG n -> CSG n -> CSG n
CsgDifference (Transformation (V (CSG n)) (N (CSG n)) -> CSG n -> CSG n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (CSG n)) (N (CSG n))
t CSG n
p1) (Transformation (V (CSG n)) (N (CSG n)) -> CSG n -> CSG n
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)      = Ellipsoid n -> Envelope (V (Ellipsoid n)) (N (Ellipsoid n))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Ellipsoid n
p
  getEnvelope (CsgBox Box n
p)            = Box n -> Envelope (V (Box n)) (N (Box n))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Box n
p
  getEnvelope (CsgFrustum Frustum n
p)        = Frustum n -> Envelope (V (Frustum n)) (N (Frustum n))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Frustum n
p
  getEnvelope (CsgUnion [CSG n]
ps)         = (CSG n -> Envelope V3 n) -> [CSG n] -> Envelope V3 n
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CSG n -> Envelope V3 n
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope [CSG n]
ps
  getEnvelope (CsgIntersection [CSG n]
ps)  = (CSG n -> Envelope V3 n) -> [CSG n] -> Envelope V3 n
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CSG n -> Envelope V3 n
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope [CSG n]
ps
  getEnvelope (CsgDifference CSG n
p1 CSG n
p2) = CSG n -> Envelope (V (CSG n)) (N (CSG n))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope CSG n
p1 Envelope V3 n -> Envelope V3 n -> Envelope V3 n
forall a. Semigroup a => a -> a -> a
<> CSG n -> Envelope (V (CSG n)) (N (CSG n))
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) = Ellipsoid n -> Query (V (Ellipsoid n)) (N (Ellipsoid n)) Any
forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery Ellipsoid n
prim
  getQuery (CsgBox Box n
prim) = Box n -> Query (V (Box n)) (N (Box n)) Any
forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery Box n
prim
  getQuery (CsgFrustum Frustum n
prim) = Frustum n -> Query (V (Frustum n)) (N (Frustum n)) Any
forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery Frustum n
prim
  getQuery (CsgUnion [CSG n]
ps) = (CSG n -> Query V3 n Any) -> [CSG n] -> Query V3 n Any
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CSG n -> Query V3 n Any
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 (Bool -> Any) -> (All -> Bool) -> All -> Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. All -> Bool
getAll (All -> Any) -> Query V3 n All -> Query V3 n Any
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CSG n -> Query V3 n All) -> [CSG n] -> Query V3 n All
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Any -> All) -> Query V3 n Any -> Query V3 n All
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> All
All (Bool -> All) -> (Any -> Bool) -> Any -> All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Bool
getAny) (Query V3 n Any -> Query V3 n All)
-> (CSG n -> Query V3 n Any) -> CSG n -> Query V3 n All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSG n -> Query V3 n Any
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 (Any -> Any -> Any) -> Query V3 n Any -> Query V3 n (Any -> Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CSG n -> Query (V (CSG n)) (N (CSG n)) Any
forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery CSG n
p1 Query V3 n (Any -> Any) -> Query V3 n Any -> Query V3 n Any
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CSG n -> Query (V (CSG n)) (N (CSG n)) Any
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 (Bool -> Any) -> Bool -> 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) = Ellipsoid n -> Trace (V (Ellipsoid n)) (N (Ellipsoid n))
forall a. Traced a => a -> Trace (V a) (N a)
getTrace Ellipsoid n
p
  getTrace (CsgBox Box n
p) = Box n -> Trace (V (Box n)) (N (Box n))
forall a. Traced a => a -> Trace (V a) (N a)
getTrace Box n
p
  getTrace (CsgFrustum Frustum n
p) = Frustum n -> Trace (V (Frustum n)) (N (Frustum n))
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 []) = Trace (V (CSG n)) (N (CSG n))
forall a. Monoid a => a
mempty
  getTrace (CsgUnion (CSG n
s:[CSG n]
ss)) = (Point V3 n -> V3 n -> SortedList n) -> Trace V3 n
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 = ([n] -> [n]) -> SortedList n -> SortedList n
forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList ((n -> Bool) -> [n] -> [n]
forall a. (a -> Bool) -> [a] -> [a]
filter ((n -> Bool) -> [n] -> [n]) -> (n -> Bool) -> [n] -> [n]
forall a b. (a -> b) -> a -> b
$ CSG n -> n -> Bool
without CSG n
s) (Trace V3 n -> Point V3 n -> V3 n -> SortedList n
forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (CSG n -> Trace (V (CSG n)) (N (CSG n))
forall a. Traced a => a -> Trace (V a) (N a)
getTrace ([CSG n] -> CSG n
forall n. [CSG n] -> CSG n
CsgUnion [CSG n]
ss)) Point V3 n
pt V3 n
v)
         SortedList n -> SortedList n -> SortedList n
forall a. Semigroup a => a -> a -> a
<> ([n] -> [n]) -> SortedList n -> SortedList n
forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList ((n -> Bool) -> [n] -> [n]
forall a. (a -> Bool) -> [a] -> [a]
filter ((n -> Bool) -> [n] -> [n]) -> (n -> Bool) -> [n] -> [n]
forall a b. (a -> b) -> a -> b
$ CSG n -> n -> Bool
without ([CSG n] -> CSG n
forall n. [CSG n] -> CSG n
CsgUnion [CSG n]
ss)) (Trace V3 n -> Point V3 n -> V3 n -> SortedList n
forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (CSG n -> Trace (V (CSG n)) (N (CSG n))
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 Point V3 n -> Diff (Point V3) n -> Point V3 n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V3 n
v V3 n -> n -> V3 n
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 (Bool -> Bool) -> (n -> Bool) -> n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSG n -> Point (V (CSG n)) (N (CSG n)) -> Bool
forall t. HasQuery t Any => t -> Point (V t) (N t) -> Bool
inquire CSG n
prim (Point V3 n -> Bool) -> (n -> Point V3 n) -> n -> Bool
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 []) = Trace (V (CSG n)) (N (CSG n))
forall a. Monoid a => a
mempty
  getTrace (CsgIntersection (CSG n
s:[CSG n]
ss)) = (Point V3 n -> V3 n -> SortedList n) -> Trace V3 n
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 = ([n] -> [n]) -> SortedList n -> SortedList n
forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList ((n -> Bool) -> [n] -> [n]
forall a. (a -> Bool) -> [a] -> [a]
filter ((n -> Bool) -> [n] -> [n]) -> (n -> Bool) -> [n] -> [n]
forall a b. (a -> b) -> a -> b
$ CSG n -> n -> Bool
within CSG n
s) (Trace V3 n -> Point V3 n -> V3 n -> SortedList n
forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (CSG n -> Trace (V (CSG n)) (N (CSG n))
forall a. Traced a => a -> Trace (V a) (N a)
getTrace ([CSG n] -> CSG n
forall n. [CSG n] -> CSG n
CsgIntersection [CSG n]
ss)) Point V3 n
pt V3 n
v)
         SortedList n -> SortedList n -> SortedList n
forall a. Semigroup a => a -> a -> a
<> ([n] -> [n]) -> SortedList n -> SortedList n
forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList ((n -> Bool) -> [n] -> [n]
forall a. (a -> Bool) -> [a] -> [a]
filter ((n -> Bool) -> [n] -> [n]) -> (n -> Bool) -> [n] -> [n]
forall a b. (a -> b) -> a -> b
$ CSG n -> n -> Bool
within ([CSG n] -> CSG n
forall n. [CSG n] -> CSG n
CsgIntersection [CSG n]
ss)) (Trace V3 n -> Point V3 n -> V3 n -> SortedList n
forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (CSG n -> Trace (V (CSG n)) (N (CSG n))
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 Point V3 n -> Diff (Point V3) n -> Point V3 n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V3 n
v V3 n -> n -> V3 n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* n
dist
      within :: CSG n -> n -> Bool
within CSG n
prim = CSG n -> Point (V (CSG n)) (N (CSG n)) -> Bool
forall t. HasQuery t Any => t -> Point (V t) (N t) -> Bool
inquire CSG n
prim (Point V3 n -> Bool) -> (n -> Point V3 n) -> n -> Bool
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) = (Point V3 n -> V3 n -> SortedList n) -> Trace V3 n
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 = ([n] -> [n]) -> SortedList n -> SortedList n
forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList ((n -> Bool) -> [n] -> [n]
forall a. (a -> Bool) -> [a] -> [a]
filter ((n -> Bool) -> [n] -> [n]) -> (n -> Bool) -> [n] -> [n]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (n -> Bool) -> n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSG n -> n -> Bool
within CSG n
s2) (Trace V3 n -> Point V3 n -> V3 n -> SortedList n
forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (CSG n -> Trace (V (CSG n)) (N (CSG n))
forall a. Traced a => a -> Trace (V a) (N a)
getTrace CSG n
s1) Point V3 n
pt V3 n
v)
         SortedList n -> SortedList n -> SortedList n
forall a. Semigroup a => a -> a -> a
<> ([n] -> [n]) -> SortedList n -> SortedList n
forall b a. Ord b => ([a] -> [b]) -> SortedList a -> SortedList b
onSortedList ((n -> Bool) -> [n] -> [n]
forall a. (a -> Bool) -> [a] -> [a]
filter ((n -> Bool) -> [n] -> [n]) -> (n -> Bool) -> [n] -> [n]
forall a b. (a -> b) -> a -> b
$ CSG n -> n -> Bool
within CSG n
s1) (Trace V3 n -> Point V3 n -> V3 n -> SortedList n
forall (v :: * -> *) n.
Trace v n -> Point v n -> v n -> SortedList n
appTrace (CSG n -> Trace (V (CSG n)) (N (CSG n))
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 Point V3 n -> Diff (Point V3) n -> Point V3 n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V3 n
v V3 n -> n -> V3 n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* n
dist
      within :: CSG n -> n -> Bool
within CSG n
prim = CSG n -> Point (V (CSG n)) (N (CSG n)) -> Bool
forall t. HasQuery t Any => t -> Point (V t) (N t) -> Bool
inquire CSG n
prim (Point V3 n -> Bool) -> (n -> Point V3 n) -> n -> Bool
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 :: CSG n -> QDiagram b V3 n Any
skin CSG n
s = Prim b V3 n
-> Envelope V3 n
-> Trace V3 n
-> SubMap b V3 n Any
-> Query V3 n Any
-> QDiagram b V3 n Any
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 (CSG n -> Prim b (V (CSG n)) (N (CSG n))
forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim CSG n
s) (CSG n -> Envelope (V (CSG n)) (N (CSG n))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope CSG n
s) (CSG n -> Trace (V (CSG n)) (N (CSG n))
forall a. Traced a => a -> Trace (V a) (N a)
getTrace CSG n
s) SubMap b V3 n Any
forall a. Monoid a => a
mempty (CSG n -> Query (V (CSG n)) (N (CSG n)) Any
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 :: Ellipsoid n -> CSG n
toCsg = Ellipsoid n -> CSG n
forall n. Ellipsoid n -> CSG n
CsgEllipsoid

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

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

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

union :: (CsgPrim a, CsgPrim b) => a n -> b n -> CSG n
union :: a n -> b n -> CSG n
union a n
a b n
b = [CSG n] -> CSG n
forall n. [CSG n] -> CSG n
CsgUnion [a n -> CSG n
forall (a :: * -> *) n. CsgPrim a => a n -> CSG n
toCsg a n
a, b n -> CSG n
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 :: a n -> b n -> CSG n
intersection a n
a b n
b = [CSG n] -> CSG n
forall n. [CSG n] -> CSG n
CsgIntersection [a n -> CSG n
forall (a :: * -> *) n. CsgPrim a => a n -> CSG n
toCsg a n
a, b n -> CSG n
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 :: a n -> b n -> CSG n
difference a n
a b n
b = CSG n -> CSG n -> CSG n
forall n. CSG n -> CSG n -> CSG n
CsgDifference (a n -> CSG n
forall (a :: * -> *) n. CsgPrim a => a n -> CSG n
toCsg a n
a) (b n -> CSG n
forall (a :: * -> *) n. CsgPrim a => a n -> CSG n
toCsg b n
b)