3d color & lighting, more solids, Angle utilities

diagrams-lib.cabal

@@ -75,6 +75,7 @@ Library
                        Diagrams.TwoD.Image,
                        Diagrams.TwoD.Adjust,
                        Diagrams.ThreeD.Align,
+                       Diagrams.ThreeD.Attributes,
                        Diagrams.ThreeD.Camera,
                        Diagrams.ThreeD.Deform,
                        Diagrams.ThreeD.Light,

src/Diagrams/Coordinates.hs

@@ -16,7 +16,7 @@ module Diagrams.Coordinates
     ( (:&)(..), Coordinates(..)
 
     -- * Lenses for particular axes
-    , HasX(..), HasY(..), HasZ(..)
+    , HasX(..), HasY(..), HasZ(..), HasR(..)
     )
     where
 
@@ -121,3 +121,7 @@ class HasY t where
 -- | The class of types with at least three coordinates, the third called _z.
 class HasZ t where
     _z :: Lens' t Double
+
+-- | _r is the vector magnitude
+class HasR t where
+    _r :: Lens' t Double

src/Diagrams/ThreeD.hs

@@ -32,6 +32,7 @@
 -----------------------------------------------------------------------------
 module Diagrams.ThreeD
        ( module Diagrams.ThreeD.Align
+       , module Diagrams.ThreeD.Attributes
        , module Diagrams.ThreeD.Camera
        , module Diagrams.ThreeD.Light
        , module Diagrams.ThreeD.Shapes
@@ -41,6 +42,7 @@ module Diagrams.ThreeD
        ) where
 
 import Diagrams.ThreeD.Align
+import Diagrams.ThreeD.Attributes
 import Diagrams.ThreeD.Camera
 import Diagrams.ThreeD.Light
 import Diagrams.ThreeD.Shapes

src/Diagrams/ThreeD/Attributes.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell            #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Diagrams.ThreeD.Attributes
+-- Copyright   :  (c) 2014 diagrams-lib team (see LICENSE)
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  diagrams-discuss@googlegroups.com
+--
+-- Diagrams may have /attributes/ which affect the way they are
+-- rendered.  This module defines some common attributes relevant in
+-- 3D; particular backends may also define more backend-specific
+-- attributes.
+--
+-- Every attribute type must have a /semigroup/ structure, that is, an
+-- associative binary operation for combining two attributes into one.
+-- Unless otherwise noted, all the attributes defined here use the
+-- 'Last' structure, that is, combining two attributes simply keeps
+-- the second one and throws away the first.  This means that child
+-- attributes always override parent attributes.
+--
+-----------------------------------------------------------------------------
+
+module Diagrams.ThreeD.Attributes where
+
+import Control.Lens
+import Data.Semigroup
+import Data.Typeable
+
+import Data.Colour
+
+import Diagrams.Core
+
+-- | @SurfaceColor@ is the inherent pigment of an object, assumed to
+-- be opaque.
+newtype SurfaceColor = SurfaceColor (Last (Colour Double))
+                     deriving (Typeable, Semigroup)
+instance AttributeClass SurfaceColor
+
+surfaceColor :: Iso' SurfaceColor (Colour Double)
+surfaceColor = iso (\(SurfaceColor (Last c)) -> c) (SurfaceColor . Last)
+
+sc :: HasStyle d => Colour Double -> d -> d
+sc = applyAttr . review surfaceColor
+
+-- | @Diffuse@ is the fraction of incident light reflected diffusely,
+-- that is, in all directions.  The actual light reflected is the
+-- product of this value, the incident light, and the @SurfaceColor@
+-- Attribute.  For physical reasonableness, @Diffuse@ should have a
+-- value between 0 and 1; this is not checked.
+newtype Diffuse = Diffuse (Last Double)
+                deriving (Typeable, Semigroup)
+instance AttributeClass Diffuse
+
+_Diffuse :: Iso' Diffuse Double
+_Diffuse = iso (\(Diffuse (Last d)) -> d) (Diffuse . Last)
+
+diffuse :: HasStyle d => Double -> d -> d
+diffuse = applyAttr . review _Diffuse
+
+-- | @Ambient@ is an ad-hoc representation of indirect lighting.  The
+-- product of @Ambient@ and @SurfaceColor@ is added to the light
+-- leaving an object due to diffuse and specular terms.  @Ambient@ can
+-- be set per-object, and can be loosely thought of as the product of
+-- indirect lighting incident on that object and the diffuse
+-- reflectance.
+newtype Ambient = Ambient (Last Double)
+                deriving (Typeable, Semigroup)
+instance AttributeClass Ambient
+
+_Ambient :: Iso' Ambient Double
+_Ambient = iso (\(Ambient (Last d)) -> d) (Ambient . Last)
+
+ambient :: HasStyle d => Double -> d -> d
+ambient = applyAttr . review _Ambient
+
+-- | A specular highlight has two terms, the intensity, between 0 and
+-- 1, and the size.  The highlight size is assumed to be the exponent
+-- in a Phong shading model (though Backends are free to use a
+-- different shading model).  In this model, reasonable values are
+-- between 1 and 50 or so, with higher values for shinier objects.
+-- Physically, the intensity and the value of @Diffuse@ must add up to
+-- less than 1; this is not enforced.
+data Specular = Specular { _specularIntensity :: Double
+                         , _specularSize :: Double
+                         }
+
+makeLenses ''Specular
+
+newtype Highlight = Highlight (Last Specular)
+                    deriving (Typeable, Semigroup)
+instance AttributeClass Highlight
+
+_Highlight :: Iso' Highlight Specular
+_Highlight = iso (\(Highlight (Last s)) -> s) (Highlight . Last)
+
+highlight :: HasStyle d => Specular -> d -> d
+highlight = applyAttr . review _Highlight

src/Diagrams/ThreeD/Camera.hs

@@ -119,13 +119,13 @@ mm50Wide = PerspectiveLens (43.2 @@ deg)  (27 @@ deg)
 -- aspect ratio of 4:3, for VGA and similar computer resulotions.
 mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg)
 
-camForward :: Direction d => Camera l -> d
+camForward :: Camera l -> Direction
 camForward = direction . forward
 
-camUp :: Direction d => Camera l -> d
+camUp :: Camera l -> Direction
 camUp = direction . up
 
-camRight :: Direction d => Camera l -> d
+camRight :: Camera l -> Direction
 camRight c = direction right where
   right = cross3 (forward c) (up c)
 

src/Diagrams/ThreeD/Light.hs

@@ -22,7 +22,6 @@ import           Data.Typeable
 
 import           Diagrams.Core
 import           Diagrams.ThreeD.Types
-import           Diagrams.ThreeD.Vector
 
 data PointLight = PointLight P3 (Colour Double)
   deriving Typeable
@@ -51,8 +50,8 @@ pointLight c = mkQD (Prim $ PointLight origin c) mempty mempty mempty
                (Query . const . Any $ False)
 
 -- | Construct a Diagram with a single ParallelLight, which takes up no space.
-parallelLight :: (Direction d, Backend b R3, Renderable ParallelLight b)
-                 => d -- ^ The direction in which the light travels.
+parallelLight :: (Backend b R3, Renderable ParallelLight b)
+                 => Direction -- ^ The direction in which the light travels.
                  -> Colour Double -- ^ The color of the light.
                  -> Diagram b R3
 parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c)

src/Diagrams/ThreeD/Shapes.hs

@@ -15,18 +15,24 @@
 
 module Diagrams.ThreeD.Shapes
        (
-         Ellipsoid(..)
-       , sphere
+         Ellipsoid(..), sphere
+       , Box(..), cube
+       , Frustum(..) , frustum, cone, cylinder
        ) where
 
 import           Data.Typeable
+import           Control.Applicative
+import           Control.Lens            ((^.), review, _1)
 
 import           Data.AffineSpace
 import           Data.Semigroup
 import           Data.VectorSpace
+import           Diagrams.Coordinates
 import           Diagrams.Core
 import           Diagrams.Solve
 import           Diagrams.ThreeD.Types
+import           Diagrams.ThreeD.Vector
+import           Diagrams.TwoD.Types
 
 data Ellipsoid = Ellipsoid T3
   deriving Typeable
@@ -41,6 +47,7 @@ instance IsPrim Ellipsoid
 instance Renderable Ellipsoid NullBackend where
   render _ _ = mempty
 
+-- | A sphere of radius 1 with its center at the origin.
 sphere :: (Backend b R3, Renderable Ellipsoid b) => Diagram b R3
 sphere = mkQD (Prim $ Ellipsoid mempty)
               (mkEnvelope sphereEnv)
@@ -54,3 +61,108 @@ sphere = mkQD (Prim $ Ellipsoid mempty)
                 c = p' <.> p' - 1
                 p' = p .-. origin
         sphereQuery v = Any $ magnitudeSq (v .-. origin) <= 1
+
+data Box = Box T3
+         deriving (Typeable)
+
+type instance V Box = R3
+
+instance Transformable Box where
+    transform t1 (Box t2) = Box (t1 <> t2)
+
+instance IsPrim Box
+
+instance Renderable Box NullBackend where
+    render _ _ = mempty
+
+-- | A cube with side length 1, in the positive octant, with one
+-- vertex at the origin.
+cube :: (Backend b R3, Renderable Box b) => Diagram b R3
+cube = mkQD (Prim $ Box mempty)
+            (mkEnvelope boxEnv)
+            (mkTrace boxTrace)
+            mempty
+            (Query boxQuery)
+  where
+    corners = mkR3 <$> [0,1] <*> [0,1] <*> [0,1]
+    boxEnv v = maximum (map (v <.>) corners) / magnitudeSq v
+    -- ts gives all intersections with the planes forming the box
+    -- filter keeps only those actually on the box surface
+    boxTrace p v = mkSortedList . filter (range . atT) $ ts where
+      (x0, y0, z0) = unp3 p
+      (vx, vy, vz) = unr3 v
+      intersections f d = case d of
+          0 -> []
+          _ -> [-f/d, (1-f)/d]
+      ts = concat $ zipWith intersections [x0,y0,z0] [vx,vy,vz]
+      atT t = p .+^ (t*^v)
+    range u = and [x >= 0, x <= 1, y >= 0, y <= 1, z >= 0, z <= 1] where
+      (x, y, z) = unp3 u
+    boxQuery = Any . range
+
+data Frustum = Frustum Double Double T3
+         deriving (Typeable)
+
+type instance V Frustum = R3
+
+instance Transformable Frustum where
+    transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2)
+
+instance IsPrim Frustum
+
+instance Renderable Frustum NullBackend where
+    render _ _ = mempty
+
+-- | 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 :: (Backend b R3, Renderable Frustum b) => Double -> Double -> Diagram b R3
+frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty)
+                 (mkEnvelope frEnv)
+                 (mkTrace frTrace)
+                 mempty
+                 (Query frQuery)
+  where
+    projectXY u = u ^-^ project unitZ u
+    frQuery p = Any $ x >= 0 && x <= 1 && a <= r where
+      (x, _, z) = unp3 p
+      r = r0 + (r1-r0)*z
+      v = p .-. origin
+      a = magnitude $ projectXY v
+    -- 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
+    frEnv v = maximum . map (magnitude . project v . review cylindrical) $ corners
+      where
+        θ = v^._theta
+        corners = [(r1,θ,1), (-r1,θ,1), (r0,θ,0), (-r0,θ,0)]
+    -- 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
+    frTrace p v = mkSortedList $ filter zbounds (quadForm a b c) ++ ends
+      where
+        (px, py, pz) = unp3 p
+        (vx, vy, vz) = unr3 v
+        ray t = p .+^ t*^v
+        dr = r1-r0
+        a = vx**2 + vy**2 - vz**2 * dr**2
+        b = 2 * (px * vx + py * vy - (r0+pz*dr) * dr  * vz)
+        c = px**2 + py**2 - (r0 + dr*pz)**2
+        zbounds t = (ray t)^._z >= 0 && (ray t)^._z <= 1
+        ends = concatMap cap [0,1]
+        cap z = if (ray t)^.cylindrical._1 < r0 + z*dr
+                then [t]
+                else []
+          where
+            t = (z - pz) / vz
+
+-- | 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 :: (Backend b R3, Renderable Frustum b) => Diagram b R3
+cone = frustum 1 0
+
+-- | A circular cylinder of radius 1 with one end cap centered on the
+-- origin, and extending to Z=1.
+cylinder :: (Backend b R3, Renderable Frustum b) => Diagram b R3
+cylinder = frustum 1 1

src/Diagrams/ThreeD/Transform.hs

@@ -102,11 +102,10 @@ aboutY ang = fromLinear r (linv r) where
 
 -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@
 --   passing through @p@.
-rotationAbout
-  :: Direction d
-  => P3     -- ^ origin of rotation
-  -> d      -- ^ direction of rotation axis
-  -> Angle      -- ^ angle of rotation
+rotationAbout ::
+     P3        -- ^ origin of rotation
+  -> Direction -- ^ direction of rotation axis
+  -> Angle     -- ^ angle of rotation
   -> T3
 rotationAbout p d a
   = mconcat [translation (negateV t),
@@ -128,7 +127,7 @@ rotationAbout p d a
 -- without tilting, it will be, otherwise if only tilting is
 -- necessary, no panning will occur.  The tilt will always be between
 -- ± 1/4 turn.
-pointAt :: Direction d => d -> d -> d -> T3
+pointAt :: Direction -> Direction -> Direction -> T3
 pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f)
 
 -- | pointAt' has the same behavior as 'pointAt', but takes vectors
@@ -137,9 +136,9 @@ pointAt' :: R3 -> R3 -> R3 -> T3
 pointAt' about initial final = tilt <> pan where
   inPanPlane    = final ^-^ project final initial
   panAngle      = angleBetween initial inPanPlane
-  pan           = rotationAbout origin (direction about :: Spherical) panAngle
+  pan           = rotationAbout origin (direction about) panAngle
   tiltAngle     = angleBetween initial inPanPlane
-  tiltDir       = direction $ cross3 inPanPlane about :: Spherical
+  tiltDir       = direction $ cross3 inPanPlane about
   tilt          = rotationAbout origin tiltDir tiltAngle
 
 -- Scaling -------------------------------------------------
@@ -261,4 +260,4 @@ reflectAbout p v = transform (reflectionAbout p v)
 --   useful for implementing backends.
 onBasis :: T3 -> ((R3, R3, R3), R3)
 onBasis t = ((x, y, z), v)
-  where ((x:y:z:[]), v) = T.onBasis t
+  where (x:y:z:[], v) = T.onBasis t