packages feed

rsagl (empty) → 0.2.1

raw patch · 50 files changed

+6554/−0 lines, 50 filesdep +GLUTdep +OpenGLdep +QuickChecksetup-changed

Dependencies added: GLUT, OpenGL, QuickCheck, array, arrows, base, containers, mtl, old-time, parallel, random

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2006, 2007, Christopher Lane Hinson+ All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are +permitted provided that the following conditions are met:++Redistributions of source code must retain the above copyright notice, this list of +conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright notice, this list of +conditions and the following disclaimer in the documentation and/or other materials +provided with the distribution.++Neither the name of Christopher Lane Hinson nor the names of its contributors may be used +to endorse or promote products derived from this software without specific prior written +permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Models/PlanetRingMoon.hs view
@@ -0,0 +1,131 @@+module Models.PlanetRingMoon+    (planet,ring,moon,ground,monolith,station,orb,glow_orb,orb_upper_leg,orb_lower_leg)+    where++import RSAGL.Model+import RSAGL.Vector+import RSAGL.ModelingExtras+import RSAGL.RayTrace+import RSAGL.Affine+import RSAGL.Auxiliary+import System.Random+import RSAGL.Angle+import RSAGL.CurveExtras+import RSAGL.Curve++ring :: Modeling ()+ring = model $ do openDisc 0.75 1.0+                  material $+		      do transparent $ pure $ alpha 0.25 purple+                         specular 2 $ pure purple+                  bumps $ waves 0.2 0.01+                  twoSided True++planet :: Modeling ()+planet = model $ +    do sphere (Point3D 0 0 0) 0.65+       deform $ constrain (\(SurfaceVertex3D (Point3D x y z) _) -> x > 0 && y > 0 && z > 0) $ +           shadowDeform (Vector3D (-1) (-1) (-1)) (map (plane (Point3D 0 0 0)) [Vector3D 1 0 0,Vector3D 0 1 0,Vector3D 0 0 1])+       let land_vs_water land water = pattern (cloudy 26 0.4) [(0,water),(0.5,water),(0.51,land),(1,land)]+       let grass_and_mountains = pattern (cloudy 81 0.25) [(0.4,pattern (cloudy 99 0.1) [(0.0,pure brown),(1.0,pure slate_gray)]),(0.5,pure forest_green)]+       let land_and_water = land_vs_water grass_and_mountains (pure blue)+       let cities bright dark = land_vs_water (pattern (cloudy 5 0.1) [(0.0,bright),(0.5,dark)]) (dark)+       let planet_surface = pattern (gradient (Point3D 0 0 0) (Vector3D 0 0.65 0)) +                                    [(-0.9,pure white),(-0.85,land_and_water),(0.85,land_and_water),(0.9,pure white)]+       let planet_interior inner_core outer_core crust = pattern (spherical (Point3D 0 0 0) 0.65) +                  [(0.0,inner_core),(0.25,inner_core),(0.5,outer_core),(0.95,outer_core),(1.0,crust)]+       material $+           do pigment $ planet_interior (pure blackbody) (pure blackbody) $ cities (pure black) planet_surface+              emissive $ planet_interior (pure yellow) (pure red) $ cities (pure $ scaleRGB 0.2 white) (pure blackbody)+              specular 20 $ planet_interior (pure blackbody) (pure blackbody) $ land_vs_water (pure blackbody) (pure white)++moon :: Modeling ()+moon = model $ +    do sphere (Point3D 0 0 0) 0.2+       material $ pigment $ pattern (cloudy 8 0.05) [(0.0,pure slate_gray),(1.0,pure black)]++monolith :: Modeling ()+monolith = model $+    do smoothbox 0.1 (Point3D 4 9 1) (Point3D (-4) (-9) (-1))+       affine (translate $ Vector3D 0 9 0)+       affine (scale' 0.20)+       material $+           do pigment $ pure blackbody+              specular 100 $ pure white++ground :: Modeling ()+ground = model $+    do closedDisc (Point3D 0 (-0.1) 0) (Vector3D 0 1 0) 75+       material $ pigment $ pattern (cloudy 27 1.0) [(0.0,pure brown),(1.0,pure forest_green)]++station :: Modeling ()+station = model $+    do model $ +         do torus 0.5 0.1+            openCone (Point3D (-0.5) 0 0,0.02) (Point3D 0.5 0 0,0.02)+            openCone (Point3D 0 0 (-0.5),0.02) (Point3D 0 0 0.5,0.02)+            closedCone (Point3D 0 0.2 0,0.2) (Point3D 0 (-0.2) 0,0.2)+            material $ +	        do pigment $ pure silver+                   specular 100 $ pure silver+       model $ +         do box (Point3D (-0.15) 0.19 (-0.05)) (Point3D 0.15 0.21 0.05)+            material $ emissive $ pure white+       sequence_ $ dropRandomElements 30 (mkStdGen 19) $ concatMap (rotationGroup (Vector3D 0 1 0) 40) $ +         [window_box,+          transformAbout (Point3D 0.5 0 0) (rotateZ $ fromDegrees 25) window_box,+          transformAbout (Point3D 0.5 0 0) (rotateZ $ fromDegrees (-25)) window_box,+          transformAbout (Point3D 0.5 0 0) (rotateZ $ fromDegrees 50) window_box,+          transformAbout (Point3D 0.5 0 0) (rotateZ $ fromDegrees (-50)) window_box]+            where window_box = model $+                      do quadralateral (Point3D 0.51 (-0.105) 0.03) (Point3D 0.49 (-0.105) 0.03)+                                       (Point3D 0.49 (-0.105) (-0.03)) (Point3D 0.51 (-0.105) (-0.03))+                         quadralateral (Point3D 0.51 0.105 (-0.03)) (Point3D 0.49 0.105 (-0.03))+                                       (Point3D 0.49 0.105 0.03) (Point3D 0.51 0.105 0.03)+                         material $+			     do pigment $ pure black+                                emissive $ pure white+                         tesselationHintComplexity 0+                         fixed (3,3)++orb :: Modeling ()+orb = model $+    do sor $ linearInterpolation $ points2d+               [(-0.001,0.4),+                (0.5,0.45),+                (0.5,0.4),+                (0.6,0.4),+                (0.6,0.6),+                (0.5,0.6),+                (0.5,0.55),+                (-0.001,0.6)]+       sequence_ $ rotationGroup (Vector3D 0 1 0) 5 $+           tube $ zipCurve (,) (pure 0.05) $ smoothCurve 3 0.4 $ loopedLinearInterpolation $ points3d+               [(0.4,0.2,0.4),+                (0.4,0.8,0.8),+                (-0.4,0.8,0.8),+                (-0.4,0.2,0.4)]+       regularPrism (Point3D 0 0.5 0,0.5) (Point3D 0 1.0 0,-0.001) 4+       material $+           do pigment $ pure gold+              specular 64 $ pure silver++glow_orb :: Modeling ()+glow_orb = translate (Vector3D 0 1 0) $+    do closedDisc (Point3D 0 0 0) (Vector3D 0 1 0) 1+       material $ emissive $ pattern (spherical (Point3D 0 0 0) 1) [(0.0,pure $ scaleRGB 1.5 white),(0.25,pure white),(0.95,pure blackbody)]++orb_upper_leg :: Modeling ()+orb_upper_leg =+    do tube $ zipCurve (,) (pure 0.05) $ linearInterpolation [Point3D 0 0 0,Point3D 0 0.1 0.5,Point3D 0 0 1]+       sphere (Point3D 0 0 1) 0.05+       material $+           do pigment $ pure gold+              specular 64 $ pure silver++orb_lower_leg :: Modeling ()+orb_lower_leg =+    do openCone (Point3D 0 0 0,0.05) (Point3D 0 0 1,-0.001)+       material $ +           do pigment $ pure gold+              specular 64 $ pure silver
+ RSAGL/AbstractVector.lhs view
@@ -0,0 +1,154 @@+\section{Abstract Vectors}++The \texttt{AbstractVector} typeclass provides some basic operations sufficient to implement various generic numerical algorithms, including numerical integration.++\begin{code}+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+module RSAGL.AbstractVector+    (AbstractVector,+     AbstractZero(..),+     AbstractAdd(..),+     AbstractSubtract(..),+     AbstractScale(..),+     AbstractMagnitude(..),+     abstractScaleTo,+     abstractSum,+     abstractAverage,+     abstractDistance)+    where++import Data.Fixed+import Data.List+import Control.Applicative+import RSAGL.ApplicativeWrapper+\end{code}++\subsection{Abstract Vectors and Differences}++\begin{code}+class AbstractZero a where+    zero :: a++class AbstractAdd p v | p -> v where+    add :: p -> v -> p++class AbstractSubtract p v | p -> v where+    sub :: p -> p -> v++class AbstractScale v where+    scalarMultiply :: Double -> v -> v++class AbstractMagnitude v where+    magnitude :: v -> Double++class (AbstractZero v,AbstractAdd v v,AbstractSubtract v v,AbstractScale v) => AbstractVector v where+\end{code}++\subsection{Instances for Float, Double, and Fixed}++\begin{code}+instance AbstractZero Float where+    zero = 0++instance AbstractAdd Float Float where+    add = (+)++instance AbstractSubtract Float Float where+    sub = (-)++instance AbstractScale Float where+    scalarMultiply d = (realToFrac d *)++instance AbstractMagnitude Float where+    magnitude = abs . realToFrac++instance AbstractVector Float++instance AbstractZero Double where+    zero = 0++instance AbstractAdd Double Double where+    add = (+)++instance AbstractSubtract Double Double where+    sub = (-)++instance AbstractScale Double where+    scalarMultiply d = (realToFrac d *)++instance AbstractMagnitude Double where+    magnitude = abs++instance AbstractVector Double++instance (HasResolution a) => AbstractZero (Fixed a) where+    zero = 0++instance (HasResolution a) => AbstractAdd (Fixed a) (Fixed a) where+    add = (+)++instance (HasResolution a) => AbstractSubtract (Fixed a) (Fixed a) where+    sub = (-)++instance (HasResolution a) => AbstractScale (Fixed a) where+    scalarMultiply d = (realToFrac d *)++instance (HasResolution a) => AbstractMagnitude (Fixed a) where+    magnitude = realToFrac++instance (HasResolution a) => AbstractVector (Fixed a)++instance (Applicative f,AbstractZero p) => AbstractZero (ApplicativeWrapper f p) where+    zero = pure zero++instance (Applicative f,AbstractAdd p v) => AbstractAdd (ApplicativeWrapper f p) (ApplicativeWrapper f v) where+    add p v = add <$> p <*> v++instance (Applicative f,AbstractSubtract p v) => AbstractSubtract (ApplicativeWrapper f p) (ApplicativeWrapper f v) where+    sub x y = sub <$> x <*> y++instance (Applicative f,AbstractScale v) => AbstractScale (ApplicativeWrapper f v) where+    scalarMultiply d v = scalarMultiply d <$> v++instance (Applicative f,AbstractVector v) => AbstractVector (ApplicativeWrapper f v)+\end{code}++\subsection{Instances for Tuples}++\begin{code}+instance (AbstractZero a,AbstractZero b) => AbstractZero (a,b) where+    zero = (zero,zero)++instance (AbstractAdd a a',AbstractAdd b b') => AbstractAdd (a,b) (a',b') where+    add (a,b) (c,d) = (add a c,add b d)++instance (AbstractSubtract a a',AbstractSubtract b b') => AbstractSubtract (a,b) (a',b') where+    sub (a,b) (c,d) = (sub a c,sub b d)++instance (AbstractScale a,AbstractScale b) => AbstractScale (a,b) where+    scalarMultiply d (a,b) = (scalarMultiply d a,scalarMultiply d b)++instance (AbstractMagnitude a,AbstractMagnitude b) => AbstractMagnitude (a,b) where+    magnitude (a,b) = sqrt $ magnitude a ^ 2 * magnitude b ^ 2++instance (AbstractVector a,AbstractVector b) => AbstractVector (a,b)+\end{code}++\subsection{Operations on Abstract Vectors}++\begin{code}+abstractScaleTo :: (AbstractScale v,AbstractMagnitude v) => Double -> v -> v+abstractScaleTo _ v | magnitude v == 0 = v+abstractScaleTo x v = scalarMultiply (x / magnitude v) v++abstractSum :: (AbstractAdd p v,AbstractZero p) => [v] -> p+abstractSum = foldr (flip add) zero++abstractAverage :: (AbstractAdd p v,AbstractSubtract p v,AbstractVector v) => [p] -> p+abstractAverage vs = add fixed_point $ scalarMultiply (recip $ fromInteger $ genericLength vs) $ abstractSum $ map (`sub` fixed_point) vs+    where fixed_point = head vs++abstractDistance :: (AbstractMagnitude v,AbstractSubtract p v) => p -> p -> Double+abstractDistance x y = magnitude $ x `sub` y+\end{code}
+ RSAGL/Affine.lhs view
@@ -0,0 +1,113 @@+\section{Transforming geometric objects: RSAGL.Affine}++AffineTransformable objects are entities that are subject to affine transformations using matrix multiplication.++Defaults are provided for all methods of AffineTransformable except transform.++The IO monad itself is AffineTransformable.  This is done by wrapping the IO action in an OpenGL transformation.++\begin{code}+{-# OPTIONS_GHC -fglasgow-exts #-}++module RSAGL.Affine+    (AffineTransformable(..),+     transformAbout,+     translateToFrom,+     rotateToFrom)+    where++import Graphics.Rendering.OpenGL.GL as GL hiding (R)+import RSAGL.Vector+import RSAGL.Matrix+import RSAGL.Angle+import RSAGL.Homogenous+\end{code}++\begin{code}+class AffineTransformable a where+    transform :: RSAGL.Matrix.Matrix -> a -> a+    scale :: Vector3D -> a -> a+    scale vector = transform $ scaleMatrix vector+    translate :: Vector3D -> a -> a+    translate vector = transform $ translationMatrix vector+    rotate :: Vector3D -> Angle -> a -> a+    rotate vector angle = transform $ rotationMatrix vector angle+    rotateX :: Angle -> a -> a+    rotateX = RSAGL.Affine.rotate (Vector3D 1 0 0)+    rotateY :: Angle -> a -> a+    rotateY = RSAGL.Affine.rotate (Vector3D 0 1 0)+    rotateZ :: Angle -> a -> a+    rotateZ = RSAGL.Affine.rotate (Vector3D 0 0 1)+    scale' :: Double -> a -> a+    scale' x = RSAGL.Affine.scale (Vector3D x x x)+    inverseTransform :: RSAGL.Matrix.Matrix -> a -> a+    inverseTransform m = transform (matrixInverse m)+\end{code}++\texttt{transformAbout} performs an affine transformation treating a particular point as the origin.  For example,+combining \texttt{transformAbout} with \texttt{rotate} performs a rotation about an arbitrary point rather than the origin.++\begin{code}+transformAbout :: (AffineTransformable a) => Point3D -> (a -> a) -> a -> a+transformAbout center tform = +    RSAGL.Affine.translate (vectorToFrom center origin_point_3d) .+    tform .+    RSAGL.Affine.translate (vectorToFrom origin_point_3d center)++translateToFrom :: (AffineTransformable a) => Point3D -> Point3D -> a -> a+translateToFrom a b = RSAGL.Affine.translate (vectorToFrom a b)++rotateToFrom :: (AffineTransformable a) => Vector3D -> Vector3D -> a -> a+rotateToFrom u v = RSAGL.Affine.rotate c a+    where c = vectorNormalize $ vectorScale (-1) $ crossProduct u v+          a = angleBetween u v++instance AffineTransformable a => AffineTransformable (Maybe a) where+    scale v = fmap (RSAGL.Affine.scale v)+    translate v = fmap (RSAGL.Affine.translate v)+    rotate angle vector = fmap (RSAGL.Affine.rotate angle vector)+    transform m = fmap (transform m)++instance AffineTransformable a => AffineTransformable [a] where+    scale v = map (RSAGL.Affine.scale v)+    translate v = map (RSAGL.Affine.translate v)+    rotate angle vector = map (RSAGL.Affine.rotate angle vector)+    transform m = map (transform m)++instance (AffineTransformable a,AffineTransformable b) => AffineTransformable (a,b) where+    transform m (a,b) = (transform m a,transform m b)++instance (AffineTransformable a,AffineTransformable b,AffineTransformable c) => AffineTransformable (a,b,c) where+    transform m (a,b,c) = (transform m a,transform m b,transform m c)++instance AffineTransformable RSAGL.Matrix.Matrix where+    transform mat = matrixMultiply mat++instance AffineTransformable Vector3D where+    transform = transformHomogenous+    scale (Vector3D x1 y1 z1) (Vector3D x2 y2 z2) = Vector3D (x1*x2) (y1*y2) (z1*z2)+    translate _ = id++instance AffineTransformable Point3D where+    transform = transformHomogenous+    scale (Vector3D x1 y1 z1) (Point3D x2 y2 z2) = Point3D (x1*x2) (y1*y2) (z1*z2)+    translate (Vector3D x1 y1 z1) (Point3D x2 y2 z2) = Point3D (x1+x2) (y1+y2) (z1+z2)++instance AffineTransformable SurfaceVertex3D where+    transform m (SurfaceVertex3D p v) = SurfaceVertex3D (RSAGL.Affine.transform m p) (RSAGL.Affine.transform (matrixTranspose $ matrixInverse m) v)+    translate vector (SurfaceVertex3D p v) = SurfaceVertex3D (RSAGL.Affine.translate vector p) v++instance AffineTransformable (IO a) where+    transform mat iofn = preservingMatrix $ do mat' <- newMatrix RowMajor $ concat $ rowMajorForm mat+                                               multMatrix (mat' :: GLmatrix Double)+                                               iofn+    translate (Vector3D x y z) iofn = preservingMatrix $ +        do GL.translate $ Vector3 x y z+           iofn+    scale (Vector3D x y z) iofn = preservingMatrix $ +        do GL.scale x y z+           iofn+    rotate (Vector3D x y z) angle iofn = preservingMatrix $ +        do GL.rotate (toDegrees_ angle) (Vector3 x y z)+           iofn+\end{code}
+ RSAGL/Angle.lhs view
@@ -0,0 +1,188 @@+\section{RSAGL.Angle}++RSAGL.Angle supports manipulation of angular values, including+angular arithmetic and trigonometry.++\begin{code}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+module RSAGL.Angle+    (Angle,+     BoundAngle(..),+     fromDegrees,+     fromRadians,+     fromRotations,+     sine,+     arcSine,+     cosine,+     arcCosine,+     tangent,+     arcTangent,+     toRadians,+     toRadians_,+     toDegrees,+     toDegrees_,+     toRotations,+     toRotations_,+     scaleAngle,+     zero_angle,+     angularIncrements,+     angleAdd,+     angleSubtract,+     angleNegate,+     absoluteAngle,+     unboundAngle)+    where++import Data.Fixed+import RSAGL.AbstractVector++newtype Angle = Radians Double deriving (Show)+newtype BoundAngle = BoundAngle Angle deriving (Show)++zero_angle :: Angle+zero_angle = Radians 0++instance Eq Angle where+    (==) a b = case (toRadians_ a,toRadians_ b) of+                   (x,y) | abs x == pi && abs y == pi -> True+                   (x,y) | x == y -> True+                   _ -> False++instance Ord Angle where+    compare x y = case () of+                      _ | x == y -> EQ+                      _ -> compare (toRadians_ x) (toRadians_ y)++instance AbstractZero Angle where+    zero = zero_angle++instance AbstractZero BoundAngle where+    zero = BoundAngle zero_angle++instance AbstractAdd Angle Angle where+    add = angleAdd++instance AbstractAdd BoundAngle Angle where+    add (BoundAngle a) x = BoundAngle $ boundAngle $ a `add` x++instance AbstractSubtract Angle Angle where+    sub = angleSubtract++instance AbstractSubtract BoundAngle Angle where+    sub (BoundAngle a) (BoundAngle b) = boundAngle $ a `sub` b++instance AbstractScale Angle where+    scalarMultiply = scaleAngle++instance AbstractVector Angle++instance AbstractMagnitude Angle where+    magnitude = toRotations_ . absoluteAngle+\end{code}++angularIncrements answers n equa-angular values from 0 to 2*pi.++\begin{code}+angularIncrements :: Integer -> [Angle]+angularIncrements subdivisions = map (fromRadians . (2*pi*) . (/ fromInteger subdivisions) . fromInteger) [0 .. subdivisions - 1]+\end{code}++\subsection{Type coercion for Angles}++\begin{code}+fromRadians :: Double -> Angle+fromRadians = Radians++fromDegrees :: Double -> Angle+fromDegrees = Radians . ((*) (pi/180))++fromRotations :: Double -> Angle+fromRotations = Radians . ((*) (2*pi))+\end{code}++\texttt{toDegrees} answers the angle in the range of -180 to 180, inclusive.++\texttt{toDegrees\_} answers the angle in degrees with no range limitation.++\begin{code}+toDegrees :: Angle -> Double+toDegrees x = let x' = toRadians x+                  in x' * 180 / pi++toDegrees_ :: Angle -> Double+toDegrees_ (Radians x) = x * 180 / pi+\end{code}++\texttt{toRadians} answers the angle in the range of -pi .. pi, inclusive.++\texttt{toRadians\_} answers the angle in radians with no range limitation.++\begin{code}+toRadians :: Angle -> Double+toRadians x = let (Radians x') = boundAngle x+                  in x'++toRadians_ :: Angle -> Double+toRadians_ (Radians x) = x+\end{code}++\texttt{toRotations} answers the angle in the range of -0.5 to 0.5, inclusive.++\texttt{toRotations\_} answers the angle in rotations with no range limitation.++\begin{code}+toRotations :: Angle -> Double+toRotations x= let x' = toRadians x+                   in x' / pi / 2++toRotations_ :: Angle -> Double+toRotations_ (Radians x) = x / pi / 2+\end{code}++\subsection{Manipulating Angular values}++\begin{code}+scaleAngle :: Double -> Angle -> Angle+scaleAngle x = Radians . (*x) . toRadians_++angleAdd :: Angle -> Angle -> Angle+angleAdd (Radians x) (Radians y) = Radians $ x + y++angleSubtract :: Angle -> Angle -> Angle+angleSubtract (Radians x) (Radians y) = Radians $ x - y++angleNegate :: Angle -> Angle+angleNegate (Radians x) = Radians $ negate x++absoluteAngle :: Angle -> Angle+absoluteAngle (Radians x) = Radians $ abs x++sine :: Angle -> Double+sine (Radians x) = sin x++arcSine :: Double -> Angle+arcSine = fromRadians . asin++cosine :: Angle -> Double+cosine (Radians x) = cos x++arcCosine :: Double -> Angle+arcCosine = fromRadians . acos++tangent :: Angle -> Double+tangent (Radians x) = tan x++arcTangent :: Double -> Angle+arcTangent = fromRadians . atan+\end{code}++\texttt{boundAngle} forces the angle into the range (-pi..pi).++\begin{code}+boundAngle :: Angle -> Angle+boundAngle (Radians x) = Radians $ if bounded > pi then bounded - 2*pi else bounded+    where bounded = x `mod'` (2*pi)++unboundAngle :: BoundAngle -> Angle+unboundAngle (BoundAngle a) = a+\end{code}
+ RSAGL/Animation.lhs view
@@ -0,0 +1,100 @@+\section{Monads and Arrows for Animation}++The \texttt{AniM} monad and the \texttt{AniA} arrow support frame time, affine transformation and scene accumulation.++\begin{code}+{-# OPTIONS_GHC -fglasgow-exts -farrows #-}++module RSAGL.Animation+    (AniM,+     TimePlusSceneAccumulator,+     frameTime,+     runAniM,+     rotationM,+     animateM,+     rotateM,+     AniA,+     AnimationObject,+     newAnimationObjectM,+     newAnimationObjectA,+     runAnimationObject)+    where++import RSAGL.Time+import RSAGL.Scene+import Control.Monad.State+import RSAGL.CoordinateSystems+import RSAGL.Angle+import RSAGL.Vector+import RSAGL.Affine+import RSAGL.FRP+import Control.Concurrent.MVar+import Control.Arrow.Transformer.State as StateArrow+\end{code}++\subsection{The AniM Monad}++The AniM monad is a simple state layer over the IO monad that supports scene accumulation and getting the frame time (the time at the beginning of the frame, as opposed to real time that would change as the animation progresses).++\begin{code}+newtype TimePlusSceneAccumulator = TimePlusSceneAccumulator (Time,SceneAccumulator)+    deriving (CoordinateSystemClass, ScenicAccumulator)++type AniM a = StateT TimePlusSceneAccumulator IO a++frameTime :: AniM Time+frameTime = gets (\(TimePlusSceneAccumulator (t,_)) -> t)++runAniM :: AniM (a,Camera) -> IO (a,Scene)+runAniM anim = +    do t <- getTime+       ((a,c),TimePlusSceneAccumulator (_,sa)) <- runStateT anim $ TimePlusSceneAccumulator (t,null_scene_accumulator)+       result_scene <- assembleScene c sa+       return (a,result_scene)++rotationM :: Vector3D -> Rate Angle -> AniM AffineTransformation+rotationM v a =+    do t <- frameTime+       return (rotate v (a `over` t))++animateM :: AniM AffineTransformation -> AniM b -> AniM b+animateM affineF action =+    do at <- affineF+       transformM (affineOf at) action++rotateM :: Vector3D -> Rate Angle -> AniM a -> AniM a+rotateM v a = animateM (rotationM v a)+\end{code}++\subsection{The AniA Arrow}++\begin{code}+type AniA t i o j p = FRPX Threaded t i o (StateArrow SceneAccumulator (->)) j p+type AniA1 i o j p = FRP1 i o (StateArrow SceneAccumulator (->)) j p+\end{code}++\subsection{Animation Objects}++This is one possible implementation of an animation object.++\begin{code}+data AnimationObject i o =+    AniMObject (i -> AniM o)+  | AniAObject (MVar (FRPProgram (StateArrow SceneAccumulator (->)) i o))++newAnimationObjectM :: (i -> AniM o) -> AnimationObject i o+newAnimationObjectM = AniMObject++newAnimationObjectA :: AniA1 i o i o -> IO (AnimationObject i o)+newAnimationObjectA thread = liftM AniAObject $ newMVar $ newFRP1Program thread++runAnimationObject :: AnimationObject i o -> i -> AniM o+runAnimationObject (AniMObject f) i = f i+runAnimationObject (AniAObject mv) i =+    do old_frpp <- liftIO $ takeMVar mv+       TimePlusSceneAccumulator (t,old_s) <- get+       let ((o,new_frpp),new_s) = (StateArrow.runState $ updateFRPProgram old_frpp) ((i,t),old_s)+       put $ TimePlusSceneAccumulator (t,new_s)+       liftIO $ putMVar mv new_frpp+       return o+\end{code}
+ RSAGL/AnimationExtras.lhs view
@@ -0,0 +1,125 @@+\section{Specific Animations}++\begin{code}+{-# OPTIONS_GHC -farrows #-}++module RSAGL.AnimationExtras+    (rotationA,+     animateA,+     rotateA,+     pointAtCameraA,+     inverseSquareLaw,+     quadraticTrap,+     drag,+     concatForces,+     constrainForce,+     accelerationModel)+    where++import RSAGL.Vector+import RSAGL.FRP+import RSAGL.Time+import RSAGL.AbstractVector+import Control.Arrow+import Control.Arrow.Operations+import RSAGL.CoordinateSystems+import RSAGL.Affine+import RSAGL.Angle+import RSAGL.Scene+import RSAGL.Model+import RSAGL.Affine+import RSAGL.WrappedAffine+import Control.Monad+\end{code}++\subsection{Simple Animators}++\begin{code}+rotationA :: (Arrow a,ArrowChoice a) => Vector3D -> Rate Angle -> FRP i o a ignored AffineTransformation+rotationA v a = proc _ ->+    do t <- absoluteTime -< ()+       returnA -< rotate v (a `over` t)++animateA :: (Arrow a,ArrowChoice a,ArrowState s a,CoordinateSystemClass s) => FRP i o a j AffineTransformation -> FRP i o a j p -> FRP i o a j p+animateA affineA action = proc i ->+    do at <- affineA -< i+       transformA action -< (affineOf at,i)++rotateA :: (Arrow a,ArrowChoice a,ArrowState s a,CoordinateSystemClass s) => Vector3D -> Rate Angle -> FRP i o a j p -> FRP i o a j p+rotateA v a = animateA (rotationA v a)+\end{code}++\subsection{Camera Relative Animators}++\texttt{pointAtCameraA} always points at the camera, using a single rotation.++\begin{code}+pointAtCameraA :: (Arrow a,ArrowState s a,CoordinateSystemClass s,ScenicAccumulator s) => a (SceneLayer,IO IntermediateModel) ()+pointAtCameraA = proc (slayer,imodel) ->+    do cs <- arr getCoordinateSystem <<< fetch -< ()+       accumulateSceneA -< (slayer,cameraRelativeSceneObject $ \c -> +           liftM ((rotateToFrom (vectorToFrom (migrate root_coordinate_system cs $ if slayer == Infinite then origin_point_3d else camera_position c) $ origin_point_3d)+                                       (Vector3D 0 1 0)) . wrapAffine) imodel)+\end{code}++\subsection{Particle Physics Models}++\begin{code}+type PV = (Point3D,Rate Vector3D)+type PVA = (Point3D,Rate Vector3D,Acceleration Vector3D)+type ForceFunction = Time -> Point3D -> Rate Vector3D -> Acceleration Vector3D+\end{code}++\texttt{inverseSquareLaw} produces a \texttt{ForceFunction} that attracts a particle as though by+a gravitational singularity.++\begin{code}+inverseSquareLaw :: Double -> Point3D -> ForceFunction+inverseSquareLaw g attractor _ p _ = perSecond $ perSecond $ vectorScaleTo (g * (recip $ vectorLengthSquared v)) v+    where v = vectorToFrom attractor p+\end{code}++\texttt{quadraticTrap} is the inverse of the inverse square law.  Because the attraction increases with+distance, all particles are trapped (there is no escape velocity).++\begin{code}+quadraticTrap :: Double -> Point3D -> ForceFunction+quadraticTrap g attractor _ p _ = perSecond $ perSecond $ vectorScaleTo (g * vectorLengthSquared v) v+    where v = vectorToFrom attractor p+\end{code}++\texttt{drag} behaves like simple aerodynamic drag.++\begin{code}+drag :: Double -> ForceFunction+drag x _ _ v' = perSecond $ perSecond $ vectorScaleTo (negate $ x * vectorLengthSquared v) v+    where v = v' `over` fromSeconds 1 +\end{code}++\texttt{concatForces} combines any arbitrary group of \texttt{ForceFunction}s.++\begin{code}+concatForces :: [ForceFunction] -> ForceFunction+concatForces ffs t p v = abstractSum $ map (\f -> f t p v) ffs+\end{code}++\texttt{constrainForce} acts as a conditional for \texttt{ForceFunction}s.++\begin{code}+constrainForce :: (Time -> Point3D -> Rate Vector3D -> Bool) -> ForceFunction -> ForceFunction+constrainForce predicate f t p v = if predicate t p v+    then f t p v+    else zero+\end{code}++\texttt{accelerationModel} implements the \texttt{ForceFunction}s on a single particle.++\begin{code}+accelerationModel :: (Arrow a,ArrowChoice a,ArrowApply a,ArrowState s a,CoordinateSystemClass s) => +                     Frequency -> PV -> FRPX any t i o a j ForceFunction ->+                     FRPX any t i o a (PVA,j) p -> FRPX any t i o a j p+accelerationModel f pv forceA actionA = proc j ->+    do (p,v) <- integralRK4' f (flip translate) pv <<< forceA -< j+       a <- derivative -< v+       transformA actionA -< (affineOf $ translate (vectorToFrom p origin_point_3d),((p,v,a),j))+\end{code}
+ RSAGL/ApplicativeWrapper.lhs view
@@ -0,0 +1,49 @@+\section{Applicative Wrapper}++\texttt{ApplicativeWrapper} is a simple wrapper over the Applicative typeclass that retains information about the purity of the wrapper data structure type.++\begin{code}+{-# OPTIONS_GHC -fglasgow-exts #-}++module RSAGL.ApplicativeWrapper+    (ApplicativeWrapper(..),+     fromPure,+     toApplicative,+     unwrapApplicative,+     wrapApplicative,+     isPure)+    where++import Control.Applicative+import Data.Maybe+import Control.Parallel.Strategies++newtype ApplicativeWrapper f a = ApplicativeWrapper (Either (f a) a)++instance (Functor f,Applicative f) => Functor (ApplicativeWrapper f) where+    fmap f (ApplicativeWrapper (Right a)) = pure $ f a+    fmap f (ApplicativeWrapper (Left a)) = wrapApplicative $ fmap f a++instance (Applicative f) => Applicative (ApplicativeWrapper f) where+    pure = ApplicativeWrapper . Right+    (ApplicativeWrapper (Right f)) <*> (ApplicativeWrapper (Right a)) = ApplicativeWrapper $ Right $ f a+    f <*> a = wrapApplicative $ toApplicative f <*> toApplicative a++instance (NFData (f a),NFData a) => NFData (ApplicativeWrapper f a) where+    rnf (ApplicativeWrapper ethr) = rnf ethr++fromPure :: (Applicative f) => ApplicativeWrapper f a -> Maybe a+fromPure = either (const Nothing) Just . unwrapApplicative++toApplicative :: (Applicative f) => ApplicativeWrapper f a -> f a+toApplicative = either id pure . unwrapApplicative++unwrapApplicative :: (Applicative f) => ApplicativeWrapper f a -> Either (f a) a+unwrapApplicative (ApplicativeWrapper x) = x++wrapApplicative :: (Applicative f) => f a -> ApplicativeWrapper f a+wrapApplicative = ApplicativeWrapper . Left++isPure :: (Applicative f) => ApplicativeWrapper f a -> Bool+isPure = isJust . fromPure+\end{code}
+ RSAGL/ArrowTransformerOptimizer.lhs view
@@ -0,0 +1,49 @@+\section{Managing Expensive Arrows}++The \texttt{ArrowTransformerOptimizer} optimizes arrow transformers that have expensive binding operations by intelligently extracting all lifted computations+and representing pure computations as lifted pure computations.++\begin{code}+{-# LANGUAGE GADTs, MultiParamTypeClasses, FlexibleInstances #-}++module RSAGL.ArrowTransformerOptimizer+    (ArrowTransformerOptimizer,+     raw,+     collapseArrowTransformer)+    where++import Control.Arrow+import Control.Arrow.Transformer++data ArrowTransformerOptimizer a l b c where+    Raw :: a l b c -> ArrowTransformerOptimizer a l b c+    Lifted :: (ArrowTransformer a l) => l b c -> ArrowTransformerOptimizer a l b c+    Joined :: (ArrowTransformer a l) => l b x -> a l x y -> l y c -> ArrowTransformerOptimizer a l b c++instance (ArrowTransformer a l) => Arrow (ArrowTransformerOptimizer a l) where+    (Raw a) >>> (Raw b) = Raw (a >>> b)+    (Lifted a) >>> (Lifted b) = Lifted (a >>> b)+    (Raw a) >>> (Lifted b) = Joined (arr id) a b+    (Lifted a) >>> (Raw b) = Joined a b (arr id)+    (Lifted l) >>> (Joined x y z) = Joined (l >>> x) y z+    (Joined x y z) >>> (Lifted l) = Joined x y (z >>> l)+    (Joined a b c) >>> (Joined x y z) = Joined a (b >>> lift (c >>> x) >>> y) z+    (Joined x y z) >>> (Raw b) = Joined x (y >>> lift z >>> b) (arr id)+    (Raw a) >>> (Joined x y z) = Joined (arr id) (a >>> lift x >>> y) z+    first (Raw a) = Raw (first a)+    first (Lifted a) = Lifted (first a)+    first (Joined x y z) = Joined (first x) (first y) (first z)+    arr a = Lifted (arr a)++instance (ArrowTransformer a l) => ArrowTransformer (ArrowTransformerOptimizer a) l where+    lift = Lifted++raw :: (ArrowTransformer a l) => a l b c -> ArrowTransformerOptimizer a l b c+raw = Raw++collapseArrowTransformer :: ArrowTransformerOptimizer a l b c -> a l b c+collapseArrowTransformer (Raw a) = a+collapseArrowTransformer (Lifted a) = lift a+collapseArrowTransformer (Joined x y z) = lift x >>> y >>> lift z+\end{code}+
+ RSAGL/Auxiliary.hs view
@@ -0,0 +1,123 @@+module RSAGL.Auxiliary+    (doubles,+     loopedDoubles,+     consecutives,+     loopedConsecutives,+     dropRandomElements,+     matrixMultiplyImpl,+     loopList,+     shiftR,+     zeroToOne,+     constrain,+     debugTime,+     waitParList)+    where++import Data.Array+import System.Random+import System.CPUTime+import Control.Parallel+import Control.Parallel.Strategies+import Debug.Trace++-- doubles transforms a list to a list of adjacent elements.++-- doubles [1,2,3,4,5] = [(1,2),(2,3),(3,4),(4,5)]++doubles :: [a] -> [(a,a)]+doubles [] = []+doubles [_] = []+doubles (x:y:zs) = (x,y) : doubles (y:zs)++-- loopedDoubles transforms a list to a list of adjacent elements, looping back to the beginning of the list.++-- loopedDoubles [1,2,3,4,5] = [(1,2),(2,3),(3,4),(4,5),(5,1)]++loopedDoubles :: [a] -> [(a,a)]+loopedDoubles as = loopedDoubles_ (head as) as+    where loopedDoubles_ _ [] = []+          loopedDoubles_ a [x] = [(x,a)]+          loopedDoubles_ a (x:y:zs) = (x,y) : loopedDoubles_ a (y:zs)++-- consecutives answers a list containing every sequence of n consecutive+-- elements in the parameter.++--consecutives 3 [1,2,3,4] = [[1,2,3],[2,3,4]]++consecutives :: Int -> [a] -> [[a]]+consecutives n xs = let taken = take n xs+			in if (length taken == n)+			   then (taken : (consecutives n $ tail xs))+			   else []++-- loopedConsecutives answers a list containing every sequence of n consecutive+-- elements in the parameter, looping back to the beginning of the list.++-- consecutives 3 [1,2,3,4] = [[1,2,3],[2,3,4],[3,4,1],[4,1,2]]++loopedConsecutives :: Int -> [a] -> [[a]]+loopedConsecutives n xs = consecutives n $ take (n + length xs - 1) $ cycle xs++-- dropRandomElements removes some elements of a list at random.  The first parameter is the number of elements out of 100 that should be included (not dropped).+-- The second is the random number generator, and the third is the list to be operated on.++dropRandomElements :: Int -> StdGen -> [a] -> [a]+dropRandomElements percent _ _ | percent > 100 = error "dropRandomElements: percent > 100"+dropRandomElements percent _ _ | percent < 0 = error "dropRandomElements: percent < 100"+dropRandomElements _ _ [] = []+dropRandomElements percent rand_ints things = +    let (next_int,next_gen) = next rand_ints+	rest = dropRandomElements percent next_gen (tail things)+	in if (next_int `mod` 100 < percent)+	   then ((head things) : rest)+	   else rest++-- matrixMultiplyImpl implements matrix multiplication.++matrixMultiplyImpl :: (b -> c -> c) -> c -> (a -> a -> b) -> [[a]] -> [[a]] -> [[c]]+matrixMultiplyImpl addOp zero multiplyOp m n = [[foldr addOp zero $ zipWith multiplyOp m' n' | n' <- n] | m' <- m]++-- loopList appends the first element of a list to the end of the list.  The result is a list of one greater length.++-- shiftR shifts every element of a list to the right, recyling the last element as the first.  The result is a list of the same length.++loopList :: [a] -> [a]+loopList ps = ps ++ [head ps]++shiftR :: [a] -> [a]+shiftR ps = last ps : init ps++-- zeroToOne creates a list of numbers from 0.0 to 1.0, using n steps.++zeroToOne :: Integer -> [Double]+zeroToOne n | n > 100000 = trace ("Warning: zeroToOne was asked for " ++ show n ++ " subdivisions, which seems high.  Using 100,000 instead.") zeroToOne 100000+zeroToOne n | n <= 1000 = ztos ! n+zeroToOne n = zeroToOnePrim n++zeroToOnePrim :: Integer -> [Double]+zeroToOnePrim n = map (*x) [0..(fromInteger $ n-1)]+    where x = recip (fromInteger $ n - 1)++ztos :: Array Integer [Double]+ztos = listArray (0,1000) $ map (zeroToOnePrim) [0 .. 1000]++-- constrain restricts the effective domain of a function.  Outside of the restricted domain, the function is id++constrain :: (a -> Bool) -> (a -> a) -> a -> a+constrain f g x = if f x then g x else x++-- debugTime prints a statement indicating how long an IO action takes to complete++debugTime :: String -> IO a -> IO a+debugTime msg io_action =+    do print $ "debugTime: starting " ++ msg+       start_time <- getCPUTime+       result <- io_action+       end_time <- getCPUTime+       print $ "debugTime: done with " ++ msg ++ " " ++ show (end_time - start_time)+       return result++-- as parList, but waits until the list is fully evaluated.++waitParList :: Strategy a -> Strategy [a]+waitParList s a = parList s a `pseq` seqList s a
+ RSAGL/Bottleneck.lhs view
@@ -0,0 +1,34 @@+\section{Artificial Bottlenecks for Parallel Computation}++In the absence of a thread priority support for haskell, and the desire not to overwhelm the rendering thread with many non-essential modeling threads, we implement an artificial bottleneck that restricts at a very coarse level the number of parallel computations that may take place at any one time.++By claiming a bottleneck, we ensure that no other operation can run on that bottleneck until the bottleneck is released.  This is essentially a semaphore, but the goal is related to performance rather than correctness.++\begin{code}+module RSAGL.Bottleneck+    (constrict,newBottleneck,Bottleneck)+    where++import Control.Monad+import Control.Concurrent.MVar+\end{code}++\begin{code}+newtype Bottleneck = Bottleneck (MVar ())++newBottleneck :: IO (Bottleneck)+newBottleneck = liftM Bottleneck $ newMVar ()++constrict :: Bottleneck -> IO a -> IO a+constrict bottleneck action =+    do claim bottleneck+       result <- action+       release bottleneck+       return result++claim :: Bottleneck -> IO ()+claim (Bottleneck mv) = takeMVar mv++release :: Bottleneck -> IO ()+release (Bottleneck mv) = putMVar mv ()+\end{code}
+ RSAGL/BoundingBox.lhs view
@@ -0,0 +1,77 @@+\section{Bounding Boxes}++Implements simple bounding boxes and spheres.++\begin{code}+module RSAGL.BoundingBox+    (BoundingBox,+     Bound3D(..),+     minimalDistanceToBoundingBox)+   where++import RSAGL.Vector+import RSAGL.Interpolation+import RSAGL.Affine+import Data.List++data BoundingBox = BoundingBox {+    bbox_bottom, bbox_top, bbox_left, bbox_right, bbox_far, bbox_near :: !Double }+        deriving (Show)++class Bound3D a where+    boundingBox :: a -> BoundingBox++instance Bound3D Point3D where+    boundingBox (Point3D x y z) = BoundingBox { +                                      bbox_bottom = y,+                                      bbox_top = y,+                                      bbox_right = x,+                                      bbox_left = x,+                                      bbox_near = z,+                                      bbox_far = z }++instance Bound3D SurfaceVertex3D where+    boundingBox = boundingBox . sv3d_position++instance (Bound3D a) => Bound3D [a] where+    boundingBox [] = error "instance Bound3D [a], boundingBox: can't construct boundingBox []"+    boundingBox (x:xs) = foldr combineBoundingBoxes (boundingBox x) $ xs++instance Bound3D BoundingBox where+    boundingBox = id++instance AffineTransformable BoundingBox where+    transform m = boundingBox . transform m . boundingBoxToPointCloud++combineBoundingBoxes :: (Bound3D a,Bound3D b) => a -> b -> BoundingBox+combineBoundingBoxes x y =+    BoundingBox {+        bbox_left = min (bbox_left b1) (bbox_left b2),+        bbox_right = max (bbox_right b1) (bbox_right b2),+        bbox_bottom = min (bbox_bottom b1) (bbox_bottom b2),+        bbox_top = max (bbox_top b1) (bbox_top b2),+        bbox_near = min (bbox_near b1) (bbox_near b2),+        bbox_far = max (bbox_far b1) (bbox_far b2) }+    where b1 = boundingBox x+          b2 = boundingBox y++boundingBoxToPointCloud :: BoundingBox -> [Point3D]+boundingBoxToPointCloud bbox =+    [Point3D (bbox_left bbox)  (bbox_bottom bbox) (bbox_near bbox),+     Point3D (bbox_right bbox) (bbox_bottom bbox) (bbox_near bbox),+     Point3D (bbox_left bbox)  (bbox_top bbox)    (bbox_near bbox),+     Point3D (bbox_right bbox) (bbox_top bbox)    (bbox_near bbox),+     Point3D (bbox_left bbox)  (bbox_bottom bbox) (bbox_far bbox),+     Point3D (bbox_right bbox) (bbox_bottom bbox) (bbox_far bbox),+     Point3D (bbox_left bbox)  (bbox_top bbox)    (bbox_far bbox),+     Point3D (bbox_right bbox) (bbox_top bbox)    (bbox_far bbox)]++boundingCenterRadius :: BoundingBox -> (Point3D,Double)+boundingCenterRadius bbox = (lerp 0.5 (nlb,frt),distanceBetween nlb frt / 2)+    where nlb = Point3D (bbox_near bbox) (bbox_left bbox) (bbox_bottom bbox)+          frt = Point3D (bbox_near bbox) (bbox_left bbox) (bbox_bottom bbox)++minimalDistanceToBoundingBox :: Point3D -> BoundingBox -> Double+minimalDistanceToBoundingBox p bbox = distanceBetween p c - r+    where (c,r) = boundingCenterRadius bbox+\end{code}
+ RSAGL/Color.lhs view
@@ -0,0 +1,133 @@+\section{Color}++\begin{code}+{-# LANGUAGE MultiParamTypeClasses #-}+module RSAGL.Color+    (RGB(..),+     RGBA(..),+     rgba,+     rgba256,+     ColorClass(..),+     addRGB,+     scaleRGB,+     rgbToOpenGL,+     rgbaToOpenGL)+    where++import Control.Parallel.Strategies+import Graphics.Rendering.OpenGL.GL.VertexSpec+import RSAGL.AbstractVector+\end{code}++\texttt{addColor} paints a color on top of another color using the additive color system.  For example, \texttt{red `addColor` green == yellow}.++\texttt{filterColor} paints a color on top of another color using the subtractive color system (actually, multiplicative).  For example, \texttt{yellow `filterColor` green == green}, but \texttt{red `filterColor` green == black}.++\texttt{rgb256} works for colors specified in hexadecimal.  For example, X11 ForestGreen is \texttt{rgb256 0x22 0x8B 0x22}.++\begin{code}+data RGB = RGB { rgb_red, rgb_green, rgb_blue :: !Float }+    deriving (Eq,Show)++data RGBA = RGBA { rgba_a :: !Float, rgba_rgb :: !RGB }+    deriving (Eq,Show)++instance NFData RGB where++instance NFData RGBA where++class (AbstractVector c) => ColorClass c where+    rgb :: Float -> Float -> Float -> c+    rgb256 :: (Integral i) => i -> i -> i -> c+    alpha :: Float -> c -> RGBA+    alpha256 :: (Integral i) => i -> c -> RGBA+    clampColor :: c -> c+    mapRGB :: (Float -> Float) -> c -> c+    zipColor :: (Float -> Float -> Float) -> c -> c -> c+    brightness :: c -> Float+    colorToOpenGL :: c -> IO ()+    toRGBA :: c -> RGBA++instance ColorClass RGB where+    rgb = RGB+    rgb256 r g b = rgb (i2f256 r) (i2f256 g) (i2f256 b)+    alpha = RGBA+    alpha256 a = alpha (i2f256 a)+    clampColor = mapRGB (min 1 . max 0)+    mapRGB f (RGB r g b) = RGB (f r) (f g) (f b)+    zipColor f (RGB r1 g1 b1) (RGB r2 g2 b2) = RGB (f r1 r2) (f g1 g2) (f b1 b2)+    brightness (RGB r g b) = 0.2126 * r + 0.7152 * g + 0.0722 * b+    colorToOpenGL = rgbToOpenGL+    toRGBA = RGBA 1++instance ColorClass RGBA where+    rgb = rgba 1.0+    rgb256 = rgba256 255+    alpha x (RGBA a rgb_color) = RGBA (x*a) rgb_color+    alpha256 i (RGBA a rgb_color) = RGBA ((i2f256 i)*a) rgb_color+    clampColor (RGBA a rgb_color) = RGBA (min 1 $ max 0 a) $ clampColor rgb_color+    mapRGB f (RGBA a rgb_color) = RGBA a $ mapRGB f rgb_color+    zipColor f (RGBA a1 c1) (RGBA a2 c2) = RGBA (f a1 a2) (zipColor f c1 c2)+    brightness (RGBA a rgb_color) = brightness rgb_color * a+    colorToOpenGL = rgbaToOpenGL+    toRGBA = id++i2f256 :: (Integral i) => i -> Float+i2f256 = (/ 255) . fromIntegral++rgba :: Float -> Float -> Float -> Float -> RGBA+rgba r g b a = alpha a $ (rgb r g b :: RGB)++rgba256 :: (Integral i) => i -> i -> i -> i -> RGBA+rgba256 r g b a = alpha256 a $ (rgb256 r g b :: RGB)++addRGB :: RGB -> RGB -> RGB+addRGB = addColor++addColor :: (ColorClass c) => c -> c -> c+addColor = zipColor (+)++subColor :: (ColorClass c) => c -> c -> c+subColor = zipColor (-)++scaleRGB :: (ColorClass c) => Float -> c -> c+scaleRGB x = mapRGB (*x)++scaleRGBA :: Float -> RGBA -> RGBA+scaleRGBA x c = c { rgba_a = x * rgba_a c,+                    rgba_rgb = scaleRGB x (rgba_rgb c) }++rgbToOpenGL :: RGB -> IO ()+rgbToOpenGL (RGB r g b) = color $! Color4 r g b 1++rgbaToOpenGL :: RGBA -> IO ()+rgbaToOpenGL (RGBA a (RGB r g b)) = color $! Color4 r g b a++instance AbstractZero RGB where+    zero = rgb 0 0 0++instance AbstractAdd RGB RGB where+    add = addColor++instance AbstractSubtract RGB RGB where+    sub = subColor++instance AbstractScale RGB where+    scalarMultiply d = scaleRGB (realToFrac d)++instance AbstractVector RGB++instance AbstractZero RGBA where+    zero = rgba 0 0 0 0++instance AbstractAdd RGBA RGBA where+    add = addColor++instance AbstractSubtract RGBA RGBA where+    sub = subColor++instance AbstractScale RGBA where+    scalarMultiply d = scaleRGBA (realToFrac d)++instance AbstractVector RGBA+\end{code}
+ RSAGL/CoordinateSystems.lhs view
@@ -0,0 +1,222 @@+\section{Coordinate System Neutral Data}++Coordinate system neutral (\texttt{CSN}) data can transparently be imported into or exported from any affine coordinate system.  All \texttt{AffineTransformable} entities+can be represented in coordinate system neutral form.++\begin{code}++{-# OPTIONS_GHC -farrows -fglasgow-exts #-}++module RSAGL.CoordinateSystems+    (AffineTransformation,+     affine_identity,+     CoordinateSystem,+     Affine(..),+     affineOf,+     CoordinateSystemClass(..),+     NestedCoordinateSystemTransformer,+     root_coordinate_system,+     migrate,+     transformation,+     inverseTransformation,+     CSN,+     importCSN,+     exportCSN,+     remoteCSN,+     importM,+     exportM,+     remoteM,+     importA,+     importFromA,+     exportA,+     exportToA,+     exportCoordinateSystem,+     remoteA,+     transformM,+     transformA,+     Distance,+     measure,+     distance,+     distanceSquared)+    where++import Control.Arrow+import Control.Monad.State+import Control.Arrow.Operations+import RSAGL.Matrix+import RSAGL.Affine+import RSAGL.Vector+\end{code}++\subsection{Coordinate Systems}++A \texttt{CoordinateSystem} is the context by which coordinate system neutral data can be imported or exported.++\texttt{migrate} is the function that exports data from one coordinate system into another.++All \texttt{CoordinateSystems} are affine transformations of the \texttt{root\_coordinate\_system}.++\begin{code}+data CoordinateSystem = CoordinateSystem Matrix deriving (Show)++instance AffineTransformable CoordinateSystem where+    transform m (CoordinateSystem cs) = CoordinateSystem $ matrixMultiply m cs++migrate :: (AffineTransformable a) => CoordinateSystem -> CoordinateSystem -> a -> a+migrate (CoordinateSystem from) (CoordinateSystem to) = inverseTransform to . transform from++class CoordinateSystemClass csc where+    getCoordinateSystem :: csc -> CoordinateSystem+    storeCoordinateSystem :: CoordinateSystem -> csc -> csc++instance CoordinateSystemClass CoordinateSystem where+    getCoordinateSystem = id+    storeCoordinateSystem cs = const cs++instance (CoordinateSystemClass csc) => CoordinateSystemClass (a,csc) where+    getCoordinateSystem = getCoordinateSystem . snd+    storeCoordinateSystem cs = second (storeCoordinateSystem cs)++root_coordinate_system :: CoordinateSystem+root_coordinate_system = CoordinateSystem $ identityMatrix 4+\end{code}++\subsection{Abstract Affine Transformations}++\begin{code}+newtype Affine = Affine { affine_transformation :: forall a. AffineTransformable a => a -> a }+type AffineTransformation = Affine -> Affine++instance AffineTransformable Affine where+   transform m (Affine f) = Affine $ transform m . f++affine_identity :: AffineTransformation+affine_identity = id++affineOf :: AffineTransformation -> Affine+affineOf = ($ (Affine id))++affineTransformationToMatrix :: AffineTransformation -> Matrix+affineTransformationToMatrix f = affine_transformation (affineOf f) $ identityMatrix 4++transformation :: (AffineTransformable a) => AffineTransformation -> a -> a+transformation = transform . affineTransformationToMatrix++inverseTransformation :: (AffineTransformable a) => AffineTransformation -> a -> a+inverseTransformation = inverseTransform . affineTransformationToMatrix++postmultiplyTransformation :: AffineTransformation -> CoordinateSystem -> CoordinateSystem+postmultiplyTransformation f (CoordinateSystem cs) = CoordinateSystem $ cs `matrixMultiply` affineTransformationToMatrix f+\end{code}++\subsection{Coordinate System Neutral Data}++\texttt{exportCSN} exports any \texttt{AffineTransformable} data structure.  \texttt{importCSN} imports data into the local coordinate system.++\texttt{remoteCSN} operates as a functor to perform non-affine transformations over coordinate system neutral data.  Since any such function+is potentially non-affine, it must take place within the context of a \texttt{CoordinateSystem}.++Versions of each of these functions are defined for state monads and state arrows, where the state type implements \texttt{CoordinateSystemClass}.+\begin{code}+data CSN a = CSN a deriving (Show)++exportCSN :: (AffineTransformable a) => CoordinateSystem -> a -> CSN a+exportCSN (CoordinateSystem m) a = CSN $ transform m a++importCSN :: (AffineTransformable a) => CoordinateSystem -> CSN a -> a+importCSN (CoordinateSystem m) (CSN a) = inverseTransform m a++remoteCSN :: (AffineTransformable a,AffineTransformable b) => CoordinateSystem -> (a -> b) -> CSN a -> CSN b+remoteCSN context f = exportCSN context . f . importCSN context++exportM :: (Monad m,MonadState s m,CoordinateSystemClass s,AffineTransformable a) => a -> m (CSN a)+exportM a = liftM (flip exportCSN a) $ gets getCoordinateSystem++importM :: (Monad m,MonadState s m,CoordinateSystemClass s,AffineTransformable a) => CSN a -> m a+importM a = liftM (flip importCSN a) $ gets getCoordinateSystem++remoteM :: (Monad m,MonadState s m,CoordinateSystemClass s,AffineTransformable a,AffineTransformable b) => CoordinateSystem -> (a -> b) -> a -> m b+remoteM context f a = +    do b <- liftM (remoteCSN context f) $ exportM a+       importM b++exportA :: (Arrow arr,ArrowState s arr,CoordinateSystemClass s,AffineTransformable a) => arr a (CSN a)+exportA = proc a ->+    do cs <- arr getCoordinateSystem <<< fetch -< ()+       returnA -< exportCSN cs a++exportToA :: (Arrow arr,ArrowState s arr,CoordinateSystemClass s,AffineTransformable a) => CoordinateSystem -> arr a a+exportToA cs = exportA >>> arr (importCSN cs)++exportCoordinateSystem :: (Arrow arr,ArrowState s arr,CoordinateSystemClass s) => arr AffineTransformation CoordinateSystem+exportCoordinateSystem = exportToA root_coordinate_system <<< arr (flip transformation root_coordinate_system)++importA :: (Arrow arr,ArrowState s arr,CoordinateSystemClass s,AffineTransformable a) => arr (CSN a) a+importA = proc a ->+    do cs <- arr getCoordinateSystem <<< fetch -< ()+       returnA -< importCSN cs a++importFromA :: (Arrow arr,ArrowState s arr,CoordinateSystemClass s,AffineTransformable a) => CoordinateSystem -> arr a a+importFromA cs = arr (exportCSN cs) >>> importA++remoteA :: (Arrow arr,ArrowState s arr,CoordinateSystemClass s,AffineTransformable a,AffineTransformable b) => arr (CoordinateSystem, (a -> b), a) b+remoteA = proc (context,f,a) ->+    do csn <- exportA -< a+       importA -< remoteCSN context f csn+\end{code}++\subsection{Affine Transformation in State Monads and State Arrows}++\begin{code}+class NestedCoordinateSystemTransformer a where+    transformCoordinateSystem :: a -> CoordinateSystem -> CoordinateSystem++instance NestedCoordinateSystemTransformer Affine where+    transformCoordinateSystem (Affine f) = postmultiplyTransformation f++instance NestedCoordinateSystemTransformer CoordinateSystem where+    transformCoordinateSystem cs = const cs++transformM :: (Monad m,MonadState s m,CoordinateSystemClass s,+               NestedCoordinateSystemTransformer cst) => cst -> m a -> m a+transformM ncst action =+    do s <- liftM getCoordinateSystem get+       modify (storeCoordinateSystem (transformCoordinateSystem ncst s))+       a <- action+       modify (storeCoordinateSystem s)+       return a++transformA :: (Arrow arr,ArrowState s arr,CoordinateSystemClass s,+               NestedCoordinateSystemTransformer cst) => arr a b -> arr (cst,a) b+transformA action = proc (ncst,a) ->+    do s <- fetch -< ()+       store -< storeCoordinateSystem (transformCoordinateSystem ncst $ getCoordinateSystem s) s+       b <- action -< a+       s' <- fetch -< ()+       store -< storeCoordinateSystem (getCoordinateSystem s) s'+       returnA -< b+\end{code}++\subsection{Coordinate System Neutral Distance}++Since we can't make scalar values \texttt{AffineTransformable}, but it is useful to measure distances in a space that is subject to affine transformations,+we define distance in terms of the elements being measured.++\begin{code}+data Distance = forall p. (AffineTransformable p,Xyz p) => Distance p p++measure :: (AffineTransformable p,Xyz p) => p -> p -> Distance+measure = Distance++distance :: Distance -> Double+distance (Distance p1 p2) = distanceBetween p1 p2++distanceSquared :: Distance -> Double+distanceSquared (Distance p1 p2) = distanceBetweenSquared p1 p2++instance AffineTransformable Distance where+    transform m (Distance p1 p2) = Distance (transform m p1) (transform m p2)+    scale v (Distance p1 p2) = Distance (scale v p1) (scale v p2)+    rotate a v (Distance p1 p2) = Distance (rotate a v p1) (rotate a v p2)+    translate v (Distance p1 p2) = Distance (translate v p1) (translate v p2)+\end{code}
+ RSAGL/Curve.lhs view
@@ -0,0 +1,155 @@+\section{Curves}++A curve is a one-dimensional figure in an arbitrary space.  The Curve typeclass allows an arbitrary curve to be sampled so that+it can be rendered iteratively in OpenGL.  The Differentiable typeclass allows a Curve to be transformed into its derivative.++\begin{code}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module RSAGL.Curve+    (Curve,+     zipCurve,+     iterateCurve,+     transposeCurve,+     curve,+     Surface,+     surface,+     wrapSurface,+     unwrapSurface,+     pretransformCurve,+     pretransformCurve2,+     transposeSurface,+     zipSurface,+     iterateSurface,+     halfIterateSurface,+     pretransformSurface,+     flipTransposeSurface,+     uv_identity,+     surfaceDerivative,+     curveDerivative,+     surfaceNormals3D)+    where++import Control.Arrow hiding (pure)+import RSAGL.Vector+import RSAGL.Auxiliary+import RSAGL.Affine+import Data.List+import Control.Parallel.Strategies+import Control.Applicative+import RSAGL.AbstractVector+\end{code}++\subsection{The Curve}++A \texttt{Curve} is either a simple parametric curve, or a derivative of a parametric curve.  To approximate the derivative of a curve, we require a subtraction function that yields the derivative's type and a scalar multiplication function that operates on the base type.++We also allow two curves to be zipped together.++We can take the derivative of a curve an arbitrary number of times, but this will run up against the precision of the underlying data types, including Double.++\begin{code}+type CurveF a = (Double,Double) -> a+type SurfaceF a = CurveF (CurveF a)+newtype Curve a = Curve { fromCurve :: CurveF a }++instance Functor Curve where+   fmap g (Curve f) = Curve $ g . f++instance Applicative Curve where+    pure a = Curve $ const a+    f <*> a = zipCurve ($) f a++instance (AffineTransformable a) => AffineTransformable (Curve a) where+    scale v = fmap (scale v)+    translate v = fmap (translate v)+    rotate vector angle = fmap (rotate vector angle)+    transform m = fmap (transform m)++instance NFData (Curve a) where+    rnf (Curve f) = seq f ()++sampleCurve :: Curve a -> Double -> Double -> a+sampleCurve (Curve f) = curry f++iterateCurve :: Integer -> Curve x -> [x]+iterateCurve n c = map f $ zeroToOne n+    where f = sampleCurve c (0.25/fromInteger n)++zipCurve :: (x -> y -> z) -> Curve x -> Curve y -> Curve z+zipCurve f (Curve x) (Curve y) = Curve $ \hu -> f (x hu) (y hu)++mapCurve :: (CurveF a -> CurveF a) -> Curve a -> Curve a+mapCurve f = Curve . f . fromCurve++mapCurve2 :: (SurfaceF a -> SurfaceF a) -> Curve (Curve a) -> Curve (Curve a)+mapCurve2 f = Curve . (Curve .) . f . (fromCurve .) . fromCurve++pretransformCurve :: (Double -> Double) -> Curve a -> Curve a+pretransformCurve g = mapCurve (\f (h,u) -> f (h,g u))++pretransformCurve2 :: (Double -> Double) -> (Double -> Double) -> Curve (Curve a) -> Curve (Curve a)+pretransformCurve2 fx fy = mapCurve2 $ (\f x y -> f (second fx x) (second fy y))++transposeCurve :: Curve (Curve a) -> Curve (Curve a)+transposeCurve = mapCurve2 flip++curve :: (Double -> a) -> Curve a+curve = Curve . uncurry . const+\end{code}++\subsection{Surfaces}++\begin{code}+newtype Surface a = Surface (Curve (Curve a)) deriving (NFData,AffineTransformable)++surface :: (Double -> Double -> a) -> Surface a+surface f = Surface $ curve (\x -> curve $ flip f x)++wrapSurface :: Curve (Curve a) -> Surface a+wrapSurface = Surface++unwrapSurface :: Surface a -> Curve (Curve a)+unwrapSurface (Surface s) = s++transposeSurface :: Surface a -> Surface a+transposeSurface (Surface s) = Surface $ transposeCurve s++iterateSurface :: (Integer,Integer) -> Surface a -> [[a]]+iterateSurface (u,v) (Surface s) = map (iterateCurve u) $ iterateCurve v s++halfIterateSurface :: Integer -> Surface a -> [Curve a]+halfIterateSurface u = iterateCurve u . unwrapSurface++instance Functor Surface where+    fmap f (Surface x) = Surface $ fmap (fmap f) x++instance Applicative Surface where+    pure a = surface (const $ const a)+    f <*> a = zipSurface ($) f a++zipSurface :: (x -> y -> z) -> Surface x -> Surface y -> Surface z+zipSurface f (Surface x) (Surface y) = Surface $ zipCurve (zipCurve f) x y++pretransformSurface :: (Double -> Double) -> (Double -> Double) -> Surface a -> Surface a+pretransformSurface fx fy = Surface . pretransformCurve2 fx fy . unwrapSurface++flipTransposeSurface :: Surface a -> Surface a+flipTransposeSurface = pretransformSurface id (1-) . transposeSurface++uv_identity :: Surface (Double,Double)+uv_identity = surface (curry id)+\end{code}++\subsection{Taking the Derivative of a Curve}++\begin{code}+curveDerivative :: (AbstractSubtract p v,AbstractScale v) => Curve p -> Curve v+curveDerivative (Curve f) = Curve $ \(h,u) -> scalarMultiply (recip $ 2 * h) $ f (h/2,u+h) `sub` f (h/2,u-h)++surfaceDerivative :: (AbstractSubtract p v,AbstractScale v) => Surface p -> Surface (v,v)+surfaceDerivative s = zipSurface (,) (curvewiseDerivative s) (transposeSurface $ curvewiseDerivative $ transposeSurface s)+    where curvewiseDerivative (Surface t) = Surface $ fmap curveDerivative t++surfaceNormals3D :: Surface Point3D -> Surface SurfaceVertex3D+surfaceNormals3D s = SurfaceVertex3D <$> s <*> fmap (vectorNormalize . uncurry crossProduct) (surfaceDerivative s)+\end{code}
+ RSAGL/CurveExtras.lhs view
@@ -0,0 +1,76 @@+\section{Specific and Interpolated Curves}++\begin{code}+module RSAGL.CurveExtras+    (circleXY,+     regularPolygon,+     linearInterpolation,+     loopedLinearInterpolation,+     smoothCurve,+     loopCurve)+    where++import RSAGL.Curve+import RSAGL.Interpolation+import RSAGL.Vector+import RSAGL.Angle+import RSAGL.Auxiliary+import RSAGL.AbstractVector+import Data.Fixed+import RSAGL.Affine+\end{code}++\subsection{Circles}++\begin{code}+circleXY :: Curve Point3D+circleXY = curve $ \u_ -> let u = fromRotations u_ in Point3D (cosine u) (sine u) 0+\end{code}++\subsection{Regular Polygons}++A regular polygon, centered at the origin, in the XY plane.++\begin{code}+regularPolygon :: Integer -> Curve Point3D+regularPolygon n = loopedLinearInterpolation $ map (flip rotateZ (Point3D 0 1 0) . fromRotations) $ zeroToOne n+\end{code}++\subsection{Piecewise Length Normalization}++\begin{code}+normalizePolyline :: (AbstractSubtract p v,AbstractMagnitude v) => [p] -> [(Double,p)]+normalizePolyline pts = zip (map (/ total_dist) accumulated_dists) pts+    where dists = map (uncurry abstractDistance) $ doubles pts+          total_dist = last accumulated_dists+          accumulated_dists = scanl (+) 0 dists+\end{code}++\subsection{Interpolated Curves}++\begin{code}+linearInterpolation :: (AbstractSubtract p v,AbstractAdd p v,AbstractMagnitude v,AbstractScale v) => [p] -> Curve p+linearInterpolation = curve . lerpMap . normalizePolyline++loopedLinearInterpolation :: (AbstractSubtract p v,AbstractAdd p v,AbstractMagnitude v,AbstractScale v) => [p] -> Curve p+loopedLinearInterpolation = loopCurve . linearInterpolation . (\a -> last a:a)+\end{code}++\subsection{Smoothing Curves}++\texttt{smoothCurve i h} takes i samples of an h-long piece of a curve at each point to smooth it.++\begin{code}+smoothCurve :: (AbstractAdd p v,AbstractSubtract p v,AbstractVector v) => Integer -> Double -> Curve p -> Curve p+smoothCurve i h c = curve (\u -> abstractAverage $ iterateCurve i $ pretransformCurve (flip lerp (u-h/2,u+h/2)) c)+\end{code}++\subsection{Looping Curves}++Curves can be forced to loop with a pre-transformation, however, if the curve does not evaluate to the same value at \texttt{u = 0} and \texttt{u = 1},+this creates a discontinuity in the curve.++\begin{code}+loopCurve :: Curve a -> Curve a+loopCurve = pretransformCurve (`mod'` 1.0)+\end{code}
+ RSAGL/Deformation.lhs view
@@ -0,0 +1,42 @@+\section{Non-affine Transformations}++The \texttt{Deformation} typeclass describes any affine or non-affine transformation.++\texttt{Deformation}s fall into two catagories: those that compute their own surface normals and those that don't.++\begin{code}+{-# OPTIONS_GHC -fglasgow-exts #-}++module RSAGL.Deformation+    (Deformation,DeformationClass(..),constrain)+    where++import RSAGL.Vector+import RSAGL.Matrix+import RSAGL.Affine+import RSAGL.Auxiliary++type Deformation = Either (SurfaceVertex3D -> Point3D) (SurfaceVertex3D -> SurfaceVertex3D)++class DeformationClass a where+    deformation :: a -> Deformation++instance (DeformationClass a,DeformationClass b) => DeformationClass (Either a b) where+    deformation = either deformation deformation++instance DeformationClass Matrix where+    deformation m = Right (\s -> transform m s)++instance DeformationClass (Point3D -> Point3D) where+    deformation f = Left (\(SurfaceVertex3D p _) -> f p)++instance DeformationClass (Point3D -> SurfaceVertex3D) where+    deformation f = Right (\(SurfaceVertex3D p _) -> f p)++instance DeformationClass (SurfaceVertex3D -> Point3D) where+    deformation f = Left f++instance DeformationClass (SurfaceVertex3D -> SurfaceVertex3D) where+    deformation f = Right f+\end{code}+
+ RSAGL/Edge.lhs view
@@ -0,0 +1,132 @@+\section{Edge Detection in FRP programs: RSAGL.Edge}++Edge detection works for all inputs that implement Eq, and is simply a mechanism to observe when a value changes.++\begin{code}+{-# OPTIONS_GHC -farrows -fglasgow-exts #-}++module RSAGL.Edge +    (Edge(..),+     edge,+     edgeBy,+     edgep,+     edgeFold,+     edgeFoldBy,+     edgeMap,+     edgeMapBy,+     history,+     sticky,+     initial,+     started)+    where++import RSAGL.AbstractVector+import RSAGL.FRP as FRP+import RSAGL.SwitchedArrow as SwitchedArrow+import RSAGL.Time+import Control.Arrow+import Control.Arrow.Operations+import Control.Arrow.Transformer+\end{code}++\subsection{Edge data structure}++\begin{code}+data Edge a = Edge { edge_previous :: !a,+                     edge_next :: !a,+                     edge_changed :: !Time }+              deriving (Eq,Show)+\end{code}++\subsection{Edge detectors}++\texttt{edge} watches an input and answers an Edge data structure.++\begin{code}+edge :: (Arrow a,ArrowChoice a,ArrowApply a,Eq e) => FRPX any t i o a e (Edge e)+edge = edgeBy (==)++edgeBy :: (Arrow a,ArrowChoice a,ArrowApply a) => (e -> e -> Bool) -> FRPX any t i o a e (Edge e)+edgeBy predicate = proc e ->+    do t <- threadTime -< ()+       edgeFoldBy (\x y -> predicate (fst x) (fst y)) (\(e,t) -> Edge e e t) edgeBy' -< (e,t)+  where edgeBy' (e,t) old_edge = Edge { edge_previous = edge_next old_edge, edge_next = e, edge_changed = t }+\end{code}++\texttt{edgep} answers True exactly once each time a value changes.++\begin{code}+edgep :: (Arrow a,ArrowChoice a,ArrowApply a,Eq e) => FRPX any t i o a e Bool+edgep = FRP.statefulContext $ SwitchedArrow.withState edgep' id+    where edgep' = proc i ->+              do old_value <- lift fetch -< ()+                 lift store -< i+                 returnA -< i /= old_value+\end{code}++\subsection{Edge folds}++\texttt{edgeFold} combines each unique input into a cumulative value using a folding function.+The folding function must have some way to discard old edges, or it will represent a space leak.++\begin{code}+edgeFold :: (Arrow a,ArrowChoice a,ArrowApply a,Eq j) => (j -> p) -> (j -> p -> p) -> FRPX any t i o a j p+edgeFold = edgeFoldBy (==)++edgeFoldBy :: (Arrow a,ArrowChoice a,ArrowApply a) => (j -> j -> Bool) -> (j -> p) -> (j -> p -> p) -> FRPX any t i o a j p+edgeFoldBy predicate initialF f = FRP.statefulContext $ SwitchedArrow.withState edgeFold' (\i -> (i,initialF i))+    where edgeFold' = proc i ->+              do (old_raw,old_folded) <- lift fetch -< ()+                 let (new_raw,new_folded) = if old_raw `predicate` i+                                            then (old_raw,old_folded)+                                            else (i,f i old_folded)+                 lift store -< seq new_raw $ seq new_folded $ (new_raw,new_folded)+                 returnA -< new_folded+\end{code}++\texttt{history} answers a history of edges for a value.  The Time parameter indicates the maximum age of an edge, +after which it can be forgotten.++\begin{code}+history :: (Arrow a,ArrowChoice a,ArrowApply a,Eq e) => Time -> FRPX any t i o a e [Edge e]+history t = edgeFold (\x -> [x]) history' <<< edge+    where history' n h = n : takeWhile ((>= edge_changed n `sub` t) . edge_changed) h+\end{code}++\texttt{edgeMap} is equivalent to \texttt{arr}, but more efficient, possibly, because the mapping function is only +applied when the input changes.++\texttt{edgeMap} should actually be more efficient only when: the cost of the mapping function is high, the cost+of comparing two equal values is low, and the input changes infrequently.++\begin{code}+edgeMap :: (Arrow a,ArrowChoice a,ArrowApply a,Eq j) => (j -> p) -> FRPX any t i o a j p+edgeMap f = edgeMapBy (==) f++edgeMapBy :: (Arrow a,ArrowChoice a,ArrowApply a,Eq j) => (j -> j -> Bool) -> (j -> p) -> FRPX any t i o a j p+edgeMapBy predicate f = edgeFoldBy predicate f (const . f)+\end{code}++\texttt{sticky} remembers the most recent value of an input that satisfies some criteria.++\begin{code}+sticky :: (Arrow a,ArrowChoice a,ArrowApply a) => (x -> Bool) -> x -> FRPX any t i o a x x+sticky criteria initial_value = edgeFoldBy (const $ const False) (const initial_value) (\new old -> if criteria new then new else old)+\end{code}++\subsection{Remembering the initial value of an input}++\texttt{initial} answers the first value that an input ever has (during this instance of this thread).++\begin{code}+initial :: (Arrow a,ArrowChoice a,ArrowApply a,Eq e) => FRPX any t i o a e e+initial = edgeMapBy (const $ const True) id+\end{code}++\texttt{started} is the \texttt{absoluteTime} at which this thread started.++\begin{code}+started :: (Arrow a,ArrowChoice a,ArrowApply a) => FRPX any t i o a () Time+started = initial <<< absoluteTime+\end{code}+
+ RSAGL/Extrusion.lhs view
@@ -0,0 +1,39 @@+\section{Extrusions}++\begin{code}+module RSAGL.Extrusion+    (extrude,+     extrudeTube,+     extrudePrism)+    where++import RSAGL.Curve+import RSAGL.CurveExtras+import RSAGL.Vector+import RSAGL.Affine+import Control.Applicative+import RSAGL.CoordinateSystems+import RSAGL.Orthagonal+\end{code}++\subsection{The General Extrusion}++\texttt{extrude} takes a vector or point indicating an orientation, a curve representing the spine of the extrusion, and+a curve representing the loop in the x-y plane.++\begin{code}+extrude :: Curve (Either Point3D Vector3D) -> Curve Point3D -> Curve (Curve Point3D) -> Surface Point3D+extrude upish spine loop = wrapSurface $ transformation <$> (modelLookAt <$> spine <*> (forward <$> Right <$> spine') <*> (up <$> upish)) <*> loop+    where spine' = curveDerivative spine+\end{code}++\subsection{Specific Extrusions}++\begin{code}+extrudeTube :: Curve Double -> Curve Point3D -> Surface Point3D+extrudeTube radius spine = extrude upish spine (scale' <$> radius <*> pure circleXY)+    where upish = pure $ Right $  newell $ iterateCurve 25 spine++extrudePrism :: Vector3D -> (Point3D,Double) -> (Point3D,Double) -> Curve Point3D -> Surface Point3D+extrudePrism upish (a,ra) (b,rb) c = extrude (pure $ Right $ upish) (linearInterpolation [a,b]) (flip scale' c <$> linearInterpolation [ra,rb])+\end{code}
+ RSAGL/FRP.lhs view
@@ -0,0 +1,265 @@+\section{The Functional Reactive Programming Arrow: RSAGL.FRP}++Functional Reactive Programming is a paradigm within functional programming.+\footnote{For more information about functional reactive programming in haskell, see http://www.haskell.org/frp/}+In particular, the RSAGL FRP arrow is inspired by YAMPA.+\footnote{http://www.haskell.org/yampa/}+The RSAGL FRP arrow is different from YAMPA in several ways.  Most significantly, it is an arrow transformer.++FRP includes all of the switching and threading operations documented in SwitchedArrow and ThreadedArrow,+and the arrow-embedding operations from FRPBase.++\begin{code}++{-# OPTIONS_GHC -fglasgow-exts -farrows -fallow-undecidable-instances #-}++module RSAGL.FRP+    (FRPX,+     FRP1,+     Threaded,+     FRP,+     RSAGL.FRP.switchContinue,+     RSAGL.FRP.switchTerminate,+     RSAGL.FRP.spawnThreads,+     RSAGL.FRP.killThreadIf,+     RSAGL.FRP.statefulContext,+     RSAGL.FRP.threadIdentity,+     frpTest,+     FRPProgram,+     newFRPProgram,+     newFRP1Program,+     updateFRPProgram,+     integral,+     derivative,+     integralRK4,+     integralRK4',+     absoluteTime,+     threadTime,+     frpContext,+     frp1Context,+     RSAGL.FRP.withState,+     RSAGL.FRP.withExposedState,+     ThreadedArrow.ThreadIdentity,+     ThreadedArrow.nullaryThreadIdentity,+     ThreadedArrow.maybeThreadIdentity,+     ThreadedArrow.unionThreadIdentity,+     whenJust)+    where++import RSAGL.AbstractVector+import RSAGL.Time+import RSAGL.StatefulArrow as StatefulArrow+import RSAGL.SwitchedArrow as SwitchedArrow+import RSAGL.ThreadedArrow as ThreadedArrow+import RSAGL.FRPBase as FRPBase+import RSAGL.RK4+import Control.Arrow+import Control.Arrow.Operations+import Control.Arrow.Transformer+import Control.Arrow.Transformer.State+import Data.Maybe++data FRPState = FRPState { frpstate_absolute_time :: Time,+                           frpstate_delta_time :: Time }++data Threaded++type FRP = FRPX Threaded ()+type FRP1 = FRPX () ()++newtype FRPX k t i o a j p = FRP (FRPBase t i o (StateArrow FRPState a) j p)++fromFRP :: FRPX k t i o a j p -> FRPBase t i o (StateArrow FRPState a) j p+fromFRP (FRP frp) = frp++instance (Arrow a,ArrowChoice a) => Arrow (FRPX k t i o a) where+    (FRP a) >>> (FRP b) = FRP $ a >>> b+    arr = FRP . arr+    first (FRP f) = FRP $ first f++instance (Arrow a,ArrowChoice a) => ArrowTransformer (FRPX k t i o) a where+    lift = FRP . lift . lift++instance (ArrowState s a,ArrowChoice a) => ArrowState s (FRPX k t i o a) where+    fetch = lift fetch+    store = lift store++switchContinue :: (Arrow a,ArrowChoice a,ArrowApply a) =>+                  FRPX any t i o a (Maybe (FRPX any t i o a i o),i) i+switchContinue = proc (s,i) -> FRP $ FRPBase.switchContinue -< (fmap fromFRP s,i)++switchTerminate :: (Arrow a,ArrowChoice a) =>+                   FRPX any t i o a (Maybe (FRPX any t i o a i o),o) o+switchTerminate = proc (s,o) -> FRP $ FRPBase.switchTerminate -< (fmap fromFRP s,o)++spawnThreads :: (Arrow a,ArrowChoice a,ArrowApply a) => FRPX Threaded t i o a [(t,FRPX Threaded t i o a i o)] ()+spawnThreads = proc threads -> FRP $ FRPBase.spawnThreads -< map (second fromFRP) threads++killThreadIf :: (Arrow a,ArrowChoice a,ArrowApply a) => FRPX Threaded t i o a Bool ()+killThreadIf = FRP $ FRPBase.killThreadIf++threadIdentity :: (ArrowChoice a) => FRPX any t i o a () t+threadIdentity = FRP $ FRPBase.threadIdentity+\end{code}++\subsection{Embedding one FRP instance in another}++The frpContext combinator allows a differently-typed FRP thread group to be embedded in another.  +Using frpContext, a thread can instantiate a group of threads that die whenever the calling thread +dies or switches.  That is, the thread group is part of the state of the calling thread.++\begin{code}+frpContext :: (Arrow a,ArrowChoice a,ArrowApply a) => +    (forall x. j -> [(t,x)] -> [(t,(p,x))] -> [x]) -> +    [(t,FRPX Threaded t j p a j p)] -> FRPX any u i o a j [(t,p)]+frpContext manageThreads = FRP . FRPBase.frpBaseContext manageThreads . map (second fromFRP)++frp1Context :: (Arrow a,ArrowChoice a,ArrowApply a) => +    FRP1 j p a j p -> FRPX any t i o a j p+frp1Context (FRP frp1_thread) = arr (fromSingletonList (error "frp1Context: non-singular list") . map snd) <<< +                                frpContext ThreadedArrow.nullaryThreadIdentity [((),FRP frp1_thread)]++fromSingletonList :: ([x] -> x) -> [x] -> x+fromSingletonList nonsingleF list = case list of+                               [x] -> x+			       xs -> nonsingleF xs++\end{code}++\subsection{Embedding a StatefulArrow in an FRP arrow}++\begin{code}+statefulContext :: (Arrow a,ArrowChoice a,ArrowApply a) => StatefulArrow a j p -> FRPX any t i o a j p+statefulContext = FRP . FRPBase.statefulContext . statefulTransform lift++statefulContext_ :: (Arrow a,ArrowChoice a,ArrowApply a) => +                        StatefulArrow a (j,FRPState) (p,FRPState) -> FRPX any t i o a j p+statefulContext_ sa = proc i ->+    do frpstate <- FRP (lift fetch) -< ()+       (o,frpstate') <- RSAGL.FRP.statefulContext sa -< (i,frpstate)+       FRP (lift store) -< frpstate'+       returnA -< o+\end{code}++\subsection{Allowing underlying state}++\begin{code}+withState :: (Arrow a,ArrowChoice a,ArrowApply a) => +   (forall x. j -> [(t,x)] -> [(t,(p,x))] -> [x]) ->               +   [(t,FRPX Threaded t j p (StateArrow s a) j p)] -> s -> FRPX any u i o a j [(t,p)]+withState manageThreads threads s = statefulContext_ $+    StatefulArrow.withState (RSAGL.FRP.statefulForm manageThreads threads) s++withExposedState :: (Arrow a,ArrowChoice a,ArrowApply a) =>+    (forall x. j -> [(t,x)] -> [(t,(p,x))] -> [x]) ->+    [(t,FRPX Threaded t j p (StateArrow s a) j p)] -> FRPX any u i o a (j,s) ([(t,p)],s)+withExposedState manageThreads threads = RSAGL.FRP.statefulContext_ $+        (arr $ \((i,s),frpstate) -> ((i,frpstate),s))+    >>> (StatefulArrow.withExposedState $ RSAGL.FRP.statefulForm manageThreads threads)+    >>> (arr $ \((o,frpstate'),s') -> ((o,s'),frpstate'))+\end{code}++\subsection{Invoking an FRP program}++\begin{code}+statefulForm :: (Arrow a,ArrowChoice a,ArrowApply a) =>+    (forall x. i -> [(t,x)] -> [(t,(o,x))] -> [x]) ->+    [(t,FRPX Threaded t i o a i o)] -> StatefulArrow a (i,FRPState) ([(t,o)],FRPState)+statefulForm manageThreads = StatefulArrow.withExposedState . FRPBase.statefulForm manageThreads . map (second fromFRP)++frpTest :: [FRP i o (->) i o] -> [i] -> [[o]]+frpTest frps is = map (map snd . fst) $ runStateMachine (RSAGL.FRP.statefulForm nullaryThreadIdentity $ (map $ \x -> ((),x)) frps) $+                      zip is frp_test_states++frp_test_states :: [FRPState]+frp_test_states = map numToState [0.0,0.1..]+    where numToState x = FRPState { frpstate_absolute_time = fromSeconds $ 1242341239 + x,+                                    frpstate_delta_time = fromSeconds (if x==0 then 0 else 0.1) }++data FRPProgram a i o = FRPProgram (StatefulArrow a (i,FRPState) ([o],FRPState)) (Maybe Time)++newFRPProgram :: (Arrow a,ArrowChoice a,ArrowApply a) => +    (forall x. i -> [(t,x)] -> [(t,(o,x))] -> [x]) ->+    [(t,FRPX Threaded t i o a i o)] -> FRPProgram a i [(t,o)]+newFRPProgram manageThreads frps = newFRP1Program (frpContext manageThreads frps)++newFRP1Program :: (Arrow a,ArrowChoice a,ArrowApply a) => FRP1 i o a i o -> FRPProgram a i o+newFRP1Program frp1 = FRPProgram (RSAGL.FRP.statefulForm nullaryThreadIdentity [((),frp1Context frp1)] >>> arr (first $ map snd)) Nothing++updateFRPProgram :: (Arrow a,ArrowChoice a,ArrowApply a) => FRPProgram a i o -> a (i,Time) (o,FRPProgram a i o)+updateFRPProgram (FRPProgram sa old_run) = proc (i,new_t) ->+    do let old_t = fromMaybe new_t old_run+       ((new_os,_),new_stateful_arrow) <- runStatefulArrow sa -< (i, FRPState { frpstate_absolute_time = new_t, frpstate_delta_time = (new_t `sub` old_t) })+       returnA -< (fromSingletonList (error "updateFRPProgram: non-singular list") new_os, FRPProgram new_stateful_arrow (Just new_t))+\end{code}++\subsection{Timelike operations on continuous values.}++\texttt{integral} and \texttt{derivative} respectively take the integral or derivative of a+continuous value.++\begin{code}+derivative :: (Arrow a,ArrowChoice a,ArrowApply a,AbstractSubtract p v,AbstractVector v) => FRPX any t i o a p (Rate v)+derivative = accumulate (error "derivative: undefined")+    (\old_value new_value old_rate _ delta_t _ -> if delta_t == zero+        then old_rate+        else (new_value `sub` old_value) `per` delta_t)+    zero++integral :: (Arrow a,ArrowChoice a,ArrowApply a,AbstractVector v) => v -> FRPX any t i o a (Rate v) v+integral = accumulate (error "integral: undefined")+    (\old_rate new_rate old_accum _ delta_t _ -> old_accum `add` ((scalarMultiply (recip 2) $ new_rate `add` old_rate) `over` delta_t))++integralRK4 :: (Arrow a,ArrowChoice a,ArrowApply a,AbstractVector v) => Frequency -> (p -> v -> p) -> p -> FRPX any t i o a (Time -> p -> Rate v) p+integralRK4 f addPV = accumulate f (\_ diffF p abs_t delta_t -> integrateRK4 addPV diffF p (abs_t `sub` delta_t) abs_t)++integralRK4' :: (Arrow a,ArrowChoice a,ArrowApply a,AbstractVector v) => Frequency -> (p -> v -> p) -> (p,Rate v) -> +                FRPX any t x y a (Time -> p -> Rate v -> Acceleration v) (p,Rate v)+integralRK4' f addPV = accumulate f (\_ diffF p abs_t delta_t -> integrateRK4' addPV diffF p (abs_t `sub` delta_t) abs_t)+\end{code}++The \texttt{accumulate} function implements practically any time-stepping algorithm as though it were continuous.+The accumulation function is of the form: old\_input new\_input old\_accumulation absolute\_time delta\_time number\_of\_intervals.++\begin{code}+accumulate :: (Arrow a,ArrowChoice a,ArrowApply a) => Frequency -> (i -> i -> o -> Time -> Time -> Integer -> o) -> o -> FRPX any t x y a i o+accumulate frequency accumF initial_value = statefulContext_ $ SwitchedArrow.withState accumulate_ (\(i,_) -> (i,initial_value))+    where accumulate_ = proc (new_input,frpstate@FRPState{ frpstate_absolute_time=abs_t, frpstate_delta_time=delta_t }) -> +              do (old_input,old_accum) <- lift fetch -< ()+                 let new_accum = accumF old_input new_input old_accum abs_t delta_t (ceiling $ toSeconds delta_t / toSeconds (interval frequency))+                 lift store -< (new_input,new_accum)+                 returnA -< (new_accum,frpstate)+\end{code}++\subsection{Getting the time}++absoluteTime answers the time relative to some fixed point (the epoch).++\begin{code}+absoluteTime :: (Arrow a,ArrowChoice a) => FRPX any t i o a () Time+absoluteTime = (arr frpstate_absolute_time) <<< FRP (lift fetch)+\end{code}++threadTime answers the time since the current thread first executed.++\begin{code}+threadTime :: (Arrow a,ArrowChoice a,ArrowApply a) => FRPX any t i o a () Time+threadTime = integral zero <<< arr (const $ perSecond $ fromSeconds 1)+\end{code}++\subsection{Additional Combinators}++\texttt{whenJust} permits some computations on \texttt{Maybe} values, but the implcit state of+the computation is reset whenever \texttt{whenJust} recieves \texttt{Nothing}.  If this is not+your intention, you might use \texttt{whenJust <<< sticky isJust Nothing}.++\begin{code}+whenJust :: (ArrowChoice a,ArrowApply a) => (forall x y. FRP1 x y a j p) -> FRPX any t i o a (Maybe j) (Maybe p)+whenJust actionA = frp1Context whenJust_+    where whenJust_ = proc i ->+              do RSAGL.FRP.switchContinue -< (maybe (Just whenNothing_) (const Nothing) i,i)+	         arr (Just) <<< actionA -< fromMaybe (error "whenJust: impossible case") i+	  whenNothing_ = proc i ->+	      do RSAGL.FRP.switchContinue -< (fmap (const whenJust_) i,i)+	         returnA -< Nothing+\end{code}
+ RSAGL/FRPBase.lhs view
@@ -0,0 +1,133 @@+\section{RSAGL.FRPBase}++The FRPBase arrow is a composite of the Stateful and Threaded arrows intended to support functional reactive programming.++\begin{code}+{-# OPTIONS_GHC -fglasgow-exts -farrows #-}++module RSAGL.FRPBase+    (FRPBase,+     RSAGL.FRPBase.switchContinue,+     RSAGL.FRPBase.switchTerminate,+     RSAGL.FRPBase.spawnThreads,+     RSAGL.FRPBase.killThreadIf,+     RSAGL.FRPBase.threadIdentity,+     RSAGL.FRPBase.frpBaseContext,+     RSAGL.FRPBase.withState,+     RSAGL.FRPBase.withExposedState,+     RSAGL.FRPBase.statefulContext,+     RSAGL.FRPBase.statefulForm)+    where++import Data.Monoid+import Control.Arrow+import Control.Arrow.Transformer+import Control.Arrow.Transformer.State+import RSAGL.StatefulArrow as StatefulArrow+import RSAGL.ThreadedArrow as ThreadedArrow+import RSAGL.ArrowTransformerOptimizer+\end{code}++FRPBase is a composite arrow in which the StatefulArrow is layered on top of the ThreadedArrow.++\begin{code}+newtype FRPBase t i o a j p = FRPBase (+    ArrowTransformerOptimizer StatefulArrow (ThreadedArrow t i o a) j p)++fromFRPBase :: FRPBase t i o a j p -> (StatefulArrow (ThreadedArrow t i o a) j p)+fromFRPBase (FRPBase a) = collapseArrowTransformer a++instance (ArrowChoice a) => Arrow (FRPBase t i o a) where+    (>>>) (FRPBase x) (FRPBase y) = FRPBase $ x >>> y+    arr = FRPBase . arr+    first (FRPBase f) = FRPBase $ first f++instance (ArrowChoice a) => ArrowTransformer (FRPBase t i o) a where+    lift = FRPBase . lift . lift++switchContinue :: (Arrow a,ArrowChoice a,ArrowApply a) => FRPBase t i o a (Maybe (FRPBase t i o a i o),i) i+switchContinue = proc (thread,i) -> +    do FRPBase $ lift $ ThreadedArrow.switchContinue -< (fmap (statefulThread . fromFRPBase) thread,i)++switchTerminate :: (Arrow a,ArrowChoice a) => FRPBase t i o a (Maybe (FRPBase t i o a i o),o) o+switchTerminate = proc (thread,o) -> +    do FRPBase $ lift $ ThreadedArrow.switchTerminate -< (fmap (statefulThread . fromFRPBase) thread,o)++spawnThreads :: (Arrow a,ArrowChoice a,ArrowApply a) => FRPBase t i o a [(t,FRPBase t i o a i o)] ()+spawnThreads = (FRPBase $ lift $ ThreadedArrow.spawnThreads) <<< +               arr (map $ second $ statefulThread . fromFRPBase)++killThreadIf :: (Arrow a,ArrowChoice a,ArrowApply a) => FRPBase t i o a Bool ()+killThreadIf = FRPBase $ lift ThreadedArrow.killThreadIf++threadIdentity :: (ArrowChoice a) => FRPBase t i o a () t+threadIdentity = FRPBase $ lift ThreadedArrow.threadIdentity+\end{code}++\subsection{Embedding one FRPBase instance in another}++The frpBaseContext combinator allows a differently-typed FRPBase thread group to be embedded in another.  +Using frpBaseContext, a thread can instantiate a group of threads that die whenever the calling thread +dies or switches.  That is, the thread group is part of the state of the calling thread.++\begin{code}+frpBaseContext :: (Arrow a,ArrowChoice a,ArrowApply a) => +    (forall x. j -> [(t,x)] -> [(t,(p,x))] -> [x]) ->+    [(t,FRPBase t j p a j p)] -> FRPBase u i o a j [(t,p)]+frpBaseContext manageThreads threads = FRPBase $ raw $ statefulTransform lift (RSAGL.FRPBase.statefulForm manageThreads threads)+\end{code}++\subsection{Embedding explicit underlying state}++The withState and withExposedState combinators are implemented in terms of the+StatefulArrow combinators of the same name\footnote{See page \pageref{withState}}.++\begin{code}+withState :: (Arrow a,ArrowChoice a,ArrowApply a,Monoid p) => +    (forall x. j -> [(t,x)] -> [(t,(p,x))] -> [x]) -> +    [(t,FRPBase t j p (StateArrow s a) j p)] -> s -> FRPBase t i o a j [(t,p)]+withState manageThreads threads s = FRPBase $ raw $ statefulTransform lift $ StatefulArrow.withState (RSAGL.FRPBase.statefulForm manageThreads threads) s++withExposedState :: (Arrow a,ArrowChoice a,ArrowApply a,Monoid p) =>+    (forall x. j -> [(t,x)] -> [(t,(p,x))] -> [x]) -> +    [(t,FRPBase t j p (StateArrow s a) j p)] -> FRPBase t i o a (j,s) ([(t,p)],s)+withExposedState manageThreads threads = statefulContext $ StatefulArrow.withExposedState $ RSAGL.FRPBase.statefulForm manageThreads threads+\end{code}++\subsection{Embedding a StatefulArrow in an FRPBase arrow}+\label{statefulContext}++The statefulContext combinator allows a StatefulArrow to be embedded in an FRPBase, with+the provision that the StatefulArrow does not have access to the threading operators.++\begin{code}+statefulContext :: (Arrow a,ArrowChoice a,ArrowApply a) =>+                       StatefulArrow a j p -> FRPBase t i o a j p+statefulContext = FRPBase . raw . statefulTransform lift+\end{code}++\subsection{The StatefulArrow form of an FRPBase arrow}++The FRPBase arrow can be made to appear as a StatefulArrow using statefulForm.+\footnote{See \pageref{statefulForm}}++\begin{code}+statefulForm :: (Arrow a,ArrowChoice a,ArrowApply a) => +     (forall x. i -> [(t,x)] -> [(t,(o,x))] -> [x]) -> +     [(t,FRPBase t i o a i o)] -> StatefulArrow a i [(t,o)]+statefulForm manageThreads = ThreadedArrow.statefulForm manageThreads . map (second $ statefulThread . fromFRPBase)+\end{code}++\subsection{Essential mechanism}++The essential mechanism of the FRPBase arrow is the layering of a StatefulArrow over a ThreadedArrow,+allowing threads that are both implicitly and explicitly stateful.  \texttt{statefulThread} implements this.+In the event of an explicit switch, all implicit state is lost.++\begin{code}+statefulThread :: (Arrow a,ArrowChoice a) => +                  StatefulArrow (ThreadedArrow t i o a) i o -> ThreadedArrow t i o a i o+statefulThread (StatefulArrow sf) = +    proc b -> do (c,sf') <- sf -< b+                 ThreadedArrow.switchTerminate -< (Just $ statefulThread sf',c)+\end{code}
+ RSAGL/Homogenous.lhs view
@@ -0,0 +1,46 @@+\section{Representing objects in homogenous coordinates: RSAGL.Homogenous}++Entities such as points and vectors that can be represented as matrices.  The Homogenous typeclass is+an easy way to implement affine transformations on these types.++toHomogenous always results in a column matrix, while fromHomogenous always expects a row matrix.+This means that (fromHomogenous . toHomogenous) is not an identity function.+Instead, (fromHomogenous . matrixTranspose . toHomogenous) is an identity function.++\begin{code}+module RSAGL.Homogenous+    (Homogenous(..),+     transformHomogenous)+    where++import RSAGL.Vector+import RSAGL.Matrix++class Homogenous a where+    toHomogenous :: a -> Matrix+    fromHomogenous :: Matrix -> a++instance Homogenous Vector3D where+    toHomogenous (Vector3D x y z) = matrix [[x],+                                            [y],+                                            [z],+                                            [0.0]]+    fromHomogenous m = vector3d $ genericFromHomogenous m ++instance Homogenous Point3D where+    toHomogenous (Point3D x y z) = matrix [[x],+                                           [y],+                                           [z],+                                           [1.0]]+    fromHomogenous m = point3d $ genericFromHomogenous m++genericFromHomogenous :: Matrix -> XYZ+genericFromHomogenous m = let x = (rowMajorForm m) !! 0 !! 0+			      y = (rowMajorForm m) !! 1 !! 0+			      z = (rowMajorForm m) !! 2 !! 0+			      in (x,y,z)++transformHomogenous :: (Homogenous a, Homogenous b) => Matrix -> a -> b+transformHomogenous transformation_matrix entity = +    fromHomogenous $ matrixMultiply transformation_matrix $ toHomogenous entity+\end{code}
+ RSAGL/Interpolation.lhs view
@@ -0,0 +1,91 @@+\section{RSAGL.Interpolation}++\begin{code}+module RSAGL.Interpolation+    (lerp,+     lerpBetween,+     lerpBetweenMutated,+     lerpBetweenClamped,+     lerpBetweenClampedMutated,+     lerp_mutator_continuous_1st,+     lerpMap)+    where++import RSAGL.AbstractVector+import Data.Ord+import Data.Map as Map+import Data.Maybe+\end{code}++\subsection{The Lerpable typeclass}++Implements linear interpolation.++\begin{code}+lerp :: (AbstractScale v,AbstractSubtract p v,AbstractAdd p v,Real r) => r -> (p,p) -> p+lerp u (a,b) = a `add` scalarMultiply (realToFrac u) (b `sub` a)+\end{code}++\subsection{Non-linear interpolations}++The mutated versions of the lerp functions takes an arbitrary ``mutator function'' to define non-linear interpolation curves.+The ``between'' versions of the lerp functions allow the u-value to lie between any two numbers, as opposed to between 0 and 1.+The ``clamped'' versions of the lerp functions clamp the u-value to lie between its boundaries.  Otherwise, with non-clamped+interpolations, the u-value may lie outside of its boundaries.++\begin{code}+lerpBetween :: (AbstractScale v,AbstractSubtract p v,AbstractAdd p v,Real r,Fractional r) => (r,r,r) -> (p,p) -> p+lerpBetween = lerpBetweenMutated id++lerpBetweenMutated :: (AbstractScale v,AbstractSubtract p v,AbstractAdd p v,Real r,Fractional r) => (r -> r) -> (r,r,r) -> (p,p) -> p+lerpBetweenMutated _ (l,_,r) | l == r = lerp 0.5+lerpBetweenMutated mutator (l,u,r) = lerp $ mutator $ (u-l) / (r-l)++lerpBetweenClamped :: (AbstractScale v,AbstractSubtract p v,AbstractAdd p v,Real r,Fractional r,Ord r) => (r,r,r) -> (p,p) -> p+lerpBetweenClamped = lerpBetweenClampedMutated id++lerpBetweenClampedMutated :: (AbstractScale v,AbstractSubtract p v,AbstractAdd p v,Real r,Fractional r,Ord r) => (r -> r) -> (r,r,r) -> (p,p) -> p+lerpBetweenClampedMutated mutator (l,u,r) = lerpBetweenMutated (lerp_mutator_clamp . mutator) (l,u,r)+\end{code}++\subsection{Lerp mutators}++\texttt{lerp\_mutator\_clamp} implements clamping between 0 and 1.++\begin{code}+lerp_mutator_clamp :: (Real r) => r -> r+lerp_mutator_clamp = min 1 . max 0+\end{code}++\texttt{lerp\_mutator\_continuous\_1st} implements clamping between 0 and 1, but such that the 1st derivative of the result is continuous.++\begin{code}+lerp_mutator_continuous_1st :: (Real r,Fractional r) => r -> r+lerp_mutator_continuous_1st x | x < 0 = 0+lerp_mutator_continuous_1st x | x > 1 = 1+lerp_mutator_continuous_1st x | x <= 0.5 = 2*x^2+lerp_mutator_continuous_1st x = 4*x - 2*x^2 - 1+\end{code}++\subsection{lerpMap}++Given many entities, lerp between the two entities closest to the given point+on either side.  For example, if we wanted to lerp between colors on a rainbow,+we might use the map [(0,red),(1,orange),(2,yellow),(3,green),(4,blue),(5,indigo),(6,violet)].+lerpMap 3.5 would result in a blue-green color.++\begin{code}+lerpMap :: (Real r,Fractional r,AbstractScale v,AbstractSubtract p v,AbstractAdd p v) => [(r,p)] -> r -> p+lerpMap pts = lerpMapSorted $ Map.fromList pts++lerpMapSorted :: (Real r,Fractional r,AbstractScale v,AbstractSubtract p v,AbstractAdd p v) => Map r p -> r -> p+lerpMapSorted m _ | Map.null m = error "lerpMapSorted: empty map"+lerpMapSorted m u = case () of+        () | isJust exactly -> fromJust exactly+        () | Map.null lowers -> higher_a+        () | Map.null highers -> lower_a+        () -> lerpBetween (lower_r,u,higher_r) (lower_a,higher_a)+    where (lowers, exactly, highers) = splitLookup u m+          (lower_r,lower_a) = findMax lowers+          (higher_r,higher_a) = findMin highers+\end{code}
+ RSAGL/InverseKinematics.lhs view
@@ -0,0 +1,114 @@+\section{Inverse Kinematics}++\begin{code}+{-# LANGUAGE Arrows #-}+{-# OPTIONS_GHC -fallow-undecidable-instances #-}++module RSAGL.InverseKinematics+    (leg,+     Leg,+     jointAnimation,+     legs,+     approach,+     approachA)+    where++import Control.Arrow+import Control.Arrow.Operations+import Data.Fixed+import RSAGL.Vector+import RSAGL.FRP+import RSAGL.Affine+import RSAGL.CoordinateSystems+import RSAGL.KinematicSensors+import RSAGL.Vector+import RSAGL.Joint+import RSAGL.Time+import RSAGL.AbstractVector+import RSAGL.Angle+\end{code}++\subsection{The Foot}++This simulates a single foot that hops along by itself whenever its coordinate system moves.  A \texttt{foot} always trys to walk on the plane \texttt{y == 0}.+\texttt{foot} takes as input a boolean which, if true, indicates that there are not enough feet on the ground and that this \texttt{foot} should perform an+``emergency foot down.''  \texttt{foot} ignores the emergency foot down flag if it is already down.  \texttt{foot} emits the position of the foot and a boolean+which indicates if the foot is up (\texttt{True}) or down (\texttt{False}).++\texttt{foot} works by reading two odometers, one for forward movement and another for sideways movement.  This is like spinning the wheel by a magical odometer+instead of spinning the odometer by the wheel.++\texttt{pre\_stepage} is the total odometer reading for all travel in both directions.  \texttt{stepage\_adjustment} is the amount by which we need to increase+\texttt{pre\_stepage} to ensure that the foot is correct based on an accumulation of emergency foot downs.  \texttt{cyclic\_stepage} is a value between 0 and 2,+where a value greater than 1 indicates that the foot is down.++FIXME: this could be done better.++\begin{code}+foot :: (Arrow a,ArrowApply a,ArrowChoice a,CoordinateSystemClass s,ArrowState s a) => Double -> Double -> Double -> FRPX any t i o a Bool (CSN Point3D,Bool)+foot forward_radius side_radius lift_radius = proc emergency_footdown ->+    do fwd_total_stepage <- arr (* recip forward_radius) <<< odometer root_coordinate_system (Vector3D 0 0 1) -< ()+       side_total_stepage <- arr (* recip side_radius) <<< odometer root_coordinate_system (Vector3D 1 0 0) -< ()+       let pre_stepage = sqrt $ fwd_total_stepage^2 + side_total_stepage^2+       stepage_adjustment <- integralRK4 fps30 add 0 -< (\_ p -> if (p + pre_stepage) `mod'` 2 < 1 && emergency_footdown then perSecond 1 else perSecond 0) +       let adjusted_stepage = stepage_adjustment + pre_stepage+       let cyclic_stepage = (`mod'` 2) $ adjusted_stepage+       motion <- derivative -< adjusted_stepage+       let foot_lift = max 0 $ min 1 (motion `over` fromSeconds 1) * lift_radius * (sine $ fromRotations (cyclic_stepage / 2))+       let stepage_offset = if cyclic_stepage > 1 then 1.5 - cyclic_stepage else cyclic_stepage - 0.5+       let step_vector = scale (Vector3D side_radius 0 forward_radius) $ vectorScaleTo stepage_offset $ Vector3D side_total_stepage 0 fwd_total_stepage+       foot_position <- importA <<< arr (remoteCSN root_coordinate_system $ scale (Vector3D 1 0 1)) <<< exportA -< translate step_vector origin_point_3d+       csn_foot_position <- exportA -< translate (Vector3D 0 foot_lift 0) foot_position+       returnA -< (csn_foot_position,cyclic_stepage > 1)+\end{code}++\texttt{leg} creates a leg that tries to walk over the ground no matter how it is positioned.  \texttt{legs} combines a group of legs so that at least half+of the legs always try to touch the ground.++\begin{code}+newtype Leg threaded t i o a = Leg (FRPX threaded t i o a [Bool] [Bool])++instance (ArrowChoice a,ArrowState s a,CoordinateSystemClass s) => AffineTransformable (Leg threaded t i o a) where+    transform m (Leg l) = Leg (proc x -> transformA l -< (Affine $ transform m,x))++leg :: (ArrowApply a,ArrowChoice a,ArrowState s a,CoordinateSystemClass s) => Vector3D -> Point3D -> Double -> Point3D -> (FRPX threaded t i o a Joint ()) -> Leg threaded t i o a+leg bend base len end animation = Leg $ proc feet_that_are_down ->+    do let declare_emergency_foot_down = length (filter id feet_that_are_down) < length (filter not feet_that_are_down) &&+                                         not (and $ take 1 feet_that_are_down)+       (p,foot_is_down) <- first importA <<< +                           transformA (foot foot_radius foot_radius (foot_radius/5)) -< (Affine $ translate (vectorToFrom end origin_point_3d),declare_emergency_foot_down)+       animation -< joint bend base len p+       returnA -< (foot_is_down || declare_emergency_foot_down) : feet_that_are_down+  where foot_radius = sqrt (len^2 - (distanceBetween base end)^2) / 2++legs :: (ArrowChoice a) => [Leg threaded t i o a] -> FRPX threaded t i o a () ()+legs ls = (foldl (>>>) (arr $ const []) $ map (\(Leg l) -> l) ls) >>> (arr $ const ())+\end{code}++\texttt{jointAnimation} is just a simple combinator to combine the upper and lower components of a joint into an animated Joint.++\begin{code}+jointAnimation :: (ArrowChoice a,ArrowState s a,CoordinateSystemClass s) => FRPX any t i o a () () -> FRPX any t i o a () () -> FRPX any t i o a Joint ()+jointAnimation upperJoint lowerJoint = proc j ->+    do transformA upperJoint -< (affineOf $ joint_arm_upper j,())+       transformA lowerJoint -< (affineOf $ joint_arm_lower j,())+\end{code}++\subsection{Approach}++\texttt{approach} is an acceleration function that that tries to approach a goal point.  It begins slowing down when it comes within+the goal radius, and otherwise travels at a fixed speed toward the goal.  The goal radius and speed are defined in terms of the+\texttt{magnitude} of the vector type.++\begin{code}+approach :: (AbstractVector v,AbstractSubtract p v,AbstractMagnitude v) => p -> Double -> Rate Double -> (Time -> p -> Rate v)+approach goal_point goal_radius max_speed _ position = withTime (fromSeconds 1) (\x -> abstractScaleTo (x * speed_ratio) goal_vector) max_speed+    where goal_vector = goal_point `sub` position+          speed_ratio = min 1 $ magnitude goal_vector / goal_radius++approachA :: (ArrowChoice a,ArrowApply a,AbstractVector v,AbstractAdd p v, AbstractSubtract p v,AbstractMagnitude v) => Double -> Rate Double -> FRPX any t i o a p p+approachA goal_radius max_speed = frp1Context $ proc initial_value -> switchContinue -< (Just $ approachA_ initial_value,initial_value)+    where approachA_ initial_value = proc goal_point -> integralRK4 frequency add initial_value -< approach goal_point goal_radius max_speed+          frequency = 8 `per` time goal_radius max_speed +\end{code}+
+ RSAGL/Joint.lhs view
@@ -0,0 +1,50 @@+\section{Joints}++Joints are a basic essential element of the RSAGL inverse kinematics subsystem.++\begin{code}+module RSAGL.Joint+    (Joint(..),+     joint) where++import RSAGL.Vector+import RSAGL.Affine+import RSAGL.Interpolation+import RSAGL.CoordinateSystems+import RSAGL.Orthagonal+\end{code}++\texttt{Joint} is the result of computing a joint.  It provides AffineTransformations that describe the orientations of the bases of the components of the joint.++\texttt{joint\_arm\_upper} is the affine transformation to the position of the upper arm, where the origin is the shoulder (or base).+\texttt{joint\_arm\_lower} is the affine transformation to the lower arm, where the origin is the elbow.+\texttt{joint\_arm\_hand} is the affine transformation where the origin is the hand.+\texttt{joint\_shoulder}, \texttt{joint\_hand}, and \texttt{joint\_elbow} refer to the positions of those endpoints of the joint.++\begin{code}+data Joint = Joint { joint_shoulder :: Point3D,+                     joint_hand :: Point3D,+                     joint_elbow :: Point3D,+                     joint_arm_lower :: AffineTransformation,+                     joint_arm_upper :: AffineTransformation,+		     joint_arm_hand :: AffineTransformation }+\end{code}++Compute a joint where given a bend vector, two end points, and the total length of them limb.  ++\begin{code}+joint :: Vector3D -> Point3D -> Double -> Point3D -> Joint+joint bend shoulder joint_length hand | distanceBetween shoulder hand > joint_length = -- if the end is out of range, constrict it to within range+    joint bend shoulder joint_length (translate (vectorScaleTo (0.99 * joint_length) $ vectorToFrom hand shoulder) shoulder)+joint bend shoulder joint_length hand = Joint {+        joint_shoulder = shoulder,+        joint_hand = hand,+        joint_elbow = elbow,+        joint_arm_lower = modelLookAt elbow (forward $ Left hand) (down $ Right bend),+        joint_arm_upper = modelLookAt shoulder (forward $ Left elbow) (down $ Right bend),+	joint_arm_hand = modelLookAt hand (backward $ Left elbow) (up $ Right (Vector3D 0 1 0)) }+    where joint_offset = sqrt (joint_length^2 - (distanceBetween shoulder hand)^2) / 2+          joint_offset_vector = vectorScaleTo joint_offset $ transformation+              (orthagonalFrame (forward $ vectorToFrom hand shoulder) (down bend)) (Vector3D 0 (-1) 0)+          elbow = translate joint_offset_vector $ lerp 0.5 (shoulder,hand)+\end{code}
+ RSAGL/KinematicSensors.lhs view
@@ -0,0 +1,31 @@+\section{Sensors for Inverse Kinematics}++These are various composable modules that provide physics information for the inverse kinematics system.++\begin{code}+module RSAGL.KinematicSensors+    (odometer)+    where++import Control.Arrow+import Control.Arrow.Operations+import RSAGL.Vector+import RSAGL.FRP+import RSAGL.CoordinateSystems+import RSAGL.Time+\end{code}++\subsection{Odometer}++The \texttt{odometer} indicates the distance traveled in a remote coordinate system along a vector in the local coordinate system.+It does not measure side-to-side motion, only motion in the direction of the vector.++\begin{code}+odometer :: (Arrow a,ArrowChoice a,ArrowApply a,ArrowState s a,CoordinateSystemClass s) => CoordinateSystem -> Vector3D -> FRPX any t i o a () Double+odometer cs measurement_vector_ =+       arr (const origin_point_3d) >>> exportToA cs >>> derivative >>> importFromA cs >>>+       arr (withTime (fromSeconds 1) (dotProduct measurement_vector)) >>>+       integral 0+    where measurement_vector = vectorNormalize measurement_vector_+\end{code}+
+ RSAGL/Main.hs view
@@ -0,0 +1,171 @@+{-# OPTIONS_GHC -fno-warn-unused-imports -farrows #-}++module RSAGL.Main+    (main,+     displayModel)+    where++import Data.IORef+import System.IO+import Graphics.UI.GLUT as GLUT+import Graphics.Rendering.OpenGL.GLU.Errors+import RSAGL.Model+import Models.PlanetRingMoon+import RSAGL.Time+import Control.Monad+import Control.Monad.Trans+import RSAGL.Angle+import System.Exit+import RSAGL.Color+import RSAGL.Bottleneck+import RSAGL.QualityControl+import RSAGL.Scene+import RSAGL.FRP+import RSAGL.Animation+import RSAGL.AnimationExtras+import RSAGL.ThreadedArrow+import Control.Arrow+import RSAGL.Vector+import RSAGL.RSAGLColors+import RSAGL.CoordinateSystems+import qualified RSAGL.Affine as Affine+import RSAGL.Matrix+import RSAGL.Interpolation+import Debug.Trace+import RSAGL.ModelingExtras+import RSAGL.WrappedAffine+import RSAGL.InverseKinematics++test_quality :: Integer+test_quality = 2^14+--test_quality = 64++moon_orbital_animation :: AniA () i o (IO IntermediateModel) (CSN Point3D)+moon_orbital_animation =+    accelerationModel (perSecond 60)+                      (Point3D (-6) 0 0,perSecond $ Vector3D 0.0 0.14 0.18)+                      (arr $ const $ inverseSquareLaw 1.0 origin_point_3d)+                      (proc (_,im) -> do rotateA (Vector3D 0 1 0) (perSecond $ fromDegrees 20) accumulateSceneA -< (Infinite,sceneObject im)+                                         exportA -< origin_point_3d)++walking_orb_animation :: QualityCache Integer IntermediateModel -> QualityCache Integer IntermediateModel ->+                         QualityCache Integer IntermediateModel -> QualityCache Integer IntermediateModel ->+                         IO (AniA () i o () ())+walking_orb_animation qo_orb qo_glow_orb qo_orb_upper_leg qo_orb_lower_leg =+    do let upper_leg_anim = proc () -> accumulateSceneA -< (Local,sceneObject $ getQuality qo_orb_upper_leg 50)+       let lower_leg_anim = proc () -> accumulateSceneA -< (Local,sceneObject $ getQuality qo_orb_lower_leg 50)+       let orb_legs = legs $ rotationGroup (Vector3D 0 1 0) 7 $+                             leg (Vector3D 0 1 1) (Point3D 0 0.5 0.5) 2 (Point3D 0 0 1.8) $ jointAnimation upper_leg_anim lower_leg_anim+       return $ proc () ->+           do accumulateSceneA -< (Local,sceneObject $ getQuality qo_orb test_quality)+              transformA pointAtCameraA -< (Affine $ Affine.translate (Vector3D 0 1.05 0),(Local,getQuality qo_glow_orb test_quality))+              accumulateSceneA -< (Local,lightSource $ PointLight (Point3D 0 0 0)+                                                                  (measure (Point3D 0 0 0) (Point3D 0 6 0))+                                                                  (scaleRGB 0.5 white) blackbody)+              orb_legs -< ()+              returnA -< ()++testScene :: IO (AniM ((),Camera))+testScene = +    do bottleneck <- newBottleneck+       let newQO im = newQuality bottleneck parIntermediateModel (flip toIntermediateModel im) $ iterate (*2) 64+       putStrLn "loading planet..."+       qo_planet <- newQO planet+       putStrLn "loading ring..."+       qo_ring <- newQO ring+       putStrLn "loading moon..."+       qo_moon <- newQO moon+       putStrLn "loading ground..."+       qo_ground <- newQO ground+       putStrLn "loading monolith..."+       qo_monolith <- newQO monolith+       putStrLn "loading station..."+       qo_station <- newQO station+       putStrLn "loading orb..."+       qo_orb <- newQO orb+       putStrLn "loading glow_orb..."+       qo_glow_orb <- newQO glow_orb+       putStrLn "loading orb_upper_leg..."+       qo_orb_upper_leg <- newQO orb_upper_leg+       putStrLn "loading orb_lower_leg..."+       qo_orb_lower_leg <- newQO orb_lower_leg+       putStrLn "done."+       walking_orb_animation_arrow <- walking_orb_animation qo_orb qo_glow_orb qo_orb_upper_leg qo_orb_lower_leg+       ao_walking_orb <- newAnimationObjectA (arr (map snd) <<< frpContext nullaryThreadIdentity [((),walking_orb_animation_arrow)])+       ao_moon_orbit <- newAnimationObjectA (arr (map snd) <<< frpContext nullaryThreadIdentity [((),moon_orbital_animation)])+       return $ +           do rotation_planet <- rotationM (Vector3D 0 1 0) (perSecond $ fromDegrees 25)+              rotation_station <- rotationM (Vector3D 0 1 0) (perSecond $ fromDegrees 5)+              rotation_camera <- rotationM (Vector3D 0 1 0) (perSecond $ fromDegrees 3)+              rotation_orb <- rotationM (Vector3D 0 1 0) (perSecond $ fromDegrees 7)+              accumulateSceneM Local $ sceneObject $ getQuality qo_ground test_quality+              accumulateSceneM Local $ sceneObject $ getQuality qo_monolith test_quality+              transformM (affineOf $ Affine.translate (Vector3D 0 1 (-4)) . Affine.rotate (Vector3D 1 0 0) (fromDegrees 90) . rotation_station) $ +                  accumulateSceneM Infinite $ sceneObject $ getQuality qo_station test_quality+              transformM (affineOf $ rotation_orb . Affine.translate (Vector3D (4) 0 0)) $+                  do runAnimationObject ao_walking_orb ()+              transformM (affineOf $ Affine.translate (Vector3D 0 1 6)) $ +                  do transformM (affineOf rotation_planet) $ accumulateSceneM Infinite $ sceneObject $ getQuality qo_planet test_quality+                     accumulateSceneM Infinite $ lightSource $ DirectionalLight (vectorNormalize $ Vector3D 1 (-1) (-1)) white blackbody+                     accumulateSceneM Infinite $ lightSource $ DirectionalLight (vectorNormalize $ Vector3D (-1) 1 1) (scaleRGB 0.5 red) blackbody+                     accumulateSceneM Infinite $ sceneObject $ getQuality qo_ring test_quality+                     runAnimationObject ao_moon_orbit $ getQuality qo_moon test_quality+              return ((),PerspectiveCamera (transformation rotation_camera $ Point3D 1 2 (-8))+                                           (Point3D 0 2.5 2)+                                           (Vector3D 0 1 0)+                                           (fromDegrees 45))++main :: IO ()+main = displayModel++default_window_size :: Size+default_window_size = Size 800 600++display_mode :: [DisplayMode]+display_mode = [RGBAMode,+		WithDepthBuffer,+		DoubleBuffered]++timer_callback_millis :: Int+timer_callback_millis = 5++displayModel :: IO ()+displayModel =+    do _ <- getArgsAndInitialize+       initialWindowSize $= default_window_size+       initialDisplayMode $= display_mode+       window <- createWindow "RSAGL Test Mode"+       reshapeCallback $= Just rsaglReshapeCallback+       counter <- newIORef 0+       testSceneCallback <- testScene+       displayCallback $= rsaglDisplayCallback counter (testSceneCallback)+       idleCallback $= (Just $ return ())+       addTimerCallback timer_callback_millis (rsaglTimerCallback window)+       mainLoop++rsaglReshapeCallback :: Size -> IO ()+rsaglReshapeCallback (Size width height) = do matrixMode $= Projection+					      loadIdentity+					      viewport $= (Position 0 0,Size width height)+                                              matrixMode $= Modelview 0++rsaglDisplayCallback :: (IORef Integer) -> AniM ((),Camera) -> IO ()+rsaglDisplayCallback counter aniM =+    do loadIdentity+       color (Color4 0.0 0.0 0.0 0.0 :: Color4 Double)+       clear [ColorBuffer]+       the_scene <- liftM snd $ runAniM aniM+       (Size w h) <- GLUT.get windowSize+       sceneToOpenGL (fromIntegral w / fromIntegral h) (0.1,30) the_scene+       swapBuffers+       modifyIORef counter (+1)+       errs <- (get errors)+       when (not $ null errs) $ print $ show errs+       frames <- readIORef counter+       when (frames `mod` 200 == 0) $ putStrLn $ "frames: " ++ show frames+       when (frames >= 4000) $ exitWith ExitSuccess++rsaglTimerCallback :: Window -> IO ()+rsaglTimerCallback window = +    do addTimerCallback timer_callback_millis (rsaglTimerCallback window)+       postRedisplay $ Just window
+ RSAGL/Material.lhs view
@@ -0,0 +1,208 @@+\section{Materials}++\begin{code}+{-# OPTIONS_GHC -fglasgow-exts #-}++module RSAGL.Material+    (module RSAGL.Color,+     MaterialLayer,MaterialSurface,Material,materialIsEmpty,+     toLayers,materialLayerSurface,materialLayerRelevant,materialComplexity,materialLayerToOpenGLWrapper,+     isOpaqueLayer,+     diffuseLayer,RSAGL.Material.specularLayer,transparentLayer,emissiveLayer)+    where++import Data.Maybe+import Data.Monoid+import Control.Applicative+import RSAGL.Color+import RSAGL.Curve+import RSAGL.ApplicativeWrapper+import Control.Parallel.Strategies+import Graphics.Rendering.OpenGL.GL.Colors+import Graphics.Rendering.OpenGL.GL.StateVar+import Graphics.Rendering.OpenGL.GL.VertexSpec+import Graphics.Rendering.OpenGL.GL.BasicTypes+import Graphics.Rendering.OpenGL.GL.PerFragment+\end{code}++\subsection{MaterialLayers}++A \texttt{MaterialLayer} is a layer of material some material quality (diffuse, transparent, emissive, or specular highlight).  MaterialLayers are rendered one on top of another to create layered effects.++\begin{code}+type MaterialSurface a = ApplicativeWrapper Surface a++data MaterialLayer =+    DiffuseLayer (MaterialSurface RGB)+  | TransparentLayer (MaterialSurface RGBA)+  | EmissiveLayer (MaterialSurface RGB)+  | SpecularLayer (MaterialSurface RGB) GLfloat+  | CompoundLayer (MaterialSurface RGB) RGB RGB GLfloat++instance NFData MaterialLayer where+    rnf (DiffuseLayer msrgb) = rnf msrgb+    rnf (TransparentLayer msrgba) = rnf msrgba+    rnf (EmissiveLayer msrgb) = rnf msrgb+    rnf (SpecularLayer msrgb shininess) = rnf (msrgb,shininess)+    rnf (CompoundLayer msrgb spec emis shininess) = rnf (msrgb,spec,emis,shininess)++data Material = Material [MaterialLayer]++toLayers :: Material -> [MaterialLayer]+toLayers (Material layers) = layers++combineLayers :: [MaterialLayer] -> [MaterialLayer]+combineLayers (x1:x2:xs) | isJust (combine2Layers x1 x2) = combineLayers $ fromJust (combine2Layers x1 x2) : xs+combineLayers (x:xs) = x : combineLayers xs+combineLayers xs = xs++combine2Layers :: MaterialLayer -> MaterialLayer -> Maybe MaterialLayer+combine2Layers (DiffuseLayer msrgb) (SpecularLayer specular_rgb shininess) | isPure specular_rgb =+    Just $ CompoundLayer msrgb (fromJust $ fromPure $ specular_rgb) (RGB 0 0 0) shininess+combine2Layers (DiffuseLayer msrgb) (EmissiveLayer emissive_rgb) | isPure emissive_rgb =+    Just $ CompoundLayer msrgb (RGB 0 0 0) (fromJust $ fromPure $ emissive_rgb) 0+combine2Layers (EmissiveLayer x) (EmissiveLayer y) = Just $ EmissiveLayer $ addRGB <$> x <*> y+combine2Layers (CompoundLayer msrgb specular_rgb emissive_rgb1 shininess) (EmissiveLayer emissive_rgb2) | isPure emissive_rgb2 =+    Just $ CompoundLayer msrgb specular_rgb (addRGB emissive_rgb1 (fromJust $ fromPure $ emissive_rgb2)) shininess+combine2Layers (CompoundLayer msrgb (RGB 0 0 0) emissive_rgb 0) (SpecularLayer specular_rgb shininess) | isPure specular_rgb =+    Just $ CompoundLayer msrgb (fromJust $ fromPure $ specular_rgb) emissive_rgb shininess+combine2Layers _ _ = Nothing++instance Monoid Material where+    mempty = Material []+    mappend (Material xs) (Material ys) = Material $ combineLayers $ (\zs -> if null (snd zs) then fst zs else snd zs) $+                                                     span (not . isOpaqueLayer) $ xs ++ ys++materialIsEmpty :: Material -> Bool+materialIsEmpty (Material xs) = null xs++materialLayerComplexity :: MaterialLayer -> Integer+materialLayerComplexity layer | fromPure (materialLayerRelevant layer) == Just False = 0+materialLayerComplexity (DiffuseLayer ms) | fromPure ms == Just (RGB 0 0 0) = 0+materialLayerComplexity (DiffuseLayer ms) | isPure ms = 1+materialLayerComplexity (DiffuseLayer {}) = 2+materialLayerComplexity (TransparentLayer ms) | isPure ms = 1+materialLayerComplexity (TransparentLayer {}) = 2+materialLayerComplexity (EmissiveLayer ms) | isPure ms = 0+materialLayerComplexity (EmissiveLayer {}) = 2+materialLayerComplexity (SpecularLayer ms _) | isPure ms = 3+materialLayerComplexity (SpecularLayer {}) = 4+materialLayerComplexity (CompoundLayer msrgb specular_rgb emissive_rgb shininess) = +    sum $ map materialLayerComplexity [DiffuseLayer msrgb,SpecularLayer (pure specular_rgb) shininess,EmissiveLayer (pure emissive_rgb)]++materialComplexity :: Material -> Integer+materialComplexity (Material layers) = sum $ map materialLayerComplexity layers++isOpaqueLayer :: MaterialLayer -> Bool+isOpaqueLayer (DiffuseLayer _) = True+isOpaqueLayer (TransparentLayer ms) | fmap rgba_a (fromPure ms) == Just 1.0 = True+isOpaqueLayer (EmissiveLayer ms) | fromPure ms == Just (RGB 1.0 1.0 1.0) = True+isOpaqueLayer (CompoundLayer _ _ _ _) = True+isOpaqueLayer _ = False++isEmissiveRelevant :: RGB -> Bool+isEmissiveRelevant (RGB 0 0 0) = False+isEmissiveRelevant _ = True++isTransparentRelevant :: RGBA -> Bool+isTransparentRelevant (RGBA 0 _) = False+isTransparentRelevant _ = True++materialLayerSurface :: MaterialLayer -> MaterialSurface RGBA+materialLayerSurface (DiffuseLayer msrgb) = fmap toRGBA msrgb+materialLayerSurface (TransparentLayer msrgba) = msrgba+materialLayerSurface (EmissiveLayer msrgb) = fmap toRGBA msrgb+materialLayerSurface (SpecularLayer msrgb _) = fmap toRGBA msrgb+materialLayerSurface (CompoundLayer msrgb _ _ _) = fmap toRGBA msrgb++materialLayerRelevant :: MaterialLayer -> MaterialSurface Bool+materialLayerRelevant (DiffuseLayer {}) = pure True+materialLayerRelevant (TransparentLayer msrgba) = fmap isTransparentRelevant msrgba+materialLayerRelevant (EmissiveLayer msrgb) = fmap isEmissiveRelevant msrgb+materialLayerRelevant (SpecularLayer msrgb _) = fmap isEmissiveRelevant msrgb+materialLayerRelevant (CompoundLayer {}) = pure True++materialLayerToOpenGLWrapper :: MaterialLayer -> IO () -> IO ()+materialLayerToOpenGLWrapper (DiffuseLayer ms) io = +    do cm <- get colorMaterial+       materialEmission FrontAndBack $= Color4 0 0 0 1+       materialSpecular FrontAndBack $= Color4 0 0 0 1+       colorMaterial $= Just (FrontAndBack,AmbientAndDiffuse)+       maybe (return ()) (rgbToOpenGL) $ fromPure ms+       io+       colorMaterial $= cm+materialLayerToOpenGLWrapper (TransparentLayer ms) io = +    do cm <- get colorMaterial+       materialEmission FrontAndBack $= Color4 0 0 0 1+       materialSpecular FrontAndBack $= Color4 0 0 0 1+       colorMaterial $= Just (FrontAndBack,AmbientAndDiffuse)+       maybe (return ()) (rgbaToOpenGL) $ fromPure ms+       alphaBlendWrapper io+       colorMaterial $= cm+materialLayerToOpenGLWrapper (EmissiveLayer ms) io = +    do l <- get lighting+       lighting $= Disabled+       maybe (return ()) (rgbToOpenGL) $ fromPure ms+       additiveBlendWrapper io+       lighting $= l+materialLayerToOpenGLWrapper (SpecularLayer ms shininess) io = +    do cm <- get colorMaterial+       lmlv <- get lightModelLocalViewer+       materialShininess FrontAndBack $= shininess+       materialAmbientAndDiffuse FrontAndBack $= Color4 0 0 0 1+       materialEmission FrontAndBack $= Color4 0 0 0 1+       colorMaterial $= Just (FrontAndBack,Specular)+       lightModelLocalViewer $= Enabled+       maybe (return ()) (rgbToOpenGL) $ fromPure ms+       additiveBlendWrapper io+       colorMaterial $= cm+       lightModelLocalViewer $= lmlv+materialLayerToOpenGLWrapper (CompoundLayer ms specular_rgb emissive_rgb shininess) io =+    do cm <- get colorMaterial+       lmlv <- get lightModelLocalViewer+       materialSpecular FrontAndBack $= (\(RGB r g b) -> Color4 r g b 1) specular_rgb+       materialShininess FrontAndBack $= shininess+       materialEmission FrontAndBack $= (\(RGB r g b) -> Color4 r g b 1) emissive_rgb+       colorMaterial $= Just (FrontAndBack,AmbientAndDiffuse)+       lightModelLocalViewer $= Enabled+       maybe (return ()) (rgbToOpenGL) $ fromPure ms+       io+       colorMaterial $= cm+       lightModelLocalViewer $= lmlv++alphaBlendWrapper :: IO () -> IO ()+alphaBlendWrapper io =+    do bf <- get blendFunc+       b <- get blend+       blendFunc $= (SrcAlpha,OneMinusSrcAlpha)+       blend $= Enabled+       io+       blendFunc $= bf+       blend $= b++additiveBlendWrapper :: IO () -> IO ()+additiveBlendWrapper io =+    do bf <- get blendFunc+       b <- get blend+       blendFunc $= (One,One)+       blend $= Enabled+       io+       blendFunc $= bf+       blend $= b+\end{code}++\subsection{Constructing Materials}++\begin{code}+diffuseLayer :: MaterialSurface RGB -> Material+diffuseLayer msrgb = Material [DiffuseLayer msrgb]++specularLayer :: MaterialSurface RGB -> GLfloat -> Material+specularLayer msrgb x = Material [SpecularLayer msrgb x]++transparentLayer :: MaterialSurface RGBA -> Material+transparentLayer msrgba = Material [TransparentLayer msrgba]++emissiveLayer :: MaterialSurface RGB -> Material+emissiveLayer msrgb = Material [EmissiveLayer msrgb]+\end{code}
+ RSAGL/Matrix.lhs view
@@ -0,0 +1,217 @@+\section{RSAGL.Matrix}++\begin{code}+module RSAGL.Matrix+    (Matrix,+     matrix,+     rowMajorForm,+     colMajorForm,+     rowAt,+     matrixAt,+     identityMatrix,+     translationMatrix,+     rotationMatrix,+     scaleMatrix,+     xyzMatrix,+     matrixAdd,+     matrixMultiply,+     matrixTranspose,+     matrixInverse,+     determinant,+     matrixInversePrim)+    where++import Data.List+import RSAGL.Angle+import RSAGL.Vector+import RSAGL.Auxiliary+\end{code}++The Matrix data structure stores copies of the matrix in both row-major and column-major form,+as well a copy of the Matrix's inverse.  Caching this information has been shown to lead to performance+increases.++In row-major form, each list represents one row; columns run between lists.+In column-major form, each list represents one column; rows run between lists.++In row-major form, the Haskell list representation of a matrix has the same orientation+as if written on paper.++\begin{code}+data Matrix = Matrix { rows, cols :: Int, +                       row_major :: [[Double]], +                       matrix_inverse :: Matrix,+                       matrix_determinant :: Double }++instance Eq Matrix where+    x == y = rows x == rows y &&+             cols x == cols y &&+             row_major x == row_major y++instance Show Matrix where+    show m = show $ row_major m++rowMajorForm :: Matrix -> [[Double]]+rowMajorForm mat = row_major mat++colMajorForm :: Matrix -> [[Double]]+colMajorForm = transpose . row_major+\end{code}++rowAt answers the nth row of a matrix.++\begin{code}+rowAt :: Matrix -> Int -> [Double]+rowAt m n = (rowMajorForm m) !! n+\end{code}++matrixAt answers the (i'th,j'th) element of a matrix.++\begin{code}+matrixAt :: Matrix -> (Int,Int) -> Double+matrixAt m (i,j) = ((rowMajorForm m) !! j) !! i+\end{code}++\subsection{Constructing matrices}++matrix constructs a matrix from row major list form.  (Such a list form can be formatted correctly in +monospaced font and haskell syntax, so that it looks like a matrix as it would be normally written.)++\begin{code}+matrix :: [[Double]] -> Matrix+matrix dats = if all (== row_length) row_lengths+              then m+              else error "row lengths do not match"+    where m = Matrix { rows=length dats, --the number of rows is the length of each column+                       cols=length $ head dats, --the number of columns is the length of each row+                       row_major=dats,+                       matrix_inverse = (matrixInversePrim m) { matrix_inverse = m },+                       matrix_determinant = determinantPrim m }+          row_lengths = map length dats+          row_length = head row_lengths+\end{code}++identityMatrix constructs the n by n identity matrix++\begin{code}+identityMatrix :: (Integral i) => i -> Matrix+identityMatrix n = matrix $ map (\x -> genericReplicate x 0 ++ [1] ++ genericReplicate (n-1-x) 0) [0..n-1]+\end{code}++\begin{code}+translationMatrix :: Vector3D -> Matrix+translationMatrix (Vector3D x y z) = matrix [[1,0,0,x],+					     [0,1,0,y],+					     [0,0,1,z],+					     [0,0,0,1]]+\end{code}++\begin{code}+rotationMatrix :: Vector3D -> Angle -> Matrix+rotationMatrix vector angle = let s = sine angle+				  c = cosine angle+				  c' = 1 - c+				  (Vector3D x y z) = vectorNormalize vector+				  in matrix [[c+c'*x*x,     c'*y*x - s*z,   c'*z*x + s*y, 0],+					     [c'*x*y+s*z,   c+c'*y*y,       c'*z*y - s*x, 0],+					     [c'*x*z-s*y,   c'*y*z+s*x,     c+c'*z*z,     0],+					     [0,            0,              0,            1]]+\end{code}++\begin{code}+scaleMatrix :: Vector3D -> Matrix+scaleMatrix (Vector3D x y z) = matrix [[x, 0, 0, 0],+				       [0, y, 0, 0],+				       [0, 0, z, 0],+				       [0, 0, 0, 1]]+\end{code}++\texttt{xyzMatrix} constructs the matrix in which the x y and z axis are transformed to point in the direction of the specified+vectors.++\begin{code}+xyzMatrix :: Vector3D -> Vector3D -> Vector3D -> Matrix+xyzMatrix (Vector3D x1 y1 z1) (Vector3D x2 y2 z2) (Vector3D x3 y3 z3) =+    matrix [[x1,x2,x3,0],+            [y1,y2,y3,0],+            [z1,z2,z3,0],+            [0,0,0,1.0]]+\end{code}++\subsection{Matrix arithmetic}++\begin{code}+matrixAdd :: Matrix -> Matrix -> Matrix+matrixAdd m n = let new_row_major = (if and [rows m == rows n,cols m == cols n]+				      then map ((map (uncurry (+))).(uncurry zip)) $ zip (row_major m) (row_major n)+				      else error "matrixAdd: dimension mismatch")+		    in matrix new_row_major+\end{code}++\label{howtoUseMatrixMultiplyImpl}++\begin{code}+matrixMultiply :: Matrix -> Matrix -> Matrix+matrixMultiply m n | cols m /= rows n = error "matrixMultiply: dimension mismatch"+matrixMultiply m n = matrix $ matrixMultiplyImpl (+) 0 (*) m_data n_data+    where m_data = row_major m+	  n_data = transpose $ row_major n++matrixTranspose :: Matrix -> Matrix+matrixTranspose = matrix . colMajorForm -- works because matrix expects row major form+\end{code}++\subsection{Inverse and determinant of a matrix}++\begin{code}+matrixInverse :: Matrix -> Matrix+matrixInverse = matrix_inverse+\end{code}++\begin{code}+determinant :: Matrix -> Double+determinant = matrix_determinant+\end{code}++reduceMatrix eliminates the row and column corresponding to a specific element of a matrix.++\begin{code}+reduceMatrix :: Matrix -> (Int,Int) -> Matrix+reduceMatrix m (i,j) =+    let (above,below) = splitAt j $ rowMajorForm m+        (left,right) = splitAt i $ transpose $ above ++ tail below+        in matrix $ transpose $ left ++ tail right+\end{code}++The minor of an element of a matrix is the determinant of the matrix that is formed by removing+the row and column corresponding to that element (see reduceMatrix).++\begin{code}+matrixMinor :: Matrix -> (Int,Int) -> Double+matrixMinor m ij = determinant $ reduceMatrix m ij+\end{code}++The cofactor of m at (i,j) is the minor of m at (i,j), multiplied by -1 at checkerboarded elements.++\begin{code}+matrixCofactor :: Matrix -> (Int,Int) -> Double+matrixCofactor m (0,0) | rows m == 1 && cols m == 1 = matrixAt m (0,0)+matrixCofactor m (i,j) = (-1)^(i+j) * matrixMinor m (i,j)+\end{code}++Implementation of determinant and matrix inverse for matrices of Rationals.++\begin{code}+matrixInversePrim :: Matrix -> Matrix+matrixInversePrim m | rows m /= cols m = error "matrixInversePrim: not a square matrix"+matrixInversePrim m | determinant m == 0 = error "matrixInversePrim: det m = 0"+matrixInversePrim m = +    let scale_factor = 1 / determinant m+        in matrixTranspose $ matrix [[scale_factor * matrixCofactor m (i,j) | i <- [0..(cols m-1)]]+                                                                            | j <- [0..(rows m-1)]]++determinantPrim :: Matrix -> Double+determinantPrim m | rows m /= cols m = error "determinantPrim: not a square matrix"+determinantPrim (Matrix { row_major=[[x]] }) = x+determinantPrim m = sum $ zipWith (*) (rowAt m 0) $ map (\x -> matrixCofactor m (x,0)) [0..(cols m - 1)]+\end{code}
+ RSAGL/Model.lhs view
@@ -0,0 +1,501 @@+\section{Haskell as a 3D Modelling Language: RSAGL.Model}++RSAGL.Model seeks to provide a complete set of high-level modelling primitives for OpenGL.++\begin{code}+{-# OPTIONS_GHC -fglasgow-exts #-}++module RSAGL.Model+    (Model,+     Modeling,+     ModelingM,+     MaterialM,+     IntermediateModel,+     parIntermediateModel,+     generalSurface,+     extractModel,+     toIntermediateModel,+     intermediateModelToOpenGL,+     intermediateModelToVertexCloud,+     splitOpaques,+     modelingToOpenGL,+     sphere,+     torus,+     openCone,+     closedCone,+     openDisc,+     closedDisc,+     quadralateral,+     triangle,+     box,+     sor,+     tube,+     prism,+     adaptive,+     fixed,+     tesselationHintComplexity,+     twoSided,+     attribute,+     withAttribute,+     model,+     RGBFunction,RGBAFunction,+     material,pigment,specular,emissive,transparent,+     MonadAffine(..),+     turbulence,+     deform,+     sphericalCoordinates,+     cylindricalCoordinates,+     toroidalCoordinates,+     planarCoordinates,+     transformUnitCubeToUnitSphere,+     transformUnitSquareToUnitCircle)+    where++import RSAGL.Curve+import RSAGL.Auxiliary+import Control.Applicative+import RSAGL.ApplicativeWrapper+import Data.Traversable+import RSAGL.Deformation+import RSAGL.Vector+import RSAGL.Material+import RSAGL.Tesselation+import RSAGL.Optimization+import RSAGL.Interpolation+import RSAGL.Affine+import RSAGL.CoordinateSystems+import RSAGL.Angle+import RSAGL.Color+import RSAGL.Extrusion+import RSAGL.BoundingBox+import Data.List as List+import Data.Maybe+import qualified Control.Monad.State as State+import Data.Monoid+import Control.Parallel.Strategies+import Graphics.Rendering.OpenGL.GL.VertexSpec+import Graphics.Rendering.OpenGL.GL.BasicTypes+import Graphics.Rendering.OpenGL.GL.Colors (lightModelTwoSide,Face(..))+import Graphics.Rendering.OpenGL.GL.StateVar as StateVar+import Graphics.Rendering.OpenGL.GL.Polygons+import Control.Arrow hiding (pure)+\end{code}++\subsection{Modeling Primitives}++A ModeledSurface consists of several essential fields: \texttt{ms\_surface} is the geometric surface.++\texttt{ms\_material} defaults to invisible if no material is ever applied.  The functions \texttt{pigment}, \texttt{transparent}, \texttt{emissive}, and \texttt{specular} apply material properties to a surface.++Scope is controlled by \texttt{model} and \texttt{withAttribute}.  \texttt{model} creates a block of modeling operations that don't affect any surfaces outside of that block.  \texttt{withAttribute} restricts all operations to a subset of surfaces defined by \texttt{attribute}.++\texttt{ms\_tesselation} describes how the model will be tesselated into polygons before being sent to OpenGL.+By default, the \texttt{adaptive} model is used, which adapts to the contour and material of each surface.+\texttt{fixed} can be used to crudely force the tesselation of objects.++\begin{code}+type Model attr = [ModeledSurface attr]++data ModeledSurface attr = ModeledSurface {+    ms_surface :: Surface SurfaceVertex3D,+    ms_material :: Material,+    ms_affine_transform :: Maybe AffineTransformation,+    ms_tesselation :: Maybe ModelTesselation,+    ms_tesselation_hint_complexity :: Integer,+    ms_two_sided :: Bool,+    ms_attributes :: attr }++data ModelTesselation = Adaptive+                      | Fixed (Integer,Integer)++data Quasimaterial = forall a. Quasimaterial (ApplicativeWrapper ((->)SurfaceVertex3D) a) (MaterialSurface a -> Material)++newtype ModelingM attr a = ModelingM (State.State (Model attr) a) deriving (Monad)+newtype MaterialM attr a = MaterialM (State.State [Quasimaterial] a) deriving (Monad)+type Modeling attr = ModelingM attr ()++instance State.MonadState [ModeledSurface attr] (ModelingM attr) where+    get = ModelingM State.get+    put = ModelingM . State.put++instance State.MonadState [Quasimaterial] (MaterialM attr) where+    get = MaterialM State.get+    put = MaterialM . State.put++extractModel :: Modeling attr -> Model attr+extractModel (ModelingM m) = State.execState m []++appendSurface :: (Monoid attr) => Surface SurfaceVertex3D -> Modeling attr+appendSurface s = State.modify $ mappend $ [ModeledSurface {+    ms_surface = s,+    ms_material = mempty,+    ms_affine_transform = Nothing,+    ms_tesselation = Nothing,+    ms_tesselation_hint_complexity = 1,+    ms_two_sided = False,+    ms_attributes = mempty }]++generalSurface :: (Monoid attr) => Either (Surface Point3D) (Surface (Point3D,Vector3D)) -> Modeling attr+generalSurface (Right pvs) = appendSurface $ uncurry SurfaceVertex3D <$> pvs+generalSurface (Left points) = appendSurface $ surfaceNormals3D points++tesselationHintComplexity :: (Monoid attr) => Integer -> Modeling attr+tesselationHintComplexity i = State.modify (map $ \m -> m { ms_tesselation_hint_complexity = i })++twoSided :: (Monoid attr) => Bool -> Modeling attr+twoSided two_sided = State.modify (map $ \m -> m { ms_two_sided = two_sided })++model :: Modeling attr -> Modeling attr+model (ModelingM actions) = State.modify (State.execState actions [] ++)++attribute :: (Monoid attr) => attr -> Modeling attr+attribute attr = State.modify (map $ \m -> m { ms_attributes = attr `mappend` ms_attributes m })++withAttribute :: (attr -> Bool) -> Modeling attr -> Modeling attr+withAttribute f actions = withFilter (f . ms_attributes) actions++withFilter :: (ModeledSurface attr -> Bool) -> Modeling attr -> Modeling attr+withFilter f (ModelingM actions) = State.modify (\m -> State.execState actions (filter f m) ++ filter (not . f) m)++class MonadMaterial m where+    material :: MaterialM attr () -> m attr ()++instance MonadMaterial ModelingM where+    material (MaterialM actions) = withFilter (materialIsEmpty . ms_material) $ mapM_ appendQuasimaterial $ State.execState actions []++instance MonadMaterial MaterialM where+    material (MaterialM actions) = State.modify (++ State.execState actions [])++appendQuasimaterial :: Quasimaterial -> ModelingM attr ()+appendQuasimaterial (Quasimaterial vertexwise_f material_constructor) | isPure vertexwise_f = State.modify (map $ \m ->+    m { ms_material = ms_material m `mappend` (material_constructor $ pure $ fromJust $ fromPure vertexwise_f) })+appendQuasimaterial (Quasimaterial vertexwise_f material_constructor) = State.modify (map $ \m ->+    m { ms_material = ms_material m `mappend` (material_constructor $ +                          wrapApplicative $ fmap (toApplicative vertexwise_f) $ ms_surface m) })++type RGBFunction = ApplicativeWrapper ((->) SurfaceVertex3D) RGB+type RGBAFunction = ApplicativeWrapper ((->) SurfaceVertex3D) RGBA++pigment :: RGBFunction -> MaterialM attr ()+pigment rgbf = State.modify (++ [Quasimaterial rgbf diffuseLayer])++specular :: GLfloat -> RGBFunction -> MaterialM attr ()+specular shininess rgbf = State.modify (++ [Quasimaterial rgbf (flip specularLayer shininess)])++emissive :: RGBFunction -> MaterialM attr ()+emissive rgbf = State.modify (++ [Quasimaterial rgbf emissiveLayer])++transparent :: RGBAFunction -> MaterialM attr ()+transparent rgbaf = State.modify (++ [Quasimaterial rgbaf transparentLayer])++adaptive :: Modeling attr+adaptive = State.modify (map $ \m -> m { ms_tesselation = ms_tesselation m `State.mplus` (Just Adaptive) })++fixed :: (Integer,Integer) -> Modeling attr+fixed x = State.modify (map $ \m -> m { ms_tesselation = ms_tesselation m `State.mplus` (Just $ Fixed x) })++instance AffineTransformable (ModelingM attr ()) where+    transform mx m = model $ m >> affine (transform mx)++instance AffineTransformable (MaterialM attr ()) where+    transform mx m = material $ m >> affine (transform mx)++class MonadAffine m where+    affine :: AffineTransformation -> m ()++instance MonadAffine (ModelingM attr) where+    affine f = State.modify $ map (\x -> x { ms_affine_transform = Just $ (f .) $ fromMaybe id $ ms_affine_transform x })++instance MonadAffine (MaterialM attr) where+    affine f = turbulence (inverseTransformation f)++turbulence :: (SurfaceVertex3D -> SurfaceVertex3D) -> MaterialM attr ()+turbulence g = State.modify $ map (\(Quasimaterial f c) -> Quasimaterial +        (either (wrapApplicative . (. g)) pure $ unwrapApplicative f) c)++deform :: (DeformationClass dc) => dc -> Modeling attr+deform dc = +    do finishModeling+       case deformation dc of+                (Left f) -> State.modify (map $ \m -> m { ms_surface = surfaceNormals3D $ fmap f $ ms_surface m })+                (Right f) -> State.modify (map $ \m -> m { ms_surface = fmap (sv3df f) $ ms_surface m })+  where sv3df f sv3d = let SurfaceVertex3D p v = f sv3d in SurfaceVertex3D p (vectorNormalize v)++finishModeling :: Modeling attr+finishModeling = State.modify (map $ \m -> if isNothing (ms_affine_transform m) then m else finishAffine m)+    where finishAffine m = m { ms_surface = fmap (\(SurfaceVertex3D p v) -> SurfaceVertex3D p (vectorNormalize v)) $+                                                     transformation (fromJust $ ms_affine_transform m) (ms_surface m),+                               ms_affine_transform = Nothing }+\end{code}++\subsection{Coordinate System Alternatives for Parametric Surface Models}++\begin{code}+sphericalCoordinates :: ((Angle,Angle) -> a) -> Surface a+sphericalCoordinates f = surface $ curry (f . (\(u,v) -> (fromRadians $ u*2*pi,fromRadians $ ((pi/2) - v*pi) * (1 - 0.5^10))))++cylindricalCoordinates :: ((Angle,Double) -> a) -> Surface a+cylindricalCoordinates f = surface $ curry (f . (\(u,v) -> (fromRadians $ u*2*pi,v)))++toroidalCoordinates :: ((Angle,Angle) -> a) -> Surface a+toroidalCoordinates f = surface $ curry (f . (\(u,v) -> (fromRadians $ u*2*pi,fromRadians $ negate $ v*2*pi)))++planarCoordinates :: Point3D -> Vector3D -> ((Double,Double) -> (Double,Double)) -> Surface (Point3D,Vector3D)+planarCoordinates center upish f = surface (curry $ g . f)+    where (u',v') = orthos upish+          g (u,v) = (translate (vectorScale u u' `vectorAdd` vectorScale v v') center, upish)++transformUnitSquareToUnitCircle :: (Double,Double) -> (Double,Double)+transformUnitSquareToUnitCircle (u,v) = (x,z)+    where (Point3D x _ z) = transformUnitCubeToUnitSphere (Point3D u 0.5 v)++transformUnitCubeToUnitSphere :: Point3D -> Point3D+transformUnitCubeToUnitSphere p =+    let p_centered@(Point3D x y z) = scale' 2.0 $ translate (Vector3D (-0.5) (-0.5) (-0.5)) p+        p_projected = scale' (minimum [recip $ abs x,recip $ abs y,recip $ abs z]) p_centered+        k = recip $ distanceBetween origin_point_3d p_projected+        in if p_centered == origin_point_3d then origin_point_3d else scale' k p_centered+\end{code}++\subsection{Simple Geometric Shapes}++\begin{code}+sphere :: (Monoid attr) => Point3D -> Double -> Modeling attr+sphere (Point3D x y z) radius = model $ do+    generalSurface $ Right $+        sphericalCoordinates $ (\(u,v) -> +            let sinev = sine v+                cosinev = cosine v+                sineu = sine u+                cosineu = cosine u+                point = Point3D (x + radius * cosinev * cosineu)+                                (y + radius * sinev)+                                (z + radius * cosinev * sineu)+                vector = Vector3D (cosinev * cosineu)+                                  (sinev)+                                  (cosinev * sineu)+                in (point,vector))++torus :: (Monoid attr) => Double -> Double -> Modeling attr+torus major minor = model $+    do generalSurface $ Right $+        toroidalCoordinates $ \(u,v) ->+            (Point3D ((major + minor * cosine v) * cosine u)+                     (minor * sine v)+                     ((major + minor * cosine v) * sine u),+             Vector3D (cosine v * cosine u)+                      (minor * sine v)+                      (cosine v * sine u))+       tesselationHintComplexity $ round $ major / minor++openCone :: (Monoid attr) => (Point3D,Double) -> (Point3D,Double) -> Modeling attr+openCone (a,a_radius) (b,b_radius) = model $+    do generalSurface $ Right $+           cylindricalCoordinates $ \(u,v) ->+               let uv' = vectorScale (cosine u) u' `vectorAdd` vectorScale (sine u) v'+                   in (translate (vectorScale (lerp v (a_radius,b_radius)) uv') $ lerp v (a,b),+                       vectorNormalize $ vectorScale slope axis `vectorAdd` uv')+           where (u',v') = orthos axis+                 axis = vectorNormalize $ vectorToFrom b a+                 slope = (b_radius - a_radius) / distanceBetween a b++openDisc :: (Monoid attr) => Double -> Double -> Modeling attr+openDisc inner_radius outer_radius = model $ +    do generalSurface $ Right $+        cylindricalCoordinates $ \(u,v) -> +             (Point3D (lerp v (inner_radius,outer_radius) * cosine u)+                      0+                      (lerp v (inner_radius,outer_radius) * sine u),+              Vector3D 0 1 0)+       tesselationHintComplexity $ round $ (max outer_radius inner_radius / (abs $ outer_radius - inner_radius))++closedDisc :: (Monoid attr) => Point3D -> Vector3D -> Double -> Modeling attr+closedDisc center up_vector radius = model $+    do generalSurface $ Right $ planarCoordinates center up_vector $ ((* radius) *** (* radius)) <<< transformUnitSquareToUnitCircle++closedCone :: (Monoid attr) => (Point3D,Double) -> (Point3D,Double) -> Modeling attr+closedCone a b = model $+    do openCone a b+       closedDisc (fst a) (vectorToFrom (fst a) (fst b)) (snd a * (1 + recip (2^8)))+       closedDisc (fst b) (vectorToFrom (fst b) (fst a)) (snd b * (1 + recip (2^8)))++quadralateral :: (Monoid attr) => Point3D -> Point3D -> Point3D -> Point3D -> Modeling attr+quadralateral a b c d = model $ +    do normal_vector <- return $ newell [a,b,c,d]+       generalSurface $ Right $ surface $ \u v -> (lerp v (lerp u (a,b), lerp u (d,c)),normal_vector)++triangle :: (Monoid attr) => Point3D -> Point3D -> Point3D -> Modeling attr+triangle a b c | distanceBetween a b > distanceBetween b c = triangle c a b+triangle a b c | distanceBetween a c > distanceBetween b c = triangle b c a+triangle a b c = quadralateral a b (lerp 0.5 (b,c)) c++box :: (Monoid attr) => Point3D -> Point3D -> Modeling attr+box (Point3D x1 y1 z1) (Point3D x2 y2 z2) = model $+    do let [lx,hx] = sort [x1,x2]+       let [ly,hy] = sort [y1,y2]+       let [lz,hz] = sort [z1,z2]+       let u = minimum [hx-lx,hy-ly,hz-lz] / 2^8+       let (lx',ly',lz',hx',hy',hz') = (lx-u,ly-u,lz-u,hx+u,hy+u,hz+u)+       quadralateral (Point3D lx' ly' lz) (Point3D lx' hy' lz) (Point3D hx' hy' lz) (Point3D hx' ly' lz)  -- near+       quadralateral (Point3D lx' ly' hz) (Point3D hx' ly' hz) (Point3D hx' hy' hz) (Point3D lx' hy' hz)  -- far+       quadralateral (Point3D lx' ly lz') (Point3D hx' ly lz') (Point3D hx' ly hz') (Point3D lx' ly hz')  -- bottom+       quadralateral (Point3D lx' hy lz') (Point3D lx' hy hz') (Point3D hx' hy hz') (Point3D hx' hy lz')  -- top+       quadralateral (Point3D lx ly' lz') (Point3D lx ly' hz') (Point3D lx hy' hz') (Point3D lx hy' lz')  -- left+       quadralateral (Point3D hx ly' lz') (Point3D hx hy' lz') (Point3D hx hy' hz') (Point3D hx ly' hz')  -- right++sor :: (Monoid attr) => Curve Point3D -> Modeling attr+sor c = model $ generalSurface $ Left $ transposeSurface $ wrapSurface $ curve (flip rotateY c . fromRotations)++tube :: (Monoid attr) => Curve (Double,Point3D) -> Modeling attr+tube c | radius <- fmap fst c +       , spine <- fmap snd c = +    model $ generalSurface $ Left $ extrudeTube radius spine++prism :: (Monoid attr) => Vector3D -> (Point3D,Double) -> (Point3D,Double) -> Curve Point3D -> Modeling attr+prism upish ara brb c = model $ generalSurface $ Left $ extrudePrism upish ara brb c+\end{code}++\subsection{Rendering Models to OpenGL}++\begin{code}+data IntermediateModel = IntermediateModel [IntermediateModeledSurface]+data IntermediateModeledSurface = IntermediateModeledSurface [(TesselatedSurface SingleMaterialSurfaceVertex3D,MaterialLayer)] Bool+data SingleMaterialSurfaceVertex3D = SingleMaterialSurfaceVertex3D SurfaceVertex3D MaterialVertex3D+data MultiMaterialSurfaceVertex3D = MultiMaterialSurfaceVertex3D SurfaceVertex3D [MaterialVertex3D]+data MaterialVertex3D = MaterialVertex3D RGBA Bool++intermediateModelToOpenGL :: IntermediateModel -> IO ()+intermediateModelToOpenGL (IntermediateModel ms) = mapM_ intermediateModeledSurfaceToOpenGL ms++modelingToOpenGL :: Integer -> Modeling attr -> IO ()+modelingToOpenGL n modeling = intermediateModelToOpenGL $ toIntermediateModel n modeling++toIntermediateModel :: Integer -> Modeling attr -> IntermediateModel+toIntermediateModel n modeling = IntermediateModel $ zipWith intermediateModeledSurface complexities ms+    where complexities = allocateComplexity sv3d_ruler (map (\m -> (ms_surface m,extraComplexity m)) ms) n+          ms = extractModel (modeling >> finishModeling)+          extraComplexity m = (1 + fromInteger (ms_tesselation_hint_complexity m)) * +                              (1 + fromInteger (materialComplexity $ ms_material m))++intermediateModeledSurfaceToOpenGL :: IntermediateModeledSurface -> IO ()+intermediateModeledSurfaceToOpenGL (IntermediateModeledSurface layers two_sided) = +    do lmts <- get lightModelTwoSide+       cf <- get cullFace+       lightModelTwoSide $= (if two_sided then Enabled else Disabled)+       cullFace $= (if two_sided then Nothing else Just Back)+       foldr (>>) (return ()) $ map (uncurry layerToOpenGL) layers+       lightModelTwoSide $= lmts+       cullFace $= cf++intermediateModeledSurface :: Integer -> ModeledSurface attr -> IntermediateModeledSurface+intermediateModeledSurface n m = IntermediateModeledSurface (zip (selectLayers (genericLength layers) tesselation) layers)+                                                            (ms_two_sided m)+    where layers = toLayers $ ms_material m+          color_material_layers :: [Surface RGBA]+          color_material_layers = map (toApplicative . materialLayerSurface) layers+          relevance_layers :: [Surface Bool]+          relevance_layers = map (toApplicative . materialLayerRelevant) layers+          the_surface = zipSurface (MultiMaterialSurfaceVertex3D) (ms_surface m) $ +                                  sequenceA $ zipWith (zipSurface MaterialVertex3D) color_material_layers relevance_layers+          tesselation = case fromMaybe Adaptive $ ms_tesselation m of+                             Adaptive -> optimizeSurface msv3d_ruler the_surface (n `div` genericLength layers)+                             Fixed uv -> tesselateSurface the_surface uv++selectLayers :: Integer -> TesselatedSurface MultiMaterialSurfaceVertex3D -> [TesselatedSurface SingleMaterialSurfaceVertex3D]+selectLayers n layered = map (\k -> map (fmap (\(MultiMaterialSurfaceVertex3D sv3d mv3ds) -> +                                                 SingleMaterialSurfaceVertex3D sv3d (mv3ds `genericIndex` k))) layered) [0..(n-1)]++layerToOpenGL :: TesselatedSurface SingleMaterialSurfaceVertex3D -> MaterialLayer -> IO ()+layerToOpenGL tesselation layer = materialLayerToOpenGLWrapper layer (tesselationsLoop tesselation)+        where tesselationsLoop [] = return()+              tesselationsLoop (t:rest) = do tesselatedElementToOpenGL toOpenGL t+                                             tesselationsLoop rest+              vertexToOpenGLWithMaterialColor (SingleMaterialSurfaceVertex3D +                                                  (SurfaceVertex3D (Point3D px py pz) (Vector3D vx vy vz))+                                                  (MaterialVertex3D color_material _)) =+                  do rgbaToOpenGL color_material+                     normal $ Normal3 vx vy vz+                     vertex $ Vertex3 px py pz+              vertexToOpenGL (SingleMaterialSurfaceVertex3D (SurfaceVertex3D (Point3D px py pz) (Vector3D vx vy vz)) _) =+                  do normal $ Normal3 vx vy vz+                     vertex $ Vertex3 px py pz+              toOpenGL = if isPure $ materialLayerSurface layer then vertexToOpenGL else vertexToOpenGLWithMaterialColor++\end{code}++\subsubsection{Seperating Opaque and Transparent Surfaces}++\texttt{splitOpaques} breaks an \texttt{IntermediateModel} into a pair containing the completely opaque surfaces of the model and a list+of transparent \texttt{IntermediateModel}s.++\begin{code}+splitOpaques :: IntermediateModel -> (IntermediateModel,[IntermediateModel])+splitOpaques (IntermediateModel ms) = (IntermediateModel opaques,map (\x -> IntermediateModel [x]) transparents)+    where opaques = filter isOpaque surfaces+          transparents = filter (not . isOpaque) surfaces+          isOpaque (IntermediateModeledSurface layers _) = any (isOpaqueLayer . snd) layers+	  notEmpty (IntermediateModeledSurface layers _) = not $ null layers+	  surfaces = filter notEmpty ms+\end{code}++\subsubsection{Vertex Clouds and Bounding Boxes for IntermediateModels}++\begin{code}+intermediateModelToVertexCloud :: IntermediateModel -> [SurfaceVertex3D]+intermediateModelToVertexCloud (IntermediateModel ms) = concatMap intermediateModeledSurfaceToVertexCloud ms++instance Bound3D IntermediateModel where+    boundingBox (IntermediateModel ms) = boundingBox ms++intermediateModeledSurfaceToVertexCloud :: IntermediateModeledSurface -> [SurfaceVertex3D]+intermediateModeledSurfaceToVertexCloud (IntermediateModeledSurface layers _) = +    fromMaybe [] $ fmap (map strip . tesselatedSurfaceToVertexCloud . fst) $ listToMaybe layers+        where strip (SingleMaterialSurfaceVertex3D sv3d _) = sv3d++instance Bound3D IntermediateModeledSurface where+    boundingBox = boundingBox . intermediateModeledSurfaceToVertexCloud+\end{code}++\subsubsection{Rulers and Concavity Detection}++\begin{code}+sv3d_ruler :: SurfaceVertex3D -> SurfaceVertex3D -> Double+sv3d_ruler a b = sv3d_distance_ruler a b * (1.0 + sv3d_normal_ruler a b)++sv3d_distance_ruler :: SurfaceVertex3D -> SurfaceVertex3D -> Double+sv3d_distance_ruler (SurfaceVertex3D p1 _) (SurfaceVertex3D p2 _) =+    distanceBetween p1 p2++sv3d_normal_ruler :: SurfaceVertex3D -> SurfaceVertex3D -> Double+sv3d_normal_ruler (SurfaceVertex3D _ v1) (SurfaceVertex3D _ v2) =+    abs $ (1-) $ dotProduct v1 v2++msv3d_ruler :: MultiMaterialSurfaceVertex3D -> MultiMaterialSurfaceVertex3D -> Double+msv3d_ruler (MultiMaterialSurfaceVertex3D p1 _) (MultiMaterialSurfaceVertex3D p2 _) =+    sv3d_ruler p1 p2++instance ConcavityDetection MultiMaterialSurfaceVertex3D where+    toPoint3D (MultiMaterialSurfaceVertex3D (SurfaceVertex3D p _) _) = p+\end{code}++\subsubsection{Parallelism for IntermediateModels}++\begin{code}+instance NFData IntermediateModel where+    rnf (IntermediateModel ms) = rnf ms++parIntermediateModel :: Strategy IntermediateModel+parIntermediateModel (IntermediateModel ms) = waitParList parIntermediateModeledSurface ms++instance NFData IntermediateModeledSurface where+    rnf (IntermediateModeledSurface layers two_sided) = rnf (layers,two_sided)++parIntermediateModeledSurface :: Strategy IntermediateModeledSurface+parIntermediateModeledSurface (IntermediateModeledSurface layers _) = waitParList rnf layers++instance NFData SingleMaterialSurfaceVertex3D where+    rnf (SingleMaterialSurfaceVertex3D sv3d mv3d) = rnf (sv3d,mv3d)++instance NFData MaterialVertex3D where+    rnf (MaterialVertex3D cm b) = rnf (cm,b)+\end{code}
+ RSAGL/ModelingExtras.lhs view
@@ -0,0 +1,163 @@+\section{Pre-specified Colors, Models, Materials and Deformations}++\begin{code}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module RSAGL.ModelingExtras+    (gray,+     gray256,+     smoothbox,+     regularPrism,+     rotationGroup,+     glass,+     plastic,+     metallic,+     pattern,+     cloudy,+     blinkBoxes,+     spherical,+     directional,+     gradient,+     bumps,+     waves,+     ColorFunction,+     Pattern,+     module RSAGL.RSAGLColors,+     module RSAGL.Material,+     module RSAGL.ApplicativeWrapper,+     module Control.Applicative)+    where++import Graphics.Rendering.OpenGL.GL.BasicTypes+import RSAGL.Noise+import RSAGL.RSAGLColors+import Control.Applicative+import RSAGL.ApplicativeWrapper+import RSAGL.Vector+import RSAGL.Material+import RSAGL.Affine+import RSAGL.Model+import System.Random+import RSAGL.Interpolation+import Data.Monoid+import RSAGL.Auxiliary+import RSAGL.Angle+\end{code}++\subsection{Colors}++\texttt{RSAGL.ModellingSupport} exports the contents of \texttt{rsagl-colors.txt}.  This file is translated to HTML and Haskell source by the script in \texttt{ProcessColors.hs}.  Color samples can be viewed by opening the file \texttt{rsagl-colors.html} in a web browser.++With the exception of \texttt{blackbody}, all of the colors contain non-zero values for the red, green, and blue components, so that extremely bright lights will (realistically) wash those colors out to white.++\begin{code}+gray :: Float -> RGB+gray x = rgb x x x++gray256 :: (Integral i) => i -> RGB+gray256 x = rgb256 x x x+\end{code}++\subsection{Models}++\texttt{smoothbox} is a box that takes an extra smoothing parameter between 0 and 1.  This box doesn't have perfectly flat normals, and may therefore be a little easier on the eye.++\begin{code}+smoothbox :: (Monoid attr) => Double -> Point3D -> Point3D -> Modeling attr+smoothbox u p q = model $+    do box p q+       deform $ \(SurfaceVertex3D point vector) -> SurfaceVertex3D point $ vectorNormalize $ lerp u (vector,vectorNormalize $ vectorToFrom point midpoint)+        where midpoint = lerp 0.5 (p,q)+\end{code}++\texttt{regularPrism} constructs a regular n-sided prism or pyramid.++\begin{code}+regularPrism ::(Monoid attr) => (Point3D,Double) -> (Point3D,Double) -> Integer -> Modeling attr+regularPrism (a,ra) (b,rb) n = +    model $ translate (vectorToFrom a origin_point_3d) $ +        rotateToFrom (Vector3D 0 1 0) (vectorToFrom b a) $ sequence_ $ rotationGroup (Vector3D 0 1 0) n $ quad+  where a1 = Point3D 0 0 ra+        a2 = rotateY (fromRotations $ recip $ fromInteger n) a1+        b1 = Point3D 0 (distanceBetween a b) rb+        b2 = rotateY (fromRotations $ recip $ fromInteger n) b1+        quad = quadralateral a1 a2 b2 b1+\end{code}++\texttt{rotationGroup} rotates a model repeatedly.++\begin{code}+rotationGroup :: (AffineTransformable a) => Vector3D -> Integer -> a -> [a]+rotationGroup v n m = map (flip (rotate v) m . fromRotations) $ tail $ zeroToOne (n+1)+\end{code}++\subsection{Patterns}++\texttt{cloudy} is a pattern made using perlin noise.  \texttt{spherical} is a pattern that ranges from the center of a sphere to its radius, where the center maps to zero and the radius maps to one.  \texttt{directional} is a pattern based on the directional (infinite) light source.  An object rendered with an emissive layer defined by a directional light source will seem to be lit from that direction.++\begin{code}+type ColorFunction a = ApplicativeWrapper ((->) SurfaceVertex3D) a++type Pattern = SurfaceVertex3D -> Double++pattern :: (ColorClass a) => Pattern -> [(GLfloat,ColorFunction a)] -> ColorFunction a+pattern _ [(_,constant_pattern)] = constant_pattern+pattern f color_map = wrapApplicative (\sv3d -> toApplicative (lerpMap color_map $ realToFrac $ f sv3d) $ sv3d)++cloudy :: Int -> Double -> Pattern+cloudy seed wave_length (SurfaceVertex3D p _) = perlinNoise (translate offset $ scale' frequency p) + 0.5+    where frequency = recip wave_length+          offset = vectorNormalize $ fst $ randomXYZ (-1000.0*wave_length,1000.0*wave_length) (mkStdGen seed)++blinkBoxes :: Int -> Double -> Double -> Double -> Pattern+blinkBoxes seed box_size chaos threshold = thresholdF . cloudy seed (recip chaos) . toLatticeCoordinates+    where thresholdF u = if u > threshold then 1.0 else 0.0+          toLatticeCoordinates (SurfaceVertex3D (Point3D x y z) v) = +              SurfaceVertex3D (Point3D (to1LatticeCoordinate x) (to1LatticeCoordinate y) (to1LatticeCoordinate z)) v+          to1LatticeCoordinate u = realToFrac $ round $ u/box_size++spherical :: Point3D -> Double -> Pattern+spherical center radius (SurfaceVertex3D p _) = distanceBetween center p / radius++directional :: Vector3D -> Pattern+directional vector (SurfaceVertex3D _ v) = dotProduct (vectorNormalize v) normalized_vector+    where normalized_vector = vectorNormalize vector++gradient :: Point3D -> Vector3D -> Pattern+gradient center vector (SurfaceVertex3D p _) = dotProduct vector (vectorToFrom p center) / vectorLengthSquared vector+\end{code}++\subsection{Materials}++\begin{code}+glass :: RGBFunction -> MaterialM attr ()+glass rgbf = +    do transparent $ (alpha 0.05) <$> rgbf+       specular 100 $ (\rgb_color -> curry (lerp (brightness rgb_color)) rgb_color white) <$> rgbf++plastic :: RGBFunction -> MaterialM attr ()+plastic rgbf = +    do pigment rgbf+       specular 50 (pure white)++metallic :: RGBFunction -> MaterialM attr ()+metallic rgbf = +    do pigment rgbf+       specular 75 rgbf+\end{code}++\subsection{Deformations}++\texttt{bumps} can be used to describe any deformation in which vertices are purturbed in the direction of their normal vectors.++\texttt{waves} is a deformation that makes little waves in a surface.++\begin{code}+bumps :: Pattern -> Modeling attr+bumps f = deform $ (\(sv3d@(SurfaceVertex3D p v)) -> translate (vectorScale (f sv3d) v) p)++waves :: Double -> Double -> Pattern+waves wave_length amplitude (SurfaceVertex3D (Point3D x y z) _) = (wave_f x + wave_f y + wave_f z) * amplitude / 3+    where wave_f u = sin (u / wave_length * 2*pi)+\end{code}
+ RSAGL/Noise.lhs view
@@ -0,0 +1,82 @@+\section{Generating Noise: RSAGL.Noise}+\ref{RSAGLNoise}++\begin{code}+module RSAGL.Noise+    (perlinTurbulence,perlinNoise)+    where++import RSAGL.Interpolation+import RSAGL.Vector+import Data.Array.Unboxed+import Data.Fixed++perlinTurbulence :: Double -> Point3D -> Point3D+perlinTurbulence s (Point3D x y z) = Point3D (x + s*perlinNoise x') (y + s*perlinNoise y') (z + s*perlinNoise z')+    where x' = Point3D (x+100) y z+          y' = Point3D x (y+100) z+          z' = Point3D x y (z+100)++-- |+-- Intellectual property note:+--+-- This is based on Perlin's improved noise reference implementation.+-- I'm assuming from the manner in which it is published and the usage+-- of the term "reference implementation" that it was intended to be+-- the basis of derivative code such as this.+--+perlinNoise :: Point3D -> Double+perlinNoise (Point3D x0 y0 z0) =+   let (x,x') = divMod' x0 1 :: (Int,Double)+       (y,y') = divMod' y0 1 :: (Int,Double)+       (z,z') = divMod' z0 1 :: (Int,Double)+       (u,v,w) = (fade x',fade y',fade z')+       a = pRandom x + y+       aa = pRandom a + z+       ab = pRandom (a+1) + z+       b = pRandom (x+1) + y+       ba = pRandom b + z+       bb = pRandom (b+1) + z+       f n = let nn = n in nn / (1 + abs nn)  -- this function forces the result into the range -1..1+       in f $ lerp w+            (lerp v (lerp u (grad (pRandom aa) x' y' z', grad (pRandom ba) (x'-1) y' z'),+                     lerp u (grad (pRandom ab) x' (y'-1) z', grad (pRandom bb) (x'-1) (y'-1) z')),+             lerp v (lerp u (grad (pRandom $ aa + 1) x' y' (z'-1), grad (pRandom $ ba + 1) (x'-1) y' (z'-1)),+                     lerp u (grad (pRandom $ ab + 1) x' (y'-1) (z'-1), grad (pRandom $ bb + 1) (x'-1) (y'-1) (z'-1))))+++pRandom :: Int -> Int+pRandom n = ps ! (n `mod` 256)++ps :: UArray Int Int+ps = listArray (0,255) [226,110,184,248,226,248,61,22,185,81,167,22,54,100,244,77,84,86,184,134,88,117,66,3,53,77,172,108,151,115,131,61,142,31,0,135,12,245,73,119,186,+  203,6,7,39,253,184,133,99,118,230,220,143,113,44,59,249,81,241,125,115,136,58,254,8,193,84,221,83,188,122,76,88,121,246,82,20,142,121,167,27,181,145,73,13,1521,165,100,+  150,197,87,45,171,151,138,40,14,230,81,162,84,10,138,20,43,70,78,18,77,43,108,177,108,102,135,220,136,11,77,234,62,32,156,190,56,44,168,177,105,143,236,255,181,203,67,+  137,31,28,199,214,47,177,61,81,205,25,138,215,6,251,53,125,102,177,30,28,210,50,255,18,71,230,215,158,58,137,3,130,105,183,226,0,159,71,75,132,254,211,158,186,196,33,+  20,72,55,74,241,165,118,67,56,118,70,82,22,159,177,126,242,102,97,213,63,22,69,68,248,247,46,148,202,228,200,242,4,29,251,71,46,222,57,33,179,226,147,203,166,38,29,96,+  224,246,11,32,94,205,108,128,63,138,252,166,62,24,215,109,165,135,53,166,5,139,185,25,68]++fade :: Double -> Double+fade t = t ^ 3 * (t * (t * 6 - 15) + 10)++grad :: Int -> Double -> Double -> Double -> Double+grad hash x y z = +    case hash `mod` 12 of+                       0 -> x + y+                       1 -> (-x) + y+                       2 -> x + (-y)+                       3 -> (-x) + (-y)+                       4 -> z + y+                       5 -> (-z) + y+                       6 -> z + (-y)+                       7 -> (-z) + (-y)+                       8 -> z + x+                       9 -> (-z) + x+                       10 -> z + (-x)+                       11 -> (-z) + (-x)+                       _ -> error "grad: impossible case"++--+-- End of the Perlin noise functions derived from the reference implementation.+--+\end{code}
+ RSAGL/Optimization.lhs view
@@ -0,0 +1,113 @@+\section{Optimization of Rendered Surfaces}++\begin{code}+module RSAGL.Optimization+    (optimizeSurface,+     allocateComplexity,+     estimateSurfaceArea)+    where++import RSAGL.Auxiliary+import RSAGL.Curve+import Data.List as List+import RSAGL.Tesselation+\end{code}++\subsection{Surface Configurations}++A \texttt{SurfaceConfiguration} represents an arrangement of vertices over a surface, with the goal that the arrangement will be made optimally.++For example, the parametric equation of a sphere maps two-dimensional points making up a 1-by-1 square onto the three-dimensional sphere. If points are arranged evenly over the square, then those points will be concentrted tightly around the poles and loosely around the equator.++\texttt{SurfaceConfiguration} is the data structure that we try to optimize to get the ideal arrangement of points.+\begin{code}+data SurfaceConfiguration = SurfaceConfiguration [Integer]+    deriving (Eq,Ord,Show)+\end{code}++\subsection{Choosing an optimal level of detail}++The goal of \texttt{optimizeSurface} is to allocate points so they are spread roughly evenly over a surface.++To measure the distance between points, we use an abstract function called the ''ruler``, which nominally measures pythagorean distance but may measure some kind of percieved distance.++\begin{code}+optimizeSurface :: (ConcavityDetection a) => (a -> a -> Double) -> Surface a -> Integer -> TesselatedSurface a+optimizeSurface ruler s max_vertices =+              if score ordinary >= score transposed+              then tesselateSurfaceConfiguration s ordinary+              else tesselateSurfaceConfiguration (flipTransposeSurface s) transposed+    where ordinary = lengthProportional ruler s max_vertices+          transposed = lengthProportional ruler (flipTransposeSurface s) max_vertices+          score :: SurfaceConfiguration -> Double+          score (SurfaceConfiguration ielems) = +              let elems = map fromIntegral ielems+                  in (sum (map (abs . subtract (sum elems / fromIntegral (length elems))) elems) + 1) / sum elems++tesselateSurfaceConfiguration :: (ConcavityDetection a) => Surface a -> SurfaceConfiguration -> TesselatedSurface a+tesselateSurfaceConfiguration s (SurfaceConfiguration elems) = +        tesselateGrid $ map zto $ zipWith iterateCurve elems $+                                           halfIterateSurface (genericLength elems) s+    where zto xs = zip (zeroToOne $ genericLength xs) xs++\end{code}++\subsection{Estimating Surface Area and Curve Length}++\begin{code}+estimateCurveLength :: (a -> a -> Double) -> Curve a -> Double+estimateCurveLength ruler c = case sum $ map (uncurry ruler) $ doubles $ iterateCurve 16 c of -- 16 is arbitrary+    x | isNaN x || isInfinite x -> error "estimateCurveLength: NaN"+    x -> x++estimateSurfaceArea :: (ConcavityDetection a) => (a -> a -> Double) -> Surface a -> Double+estimateSurfaceArea ruler s = snd $ head $ dropWhile (\(x,y) -> y > x*1.125) $ doubles surface_areas_at_increasing_levels_of_detail+    where surface_areas_at_increasing_levels_of_detail = map (\d -> estimateTesselatedSurfaceArea ruler $ tesselateSurface s (d,d)) $ iterate (*2) 4++estimateTesselatedSurfaceArea :: (a -> a -> Double) -> TesselatedSurface a -> Double+estimateTesselatedSurfaceArea ruler pieces = sum $ map measurePiece pieces+   where measurePiece (TesselatedTriangleFan (v0:v1:v2:vs)) = heronsFormula ruler v0 v1 v2 ++                                                              measurePiece (TesselatedTriangleFan (v0:v2:vs))+         measurePiece (TesselatedQuadStrip (v0:v1:v2:v3:vs)) = heronsFormula ruler v0 v1 v2 ++                                                               heronsFormula ruler v2 v3 v1 ++                                                               measurePiece (TesselatedQuadStrip (v2:v3:vs))+         measurePiece _ = 0.0++heronsFormula :: (a -> a -> Double) -> a -> a -> a -> Double+heronsFormula ruler v0 v1 v2 = max 0 $ (/ 4) $ sqrt $ (a + (b + c)) * (c - (a - b)) * (c + (a - b)) * (a + (b - c))+    where a_ = ruler v0 v1+          b_ = ruler v1 v2+          c_ = ruler v2 v0+          [c,b,a] = sort [a_,b_,c_]++\end{code}++\subsection{Allocating Proportional Model Complexity}++Estimate the relative size of a collection of surfaces and allocate complexity to those surfaces proportionally.  This function does not bother accounting for rounding errors, so the sum of the complexity counts allocated to the surfaces may not equal the complexity count passed in as a parameter.++\texttt{allocatedComplexity} allocates vertices to surfaces, with half of all vertices being distributed equally among all surfaces and half of all vertices being distributed in proportion to their surface areas.  Surfaces (such as surfaces that have many layers) may be weighted to carry disproportionately more vertices.++\begin{code}+allocateComplexity :: (ConcavityDetection p) => (p -> p -> Double) -> [(Surface p,Double)] -> Integer -> [Integer]+allocateComplexity ruler surfaces n = +    let surface_areas = map (\s -> estimateSurfaceArea ruler (fst s) * snd s) surfaces+        half_alloc = n `div` 2+        constant_alloc = half_alloc `div` genericLength surfaces+        in map ((+ constant_alloc) . round) $ proportional (fromInteger half_alloc) surface_areas++lengthProportional :: (p -> p -> Double) -> Surface p -> Integer -> SurfaceConfiguration+lengthProportional ruler s n =+    let curve_lengths = map (estimateCurveLength ruler) $ halfIterateSurface base_width s+        transpose_lengths = map (estimateCurveLength ruler) $ halfIterateSurface base_width $ flipTransposeSurface s+        base_width = max 2 $ floor $ sqrt $ fromInteger n+        improved_width = max 5 $ round $ sqrt (sum transpose_lengths / sum curve_lengths) * realToFrac base_width+        roundOdd x = case floor x of+                          x' | even x' -> x' + 1+                          x' -> x'+        in SurfaceConfiguration $ map (max 5 . roundOdd) $ proportional (fromInteger n) $ +               map (estimateCurveLength ruler) $ halfIterateSurface improved_width s++proportional :: Double -> [Double] -> [Double]+proportional total xs = map (* (total / sum xs)) xs+\end{code}
+ RSAGL/Orthagonal.lhs view
@@ -0,0 +1,83 @@+\section{Orthagonal Unit-Scaled Coordinate Systems}++It's useful to work with the set of coordinate systems restricted to those that use orthagonal unit-scaled axes, that is, that are subject only to rotation and translation.+This is because these coordinate systems are the only ones that describe rigid objects.++\begin{code}+module RSAGL.Orthagonal+    (up,down,left,right,forward,backward,+     orthagonalFrame,+     modelLookAt,+     FUR)+    where++import RSAGL.Affine+import RSAGL.Vector+import RSAGL.Matrix+\end{code}++\texttt{FUR} stands for Forward Up Right.  It's used to specify arbitrary orthagonal coordinate systems given any combination+of forward up and right vectors.  It also accepts down, left, and backward vectors.++\texttt{right} is positive X, \texttt{up} is positive Y, \texttt{forward} is positive Z.++When specifying \texttt{FUR} coordinate systems, the first vector is fixed, while the second vector will be adjusted as little as possible to +guarantee that it is orthagonal to the first.  The third vector never needs to be specified, it can be deduced.++\begin{code}+data FURAxis = ForwardAxis | UpAxis | RightAxis | DownAxis | LeftAxis | BackwardAxis++data FUR a = FUR FURAxis a++instance Functor FUR where+    fmap f (FUR a x) = FUR a $ f x++up :: a -> FUR a+up = FUR UpAxis++down :: a -> FUR a+down = FUR DownAxis++left :: a -> FUR a+left = FUR LeftAxis++right :: a -> FUR a+right = FUR RightAxis++forward :: a -> FUR a+forward = FUR ForwardAxis++backward :: a -> FUR a+backward = FUR BackwardAxis++orthagonalFrame :: (AffineTransformable a) => FUR Vector3D -> FUR Vector3D -> a -> a+orthagonalFrame (FUR ForwardAxis f) (FUR RightAxis r) = let (r',u') = fixOrtho2 f r in transform (xyzMatrix r' u' (vectorNormalize f))+orthagonalFrame (FUR UpAxis u) (FUR ForwardAxis f) = let (f',r') = fixOrtho2 u f in transform (xyzMatrix r' (vectorNormalize u) f')+orthagonalFrame (FUR RightAxis r) (FUR UpAxis u) = let (u',f') = fixOrtho2 r u in transform (xyzMatrix (vectorNormalize r) u' f')+orthagonalFrame (FUR RightAxis r) (FUR ForwardAxis f) = let (f',u') = fixOrtho2Left r f in transform (xyzMatrix (vectorNormalize r) u' f')+orthagonalFrame (FUR ForwardAxis f) (FUR UpAxis u) = let (u',r') = fixOrtho2Left f u in transform (xyzMatrix r' u' (vectorNormalize f))+orthagonalFrame (FUR UpAxis u) (FUR RightAxis r) = let (r',f') = fixOrtho2Left u r in transform (xyzMatrix r' (vectorNormalize u) f')+orthagonalFrame (FUR ForwardAxis _) (FUR ForwardAxis _) = error "orthagonalFrame: two forward vectors"+orthagonalFrame (FUR UpAxis _) (FUR UpAxis _) = error "orthagonalFrame: two up vectors"+orthagonalFrame (FUR RightAxis _) (FUR RightAxis _) = error "orthagonalFrame: two right vectors"+orthagonalFrame x y = orthagonalFrame (furCorrect x) (furCorrect y)++furCorrect :: FUR Vector3D -> FUR Vector3D+furCorrect (FUR ForwardAxis f) = FUR ForwardAxis f+furCorrect (FUR UpAxis u) = FUR UpAxis u+furCorrect (FUR RightAxis r) = FUR RightAxis r+furCorrect (FUR DownAxis d) = FUR UpAxis $ vectorScale (-1) d+furCorrect (FUR LeftAxis l) = FUR RightAxis $ vectorScale (-1) l+furCorrect (FUR BackwardAxis b) = FUR ForwardAxis $ vectorScale (-1) b+\end{code}++\texttt{modelLookAt} generates the affine transformation needed to aim a model at a given position either at a point or along a vector.+The first parameter is the position of the model.  Typically the second parameter will be the position of the target, and the +third parameter will \texttt{(up \$ Vector3D 0 1 0)}.++\begin{code}+modelLookAt :: (AffineTransformable a) => Point3D -> FUR (Either Point3D Vector3D) -> FUR (Either Point3D Vector3D) -> a -> a+modelLookAt pos primaryish secondaryish = RSAGL.Affine.translate (vectorToFrom pos origin_point_3d) . orthagonalFrame primary secondary+    where primary = fmap (either (`vectorToFrom` pos) id) primaryish+          secondary = fmap (either (`vectorToFrom` pos) id) secondaryish+\end{code}
+ RSAGL/ProcessColors.hs view
@@ -0,0 +1,61 @@+module RSAGL.ProcessColors+    (main)+    where++import RSAGL.Material+import Control.Monad+import Data.List+import Numeric++data ColorTableEntry = ColorTableEntry { cte_name :: String, cte_red, cte_green, cte_blue :: Int }++readColorTableEntry :: String -> ColorTableEntry+readColorTableEntry s = ColorTableEntry name (read r :: Int) (read g :: Int) (read b :: Int)+    where [name,r,g,b] = words s++cteToColor :: ColorTableEntry -> RGB+cteToColor cte = rgb256 (cte_red cte) (cte_green cte) (cte_blue cte)++cteToHaskell :: ColorTableEntry -> String+cteToHaskell (ColorTableEntry s r g b) = s ++ " :: RGB\n" ++ s ++ " = rgb256 " ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ "\n"++wrapHaskellModule :: [ColorTableEntry] -> String -> String+wrapHaskellModule cte s = ("module RSAGL.RSAGLColors (" ++ (listColors cte) ++ ") where") ++ +                          "\n\nimport RSAGL.Material\n\n" ++ s++listColors :: [ColorTableEntry] -> String+listColors = concat . intersperse "," . map cte_name++wrapHTMLFile :: String -> String+wrapHTMLFile s = "<html><head><title>RSAGL Color Tables</title></head><body>" ++ s ++ "</body></html>"++cteToHTML :: ColorTableEntry -> String+cteToHTML (ColorTableEntry s r g b) = "<p><div style=\"background-color:" ++ (zeroes $ showHex (r * 0x10000 + g * 0x100 + b) "") ++ "\">" +                                      ++ s ++ " " ++ show r ++ " " ++ show g ++ " " ++ show b ++ "</div>"+    where zeroes x = replicate (6 - length x) '0' ++ x++cteSubtable :: String -> [ColorTableEntry] -> String+cteSubtable name color_tables = "<h4>" ++ name ++ "</h4>" ++ (unlines . map cteToHTML) color_tables++colorTablesToHTML :: [ColorTableEntry] -> String+colorTablesToHTML color_tables =+   cteSubtable "All Colors" color_tables +++   cteSubtable "By Luminance" (reverse $ sortBy luminance color_tables) +++   cteSubtable "By Red" (takeHalf $ sortBy byred color_tables) +++   cteSubtable "By Green" (takeHalf $ sortBy bygreen color_tables) +++   cteSubtable "By Blue" (takeHalf $ sortBy byblue color_tables)+       where luminance x y = compare (cteBrightness x) (cteBrightness y)+             byred x y = compare (toRed y ^ 2 / flatBrightness y) (toRed x ^ 2 / flatBrightness x)+             bygreen x y = compare (toGreen y ^ 2 / flatBrightness y) (toGreen x ^ 2 / flatBrightness x)+             byblue x y = compare (toBlue y ^ 2 / flatBrightness y) (toBlue x ^ 2 / flatBrightness x)+             cteBrightness = realToFrac . (1 +) . brightness . cteToColor+             flatBrightness x = toRed x * toGreen x * toBlue x+             toRed = realToFrac . cte_red+             toGreen = realToFrac . cte_green+             toBlue = realToFrac . cte_blue+             takeHalf x = take (length x `div` 2) x++main :: IO ()+main = do color_tables <- liftM (map readColorTableEntry . lines) $ readFile "rsagl-rgb.txt"+          writeFile "RSAGL/RSAGLColors.hs" $ wrapHaskellModule color_tables $ (unlines . map cteToHaskell) color_tables+          writeFile "rsagl-rgb.html" $ wrapHTMLFile $ colorTablesToHTML color_tables
+ RSAGL/QualityControl.lhs view
@@ -0,0 +1,57 @@+\section{Threaded Quality Control}++\begin{code}+module RSAGL.QualityControl+    (QualityCache,newQuality,getQuality)+    where++import Control.Parallel.Strategies+import Data.Map as Map+import Control.Concurrent+import Control.Monad+import Data.Maybe+import RSAGL.Bottleneck+\end{code}++The \texttt{QualityCache} object is used to memoize entities with variable level-of-detail.++\texttt{QualityCache}s use \texttt{Bottlenecks} to limit the amount of non-essential computation that is taking place at any one time.++\texttt{getQuality} answers the highest-quality available object that has a quality less than or equal to the requested quality.++If necessary, the \texttt{QualityCache} fires off a worker thread to generate higher-quality versions of the entity.  At most+one worker thread is ever actually running for each \texttt{QualityCache}.++The effect when \texttt{QualityCache} is used to view 3D models is a little like loading a progressive JPEG.  First a very low+quality model appears, which is gradually replaced by higher and higher qualities until the desired level of detail is finished.+\begin{code}+data QualityCache q a = QualityCache Bottleneck (Strategy a) (q -> a) (MVar [q]) (MVar (Map q a))++newQuality :: (Ord q) => Bottleneck -> Strategy a -> (q -> a) -> [q] -> IO (QualityCache q a)+newQuality _ _ _ [] = error "mkQuality: empty quality list"+newQuality bottleneck strategy f (q:qs) = +    do lowest_quality <- return $! (f q `using` strategy)+       liftM2 (QualityCache bottleneck strategy f) (newMVar qs) (newMVar $ singleton q lowest_quality)++completeQuality :: (Ord q) => QualityCache q a -> q -> IO ()+completeQuality (qo@(QualityCache bottleneck strategy f quality_mvar map_mvar)) want_q =+    do qualities <- takeMVar quality_mvar  -- block on the quality_mvar+       case qualities of+           (q:qs) | q < want_q -> do new_elem <- constrict bottleneck $ return $| strategy $ f q+                                     modifyMVar_ map_mvar (return . Map.insert q new_elem)+                                     putMVar quality_mvar qs+                                     completeQuality qo want_q+           _ -> do putMVar quality_mvar qualities++getQuality :: (Ord q) => QualityCache q a -> q -> IO a+getQuality (qo@(QualityCache _ _ _ quality_mvar mv)) q = +    do m <- readMVar mv+       case Map.lookup q m of+            Just a -> return a+            Nothing -> do e <- isEmptyMVar quality_mvar -- is completeQuality already running or pending for this QualityObject?+                          when (not e) $ (forkIO $ completeQuality qo q) >> return ()  -- then don't launch another one+                          let suitable_qualities = filterWithKey (\k _ -> (k <= q)) m+                          return $ snd $ if Map.null suitable_qualities +                              then findMin m+                              else findMax suitable_qualities +\end{code}
+ RSAGL/RK4.lhs view
@@ -0,0 +1,47 @@+\section{Runge-Kutta}++Haskell implementation of RK4.++\begin{code}+module RSAGL.RK4+    (rk4,+     integrateRK4,+     rk4',+     integrateRK4')+    where++import RSAGL.AbstractVector+import RSAGL.Time+\end{code}++\begin{code}+genericRK4 :: (AbstractVector v) => (Time -> p -> v -> p) -> (Time -> p -> Rate v) -> p -> Time -> Time -> p+genericRK4 addPV diffF p0 t0 t1 = addPV h p0 $ (scalarMultiply (recip 6) (abstractSum [k1,k2,k2,k3,k3,k4]) `over` h)+    where k1 = diffF t0 p0+          k2 = diffF tmid (addPV h2 p0 $ k1 `over` h2)+          k3 = diffF tmid (addPV h2 p0 $ k2 `over` h2)+          k4 = diffF t1 (addPV h p0 $ k3 `over` h)+          h = t1 `sub` t0+          h2 = scalarMultiply (recip 2) h+          tmid = t0 `add` h2++rk4 :: (AbstractVector v) => (p -> v -> p) -> (Time -> p -> Rate v) -> p -> Time -> Time -> p+rk4 addPV = genericRK4 (const addPV)++rk4' :: (AbstractVector v) => (p -> v -> p) -> (Time -> p -> Rate v -> Acceleration v) -> (p,Rate v) -> Time -> Time -> (p,Rate v)+rk4' addPV diffF = genericRK4+    (\t (p,old_v) delta_v -> let new_v = old_v `add` delta_v in (addPV p $ (scalarMultiply (recip 2) $ old_v `add` new_v) `over` t,new_v))+    (\t (p,v) -> diffF t p v)++genericIntegrate :: (p -> Time -> Time -> p) -> p -> Time -> Time -> Integer -> p+genericIntegrate _ pn _ _ 0 = pn+genericIntegrate f p0 t0 tn n = genericIntegrate f p1 t1 tn (n-1)+    where t1 = t0 `add` (scalarMultiply (recip $ realToFrac n) $ tn `sub` t0)+          p1 = f p0 t0 t1++integrateRK4 :: (AbstractVector v) => (p -> v -> p) -> (Time -> p -> Rate v) -> p -> Time -> Time -> Integer -> p+integrateRK4 addPV diffF = genericIntegrate $ rk4 addPV diffF++integrateRK4' :: (AbstractVector v) => (p -> v -> p) -> (Time -> p -> Rate v -> Acceleration v) -> (p,Rate v) -> Time -> Time -> Integer -> (p,Rate v)+integrateRK4' addPV diffF = genericIntegrate $ rk4' addPV diffF+\end{code}
+ RSAGL/RSAGLColors.hs view
@@ -0,0 +1,229 @@+module RSAGL.RSAGLColors (amber,amethyst,azure,beige,black,blackbody,blue,brass,bronze,brown,burgundy,burnt_sienna,camouflage_green,cardinal,carnation,carrot,chartreuse,chartreuse_yellow,cobalt,copper,coral,corn,crimson,cyan,dark_brown,emerald,eggplant,fern_green,firebrick,forest_green,fuchsia,gold,goldenrod,green,indigo,jade,lavender,lemon,lilac,magenta,maroon,mauve,midnight_blue,mint_green,mustard,ochre,olive,orange,orchid,pale_brown,pink,puce,purple,red,royal_blue,royal_purple,rust,safety_orange,saffron,sapphire,salmon,sea_green,sepia,shamrock,silver,slate_gray,tan_color,teal,ultramarine,vermillion,violet,viridian,wheat,white,yellow) where++import RSAGL.Material++amber :: RGB+amber = rgb256 255 191 1++amethyst :: RGB+amethyst = rgb256 153 102 204++azure :: RGB+azure = rgb256 1 127 255++beige :: RGB+beige = rgb256 245 245 220++black :: RGB+black = rgb256 1 1 1++blackbody :: RGB+blackbody = rgb256 0 0 0++blue :: RGB+blue = rgb256 1 1 255++brass :: RGB+brass = rgb256 181 166 66++bronze :: RGB+bronze = rgb256 205 127 50++brown :: RGB+brown = rgb256 150 75 0++burgundy :: RGB+burgundy = rgb256 128 1 32++burnt_sienna :: RGB+burnt_sienna = rgb256 233 116 81++camouflage_green :: RGB+camouflage_green = rgb256 120 134 107++cardinal :: RGB+cardinal = rgb256 196 30 58++carnation :: RGB+carnation = rgb256 255 166 201++carrot :: RGB+carrot = rgb256 237 145 33++chartreuse :: RGB+chartreuse = rgb256 127 255 1++chartreuse_yellow :: RGB+chartreuse_yellow = rgb256 223 255 1++cobalt :: RGB+cobalt = rgb256 1 71 171++copper :: RGB+copper = rgb256 184 115 51++coral :: RGB+coral = rgb256 255 127 80++corn :: RGB+corn = rgb256 251 236 93++crimson :: RGB+crimson = rgb256 220 20 60++cyan :: RGB+cyan = rgb256 1 255 255++dark_brown :: RGB+dark_brown = rgb256 101 67 33++emerald :: RGB+emerald = rgb256 80 200 120++eggplant :: RGB+eggplant = rgb256 153 1 102++fern_green :: RGB+fern_green = rgb256 79 121 66++firebrick :: RGB+firebrick = rgb256 178 34 34++forest_green :: RGB+forest_green = rgb256 34 139 34++fuchsia :: RGB+fuchsia = rgb256 255 1 255++gold :: RGB+gold = rgb256 255 215 1++goldenrod :: RGB+goldenrod = rgb256 218 165 32++green :: RGB+green = rgb256 1 255 1++indigo :: RGB+indigo = rgb256 1 65 106++jade :: RGB+jade = rgb256 1 168 107++lavender :: RGB+lavender = rgb256 181 126 220++lemon :: RGB+lemon = rgb256 253 233 16++lilac :: RGB+lilac = rgb256 200 162 200++magenta :: RGB+magenta = rgb256 255 1 255++maroon :: RGB+maroon = rgb256 128 1 1++mauve :: RGB+mauve = rgb256 224 176 255++midnight_blue :: RGB+midnight_blue = rgb256 1 51 102++mint_green :: RGB+mint_green = rgb256 152 255 152++mustard :: RGB+mustard = rgb256 255 219 88++ochre :: RGB+ochre = rgb256 204 119 34++olive :: RGB+olive = rgb256 128 128 1++orange :: RGB+orange = rgb256 255 160 1++orchid :: RGB+orchid = rgb256 218 112 214++pale_brown :: RGB+pale_brown = rgb256 152 118 84++pink :: RGB+pink = rgb256 255 192 203++puce :: RGB+puce = rgb256 204 136 153++purple :: RGB+purple = rgb256 160 92 240++red :: RGB+red = rgb256 255 1 1++royal_blue :: RGB+royal_blue = rgb256 65 105 225++royal_purple :: RGB+royal_purple = rgb256 107 63 160++rust :: RGB+rust = rgb256 183 65 14++safety_orange :: RGB+safety_orange = rgb256 255 102 1++saffron :: RGB+saffron = rgb256 244 196 48++sapphire :: RGB+sapphire = rgb256 8 37 103++salmon :: RGB+salmon = rgb256 255 140 105++sea_green :: RGB+sea_green = rgb256 46 139 87++sepia :: RGB+sepia = rgb256 112 66 20++shamrock :: RGB+shamrock = rgb256 1 158 96++silver :: RGB+silver = rgb256 192 192 192++slate_gray :: RGB+slate_gray = rgb256 112 128 144++tan_color :: RGB+tan_color = rgb256 210 180 140++teal :: RGB+teal = rgb256 1 128 128++ultramarine :: RGB+ultramarine = rgb256 18 10 143++vermillion :: RGB+vermillion = rgb256 255 77 1++violet :: RGB+violet = rgb256 139 1 255++viridian :: RGB+viridian = rgb256 64 130 109++wheat :: RGB+wheat = rgb256 245 222 179++white :: RGB+white = rgb256 255 255 255++yellow :: RGB+yellow = rgb256 255 255 1+
+ RSAGL/RayTrace.lhs view
@@ -0,0 +1,82 @@+\section{Ray Tracing Support}++This section implements functions that could form the basis of a ray tracer.++\begin{code}+module RSAGL.RayTrace+    (Ray3D,+     ray3d,+     Geometry(..),+     Plane,+     plane,+     plane3,+     shadowDeform)+    where++import RSAGL.Affine+import RSAGL.Vector+import Data.Ord+import Data.List+import Data.Maybe+\end{code}++\subsection{Rays in 3-space}++A \texttt{Ray3D} has a endpoint and direction.++\begin{code}+data Ray3D = Ray3D Point3D Vector3D+    deriving (Read,Show)++projectRay :: Double -> Ray3D -> Point3D+projectRay t (Ray3D p v) = translate (vectorScale t v) p++ray3d :: Point3D -> Vector3D -> Ray3D+ray3d p v = Ray3D p $ vectorNormalize v+\end{code}++\subsection{Geometry}++\texttt{Geometry} supports testing ray-object intersections.  \texttt{traceRay} takes an incomming ray of unit length and the \texttt{Geometry} and yields both a \texttt{SurfaceVertex3D} for the point of intersection and the distance between the point of origin and the point of intersection.++\begin{code}+class Geometry g where+    testRay :: Ray3D -> g -> Maybe (Double,SurfaceVertex3D)++instance (Geometry g) => Geometry [g] where+    testRay ray gs = case hits of+                           [] -> Nothing+                           _  -> Just $ minimumBy (comparing fst) hits+        where hits = mapMaybe (testRay ray) gs+\end{code}++\subsection{Planes}++\begin{code}+data Plane = Plane Point3D Vector3D++instance Geometry Plane where+    testRay (ray@(Ray3D r r')) (Plane p n) = case t of+            _ | t > 0.0 -> Just (t,SurfaceVertex3D (projectRay t ray) n)+            _           -> Nothing+        where k = dotProduct n $ vectorToFrom p r+              a = dotProduct n r'+              t = k/a++plane :: Point3D -> Vector3D -> Plane+plane p v = Plane p $ vectorNormalize v++plane3 :: Point3D -> Point3D -> Point3D -> Plane+plane3 p1 p2 p3 = plane p1 $ newell [p1,p2,p3]+\end{code}++\subsection{Algorithms}++\texttt{shadowDeform} constructs a deformation function using a geometry.  An existing surface is mapped to the surface of the geometry by casting the surface along +parallel rays, as happens when a shadow is cast by rays of sunlight.++\begin{code}+shadowDeform :: (Geometry g) => Vector3D -> g -> SurfaceVertex3D -> SurfaceVertex3D+shadowDeform sunlight g (sv3d) = maybe sv3d snd $ testRay r g+    where r = ray3d (sv3d_position sv3d) sunlight+\end{code}
+ RSAGL/Scene.lhs view
@@ -0,0 +1,269 @@+\section{Scenes and Animation}++A \texttt{Scene} is a complete description of an image to be rendered, consisting of a camera position, light sources, and models.++\begin{code}++{-# OPTIONS_GHC -farrows #-}++module RSAGL.Scene+    (Scene,+     Camera(..),+     LightSource(..),+     SceneObject,+     SceneLayer(..),+     ScenicAccumulator(..),+     SceneAccumulator,+     null_scene_accumulator,+     sceneObject,+     cameraRelativeSceneObject,+     lightSource,+     accumulateSceneM,+     accumulateSceneA,+     assembleScene,+     sceneToOpenGL)+    where++import Data.Ord+import RSAGL.BoundingBox+import RSAGL.Vector+import RSAGL.Affine as Affine+import RSAGL.Angle as Angle+import RSAGL.Model+import RSAGL.CoordinateSystems+import Data.List+import Control.Monad.State as State+import Control.Arrow+import Control.Arrow.Operations+import RSAGL.Color as Color+import Graphics.UI.GLUT as GLUT+import Data.Maybe+import RSAGL.WrappedAffine+\end{code}++\subsection{Cameras}++\begin{code}+data Camera =+    PerspectiveCamera { camera_position, camera_lookat :: Point3D, +                        camera_up :: Vector3D,+                        camera_fov :: Angle.Angle }++instance AffineTransformable Camera where+    transform m (pc@(PerspectiveCamera {})) = +        pc { camera_position = transform m $ camera_position pc,+             camera_lookat = transform m $ camera_lookat pc,+             camera_up = transform m $ camera_up pc }++cameraToOpenGL :: Double -> (Double,Double) -> Camera -> IO ()+cameraToOpenGL aspect_ratio (near,far)+        (PerspectiveCamera { camera_position = (Point3D px py pz),+                             camera_lookat = (Point3D lx ly lz),+                             camera_up = (Vector3D ux uy uz),+                             camera_fov = fov }) =+    do matrixMode $= Projection+       loadIdentity+       perspective (toDegrees fov)+                   aspect_ratio+                   near+                   far+       matrixMode $= Modelview 0+       lookAt (Vertex3 px py pz) (Vertex3 lx ly lz) (Vector3 ux uy uz)++infiniteCameraToOpenGL :: Double -> (Double,Double) -> Camera -> IO ()+infiniteCameraToOpenGL aspect_ratio nearfar pc =+    cameraToOpenGL aspect_ratio nearfar $ Affine.translate (vectorToFrom origin_point_3d $ camera_position pc) pc+\end{code}++\subsection{Light Sources}++\begin{code}+data LightSource =+      DirectionalLight { lightsource_direction :: Vector3D,+                         lightsource_color :: Color.RGB,+                         lightsource_ambient :: Color.RGB }+    | PointLight { lightsource_position :: Point3D,+                   lightsource_radius :: Distance,+                   lightsource_color :: Color.RGB,+                   lightsource_ambient :: Color.RGB }+    | NoLight++makeInfinite :: LightSource -> LightSource+makeInfinite NoLight = NoLight+makeInfinite (d@(DirectionalLight {})) = d+makeInfinite (p@PointLight {}) = DirectionalLight {+    lightsource_direction = vectorToFrom origin_point_3d $ lightsource_position p,+    lightsource_color = scaleRGB scale_factor $ lightsource_color p,+    lightsource_ambient = scaleRGB scale_factor $ lightsource_ambient p }+        where scale_factor = realToFrac $ (distance $ lightsource_radius p) / (distanceBetweenSquared origin_point_3d (lightsource_position p))++instance AffineTransformable LightSource where+    transform _ NoLight = NoLight+    transform m (dl@(DirectionalLight {})) = dl { lightsource_direction = transform m $ lightsource_direction dl }+    transform m (pl@(PointLight {})) = pl {+        lightsource_position = transform m $ lightsource_position pl,+        lightsource_radius = transform m $ lightsource_radius pl }++setLightSources :: [LightSource] -> IO ()+setLightSources lss =+    do max_lights <- GLUT.get maxLights+       mapM_ setLightSource $ genericTake max_lights $ zip (map Light [0..]) (lss ++ repeat NoLight)++setLightSource :: (Light,LightSource) -> IO ()+setLightSource (l,NoLight) = light l $= Disabled+setLightSource (l,dl@DirectionalLight { lightsource_color = Color.RGB cr cg cb,+                                        lightsource_ambient = Color.RGB ar ag ab }) =+    do let Vector3D vx vy vz = vectorNormalize $ lightsource_direction dl+       light l $= Enabled+       ambient l $= (Color4 ar ag ab 1.0 :: Color4 Float)+       GLUT.specular l $= (Color4 cr cg cb 1.0 :: Color4 Float)+       diffuse l $= (Color4 cr cg cb 1.0 :: Color4 Float)+       position l $= (Vertex4 (realToFrac vx) (realToFrac vy) (realToFrac vz) 0 :: Vertex4 Float)+       attenuation l $= (1,0,0)+setLightSource (l,pl@(PointLight { lightsource_position = (Point3D px py pz),+                                   lightsource_color = Color.RGB cr cg cb,+                                   lightsource_ambient = Color.RGB ar ag ab })) =+    do light l $= Enabled+       ambient l $= (Color4 ar ag ab 1.0 :: Color4 Float)+       GLUT.specular l $= (Color4 cr cg cb 1.0 :: Color4 Float)+       diffuse l $= (Color4 cr cg cb 1.0 :: Color4 Float)+       position l $= (Vertex4 (realToFrac px) (realToFrac py) (realToFrac pz) 1 :: Vertex4 Float)+       attenuation l $= (0.01,0,recip $ realToFrac $ distanceSquared $ lightsource_radius pl)+\end{code}++\subsection{Scene Construction}++A \texttt{Scene} supports local and infinite scene layers.  The camera moves through the local scene layer, but the infinite scene layer is fixed.  Objects in the infinite scene layer never occlude objects in the local layer.  All light sources in the infinite scene layer are rendered as directional light sources in the local scene layer.  Local light sources are not rendered at all in the infinite layer.++Celestial objects such as the moon and sun, as well as the sky sphere, belong in the infinite subscene.  Distant clouds or mountains may also belong in the infinite layer.++\begin{code}+data SceneObject = +    LightSource LightSource+  | Model (Camera -> IO (WrappedAffine IntermediateModel))++instance AffineTransformable SceneObject where+    transform m (LightSource ls) = LightSource $ transform m ls+    transform m (Model imodel) = Model $ \c -> liftM (transform m) (imodel c)++data SceneLayer = Local | Infinite deriving (Eq)++data SceneAccumulator = SceneAccumulator {+    sceneaccum_objs :: [(SceneLayer,SceneObject)],+    sceneaccum_coordinate_system :: CoordinateSystem }++instance CoordinateSystemClass SceneAccumulator where+    getCoordinateSystem = sceneaccum_coordinate_system+    storeCoordinateSystem cs sceneaccum = sceneaccum { sceneaccum_coordinate_system = cs }++class (CoordinateSystemClass a) => ScenicAccumulator a where+    accumulateScene :: SceneLayer -> SceneObject -> a -> a++instance ScenicAccumulator SceneAccumulator where+    accumulateScene slayer scobj sceneaccum = sceneaccum { +        sceneaccum_objs = (slayer,migrate (sceneaccum_coordinate_system sceneaccum) root_coordinate_system scobj) : sceneaccum_objs sceneaccum }++instance (ScenicAccumulator sa) => ScenicAccumulator (a,sa) where+    accumulateScene slayer scobj (a,sceneaccum) = (a,accumulateScene slayer scobj sceneaccum)++null_scene_accumulator :: SceneAccumulator+null_scene_accumulator = SceneAccumulator [] root_coordinate_system++sceneObject :: IO IntermediateModel -> SceneObject+sceneObject = cameraRelativeSceneObject . const . liftM wrapAffine++cameraRelativeSceneObject :: (Camera -> IO (WrappedAffine IntermediateModel)) -> SceneObject+cameraRelativeSceneObject = Model++lightSource :: LightSource -> SceneObject+lightSource = LightSource++accumulateSceneM :: (ScenicAccumulator sa,Monad m,MonadState sa m) => SceneLayer -> SceneObject -> m ()+accumulateSceneM slayer scobj = modify (accumulateScene slayer scobj)++accumulateSceneA :: (ScenicAccumulator sa,Arrow arr,ArrowState sa arr) => arr (SceneLayer,SceneObject) ()+accumulateSceneA = proc (slayer,scobj) ->+    do sceneaccum <- fetch -< ()+       store -< accumulateScene slayer scobj sceneaccum+\end{code}++\subsection{Scene Assembly}++Once all objects have been accumulated, the accumulation is used to generate a \texttt{Scene} object.++\begin{code}+data Scene = Scene {+    scene_infinite_opaques :: [(WrappedAffine IntermediateModel,[LightSource])],+    scene_infinite_transparents :: [(WrappedAffine IntermediateModel,[LightSource])],+    scene_local_opaques :: [(WrappedAffine IntermediateModel,[LightSource])],+    scene_local_transparents :: [(WrappedAffine IntermediateModel,[LightSource])],+    scene_camera :: Camera }++-- FIXME: This function is a horrible mess (I need to redo this to implement 0.4 features anyway).+assembleScene :: Camera -> SceneAccumulator -> IO Scene+assembleScene c sceneaccum = +    do infinite_models <- liftM (map splitOpaquesWrapped . catMaybes) $ mapM toModel infinites+       local_models <- liftM (map splitOpaquesWrapped . catMaybes) $ mapM toModel locals+       return $ Scene {+           scene_infinite_opaques = map (\m -> (fst m,infinite_light_sources)) infinite_models,+           scene_infinite_transparents = map (\m -> (m,infinite_light_sources)) $ sortModels origin_point_3d $ concatMap snd infinite_models,+           scene_local_opaques = map (\m -> (fst m,local_light_sources)) local_models,+           scene_local_transparents = map (\m -> (m,local_light_sources)) $ sortModels (camera_position c) $ concatMap snd local_models,+           scene_camera = c }+        where infinites = map snd $ filter ((Infinite ==) . fst) $ sceneaccum_objs sceneaccum+              locals = map snd $ filter ((Local ==) . fst) $ sceneaccum_objs sceneaccum+              infinite_light_sources = mapMaybe toLightSource infinites+              local_light_sources = map makeInfinite infinite_light_sources ++ mapMaybe toLightSource locals+              sortModels :: Point3D -> [WrappedAffine IntermediateModel] -> [WrappedAffine IntermediateModel]+              sortModels p = map fst . sortBy (comparing $ negate . minimalDistanceToBoundingBox p . snd) .+                             map (\(wa@(WrappedAffine cs m)) -> (wa,migrate cs root_coordinate_system $ boundingBox m))+              splitOpaquesWrapped (WrappedAffine a m) =+                  let (opaques,transparents) = splitOpaques m+                      in (WrappedAffine a opaques,map (WrappedAffine a) transparents)+              toLightSource so = case so of+                  LightSource ls -> Just ls+                  _ -> Nothing+              toModel so = case so of+                  Model m -> liftM Just (m c)+                  _ -> return Nothing++sceneToOpenGL :: Double -> (Double,Double) -> Scene -> IO ()+sceneToOpenGL aspect_ratio nearfar scene =+    do save_rescale_normal <- GLUT.get rescaleNormal+       save_cull_face <- GLUT.get cullFace+       save_depth_func <- GLUT.get depthFunc+       save_depth_mask <- GLUT.get depthMask+       save_lighting <- GLUT.get lighting+       save_light_model_ambient <- GLUT.get lightModelAmbient+       rescaleNormal $= Enabled+       cullFace $= Just Front+       depthFunc $= Just Lequal+       depthMask $= Enabled+       lighting $= Enabled+       lightModelAmbient $= (Color4 0 0 0 1)+       clear [DepthBuffer]+       preservingMatrix $ +           do infiniteCameraToOpenGL aspect_ratio nearfar (scene_camera scene)+              mapM_ render1Object (scene_infinite_opaques scene)+	      depthMask $= Disabled+              mapM_ render1Object (scene_infinite_transparents scene)+	      depthMask $= Enabled+       clear [DepthBuffer]+       preservingMatrix $ +           do cameraToOpenGL aspect_ratio nearfar (scene_camera scene)+              mapM_ render1Object (scene_local_opaques scene)+	      depthMask $= Disabled+              mapM_ render1Object (scene_local_transparents scene)+	      depthMask $= Enabled+       lightModelAmbient $= save_light_model_ambient+       lighting $= save_lighting+       depthMask $= save_depth_mask+       depthFunc $= save_depth_func+       cullFace $= save_cull_face+       rescaleNormal $= save_rescale_normal++render1Object :: (WrappedAffine IntermediateModel,[LightSource]) -> IO ()+render1Object (WrappedAffine m imodel,lss) =+    do setLightSources lss+       transformation (migrate m root_coordinate_system) $ intermediateModelToOpenGL imodel+\end{code}
+ RSAGL/StatefulArrow.lhs view
@@ -0,0 +1,98 @@+\section{RSAGL.StatefulArrow}++A StatefulArrow is a form of automata or self-modifying program.++The assumption is that a StatefulArrow will be re-evaluated many times.+The result of each iteration includes a new form of the StatefulArrow+that will be evaluated on the next iteration.++\begin{code}+{-# OPTIONS_GHC -farrows -fglasgow-exts #-}++module RSAGL.StatefulArrow+    (StatefulArrow(..),+     StatefulFunction,+     stateContext,+     withState,+     withExposedState,+     statefulTransform,+     runStateMachine)+    where++import Control.Arrow+import Control.Arrow.Transformer.State+import Control.Arrow.Operations+import Control.Arrow.Transformer++type StatefulFunction = StatefulArrow (->)+data StatefulArrow a i o = StatefulArrow { runStatefulArrow :: (a i (o,StatefulArrow a i o)) }++instance (Arrow a) => Arrow (StatefulArrow a) where+    (>>>) (StatefulArrow sf1) (StatefulArrow sf2) = StatefulArrow $+        proc a -> do (b,sf1') <- sf1 -< a+                     (c,sf2') <- sf2 -< b+                     returnA -< seq b $ seq c $ seq sf1' $ seq sf2' $ (c,sf1' >>> sf2')+    arr = lift . arr+    first (StatefulArrow sf) = StatefulArrow $+        proc (b,d) -> do (c,sf') <- sf -< b+                         returnA -< seq c $ seq sf' $ ((c,d),first sf')++instance (Arrow a) => ArrowTransformer StatefulArrow a where+    lift f = lifted+        where lifted = StatefulArrow $ f &&& (arr $ const $ lifted)+\end{code}++\subsection{Mixing StatefulArrows and StateArrows}+\label{withState}+\label{withExposedState}++stateContext allows a StateArrow to be run as a StatefulArrow, where the StateArrow's +explicit state becomes the StatefulArrow's implicit state.++withState allows a StatefulArrow to be both explicitly and implicitly stateful.+The StatefulArrow does the work of retaining the explicit state between iterations.++withExposedState exposes the state to the caller by explicitly routing the state+as an input and output of the arrow.++\begin{code}+stateContext :: (Arrow a) => StateArrow s a i o -> s -> StatefulArrow a i o+stateContext sa s = StatefulArrow $+    proc i -> do (o,s') <- runState sa -< (i,s)+                 returnA -< seq o $ seq s' $ (o,stateContext sa s')++withState :: (Arrow a,ArrowApply a) => StatefulArrow (StateArrow s a) i o -> s -> StatefulArrow a i o+withState sa s = flip stateContext (sa,s) $+    proc i -> do (StatefulArrow sa',s') <- fetch -< ()+                 ((o,sa''),s'') <- lift app -< (runState sa',(i,s'))+                 store -< seq sa'' $ seq s'' $ seq o $ (sa'',s'')+                 returnA -< seq sa'' $ seq s'' o++withExposedState :: (Arrow a,ArrowApply a) => StatefulArrow (StateArrow s a) i o -> StatefulArrow a (i,s) (o,s)+withExposedState (StatefulArrow sa) = StatefulArrow $ (arr $ \((o,sa'),s') -> ((o,s'),withExposedState sa')) <<< runState sa+\end{code}++\subsection{Transforming the underlying type of a StatefulArrow}++\begin{code}+statefulTransform :: (Arrow a,Arrow b) => (forall j p. a j p -> b j p) -> +                                          StatefulArrow a i o -> StatefulArrow b i o+statefulTransform f (StatefulArrow a) = StatefulArrow $+    proc i -> do (o,a') <- f a -< i+                 returnA -< seq o $ seq a' $ (o,statefulTransform f a')+\end{code}++\subsection{Using a StatefulArrow as a state machine}++\begin{code}+runStateMachine :: (ArrowChoice a,ArrowApply a) => StatefulArrow a i o -> a [i] [o]+runStateMachine stateful_arrow = +    proc x -> do runStateMachine_ -< (([],stateful_arrow),x)+        where runStateMachine_ :: (ArrowChoice a,ArrowApply a) => a (([o],StatefulArrow a i o),[i]) [o]+              runStateMachine_ =+                  proc ((reversed_so_far,StatefulArrow stateful),x) -> +                      do case x of+                                [] -> returnA -< reverse reversed_so_far+                                (i:is) -> do (o,stateful') <- app -< (stateful,i)+                                             runStateMachine_ -< ((o:reversed_so_far,stateful'),is)+\end{code}
+ RSAGL/SwitchedArrow.lhs view
@@ -0,0 +1,115 @@+\section{RSAGL.SwitchedArrow}++A SwitchedArrow is very much like a StatefulArrow, in that it can specify a new form of itself+to be evaluated on each iteration.++Unlike a StatefulArrow, a Switched Arrow retains type information about itself+allowing any of it's delegate arrows to explicitly switch (and thereby terminate +execution of the current iteration of) the switched arrow.++\begin{code}+{-# OPTIONS_GHC -farrows -fglasgow-exts #-}++module RSAGL.SwitchedArrow+    (SwitchedArrow,+     SwitchedFunction,+     switchContinue,+     switchTerminate,+     statefulForm,+     runStateful,+     RSAGL.SwitchedArrow.withState,+     RSAGL.SwitchedArrow.withExposedState)+    where++import RSAGL.StatefulArrow as StatefulArrow+import Control.Arrow.Operations+import Control.Arrow.Transformer.Error+import Control.Arrow.Transformer.State+import Control.Arrow.Transformer+import Control.Arrow++type SwitchedFunction i o j p = SwitchedArrow i o (->) j p+\end{code}++The SwitchedArrow is really a special case of the ErrorArrow with ArrowApply.++\begin{code}+newtype SwitchedArrow i o a j p = SwitchedArrow (ErrorArrow (o,SwitchedArrow i o a i o) a j p)++instance (Arrow a,ArrowChoice a) => Arrow (SwitchedArrow i o a) where+    (>>>) (SwitchedArrow sa1) (SwitchedArrow sa2) = SwitchedArrow $ sa1 >>> sa2+    arr = SwitchedArrow . arr+    first (SwitchedArrow a) = SwitchedArrow $ first a++instance (Arrow a,ArrowChoice a) => ArrowTransformer (SwitchedArrow i o) a where+    lift = SwitchedArrow . lift++instance (ArrowChoice a) => ArrowChoice (SwitchedArrow i o a) where+    left (SwitchedArrow a) = SwitchedArrow $ left a++instance (ArrowChoice a,ArrowApply a) => ArrowApply (SwitchedArrow i o a) where+    app = SwitchedArrow $ proc (SwitchedArrow a,b) -> do app -< (a,b)+\end{code}++\subsection{Switching operators}+\label{switchContinue}+\label{switchTerminate}++A switchable arrow has two switching operators: switchContinue and switchTerminate.++\texttt{switchContinue} resumes execution using the new switch and a new input.  +It is possible for the new switch to switch again, even leading to non-termination.+\texttt{switchTerminate} ends execution, specifying the final output.  The new switch will not be+used until the next time this arrow is executed.++If the switch is \texttt{Nothing}, then no switch occurs.++\begin{code}+switchContinue :: (Arrow a,ArrowChoice a,ArrowApply a) => SwitchedArrow i o a (Maybe (SwitchedArrow i o a i o),i) i+switchContinue = proc (m_switch,i) -> +    case m_switch of+        Just switch -> do o <- app -< (switch,i)+                          SwitchedArrow raise -< (o,switch)+                          returnA -< i+        Nothing -> returnA -< i++switchTerminate :: (Arrow a,ArrowChoice a) => SwitchedArrow i o a (Maybe (SwitchedArrow i o a i o),o) o+switchTerminate = proc (m_switch,o) -> +    case m_switch of+        Just switch -> do SwitchedArrow raise -< (o,switch)+                          returnA -< o+	Nothing -> returnA -< o+\end{code}++\subsection{The StatefulArrow form of a SwitchedArrow}+\label{statefulForm}++\begin{code}+statefulForm :: (Arrow a,ArrowChoice a) => SwitchedArrow i o a i o -> StatefulArrow a i o+statefulForm switchedA = StatefulArrow $ arr (second statefulForm) <<< runStateful switchedA++runStateful :: (Arrow a,ArrowChoice a) => SwitchedArrow i o a i o -> a i (o,SwitchedArrow i o a i o)+runStateful (SwitchedArrow a) = runError switch handler+    where handler = proc (_,(o,newswitch)) -> do returnA -< (o,newswitch)+          switch = proc i -> do o <- a -< i+	                        returnA -< (o,SwitchedArrow a)+\end{code}++\subsection{Mixing SwitchedArrows and StateArrows}++These are the StateArrow-related combinators introduced with StatefulArrow+\footnote{Page \pageref{withState}}++\begin{code}+withState :: (Arrow a,ArrowChoice a,ArrowApply a) =>+                SwitchedArrow i o (StateArrow s a) i o -> (i -> s) -> StatefulArrow a i o+withState switch2 f = StatefulArrow.withState (statefulForm switch1) (error "withState: undefined")+    where switch1 = proc i ->+              do lift store -< f i+                 RSAGL.SwitchedArrow.switchContinue -< (Just switch2,i)+		 returnA -< error "withState: unreachable code"++withExposedState :: (Arrow a,ArrowChoice a,ArrowApply a) =>+                        SwitchedArrow i o (StateArrow s a) i o -> StatefulArrow a (i,s) (o,s)+withExposedState switch = StatefulArrow.withExposedState (statefulForm switch)+\end{code}
+ RSAGL/Tesselation.lhs view
@@ -0,0 +1,149 @@+\section{Decomposing Surface Data}++\begin{code}+module RSAGL.Tesselation+    (TesselatedSurface,+     TesselatedElement(..),+     tesselatedSurfaceToVertexCloud,+     tesselateSurface,+     tesselateGrid,+     tesselatedElementToOpenGL,+     ConcavityDetection(..))+    where++import RSAGL.Curve+import RSAGL.Vector+import RSAGL.Auxiliary+import RSAGL.Affine+import RSAGL.BoundingBox+import Data.List+import Control.Parallel.Strategies hiding (r0)+import Control.Arrow+import Graphics.Rendering.OpenGL.GL.BeginEnd+\end{code}++Tesselation is a stage of transforming a model into OpenGL procedure calls.  Tesselation is done by breaking a surface into a sequence of polylines (a grid).  Pairs of polylines, possibly of differing length, describe a polygon strip.  We subdivide that strip into triangle fans and quadralateral strips, as described by the OpenGL specification.++\begin{code}+type TesselatedSurface a = [TesselatedElement a]++data TesselatedElement a = TesselatedTriangleFan [a]+                         | TesselatedQuadStrip [a]+    deriving (Read,Show)++instance (AffineTransformable a) => AffineTransformable (TesselatedElement a) where+    transform m (TesselatedTriangleFan as) = TesselatedTriangleFan $ transform m as+    transform m (TesselatedQuadStrip as) = TesselatedTriangleFan $ transform m as++instance (NFData a) => NFData (TesselatedElement a) where+    rnf (TesselatedTriangleFan as) = rnf as+    rnf (TesselatedQuadStrip as) = rnf as++instance Functor TesselatedElement where+    fmap f (TesselatedTriangleFan as) = TesselatedTriangleFan $ fmap f as+    fmap f (TesselatedQuadStrip as) = TesselatedQuadStrip $ fmap f as++tesselatedSurfaceToVertexCloud :: TesselatedSurface a -> [a]+tesselatedSurfaceToVertexCloud = concatMap (\x ->+    case x of+           TesselatedTriangleFan as -> as+           TesselatedQuadStrip as -> as)++instance (Bound3D a) => Bound3D (TesselatedElement a) where+    boundingBox x = boundingBox $ tesselatedSurfaceToVertexCloud [x]++tesselateSurface :: (ConcavityDetection a) => Surface a -> (Integer,Integer) -> TesselatedSurface a+tesselateSurface s uv = tesselateGrid $ iterateSurface uv (zipSurface (,) (fmap fst uv_identity) s)++tesselateGrid :: (ConcavityDetection a) => [[(Double,a)]] -> TesselatedSurface a+tesselateGrid = concatMap (uncurry tesselateStrip) . doubles++tesselateStrip :: (ConcavityDetection a) => [(Double,a)] -> [(Double,a)] -> TesselatedSurface a+tesselateStrip lefts rights = tesselatePieces $ tesselateSteps lefts rights++tesselateSteps :: [(Double,a)] -> [(Double,a)] -> [Either a a]+tesselateSteps lefts rights = map (either (Left . snd) (Right . snd)) $ sortBy (\x y -> compare (either fst fst x) (either fst fst y)) (map Left lefts ++ map Right rights)++tesselatePieces :: (ConcavityDetection a) => [Either a a] -> TesselatedSurface a+tesselatePieces [] = []+tesselatePieces [_] = []+tesselatePieces [_,_] = []+tesselatePieces xs = fst best : tesselatePieces (snd best)+    where rightside_triangle = tesselateAsRightSidedTriangle xs+          leftside_triangle = tesselateAsLeftSidedTriangle xs+          quadralateral = tesselateAsQuadralateral xs+          best = case (length $ fst leftside_triangle,length $ fst quadralateral,length $ fst rightside_triangle) of+                     (0,0,0) -> (undefined,[])+                     (l,q,r) | q >= r && q >= l -> first TesselatedQuadStrip quadralateral+                     (l,_,r) | l >= r -> first TesselatedTriangleFan leftside_triangle+                     _ -> first TesselatedTriangleFan rightside_triangle++isLeft :: Either a b -> Bool+isLeft = either (const True) (const False)++isRight :: Either a b -> Bool+isRight = either (const False) (const True)++stripEither :: Either a a -> a+stripEither = either id id++tesselateAsLeftSidedTriangle :: [Either a a] -> ([a],[Either a a])+tesselateAsLeftSidedTriangle = tesselateAsSidedTriangle isLeft++tesselateAsRightSidedTriangle :: [Either a a] -> ([a],[Either a a])+tesselateAsRightSidedTriangle = first (\x -> take 1 x ++ reverse (drop 1 x)) . tesselateAsSidedTriangle isRight++tesselateAsSidedTriangle :: (Either a a -> Bool) -> [Either a a] -> ([a],[Either a a])+tesselateAsSidedTriangle test lrs =    -- looking for a pattern that contains at least two Lefts and exactly one Right +                                       -- (except the test may be reversed Left for Right)+        if ok then (map stripEither $ right_vertex : (leading_lefts ++ trailing_lefts),+	                               -- the triangle strip defined by on right edge and several left edges+                    right_vertex : (last $ leading_lefts ++ trailing_lefts) : rest)      +		                       -- the right edge and the trailing left edge define the start of the next strip+              else ([],lrs)            -- pattern match failure, return the parameters as we recieved them to pattern match on something else+    where (leading_lefts,trailing) = span test lrs+          right_vertex = head trailing+          (trailing_lefts,rest) = span test $ tail trailing+          ok = (not $ null trailing) && ((not $ null leading_lefts) || (not $ null trailing_lefts))++tesselateAsQuadralateral :: (ConcavityDetection a) => [Either a a] -> ([a],[Either a a])+tesselateAsQuadralateral xs = case length goods of+                                  n | n < 4 || isConcaveQuadStrip goods -> ([],xs)+                                  n -> (\[r,l] -> (goods,Right r : Left l : trailing)) $ genericDrop (n-2) goods+    where (goods,trailing) = tesselateAsQuadralateral_ xs++tesselateAsQuadralateral_ :: [Either a a] -> ([a],[Either a a])+tesselateAsQuadralateral_ (Left l:Right r:lrs) = first ([r,l] ++) $ tesselateAsQuadralateral_ lrs+tesselateAsQuadralateral_ (Right r:Left l:lrs) = first ([r,l] ++) $ tesselateAsQuadralateral_ lrs+tesselateAsQuadralateral_ lrs = ([],lrs)+\end{code}++\subsection{Sending decomposed data to OpenGL}++\begin{code}+tesselatedElementToOpenGL :: (a -> IO ()) -> TesselatedElement a -> IO ()+tesselatedElementToOpenGL f (TesselatedQuadStrip xs) = renderPrimitive QuadStrip $ mapM_ f xs+tesselatedElementToOpenGL f (TesselatedTriangleFan xs) = renderPrimitive TriangleFan $ mapM_ f xs+\end{code}++\subsection{Concavity Detection}++When decomposing as quadralaterals, we need to detect concave polygons and decompose them as triangles instead.  Minimal definition is \texttt{toPoint3D}.++\begin{code}+class ConcavityDetection a where+    isConcave :: [a] -> Bool+    isConcave = isConcave . map toPoint3D+    toPoint3D :: a -> Point3D++instance ConcavityDetection Point3D where+    isConcave = any ((<= 0) . uncurry dotProduct) . doubles . map newell . loopedConsecutives 3+    toPoint3D = id++instance ConcavityDetection SurfaceVertex3D where+    toPoint3D = sv3d_position++isConcaveQuadStrip :: (ConcavityDetection a) => [a] -> Bool+isConcaveQuadStrip (r0:l0:r1:l1:rest) = isConcave [r0,l0,l1,r1] || isConcaveQuadStrip (r1:l1:rest)+isConcaveQuadStrip _ = False+\end{code}
+ RSAGL/Tests.hs view
@@ -0,0 +1,557 @@+{-# OPTIONS_GHC -farrows #-}++--+-- Some basic tests of the FRP arrow system.+--++module RSAGL.Tests+    (main)+    where++import RSAGL.StatefulArrow as StatefulArrow+import RSAGL.SwitchedArrow as SwitchedArrow+import RSAGL.ThreadedArrow as ThreadedArrow+import RSAGL.FRP as FRP+import RSAGL.Edge as Edge+import RSAGL.Time+import RSAGL.Angle+import RSAGL.Auxiliary+import RSAGL.Vector+import RSAGL.Matrix+import RSAGL.QualityControl+import Control.Arrow.Operations+import Control.Arrow+import Data.Set as Set+import Data.List as List+import Data.Monoid+import Test.QuickCheck hiding (test)+import Control.Concurrent+import Control.Parallel.Strategies+import RSAGL.RK4+import RSAGL.Bottleneck+import RSAGL.Joint++--+-- State machine that adds its input to its state+--+countingArrow :: Integer -> StatefulFunction Integer Integer+countingArrow = stateContext $ +                    proc x -> do y <- fetch -< ()+                                 store -< x + y+                                 fetch -< ()++--+-- State machine that is true iff the number of False inputs it has recieved is even+--+evenZeroesArrow :: SwitchedFunction Bool Bool Bool Bool+evenZeroesArrow = proc x ->+     do case x of+               False -> SwitchedArrow.switchTerminate -< (Just evenZeroesArrow_oddZeroes,False)+               True -> returnA -< True++evenZeroesArrow_oddZeroes :: SwitchedFunction Bool Bool Bool Bool+evenZeroesArrow_oddZeroes = proc x ->+    do case x of+              False -> SwitchedArrow.switchTerminate -< (Just evenZeroesArrow,True)+              True -> returnA -< False++--+-- A cellular automata that spawns the two adjacent cells (represented by Integers) on each iteration.+-- Cells at non-zero integers divisible by 3 are "sticky;" once reached they persist forever.+-- All other integers die out after spawning.+--+spawnPlusAndMinusAndDie :: ThreadedArrow Integer () (Set Integer) (->) () (Set Integer)+spawnPlusAndMinusAndDie = step1+    where step1 = proc () ->+              do i <- ThreadedArrow.threadIdentity -< ()+	         ThreadedArrow.switchTerminate -< (Just $ step2,Set.singleton i)+          step2 = proc () ->+              do i <- ThreadedArrow.threadIdentity -< ()+	         ThreadedArrow.spawnThreads -< [(i + 1,spawnPlusAndMinusAndDie),(i - 1,spawnPlusAndMinusAndDie)]+		 ThreadedArrow.killThreadIf -< not $ i `mod` 3 == 0 && i /= 0+                 returnA -< Set.singleton i++--+-- Sanity test of the StatefulArrow.+--+addFive :: Integer -> Integer+addFive x = let (_,sf1) = runStatefulArrow (countingArrow x) 1+                (_,sf2) = runStatefulArrow sf1 3+                (_,sf3) = runStatefulArrow sf2 (-1)+                (_,sf4) = runStatefulArrow sf3 1+                in fst $ runStatefulArrow sf4 1++--+--Sanity test of the SwitchedArrow.+--+evenZeroes :: [Bool] -> Bool+evenZeroes = last . runStateMachine (SwitchedArrow.statefulForm evenZeroesArrow)++--+-- Sanity test of the ThreadedArrow+--+spawnPMD :: Int -> Set Integer+spawnPMD n = mconcat $ List.map snd $ (!! n) $ runStateMachine (ThreadedArrow.statefulForm (unionThreadIdentity (==)) $ [(0,spawnPlusAndMinusAndDie)]) $ replicate (n+1) ()+++testIntegral :: IO ()+testIntegral = testClose "testIntegral"+                  (frpTest [threadTime] (replicate 16 ()))+                  (List.map (List.map fromSeconds) [[0.0],[0.1],[0.2],[0.3],[0.4],[0.5],[0.6],[0.7],[0.8],[0.9],[1.0],[1.1],[1.2],[1.3],[1.4],[1.5]])+                  (listEqualClose $ listEqualClose timeEqualClose)++testDerivative :: IO ()+testDerivative = test "testDerivative"+                    (frpTest [derivative]+                             [5.0,6.0,8.0,11.0,15.0,20.0,26.0,33.0 :: Double])+                    (List.map (List.map perSecond) [[0],[10],[20],[30],[40],[50],[60],[70]])++testInitial :: IO ()+testInitial = test "testInitial"+                 (frpTest [initial]+                          [5,7,2,1,6,3,4])+                 [[5],[5],[5],[5],[5],[5],[5]]++testEdgeFold :: IO ()+testEdgeFold = test "testEdgeFold"+                  (frpTest [edgeFold id (+)]+                           [3,2,2,2,2,4,4,3,8,7,6,6])+                  [[3],[5],[5],[5],[5],[9],[9],[12],[20],[27],[33],[33]]++testEdgeMap :: IO ()+testEdgeMap = test "testEdgeMap"+                 (frpTest [edgeMap (*2)]+                          [2,2,2,4,1,3,9,5,5,5,3])+                 [[4],[4],[4],[8],[2],[6],[18],[10],[10],[10],[6]]++testHistory :: IO ()+testHistory = testClose "testHistory"+                 (frpTest [history (fromSeconds 0.31)]+                          [2,3,1,1,2,2,2,7,7,7,7,7])+                 [[[edge0]],+                  [[edge1,edge0]],+                  [[edge2,edge1,edge0]],+                  [[edge2,edge1,edge0]],+                  [[edge3,edge2,edge1]],+                  [[edge3,edge2,edge1]],+                  [[edge3,edge2,edge1]],+                  [[edge4,edge3]],+                  [[edge4,edge3]],+                  [[edge4,edge3]],+                  [[edge4,edge3]],+                  [[edge4,edge3]]]+                 (listEqualClose $ listEqualClose $ listEqualClose $ edgeEqualClose (==))+    where edge0 = Edge { edge_previous = 2,+                         edge_next = 2,+                         edge_changed = fromSeconds 0.0 }+          edge1 = Edge { edge_previous = 2,+                         edge_next = 3,+                         edge_changed = fromSeconds 0.1 }+          edge2 = Edge { edge_previous = 3,+                         edge_next = 1,+                         edge_changed = fromSeconds 0.2 }+          edge3 = Edge { edge_previous = 1,+                         edge_next = 2,+                         edge_changed = fromSeconds 0.4 }+          edge4 = Edge { edge_previous = 2,+                         edge_next = 7,+                         edge_changed = fromSeconds 0.7 }++testEdgep :: IO ()+testEdgep = test "testEdgep"+                 (frpTest [edgep]+                          [2,2,2,3,2,3,3,3,4,4,4,4,5,4,5,5])+                 [[False],[False],[False],[True],[True],[True],[False],[False],[True],[False],[False],[False],+                  [True],[True],[True],[False]]++testSticky :: IO ()+testSticky = test "testSticky"+                  (frpTest [sticky odd 1]+		           [0,1,2,3,4,5,6,7,8,9,10,11])+		  [[1],[1],[1],[3],[3],[5],[5],[7],[7],[9],[9],[11]]++testRadiansToDegrees :: IO ()+testRadiansToDegrees = testClose "testRadiansToDegrees"+                          (toDegrees $ fromRadians (pi/6))+                          30+                          equalClose++testDegreesToRadians :: IO ()+testDegreesToRadians = testClose "testDegreesToRadians"+                          (toRadians $ fromDegrees 270)+                          (-pi/2)+                          equalClose++testAngleAdd :: IO ()+testAngleAdd = testClose "testAngleAdd"+                   (toDegrees $ fromDegrees 100 `angleAdd` fromDegrees 90)+                   (-170)+                   equalClose++testAngleSubtract :: IO ()+testAngleSubtract = testClose "testAngleSubtract"+                        (toDegrees $ fromDegrees (-20) `angleSubtract` fromDegrees 400)+                        (-60)+                        equalClose++testDoubles :: IO ()+testDoubles = test "testDoubles"+                             (doubles [1,2,3,4])+                             [(1,2),(2,3),(3,4)]++testLoopedDoubles :: IO ()+testLoopedDoubles = test "testLoopedDoubles"+                             (loopedDoubles [1,2,3,4])+                             [(1,2),(2,3),(3,4),(4,1)]++testConsecutives :: IO ()+testConsecutives = test "testConsecutives"+                             (consecutives 3 [1,2,3,4])+                             [[1,2,3],[2,3,4]]++testShortConsecutives :: IO ()+testShortConsecutives = test "testShortConsecutives"+                            (consecutives 3 [1,2])+                            []++testLoopedConsecutives :: IO ()+testLoopedConsecutives = test "testLoopedConsecutives"+                             (loopedConsecutives 3 [1,2,3,4])+                             [[1,2,3],[2,3,4],[3,4,1],[4,1,2]]++testShortLoopedConsecutives :: IO ()+testShortLoopedConsecutives = test "testShortLoopedConsecutives"+                             (loopedConsecutives 3 [1,2])+                             [[1,2,1],[2,1,2]]++testAngleBetween :: IO ()+testAngleBetween = testClose "testAngleBetween"+                   (toDegrees $ angleBetween (vector3d (-1,1,0)) (vector3d (0,0,1)))+                   90+                   equalClose++testDistanceBetween :: IO ()+testDistanceBetween = testClose "testDistanceBetween"+                      (distanceBetween (vector3d (-1,1,0)) (vector3d (0,0,1)))+                      (sqrt 3)+                      equalClose++-- we just test that the right-hand rule is observed+testCrossProduct :: IO ()+testCrossProduct =+    do let (x,y,z) = toXYZ $ crossProduct (vector3d (1,0,0)) (vector3d (0,1,0))+       testClose "testCrossProduct(x)" x 0.0 equalClose+       testClose "testCrossProduct(y)" y 0.0 equalClose+       testClose "testCrossProduct(z)" z 1.0 equalClose++-- crossProduct always yields a vector orthagonal to the parameters.+quickCheckCrossProductByAngleBetween :: IO ()+quickCheckCrossProductByAngleBetween = +    do putStr "quickCheckCrossProductByAngleBetween: "+       quickCheck _qccpbab+           where _qccpbab (v1,v2) = let (a,b,c) = (vector3d v1,vector3d v2,crossProduct a b)+                                        in (toDegrees $ angleBetween a c) `equalClose` 90 &&+                                           (toDegrees $ angleBetween b c) `equalClose` 90++-- orthos always yields two vectors orthagonal to the parameters+quickCheckOrthos :: IO ()+quickCheckOrthos =+    do putStr "quickCheckOrthos: "+       quickCheck _qco+           where _qco v = let a = vector3d v+                              (b,c) = orthos a+                              in (toDegrees $ angleBetween a b) `equalClose` 90 &&+                                 (toDegrees $ angleBetween b c) `equalClose` 90 &&+                                 (toDegrees $ angleBetween a c) `equalClose` 90++testVectorAverage :: IO ()+testVectorAverage =+    do let (x,y,z) = toXYZ $ vectorAverage [vector3d (0.1,0,0),vector3d (0,-2,0),vector3d (0,0,5)]+       testClose "testVectorAverage(x)" x 0.57735 equalClose+       testClose "testVectorAverage(y)" y (-0.57735) equalClose+       testClose "testVectorAverage(z)" z 0.57735 equalClose++testNewell :: IO ()+testNewell =+    do let (x,y,z) = toXYZ $ newell [point3d (1,0,0),point3d (0,1,0),point3d (0,0,-1)]+       testClose "testNewell(x)" x (-0.57735) equalClose+       testClose "testNewell(y)" y (-0.57735) equalClose+       testClose "testNewell(z)" z 0.57735 equalClose++type Double2 = (Double,Double)+type Double22 = (Double2,Double2)+type Double3 = (Double,Double,Double)+type Double33 = (Double3,Double3,Double3)+type Double4 = (Double,Double,Double,Double)+type Double44 = (Double4,Double4,Double4,Double4)++d2ToMatrix :: Double22 -> Matrix+d2ToMatrix ((a,b),(c,d)) = matrix $ [[a,b],[c,d]]++d3ToMatrix :: Double33 -> Matrix+d3ToMatrix ((a,b,c),(d,e,f),(g,h,i)) = matrix $ [[a,b,c],[d,e,f],[g,h,i]]++d4ToMatrix :: Double44 -> Matrix+d4ToMatrix ((a,b,c,d),(e,f,g,h),(i,j,k,l),(m,n,o,p)) = matrix $ [[a,b,c,d],[e,f,g,h],[i,j,k,l],[m,n,o,p]]++testDeterminant2 :: IO ()+testDeterminant2 =+   do test "testDeterminant2-1"+           (determinant $ matrix [[1,5],[3,0]])+           (-15)+      test "testDeterminant2-2"+           (determinant $ matrix [[-2,0],[0.5,1]])+           (-2)+      test "testDeterminant2-3"+           (determinant $ matrix [[0,0.5],[0.5,0.5]])+           (-0.25)++testDeterminant3 :: IO ()+testDeterminant3 =+   do test "testDeterminant3-1"+           (determinant $ matrix [[5,-1,0.5],[-3,4,2],[0,0,-1]])+           (-17)+      testClose "testDeterminant3-2" 3.5+           (determinant $ matrix [[0.5,-0.5,-2.0/3.0],+                                  [-2.5,-1.0,-3.0],+                                  [-0.5,0.5,-4.0/3.0]])+           equalClose++testDeterminant4 :: IO ()+testDeterminant4 =+   do test "testDeterminant4-1"+           (determinant $ matrix [[1.5,-1.0,0.5,-2.0],[1.0,1.5,1.0,1.0],[1.5,1.0,0.5,-0.5],[1.0,1.5,1.0,0.0]])+           2++testJoint :: IO () +testJoint = testClose "testJoint"+    (joint_elbow $ joint (Vector3D 0 1 1) (Point3D 0 1 0) 3 (Point3D 0 0 1))+    (Point3D 0 1.43541 1.43541)+    xyzEqualClose++quickCheckMatrixDeterminant2 :: IO ()+quickCheckMatrixDeterminant2 =+    do putStr "quickCheckMatrixDeterminant2: "+       quickCheck _qcmi+           where _qcmi :: Double22 -> Bool+                 _qcmi m = +                     determinant (matrixTranspose mat) `equalClose` determinant mat+                         where mat = d2ToMatrix m++quickCheckMatrixDeterminant3 :: IO ()+quickCheckMatrixDeterminant3 =+    do putStr "quickCheckMatrixDeterminant3: "+       quickCheck _qcmi+           where _qcmi :: Double33 -> Bool+                 _qcmi m = +                     determinant (matrixTranspose mat) `equalClose` determinant mat+                         where mat = d3ToMatrix m++quickCheckMatrixDeterminant4 :: IO ()+quickCheckMatrixDeterminant4 =+    do putStr "quickCheckMatrixDeterminant4: "+       quickCheck _qcmi+           where _qcmi :: Double44 -> Bool+                 _qcmi m = +                     determinant (matrixTranspose mat) `equalClose` determinant mat+                         where mat = d4ToMatrix m++quickCheckMatrixMultiplyDeterminant2 :: IO ()+quickCheckMatrixMultiplyDeterminant2 =+    do putStr "quickCheckMatrixMultiplyDeterminant2: "+       quickCheck _qcmmd +            where _qcmmd :: (Double22,Double22) -> Bool+                  _qcmmd (m1,m2) =+                       (determinant (mat1 `matrixMultiply` mat2)) `equalClose` (determinant mat1 * determinant mat2)+                           where mat1 = d2ToMatrix m1+                                 mat2 = d2ToMatrix m2++quickCheckMatrixMultiplyDeterminant3 :: IO ()+quickCheckMatrixMultiplyDeterminant3 =+    do putStr "quickCheckMatrixMultiplyDeterminant3: "+       quickCheck _qcmmd +            where _qcmmd :: (Double33,Double33) -> Bool+                  _qcmmd (m1,m2) =+                       (determinant (mat1 `matrixMultiply` mat2)) `equalClose` (determinant mat1 * determinant mat2)+                           where mat1 = d3ToMatrix m1+                                 mat2 = d3ToMatrix m2++quickCheckMatrixMultiplyDeterminant4 :: IO ()+quickCheckMatrixMultiplyDeterminant4 =+    do putStr "quickCheckMatrixMultiplyDeterminant4: "+       quickCheck _qcmmd +            where _qcmmd :: (Double44,Double44) -> Bool+                  _qcmmd (m1,m2) =+                       (determinant (mat1 `matrixMultiply` mat2)) `equalClose` (determinant mat1 * determinant mat2)+                           where mat1 = d4ToMatrix m1+                                 mat2 = d4ToMatrix m2++quickCheckMatrixInverse2 :: IO ()+quickCheckMatrixInverse2 =+    do putStr "quickCheckMatrixInverse2: "+       quickCheck _qcmi+           where _qcmi :: Double22 -> Bool+                 _qcmi ((a,b),(e,f)) = +                     if determinant mat `equalClose` 0+                     then True+                     else matrixInversePrim (matrixInversePrim mat) `matrixEqualClose` mat+                         where mat = matrix [[a,b],[e,f]]++quickCheckMatrixInverse3 :: IO ()+quickCheckMatrixInverse3 =+    do putStr "quickCheckMatrixInverse3: "+       quickCheck _qcmi+           where _qcmi :: Double33 -> Bool+                 _qcmi ((a,b,c),(e,f,g),(i,j,k)) = +                     if determinant mat `equalClose` 0+                     then True+                     else matrixInversePrim (matrixInversePrim mat) `matrixEqualClose` mat+                         where mat = matrix [[a,b,c],[e,f,g],[i,j,k]]++quickCheckMatrixInverse4 :: IO ()+quickCheckMatrixInverse4 =+    do putStr "quickCheckMatrixInverse4: "+       quickCheck _qcmi+           where _qcmi :: Double44 -> Bool+                 _qcmi ((a,b,c,d),(e,f,g,h),(i,j,k,l),(m,n,o,p)) = +                     if determinant mat `equalClose` 0+                     then True+                     else matrixInversePrim (matrixInversePrim mat) `matrixEqualClose` mat+                         where mat = matrix [[a,b,c,d],[e,f,g,h],[i,j,k,l],[m,n,o,p]]++test :: (Eq a,Show a) => String -> a -> a -> IO ()+test name actual expected | actual == expected = +                       do putStrLn $ "Test Case Passed: " ++ name+test name actual expected = +                       do putStrLn ""+                          putStrLn $ "TEST CASE FAILED: " ++ name+                          putStrLn $ "expected: " ++ show expected+                          putStrLn $ "actual:   " ++ show actual+                          putStrLn ""++equalClose :: (Eq a,Num a,Ord a,Fractional a) => a -> a -> Bool+equalClose actual expected | abs (actual * expected) > 0.01 = abs ((expected - actual) / expected) < 0.01+equalClose actual expected = abs (actual - expected) < 0.01++listEqualClose :: (a -> a -> Bool) -> [a] -> [a] -> Bool+listEqualClose f xs ys | length xs == length ys = and $ zipWith f xs ys+listEqualClose _ _ _ = False++matrixEqualClose :: Matrix -> Matrix -> Bool+matrixEqualClose m n = and $ List.map and $ zipWith (zipWith equalClose)+    (rowMajorForm m) (rowMajorForm n)++timeEqualClose :: Time -> Time -> Bool+timeEqualClose t1 t2 = equalClose (toSeconds t1) (toSeconds t2)++edgeEqualClose :: (a -> a -> Bool) -> Edge a -> Edge a -> Bool+edgeEqualClose f x y =+    (edge_previous x `f` edge_previous y) &&+    (edge_next x `f` edge_next y) &&+    (edge_changed x `timeEqualClose` edge_changed y)++xyzEqualClose :: (Xyz xyz) => xyz -> xyz -> Bool+xyzEqualClose a b = equalClose ax bx && equalClose ay by && equalClose az bz+    where (ax,ay,az) = toXYZ a+          (bx,by,bz) = toXYZ b++testClose :: (Show a) => String -> a -> a -> (a -> a -> Bool) -> IO ()+testClose name actual expected f | f actual expected =+    do putStrLn $ "Test Case Passed: " ++ name+testClose name actual expected _ = +    do putStrLn ""+       putStrLn $ "TEST CASE FAILED: " ++ name+       putStrLn $ "expected: " ++ show expected+       putStrLn $ "actual: " ++ show actual+       putStrLn ""++testQualityObject :: IO ()+testQualityObject =+    do bottleneck <- newBottleneck+       qo <- newQuality bottleneck rnf naiveFib qs+       print =<< getQuality qo 100+       threadDelay 1000000+       print =<< getQuality qo 100+       threadDelay 1000000+       print =<< getQuality qo 100+       threadDelay 1000000+       print =<< getQuality qo 100+       threadDelay 1000000+       print =<< getQuality qo 100+       threadDelay 1000000+       print =<< getQuality qo 100+       threadDelay 1000000+       print =<< getQuality qo 100+       threadDelay 1000000+       print =<< getQuality qo 100+       threadDelay 1000000+       print =<< getQuality qo 100+        where qs = [1..100]+              naiveFib :: Integer -> Integer+              naiveFib 0 = 0+              naiveFib 1 = 1+              naiveFib n = naiveFib (n-1) + naiveFib (n-2)++testRK4 :: IO ()+testRK4 = testClose "testRK4" +                    (integrateRK4 (+) (\t _ -> perSecond $ cos $ toSeconds t) 0 (fromSeconds 0) (fromSeconds 1) 100)+                    (sin 1.0 :: Double)+                    equalClose++main :: IO ()+main = do test "add five test (sanity test of StatefulArrow)" +               (addFive 2) 7+          test "even zeroes test (sanity test of SwitchedArrow)" +               (evenZeroes [True,True,False,True,False]) True+          test "odd zeroes test (sanity test of SwitchedArrow)" +               (evenZeroes [True,True,True,False,False,True,False,True]) False+          test "spawning test 1 (sanity test of ThreadedArrow)"+               (spawnPMD 0) (Set.fromList [0])+          test "spawning test 2 (sanity test of ThreadedArrow)"+               (spawnPMD 1) (Set.fromList [-1,1])+          test "spawning test 3 (sanity test of ThreadedArrow)"+               (spawnPMD 2) (Set.fromList [0,-2,2])+          test "spawning test 4 (sanity test of ThreadedArrow)"+               (spawnPMD 3) (Set.fromList [-3,-1,1,3])+          test "spawning test 5 (does killThreadIf work conditionally?)"+               (spawnPMD 4) (Set.fromList [-4,-3,-2,0,2,3,4])+          testIntegral+          testDerivative+          testInitial+          testEdgeFold+          testEdgeMap+          testHistory+          testEdgep+	  testSticky+          testRadiansToDegrees+          testDegreesToRadians+          testAngleAdd+          testAngleSubtract+          testDoubles+          testLoopedDoubles+          testConsecutives+          testShortConsecutives+          testLoopedConsecutives+          testShortLoopedConsecutives+          testAngleBetween+          testDistanceBetween+          testCrossProduct+          quickCheckCrossProductByAngleBetween+          quickCheckOrthos+          testVectorAverage+          testNewell+          testDeterminant2+          testDeterminant3+          testDeterminant4+          quickCheckMatrixDeterminant2+          quickCheckMatrixDeterminant3+          quickCheckMatrixDeterminant4+          quickCheckMatrixMultiplyDeterminant2+          quickCheckMatrixMultiplyDeterminant3+          quickCheckMatrixMultiplyDeterminant4+          quickCheckMatrixInverse2+          quickCheckMatrixInverse3+          quickCheckMatrixInverse4+          testJoint+          testRK4+          testQualityObject
+ RSAGL/ThreadedArrow.lhs view
@@ -0,0 +1,131 @@+\section{RSAGL.ThreadedArrow}++A ThreadedArrow is an extension of the SwitchedArrow.  In addition to switching, ThreadedArrow threads can spawn new threads and+terminate themselves.  All threads recieve the same input.++ThreadedArrow also supports a model of thread management that allows an arbitrary, external function to view all threads and cull unwanted threads+either before they begin or sometime after, and even control the order in which threads exectute.++While the ThreadedArrow has conceptual similarities to the threading systems provided by an operating system,+it provides neither parallelism nor concurency.++\begin{code}+{-# OPTIONS_GHC -farrows -fglasgow-exts #-}++module RSAGL.ThreadedArrow+    (ThreadIdentity,+     nullaryThreadIdentity,+     maybeThreadIdentity,+     unionThreadIdentity,+     ThreadedFunction,+     ThreadedArrow,+     RSAGL.ThreadedArrow.switchContinue,+     RSAGL.ThreadedArrow.switchTerminate,+     spawnThreads,+     killThreadIf,+     threadIdentity,+     RSAGL.ThreadedArrow.statefulForm)+    where++import Control.Arrow+import Control.Arrow.Operations+import Control.Arrow.Transformer+import Control.Arrow.Transformer.State+import RSAGL.SwitchedArrow as SwitchedArrow+import RSAGL.StatefulArrow as StatefulArrow+import Data.Maybe+import Data.List++type ThreadIdentity t = forall i x o. i -> [(t,x)] -> [(t,(o,x))] -> [x]++nullaryThreadIdentity :: ThreadIdentity ()+nullaryThreadIdentity _ news olds = map (snd . snd) olds ++ map snd news++maybeThreadIdentity :: ThreadIdentity t -> ThreadIdentity (Maybe t)+maybeThreadIdentity manageThreads i news olds = manageThreads i (justs news) (justs olds) ++ nothings+        where nothings = map snd (filter (isNothing . fst) news) ++ map (snd . snd) (filter (isNothing . fst) olds)+	      justs = map (first fromJust) . filter (isJust . fst)++unionThreadIdentity :: (t -> t -> Bool) -> ThreadIdentity t+unionThreadIdentity predicate _ news olds_ = map snd $ unionBy (\x y -> fst x `predicate` fst y) olds news+    where olds = map (second snd) olds_++newtype ThreadedArrow t i o a j p = ThreadedArrow (SwitchedArrow i (Maybe o) (StateArrow (t,[(t,ThreadedArrow t i o a i (Maybe o))]) a) j p)+type ThreadedFunction i o j p = ThreadedArrow () i o (->) j p++instance (ArrowChoice a) => Arrow (ThreadedArrow t i o a) where+    (>>>) (ThreadedArrow ta1) (ThreadedArrow ta2) = ThreadedArrow $ ta1 >>> ta2+    arr = ThreadedArrow . arr+    first (ThreadedArrow f) = ThreadedArrow $ first f++instance (Arrow a,ArrowChoice a) => ArrowTransformer (ThreadedArrow t i o) a where+    lift = ThreadedArrow . lift . lift++instance (ArrowChoice a) => ArrowChoice (ThreadedArrow t i o a) where+    left (ThreadedArrow a) = ThreadedArrow $ left a++instance (ArrowChoice a,ArrowApply a) => ArrowApply (ThreadedArrow t i o a) where+    app = ThreadedArrow $ proc (ThreadedArrow a,b) -> app -< (a,b)++statefulForm :: (ArrowChoice a,ArrowApply a) => (forall x. i -> [(t,x)] -> [(t,(o,x))] -> [x]) -> [(t,ThreadedArrow t i o a i o)] -> StatefulArrow a i [(t,o)]+statefulForm manageThreads initial_threads = flip stateContext (map (second (>>> arr Just)) initial_threads) $ proc i ->+    do threads <- fetch -< ()+       olds <- lift (runThreadsLoop manageThreads) -< (i,[],threads)+       store -< map (second snd) olds+       returnA -< map (second fst) olds++manageOldNewThreads :: (forall ex. i -> [(t,ex)] -> [(t,(o,ex))] -> [ex]) -> i -> [(t,x)] -> [(t,(o,x))] -> ([(t,x)],[(t,(o,x))])+manageOldNewThreads manageThreads i news_ olds_ = (concat *** concat) $ unzip $ map (either (\l -> ([l],[])) (\r -> ([],[r]))) result+    where news = map (\x -> second (const $ Left x) x) news_+          olds = map (\x -> second (second $ const $ Right x) x) olds_+	  result = manageThreads i news olds++runThreadsLoop :: (ArrowChoice a,ArrowApply a) => +                      (forall x. i -> [(t,x)] -> [(t,(o,x))] -> [x]) ->+		      a (i,[(t,(o,ThreadedArrow t i o a i (Maybe o)))],[(t,ThreadedArrow t i o a i (Maybe o))])+                        [(t,(o,ThreadedArrow t i o a i (Maybe o)))]+runThreadsLoop manageThreads = proc (i,finished_threads,current_threads) ->+    do (freshly_finished_threads,(_,freshly_spawned_threads)) <- runState runThreads -< +               ((i,current_threads),(error "runThreadsLoop: undefined thread identity",[]))+       let (managed_spawned_threads,managed_finished_threads) = manageOldNewThreads manageThreads i +                                                                freshly_spawned_threads +								(freshly_finished_threads ++ finished_threads)+       if null managed_spawned_threads+           then returnA -< managed_finished_threads+	   else runThreadsLoop manageThreads -< (i,managed_finished_threads,managed_spawned_threads)++runThreads :: (ArrowChoice a,ArrowApply a) => StateArrow (t,[(t,ThreadedArrow t i o a i (Maybe o))]) a +                                                         (i,[(t,ThreadedArrow t i o a i (Maybe o))]) +							 [(t,(o,ThreadedArrow t i o a i (Maybe o)))]+runThreads = proc (i,threads) ->+    do case threads of+           [] -> returnA -< []+	   ((ident,ThreadedArrow switchedA):rest_in) ->+	       do x <- fetch -< ()+	          store -< first (const ident) x+	          (m_o,newA) <- app -< (runStateful switchedA,i)+	          rest_out <- runThreads -< (i,rest_in)+                  returnA -< (maybe id (\o -> ((ident,(o,ThreadedArrow newA)) :)) m_o) rest_out++switchContinue :: (Arrow a,ArrowChoice a,ArrowApply a) => ThreadedArrow t i o a (Maybe (ThreadedArrow t i o a i o),i) i+switchContinue = (arr $ first $ fmap (\(ThreadedArrow thread) -> thread >>> arr Just)) >>> (ThreadedArrow SwitchedArrow.switchContinue)++switchTerminate :: (Arrow a,ArrowChoice a) => ThreadedArrow t i o a (Maybe (ThreadedArrow t i o a i o),o) o+switchTerminate = proc (m_thread,o) ->+    do ThreadedArrow $ SwitchedArrow.switchTerminate -< (fmap (\(ThreadedArrow thread) -> thread >>> arr Just) m_thread,Just o)+       returnA -< o++spawnThreads :: (Arrow a,ArrowChoice a) => ThreadedArrow t i o a [(t,ThreadedArrow t i o a i o)] ()+spawnThreads = ThreadedArrow $ lift $ proc new_spawned -> +    do x <- fetch -< ()+       store -< second (map (second (>>> arr Just)) new_spawned ++) x+       returnA -< ()++killThreadIf :: (Arrow a,ArrowChoice a,ArrowApply a) => ThreadedArrow t i o a Bool ()+killThreadIf = proc b -> +    do ThreadedArrow SwitchedArrow.switchContinue -< (if b then (Just $ arr (const Nothing)) else Nothing,error "ThreadedArrow.killThreadIf: this thread has been killed")+       returnA -< ()++threadIdentity :: (ArrowChoice a) => ThreadedArrow t i o a () t+threadIdentity = arr fst <<< ThreadedArrow (lift fetch)+\end{code}
+ RSAGL/Time.lhs view
@@ -0,0 +1,156 @@+\section{RSAGL.Time}++RSAGL.Time provides a fixed-point (as opposed to a floating-point number) representation of time.+This is necessary because the Float and Double types are inadequate to precisely represent large+quantities of time.++This time library is designed to support real-time animation.++\begin{code}+{-# LANGUAGE TypeSynonymInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}++module RSAGL.Time+    (Time,+     Rate,+     Acceleration,+     Frequency,+     fps30,+     fps60,+     fps120,+     minute,+     day,+     month,+     year,+     fromSeconds,+     toSeconds,+     getTime,+     cyclical,+     cyclical',+     over,+     rate,+     time,+     perSecond,+     per,+     interval,+     withTime)+    where++import RSAGL.AbstractVector+import System.Time+import Control.Monad+import Data.Fixed+import Data.Ratio+import RSAGL.Affine++newtype Time = Time Pico deriving (Show,Eq,Ord)+newtype Rate a = Rate a deriving (Show,Eq,Ord,AffineTransformable)+type Acceleration a = Rate (Rate a)+type Frequency = Rate Double++instance AbstractZero Time where+    zero = Time 0.0++instance AbstractAdd Time Time where+    add (Time a) (Time b) = Time $ a `add` b++instance AbstractSubtract Time Time where+    sub (Time a) (Time b) = Time $ a `sub` b++instance AbstractScale Time where+    scalarMultiply d (Time t) = Time $ realToFrac d * t++instance AbstractVector Time++instance (AbstractZero a) => AbstractZero (Rate a) where+    zero = Rate zero++instance (AbstractAdd a a) => AbstractAdd (Rate a) (Rate a) where+    add (Rate a) (Rate b) = Rate $ a `add` b++instance (AbstractSubtract a a) => AbstractSubtract (Rate a) (Rate a) where+    sub (Rate a) (Rate b) = Rate $ a `sub` b++instance (AbstractScale a) => AbstractScale (Rate a) where+    scalarMultiply d (Rate r) = Rate $ scalarMultiply d r++instance (AbstractVector a) => AbstractVector (Rate a)+\end{code}++\subsection{Getting and Constructing Time}++getTime gets the current, absolute time, using Haskell's standard time facilities.++\begin{code}+minute :: Time+minute = fromSeconds 60++hour :: Time+hour = scalarMultiply 60 minute++day :: Time+day = scalarMultiply 24 hour++month :: Time+month = scalarMultiply 30.43 day++year :: Time+year = scalarMultiply 365.25 month++fps30 :: Frequency+fps30 = perSecond 24++fps60 :: Frequency+fps60 = perSecond 60++fps120 :: Frequency+fps120 = perSecond 120++fromSeconds :: Double -> Time+fromSeconds = Time . realToFrac++toSeconds :: Time -> Double+toSeconds (Time t) = realToFrac t++getTime :: IO Time+getTime = +    do (TOD secs picos) <- getClockTime+       return $ Time $ fromIntegral secs + fromRational (picos%(resolution (undefined :: E12)))+\end{code}++\subsection{Modulo Division for Time}++\texttt{cyclical} answers the amount of time into a cycle.  \texttt{cyclical'} answers the fraction of time into a cycle, +in the range \texttt{0 <= x <= 1}.++\begin{code}+cyclical :: Time -> Time -> Time+cyclical (Time t) (Time k) = Time $ t `mod'` k++cyclical' :: Time -> Time -> Double+cyclical' t k = (toSeconds $ t `cyclical` k) / toSeconds k+\end{code}++\subsection{Rate as Change over Time}++\begin{code}+over :: (AbstractVector a) => Rate a -> Time -> a+over (Rate a) (Time t) = realToFrac t `scalarMultiply` a++rate :: (AbstractVector a) => (a,Time) -> (a,Time) -> Rate a+rate (x,t1) (y,t2) = (y `sub` x) `per` (t2 `sub` t1)++perSecond :: a -> Rate a+perSecond a = Rate a++per :: (AbstractVector a) => a -> Time -> Rate a+per a (Time t) = Rate $ realToFrac (recip t) `scalarMultiply` a++interval :: Frequency -> Time+interval (Rate x) = fromSeconds $ recip x++time :: Double -> Rate Double -> Time+time d r = interval $ withTime (fromSeconds 1) (/d) r++withTime :: (AbstractVector a,AbstractVector b) => Time -> (a -> b) -> Rate a -> Rate b+withTime t f = (`per` t) . f . (`over` t)+\end{code}
+ RSAGL/Vector.lhs view
@@ -0,0 +1,289 @@+\section{Points and Vectors: RSAGL.Vector}++\begin{code}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-}+module RSAGL.Vector+    (Point3D(..),+     origin_point_3d,+     Vector3D(..),+     SurfaceVertex3D(..),+     zero_vector,+     point3d,+     points3d,+     point2d,+     points2d,+     vector3d,+     dotProduct,+     angleBetween,+     crossProduct,+     distanceBetween,+     distanceBetweenSquared,+     aNonZeroVector,+     vectorAdd,+     vectorSum,+     vectorScale,+     vectorScaleTo,+     vectorToFrom,+     vectorNormalize,+     vectorAverage,+     vectorLength,+     vectorLengthSquared,+     newell,+     Xyz(..),+     XYZ,+     vectorString,+     randomXYZ,+     fixOrtho,+     fixOrtho2,+     fixOrtho2Left,+     orthos)+    where++import Data.Maybe+import Control.Parallel.Strategies+import RSAGL.Angle+import RSAGL.Auxiliary+import System.Random+import RSAGL.AbstractVector+\end{code}++\subsection{Generic 3-dimensional types and operations}++\begin{code}+type XYZ = (Double,Double,Double)++class Xyz a where+    toXYZ :: a -> XYZ+    fromXYZ :: XYZ -> a++instance Xyz (Double,Double,Double) where+    toXYZ = id+    fromXYZ = id++vectorString :: Xyz a => a -> String+vectorString xyz = let (x,y,z) = toXYZ xyz+		       in (show x) ++ "," ++ (show y) ++ "," ++ (show z)++uncurry3d :: (Double -> Double -> Double -> a) -> XYZ -> a+uncurry3d fn (x,y,z) = fn x y z+\end{code}++\subsection{Points in 3-space}++\begin{code}+data Point3D = Point3D !Double !Double !Double+	     deriving (Read,Show,Eq)++origin_point_3d :: Point3D+origin_point_3d = Point3D 0 0 0++point3d :: (Double,Double,Double) -> Point3D+point3d = uncurry3d Point3D++point2d :: (Double,Double) -> Point3D+point2d (x,y) = point3d (x,y,0)++points3d :: [(Double,Double,Double)] -> [Point3D]+points3d = map point3d++points2d :: [(Double,Double)] -> [Point3D]+points2d = map point2d++instance Xyz Point3D where+    toXYZ (Point3D x y z) = (x,y,z)+    fromXYZ (x,y,z) = Point3D x y z++instance AbstractZero Point3D where+    zero = origin_point_3d++instance AbstractAdd Point3D Vector3D where+    add = displace++instance AbstractSubtract Point3D Vector3D where+    sub = vectorToFrom++instance NFData Point3D+\end{code}++\subsection{Vectors in 3-space}++\begin{code}+data Vector3D = Vector3D !Double !Double !Double+	      deriving (Read,Show,Eq)++zero_vector :: Vector3D+zero_vector = Vector3D 0 0 0++vector3d :: (Double,Double,Double) -> Vector3D+vector3d = uncurry3d Vector3D++instance Xyz Vector3D where+    toXYZ (Vector3D x y z) = (x,y,z)+    fromXYZ (x,y,z) = Vector3D x y z++instance NFData Vector3D++instance AbstractZero Vector3D where+    zero = zero_vector++instance AbstractAdd Vector3D Vector3D where+    add = vectorAdd++instance AbstractSubtract Vector3D Vector3D where+    sub = vectorToFrom++instance AbstractScale Vector3D where+    scalarMultiply = vectorScale++instance AbstractMagnitude Vector3D where+    magnitude = vectorLength++instance AbstractVector Vector3D+\end{code}++A \texttt{SurfaceVertex3D} is a a point on an orientable surface, having a position and a normal vector.++\subsection{Surface Vertices in 3-space}++\begin{code}+data SurfaceVertex3D = SurfaceVertex3D { sv3d_position :: Point3D, +                                         sv3d_normal :: Vector3D }+    deriving (Read,Show)++instance NFData SurfaceVertex3D where+    rnf (SurfaceVertex3D p v) = rnf (p,v)+\end{code}++\subsection{Vector Arithmetic}++\begin{code}+aNonZeroVector :: Vector3D -> Maybe Vector3D+aNonZeroVector (Vector3D 0 0 0) = Nothing+aNonZeroVector vector = Just vector++dotProduct :: Vector3D -> Vector3D -> Double+dotProduct (Vector3D ax ay az) (Vector3D bx by bz) = +    (ax*bx) + (ay*by) + (az*bz)++angleBetween :: Vector3D -> Vector3D -> Angle+angleBetween a b = arcCosine $ dotProduct (vectorNormalize a) (vectorNormalize b)++crossProduct :: Vector3D -> Vector3D -> Vector3D+crossProduct (Vector3D ax ay az) (Vector3D bx by bz) = +    Vector3D (ay*bz - az*by) (az*bx - ax*bz) (ax*by - ay*bx)++distanceBetween :: (Xyz xyz) => xyz -> xyz -> Double+distanceBetween a b = vectorLength $ vectorToFrom a b++distanceBetweenSquared :: (Xyz xyz) => xyz -> xyz -> Double+distanceBetweenSquared a b = vectorLengthSquared $ vectorToFrom a b++displace :: (Xyz xyz) => xyz -> Vector3D -> xyz+displace xyz (Vector3D x2 y2 z2) =+    let (x1,y1,z1) = toXYZ xyz+        in fromXYZ (x1+x2,y1+y2,z1+z2)++vectorAdd :: Vector3D -> Vector3D -> Vector3D+vectorAdd = displace++vectorSum :: [Vector3D] -> Vector3D+vectorSum vectors = foldr vectorAdd zero_vector vectors++vectorToFrom :: (Xyz xyz) => xyz -> xyz -> Vector3D+vectorToFrom a b = +    let (ax,ay,az) = toXYZ a+        (bx,by,bz) = toXYZ b+        in Vector3D (ax - bx) (ay - by) (az - bz)++vectorLength :: Vector3D -> Double+vectorLength = sqrt . vectorLengthSquared++vectorLengthSquared :: Vector3D -> Double+vectorLengthSquared (Vector3D x y z) = (x*x + y*y + z*z)++vectorScale :: Double -> Vector3D -> Vector3D+vectorScale s (Vector3D x y z) = Vector3D (x*s) (y*s) (z*s)+\end{code}++vectorScaleTo forces the length of a vector to a certain value, without changing the vector's direction.++\begin{code}+vectorScaleTo :: Double -> Vector3D -> Vector3D+vectorScaleTo new_length vector = vectorScale new_length $ vectorNormalize vector+\end{code}++vectorNormalize forces the length of a vector to 1, without changing the vector's direction.++\begin{code}+vectorNormalize :: Vector3D -> Vector3D+vectorNormalize v = +    let l = vectorLength v+	in maybe (Vector3D 0 0 0) (vectorScale (1/l)) $ aNonZeroVector v+\end{code}++vectorAverage takes the average of a list of vectors.  The result is a normalized vector+where the length of the element vectors is not reflected in the result.++\begin{code}+vectorAverage :: [Vector3D] -> Vector3D+vectorAverage vects = vectorNormalize $ vectorSum $ map vectorNormalize vects+\end{code}++\subsection{Generating normal vectors}++newell calculates the normal vector of an arbitrary polygon.  If the points specified are non-coplanar,+newell often calculates a reasonable result.++The result is a normalized vector.++\begin{code}+newell :: [Point3D] -> Vector3D+newell points = vectorNormalize $ fromMaybe (error errmsg) $ aNonZeroVector $ vectorSum $ map newell_ $ loopedDoubles points+    where newell_ (Point3D x0 y0 z0,Point3D x1 y1 z1) =+              (Vector3D +               ((y0 - y1)*(z0 + z1))+               ((z0 - z1)*(x0 + x1))+               ((x0 - x1)*(y0 + y1)))+          errmsg = "newell: zero vector.  This is typically caused by colinear geometries, such as degenerate triangles, zero-radius spheres " +++                   "or certain extrusions with a linear spine and no explicit orientation."+\end{code}++\subsection{Randomly Generated Coordinates}++\texttt{randomXYZ} can generate random coordinates within the cube where x, y, and z are each in the range (lo,hi).++\begin{code}+randomXYZ :: (RandomGen g,Xyz p) => (Double,Double) -> g -> (p,g)+randomXYZ lohi g = (fromXYZ (x,y,z),g')+    where (g_,g') = split g+          (x:y:z:_) = randomRs lohi g_+\end{code}++\subsection{Orthagonal Vectors}++\texttt{fixOrtho a v} finds the vector, orthagonal to a, that has the least angle to v.++\texttt{fixOrtho2 right up} yields \texttt{(up,forward)}.++\texttt{fixOrtho2Left right up} yields \texttt{(up,backward)}.++\texttt{orthos} finds two arbitrary vectors orthagonal to the parameter.++\begin{code}+fixOrtho :: Vector3D -> Vector3D -> Vector3D+fixOrtho a = fst . fixOrtho2 a++fixOrtho2 :: Vector3D -> Vector3D -> (Vector3D,Vector3D)+fixOrtho2 a v = (vectorNormalize $ crossProduct a $ vectorScale (-1) b,vectorNormalize b)+    where b = crossProduct a v++fixOrtho2Left :: Vector3D -> Vector3D -> (Vector3D,Vector3D)+fixOrtho2Left a v = (vectorNormalize $ crossProduct a b,vectorNormalize b)+    where b = vectorScale (-1) $ crossProduct a v++orthos :: Vector3D -> (Vector3D,Vector3D)+orthos v@(Vector3D x y z) | abs y >= abs x && abs z >= abs x = fixOrtho2 v (Vector3D (abs x + abs y + abs z) y z)+orthos v@(Vector3D x y z) | abs x >= abs y && abs z >= abs y = fixOrtho2 v (Vector3D x (abs x + abs y + abs z) z)+orthos v@(Vector3D x y z) | abs x >= abs z && abs y >= abs z = fixOrtho2 v (Vector3D x y (abs x + abs y + abs z))+orthos _ = error "orthos: NaN"+\end{code}
+ RSAGL/WrappedAffine.lhs view
@@ -0,0 +1,30 @@+\section{Wrapped Affine Data Types}++\begin{code}+module RSAGL.WrappedAffine+    (WrappedAffine(..),+     wrapAffine,+     unwrapAffine)+    where++import RSAGL.Affine+import RSAGL.CoordinateSystems+\end{code}++\texttt{WrappedAffine} stores up affine transformations that are commited only when the entity is unwrapped.  In this way we can store affine transformations for entities that can not be directly transformed, or for which delaying transformation as long as possible is an optimization.++\begin{code}+data WrappedAffine a = WrappedAffine CoordinateSystem a++wrapAffine :: a -> WrappedAffine a+wrapAffine = WrappedAffine root_coordinate_system++unwrapAffine :: (AffineTransformable a) => WrappedAffine a -> a+unwrapAffine (WrappedAffine cs a) = migrate cs root_coordinate_system a++instance AffineTransformable (WrappedAffine a) where+    transform t (WrappedAffine cs a) = WrappedAffine (transform t cs) a++instance Functor WrappedAffine where+    fmap f (WrappedAffine m a) = WrappedAffine m $ f a+\end{code}
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMainWithHooks simpleUserHooks
+ rsagl.cabal view
@@ -0,0 +1,43 @@+name:                rsagl+version:             0.2.1+license:             BSD3+license-file:        LICENSE+author:              Christopher Lane Hinson+maintainer:          Christopher Lane Hinson <lane@downstairspeople.org>++category:            Game, Graphics+synopsis:            The RogueStar Animation and Graphics Library+description:         RSAGL, the RogueStar Animation and Graphics Library, includes a+                     domain-specific monad for 3D modelling of arbitrary parametric surfaces,+                     as well as an animation monad and arrow, which is more or less like YAMPA+                     as a stack of arrow transformers.  RSAGL was specifically designed for+                     roguestar, but every effort has been made (including the license) to make+                     it accessable to other projects that might benefit from it.+                     .+                     The Darcs repository is available at <http://www.downstairspeople.org/darcs/rsagl>.+homepage:            http://roguestar.downstairspeople.org/++build-depends:       base>3, old-time, random, array, arrows, containers, parallel, mtl, OpenGL, GLUT, QuickCheck<2+build-type:          Simple+tested-with:         GHC==6.8.2++exposed-modules:     Models.PlanetRingMoon,+                     RSAGL.FRPBase, RSAGL.RayTrace, RSAGL.StatefulArrow,+                     RSAGL.Material, RSAGL.Auxiliary, RSAGL.BoundingBox,+                     RSAGL.Vector, RSAGL.KinematicSensors, RSAGL.RSAGLColors,+                     RSAGL.Extrusion, RSAGL.Main, RSAGL.Color,+                     RSAGL.SwitchedArrow, RSAGL.Time, RSAGL.Matrix,+                     RSAGL.Joint, RSAGL.ArrowTransformerOptimizer, RSAGL.ProcessColors,+                     RSAGL.Affine, RSAGL.WrappedAffine, RSAGL.CurveExtras,+                     RSAGL.Scene, RSAGL.InverseKinematics, RSAGL.FRP,+                     RSAGL.RK4, RSAGL.AnimationExtras, RSAGL.Interpolation,+                     RSAGL.Model, RSAGL.Deformation, RSAGL.QualityControl,+                     RSAGL.Noise, RSAGL.ApplicativeWrapper, RSAGL.Tesselation,+                     RSAGL.Bottleneck, RSAGL.ModelingExtras, RSAGL.Animation,+                     RSAGL.Curve, RSAGL.Angle, RSAGL.Optimization,+                     RSAGL.Tests, RSAGL.CoordinateSystems, RSAGL.Orthagonal,+                     RSAGL.AbstractVector, RSAGL.ThreadedArrow, RSAGL.Edge,+                     RSAGL.Homogenous++ghc-options:         -Wall -threaded -fno-warn-type-defaults -fexcess-precision+ghc-prof-options:    -prof -auto-all