{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses , ParallelListComp, ScopedTypeVariables, TypeOperators , FlexibleContexts, TypeFamilies #-} -- {-# OPTIONS_GHC -Wall #-} -- TODO: restore ---------------------------------------------------------------------- -- | -- Module : Graphics.FieldTrip.Geometry3 -- Copyright : (c) Conal Elliott and Andy J Gill 2008 -- License : BSD3 -- -- Maintainer : conal@conal.net, andygill@ku.edu -- Stability : experimental -- -- 3D geometry ---------------------------------------------------------------------- module Graphics.FieldTrip.Geometry3 ( Geometry3, onMaterialG, materialG, rendererG, renderableG, flatG , renderWith3, render3 , normalArrowG , cube, box3 , sphere, usphere, frustrum, cone, cylinder, torus , surfG, surfG' -- * Geometry filters , Filter3, move3, move3X, move3Y, move3Z, pivot3, andFlip3 , pivot3X, pivot3Y, pivot3Z -- tmp ,vsurf ) where -- TODO: restore exports when i get this module compiling again import Data.Monoid import Control.Applicative import Graphics.Rendering.OpenGL hiding (normal) import qualified Graphics.Rendering.OpenGL as G -- TypeCompose import Control.Instances () -- IO monoid import Data.VectorSpace import Data.MemoTrie import Data.Basis import Data.Cross import Data.AffineSpace import Graphics.FieldTrip.Misc import Graphics.FieldTrip.Vector2 import Graphics.FieldTrip.Vector3 import Graphics.FieldTrip.Normal3 import Graphics.FieldTrip.Point3 import Graphics.FieldTrip.Color import Graphics.FieldTrip.Material import Graphics.FieldTrip.Transform import Graphics.FieldTrip.Transform3 import Graphics.FieldTrip.Render import Graphics.FieldTrip.Geometry2 -- import Graphics.FieldTrip.Image import Graphics.Formats -- for parametric surfaces import Data.Derivative ((:>),pureD,idD,powVal) import qualified Graphics.FieldTrip.ParamSurf as P import Graphics.FieldTrip.ParamSurf hiding (frustrum,torus) -- | 3D geometry data Geometry3 = EmptyG | UnionG Geometry3 Geometry3 | forall s. (Floating s, Real s, MatrixComponent s) => TransformG (Transform3 s) Geometry3 | RenderG Renderer | GContextG (Unop GContext) Geometry3 -- temporary: | MaterialG MaterialTrans Geometry3 -- TextureG Image Geometry3 -- LightG LightType -- embedded light -- TODO: textures & lights. What interface to use for textures? I'd like -- to have a composable image type. -- TODO: consider dropping EmptyG in favor of a trivial use of RenderG. -- Possible drawback: loss of optimization. -- Why represent 3d geometry as an algebraic type but 2d geometry as a -- rendering action? Because of embeddable lights and cameras, which can -- be extracted by a first pass for rendering in a second pass. We could -- represent a geometry as a set of lights and cameras plus a rendering -- action. We'll probably want to gather up and use all of the lights, -- but just one of the cameras. Question: how to select an embedded camera? -- -- Still -- make 2d & 3d consistent, even if currently unnecessary for 2d. -- -- Why *embed* lights and cameras in the geometry instead of specifying -- them separately? Because then they can be placed deeply into the -- scene, accumulating transforms, along with the visible geometry. -- TODO: consider replacing RenderG with something more declarative, -- such as a parametric surface and an image. Then we could do other -- things with geometry. -- | Make a geometry from a rendering action. The action must leave graphics -- state as it found it. rendererG :: Renderer -> Geometry3 rendererG = RenderG renderableG :: Renderable a => a -> Geometry3 renderableG = rendererG . const . render instance Monoid Geometry3 where mempty = EmptyG mappend = UnionG -- TODO: optimize instance (Floating s, Real s, MatrixComponent s) => Transform (Transform3 s) Geometry3 where (*%) = TransformG -- | Modify the material in a geometry. See also 'materialG'. onMaterialG :: MaterialTrans -> Filter3 onMaterialG = MaterialG -- | Replace the material of a geometry. More generally, see 'onMaterialG'. materialG :: Material -> Filter3 materialG = MaterialG . const -- | Render the geometry, given a graphics context. Leaves graphics state unchanged. renderWith3 :: GContext -> Geometry3 -> IO () renderWith3 = flip renderIO -- | Render the geometry with default graphics context. See also 'renderWith3'. render3 :: Geometry3 -> IO () render3 = renderWith3 defaultGC -- | Use a graphics context transformer. -- TODO: rewrite onColor usi9ng renderUsing3. renderUsing3 :: Unop GContext -> Geometry3 -> Geometry3 renderUsing3 = GContextG normalArrowG :: Col -> Filter3 normalArrowG col = renderUsing3 (\ gc -> gc { gcNormals = Just col }) -- -- | Flatten 3d geometry to 2d. -- flatten :: Geometry3 -> Geometry2 -- flatten = renderer2 . renderIO -- IO version. renderIO :: Geometry3 -> Renderer renderIO EmptyG = mempty renderIO (g `UnionG` g') = renderIO g `mappend` renderIO g' renderIO (xf `TransformG` g) = \ gc -> preservingMatrix $ do tweakMatrix3 xf renderIO g (onErr (tweakError3 xf) gc) renderIO (RenderG r) = r renderIO (GContextG f g) = \ gc -> renderIO g (f gc) renderIO (MaterialG i g) = \ (GC err o norms) -> renderIO g (GC err (o.i) norms) -- TODO: resolve inconsistency between style for tweaking err vs colortrans. -- | Flat geometry flatG :: Geometry2 -> Geometry3 flatG g2 = rendererG $ \ gc -> -- The 2d geometry likely omits normals, so set them all here. If we -- don't, then normals from 3D geometry will contaminate 2D. G.normal (Normal3 0 0 (1 :: R)) >> renderWith2 gc g2 -- TODO: Get flatG and flatten to work together. I'd like flatten to ---- primitives -- | Four-tuple. Useful for making quadrilateral geometry. data Quad p = Quad !p !p !p !p -- Useful? instance Functor Quad where f `fmap` Quad a b c d = Quad (f a) (f b) (f c) (f d) -- TODO: Get flatG and flatten to work together. -- Unit cube cube :: Geometry3 cube = topBottom `mappend` pivoted xAxis `mappend` pivoted yAxis where topBottom = andFlip3 yAxis (move3Z (1/2 :: R) side) -- side = flatG ubox2 side = surfG (hfSurf (const 0)) pivoted = flip pivot3 topBottom xAxis, yAxis :: Vector3 R -- monomorphic versions xAxis = xVector3 yAxis = yVector3 -- Box with given sizes in X, Y, and Z box3 :: (MatrixComponent s, Real s, Floating s) => s -> s -> s -> Geometry3 box3 sx sy sz = scale3 sx sy sz *% cube -- TODO: -- + more elegant/modular way to specify normals -- + triangle fans -- | Unit sphere usphere :: Geometry3 usphere = surfG (sphere1 :: Surf (Vector2 R :> R)) -- | Sphere with given radius sphere :: R -> Geometry3 sphere r = uscale3 r *% usphere -- | Frustrum of a cone, with given base radius, top radius, and height, -- centered at origin. frustrum :: R -> R -> R -> Geometry3 frustrum baseR topR h = surfG (P.frustrum (pureD baseR) (pureD topR) (pureD h)) -- | Cone with given base radius and height, and height, -- centered at origin.. cone :: R -> R -> Geometry3 cone r h = frustrum r 0 h -- | Cylinder with given radius and height, centered at origin, and height, -- centered at origin.. cylinder :: R -> R -> Geometry3 cylinder r h = frustrum r r h -- | Torus with given radii for the sweep and the swept circle torus :: R -> R -> Geometry3 torus sr cr = surfG (P.torus (pureD sr) (pureD cr)) -- General surface renderer renderSurfG :: (Fractional s, Vertex b) => (Vector2 s -> b) -> ErrorBound -> IO () renderSurfG f = logMemo (3/4) $ \ err -> sequence_ $ let -- Surface samples. -- outs :: [[VN3 R]] outs = (fmap.fmap) f (params err) in [ renderPrimitive TriangleStrip $ sequence_ $ [ vertex vn' >> vertex vn | vn <- row | vn' <- row' ] | row <- outs | row' <- tail outs ] renderNormalArrowsG :: (Vector2 R -> VN3 R) -> ErrorBound -> Col -> IO () renderNormalArrowsG f = logMemo (1/4) $ \ err col -> sequence_ $ let -- Surface samples. -- outs :: [[VN3 R]] outs = (fmap.fmap) f (params err) in [ renderPrimitive Lines $ sequence_ $ [ case vn of (VN pt3 nor3) -> color col >> vertex pt3 >> vertex (add err pt3 nor3) | vn <- row ] | row <- outs ] where add :: R -> Vertex3 R -> Normal3 R -> Vertex3 R add err (Vertex3 x y z) (Normal3 x' y' z') = Vertex3 (x + x' * err') (y + y' * err') (z + z' * err') where err' = sqrt err -- | Parametric surface without texture surfG :: Surf (Vector2 R :> R) -> Geometry3 surfG surf = rendererG $ \ (GC err fmat norms) -> do material (fmat defaultMat) rsurf err case norms of Nothing -> return () Just col' -> arrows err col' where -- out of the \ (GC ...) so computed once per surf, not once per gc the_surf = vsurf surf rsurf = renderSurfG the_surf arrows = renderNormalArrowsG the_surf -- The types of surfG and related functions can be parameterized over -- scalar types and material type. -- | Parametric surface with texture -- surfG' :: Surf (Vector2 R :> R) -> ImageC -> Geometry3 surfG' :: ( Floating s, InnerSpace s s, HasBasis s s, HasTrie (Basis s), Basis s ~ () , VertexComponent s, NormalComponent s, Color c) => Surf (Vector2 s :> s) -> ((s, s) -> c) -> Geometry3 surfG' surf img = rendererG $ \ (GC err _ _) -> rsurf err where -- out of the \ (GC ...) so computed once per surf, not once per gc rsurf = renderSurfG (vsurf' surf img) -- TODO: refactor surfG' & surfG -- type VNC s = VC (VN3 s) (Color4 s) vsurf' :: (InnerSpace s s, Floating s, HasBasis s s, HasTrie (Basis s), Basis s ~ ()) => Surf (Vector2 s :> s) -> ((s,s) -> c) -> Vector2 s -> VC (VN3 s) c vsurf' surf img = liftA2 VC (vsurf surf) (img . coords2) where coords2 (Vector2 x y) = (x,y) -- Parameter space samples, based on error bound. Should really depend on -- the surface properties. Redo later. params :: forall s. Fractional s => ErrorBound -> [[Vector2 s]] params err = [[Vector2 u v | u <- us] | v <- vs] where -- Steps/facets in u and in v. Placeholder. -- TODO: consider how to distribute the error for surfaces. Maybe use -- derivative bounds and adaptively tessellate. nu :: Int nu = round (recip err) `max` 1 -- nv = ... du :: s du = recip (fromIntegral nu) -- dv = du -- recip (fromIntegral nv) -- nu+1 u samples, and nv+1 v samples us,vs :: [s] us = fmap ((subtract 0.5).(*du).fromIntegral) [0::Int .. nu] vs = us -- fmap ((*du).fromIntegral) [0::Int .. nu] -- TODO: consider redoing tessellation functionally, i.e., generating a -- list of OpenGL primitives instead of rendering them. So far, I don't -- see a benefit. -- x',y',z' :: a :-* (a :> s) -- look for a simpler formulation, exploiting linearity. first collapse -- @(a:>s, a:>s, a:>s)@ to @a:>(s,s,s)@. -- vec3 = linearD (\ (x,y,z) -> Vector3 x y z) -- type SurfPt s = Two s :> Three s type SurfPt s = Vector2 s :> Vector3 s vsurf :: ( InnerSpace s s, Floating s , HasBasis s s, HasTrie (Basis s), Basis s ~ ()) => Surf (Vector2 s :> s) -> (Vector2 s -> VN3 s) vsurf surf = toVN3 . vector3D . surf . unvector2D . idD -- dId :: R2 -> R2 :> R2 -- unvec2 . dId :: R2 -> (R2:>R,R2:>R) -- surf . unvec2 . dId :: R2 -> (R2:>R,R2:>R,R2:>R) -- vec3 . surf . unvec2 . dId :: R2 -> R2 :> R3 -- toVN3 . vec3 . surf . unvec2 . dId :: R2 -> VN3 toVN3 :: (Floating s, InnerSpace s s, HasBasis s s, HasTrie (Basis s) , HasNormal (SurfPt s), InnerSpace (SurfPt s) (Vector2 s :> s) ) => SurfPt s -> VN3 s toVN3 v = VN (origin3 .+^ powVal v) (vectorToNormal3 (powVal (normal v))) -- toVN3 :: a -- toVN3 = error "toVN3" ---- Geometry3 filters -- Geometry3 filter type Filter3 = Geometry3 -> Geometry3 -- move3 :: R -> R -> R -> Filter3 move3 :: (MatrixComponent s, Real s, Floating s) => s -> s -> s -> Filter3 move3 dx dy dz = (translate3 (Vector3 dx dy dz) *%) move3X, move3Y, move3Z :: (MatrixComponent s, Real s, Floating s) => s -> Filter3 move3X dx = move3 dx 0 0 move3Y dy = move3 0 dy 0 move3Z dz = move3 0 0 dz -- Rotate pi/2 about axis pivot3 :: (MatrixComponent s, Floating s, Real s) => Vector3 s -> Filter3 pivot3 axis = (rotate3 (pi/2) axis *%) pivot3X, pivot3Y, pivot3Z :: Filter3 pivot3X = pivot3 (xVector3 :: Vector3 R) pivot3Y = pivot3 (yVector3 :: Vector3 R) pivot3Z = pivot3 (zVector3 :: Vector3 R) -- A geometry plus its a rotated-by-pi version. andFlip3 :: (MatrixComponent s, Floating s, Real s) => Vector3 s -> Filter3 andFlip3 axis g = g `mappend` (rotate3 pi axis *% g)