Merge pull request #114 from diagrams/threeD-render

Three d render

diagrams-lib.cabal

@@ -72,6 +72,8 @@ Library
                        Diagrams.ThreeD.Shapes,
                        Diagrams.ThreeD.Vector,
                        Diagrams.ThreeD.Transform,
+                       Diagrams.ThreeD.Camera,
+                       Diagrams.ThreeD.Light,
                        Diagrams.Animation,
                        Diagrams.Animation.Active,
                        Diagrams.Util,

src/Diagrams/ThreeD/Camera.hs

@@ -0,0 +1,119 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Diagrams.ThreeD.Camera
+-- Copyright   :  (c) 2013 diagrams-lib team (see LICENSE)
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  diagrams-discuss@googlegroups.com
+--
+-- Types to specify viewpoint for 3D rendering.
+--
+-----------------------------------------------------------------------------
+
+module Diagrams.ThreeD.Camera
+       ( Camera  -- do not export constructor
+       , PerspectiveLens(..), OrthoLens(..) -- These are safe to construct manually
+       , camLoc, camForward, camUp, camRight, camLens
+       , facing_ZCamera, mm50Camera
+       , mm50, mm50Wide, mm50Narrow
+       , aspect, camAspect
+       )
+       where
+
+import Data.Monoid
+
+import Data.Cross
+
+import Diagrams.Core
+import Diagrams.ThreeD.Types
+import Diagrams.ThreeD.Vector
+
+-- Parameterize Camera on the lens type, so that Backends can express which
+-- lenses they handle.
+data Camera l = Camera
+    { camLoc   :: P3
+    , forward  :: R3
+    , up       :: R3
+    , lens     :: l
+    }
+
+class CameraLens l where
+    -- | The natural aspect ratio of the projection.
+    aspect :: l -> Double
+
+data PerspectiveLens = PerspectiveLens -- ^ A perspective projection
+                          Deg -- ^ Horizontal field of view.
+                          Deg -- ^ Vertical field of view.
+
+instance CameraLens PerspectiveLens where
+    aspect (PerspectiveLens h v) = angleRatio h v
+
+data OrthoLens = OrthoLens -- ^ An orthographic projection
+                 Double -- ^ Width
+                 Double -- ^ Height
+
+instance CameraLens OrthoLens where
+    aspect (OrthoLens h v) = h / v
+
+type instance V (Camera l) = R3
+
+instance Transformable (Camera l) where
+  transform t (Camera p f u l) =
+      Camera (transform t p)
+             (transform t f)
+             (transform t u)
+             l
+
+instance IsPrim (Camera l)
+
+instance Renderable (Camera l) NullBackend where
+    render _ _ = mempty
+
+-- | A camera at the origin facing along the negative Z axis, with its
+-- up-axis coincident with the positive Y axis.  The field of view is
+-- chosen to match a 50mm camera on 35mm film. Note that Cameras take
+-- up no space in the Diagram.
+mm50Camera :: (Backend b R3, Renderable (Camera PerspectiveLens) b) => Diagram b R3
+mm50Camera = facing_ZCamera mm50
+
+-- | 'facing_ZCamera l' is a camera at the origin facing along the
+-- negative Z axis, with its up-axis coincident with the positive Y
+-- axis, with the projection defined by l.
+facing_ZCamera :: (CameraLens l, Backend b R3, Renderable (Camera l) b) =>
+                  l -> Diagram b R3
+facing_ZCamera l = mkQD (Prim $ Camera origin unit_Z unitY l)
+        mempty mempty mempty (Query . const . Any $ False)
+
+mm50, mm50Wide, mm50Narrow :: PerspectiveLens
+
+-- | mm50 has the field of view of a 50mm lens on standard 35mm film,
+-- hence an aspect ratio of 3:2.
+mm50 = PerspectiveLens 40.5 27
+
+-- | mm50Wide has the same vertical field of view as mm50, but an
+-- aspect ratio of 1.6, suitable for wide screen computer monitors.
+mm50Wide = PerspectiveLens 43.2 27
+
+-- | mm50Narrow has the same vertical field of view as mm50, but an
+-- aspect ratio of 4:3, for VGA and similar computer resulotions.
+mm50Narrow = PerspectiveLens 36 27
+
+camForward :: Direction d => Camera l -> d
+camForward = direction . forward
+
+camUp :: Direction d => Camera l -> d
+camUp = direction . up
+
+camRight :: Direction d => Camera l -> d
+camRight c = direction right where
+  right = cross3 (forward c) (up c)
+
+camLens :: Camera l -> l
+camLens = lens
+
+camAspect :: CameraLens l => Camera l -> Double
+camAspect = aspect . camLens

src/Diagrams/ThreeD/Light.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FlexibleContexts           #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Diagrams.ThreeD.Render
+-- Copyright   :  (c) 2013 diagrams-lib team (see LICENSE)
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  diagrams-discuss@googlegroups.com
+--
+-- Types to specify lighting for 3D rendering.
+--
+-----------------------------------------------------------------------------
+
+module Diagrams.ThreeD.Light where
+
+import Data.Colour
+import Data.Monoid
+
+import Diagrams.Core
+import Diagrams.ThreeD.Types
+import Diagrams.ThreeD.Vector
+
+data PointLight = PointLight P3 (Colour Double)
+
+data ParallelLight = ParallelLight R3 (Colour Double)
+
+type instance V PointLight = R3
+type instance V ParallelLight = R3
+
+instance Transformable PointLight where
+    transform t (PointLight p c) = PointLight (transform t p) c
+
+instance Transformable ParallelLight where
+    transform t (ParallelLight v c) = ParallelLight (transform t v) c
+
+instance IsPrim PointLight
+instance IsPrim ParallelLight
+
+-- | Construct a Diagram with a single PointLight at the origin, which
+-- takes up no space.
+pointLight :: (Backend b R3, Renderable PointLight b)
+              => Colour Double -- ^ The color of the light
+              -> Diagram b R3
+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.
+                 -> Colour Double -- ^ The color of the light.
+                 -> Diagram b R3
+parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c)
+                    mempty mempty mempty (Query . const . Any $ False)

src/Diagrams/ThreeD/Types.hs

@@ -36,8 +36,11 @@ module Diagrams.ThreeD.Types
          -- * Directions in 3D
        , Direction(..)
        , Spherical(..)
+       , asSpherical
        ) where
 
+import Control.Applicative
+
 import Diagrams.Coordinates
 import Diagrams.TwoD.Types
 import Diagrams.Core
@@ -116,24 +119,34 @@ instance HasCross3 R3 where
 -- | Direction is a type class representing directions in R3.  The interface is
 -- based on that of the Angle class in 2D.
 
-class AdditiveGroup d => Direction d where
+class Direction d where
     -- | Convert to polar angles
     toSpherical :: Angle a => d -> Spherical a
 
     -- | Convert from polar angles
     fromSpherical :: Angle a => Spherical a -> d
 
-instance Angle a => AdditiveGroup (Spherical a) where
-    zeroV = Spherical 0 0
-    (Spherical θ φ) ^+^ (Spherical θ' φ') = Spherical (θ+θ') (φ+φ')
-    negateV (Spherical θ φ) = Spherical (-θ) (-φ)
-
-instance Angle a => Direction (Spherical a) where
-    toSpherical (Spherical θ φ) = Spherical (convertAngle θ) (convertAngle φ)
-    fromSpherical (Spherical θ φ) = Spherical (convertAngle θ) (convertAngle φ)
-
 -- | A direction expressed as a pair of spherical coordinates.
 -- `Spherical 0 0` is the direction of `unitX`.  The first coordinate
 -- represents rotation about the Z axis, the second rotation towards the Z axis.
-data Angle a => Spherical a = Spherical a a
-                            deriving (Show)
+data Spherical a = Spherical a a
+                   deriving (Show, Read, Eq)
+
+instance Applicative Spherical where
+    pure a = Spherical a a
+    Spherical a b <*> Spherical c d = Spherical (a c) (b d)
+
+instance Functor Spherical where
+    fmap f s = pure f <*> s
+
+instance (Angle a) => Direction (Spherical a) where
+    toSpherical = fmap convertAngle
+    fromSpherical = fmap convertAngle
+
+-- | The identity function with a restricted type, for conveniently
+-- restricting unwanted polymorphism.  For example, @fromDirection
+-- . asSpherical . camForward@ gives a unit vector pointing in the
+-- direction of the camera view.  Without @asSpherical@, the
+-- intermediate type would be ambiguous.
+asSpherical :: Spherical Turn -> Spherical Turn
+asSpherical = id

src/Diagrams/TwoD/Types.hs

@@ -196,7 +196,7 @@ instance Transformable R2 where
 -- | Newtype wrapper used to represent angles as fractions of a
 --   circle.  For example, 1\/3 turn = tau\/3 radians = 120 degrees.
 newtype Turn = Turn { getTurn :: Double }
-  deriving (Read, Show, Eq, Ord, Enum, Fractional, Num, Real, RealFrac)
+  deriving (Read, Show, Eq, Ord, Enum, Fractional, Num, Real, RealFrac, AdditiveGroup)
 
 -- | The identity function with a restricted type, for conveniently
 -- declaring that some value should have type 'Turn'.  For example,
@@ -211,7 +211,7 @@ type CircleFrac = Turn
 
 -- | Newtype wrapper for representing angles in radians.
 newtype Rad = Rad { getRad :: Double }
-  deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac)
+  deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac, AdditiveGroup)
 
 -- | The identity function with a restricted type, for conveniently
 -- declaring that some value should have type 'Rad'.  For example,
@@ -223,7 +223,7 @@ asRad = id
 
 -- | Newtype wrapper for representing angles in degrees.
 newtype Deg = Deg { getDeg :: Double }
-  deriving (Read, Show, Eq, Ord, Enum, Fractional, Num, Real, RealFrac)
+  deriving (Read, Show, Eq, Ord, Enum, Fractional, Num, Real, RealFrac, AdditiveGroup)
 
 -- | The identity function with a restricted type, for conveniently
 -- declaring that some value should have type 'Deg'.  For example,