FieldTrip (empty) → 0.2
raw patch · 30 files changed
+2699/−0 lines, 30 filesdep +GLUTdep +MemoTriedep +OpenGLsetup-changed
Dependencies added: GLUT, MemoTrie, OpenGL, TypeCompose, base, graphicsFormats, old-time, vector-space
Files
- FieldTrip.cabal +46/−0
- Makefile +3/−0
- README +10/−0
- Setup.lhs +3/−0
- TODO +31/−0
- doc/Makefile +13/−0
- doc/datatypes.dot +76/−0
- doc/packages.dot +28/−0
- doc/relate.dot +54/−0
- examples/src/Perf.hs +175/−0
- examples/src/Tablet.hs +105/−0
- examples/src/Test.hs +175/−0
- src/Graphics/FieldTrip.hs +48/−0
- src/Graphics/FieldTrip/Color.hs +152/−0
- src/Graphics/FieldTrip/Geometry2.hs +225/−0
- src/Graphics/FieldTrip/Geometry3.hs +393/−0
- src/Graphics/FieldTrip/Image.hs +46/−0
- src/Graphics/FieldTrip/Material.hs +78/−0
- src/Graphics/FieldTrip/Misc.hs +42/−0
- src/Graphics/FieldTrip/Normal3.hs +56/−0
- src/Graphics/FieldTrip/ParamSurf.hs +180/−0
- src/Graphics/FieldTrip/Point2.hs +61/−0
- src/Graphics/FieldTrip/Point3.hs +61/−0
- src/Graphics/FieldTrip/Render.hs +53/−0
- src/Graphics/FieldTrip/Transform.hs +50/−0
- src/Graphics/FieldTrip/Transform2.hs +74/−0
- src/Graphics/FieldTrip/Transform3.hs +102/−0
- src/Graphics/FieldTrip/Vector2.hs +119/−0
- src/Graphics/FieldTrip/Vector3.hs +179/−0
- src/Graphics/FieldTrip/Vertex.hs +61/−0
+ FieldTrip.cabal view
@@ -0,0 +1,46 @@+Name: FieldTrip+Version: 0.2+Synopsis: Functional 3D+Category: graphics+Description:+ FieldTrip is a library for functional 3D geometry+ .+ Please see the project wiki page: <http://haskell.org/haskellwiki/reactive>+ .+ The module documentation pages have links to colorized source code and+ to wiki pages where you can read and contribute user comments. Enjoy!+ .+ © 2008 by Andy Gill and Conal Elliott; BSD3 license.+Author: Conal Elliott and Andy Gill+Maintainer: conal@conal.net, andygill@ku.edu+Homepage: http://haskell.org/haskellwiki/FieldTrip+Package-Url: http://code.haskell.org/f3d+Copyright: (c) 2007-2008 by Conal Elliott and Andy Gill+License: BSD3+Stability: experimental+build-type: Simple+Hs-Source-Dirs: src+Extensions: +Build-Depends: base, old-time, OpenGL, GLUT, TypeCompose, MemoTrie, vector-space >= 0.4.1, graphicsFormats+Exposed-Modules: + Graphics.FieldTrip+ Graphics.FieldTrip.Misc+ Graphics.FieldTrip.Vector2+ Graphics.FieldTrip.Vector3+ Graphics.FieldTrip.Point2+ Graphics.FieldTrip.Point3+ Graphics.FieldTrip.Normal3+ Graphics.FieldTrip.Transform+ Graphics.FieldTrip.Transform2+ Graphics.FieldTrip.Transform3+ Graphics.FieldTrip.Color+ Graphics.FieldTrip.Material+ Graphics.FieldTrip.Render+ Graphics.FieldTrip.ParamSurf+ Graphics.FieldTrip.Image+ Graphics.FieldTrip.Geometry2+ Graphics.FieldTrip.Geometry3+ +ghc-options: -Wall -O2++-- TypeCompose is used for its IO monoid. Not much of a reason.
+ Makefile view
@@ -0,0 +1,3 @@+# For special configuration, especially for docs. Otherwise see README.++include ../my-cabal-make.inc
+ README view
@@ -0,0 +1,10 @@+A functional 3D graphics library.++We're just getting started, so abstractions are in flux. I think we'll+want this library to have functional 3D and rely on another library (e.g.,+Reactive) for animation and reactivity.++If you want to try things out from inside ghci, use the following command line.++ghci -isrc:FieldTrip-GLUT/src:examples examples/Test.hs+
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ TODO view
@@ -0,0 +1,31 @@+## To do++### Both++* Colors, at least. Textures!+* Display frame rate and polygon count in viewer.+* Feeback between frame rate and error bound.+* Decide whether we want coordinate-polymorphism (Float/Double). Often+requires type annotations. If not, do we wire in Float or Double?+* Revisit dependency on TypeCompose.+* Change this file to markdown mode (TODO.md) and use pandoc (via make) to+generate a prettier version. And longlines mode as well.++### Conal++* Improve adaptive tessellation. Account for perspective viewing and for+the nature of a parametric surface (e.g., derivative bounds).+* Blog about the AD stuff that uses linear maps++### Andy++* Get our demo working inside GHCi, in a way we can restart+* Work out how to use an Image as a 2D-texture+* Add a Text -> Image function (adaptive to error bound)+++## Done++* Tablet, as an example+* General parametric surfaces with computed normals, using automatic+differentiation (AD).
+ doc/Makefile view
@@ -0,0 +1,13 @@+.SUFFIXES: .dot .png++DOT_FILES = datatypes.dot \+ packages.dot \+ relate.dot++build:: $(DOT_FILES:.dot=.png)++clean:+ rm *.png++%.png: %.dot+ dot -Tpng $< > $@
+ doc/datatypes.dot view
@@ -0,0 +1,76 @@+digraph G {++ rankdir=LR;++ GContext[label="GContext\n(Graphics Context)"];++ Geometry2[label="Geometry2"];++ Geometry3[label="Geometry3"];++ renderIO[shape="box",label="renderIO\n(render compiler)"]; + Geometry3 -> renderIO;+ renderIO -> Renderer;+ rendererG[shape="box",label="rendererG\n(adding primitive\nshape to geometry)"]; + rendererG -> Renderer[dir="back"]; + Geometry3 -> rendererG[dir="back"];++ Renderer[label="Renderer\n(GContext -> IO ())"];+++ flatG[shape="box"];+ Geometry2 -> flatG; flatG -> Geometry3;++ HeightField_a[label="HeightField a\n(a,a) -> a"];+ Surf_a[label="Surf a\n(a,a) -> (a,a,a)"];+ Curve2_a[label="Curve2 a\na -> (a,a)"];+ Curve3_a[label="Curve3 a\na -> (a,a,a)"];++ hfSurf[shape="box"];+ HeightField_a -> hfSurf;+ hfSurf -> Surf_a;++ Surf_der[label="Surf (Vector2 R :> R)"];+ Surf_a -> Surf_der[label="a : (Vector R :> R)",style="dashed"];+++ surfG[shape="box"];+ Surf_der -> surfG;+ surfG -> Geometry3;++ Image_a[label="Image a\n(R,R) -> a"];++ ImageC[label="ImageC\nImage Color"];+ Image_a -> ImageC[label="a : Color",style="dashed"];+ Region[label="Region\nImage Bool"];+ Image_a -> Region[label="a : Bool",style="dashed"];++ surfGP[shape="box",label="surfG'"];+ Surf_der -> surfGP;+ ImageC -> surfGP;+ surfGP -> Geometry3;++ circle[shape="box"];+ circle -> Curve2_a;+ semiCircle[shape="box"];+ semiCircle -> Curve2_a;++ { rank=same;+ revolve[shape="box"];+ sphere1[shape="box"];+ }++ Curve2_a -> revolve;+ revolve -> Surf_a;++ sphere1 -> revolve[style="dotted"];+ semiCircle -> sphere1[style="dotted"]; + sphere1 -> Surf_a;+++ sphere[shape="box"];+ sphere -> Geometry3;+ sphere -> surfG[style=dotted];+ sphere1 -> sphere[style=dotted];++}
+ doc/packages.dot view
@@ -0,0 +1,28 @@+digraph G {++ rankdir=TB;++ FieldTrip[shape="box",style="filled",fillcolor="yellow"];++ OpenGL[shape="box"];+ FieldTrip->OpenGL;++ GLUT[shape="box"];+ FieldTripGLUT->GLUT;+ GLUT->OpenGL;++ TypeCompose[shape="box"];+ frp -> TypeCompose;++ FieldTripGLUT[shape="box",style="filled",fillcolor="yellow",label="FieldTrip-GLUT"];+ FieldTripGLUT->FieldTrip;++ frp[shape="box",label="simply-reactive"];+ FieldTripGLUT->frp;+++ vectorspace[label="vector-space",shape=box];++ frp -> vectorspace;++}
+ doc/relate.dot view
@@ -0,0 +1,54 @@+digraph G {+++ subgraph cluster_1 {+ label="Specifing Scenes\n ";++ f3d[shape="box",style="filled",fillcolor="yellow"];+ }+++ OpenGL[shape="box"];+ OpenGLHW[shape="box",label="Hardware\nSupport"];++ f3d -> OpenGL;+ OpenGL -> OpenGLHW;++ subgraph cluster_2 {+ label="Rendering Scenes\n(using one of)";+ f3d_glut[shape="box",style="filled",fillcolor="green",label="f3d-glut"];+ f3d_glfw[shape="box",style="filled",fillcolor="green",label="f3d-glfw"];+ f3d_sdl[shape="box",style="filled",fillcolor="green",label="f3d-sdl"]; + f3d_other[shape="box",style="filled",fillcolor="green",label="f3d-(...)"];+ }++++ GLUT[shape="box"];+ GLFW[shape="box"];+ SDL[shape="box"];+ OTHER[shape="box",label="..."];++ f3d_glut -> GLUT;+ f3d_glfw -> GLFW;+ f3d_sdl -> SDL;+ f3d_other -> OTHER;+++ WINDOWING[shape="box",label="OS Specific Window Management"];++ GLUT -> WINDOWING;+ GLFW -> WINDOWING;+ SDL -> WINDOWING;+ OTHER -> WINDOWING;+++ sample[shape="box",style="filled",fillcolor="yellow",label="Sample Application"];+ sample -> f3d;+ sample -> f3d_glut;++++++}
+ examples/src/Perf.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Perf+-- Copyright : (c) Andy J Gill and Conal Elliott 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Try get peformance better+----------------------------------------------------------------------++-- module Test where++-- import Data.Monoid+-- import Control.Applicative++import Graphics.Rendering.OpenGL (Color)+-- import Graphics.FieldTrip.Glut ++-- import Data.Derivative ((:>))++import Graphics.FieldTrip.Misc+-- import Graphics.FieldTrip.Geometry2+import Graphics.FieldTrip.Geometry3+-- import Graphics.FieldTrip.Transform+-- import Graphics.FieldTrip.Transform3+import Graphics.FieldTrip.Vector2+import Graphics.FieldTrip.Vector3+import Graphics.FieldTrip.Color+import Graphics.FieldTrip.Image+-- import Graphics.FieldTrip.Render++import qualified Graphics.FieldTrip.ParamSurf as P+import Graphics.FieldTrip.ParamSurf hiding (torus)++-- import Data.Behavior+-- import Data.Reactive++import Data.VectorSpace+import Data.MemoTrie+-- import System.Environment +-- import Data.Cross+-- import Debug.Trace++import Graphics.FieldTrip.Normal3+import System.Time+import Data.Derivative+import Data.IORef+import System.IO.Unsafe++torusCrate :: Geometry3+torusCrate = colorG blue $ surfG fun++main :: IO ()+main = do+ () <- return () -- stops the rest from being a CAF++ writeIORef counterVar 0++ let fun2 :: Vector2 R -> VN3 R+ fun2 v = vsurf fun v+ let sz = 49+ numVerts = sqr (succ sz)++ putStrLn ("Test: " ++ show numVerts ++ " vertices")++ clock <- newClock+ -- getClockTime >>= print++ sequence_ [ p `seq` n `seq` return ()+ | x <- map (/sz) [0..sz]+ , y <- map (/sz) [0..sz]+ , let VN p n = fun2 (Vector2 x y) ]+ -- getClockTime >>= print+ t <- clock+ putStrLn $ show t ++ " seconds. " +++ show (numVerts / t) ++ " vertices per second."++ count <- readIORef counterVar++ putStrLn $ "Count == " ++ show count+ putStrLn $ "Count/vertex == " ++ show (fromIntegral count / numVerts)++-- A provider of relative time+type Clock = IO R++newClock :: IO Clock+newClock = currRelTime `fmap` getClockTime++-- Get the current time in seconds, relative to a start 'ClockTime'.+currRelTime :: ClockTime -> IO R+currRelTime (TOD sec0 pico0) = fmap delta getClockTime+ where+ delta (TOD sec pico) =+ fromIntegral (sec-sec0) + 1.0e-12 * fromIntegral (pico-pico0)+++sqr :: Num a => a -> a+sqr a = a * a++fun :: Surf (Vector2 R :> R)+fun v = 0 ^/ magnitude r1+ where+ r1 = unvector3D (normalV (vector3D (tt v)))++tt :: Surf (Vector2 R :> R)+tt = P.torus 1 (1/2)++normalV :: Vector2 R :> Vector3 R -> Vector2 R :> Vector3 R+normalV v = d (Left ()) `cross3` d (Right ())+ where+ d = untrie (derivative v)++ -- vector3F :: Three (Vector2 R :> R) -> Vector2 R :> Vector3 R+ -- vector3F (u,v,w) = liftA3 Vector3 u v w++ -- unvector3F :: Vector2 R :> Vector3 R -> Three (Vector2 R :> R)+ -- unvector3F d = (vector3x <$> d, vector3y <$> d, vector3z <$> d)+++cross3X :: (Vector2 R :> Vector3 R) -> (Vector2 R :> Vector3 R) -> Vector2 R :> Vector3 R+cross3X = distrib cross3X'++-- when i replaced the recursive cross3X with (^+^), the cross3X per+-- vertex drops from 73 to 1. but the running time stays about the same.++cross3X' :: Vector3 R -> Vector3 R -> Vector3 R+Vector3 ax ay az `cross3X'` Vector3 bx by bz = counter $+ Vector3 (ay * bz - az * by)+ (az * bx - ax * bz)+ (ax * by - ay * bx)+++-- let v = P.torus 1 (1/2) xy+-- ((fmap (\ v -> v ^+^ (0 *^ normal v)) tt)) xy+-- displace (P.torus 1 (1/2)) (\ (_,_) -> 0) -- (stretchH eggcrateH)++--tt = P.torus 1 (1/2)+--tt = \ (u,v) -> (u,v,u*v)+--tt = revolve (const (1,0) ^+^ (1/2) *^ liftA2 (,) cosU sinU)++testH :: HeightField (Vector2 R :> R) -> Geometry3+testH = surfG . hfSurf . stretchH++testH' :: Color c => Image c -> HeightField (Vector2 R :> R) -> Geometry3+testH' im = flip surfG' im . hfSurf . stretchH++stretchH :: Fractional s => HeightField s -> HeightField s+stretchH hf = (/ 5) . hf . (* 5)++ptor :: Color c => Image c -> Geometry3+ptor = surfG' (P.torus 1 (1/2))++groovy :: ImageC+groovy (s,t) =+ rgba (sinU (3*s+5*t)) (cosU (5*t-3*s)) (sinU (3*s+5*t)) ((1+sinU (5*s*t) / 2))++redTorus, greenCyl :: Geometry3+redTorus = colorG red $ torus 1 (1/2)+greenCyl = colorG green $ cylinder (1/3) 3+++{-# NOINLINE counterVar #-}+counterVar :: IORef Int+counterVar = unsafePerformIO $ newIORef 0++{-# NOINLINE counter #-}+counter :: a -> a+counter a = unsafePerformIO $ do+ val <- readIORef counterVar+ writeIORef counterVar $! succ val+ return $ a
+ examples/src/Tablet.hs view
@@ -0,0 +1,105 @@+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Tablet+-- Copyright : (c) Conal Elliott and Andy J Gill 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net, andygill@ku.edu+-- Stability : experimental+-- +-- Tablet shape with rounded corners+----------------------------------------------------------------------++module Tablet where++import Data.Monoid++import Graphics.FieldTrip.Misc+import Graphics.FieldTrip.Vector3+import Graphics.FieldTrip.Transform+import Graphics.FieldTrip.Transform2+import Graphics.FieldTrip.Geometry2+import Graphics.FieldTrip.Geometry3++--import Graphics.FieldTrip.QParamSurf as Q++-- 2D rectangle with rounded corners, having given width, height, and+-- rounding radius.+roundedRect :: R -> R -> R -> Geometry2+roundedRect width height radius = right `sandwich2` center+ -- Build out of left, center, right.+ -- The sides sandwich the center to make the whole; and+ -- the quarter-disks sandwich the edge strip to make the right side.+ where+ -- Trimmed dimensions+ width' = width-2*radius+ height' = height-2*radius+ center = box2 width' height+ -- Quarter-disk at origin, angle ranges from 0 to pi/2 (3pm to noon)+ qdisk = uscale2 radius *% diskWedge (1/4)+ ne = move2Y (height'/2) qdisk+ se = move2Y (-height'/2) (rotate2 (-pi/2::Float) *% qdisk)+ right = move2X (width'/2) $+ ne `mappend` move2X (radius/2) (box2 radius height') `mappend` se++-- Sandwich @inside@ between @outside@ and a flipped version of @outside@+sandwich2 :: Geometry2 -> Filter2+outside `sandwich2` inside = andFlip2 outside `mappend` inside++++-- 3D tablet shape, with flat top & bottom, using roundedRect.+-- Cylinders for the four corners.++tablet1 :: R -> R -> R -> R -> Geometry3+tablet1 width height depth radius = top `sandwichY` edging+ where+ width' = width-2*radius+ height' = height-2*radius+ top = move3Z (depth/2) $ flatG (roundedRect width height radius)+ edging = andFlip3 (zVector3::Vector3 Float) ell+ ell = capped height' (width'/2) `mappend`+ pivot3Z (capped width' (height'/2))+ capped len dx = ( move3X (dx+radius) $+ pivot3Y $+ flatG (box2 depth len) )+ `mappend`+ ( move3 dx (len/2) 0 $+ cylinder radius depth )++-- Or with more rounding.+-- 3D tablet with half-cylinders for sides and quarter-sphere corners,+-- having given width, height, and depth. Rounding radius is depth/2.+tablet2 :: R -> R -> R -> Geometry3+tablet2 width height depth = ell `sandwichZ` center+ -- Build out of two ell shapes sandwiching a center box. Each ell has+ -- two cylinders and two spheres. I can't yet make partial spheres or+ -- cylinders, so I'll make full ones, which will be partly hidden (half+ -- of each cylinder and 3/4 of each sphere). Later, make the partial+ -- versions, to reduce computing and rendering.+ where+ radius = depth/2+ width' = width-2*radius+ height' = height-2*radius+ center = box3 width' height' depth+ right = move3X (width'/2) $+ move3Y (height'/2) (sphere radius) `sandwichX` rightCyl+ ell = move3Y (height'/2) topCyl `mappend` right+ rightCyl = cyl xVector3 height'+ topCyl = cyl yVector3 width'+ cyl :: Vector3 Float -> R -> Geometry3+ cyl axis len = pivot3 axis $ cylinder radius len+++---- utilities++-- Sandwich @inside@ between @outside@ and a flipped version of @outside@+sandwich3 :: Vector3 Float -> Geometry3 -> Filter3+sandwich3 axis outside inside = andFlip3 axis outside `mappend` inside++-- Specializations+sandwichX, sandwichY, sandwichZ :: Geometry3 -> Filter3+sandwichX = sandwich3 xVector3+sandwichY = sandwich3 yVector3+sandwichZ = sandwich3 zVector3
+ examples/src/Test.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE TypeOperators #-}+-- {-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Test+-- Copyright : (c) Andy J Gill and Conal Elliott 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Tablet shape with rounded corners+----------------------------------------------------------------------++module Main where++import Data.Monoid+import Control.Applicative++import Graphics.Rendering.OpenGL (Color)+import Graphics.FieldTrip.Glut ++import Data.VectorSpace+import Data.Derivative ((:>))++import Graphics.FieldTrip.Misc+import Graphics.FieldTrip.Geometry2+import Graphics.FieldTrip.Geometry3+import Graphics.FieldTrip.Transform+import Graphics.FieldTrip.Transform3+import Graphics.FieldTrip.Vector2+import Graphics.FieldTrip.Vector3+import Graphics.FieldTrip.Color+import Graphics.FieldTrip.Material+import Graphics.FieldTrip.Image+import Graphics.FieldTrip.Render+import qualified Graphics.FieldTrip.ParamSurf as P+import Graphics.FieldTrip.ParamSurf hiding (torus)++import Graphics.Formats++-- These next two aren't yet release openly.++-- import Graphics.Formats.Obj+-- import Codec.Image.DevIL++import System.IO.Unsafe++-- import Data.Behavior+import FRP.Reactive.Reactive++import FRP.Reactive.Internal.Misc (Sink)++-- import Tablet++main :: IO ()+main =+ do -- ilInit+ anim3 $ spinningG $+ -- flatG ubox2+ -- uscale3 (3::R) *% (sphere 0.3 `mappend` flatG ubox2)+ -- cube+ -- flatG $ uscale2 (0.5::R) *% diskWedge (1/3)+ -- flatG $ roundedRect 2 3 (1/2)+ -- pivot3 (xVector3::Vector3 R) $ cylinder (1/2) 2+ -- tablet1 2 3 (1/2) (1/4)+ -- tablet2 2 3 (1/2)+ -- cone 1 1+ -- redTorus `mappend` greenCyl+ torusPair+ -- ptor (rings . (50 *^))+ -- ptor (checker . (50 *^))+ -- ptor groovy+ -- testH' groovy eggcrateH+ -- testH rippleH+ -- when testing the next two, increase gcErr (below) to 0.05+ -- torusCrate+ -- torusCrate'+ -- loadObj "Astin DB9.obj"++-- loadObj :: String -> Geometry3+-- loadObj x =+-- renderableG obj+-- where+-- obj = unsafePerformIO+-- $ objFromFile ("examples/" ++ x) ["examples/"]++plasmat :: Col -> Filter3+plasmat col = materialG (plastic col)++torusCrate, torusCrate' :: Geometry3+torusCrate = plasmat yellow $ surfG $+ displace (P.torus 1 (1/2)) (stretchH eggcrateH)++torusCrate' = flip surfG' groovy $+ displace (P.torus 1 (1/2)) (stretchH eggcrateH)++testH :: HeightField (Vector2 R :> R) -> Geometry3+testH = surfG . hfSurf . stretchH++testH' :: Color c => Image c -> HeightField (Vector2 R :> R) -> Geometry3+testH' im = flip surfG' im . hfSurf . stretchH++stretchH :: Fractional s => HeightField s -> HeightField s+stretchH hf = (/ 10) . hf . (* 10)++ptor :: Color c => Image c -> Geometry3+ptor = surfG' (P.torus 1 (1/2))++groovy :: ImageC+groovy (s,t) =+ rgba (sinU (3*s+5*t)) (cosU (5*t-3*s)) (sinU (3*s+5*t)) ((1+sinU (5*s*t) / 2))++redTorus, greenCyl :: Geometry3+redTorus = plasmat red $ torus 1 (1/2)+greenCyl = plasmat green $ cylinder (1/3) 3++torusPair :: Geometry3+torusPair = f red (1/2) `mappend` pivot3X (f green (-1/2))+ where+ tor = torus 1 (2/5)+ f :: Col -> R -> Geometry3+ f col dx = plasmat col (move3X dx tor)++spinningG :: Geometry3 -> Anim Geometry3+spinningG g env = liftA2 (*%) (spinning env) (pure g)++spinning :: Anim (Transform3 Double)+spinning env = (f . (*1)) <$> timeR env+ where+ f t = translate3 (Vector3 (0::Double) 0 (3*sin (-t/5)))+ `mappend` rotate3 t (Vector3 0.1 0.2 0.3)+ `mappend` scale3 0.2 0.2 0.2++{-++-- This reads mouse clicks, and +withClick :: GlutEvents -> Behavior Double+withClick events = timeB+{-+fmap (\ (a,b) -> b)+ $ snapshot mouseEvents timeB+-}+ where+ mouseEvents :: Event Bool+ mouseEvents = fmap (\ (_,x,_,_) ->+ case x of+ Up -> False+ Down -> True)+ $ filterMP (\ (key,state,mods,pos) ->+ case (key,state) of+ (MouseButton _,Down) -> True+ _ -> False) + (keyboardMouseEvent events)++-}++view :: Filter3+view = move3Z (-3 :: R)++animate :: Sink a -> Sink (Anim a)+animate f anim = runWithGlut ((fmap.fmap) f anim)++anim2 :: Sink (Anim Geometry2)+anim2 = animate render2++anim3 :: Sink (Anim Geometry3)+anim3 = animate (renderWith3 gc . view)+ where+ gc = defaultGC { gcErr = 0.01 }+++-- Later:++-- type Anim a = GlutEvents -> Behavior a
+ src/Graphics/FieldTrip.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.FieldTrip+-- Copyright : (c) Conal Elliott 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- A functional library for 3D graphics+----------------------------------------------------------------------++module Graphics.FieldTrip+ ( module Graphics.FieldTrip.Misc+ , module Graphics.FieldTrip.Vector2+ , module Graphics.FieldTrip.Vector3+ , module Graphics.FieldTrip.Point2+ , module Graphics.FieldTrip.Point3+ , module Graphics.FieldTrip.Normal3+ , module Graphics.FieldTrip.Transform+ , module Graphics.FieldTrip.Transform2+ , module Graphics.FieldTrip.Transform3+ , module Graphics.FieldTrip.Color+ , module Graphics.FieldTrip.Material+ , module Graphics.FieldTrip.Render+ , module Graphics.FieldTrip.ParamSurf+ , module Graphics.FieldTrip.Image+ , module Graphics.FieldTrip.Geometry2+ , module Graphics.FieldTrip.Geometry3+ ) where++import Graphics.FieldTrip.Misc+import Graphics.FieldTrip.Vector2+import Graphics.FieldTrip.Vector3+import Graphics.FieldTrip.Point2+import Graphics.FieldTrip.Point3+import Graphics.FieldTrip.Normal3+import Graphics.FieldTrip.Transform+import Graphics.FieldTrip.Transform2+import Graphics.FieldTrip.Transform3+import Graphics.FieldTrip.Color+import Graphics.FieldTrip.Material+import Graphics.FieldTrip.Render+import Graphics.FieldTrip.ParamSurf hiding (frustrum,torus)+import Graphics.FieldTrip.Image+import Graphics.FieldTrip.Geometry2+import Graphics.FieldTrip.Geometry3
+ src/Graphics/FieldTrip/Color.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses+ , UndecidableInstances, TypeSynonymInstances+ #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -- Color4++----------------------------------------------------------------------+-- |+-- Module : Graphics.FieldTrip.Color+-- Copyright : (c) Conal Elliott 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Color helpers+----------------------------------------------------------------------++module Graphics.FieldTrip.Color+ (+ Col, rgb, rgba, rgb255+ , transparent, black, white, red, green, blue, yellow, purple+ , HasColor(..)+ , VC(..)+ , overC, overPre, overNon+ ) where++import Graphics.Rendering.OpenGL++import Data.VectorSpace+import Graphics.FieldTrip.Misc+++-- | Our color type (with alpha)+type Col = Color4 R++rgba :: s -> s -> s -> s -> Color4 s+rgba = Color4++rgb :: Num s => s -> s -> s -> Color4 s+rgb r g b = Color4 r g b 1+++grey :: Num s => s -> Color4 s+grey x = rgb x x x++transparent, black, white,+ red, green, blue,+ yellow, purple :: Fractional s => Color4 s++transparent = rgba 0 0 0 0++white = grey 1+black = grey 0++red = rgb 1 0 0+green = rgb 0 1 0+blue = rgb 0 0 1++yellow = rgb 1 1 0++purple = rgb255 160 32 240++rgb255 :: Fractional s => s -> s -> s -> Color4 s+rgb255 r g b = rgb (byte r) (byte g) (byte b)++byte :: Fractional s => s -> s+byte = (/ 255)++class HasColor c where toColor :: c -> Col++instance HasColor Bool where+ toColor True = white+ toColor False = transparent++instance HasColor Float where toColor = grey++instance Color Bool where+ color = color . toColor+ colorv = error "colorv: not defined on Bool"+instance Color R where+ color = color . toColor+ colorv = error "colorv: not defined on R"++-- instance HasColor Double where toColor = grey+-- instance Color Double where color = color . toColor+++-- Experiment. See also Graphics.FieldTrip.Vertex++-- | Vertex and color+data VC v c = VC !v !c++instance (Vertex v, Color c) => Vertex (VC v c)+ where+ vertex (VC v c) = color c >> vertex v+ vertexv = error "vertexv: undefined on VC"+++-- UndecidableInstances because "the Coverage Condition fails" below++instance AdditiveGroup u => AdditiveGroup (Color4 u) where+ zeroV = Color4 zeroV zeroV zeroV zeroV+ Color4 r g b a ^+^ Color4 r' g' b' a'+ = Color4 (r^+^r') (g^+^g') (b^+^b') (a^+^a')+ negateV (Color4 r g b a)+ = Color4 (negateV r) (negateV g) (negateV b) (negateV a)++instance VectorSpace u s => VectorSpace (Color4 u) s where+ s *^ (Color4 r g b a)+ = Color4 (s*^r) (s*^g) (s*^b) (s*^a)++instance (InnerSpace r s, VectorSpace s s')+ => InnerSpace (Color4 r) s where+ Color4 r g b a <.> Color4 r' g' b' a' =+ r<.>r' ^+^ g<.>g' ^+^ b<.>b' ^+^ a<.>a'++instance Functor Color4 where+ fmap f (Color4 r g b a) = Color4 (f r) (f g) (f b) (f a)++-- instance Applicative Color4 where+-- pure = grey+-- Color4 f h k l <*> Color4 r g b a = Color4 (f r) (h g) (k b) (l a)++-- I don't know how to define 'pure' above without requiring Num on the+-- parameter, which then breaks the required unrestricted polymorphism.++++-- Do OpenGL colors have pre-multiplied alpha? If so, color overlay is+-- simple.++-- | Overlay (alpha-blend) first color onto the second, accounting for+-- transparency+overC :: Fractional s => Color4 s -> Color4 s -> Color4 s+overC = overPre++-- The definition depends on whether we're using pre-multiplied or+-- non-premultiplied alpha in the Color4 representation. I don't know+-- which.+overPre, overNon :: Fractional s => Binop (Color4 s)++Color4 r g b a `overPre` Color4 r' g' b' a' =+ Color4 (r // r') (g // g') (b // b') (a // a')+ where+ top // bot = top + (1-a) * bot++Color4 r g b a `overNon` Color4 r' g' b' a' =+ Color4 (r // r') (g // g') (b // b') ao+ where+ top // bot = ((top*a) `pre` (bot*a')) / ao+ ao = a `pre` a'+ top `pre` bot = top + (1-a) * bot
+ src/Graphics/FieldTrip/Geometry2.hs view
@@ -0,0 +1,225 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.FieldTrip.Geometry2+-- Copyright : (c) Conal Elliott and Andy J Gill 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net, andygill@ku.edu+-- Stability : experimental+-- +-- 2D geometry+----------------------------------------------------------------------++module Graphics.FieldTrip.Geometry2+ (+ Geometry2, renderer2, renderWith2, render2+ , ubox2, box2+ , approx2, udisk, polygon, regularPolygon+ , diskWedge, regularPolygonWedge+ -- * Text+ , utext, utextWidth, utextBaseline+ -- * Geometry2 filters+ , Filter2, move2, move2X, move2Y, andFlip2+ ) where++import Data.Monoid+import Control.Applicative+import System.IO.Unsafe( unsafePerformIO )++import Graphics.UI.GLUT++import Graphics.FieldTrip.Misc+import Graphics.FieldTrip.Point2+import Graphics.FieldTrip.Transform+import Graphics.FieldTrip.Transform2+import Graphics.FieldTrip.Render+import Graphics.FieldTrip.Material++-- | 2D geometry+-- In the 'Monoid' instance, 'mempty' is completely invisible (aka+-- transparent or empty), and @a 'mappend' b@ places @a@ on top of @b@.++newtype Geometry2 = Renderer2 { unRenderer2 :: Renderer }++-- TODO: consider expanding Geometry2 with more constructors, as in+-- Geometry3, e.g., +-- +-- -- | 2D geometry+-- data Geometry2+-- = EmptyG+-- | OverG Geometry2 Geometry2+-- | forall s. (Floating s, Real s, MatrixComponent s) =>+-- TransformG (Transform2 s) Geometry2+-- | RenderG Renderer+-- -- temporary:+-- | ColorG ColorTrans Geometry2+++inRenderer2 :: (Renderer -> Renderer)+ -> (Geometry2 -> Geometry2)+inRenderer2 f = Renderer2 . f . unRenderer2++inRenderer22 :: (Renderer -> Renderer -> Renderer)+ -> (Geometry2 -> Geometry2 -> Geometry2)+inRenderer22 f = inRenderer2 . f . unRenderer2++instance Monoid Geometry2 where+ mempty = Renderer2 (pure (return ()))+ mappend = inRenderer22 (liftA2 (>>))++-- | Make a geometry from a rendering action. The action must leave graphics+-- state as it found it.+renderer2 :: Renderer -> Geometry2+renderer2 = Renderer2++-- | Render the geometry, given a graphics context. Leaves graphics state unchanged.+renderWith2 :: GContext -> Geometry2 -> IO ()+renderWith2 = flip unRenderer2++-- | Render the geometry with default graphics context. See also 'renderWith2'.+render2 :: Geometry2 -> IO ()+render2 = renderWith2 defaultGC++instance (Floating s, Real s, MatrixComponent s) =>+ Transform (Transform2 s) Geometry2 where+ xf *% im = Renderer2 $ \ gc ->+ preservingMatrix $ do+ tweakMatrix2 xf+ renderWith2 (onErr (tweakError2 xf) gc) im+++-- | Box2 of given @width@ and @height@. See also 'ubox2.+box2 :: (Real s, Floating s, MatrixComponent s) => s -> s -> Geometry2+box2 width height = scale2 width height *% ubox2++-- | Box2 of unit @width@ and @height@. See also 'box2.+ubox2 :: Geometry2+ubox2 = polygon [Vertex2 p p, Vertex2 p m, Vertex2 m m, Vertex2 m p]+ where+ p,m :: Float+ p = 1/2+ m = -p++-- | Approximate one geometry by another, given an error bound+approx2 :: (ErrorBound -> Geometry2) -> Geometry2+approx2 f = Renderer2 $ \ gc -> renderWith2 gc (f (gcErr gc))++-- | The unit disk, approximated as regular n-gons+udisk :: Geometry2+udisk = approx2 $ regularPolygon . max 3 . round . recip++-- | Portion of a disk+diskWedge :: R -> Geometry2+diskWedge frac =+ approx2 $ regularPolygonWedge frac . max 3 . round . (frac /)++-- | A polygon+polygon :: VertexComponent s => [Vertex2 s] -> Geometry2+polygon vs =+ renderer2 (\(GC _ mTrans _) -> do material (mTrans defaultMat)+ renderPrimitive Polygon (mapM_ vertex vs))++-- | Regular polygon+regularPolygon :: Int -> Geometry2+regularPolygon sides+ | sides < 3 = error "regularPolygon must have at least three sides"+ | otherwise = polygon points+ where+ points :: [Point2 Float]+ points = [ point2Polar 1 (fromIntegral i * theta)+ | i <- [sides,sides-1 .. 1]]+ theta = 2*pi / fromIntegral sides++-- | Regular polygon wedge. Oops! only works for frac <= 1/2, since+-- otherwise the polygon is non-convex.+regularPolygonWedge :: forall s. (Ord s, Floating s, VertexComponent s) =>+ s -> Int -> Geometry2+regularPolygonWedge frac sides+ | sides < 1 = error "regularPolygonWedge must have at least one side"+ | frac > 1/2 = error "regularPolygonWedge: requires frac <= 1/2 for now."+ | otherwise = renderer2 $ const $+ renderPrimitive Polygon $+ do verts+ vertex (point2 0 0 :: Point2 s)+ where+ verts :: IO ()+ verts = sequence_ [ v (fromIntegral i * theta)+ | i <- [sides,sides-1 .. 0]]+ p :: s -> Point2 s+ p = point2Polar 1+ v :: s -> IO ()+ v = vertex . p+ theta :: s+ theta = frac * (2*pi / fromIntegral sides)++-- TODO: refactor regularPolygon & regularPolygonWedge, and disk & wedge.++-- TODO: verify counter-clockwise order. might not be what GL expects.+++{--------------------------------------------------------------------+ Text+--------------------------------------------------------------------}++-- Utility function for allowing material transformations for when lifted to+-- 3d geometry.+withDefaultMat :: IO () -> Geometry2+withDefaultMat x =+ renderer2 (\(GC _ mTrans _) -> material (mTrans defaultMat) >> x)++-- TODO: I think withDefaultMat leaves the graphics state changed, thus+-- breaking composability. - Conal++glText :: String -> Geometry2+glText = withDefaultMat . preservingMatrix . renderString Roman++glAboveBaseline, glBelowBaseline :: Double+glAboveBaseline = 119.05+glBelowBaseline = 33.33++glTextWidth :: String -> Double+glTextWidth = fromIntegral . unsafePerformIO . stringWidth Roman++-- | The passed string of text centered at the origin with height 1.0+utext :: String -> Geometry2+utext s = (m . sc . glText) s+ where+ h = glAboveBaseline + glBelowBaseline+ z = glBelowBaseline / h+ m = move2 (-utextWidth s/2) (-0.5 + z)+ sc = (*%) (uscale2 (1.0/h))++-- | The width of the geometry of utext of that string.+utextWidth :: String -> Double+utextWidth = flip (/) (glAboveBaseline+glBelowBaseline) . glTextWidth++-- | The height of the baseline of geometry created by utext. This can be+-- used for underlining, for example.+utextBaseline :: Double+utextBaseline = glBelowBaseline/(glAboveBaseline+glBelowBaseline) - 0.5++++{--------------------------------------------------------------------+ Filters+--------------------------------------------------------------------}++-- | Geometry2 filter+type Filter2 = Geometry2 -> Geometry2++-- | Simplified interface to 'translate2'+move2 :: (MatrixComponent s, Real s, Floating s) =>+ s -> s -> Filter2+move2 dx dy = (translate2 (Vector2 dx dy) *%)++-- | Specializations of 'move2'+move2X, move2Y :: (MatrixComponent s, Real s, Floating s) =>+ s -> Filter2+move2X dx = move2 dx 0+move2Y dy = move2 0 dy++-- | A geometry plus its a rotated-by-pi version.+andFlip2 :: Filter2+andFlip2 im = im `mappend` (rotate2 (pi :: Float) *% im)
+ src/Graphics/FieldTrip/Geometry3.hs view
@@ -0,0 +1,393 @@+{-# 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)
+ src/Graphics/FieldTrip/Image.hs view
@@ -0,0 +1,46 @@+----------------------------------------------------------------------+-- |+-- Module : Graphics.FieldTrip.Image+-- Copyright : (c) Conal Elliott 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- 2D imagery+----------------------------------------------------------------------++module Graphics.FieldTrip.Image where++import Data.Function (on)+import Control.Applicative++-- import Graphics.Rendering.OpenGL (Color4)++import Data.VectorSpace+import Graphics.FieldTrip.Misc+import Graphics.FieldTrip.Color++-- These types can be generalized to other scalar types, at the cost of+-- lots of type constraints.++type Image o = (R,R) -> o++type ImageC = Image Col+type Region = Image Bool++over :: Binop ImageC+over = liftA2 overC++smallFrac :: R -> Bool+smallFrac = (< 1/2) . fracPart++rings :: Region+rings = smallFrac . magnitude++checker :: Region+-- checker (x,y) = smallFrac x == smallFrac y++checker = uncurry ((==) `on` smallFrac)++-- TODO:
+ src/Graphics/FieldTrip/Material.hs view
@@ -0,0 +1,78 @@+{-# OPTIONS_GHC -Wall #-}+module Graphics.FieldTrip.Material+ ( Material(..)+ , setAmbient , setDiffuse , setSpecular , setEmission , setShininess+ , plastic, flat+ , defaultMat, bluePlastic++ , material+ ) where++import Graphics.Rendering.OpenGL+import Graphics.FieldTrip.Misc+import Graphics.FieldTrip.Color++data Material = Mat+ { ambientM :: Col+ , diffuseM :: Col+ , specularM :: Col+ , emissionM :: Col+ , shininessM :: R -- Between 0 and 1+ } deriving Show++defaultMat :: Material+defaultMat = Mat { ambientM = rgba 0.2 0.2 0.2 1.0+ , diffuseM = rgba 0.8 0.8 0.8 1.0+ , specularM = rgba 0.0 0.0 0.0 1.0+ , emissionM = rgba 0.0 0.0 0.0 1.0+ , shininessM = 0+ }++setAmbient :: Col -> Material -> Material+setAmbient c m = m{ ambientM=c }++setDiffuse :: Col -> Material -> Material+setDiffuse c m = m{ diffuseM=c }++setSpecular :: Col -> Material -> Material+setSpecular c m = m{ specularM=c }++setEmission :: Col -> Material -> Material+setEmission c m = m{ emissionM=c }++setShininess :: R -> Material -> Material+setShininess c m = m{ shininessM=c }++polishedPlastic :: Material-> Material+polishedPlastic = \m -> m { specularM = (rgba 1.0 1.0 1.0 1.0)+ , emissionM = (rgba 0.0 0.0 0.0 1.0)+ , shininessM = (70.0/128.0)+ }++-- Alternate defn.+-- polishedPlastic = setSpecular (rgba 1.0 1.0 1.0 1.0)+-- . setEmission (rgba 0.0 0.0 0.0 1.0)+-- . setShininess (70.0/128.0)+--+-- What do we like better, point free or clear nonsequentiality?++setAmbDiff :: Col -> Material -> Material+setAmbDiff c = \m -> m { ambientM = c+ , diffuseM = c+ }++bluePlastic :: Material+bluePlastic = plastic blue++plastic :: Col -> Material+plastic = polishedPlastic . flat++flat :: Col -> Material+flat = flip setAmbDiff defaultMat++material :: Material -> IO()+material m = do materialAmbient Front $= ambientM m+ materialDiffuse Front $= diffuseM m+ materialSpecular Front $= specularM m+ materialEmission Front $= emissionM m+ materialShininess Front $= (shininessM m)*128.0
+ src/Graphics/FieldTrip/Misc.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE ScopedTypeVariables #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.FieldTrip.Misc+-- Copyright : (c) Conal Elliott 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Miscellany for FieldTrip graphics+----------------------------------------------------------------------++module Graphics.FieldTrip.Misc+ (+ R, fracPart, Unop, Binop, logMemo+ ) where++import Data.MemoTrie++-- | Values commonly used for coordinates, coefficients, etc.+type R = Float++-- | Fractional portion, @x - floor x@+fracPart :: R -> R+fracPart x = x - fromIntegral (floor x :: Int)++-- | Unary operations+type Unop a = a -> a++-- | Binary operations+type Binop a = a -> a -> a++-- | Memoize an approximation to a given function, discretizing its domain+-- by scaling. An input @x@ discretizes into @round (logBase base x)@.+logMemo :: forall s a. (Floating s, RealFrac s) => s -> (s->a) -> (s->a)+logMemo base f = memo (f . unapprox) . approx+ where+ approx :: s -> Int+ approx = round . logBase base+ unapprox :: Int -> s+ unapprox = (base **) . fromIntegral
+ src/Graphics/FieldTrip/Normal3.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE BangPatterns, TypeOperators, ScopedTypeVariables+ , TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses+ #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.FieldTrip.Normal3+-- Copyright : (c) Conal Elliott 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Normals and Vertex/normal pairs+----------------------------------------------------------------------++module Graphics.FieldTrip.Normal3+ (+ VN(..), VN3, vectorToNormal3+ ) where++import Graphics.Rendering.OpenGL hiding (normal)+import qualified Graphics.Rendering.OpenGL as G++import Graphics.FieldTrip.Point3+import Graphics.FieldTrip.Vector3+++-- What do I want here? For displacement mapping, I'll need 'normal' to+-- compute a tower. For shading, I'll use the value part of the normal+-- and ignore the rest.++-- It probably makes more sense to have 'Cross' be the class. Define+-- @normal = normalized . cross@. What are some 'Cross' instances?+-- Instead of a pair of 3-vectors, start with a @V2 s :> V3 s@ and a @s :>+-- V2 s@.++-- Hm. I'll want to use tuples for parametric surfaces but vectors for+-- rendering. Do I *really* want OpenGL vectors instead of tuples?+-- Tuples would get converted to OpenGL vectors, vertices, and normals in+-- IO generation anyway.++-- | Treat a vector as a normal+vectorToNormal3 :: Vector3 s -> Normal3 s+vectorToNormal3 (Vector3 x y z) = Normal3 x y z++-- | Vertex and normal+data VN v n = VN !v !n++instance (Vertex v, Normal n) => Vertex (VN v n)+ where+ vertex (VN v n) = G.normal n >> vertex v+ vertexv = error "vertexv: undefined on VN"++-- | 3D vertex/normal pair+type VN3 s = VN (Point3 s) (Normal3 s)
+ src/Graphics/FieldTrip/ParamSurf.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE Rank2Types, TypeOperators, FlexibleContexts #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.FieldTrip.ParamSurf+-- Copyright : (c) Conal Elliott 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Parametric surfaces with automatic normals+----------------------------------------------------------------------++module Graphics.FieldTrip.ParamSurf where++import Control.Applicative++import Data.NumInstances ()+import Data.VectorSpace+import Data.Cross+++type HeightField s = Two s -> One s+type Surf s = Two s -> Three s++type USurf = forall s. Floating s => Surf s+++type Curve2 s = One s -> Two s+type Curve3 s = One s -> Three s++type Warp1 s = One s -> One s+type Warp2 s = Two s -> Two s+type Warp3 s = Three s -> Three s++mul2pi :: Floating s => s -> s+mul2pi = (* (2*pi))++-- | Trig functions with unit period ([-1/2,1/2])+cosU, sinU :: Floating s => s -> s+cosU = cos . mul2pi+sinU = sin . mul2pi+++-- | Turn a height field into a surface+hfSurf :: HeightField s -> Surf s+hfSurf field = \ (u,v) -> (u, v, field (u,v))++-- | Like 'hfSurf' but for curve construction+fcurve :: Warp1 s -> Curve2 s+fcurve f = \ u -> (u, f u)++-- | Unit circle.+circle :: Floating s => Curve2 s+circle = liftA2 (,) cosU sinU++-- | Half semi circle, with theta in [-pi/2,pi/2]+semiCircle :: Floating s => Curve2 s+semiCircle = circle . (/ 2)++-- | Torus, given radius of sweep circle and cross section+torus :: (Floating s, VectorSpace s s) => s -> s -> Surf s+-- torus sr cr = revolve (\ s -> (sr,0) ^+^ cr *^ circle s)+torus sr cr = revolve (const (sr,0) ^+^ cr *^ circle)++-- Surface of revolution, formed by rotation around Z axis. The curve is+-- parameterized by u, and the rotation by v. In this generalized+-- version, we have not a single curve, but a function from v to curves.+revolveG :: Floating s => (s -> Curve2 s) -> Surf s+revolveG curveF = \ (u,v) -> onXY (rotate (-2*pi*v)) (addY (curveF v) u)++revolve :: Floating s => Curve2 s -> Surf s+revolve curve = revolveG (const curve)++-- A sphere is a revolved semi-circle+sphere1 :: Floating s => Surf s+sphere1 = revolve semiCircle+++-- | Profile product.+profile :: Num s => Curve2 s -> Curve2 s -> Surf s+profile curve prof (u,v) = (cx*px,cy*px,py)+ where+ (cx,cy) = curve u+ (px,py) = prof v++-- More spheres+sphere2,sphere3 :: Floating s => Surf s+sphere2 = profile circle semiCircle+sphere3 = profile semiCircle circle++-- | Frustrum, given base & cap radii and height.+frustrum :: (Floating s, VectorSpace s s) => s -> s -> s -> Surf s+frustrum baseR topR h = profile circle rad+ where+ rad t = (lerp baseR topR (t + 1/2), h*t)++-- | Unit cylinder. Unit height and radii+ucylinder :: (Floating s, VectorSpace s s) => Surf s+ucylinder = profile circle (const 1)+++-- | Given a combining op and two curves, make a surface. A sort of+-- Cartesian product with combination.+cartF :: (a -> b -> c) -> (u -> a) -> (v -> b) -> ((u,v) -> c)+cartF op f g = \ (u,v) -> f u `op` g v++-- Sweep a basis curve by a sweep curve. Warning: does not reorient the+-- basis curve as cross-section. TODO: Frenet frame.+sweep :: VectorSpace s s' => Curve3 s -> Curve3 s -> Surf s+sweep = cartF (^+^)+++-- | One period, unit height eggcrate+eggcrateH :: Floating s => HeightField s+eggcrateH = cartF (*) cosU sinU++revolveH :: (Floating s, InnerSpace s s) => Warp1 s -> HeightField s+revolveH = (. magnitude)++rippleH :: (Floating s, InnerSpace s s) => HeightField s+rippleH = revolveH sinU++-- | Simple ripply pond shape+ripple :: Floating s => Surf s+ripple = -- onXY' (2 *^) $+ revolve (const (0.5,0) - fcurve sinU)++-- | Apply a displacement map at a value++displaceV :: (InnerSpace v s, Floating s, HasNormal v) =>+ v -> s -> v+displaceV v s = v ^+^ s *^ normal v++-- | Apply a displacement map to a function (e.g., 'Curve2' or 'Surf') or+-- other container.+displace :: (InnerSpace v s, Floating s, HasNormal v, Applicative f) =>+ f v -> f s -> f v+displace = liftA2 displaceV++++---- Misc++rotate :: Floating s => s -> Warp2 s+rotate theta = \ (x,y) -> (x * c - y * s, y * c + x * s)+ where c = cos theta+ s = sin theta++addX, addY, addZ :: Num s => (a -> Two s) -> (a -> Three s)+addX = fmap (\ (y,z) -> (0,y,z))+addY = fmap (\ (x,z) -> (x,0,z))+addZ = fmap (\ (x,y) -> (x,y,0))++addYZ,addXZ,addXY :: Num s => (a -> One s) -> (a -> Three s)+addYZ = fmap (\ x -> (x,0,0))+addXZ = fmap (\ y -> (0,y,0))+addXY = fmap (\ z -> (0,0,z))++onX,onY,onZ :: Warp1 s -> Warp3 s+onX f (x,y,z) = (f x, y, z)+onY f (x,y,z) = (x, f y, z)+onZ f (x,y,z) = (x, y, f z)++onXY,onYZ,onXZ :: Warp2 s -> Warp3 s+onXY f (x,y,z) = (x',y',z ) where (x',y') = f (x,y)+onXZ f (x,y,z) = (x',y ,z') where (x',z') = f (x,z)+onYZ f (x,y,z) = (x ,y',z') where (y',z') = f (y,z)+++onX',onY',onZ' :: Warp1 s -> (a -> Three s) -> (a -> Three s)+onX' = fmap fmap onX+onY' = fmap fmap onY+onZ' = fmap fmap onZ++onXY',onXZ',onYZ' :: Warp2 s -> (a -> Three s) -> (a -> Three s)+onXY' = fmap fmap onXY+onXZ' = fmap fmap onXZ+onYZ' = fmap fmap onYZ
+ src/Graphics/FieldTrip/Point2.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- Vertex2+----------------------------------------------------------------------+-- |+-- Module : Point3+-- Copyright : (c) Conal Elliott and Andy J Gill 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net, andygill@ku.edu+-- Stability : experimental+-- +-- Points in 3D+----------------------------------------------------------------------++module Graphics.FieldTrip.Point2+ (+ Point2, point2, origin2, Vertex2(..)+ , point2Polar+ , point2PolarCoords+ ) where++import Graphics.Rendering.OpenGL (Vertex2(..))++import Data.VectorSpace+import Data.AffineSpace+import Graphics.FieldTrip.Vector2++-- | Synonym for Vertex2, a 2D point, parameterized over coordinate type.+type Point2 = Vertex2++-- | Construct a 2D point in rectangular coordinates.+point2 :: s -> s -> Vertex2 s+point2 = Vertex2++origin2 :: Num s => Point2 s+origin2 = point2 0 0++-- or substitute zeroV for 0 above to relax Num s to VectorSpace s s++-- -- | 2D point, parameterized over coordinate type.+-- data Point2 s = Point2 !s !s deriving (Eq, Show)++-- UndecidableInstances because "the Coverage Condition fails" below++instance VectorSpace u s => AffineSpace (Vertex2 u) (Vector2 u) s where+ Vertex2 u v .-. Vertex2 u' v' = Vector2 (u ^-^ u') (v ^-^ v')+ Vertex2 u v .+^ Vector2 dx dy = Vertex2 (u ^+^ dx) (v ^+^ dy)++vToP :: Vector2 s -> Point2 s+vToP (Vector2 u v) = Vertex2 u v++pToV :: Point2 s -> Vector2 s+pToV (Vertex2 u v) = Vector2 u v++-- | Vector from polar coordinates. See also 'vectorPolarCoords'.+point2Polar :: Floating s => s -> s -> Point2 s+point2Polar = (fmap.fmap) vToP vector2Polar++-- | Polar coordinates of a point. See also 'point2Polar'.+point2PolarCoords :: (InnerSpace s s, Floating s) => Point2 s -> (s,s)+point2PolarCoords = vector2PolarCoords . pToV
+ src/Graphics/FieldTrip/Point3.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- Vertex3+----------------------------------------------------------------------+-- |+-- Module : Graphics.FieldTrip.Point3+-- Copyright : (c) Conal Elliott and Andy J Gill 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net, andygill@ku.edu+-- Stability : experimental+-- +-- Points in 3D+----------------------------------------------------------------------++module Graphics.FieldTrip.Point3+ (+ Point3, point3, origin3, Vertex3(..)+ , point3Spherical+ , point3SphericalCoords+ ) where++import Graphics.Rendering.OpenGL (Vertex3(..))++import Data.VectorSpace+import Data.AffineSpace+import Graphics.FieldTrip.Vector3++-- | Synonym for Vertex3, a 3D point, parameterized over coordinate type.+type Point3 = Vertex3++-- | Construct a 3D point in rectangular coordinates.+point3 :: s -> s -> s -> Vertex3 s+point3 = Vertex3++origin3 :: Num s => Point3 s+origin3 = point3 0 0 0++-- or substitute zeroV for 0 above to relax Num s to VectorSpace s s++-- -- | 3D point, parameterized over coordinate type.+-- data Point3 s = Point3 !s !s !s deriving (Eq, Show)++-- UndecidableInstances because "the Coverage Condition fails" below++instance VectorSpace u s => AffineSpace (Vertex3 u) (Vector3 u) s where+ Vertex3 u v w .-. Vertex3 u' v' w' = Vector3 (u ^-^ u') (v ^-^ v') (w ^-^ w')+ Vertex3 u v w .+^ Vector3 dx dv dw = Vertex3 (u ^+^ dx) (v ^+^ dv) (w ^+^ dw)++vToP :: Vector3 s -> Point3 s+vToP (Vector3 u v w) = Vertex3 u v w++pToV :: Point3 s -> Vector3 s+pToV (Vertex3 u v w) = Vector3 u v w++-- | Vector from spherical coordinates. See also 'vectorSphericalCoords'.+point3Spherical :: Floating s => s -> s -> s -> Point3 s+point3Spherical = (fmap.fmap.fmap) vToP vector3Spherical++-- | Spherical coordinates of a point. See also 'point3Spherical'.+point3SphericalCoords :: (InnerSpace s s, Floating s) => Point3 s -> (s,s,s)+point3SphericalCoords = vector3SphericalCoords . pToV
+ src/Graphics/FieldTrip/Render.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.FieldTrip.Render+-- Copyright : (c) Conal Elliott 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Misc rendering-related+----------------------------------------------------------------------++module Graphics.FieldTrip.Render+ (+ ErrorBound, MaterialTrans+ , GContext(..), defaultGC, onErr+ , enableNormals+ , Renderer+ ) where+++import Graphics.FieldTrip.Misc (R,Unop)+import Graphics.FieldTrip.Material (Material)+import Graphics.FieldTrip.Color (Col)++-- | For use in dynamically approximating curved surfaces+type ErrorBound = R++-- | A transformation on materials. Accumulated during rendering.+type MaterialTrans = Unop Material++-- | Rendering context for geometry+data GContext = GC { gcErr :: ErrorBound+ , gcMaterialTrans :: MaterialTrans + , gcNormals :: Maybe Col+ }++-- | Default graphics context+defaultGC :: GContext+defaultGC = GC { gcErr = 0.01, gcMaterialTrans = id, gcNormals = Nothing }++-- | Modify the error-bound in a 'GContext'+onErr :: Unop ErrorBound -> Unop GContext+onErr f gc = gc { gcErr = f (gcErr gc) }+++-- | Turn on visible normals.+enableNormals :: Col -> GContext -> GContext+enableNormals col gc = gc { gcNormals = Just col }++-- | renderer+type Renderer = GContext -> IO ()
+ src/Graphics/FieldTrip/Transform.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Transform+-- Copyright : (c) Conal Elliott and Andy J Gill 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net, andygill@ku.edu+-- Stability : experimental+-- +-- General transform class+----------------------------------------------------------------------++module Graphics.FieldTrip.Transform (Transform(..), Invertible(..)) where++import Control.Arrow ((***))+-- import Control.Applicative (liftA2)++infixr 7 *% -- transform application++-- | General transform class+class Transform xf a where+ -- | Transform a value+ (*%) :: xf -> a -> a+++instance (Transform xf a, Transform xf b) => Transform xf (a,b) where+ (*%) xf = (*%) xf *** (*%) xf++-- Alternative definitions:+-- xf *% (a,b) = (xf *% a, xf *% b)+-- (*%) = liftA2 (***) (*%) (*%)++instance (Transform xf a, Transform xf b, Transform xf c)+ => Transform xf (a,b,c) where+ xf *% (a,b,c) = (xf *% a, xf *% b, xf *% c)++instance (Transform xf a, Transform xf b, Transform xf c, Transform xf d)+ => Transform xf (a,b,c,d) where+ xf *% (a,b,c,d) = (xf *% a, xf *% b, xf *% c, xf *% d)++-- | Invertible transformations+class Invertible xf where+ inverse :: xf -> xf++instance (Invertible xf, Transform xf a, Transform xf b)+ => Transform xf (a -> b) where+ xf *% f = (xf *%) . f . (inverse xf *%)+
+ src/Graphics/FieldTrip/Transform2.hs view
@@ -0,0 +1,74 @@+----------------------------------------------------------------------+-- |+-- Module : Transform2+-- Copyright : (c) Conal Elliott and Andy J Gill 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net, andygill@ku.edu+-- Stability : experimental+-- +-- 3D transforms+----------------------------------------------------------------------++module Graphics.FieldTrip.Transform2 + (+ Transform2+ , translate2, rotate2, scale2, uscale2+ , tweakMatrix2, tweakError2+ , toT3+ ) where++import Data.Monoid++import Graphics.Rendering.OpenGL.GL.CoordTrans++import Data.VectorSpace (AdditiveGroup)++import Graphics.FieldTrip.Vector2+import Graphics.FieldTrip.Vector3+import Graphics.FieldTrip.Transform+import Graphics.FieldTrip.Transform3+import Graphics.FieldTrip.Render (ErrorBound)++-- | 3D affine transform+newtype Transform2 s = T2 { toT3 :: Transform3 s }++instance (Fractional s, AdditiveGroup s) => Invertible (Transform2 s) where+ inverse (T2 xf3) = T2 (inverse xf3)++-- | Translation (motion) in 3D+translate2 :: Num s => Vector2 s -> Transform2 s+translate2 (Vector2 dx dy) = T2 (translate3 (Vector3 dx dy 0))++-- | Rotation in 3D, with angle @theta@ in radians.+rotate2 :: Num s => s -> Transform2 s+rotate2 theta = T2 (rotate3 theta zVector3)++-- | Scaling in 3D+scale2 :: Num s => s -> s -> Transform2 s+scale2 sx sy = T2 (scale3 sx sy 1)++-- | Uniform scale in 2D.+uscale2 :: Num s => s -> Transform2 s+uscale2 s = scale2 s s++instance Monoid (Transform2 s) where+ mempty = T2 mempty+ T2 o `mappend` T2 i = T2 (o `mappend` i)++-- TODO: optimize mappend++-- instance Transform (Transform2 s) (Point2 s) where+-- xf *% p = ...++-- instance Transform (Transform2 s) (Vector2 s) where+-- xf *% p = ...++-- | Change the matrix state, according to the given transform.+tweakMatrix2 :: (Floating s, MatrixComponent s) => Transform2 s -> IO ()+tweakMatrix2 = tweakMatrix3 . toT3++-- | Change the required upper error bound, to one that applies before+-- transforming. Hack for now.+tweakError2 :: (Real s, Fractional s) => Transform2 s -> ErrorBound -> ErrorBound+tweakError2 = tweakError3 . toT3
+ src/Graphics/FieldTrip/Transform3.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.FieldTrip.Transform3+-- Copyright : (c) Conal Elliott and Andy J Gill 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net, andygill@ku.edu+-- Stability : experimental+-- +-- 3D transforms+----------------------------------------------------------------------++module Graphics.FieldTrip.Transform3+ (+ Transform3(..)+ , translate3, rotate3, scale3, uscale3+ , tweakMatrix3, tweakError3+ ) where++import Data.Monoid++import Data.VectorSpace (AdditiveGroup,negateV)+import Graphics.Rendering.OpenGL++import Graphics.FieldTrip.Vector3+import Graphics.FieldTrip.Render (ErrorBound)++import Graphics.FieldTrip.Transform++-- | 3D affine transform+data Transform3 s =+ Identity3+ | Translate3 (Vector3 s)+ | Rotate3 s (Vector3 s) -- ^ angle (radians) and axis+ | Scale3 s s s+ | Compose3 (Transform3 s) (Transform3 s) -- outer and inner+ deriving (Eq,Show)++instance (Fractional s, AdditiveGroup s) => Invertible (Transform3 s) where+ inverse Identity3 = Identity3+ inverse (Translate3 v) = Translate3 (negateV v)+ inverse (Rotate3 a axis) = Rotate3 (-a) axis+ inverse (Scale3 r s t) = Scale3 (recip r) (recip s) (recip t)+ inverse (Compose3 outer inner) =+ Compose3 (inverse inner) (inverse outer)++-- | Translation (motion) in 3D+translate3 :: Vector3 s -> Transform3 s+translate3 = Translate3++-- | Rotation in 3D, with angle in radians.+rotate3 :: s -> Vector3 s -> Transform3 s+rotate3 = Rotate3++-- | Scaling in 3D+scale3 :: s -> s -> s -> Transform3 s+scale3 = Scale3++-- | Uniform scale in 3D.+uscale3 :: s -> Transform3 s+uscale3 s = scale3 s s s++instance Monoid (Transform3 s) where+ mempty = Identity3+ mappend = Compose3+++-- TODO: optimize mappend++-- instance Transform (Transform3 s) (Point3 s) where+-- xf *% p = ...++-- instance Transform (Transform3 s) (Vector3 s) where+-- xf *% v = ...++-- instance Transform (Transform3 s) (Normal3 s) where+-- xf *% n = ...+++-- | Change the matrix state, according to the given transform.+tweakMatrix3 :: (Floating s, MatrixComponent s) => Transform3 s -> IO ()+tweakMatrix3 Identity3 = return ()+tweakMatrix3 (Translate3 vec) = translate vec+tweakMatrix3 (Rotate3 r vec ) = rotate (r * (180/pi)) vec+tweakMatrix3 (Scale3 x y z ) = scale x y z+tweakMatrix3 (Compose3 o i) = tweakMatrix3 o >> tweakMatrix3 i++-- Error bounds. Needs to be worked through carefully. My treatment+-- doesn't yet consider the effect of perspective viewing on Translate3,+-- which is considerable.++-- | Change the required upper error bound, to one that applies before+-- transforming. Hack for now.+tweakError3 :: (Real s, Fractional s) => Transform3 s -> ErrorBound -> ErrorBound+tweakError3 (Scale3 x y z ) = (/ toBound (abs x `max` abs y `max` abs z)) -- guess+tweakError3 (Compose3 o i) = tweakError3 o . tweakError3 i+tweakError3 _ = id++toBound :: (Real s, Fractional s) => s -> ErrorBound+toBound = fromRational . toRational
+ src/Graphics/FieldTrip/Vector2.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses+ , UndecidableInstances, TypeOperators, TypeSynonymInstances+ , TypeFamilies+ #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -- Vector2+----------------------------------------------------------------------+-- |+-- Module : Vector2+-- Copyright : (c) Conal Elliott and Andy J Gill 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net, andygill@ku.edu+-- Stability : experimental+-- +-- Vectors in 2D. Uses the OpenGL 'Vector2' type, for convenience and+-- efficiency.+----------------------------------------------------------------------++module Graphics.FieldTrip.Vector2 + (+ Vector2(..), vector2x, vector2y+ , xVector2, yVector2+ , vector2Polar+ , vector2PolarCoords+ , vector2D, unvector2D+ ) where++import Control.Applicative++import Graphics.Rendering.OpenGL.GL.CoordTrans (Vector2(..))++import Data.VectorSpace+import Data.MemoTrie+import Data.Basis+import Data.Derivative+import Data.Cross++-- | The unit vector in the positive X direction.+xVector2 :: Num s => Vector2 s+xVector2 = Vector2 1 0++-- | The unit vector in the positive Y direction.+yVector2 :: Num s => Vector2 s+yVector2 = Vector2 0 1++vector2x, vector2y :: Vector2 s -> s+vector2x (Vector2 x _) = x+vector2y (Vector2 _ y) = y++-- | Vector from polar coordinates. See also 'vector2PolarCoords'.+vector2Polar :: Floating s => s -> s -> Vector2 s+vector2Polar rho theta = Vector2 (rho * cos theta) (rho * sin theta)++-- | Polar coordinates of a vector. See also 'vector2Polar'.+vector2PolarCoords :: (InnerSpace s s, Floating s) => Vector2 s -> (s,s)+vector2PolarCoords v@(Vector2 x y) = (rho, theta)+ where+ rho = magnitude v+ theta = atan (y/x) -- in case (==) is not defined, as in (a:>b)+ -- if x == 0 then 0 else atan (y/x)+++instance Functor Vector2 where+ fmap f (Vector2 x y) = Vector2 (f x) (f y)++instance Applicative Vector2 where+ pure x = Vector2 x x+ Vector2 f g <*> Vector2 x y = Vector2 (f x) (g y)+++-- TODO: is UndecidableInstances still necessary?++instance AdditiveGroup u => AdditiveGroup (Vector2 u) where+ zeroV = Vector2 zeroV zeroV+ Vector2 u v ^+^ Vector2 u' v' = Vector2 (u^+^u') (v^+^v')+ negateV (Vector2 u v) = Vector2 (negateV u) (negateV v)++instance (VectorSpace u s) => VectorSpace (Vector2 u) s where+ s *^ Vector2 u v = Vector2 (s*^u) (s*^v)++instance (InnerSpace u s, AdditiveGroup s)+ => InnerSpace (Vector2 u) s where+ Vector2 u v <.> Vector2 u' v' = u<.>u' ^+^ v<.>v'++instance HasBasis u s => HasBasis (Vector2 u) s where+ type Basis (Vector2 u) = Basis (u,u)+ basisValue = toV2 . basisValue+ decompose = decompose . fromV2+ decompose' = decompose' . fromV2++toV2 :: (u,u) -> Vector2 u+toV2 (u,v) = Vector2 u v++fromV2 :: Vector2 u -> (u,u)+fromV2 (Vector2 u v) = (u,v)+++instance Num s => HasCross2 (Vector2 s) where+ cross2 (Vector2 x y) = Vector2 (-y) x -- or @Vector2 (-y) x@?+++-- instance (Num s, LMapDom s s) => HasNormal (s :> Vector2 s) where+-- normalVec v = cross2 (derivativeAt v 1)++instance HasNormal (Float :> Vector2 Float) where+ normalVec v = cross2 (derivative v `untrie` ())++-- instance HasNormal (One Double :> Two Double) where+-- normalVec v = cross2 (derivative v `untrie` ())++++vector2D :: (HasBasis a s, HasTrie (Basis a), VectorSpace s s) =>+ Two (a :> s) -> a :> (Vector2 s)+vector2D (u,v) = liftD2 Vector2 u v++unvector2D :: (HasBasis a s, HasTrie (Basis a), VectorSpace s s) =>+ a :> (Vector2 s) -> Two (a :> s)+unvector2D d = (vector2x <$>> d, vector2y <$>> d)
+ src/Graphics/FieldTrip/Vector3.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts+ , UndecidableInstances, TypeOperators+ , TypeFamilies, TypeSynonymInstances+ #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+----------------------------------------------------------------------+-- |+-- Module : Vector3+-- Copyright : (c) Conal Elliott and Andy J Gill 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net, andygill@ku.edu+-- Stability : experimental+-- +-- Vectors in 3D. Uses the OpenGL 'Vector3' type, for convenience and+-- efficiency.+----------------------------------------------------------------------++module Graphics.FieldTrip.Vector3 + (+ Vector3(..)+ , xVector3, yVector3, zVector3+ , vector3x, vector3y, vector3z+ , vector3Spherical+ , vector3SphericalCoords+ , vector3D, unvector3D, cross3+ ) where++import Control.Applicative++import Graphics.Rendering.OpenGL (Vector3(..))++import Data.VectorSpace+import Data.MemoTrie+import Data.Basis+import Data.Derivative+import Data.Cross++import Graphics.FieldTrip.Vector2++-- type V3 = Vector3 Double++-- | The unit vector in the positive X direction.+xVector3 :: Num s => Vector3 s+xVector3 = Vector3 1 0 0++-- | The unit vector in the positive Y direction.+yVector3 :: Num s => Vector3 s+yVector3 = Vector3 0 1 0++-- | The unit vector in the positive Z direction.+zVector3 :: Num s => Vector3 s+zVector3 = Vector3 0 0 1++vector3x, vector3y, vector3z :: Vector3 s -> s+vector3x (Vector3 x _ _) = x+vector3y (Vector3 _ y _) = y+vector3z (Vector3 _ _ z) = z++-- vector3RectCoords :: Vector3 -> (R,R,R)+-- vector3RectCoords (Vector3 x y z) = (x,y,z)++-- | Vector from spherical coordinates. See also 'vector2SphericalCoords'.+vector3Spherical :: Floating s => s -> s -> s -> Vector3 s+vector3Spherical rho theta phi =+ Vector3 (rho * sinPhi * cosTheta)+ (rho * sinPhi * sinTheta)+ (rho * cosPhi)+ where+ cosTheta = cos theta; cosPhi = cos phi+ sinTheta = sin theta; sinPhi = sin phi ++-- | Spherical coordinates of a vector. See also 'vector2Spherical'.+vector3SphericalCoords :: (InnerSpace s s, Floating s) => Vector3 s -> (s,s,s)+vector3SphericalCoords v@(Vector3 x y z) = (rho, theta, phi)+ where+ rho = magnitude v+ theta = atan (y/x) -- in case (==) is not defined, as in (a:>b)+ -- if x == 0 then 0 else atan (y/x)+ phi = acos (z / rho)++instance Functor Vector3 where+ fmap f (Vector3 x y z) = Vector3 (f x) (f y) (f z)++instance Applicative Vector3 where+ pure x = Vector3 x x x+ Vector3 f g h <*> Vector3 x y z = Vector3 (f x) (g y) (h z)+++instance AdditiveGroup u => AdditiveGroup (Vector3 u) where+ zeroV = Vector3 zeroV zeroV zeroV+ Vector3 u v w ^+^ Vector3 u' v' w'+ = Vector3 (u^+^u') (v^+^v') (w^+^w')+ negateV (Vector3 u v w) = Vector3 (negateV u) (negateV v) (negateV w)++instance VectorSpace u s => VectorSpace (Vector3 u) s where+ s *^ Vector3 u v w = Vector3 (s*^u) (s*^v) (s*^w)++instance (InnerSpace u s, AdditiveGroup s)+ => InnerSpace (Vector3 u) s where+ Vector3 u v w <.> Vector3 u' v' w' = u<.>u' ^+^ v<.>v' ^+^ w<.>w'++instance HasBasis u s => HasBasis (Vector3 u) s where+ type Basis (Vector3 u) = Basis (u,u,u)+ basisValue = toV3 . basisValue+ decompose = decompose . fromV3+ decompose' = decompose' . fromV3++toV3 :: (u,u,u) -> Vector3 u+toV3 (u,v,w) = Vector3 u v w++fromV3 :: Vector3 u -> (u,u,u)+fromV3 (Vector3 u v w) = (u,v,w)++instance ( Num s, VectorSpace s s+ , HasBasis s s, HasTrie (Basis s), Basis s ~ () )+ => HasNormal (Vector2 s :> Vector3 s) where+ normalVec v = d (Left ()) `cross3` d (Right ())+ where+ d = untrie (derivative v)++-- Above doesn't seem to work in ghc 6.8. So use explicit instances for+-- 'Float' & 'Double'. Revisit.++-- instance HasNormal (Vector2 Float :> Vector3 Float) where+-- normalVec v = d (Left ()) `cross3` d (Right ())+-- where+-- d = untrie (derivative v)++-- instance HasNormal (Vector2 Double :> Vector3 Double) where+-- normalVec v = d (Left ()) `cross3` d (Right ())+-- where+-- d = untrie (derivative v)++instance Num s => HasCross3 (Vector3 s) where+ Vector3 ax ay az `cross3` Vector3 bx by bz =+ Vector3 (ay * bz - az * by)+ (az * bx - ax * bz)+ (ax * by - ay * bx)++-- instance (Num s, VectorSpace s s) => HasCross (Vector3 (Vector2 s :> s)) where+-- cross = unvector3F . cross . vector3F++-- vector3F :: (Applicative f) => Vector3 (f s) -> f (Vector3 s)+-- vector3F (Vector3 u v w) = liftA3 Vector3 u v w++-- unvector3F :: (Functor f) => f (Vector3 s) -> Vector3 (f s)+-- unvector3F d = Vector3 (vector3x <$> d) (vector3y <$> d) (vector3z <$> d)++-- instance (Num s, LMapDom s s) => HasNormal (Three (Vector2 s :> s)) where+-- normalVec = unvector3D . normalVec . vector3D++-- instance ( Num s, VectorSpace s s, HasBasis s s, HasTrie (Basis s)+-- , HasNormal (Vector2 s :> Vector3 s)+-- , HasBasis (Vector2 s) s, HasTrie (Basis (Vector2 s)))+-- => HasNormal (Vector3 (Vector2 s :> s)) where+-- normalVec v = d (Left ()) `cross3` d (Right ())+-- where+-- d = untrie (derivative v)++-- instance (Num s, VectorSpace s s, HasBasis s s, HasTrie (Basis s)) =>+-- HasNormal (Three (Vector2 s :> s)) where+-- normalVec = unvector3D . normalVec . vector3D++-- sigh. try the instance above when we're on ghc-6.9++instance HasNormal (Three (Vector2 Float :> Float)) where+ normalVec = unvector3D . normalVec . vector3D++instance HasNormal (Three (Vector2 Double :> Double)) where+ normalVec = unvector3D . normalVec . vector3D++vector3D :: (VectorSpace s s, HasTrie (Basis a)) =>+ Three (a :> s) -> a :> (Vector3 s)+vector3D (u,v,w) = liftD3 Vector3 u v w++unvector3D :: (VectorSpace s s, HasTrie (Basis a)) =>+ a :> (Vector3 s) -> Three (a :> s)+unvector3D d = (vector3x <$>> d, vector3y <$>> d, vector3z <$>> d)
+ src/Graphics/FieldTrip/Vertex.hs view
@@ -0,0 +1,61 @@+----------------------------------------------------------------------+-- |+-- Module : Graphics.FieldTrip.Vertex+-- Copyright : (c) Conal Elliott 2008+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Experiment with vertex specs+----------------------------------------------------------------------++-- I'm torn about using this coding trick. HOpenGL has a 'Vertex'+-- class. I added instances for normals and colors, and for pairs. Then+-- surfaces over any nested pairing of such things can be rendered.+-- Moreover, one can do interpolation and differentiation generically, if+-- the components support those operations. However, it's not really+-- safe, given the order-sensitivity of processing of these components, and+-- specifically that the real vertex must come last. Perhaps provide a+-- type of vertex-with-adornment, and give it a 'VectorSpace' instance. I+-- could play the tuple game on the adornments. Even represent the+-- vertex-with-adornment as a newtype around a pair, deriving the+-- 'VectorSpace' instance.+++module Graphics.FieldTrip.Vertex where++import Graphics.Rendering.OpenGL+++-- Pairs as vertices, processed left-to-right.+-- The real vertex then must be given last!++instance (Vertex v, Vertex v') => Vertex (v,v')+ where+ vertex (v,v') = vertex v >> vertex v'+ vertexv = error "vertexv: undefined on pairs"+++newtype NormalV n = NormalV n++instance Normal n => Vertex (NormalV n)+ where+ vertex (NormalV n) = normal n+ vertexv = error "vertexv: undefined on NormalV"+++newtype ColorV n = ColorV n++instance Color n => Vertex (ColorV n)+ where+ vertex (ColorV n) = color n+ vertexv = error "vertexv: undefined on ColorV"+++-- The pairing trick provides 'VectorSpace' and 'Num' operations for free,+-- including derivatives and interpolation. I think we could get a lot of+-- genericity out of this trick.+-- +-- However, it's not really safe, given the order-senstivity, and+-- specifically that the real vertex must come last.