From 7e99a63a8bcf0c338aef649343ae52657e4d764a Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 18 Sep 2013 15:14:12 -0400 Subject: [PATCH 1/6] AdditiveGroup instances for Angle types --- src/Diagrams/TwoD/Types.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 3d3a7e93..2a7fd3a6 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/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, From e204d896d4f5af545015910461bcf6715baaf263 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 18 Sep 2013 13:27:26 -0400 Subject: [PATCH 2/6] Remove Angle constraint on Spherical type avoid Datatype Context --- src/Diagrams/ThreeD/Types.hs | 40 ++++++++++++++++++++++++++---------- 1 file changed, 29 insertions(+), 11 deletions(-) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 80b77504..efc02624 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/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 @@ -123,17 +126,32 @@ class AdditiveGroup d => Direction d where -- | 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 (AdditiveGroup a) => AdditiveGroup (Spherical a) where + zeroV = Spherical zeroV zeroV + (^+^) = liftA2 (^+^) + negateV = fmap negateV + +instance (AdditiveGroup a, 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 From a9867def9dd4fcbab9c6ea57a0363e8972f52ed1 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Thu, 12 Sep 2013 11:24:28 -0400 Subject: [PATCH 3/6] New Camera type & CameraLens class; perspective & orthographic instances --- src/Diagrams/ThreeD/Camera.hs | 119 ++++++++++++++++++++++++++++++++++ 1 file changed, 119 insertions(+) create mode 100644 src/Diagrams/ThreeD/Camera.hs diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs new file mode 100644 index 00000000..8c55d2be --- /dev/null +++ b/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 From 61982ea83ce9b553798689b206f5ce0fbf928915 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 16 Sep 2013 17:17:17 -0400 Subject: [PATCH 4/6] Add types PointLight, ParallelLight PointLight represents a spherically symmetric light source ParallelLight represents parallel light rays covering the entire scene --- src/Diagrams/ThreeD/Light.hs | 55 ++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 src/Diagrams/ThreeD/Light.hs diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs new file mode 100644 index 00000000..8c939f02 --- /dev/null +++ b/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) From 14be36cf4f2fab7e347dd7808363cfc4550d5ff0 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 16 Sep 2013 17:17:34 -0400 Subject: [PATCH 5/6] Export Camera and Light modules --- diagrams-lib.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 04b31b97..e23c4bcf 100644 --- a/diagrams-lib.cabal +++ b/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, From 76771339c4bb2580277c0c6fb658472a11155587 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 18 Sep 2013 21:11:13 -0400 Subject: [PATCH 6/6] Directions do not form an AdditiveGroup --- src/Diagrams/ThreeD/Types.hs | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index efc02624..82ef02e4 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -119,7 +119,7 @@ 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 @@ -139,12 +139,7 @@ instance Applicative Spherical where instance Functor Spherical where fmap f s = pure f <*> s -instance (AdditiveGroup a) => AdditiveGroup (Spherical a) where - zeroV = Spherical zeroV zeroV - (^+^) = liftA2 (^+^) - negateV = fmap negateV - -instance (AdditiveGroup a, Angle a) => Direction (Spherical a) where +instance (Angle a) => Direction (Spherical a) where toSpherical = fmap convertAngle fromSpherical = fmap convertAngle