Lights & Camera

diagrams-povray.cabal

@@ -18,10 +18,12 @@ Source-repository head
 
 Library
   Exposed-modules:   Diagrams.Backend.POVRay
+  Other-Modules:     Diagrams.Backend.POVRay.Syntax
   Hs-source-dirs:    src
   Build-depends:     base >= 4.2 && < 4.7,
                      diagrams-core >= 0.7 && < 0.8,
                      diagrams-lib >= 0.7 && < 0.8,
                      pretty >= 1.0.1.2 && < 1.2,
-                     vector-space >= 0.8 && < 0.9
+                     vector-space >= 0.8 && < 0.9,
+                     colour >= 2.3 && < 2.4
   Default-language:  Haskell2010

src/Diagrams/Backend/POVRay.hs

@@ -19,13 +19,19 @@
 module Diagrams.Backend.POVRay
 
   ( POVRay(..)       -- backend token
+  ,  Options(..)  -- rendering options
   ) where
 
+import qualified Data.Colour.SRGB.Linear as S
+
 import Diagrams.Core.Transform
 
-import Diagrams.Prelude
+import Diagrams.Prelude hiding (fromDirection, tan)
 import Diagrams.ThreeD.Types
 import Diagrams.ThreeD.Shapes
+import Diagrams.ThreeD.Vector
+import Diagrams.ThreeD.Camera
+import Diagrams.ThreeD.Light
 
 import Diagrams.Backend.POVRay.Syntax
 
@@ -45,14 +51,63 @@ instance Backend POVRay R3 where
   type Result  POVRay R3 = String
   data Options POVRay R3 = POVRayOptions
 
-  withStyle _ _ _ p = p
+  withStyle _ s _ (Pov is) = Pov $ map (setSurfColor s) is
 
   doRender _ _ (Pov items) = PP.render . PP.vcat . map toSDL $ items
 
 instance Renderable Ellipsoid POVRay where
   render _ (Ellipsoid t) = Pov [SIObject . OFiniteSolid $ s]
     where s = Sphere zeroV 1 [povrayTransf t]
 
+-- For perspective projection, forLen tells POVRay the horizontal
+-- field of view, and CVRight specifies the aspect ratio of the view.
+-- For orthographic projection, rightLen & upLen are the actual window
+-- dimensions, and forLen is ignored by POVRay.
+instance Renderable (Camera PerspectiveLens) POVRay where
+  render _ c = Pov [ SICamera cType [
+    CIVector . CVLocation . vector $ loc
+    , CIVector . CVDirection . vector . unr3 $ forLen *^ forUnit
+    , CIVector . CVUp . vector . unr3 $ upUnit
+    , CIVector . CVRight . vector . unr3 $ rightLen *^ rightUnit
+    ]]
+    where
+      loc = unp3 . camLoc $ c
+      (PerspectiveLens h v) = camLens c
+      forUnit = fromDirection . asSpherical . camForward $ c
+      forLen = 0.5*rightLen/tan(h'/2) where
+        (Rad h') = convertAngle h
+      upUnit =  fromDirection . asSpherical . camUp $ c
+      rightUnit = fromDirection . asSpherical . camRight $ c
+      rightLen = angleRatio h v
+      cType = Perspective
+
+instance Renderable (Camera OrthoLens) POVRay where
+  render _ c = Pov [ SICamera Orthographic [
+    CIVector . CVLocation . vector $ loc
+    , CIVector . CVDirection . vector . unr3 $ forUnit
+    , CIVector . CVUp . vector . unr3 $ v *^ upUnit
+    , CIVector . CVRight . vector . unr3 $ h *^ rightUnit
+    ]]
+    where
+      loc = unp3 . camLoc $ c
+      (OrthoLens h v) = camLens c
+      forUnit = fromDirection . asSpherical . camForward $ c
+      upUnit =  fromDirection . asSpherical . camUp $ c
+      rightUnit = fromDirection . asSpherical . camRight $ c
+
+instance Renderable ParallelLight POVRay where
+    render _ (ParallelLight v c) = Pov [SIObject . OLight $ LightSource pos c' [
+        Parallel v' ]] where
+      pos = vector . unp3 $ origin .-^ (1000 *^ v)
+      v' =  vector . unp3 $ origin
+      c' = convertColor c
+
+instance Renderable PointLight POVRay where
+    render _ (PointLight p c) =
+        Pov [SIObject . OLight $ LightSource pos c' []] where
+          pos = vector $ unp3 p
+          c' = convertColor c
+
 povrayTransf :: T3 -> ObjectModifier
 povrayTransf t = OMTransf $
                  TMatrix [ v00, v01, v02
@@ -62,4 +117,22 @@ povrayTransf t = OMTransf $
   where (unr3 -> (v00, v01, v02)) = apply t (r3 (1,0,0))
         (unr3 -> (v10, v11, v12)) = apply t (r3 (0,1,0))
         (unr3 -> (v20, v21, v22)) = apply t (r3 (0,0,1))
-        (unr3 -> (v30, v31, v32)) = transl t
+        (unr3 -> (v30, v31, v32)) = transl t
+
+vector :: (Double, Double, Double) -> Vector
+vector (x, y, z) = VecLit x y z
+
+convertColor :: Color c => c -> VColor
+convertColor c = RGB $ vector (r, g, b) where
+  (r, g, b, _) = colorToSRGBA c
+
+-- Use the FillColor attribute for the diffuse pigment of the object.  Diagrams
+-- doesn't have a model for highlights, transparency, etc. yet.
+setSurfColor :: Style v -> SceneItem -> SceneItem
+setSurfColor _ i@(SICamera _ _) = i
+setSurfColor _ i@(SIObject (OLight _)) = i
+setSurfColor s i@(SIObject (OFiniteSolid (Sphere c r mods))) =
+    case getFillColor <$> getAttr s of
+        Nothing -> i
+        Just (SomeColor col) -> SIObject . OFiniteSolid $ Sphere c r (p:mods) where
+          p = OMPigment . PColor . convertColor $ col

src/Diagrams/Backend/POVRay/Syntax.hs

@@ -49,6 +49,10 @@ instance SDL Double where
 instance SDL () where
   toSDL _ = empty
 
+instance SDL s => SDL (Maybe s) where
+  toSDL Nothing  = empty
+  toSDL (Just s) = toSDL s
+
 ------------------------------------------------------------
 -- Basics
 ------------------------------------------------------------
@@ -62,28 +66,29 @@ instance SDL Vector where
 
 instance AdditiveGroup Vector where
   zeroV = VecLit 0 0 0
-  (VecLit x1 y1 z1) ^+^ (VecLit x2 y2 z2) = VecLit (x1+x2) (y1+y2) (z1+z1)
+  (VecLit x1 y1 z1) ^+^ (VecLit x2 y2 z2) = VecLit (x1+x2) (y1+y2) (z1+z2)
   negateV (VecLit x y z) = VecLit (-x) (-y) (-z)
 
 instance VectorSpace Vector where
   type Scalar Vector = Double
   d *^ (VecLit x y z) = VecLit (d*x) (d*y) (d*z)
 
-data Color = RGB Vector
+data VColor = RGB Vector
 
-instance SDL Color where
+instance SDL VColor where
   toSDL (RGB v) = text "rgb" <+> toSDL v
 
 ------------------------------------------------------------
 -- Scene items
 ------------------------------------------------------------
 
 -- | Top-level items that can occur in a scene.
-data SceneItem = SICamera [CameraItem]
+data SceneItem = SICamera CameraType [CameraItem]
                | SIObject Object
 
 instance SDL SceneItem where
-  toSDL (SICamera cItems) = block "camera" (map toSDL cItems)
+  toSDL (SICamera cType cItems) = block "camera"
+                                  (toSDL cType:map toSDL cItems)
   toSDL (SIObject obj)    = toSDL obj
 
 ------------------------------------------------------------
@@ -97,13 +102,19 @@ instance SDL CameraItem where
   toSDL (CIVector cv)   = toSDL cv
   toSDL (CIModifier cm) = toSDL cm
 
+data CameraType = Perspective | Orthographic  -- TODO add more types?
+
 
 data CameraVector = CVLocation  Vector
                   | CVRight     Vector
                   | CVUp        Vector
                   | CVDirection Vector
                   | CVSky       Vector
 
+instance SDL CameraType where
+    toSDL Perspective = empty
+    toSDL Orthographic = text "orthographic"
+
 instance SDL CameraVector where
   toSDL (CVLocation v)  = text "location"  <+> toSDL v
   toSDL (CVRight v)     = text "right"     <+> toSDL v
@@ -112,9 +123,11 @@ instance SDL CameraVector where
   toSDL (CVSky v)       = text "sky"       <+> toSDL v
 
 data CameraModifier = CMLookAt Vector
+                    | CMAngle Double -- degrees
 
 instance SDL CameraModifier where
   toSDL (CMLookAt v) = text "look_at" <+> toSDL v
+  toSDL (CMAngle  d) = text "angle" <+> toSDL d
 
 ------------------------------------------------------------
 -- Objects
@@ -142,7 +155,7 @@ instance SDL TMatrix where
                        <> (hcat . punctuate comma . map toSDL $ ds)
                        <> text ">"
 
-data Pigment = PColor Color
+data Pigment = PColor VColor
 
 instance SDL Pigment where
   toSDL (PColor c) = block "pigment" [toSDL c]
@@ -161,10 +174,13 @@ instance SDL FiniteSolid where
 -- Light sources
 ------------------------------------------------------------
 
-data LightSource = LightSource Vector Color [LightModifier]
+data LightSource = LightSource Vector VColor [LightModifier]
 
 instance SDL LightSource where
   toSDL (LightSource loc c mods) = block "light_source" (lc : map toSDL mods)
     where lc = toSDL loc <> comma <+> toSDL c
 
-type LightModifier = ()
+data LightModifier = Parallel Vector
+
+instance SDL LightModifier where
+    toSDL (Parallel v) = text "parallel" $$ text "point_at" <+> toSDL v