gloss-examples 1.7.0.1 → 1.7.2.1
raw patch · 98 files changed
+4364/−3407 lines, 98 filesdep +gloss-rasterdep ~ghc-primdep ~vectornew-component:exe:gloss-crystalnew-component:exe:gloss-pulsenew-component:exe:gloss-raynew-component:exe:gloss-wave
Dependencies added: gloss-raster
Dependency ranges changed: ghc-prim, vector
Files
- Bitmap/Main.hs +0/−27
- Boids/KDTree2d.hs +0/−175
- Boids/Main.hs +0/−354
- Boids/Vec2.hs +0/−59
- Clock/Main.hs +0/−73
- Conway/Cell.hs +0/−91
- Conway/Main.hs +0/−64
- Conway/World.hs +0/−131
- Draw/Main.hs +0/−59
- Easy/Main.hs +0/−3
- Eden/Cell.hs +0/−38
- Eden/Community.hs +0/−55
- Eden/Main.hs +0/−19
- Eden/World.hs +0/−47
- Flake/Main.hs +0/−46
- GameEvent/Main.hs +0/−14
- Hello/Main.hs +0/−18
- Lifespan/Cell.hs +0/−36
- Lifespan/Community.hs +0/−58
- Lifespan/Main.hs +0/−20
- Lifespan/World.hs +0/−44
- Machina/Main.hs +0/−30
- Occlusion/Cell.hs +0/−47
- Occlusion/Data.hs +0/−40
- Occlusion/Main.hs +0/−118
- Occlusion/State.hs +0/−42
- Occlusion/World.hs +0/−156
- Styrene/Actor.hs +0/−73
- Styrene/Advance.hs +0/−130
- Styrene/Collide.hs +0/−167
- Styrene/Config.hs +0/−46
- Styrene/Contact.hs +0/−132
- Styrene/Main.hs +0/−117
- Styrene/QuadTree.hs +0/−90
- Styrene/World.hs +0/−90
- Tree/Main.hs +0/−54
- Visibility/Draw.hs +0/−120
- Visibility/Geometry/Randomish.hs +0/−115
- Visibility/Geometry/Segment.hs +0/−81
- Visibility/Interface.hs +0/−72
- Visibility/Main.hs +0/−27
- Visibility/State.hs +0/−59
- Visibility/World.hs +0/−54
- Zen/Main.hs +0/−64
- gloss-examples.cabal +121/−52
- picture/Bitmap/Main.hs +27/−0
- picture/Boids/KDTree2d.hs +175/−0
- picture/Boids/Main.hs +354/−0
- picture/Boids/Vec2.hs +59/−0
- picture/Clock/Main.hs +73/−0
- picture/Conway/Cell.hs +91/−0
- picture/Conway/Main.hs +64/−0
- picture/Conway/World.hs +131/−0
- picture/Draw/Main.hs +59/−0
- picture/Easy/Main.hs +3/−0
- picture/Eden/Cell.hs +38/−0
- picture/Eden/Community.hs +55/−0
- picture/Eden/Main.hs +19/−0
- picture/Eden/World.hs +47/−0
- picture/Flake/Main.hs +46/−0
- picture/GameEvent/Main.hs +14/−0
- picture/Hello/Main.hs +18/−0
- picture/Lifespan/Cell.hs +36/−0
- picture/Lifespan/Community.hs +58/−0
- picture/Lifespan/Main.hs +20/−0
- picture/Lifespan/World.hs +44/−0
- picture/Machina/Main.hs +30/−0
- picture/Occlusion/Cell.hs +47/−0
- picture/Occlusion/Data.hs +40/−0
- picture/Occlusion/Main.hs +118/−0
- picture/Occlusion/State.hs +42/−0
- picture/Occlusion/World.hs +156/−0
- picture/Styrene/Actor.hs +73/−0
- picture/Styrene/Advance.hs +130/−0
- picture/Styrene/Collide.hs +167/−0
- picture/Styrene/Config.hs +46/−0
- picture/Styrene/Contact.hs +132/−0
- picture/Styrene/Main.hs +117/−0
- picture/Styrene/QuadTree.hs +90/−0
- picture/Styrene/World.hs +90/−0
- picture/Tree/Main.hs +54/−0
- picture/Visibility/Draw.hs +120/−0
- picture/Visibility/Geometry/Randomish.hs +115/−0
- picture/Visibility/Geometry/Segment.hs +81/−0
- picture/Visibility/Interface.hs +72/−0
- picture/Visibility/Main.hs +27/−0
- picture/Visibility/State.hs +59/−0
- picture/Visibility/World.hs +54/−0
- picture/Zen/Main.hs +64/−0
- raster/Crystal/Main.hs +107/−0
- raster/Pulse/Main.hs +12/−0
- raster/Ray/Light.hs +69/−0
- raster/Ray/Main.hs +235/−0
- raster/Ray/Object.hs +215/−0
- raster/Ray/Trace.hs +63/−0
- raster/Ray/Vec3.hs +81/−0
- raster/Ray/World.hs +57/−0
- raster/Wave/Main.hs +49/−0
− Bitmap/Main.hs
@@ -1,27 +0,0 @@--import Graphics.Gloss-import Codec.BMP-import System.Environment---- | Displays uncompressed 24/32 bit BMP images.-main- = do args <- getArgs- case args of- [fileName] -> run fileName- _ -> putStr - $ unlines [ "usage: bitmap <file.bmp>"- , " file.bmp should be a 24 or 32-bit uncompressed BMP file" ]--run fileName- = do picture@(Bitmap width height _ _)- <- loadBMP fileName-- animate (InWindow fileName (width, height) (10, 10))- black (frame width height picture)--frame :: Int -> Int -> Picture -> Float -> Picture-frame width height picture t- = Color (greyN (abs $ sin (t * 2)))- $ Pictures - [rectangleSolid (fromIntegral width) (fromIntegral height)- , picture]
− Boids/KDTree2d.hs
@@ -1,175 +0,0 @@-{-# LANGUAGE BangPatterns #-}--- KDTree code--- by Matthew Sottile <matt@galois.com> <mjsottile@computer.org>----module KDTree2d (- KDTreeNode(..),- newKDTree,- kdtAddPoints,- kdtAddPoint,- kdtRangeSearch,- kdtCollisionDetect,- kdtInBounds,- dumpKDTree,- mapKDTree,- kdtreeToList-) where-import Vec2-import Data.Maybe-import System.IO---data KDTreeNode a - = Empty- | Node !(KDTreeNode a) !Vec2 !a !(KDTreeNode a)- deriving Show----- | An empty KDTree-newKDTree :: KDTreeNode a-newKDTree = Empty---- | Flatten out a KDTree to a list.-kdtreeToList :: KDTreeNode a -> [a]-kdtreeToList Empty = []-kdtreeToList (Node l _ x r) = [x] ++ kdtreeToList l ++ kdtreeToList r----- | Apply a worker function to all elements of a KDTree.-mapKDTree :: KDTreeNode a -> (a -> b) -> [b]-mapKDTree Empty _ = []-mapKDTree (Node l p n r) f = f n : (mapKDTree l f ++ mapKDTree r f)---kdtAddWithDepth :: KDTreeNode a -> Vec2 -> a -> Int -> KDTreeNode a-kdtAddWithDepth Empty pos dat _ - = Node Empty pos dat Empty--kdtAddWithDepth (Node left npos ndata right) pos dat d - | vecDimSelect pos d < vecDimSelect npos d- = Node (kdtAddWithDepth left pos dat d') npos ndata right-- | otherwise- = Node left npos ndata (kdtAddWithDepth right pos dat d')- where d' = if (d == 1) then 0 else 1---kdtAddPoint :: KDTreeNode a -> Vec2 -> a -> KDTreeNode a-kdtAddPoint t p d - = kdtAddWithDepth t p d 0--kdtInBounds p bMin bMax - = vecLessThan p bMax && vecGreaterThan p bMin----- X dimension-kdtRangeSearchRecX :: KDTreeNode a -> Vec2 -> Vec2 -> [(Vec2,a)]-kdtRangeSearchRecX Empty _ _ = []-kdtRangeSearchRecX (Node left npos ndata right) bMin bMax- | nc < mnc- = nextfun right bMin bMax-- | nc > mxc- = nextfun left bMin bMax-- | kdtInBounds npos bMin bMax- = (npos, ndata) - : (nextfun right bMin bMax ++ nextfun left bMin bMax)-- | otherwise- = nextfun right bMin bMax ++ nextfun left bMin bMax-- where Vec2 nc _ = npos- Vec2 mnc _ = bMin- Vec2 mxc _ = bMax- nextfun = kdtRangeSearchRecY----- Y dimension-kdtRangeSearchRecY :: (KDTreeNode a) -> Vec2 -> Vec2 -> [(Vec2,a)]-kdtRangeSearchRecY Empty _ _ = []-kdtRangeSearchRecY (Node left npos ndata right) bMin bMax- | nc < mnc- = nextfun right bMin bMax- - | nc > mxc- = nextfun left bMin bMax- - | (kdtInBounds npos bMin bMax)- = (npos, ndata)- : (nextfun right bMin bMax ++ nextfun left bMin bMax)-- | otherwise- = nextfun right bMin bMax ++ nextfun left bMin bMax-- where Vec2 _ nc = npos- Vec2 _ mnc = bMin- Vec2 _ mxc = bMax- nextfun = kdtRangeSearchRecX---kdtRangeSearch :: (KDTreeNode a) -> Vec2 -> Vec2 -> [(Vec2,a)]-kdtRangeSearch t bMin bMax - = kdtRangeSearchRecX t bMin bMax---kdtAddPoints :: [(Vec2,a)] -> (KDTreeNode a) -> (KDTreeNode a)-kdtAddPoints [] t = t-kdtAddPoints ((pt, dat):ps) t - = kdtAddPoints ps $ kdtAddPoint t pt dat---singleCollision :: Vec2 -> Vec2 -> Vec2 -> Double -> a -> Maybe (Vec2, a)-singleCollision pt start a eps dat- | sqrd_dist < eps * eps- = Just (vecAdd start p, dat)- - | otherwise- = Nothing-- where b = vecSub pt start- xhat = (vecDot a b) / (vecDot a a)- p = vecScale a xhat- e = vecSub p b- sqrd_dist = vecDot e e---kdtCollisionDetect :: KDTreeNode a -> Vec2 -> Vec2 -> Double -> [(Vec2,a)]-kdtCollisionDetect root !start !end !eps - = colls - where Vec2 sx sy = start- Vec2 ex ey = end- rmin = Vec2 (min sx ex - eps) (min sy ey - eps)- rmax = Vec2 (max sx ex + eps) (max sy ey + eps)- pts = kdtRangeSearch root rmin rmax- a = vecSub end start- colls = mapMaybe (\(pt,dat) -> singleCollision pt start a eps dat) pts- - --- Dumping ----------------------------------------------------------------------- | Dump a KDTree to a file-dumpKDTree :: KDTreeNode Int -> FilePath -> IO ()-dumpKDTree kdt name - = do h <- openFile name WriteMode- hPutStrLn h "n x y z"- dumpKDTreeInner kdt h- hClose h----- | Dump a KDTree to a handle.-dumpKDTreeInner :: KDTreeNode Int -> Handle -> IO ()-dumpKDTreeInner kdt h - = case kdt of- Empty -> return ()-- Node l v d r - -> do printVec v h d- dumpKDTreeInner l h- dumpKDTreeInner r h----- | Print a vector to a handle.-printVec :: Vec2 -> Handle -> Int -> IO ()-printVec (Vec2 x y) h i - = hPutStrLn h $ show i ++ " " ++ show x ++ " " ++ show y-
− Boids/Main.hs
@@ -1,354 +0,0 @@--- Implementation of the Boids flocking algorithm. --- by Matthew Sottile <matt@galois.com> <mjsottile@computer.org>--- Described in http://syntacticsalt.com/2011/03/10/functional-flocks/------ Read more about Boids here: http://www.red3d.com/cwr/boids/--- -import KDTree2d-import Vec2-import System.Random-import System.IO.Unsafe-import Debug.Trace-import Graphics.Gloss-import Graphics.Gloss.Data.Picture-import Graphics.Gloss.Interface.Pure.Simulate----- Parameters ------------------------------------------------------------------cParam = 0.0075--sParam = 0.1-sScale = 1.25--aParam = 1.0 / 1.8-vLimit = 0.0025 * max (maxx - minx) (maxy - miny)-epsilon = 0.40-maxx = 8.0-maxy = 8.0-minx = -8.0-miny = -8.0----- Colors ----------------------------------------------------------------------boidColor = makeColor 1.0 1.0 0.0 1.0-radiusColor = makeColor 0.5 1.0 1.0 0.2-cohesionColor = makeColor 1.0 0.0 0.0 1.0-separationColor = makeColor 0.0 1.0 0.0 1.0-alignmentColor = makeColor 0.0 0.0 1.0 1.0----- Types -----------------------------------------------------------------------data World- = World- { width :: Double- , height :: Double- , pixWidth :: Int- , pixHeight :: Int }- deriving Show---data Boid- = Boid- { identifier :: Int- , position :: Vec2- , velocity :: Vec2- , dbgC :: Vec2- , dbgS :: Vec2- , dbgA :: Vec2 }- deriving Show----- Main ------------------------------------------------------------------------main :: IO ()-main - = do let w = World { width = maxx - minx- , height = maxy - miny- , pixWidth = 700- , pixHeight = 700 }-- let bs = initialize 500 10.0 0.5- let t = foldl (\t b -> kdtAddPoint t (position b) b) newKDTree bs-- simulate (InWindow "Boids" (pixWidth w, pixHeight w) (10,10))- (greyN 0.1) 30 t (renderboids w) iterationkd----- Coordinate Conversion -------------------------------------------------------modelToScreen :: World -> (Double, Double) -> (Float, Float)-modelToScreen world (x,y) - = let xscale = fromIntegral (pixWidth world) / width world- yscale = fromIntegral (pixHeight world) / height world- in (realToFrac $ x * xscale, realToFrac $ y * yscale)---scaleFactor :: World -> Float-scaleFactor world- = let xscale = fromIntegral (pixWidth world) / width world- yscale = fromIntegral (pixHeight world) / height world- in realToFrac $ max xscale yscale---velocityScale :: Float-velocityScale = 10.0 * (realToFrac (max (maxx - minx) (maxy - miny)) :: Float)----- Rendering ------------------------------------------------------------------renderboids :: World -> KDTreeNode Boid -> Picture-renderboids world bs- = Pictures $ mapKDTree bs (renderboid world)--renderboid :: World -> Boid -> Picture-renderboid world b - = let (Vec2 x y) = position b- (Vec2 vx vy) = velocity b- v = velocity b- (Vec2 dCX dCY) = dbgC b- (Vec2 dSX dSY) = dbgS b- (Vec2 dAX dAY) = dbgA b- sf = 5.0 * (scaleFactor world)- sf' = 1.0 * (scaleFactor world)- sf2 = sf * 10- (xs,ys) = modelToScreen world (x,y)- vxs = sf * (realToFrac vx) :: Float- vys = sf * (realToFrac vy) :: Float-- in Pictures - [ Color boidColor $ - Translate xs ys $- Circle 2-- , Color radiusColor $- Translate xs ys $- Circle ((realToFrac epsilon) * sf')-- , Color boidColor $ - Line [(xs, ys), (xs + vxs, ys + vys)]-- , Color cohesionColor $- Line [(xs, ys), (xs + sf2 * realToFrac dCX, ys + sf2 * realToFrac dCY) ]-- , Color alignmentColor $- Line [(xs, ys), (xs + sf2 * realToFrac dAX, ys + sf2 * realToFrac dAY) ]-- , Color separationColor $- Line [(xs, ys), (xs + sf' * realToFrac dSX, ys + sf' * realToFrac dSY)] ]----- Initialisation --------------------------------------------------------------rnlist :: Int -> IO [Double]-rnlist n - = mapM (\_ -> randomRIO (0.0,1.0)) [1..n]---initialize :: Int -> Double -> Double -> [Boid]-initialize n sp sv - = let nums = unsafePerformIO $ rnlist (n*6) - nums' = map (\i -> (0.5 - i) / 2.0) nums-- makeboids [] [] = []- makeboids (a:b:c:d:e:f:rest) (id:ids) - = Boid { identifier = id- , velocity = Vec2 (a*sv) (b*sv)- , position = Vec2 (d*sp) (e*sp)- , dbgC = vecZero- , dbgS = vecZero- , dbgA = vecZero} - : makeboids rest ids-- in makeboids nums' [1..n]----- Vector Helpers ---------------------------------------------------------------- | Sometimes we want to control runaway of vector scales, so this can--- be used to enforce an upper bound-limiter :: Vec2 -> Double -> Vec2-limiter x lim = let d = vecNorm x- in if (d < lim) then x- else vecScale (vecNormalize x) lim---- | Vector with all components length epsilon-epsvec :: Vec2-epsvec = Vec2 epsilon epsilon----- Boids Logic -------------------------------------------------------------------- three rules: --- cohesion (seek centroid)--- separation (avoid neighbors),--- and alignment (fly same way as neighbors)----- | Centroid is average position of boids, or the vector sum of all--- boid positions scaled by 1/(number of boids)-findCentroid :: [Boid] -> Vec2-findCentroid [] = error "Bad centroid"-findCentroid boids - = let n = length boids- in vecScale (foldl1 vecAdd (map position boids))- (1.0 / (fromIntegral n))---- | cohesion : go towards centroid. Parameter dictates fraction of--- distance from boid to centroid that contributes to velocity-cohesion :: Boid -> [Boid] -> Double -> Vec2-cohesion b boids a = vecScale diff a- where c = findCentroid boids- p = position b- diff = vecSub c p- ---- | separation: avoid neighbours-separation :: Boid -> [Boid] -> Double -> Vec2-separation b [] a = vecZero-separation b boids a- = let diff_positions = map (\i -> vecSub (position i) (position b)) boids- closeby = filter (\i -> (vecNorm i) < a) diff_positions- sep = foldl vecSub vecZero closeby- in vecScale sep sScale----- | alignment: fly the same way as neighbours-alignment :: Boid -> [Boid] -> Double -> Vec2-alignment b [] a = vecZero-alignment b boids a - = let v = foldl1 vecAdd (map velocity boids)- s = 1.0 / (fromIntegral $ length boids)- v' = vecScale v s- in vecScale (vecSub v' (velocity b)) a----- | Move one boid, with respect to its neighbours.-oneboid :: Boid -> [Boid] -> Boid-oneboid b boids - = let c = cohesion b boids cParam- s = separation b boids sParam- a = alignment b boids aParam- p = position b- v = velocity b- id = identifier b- v' = vecAdd v (vecScale (vecAdd c (vecAdd s a)) 0.1)- v'' = limiter (vecScale v' 1.0025) vLimit- p' = vecAdd p v''-- in Boid { identifier = id- , position = wraparound p'- , velocity = v''- , dbgC = c- , dbgS = s- , dbgA = a }----- | Neighbor finding code------ This is slightly tricky if we want to represent a world that wraps--- around in one or more dimensions (aka, a torus or cylinder).------ The issue is that we need to split the bounding box that we query the--- KDTree with when that box extends outside the bounds of the world.--- Furthermore, when a set of boids are found in the split bounding boxes--- representing a neighbor after wrapping around, we need to adjust the--- relative position of those boids with respect to the reference frame--- of the central boid. For example, if the central boid is hugging the left--- boundary, and another boid is right next to it hugging the right--- boundary, their proper distance is likely very small. If the one on the--- right boundary isn't adjusted, then the distance will actually appear to--- be very large (approx. the width of the world).--findNeighbors :: KDTreeNode Boid -> Boid -> [Boid]-findNeighbors w b - = let p = position b- - -- bounds- vlo = vecSub p epsvec- vhi = vecAdd p epsvec- - -- split the boxes- splith = splitBoxHoriz (vlo, vhi, 0.0, 0.0)- splitv = concatMap splitBoxVert splith- - -- adjuster for wraparound- adj1 ax ay (pos, theboid)- = (vecAdd pos av, theboid { position = vecAdd p av })-- where av = Vec2 ax ay- p = position theboid-- adjuster lo hi ax ay - = let neighbors = kdtRangeSearch w lo hi- in map (adj1 ax ay) neighbors- - -- do the sequence of range searches- ns = concatMap (\(lo,hi,ax,ay) -> adjuster lo hi ax ay) splitv- - -- compute the distances from boid b to members- dists = map (\(np,n) -> (vecNorm (vecSub p np), n)) ns-- in b : map snd (filter (\(d,_) -> d <= epsilon) dists)---splitBoxHoriz - :: (Vec2, Vec2, Double, Double) - -> [(Vec2, Vec2, Double, Double)]- -splitBoxHoriz (lo@(Vec2 lx ly), hi@(Vec2 hx hy), ax, ay) - | hx-lx > w- = [(Vec2 minx ly, Vec2 maxx hy, ax, ay)]- - | lx < minx- = [ (Vec2 minx ly, Vec2 hx hy, ax, ay)- , (Vec2 (maxx-(minx-lx)) ly, Vec2 maxx hy, (ax-w), ay)]- - | hx > maxx- = [ (Vec2 lx ly, Vec2 maxx hy, ax, ay)- , (Vec2 minx ly, Vec2 (minx + (hx-maxx)) hy, ax+w, ay)]- - | otherwise- = [(lo, hi, ax, ay)]-- where w = maxx-minx---splitBoxVert - :: (Vec2, Vec2, Double, Double)- -> [(Vec2, Vec2, Double, Double)]--splitBoxVert (lo@(Vec2 lx ly), hi@(Vec2 hx hy), ax, ay) - | hy-ly > h- = [(Vec2 lx miny, Vec2 hx maxy, ax, ay)]- - | ly < miny- = [ (Vec2 lx miny, Vec2 hx hy, ax, ay)- , (Vec2 lx (maxy-(miny-ly)), Vec2 hx maxy, ax, ay-h) ]- - | hy > maxy- = [ (Vec2 lx ly, Vec2 hx maxy, ax, ay)- , (Vec2 lx miny, Vec2 hx (miny + (hy-maxy)), ax, ay+h) ]-- | otherwise- = [(lo, hi, ax, ay)]-- where h = maxy-miny---wraparound :: Vec2 -> Vec2-wraparound (Vec2 x y) - = let w = maxx-minx- h = maxy-miny- x' = if x > maxx then x - w else (if x < minx then x+w else x)- y' = if y > maxy then y - h else (if y < miny then y+h else y)-- in Vec2 x' y'-- -iteration :: ViewPort -> Float -> KDTreeNode Boid -> KDTreeNode Boid-iteration vp step w - = let all = kdtreeToList w- boids = mapKDTree w (\i -> oneboid i all)- in foldl (\t b -> kdtAddPoint t (position b) b) newKDTree boids---iterationkd :: ViewPort -> Float -> KDTreeNode Boid -> KDTreeNode Boid-iterationkd vp step w - = let boids = mapKDTree w (\i -> oneboid i (findNeighbors w i))- in foldl (\t b -> kdtAddPoint t (position b) b) newKDTree boids-
− Boids/Vec2.hs
@@ -1,59 +0,0 @@--{-# LANGUAGE BangPatterns #-}-module Vec2 where--data Vec2 - = Vec2 {-# UNPACK #-}!Double {-# UNPACK #-}!Double- deriving Show---vecZero :: Vec2-vecZero = Vec2 0.0 0.0---vecAdd :: Vec2 -> Vec2 -> Vec2-vecAdd (Vec2 a b) (Vec2 x y)- = Vec2 (a+x) (b+y)---vecSub :: Vec2 -> Vec2 -> Vec2-vecSub (Vec2 a b) (Vec2 x y)- = Vec2 (a-x) (b-y)---vecScale :: Vec2 -> Double -> Vec2-vecScale (Vec2 a b) !s- = Vec2 (a*s) (b*s)---vecDot :: Vec2 -> Vec2 -> Double-vecDot (Vec2 a b) (Vec2 x y)- = (a*x)+(b*y)---vecNorm :: Vec2 -> Double-vecNorm v- = sqrt (vecDot v v)---vecNormalize :: Vec2 -> Vec2-vecNormalize v- = vecScale v (1.0 / (vecNorm v))---vecDimSelect :: Vec2 -> Int -> Double-vecDimSelect (Vec2 a b) n- = case rem n 2 of- 0 -> a- 1 -> b---vecLessThan :: Vec2 -> Vec2 -> Bool-vecLessThan (Vec2 a b) (Vec2 x y)- = a < x && b < y---vecGreaterThan :: Vec2 -> Vec2 -> Bool-vecGreaterThan (Vec2 a b) (Vec2 x y)- = a > x && b > y-
− Clock/Main.hs
@@ -1,73 +0,0 @@---- A fractal consisting of circles and lines which looks a bit like--- the workings of a clock.-import Graphics.Gloss--main- = animate (InWindow "Clock" (600, 600) (20, 20))- black frame----- Build the fractal, scale it so it fits in the window--- and rotate the whole thing as time moves on.-frame :: Float -> Picture-frame time- = Color white- $ Scale 120 120- $ Rotate (time * 2*pi)- $ clockFractal 5 time- ---- The basic fractal consists of three circles offset from the origin--- as follows.------ 1--- |--- .--- / \--- 2 3------ The direction of rotation switches as n increases.--- Components at higher iterations also spin faster.----clockFractal :: Int -> Float -> Picture-clockFractal 0 s = Blank-clockFractal n s = Pictures [circ1, circ2, circ3, lines]- where- -- y offset from origin to center of circle 1.- a = 1 / sin (2 * pi / 6)-- -- x offset from origin to center of circles 2 and 3.- b = a * cos (2 * pi / 6)-- nf = fromIntegral n- rot = if n `mod` 2 == 0- then 50 * s * (log (1 + nf))- else (-50 * s * (log (1 + nf)))-- -- each element contains a copy of the (n-1) iteration contained- -- within a larger circle, and some text showing the time since - -- the animation started.- --- circNm1 - = Pictures- [ circle 1- , Scale (a/2.5) (a/2.5) $ clockFractal (n-1) s- , if n > 2- then Color cyan - $ Translate (-0.15) 1- $ Scale 0.001 0.001 - $ Text (show s) - else Blank- ]-- circ1 = Translate 0 a $ Rotate rot circNm1- circ2 = Translate 1 (-b) $ Rotate (-rot) circNm1- circ3 = Translate (-1) (-b) $ Rotate rot circNm1- - -- join each iteration to the origin with some lines.- lines - = Pictures- [ Line [(0, 0), ( 0, a)]- , Line [(0, 0), ( 1, -b)]- , Line [(0, 0), (-1, -b)] ]
− Conway/Cell.hs
@@ -1,91 +0,0 @@--module Cell where-import Graphics.Gloss ---- | A cell in the world.-data Cell- = -- | A living cell with its age- CellAlive Int -- -- | A dead / blank cell.- | CellDead- deriving (Show, Eq)----- | Sort the living from the dead.-isAlive :: Cell -> Bool-isAlive cell- = case cell of- CellAlive _ -> True- CellDead -> False----- | The basic shape of a cell.-cellShape :: Int -> Int -> Int -> Picture-cellShape cellSize posXi posYi- = let cs = fromIntegral cellSize- posX = fromIntegral posXi- posY = fromIntegral posYi- x1 = posX- x2 = posX + cs- y1 = posY - y2 = posY + cs- in Polygon [(x1, y1), (x1, y2), (x2, y2), (x2, y1)]- ---- | Convert a cell to a picture, based on a primitive shape.--- We pass the shape in to avoid recomputing it for each cell.-pictureOfCell :: Int -> Int -> Int -> Int -> Cell -> Picture-pictureOfCell oldAge cellSize posX posY cell- = case cell of- CellAlive age -> Color (ageColor oldAge age) (cellShape cellSize posX posY)- CellDead -> Color (greyN 0.8) (cellShape cellSize posX posY)--ageColor :: Int -> Int -> Color-ageColor oldAge age- = let (r, g, b) = rampColorHotToCold 0 (fromIntegral oldAge) (fromIntegral age)- in makeColor r g b 1.0- - ---- Color Ramps -------------------------------------------------------------------------------------- | Standard Hot -> Cold hypsometric color ramp.--- Sequence is red, yellow, green, cyan, blue.-rampColorHotToCold - :: (Ord a, Floating a) - => a - -> a - -> a - -> (a, a, a)- -rampColorHotToCold vmin vmax vNotNorm- = let - v | vNotNorm < vmin = vmin- | vNotNorm > vmax = vmax- | otherwise = vNotNorm- - dv = vmax - vmin -- result | v < vmin + 0.25 * dv- = ( 0- , 4 * (v - vmin) / dv- , 1.0)- - | v < vmin + 0.5 * dv- = ( 0- , 1.0- , 1 + 4 * (vmin + 0.25 * dv - v) / dv)- - | v < vmin + 0.75 * dv- = ( 4 * (v - vmin - 0.5 * dv) / dv- , 1.0- , 0.0)- - | otherwise- = ( 1.0- , 1 + 4 * (vmin + 0.75 * dv - v) / dv- , 0)- - in result--
− Conway/Main.hs
@@ -1,64 +0,0 @@--module Main where-import World-import Cell-import Graphics.Gloss-import qualified Data.Vector as Vec--main :: IO ()-main - = do - let width = 150- let height = 100- world <- randomWorld (width, height)- - simulate (InWindow "John Conway's Game of Life" - (windowSizeOfWorld world) (5, 5))- white 10 world drawWorld simulateWorld- ---- | Convert a world to a picture.-drawWorld- :: World - -> Picture--drawWorld world - = let (windowWidth, windowHeight) - = windowSizeOfWorld world- - offsetX = - fromIntegral windowWidth / 2- offsetY = - fromIntegral windowHeight / 2 - in Translate offsetX offsetY- $ Pictures - $ Vec.toList - $ Vec.imap (drawCell world) (worldCells world)----- | Convert a cell at a particular coordinate to a picture.-drawCell :: World -> Index -> Cell -> Picture-drawCell world index cell - = let cs = fromIntegral (worldCellSize world)- cp = fromIntegral (worldCellSpace world)-- (x, y) = coordOfIndex world index- fx = fromIntegral x * (cs + cp) + 1- fy = fromIntegral y * (cs + cp) + 1-- in pictureOfCell- (worldCellOldAge world)- (worldCellSize world)- fx- fy- cell- ---- | Get the size of the window needed to display a world.-windowSizeOfWorld :: World -> (Int, Int)-windowSizeOfWorld world- = let cellSize = worldCellSize world- cellSpace = worldCellSpace world- cellPad = cellSize + cellSpace- height = cellPad * (worldHeight world) + cellSpace- width = cellPad * (worldWidth world) + cellSpace- in (width, height)-
− Conway/World.hs
@@ -1,131 +0,0 @@-{-# LANGUAGE PatternGuards, ParallelListComp, BangPatterns #-}--module World where-import Cell-import System.Random-import Control.Monad-import Graphics.Gloss-import Graphics.Gloss.Interface.Pure.Simulate-import qualified Data.Vector as Vec-type Vec = Vec.Vector---- Index ------------------------------------------------------------------------- | An index into the vector holding all the cells.-type Index = Int---- | The x y coordinate of a cell.-type Coord = (Int, Int)--indexOfCoord :: World -> Coord -> Index-indexOfCoord world (x, y) - = x + y * (worldWidth world)--coordOfIndex :: World -> Index -> Coord-coordOfIndex world i - = ( i `mod` worldWidth world- , i `div` worldWidth world)----- World -----------------------------------------------------------------------data World - = World- { worldCells :: Vec Cell - , worldWidth :: Int - , worldHeight :: Int -- -- | Width and height of each cell.- , worldCellSize :: Int-- -- | Number of pixels to leave between each cell.- , worldCellSpace :: Int-- -- | Cells less than this age are drawn with the color ramp- , worldCellOldAge :: Int-- -- | Seconds to wait between each simulation step.- , worldSimulationPeriod :: Float - - -- | Time that has elapsed since we drew the last step- , worldElapsedTime :: Float }----- | Make a new world of a particular size.-randomWorld :: (Int, Int) -> IO World-randomWorld (width, height)- = do bools <- replicateM (width * height) randomIO - return $ World- { worldCells = Vec.fromList $ map cellOfBool bools- , worldWidth = width- , worldHeight = height- , worldCellSize = 5- , worldCellSpace = 1 - , worldCellOldAge = 20- , worldSimulationPeriod = 0.1 - , worldElapsedTime = 0 }----- | Convert a bool to a live or dead cell.-cellOfBool :: Bool -> Cell-cellOfBool b- = case b of- True -> CellAlive 0- False -> CellDead----- | Get the cell at a particular coordinate in the world.-getCell :: World -> Coord -> Cell-getCell world coord@(x, y)- | x < 0 || x >= worldWidth world = CellDead- | y < 0 || y >= worldHeight world = CellDead-- | otherwise - = worldCells world Vec.! indexOfCoord world coord ----- | Get the neighbourhood of cells aroudn this coordinate.-getNeighbourhood :: World -> Coord -> [Cell]-getNeighbourhood world (ix, iy)- = let indexes = [ (x, y) - | x <- [ix - 1 .. ix + 1]- , y <- [iy - 1 .. iy + 1]- , not (x == ix && y == iy) ]- in map (getCell world) indexes----- | Compute the next cell state depending on its neighbours.-stepCell :: Cell -> [Cell] -> Cell-stepCell cell neighbours- = let live = length (filter isAlive neighbours)- in case cell of- CellAlive age -> if elem live [2, 3] then CellAlive (age + 1) else CellDead- CellDead -> if live == 3 then CellAlive 0 else CellDead----- | Compute the next state of the cell at this index in the world.-stepIndex :: World -> Int -> Cell -> Cell-stepIndex world index cell- = let coord = coordOfIndex world index- neigh = getNeighbourhood world coord- in stepCell cell neigh-- --- | Compute the next world state.-stepWorld :: World -> World-stepWorld world- = world { worldCells = Vec.imap (stepIndex world) (worldCells world) }-- --- | Simulation function for worlds.-simulateWorld :: ViewPort -> Float -> World -> World-simulateWorld _ time world -- -- If enough time has passed then it's time to step the world.- | worldElapsedTime world >= (worldSimulationPeriod world)- = let world' = stepWorld world- in world' { worldElapsedTime = 0 }- - -- Wait some more.- | otherwise- = world { worldElapsedTime = worldElapsedTime world + time }--
− Draw/Main.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE PatternGuards #-}--- | Simple picture drawing application. --- Like MSPaint, but you can only draw lines.-import Graphics.Gloss.Interface.Pure.Game-import Graphics.Gloss-import Data.Maybe (maybe)-import Debug.Trace---main - = do let state = State Nothing []- play (InWindow "Draw" (600, 600) (0,0))- white 100 state- makePicture handleEvent stepWorld----- | The game state.-data State - = State (Maybe Path) -- The current line being drawn.- [Picture] -- All the lines drawn previously.----- | A Line Segment-type Segment = ((Float, Float), (Float, Float))----- | Convert our state to a picture.-makePicture :: State -> Picture-makePicture (State m xs)- = Pictures (maybe xs (\x -> Line x : xs) m)----- | Handle mouse click and motion events.-handleEvent :: Event -> State -> State-handleEvent event state- -- If the mouse has moved, then extend the current line.- | EventMotion (x, y) <- event- , State (Just ps) ss <- state- = State (Just ((x, y):ps)) ss -- -- Start drawing a new line.- | EventKey (MouseButton LeftButton) Down _ pt@(x,y) <- event- , State Nothing ss <- state- = State (Just [pt])- ((Translate x y $ Scale 0.1 0.1 $ Text "Down") : ss)-- -- Finish drawing a line, and add it to the picture.- | EventKey (MouseButton LeftButton) Up _ pt@(x,y) <- event- , State (Just ps) ss <- state- = State Nothing- ((Translate x y $ Scale 0.1 0.1 $ Text "up") : Line (pt:ps) : ss)-- | otherwise- = state---stepWorld :: Float -> State -> State-stepWorld _ = id-
− Easy/Main.hs
@@ -1,3 +0,0 @@--import Graphics.Gloss-main = display (InWindow "My Window" (200, 200) (10, 10)) white (Circle 80)
− Eden/Cell.hs
@@ -1,38 +0,0 @@-module Cell where--import Graphics.Gloss--data Cell - = Cell Point -- centre- Float -- radius- Int - deriving Show---- Produce a new cell of a certain relative radius at a certain angle.--- The factor argument is in the range [0..1] so spawned cells are--- smaller than their parent.--- The check whether it fits in the community is elsewhere.-offspring :: Cell -> Float -> Float -> Cell-offspring (Cell (x,y) r gen) alpha factor - = Cell (x + (childR+r) * cos alpha, y + (childR+r) * sin alpha) - childR - (gen + 1)-- where childR = factor * r---- Do two cells overlap? --- Used to decide if newly spawned cells can join the community.-overlap :: Cell -> Cell -> Bool-overlap (Cell (x1,y1) r1 _) (Cell (x2,y2) r2 _) - = centreDist < (r1 + r2) * 0.999- where centreDist = sqrt(xdiff*xdiff + ydiff*ydiff)- xdiff = x1 - x2- ydiff = y1 - y2--render :: Cell -> Picture-render (Cell (x,y) r gen) - = let z = fromIntegral gen * 0.1- color = makeColor 0.0 z 0.5 1.0- in Color color- $ Translate x y- $ Circle r
− Eden/Community.hs
@@ -1,55 +0,0 @@-module Community where--import Cell-import Graphics.Gloss--type Community = [Cell]---- does a (newly spawned) cell fit in the community?--- that is, does it overlap with any others?-fits :: Cell -> Community -> Bool-fits cell cells - = not $ any (overlap cell) cells---- For each member of a community, produce one offspring--- The lists of Floats are the (random) parameters that determine size--- and location of each offspring.-spawn :: Community -> [Float] -> [Float] -> [Cell]-spawn = zipWith3 offspring---- Given a collection of cells (one spawned by each member of the--- community) check if it fits, and if so add it to the community.--- That check must include new cells that have been added to the--- community in this process.-survive :: [Cell] -> Community -> Community-survive [] comm = comm-survive (cell:cells) comm- | fits cell comm = survive cells (cell:comm)- | otherwise = survive cells comm---- The next generation of a community-generation :: Community -> [Float] -> [Float] -> Community-generation comm angles scales - = survive (spawn comm angles scales) comm--render :: Community -> Picture-render comm - = Pictures $ map Cell.render comm--initial :: Community-initial = [Cell (0,0) 50 0]----- thread the random lists for testing outside IO()----life :: Community -> [Float] -> [Float] -> (Community, [Float], [Float])-life comm randomAngles randomScales =- (generation comm angles scales, randomAngles', randomScales')- where population = length comm- (angles, randomAngles') = splitAt population randomAngles- (scales, randomScales') = splitAt population randomScales--evolution :: Community -> [Float] -> [Float] -> [Community]-evolution comm randomAngles randomScales = comm1 : comms- where (comm1, ras, rss) = life comm randomAngles randomScales- comms = evolution comm1 ras rss
− Eden/Main.hs
@@ -1,19 +0,0 @@---- Adapted from ANUPlot version by Clem Baker-Finch-module Main where-import World-import Graphics.Gloss-import Graphics.Gloss.Interface.Pure.Simulate-import System.Random---- varying prng sequence-main - = do gen <- getStdGen- simulate (InWindow "Eden" (800, 600) (10, 10))- (greyN 0.1) -- background color- 2 -- number of steps per second- (genesis' gen) -- initial world- render -- function to convert world to a Picture- evolve -- function to step the world one iteration--
− Eden/World.hs
@@ -1,47 +0,0 @@-module World where--import Graphics.Gloss-import Graphics.Gloss.Interface.Pure.Simulate-import System.Random-import Community-import Cell--maxSteps = 30---- The World consists of a Community and a random number generator.--- (The RNG is a model of chaos or hand-of-god.)-data World - = World Community StdGen Int- deriving (Show)---- The initial world-genesis :: World-genesis - = World [Cell (0,0) 30 0] (mkStdGen 1023) 0---- Seeding the prng means every run is identical.--- To get different runs, need to use gen <- getStdGen in main :: IO()--- and pass gen in as an argument. Edit Main.hs accordingly.-genesis' :: StdGen -> World-genesis' gen - = World [Cell (0,0) 30 0] gen 0----- Consume some random numbers to advance the simulation-evolve :: ViewPort -> Float -> World -> World-evolve vp step world@(World comm gen steps) - | steps < maxSteps - = let (genThis, genNext) = split gen- (genA, genS) = split genThis- angles = randomRs (0.0, 2*pi) genA- scales = randomRs (0.7, 0.9) genS- in World (generation comm angles scales) genNext (steps + 1)-- | otherwise- = world---- Converting the world to a picture is just converting the community component-render :: World -> Picture-render (World comm gen steps) - = Color (makeColor 0.3 0.3 0.6 1.0)- $ Community.render comm
− Flake/Main.hs
@@ -1,46 +0,0 @@---- | Snowflake Fractal.--- Based on ANUPlot code by Clem Baker-Finch.----import Graphics.Gloss--main = display (InWindow "Snowflake" (500, 500) (20, 20))- black (picture 3)----- Fix a starting edge length of 360-edge = 360 :: Float----- Move the fractal into the center of the window and colour it nicely-picture :: Int -> Picture-picture degree - = Color aquamarine- $ Translate (-edge/2) (-edge * sqrt 3/6)- $ snowflake degree- ---- The fractal function-side :: Int -> Picture-side 0 = Line [(0, 0), (edge, 0)]-side n - = let newSide = Scale (1/3) (1/3) - $ side (n-1)- in Pictures- [ newSide- , Translate (edge/3) 0 $ Rotate 60 newSide - , Translate (edge/2) (-(edge * sqrt 3)/6) $ Rotate (-60) newSide - , Translate (2 * edge/3) 0 $ newSide ]----- Put 3 together to form the snowflake-snowflake :: Int -> Picture-snowflake n - = let oneSide = side n- in Pictures- [ oneSide - , Translate edge 0 $ Rotate (-120) $ oneSide- , Translate (edge/2) (edge * sqrt 3/2) $ Rotate 120 $ oneSide]---
− GameEvent/Main.hs
@@ -1,14 +0,0 @@--import Graphics.Gloss---- | Display the last event received as text.-main- = play (InWindow "GameEvent" (700, 100) (10, 10))- white- 100- ""- (\str -> Translate (-340) 0 $ Scale 0.1 0.1 $ Text str)- (\event _ -> show event)- (\_ world -> world)- -
− Hello/Main.hs
@@ -1,18 +0,0 @@---- | Display "Hello World" in a window.----import Graphics.Gloss--main - = display - (InWindow- "Hello World" -- window title- (400, 150) -- window size- (10, 10)) -- window position- white -- background color- picture -- picture to display--picture - = Translate (-170) (-20) -- shift the text to the middle of the window- $ Scale 0.5 0.5 -- display it half the original size- $ Text "Hello World" -- text to display
− Lifespan/Cell.hs
@@ -1,36 +0,0 @@-module Cell where--import Graphics.Gloss--data Cell = Cell Point -- centre- Float -- radius- Int -- remaining lifetime- deriving Show---- Produce a new cell of a certain relative radius at a certain angle.--- The factor argument is in the range [0..1] so spawned cells are--- smaller than their parent.--- The check whether it fits in the community is elsewhere.-offspring :: Cell -> Float -> Float -> Int -> Cell-offspring (Cell (x,y) r _) alpha factor lifespan =- Cell (x + (childR+r) * cos alpha, y + (childR+r) * sin alpha)- childR - lifespan- where childR = factor * r---- Do two cells overlap? --- Used to decide if newly spawned cells can join the community.-overlap :: Cell -> Cell -> Bool-overlap (Cell (x1,y1) r1 _) (Cell (x2,y2) r2 _) = centreDist < (r1 + r2) *0.999- where centreDist = sqrt(xdiff*xdiff + ydiff*ydiff)- xdiff = x1 - x2- ydiff = y1 - y2---- thickness of circle is determined by lifespan-render :: Cell -> Picture-render (Cell (x,y) r life) - = Color (makeColor 0.6 z 0.6 1.0)- $ Translate x y- $ ThickCircle (r - thickness / 2) thickness- where z = fromIntegral life * 0.12- thickness = fromIntegral life
− Lifespan/Community.hs
@@ -1,58 +0,0 @@-module Community where--import Cell-import Graphics.Gloss--type Community = [Cell]---- does a (newly spawned) cell fit in the community?--- that is, does it overlap with any others?-fits :: Cell -> Community -> Bool-fits cell cells = not $ any (overlap cell) cells---- For each member of a community, produce one offspring--- The lists of Floats are the (random) parameters that determine size---- and location of each offspring.-spawn :: Community -> [Float] -> [Float] -> [Int] -> [Cell]-spawn = zipWith4 offspring--zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]-zipWith4 f [] _ _ _ = []-zipWith4 f _ [] _ _ = []-zipWith4 f _ _ [] _ = []-zipWith4 f _ _ _ [] = []-zipWith4 f (b:bs) (c:cs) (d:ds) (e:es) =- f b c d e : zipWith4 f bs cs ds es----- Given a collection of cells (one spawned by each member of the--- community) check if it fits, and if so add it to the community.--- That check must include new cells that have been added to the--- community in this process.-survive :: [Cell] -> Community -> Community-survive [] comm = comm-survive (cell:cells) comm- | fits cell comm = survive cells (cell:comm)- | otherwise = survive cells comm--age :: Community -> Community-age [] = []-age (Cell c r 0 : cells) = age cells-age (Cell c r life : cells) = Cell c r (life-1) : age cells----- The next generation of a community-generation :: Community -> [Float] -> [Float] -> Community-generation comm angles scales =- survive (spawn comm angles scales (repeat 5)) (age comm)--render :: Community -> Picture-render comm - = Pictures - $ map Cell.render comm--initial :: Community-initial = [Cell (0,0) 50 5]--
− Lifespan/Main.hs
@@ -1,20 +0,0 @@---- Adapted from ANUPlot version by Clem Baker-Finch-module Main where-import World-import Graphics.Gloss-import Graphics.Gloss.Interface.Pure.Simulate-import System.Random---- varying prng sequence-main - = do gen <- getStdGen- simulate (InWindow "Lifespan" (800, 600) (10, 10))- (greyN 0.1) -- background color- 2 -- number of steps per second- (genesis' gen) -- initial world- render -- function to convert world to a Picture- evolve -- function to step the world one iteration---
− Lifespan/World.hs
@@ -1,44 +0,0 @@-module World where--import Graphics.Gloss-import Graphics.Gloss.Interface.Pure.Simulate-import System.Random-import Community-import Cell--stepsMax = 20---- The World consists of a Community and a random number generator.--- (The RNG is a model of chaos or hand-of-god.)-data World - = World Community StdGen Int- deriving (Show)---- The initial world-genesis :: World-genesis - = World [Cell (0,0) 50 5] (mkStdGen 1023) 0---- Seeding the prng means every run is identical.--- To get different runs, need to use gen <- getStdGen in main :: IO()--- and pass gen in as an argument. Edit Main.hs accordingly.-genesis' :: StdGen -> World-genesis' gen - = World [Cell (0,0) 50 5] gen 0---- Consume some random numbers to advance the simulation-evolve :: ViewPort -> Float -> World -> World-evolve _ _ world@(World comm gen step) - | step > stepsMax = world- | otherwise- = World (generation comm angles scales) genNext (step + 1)- where (genThis, genNext) = split gen- (genA, genS) = split genThis- angles = randomRs (0.0, 2*pi) genA- scales = randomRs (0.7, 0.9) genS---- Converting the world to a picture is just converting the community component-render :: World -> Picture-render (World comm gen _) - = Color (makeColor 0.3 0.3 0.6 1.0)- $ Community.render comm
− Machina/Main.hs
@@ -1,30 +0,0 @@--import Graphics.Gloss--main = animate (InWindow "machina" (800, 600) (10, 10))- black frame--frame time- = Scale 0.8 0.8- $ Rotate (time * 30)- $ mach time 6- -mach t 0 = leaf-mach t d- = Pictures- [ leaf- , Translate 0 (-100) - $ Scale 0.8 0.8 - $ Rotate (90 + t * 30) - $ mach (t * 1.5) (d - 1)-- , Translate 0 100 - $ Scale 0.8 0.8 - $ Rotate (90 - t * 30) - $ mach (t * 1.5) (d - 1) ]- -leaf = Pictures- [ Color (makeColor 1.0 1.0 1.0 0.5) $ Polygon loop- , Color (makeColor 0.0 0.0 1.0 0.8) $ Line loop ]--loop = [(-10, -100), (-10, 100), (10, 100), (10, -100), (-10, -100)]
− Occlusion/Cell.hs
@@ -1,47 +0,0 @@--module Cell- ( Cell (..)- , readCell - , pictureOfCell- , cellShape)-where-import Data.Char-import Graphics.Gloss---- | A terrain cell in the world.-data Cell- = CellEmpty- | CellWall- deriving (Show, Eq)----- | Read a cell from a character.-readCell :: Char -> Cell-readCell c- = case c of- '.' -> CellEmpty- '#' -> CellWall- _ -> error $ "readCell: no match for char " ++ show (ord c) ++ " " ++ show c----- | The basic shape of a cell.-cellShape :: Int -> Int -> Int -> Picture-cellShape cellSize posXi posYi- = let cs = fromIntegral cellSize- posX = fromIntegral posXi- posY = fromIntegral posYi- x1 = posX- x2 = posX + 1- y1 = posY - y2 = posY + 1- in Polygon [(x1, y1), (x1, y2), (x2, y2), (x2, y1)]- ---- | Convert a cell to a picture, based on a primitive shape.--- We pass the shape in to avoid recomputing it for each cell.-pictureOfCell :: Int -> Int -> Int -> Cell -> Picture-pictureOfCell cellSize posX posY cell- = case cell of- CellEmpty -> Color (greyN 0.2) (cellShape cellSize posX posY)- CellWall -> Color white (cellShape cellSize posX posY)-
− Occlusion/Data.hs
@@ -1,40 +0,0 @@--module Data where--worldData- = unlines- [ "WORLD"- , "32 32"- , " 01234567890123456789012345678901"- , "0#..............................#"- , "1.....................#####......"- , "2....#.#.#.#..#.#.#.............."- , "3....#######...#.#....#.#.#......"- , "4....#######..#.#.#.............."- , "5....#######...#.#...###.###....."- , "6................................"- , "7......#.#.............#.#......."- , "8......#.#.............#.#......."- , "9......#.#.............#.#......."- , "0......#.#####.........#.#......."- , "1......#.....#.........#.#......."- , "2......#.###.#.........#.#......."- , "3......#.#.#.###########.#######."- , "4......#.#.#...................#."- , "5......#.#.#####################."- , "6......#.#......................."- , "7......#.#...########............"- , "8......#.#...#......#............"- , "9......#.#...########............"- , "0......#.#................####..."- , "1......#.#.........#####..#..#..."- , "2......#.###########...####..#..."- , "3......#.....................#..."- , "4..#####.###########...####..#..."- , "5..#.....#.........#####..#..#..."- , "6..#.#####.....#..........####..."- , "7..#.#.........#................."- , "8..#.#......#######.............."- , "9..#.#.........#................."- , "0..............#................."- , "1#..............................#" ]
− Occlusion/Main.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE PatternGuards #-}--import World-import Data-import State-import Cell-import Graphics.Gloss.Interface.Pure.Game-import Graphics.Gloss.Data.QuadTree-import Graphics.Gloss.Data.Extent-import System.Environment-import Data.Maybe-import Data.List-import Data.Function--main - = do args <- getArgs- case args of- [fileName] - -> do world <- loadWorld fileName- mainWithWorld world- - _ -> do- let world = readWorld worldData- mainWithWorld world- - -mainWithWorld world- = play (InWindow "Occlusion"- (windowSizeOfWorld world) (10, 10))- black - 10- (initState world)- drawState- (handleInput world)- (\_ -> id)- - --- | Convert the state to a picture.-drawState :: State -> Picture-drawState state- = let world = stateWorld state-- -- The ray cast by the user.- p1 = stateLineStart state- p2 = stateLineEnd state- picRay = drawRay world p1 p2-- -- The cell hit by the ray (if any)- mHitCell = castSegIntoWorld world p1 p2- hitCells = maybeToList mHitCell- picCellsHit = Pictures $ map (drawHitCell world) hitCells-- -- All the cells in the world.- cellsAll = flattenQuadTree (worldExtent world) (worldTree world)- picCellsAll = Pictures $ map (uncurry (drawCell False world)) cellsAll-- -- The cells visible from the designated point.- cellsVisible - = [ (coord, cell)- | (coord, cell) <- flattenQuadTree (worldExtent world) (worldTree world)- , cellAtCoordIsVisibleFromPoint world p1 coord ]-- picCellsVisible = Pictures $ map (uncurry (drawCell True world)) cellsVisible-- -- How big to draw the cells.- scale = fromIntegral $ worldCellSize world-- (windowSizeX, windowSizeY) - = windowSizeOfWorld- $ stateWorld state- - -- Shift the cells so they are centered in the window.- offsetX = - (fromIntegral $ windowSizeX `div` 2)- offsetY = - (fromIntegral $ windowSizeY `div` 2)-- in Translate offsetX offsetY- $ Scale scale scale- $ Pictures [ picCellsAll, picCellsVisible, picCellsHit, picRay ]----- | Draw the cell hit by the ray defined by the user.-drawHitCell :: World -> (Point, Extent, Cell) -> Picture-drawHitCell world (pos@(px, py), extent, cell)- = let (n, s, e, w) = takeExtent extent- x = w- y = s-- posX = fromIntegral x - posY = fromIntegral y- - in Pictures [ Color blue $ cellShape 1 posX posY ]----- | Draw the ray defined by the user.-drawRay :: World -> Point -> Point -> Picture -drawRay world p1@(x, y) p2- = Pictures- [ Color red $ Line [p1, p2]- , Color cyan - $ Translate x y - $ Pictures - [ Line [(-0.3, -0.3), (0.3, 0.3)]- , Line [(-0.3, 0.3), (0.3, -0.3)] ] ]----- | Draw a cell in the world.-drawCell :: Bool -> World -> Coord -> Cell -> Picture-drawCell visible world (x, y) cell - = let cs = fromIntegral (worldCellSize world)- cp = fromIntegral (worldCellSpace world)-- posX = fromIntegral x - posY = fromIntegral y-- in if visible- then pictureOfCell (worldCellSize world) posX posY cell- else Color (greyN 0.4) (cellShape cs posX posY)-
− Occlusion/State.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE PatternGuards #-}--module State where-import World-import Graphics.Gloss.Interface.Pure.Game---- | The game state.-data State- = State- { stateWorld :: World- , stateLineStart :: Point- , stateLineEnd :: Point }----- | Initial game state.-initState world- = State- { stateWorld = world- , stateLineStart = (10, 10)- , stateLineEnd = (10, 10) }- ---- | Handle an input event.-handleInput :: World -> Event -> State -> State-handleInput world (EventKey key keyState mods pos) state- | MouseButton LeftButton <- key- , Down <- keyState- , shift mods == Down - = state { stateLineEnd = worldPosOfWindowPos world pos }-- | MouseButton LeftButton <- key- , Down <- keyState- = state { stateLineStart = worldPosOfWindowPos world pos - , stateLineEnd = worldPosOfWindowPos world pos }-- | MouseButton RightButton <- key- , Down <- keyState- = state { stateLineEnd = worldPosOfWindowPos world pos }--handleInput _ _ state- = state-
− Occlusion/World.hs
@@ -1,156 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module World where-import Cell-import Graphics.Gloss.Interface.Pure.Game-import Graphics.Gloss.Data.Extent-import Graphics.Gloss.Data.QuadTree-import Graphics.Gloss.Algorithms.RayCast-import System.IO-import Control.Monad----- | The game world.-data World - = World- { worldWidth :: Int- , worldHeight :: Int- , worldTree :: QuadTree Cell- , worldCellSize :: Int- , worldCellSpace :: Int }- deriving Show----- | Get the extent covering the entire world.-worldExtent :: World -> Extent-worldExtent world- = makeExtent (worldWidth world) 0 (worldHeight world) 0----- | Load a world from a file. -loadWorld :: FilePath -> IO World-loadWorld fileName- = do str <- readFile fileName- return $ readWorld str- - --- | Read a world from a string.-readWorld :: String -> World-readWorld str- = let ("WORLD" : strWidthHeight : skip : cellLines) - = lines str- - [width, height] = map read $ words strWidthHeight- rows = take height $ cellLines-- cells = concat - $ map (readLine width) - $ reverse rows-- extent = makeExtent height 0 width 0-- in World { worldWidth = width- , worldHeight = height- , worldTree = makeWorldTree extent cells- , worldCellSize = 20- , worldCellSpace = 0 }--readLine :: Int -> String -> [Cell]-readLine width (s:str)- = map readCell- $ take width str------ | Get the size of the window needed to display a world.-windowSizeOfWorld :: World -> (Int, Int)-windowSizeOfWorld world- = let cellSize = worldCellSize world- cellSpace = worldCellSpace world- cellPad = cellSize + cellSpace- height = cellPad * (worldHeight world) + cellSpace- width = cellPad * (worldWidth world) + cellSpace- in (width, height)----- | Create the tree representing the world from a list of all its cells.-makeWorldTree :: Extent -> [Cell] -> QuadTree Cell-makeWorldTree extent cells- = foldr insert' emptyTree nonEmptyPosCells- where - insert' (pos, cell) tree- = case insertByCoord extent pos cell tree of- Nothing -> tree- Just tree' -> tree'- - (width, height) - = sizeOfExtent extent- - posCells - = zip [(x, y) | y <- [0 .. height - 1]- , x <- [0 .. width - 1]]- cells- - nonEmptyPosCells - = filter (\x -> snd x /= CellEmpty) posCells----- | Get the world position coresponding to a point in the window.-worldPosOfWindowPos :: World -> Point -> Point-worldPosOfWindowPos world (x, y)- = let (windowSizeX, windowSizeY)- = windowSizeOfWorld world- - offsetX = fromIntegral $ windowSizeX `div` 2- offsetY = fromIntegral $ windowSizeY `div` 2- - scale = fromIntegral $ worldCellSize world- - x' = (x + offsetX) / scale- y' = (y + offsetY) / scale-- in (x', y')----- | Check if a the cell at a given coordinate is visible from a point.-cellAtCoordIsVisibleFromCoord :: World -> Coord -> Coord -> Bool-cellAtCoordIsVisibleFromCoord world cFrom cTo- = let (cx, cy) = cFrom- pFrom = (fromIntegral cx + 0.5 , fromIntegral cy + 0.5)- in cellAtCoordIsVisibleFromPoint world pFrom cTo----- | Check if a cell at a given coordinate is visible from a point.--- We say it's visible if the center of any of its faces is visible.-cellAtCoordIsVisibleFromPoint :: World -> Point -> Coord -> Bool-cellAtCoordIsVisibleFromPoint world pFrom (x', y')- = or $ map (cellAtPointIsVisibleFromPoint world pFrom) [pa, pb, pc, pd]- where x :: Float = fromIntegral x' + 0.5- y :: Float = fromIntegral y' + 0.5- pa = (x - 0.4999, y)- pb = (x + 0.4999, y)- pc = (x, y - 0.4999)- pd = (x, y + 0.4999)- - --- | Check if a point on some cell (P2) is visible from some other point (P1).-cellAtPointIsVisibleFromPoint :: World -> Point -> Point -> Bool-cellAtPointIsVisibleFromPoint world p1 p2- = let mOccluder = castSegIntoWorld world p1 p2- in case mOccluder of- Nothing -> False- Just (pos, extent, cell) -> pointInExtent extent p2----- | Given a line segment (P1-P2) get the cell closest to P1 that intersects the segment.-castSegIntoWorld :: World -> Point -> Point -> Maybe (Point, Extent, Cell)-castSegIntoWorld world p1 p2- = castSegIntoCellularQuadTree p1 p2 (worldExtent world) (worldTree world)----- | Given a line segment (P1-P2) get the cell closest to P1 that intersects the segment.-traceSegIntoWorld :: World -> Point -> Point -> [(Point, Extent, Cell)]-traceSegIntoWorld world p1 p2- = traceSegIntoCellularQuadTree p1 p2 (worldExtent world) (worldTree world)--
− Styrene/Actor.hs
@@ -1,73 +0,0 @@--module Actor where---- | 2D position on the screen.-type Position = (Float, Float)---- | Force and velocity vectors.-type Force = (Float, Float)-type Velocity = (Float, Float)---- | Time in seconds-type Time = Float---- | Radius of a bead-type Radius = Float---- | Each actor has its own unique index.-type Index = Int---- | The actors in the world.-data Actor- = Wall !Index -- ^ unique index of this actor- !Position -- ^ wall starting point- !Position -- ^ wall ending point-- | Bead !Index -- ^ unique index of this actor - !Int -- ^ whether the bead is stuck- !Radius -- ^ radius of bead- !Position -- ^ position of bead- !Velocity -- ^ velocity of bead-- deriving Show---- | Equality and ordering of actors will consider their index only.--- We need Ord so we can put them in Maps and Sets.-instance Eq Actor where- a1 == a2 = actorIx a1 == actorIx a2- -instance Ord Actor where- compare a1 a2 = compare (actorIx a1) (actorIx a2)---- | Check whether an actor is a bead.-isBead :: Actor -> Bool-isBead (Bead _ _ _ _ _) = True-isBead _ = False----- | Check whether an actor is a wall.-isWall :: Actor -> Bool-isWall (Wall _ _ _) = True-isWall _ = False----- | Take the index of an actor-actorIx :: Actor -> Index-actorIx actor- = case actor of- Wall ix _ _ -> ix- Bead ix _ _ _ _ -> ix----- | Set the index of an actor-actorSetIndex :: Actor -> Index -> Actor-actorSetIndex actor ix- = case actor of- Bead _ m r pos vel -> Bead ix m r pos vel - Wall _ p1 p2 -> Wall ix p1 p2----- | Set whether a bead is stuck-actorSetMode :: Int -> Actor -> Actor-actorSetMode m (Bead ix _ r p v)- = Bead ix m r p v
− Styrene/Advance.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE PatternGuards #-}---- | Advance the world to the next time step.-module Advance where-import World-import Contact-import QuadTree-import Collide-import Actor-import Config--import Graphics.Gloss.Geometry-import Graphics.Gloss.Interface.Pure.Simulate-import Graphics.Gloss.Data.Point-import Graphics.Gloss.Data.Vector--import Data.List-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Set (Set)-import Data.Map (Map)----- Advance ----------------------------------------------------------------------------------------------- | Advance all the actors in this world by a certain time.-advanceWorld - :: ViewPort -- ^ current viewport- -> Time -- ^ time to advance them for.- -> World -- ^ the world to advance.- -> World -- ^ the new world.--advanceWorld viewport time (World actors tree)- = let - rot = viewPortRotate viewport- force = rotateV (degToRad $ negate rot) (0, negate gravityCoeff)-- -- move all the actors - actors_moved = Map.map (moveActor_free time force) actors- - -- find contacts in the world- (contacts, tree') - = findContacts (World actors_moved tree)-- -- apply contacts to each pair of actors- actors_bounced - = Set.fold - (applyContact time force) - actors_moved- contacts-- in World actors_bounced tree'----- Move two actors which are known to be in contact.-applyContact - :: Time -- ^ time step- -> Force -- ^ ambient force on the actors- -> (Index, Index) -- ^ indicies of the the two actors in contact- -> Map Index Actor -- ^ the old world- -> Map Index Actor -- ^ the new world--applyContact time force (ix1, ix2) actors- = let -- use the indicies to lookup the data for each actor from the map- Just a1 = Map.lookup ix1 actors- Just a2 = Map.lookup ix2 actors- - resultActors- -- handle a collision between bead and a wall- | Bead _ _ r1 p1 v1 <- a1- , Wall{} <- a2- = let a1' = collideBeadWall a1 a2- in Map.insert ix1 a1' actors- - -- handle a collision between two beads- | Bead ix1 m1 r1 p1 v1 <- a1- , Bead ix2 m2 r2 p2 v2 <- a2- = let - (a1', a2')- -- if one of the beads is stuck then do a safer, static collision.- -- with this method the beads don't transfer energy into each other- -- so there is less of a chance of lots of beads being crushed together- -- if there are many in the same place.- | m1 >= beadStuckCount || m2 >= beadStuckCount- = let a1' = collideBeadBead_static a1 a2- a2' = collideBeadBead_static a2 a1- in (a1', a2')-- -- otherwise do the real elastic collision- -- this is much more realistic.- | otherwise- = collideBeadBead_elastic a1 a2-- -- write the new data for the actors back into the map- in Map.insert ix1 a1'- $ Map.insert ix2 a2' actors- - in resultActors - ---- | Move a bead which isn't in contact with anything else.-moveActor_free - :: Time -- ^ time to move it for- -> Force -- ^ ambient force on the actor during this time- -> Actor -- ^ the bead to move- -> Actor -- ^ the new bead--moveActor_free time force actor- -- move a bead- | Bead ix stuck radius pos vel <- actor- = let -- assume all beads have the same mass.- beadMass = 1- - -- calculate the new position and velocity of the bead.- pos' = (pos + time `mulSV` vel)- vel' = (vel + (time / beadMass) `mulSV` force)-- -- if the bead is travelling slowly then set it as being stuck.- stuck' - | magV vel' < 20- = min beadStuckCount (stuck + 1)-- | otherwise - = max 0 (stuck - 2)-- in Bead ix stuck' radius pos' vel'-- -- walls don't move- | Wall{} <- actor- = actor
− Styrene/Collide.hs
@@ -1,167 +0,0 @@--- | Physics for bead bouncing.-module Collide where-import World-import Actor-import Graphics.Gloss.Data.Point-import Graphics.Gloss.Data.Vector-import Graphics.Gloss.Geometry---- Config -------------------------------------------------------------------------------------------- How bouncy the beads are--- at 0.2 and they look like melting plastic.--- at 0.8 and they look like bouncy rubber balls.--- at > 1 and they gain energy with each bounce and escape the box.----beadBeadLoss = 0.95-beadWallLoss = 0.8----- | Move a bead which is in contact with a wall.-collideBeadWall- :: Actor -- ^ the bead - -> Actor -- ^ the wall that bead is in contact with- -> Actor -- ^ the new bead--collideBeadWall- bead@(Bead ix _ radius pBead vIn@(velX, velY))- wall@(Wall _ pWall1 pWall2)-- = let -- Take the collision point as being the point on the wall which is - -- closest to the bead's center.- pCollision = closestPointOnLine pWall1 pWall2 pBead- - -- then do a static, non energy transfering collision.- in collideBeadPoint_static - bead - pCollision- beadWallLoss----- | Move two beads which have bounced into each other.-collideBeadBead_elastic- :: Actor -> Actor- -> (Actor, Actor)--collideBeadBead_elastic- bead1@(Bead ix1 mode1 r1 p1 v1) - bead2@(Bead ix2 mode2 r2 p2 v2)-- = let mass1 = 1- mass2 = 1-- -- the axis of collision (towards p2)- vCollision@(cX, cY) = normaliseV (p2 - p1)- vCollisionR = (cY, -cX)- - -- the velocity component of each bead along the axis of collision- s1 = dotV v1 vCollision- s2 = dotV v2 vCollision-- -- work out new velocities along the collision- s1' = (s1 * (mass1 - mass2) + 2 * mass2 * s2) / (mass1 + mass2)- s2' = (s2 * (mass2 - mass1) + 2 * mass1 * s1) / (mass1 + mass2)- - -- the velocity components at right angles to the collision- -- there is no friction in the collision so these don't change- k1 = dotV v1 vCollisionR- k2 = dotV v2 vCollisionR- - -- new bead velocities- v1' = mulSV s1' vCollision + mulSV k1 vCollisionR- v2' = mulSV s2' vCollision + mulSV k2 vCollisionR-- v1_slow = mulSV beadBeadLoss v1'- v2_slow = mulSV beadBeadLoss v2'-- -- work out the point of collision- u1 = r1 / (r1 + r2)- u2 = r2 / (r1 + r2)-- pCollision - = p1 + mulSV u1 (p2 - p1)-- -- place the beads just next to each other so they are no longer overlapping.- p1' = pCollision - (r1 + 0.001) `mulSV` vCollision- p2' = pCollision + (r2 + 0.001) `mulSV` vCollision-- bead1' = Bead ix1 mode1 r1 p1' v1_slow- bead2' = Bead ix2 mode2 r2 p2' v2_slow-- in (bead1', bead2')---collideBeadBead_static- :: Actor -> Actor - -> Actor- -collideBeadBead_static- bead1@(Bead ix1 _ radius1 pBead1 _)- bead2@(Bead ix2 _ radius2 pBead2 _)-- = let -- Take the collision point as being between the center's of the two beads. - -- For beads which have the same radius the collision point is half way between- -- their centers and u == 0.5- u = radius1 / (radius1 + radius2)- pCollision = pBead1 + mulSV u (pBead2 - pBead1)- - bead1' = collideBeadPoint_static- bead1- pCollision- beadBeadLoss- in bead1'----- | Move a bead which has collided with something.-collideBeadPoint_static- :: Actor -- ^ the bead which collided with something- -> Point -- ^ the point of collision (should be near the bead's surface)- -> Float -- ^ velocity scaling factor (how much to slow the bead down after the collision)- -> Actor--collideBeadPoint_static- bead@(Bead ix mode radius pBead vIn) - pCollision- velLoss- = let- -- take a normal vector from the wall to the bead.- -- this vector is at a right angle to the wall.- vNormal = normaliseV (pBead - pCollision)- - -- the bead at pBead is overlapping with what it collided with, but we don't want that.- -- place the bead so it's surface is just next to the point of collision.- pBead_new = pCollision + (radius + 0.01) `mulSV` vNormal-- -- work out the angle of incidence for the bounce.- -- this is the angle between the surface normal and- -- the direction of travel for the bead.- aInc = angleVV vNormal (negate vIn)-- -- aInc2 is the angle between the wall /surface/ and- -- the direction of travel.- aInc2 = (pi / 2) - aInc-- -- take the determinant between the surface normal and the direction of travel.- -- This will tell us what direction the bead hit the wall. - -- The diagram shows the sign of the determinant for the four possiblities.- --- -- \ +ve -ve /- -- \ /- -- \/ \/- -- pWall1 ---------- pWall2 pWall1 ---------- pWall2- -- /\ /\- -- / \- -- / -ve +ve \- --- determinant = detV vIn vNormal-- -- Use the determinant to rotate the bead's velocity vector for the bounce.- vOut - | determinant > 0 = rotateV (2 * aInc2) vIn- | otherwise = rotateV (negate (2 * aInc2)) vIn-- -- Slow down the bead when it hits the wall- vSlow = velLoss `mulSV` vOut-- bead1_new = Bead ix mode radius pBead_new vSlow-- in bead1_new
− Styrene/Config.hs
@@ -1,46 +0,0 @@--module Config where-import Graphics.Gloss---- Number of simulation steps per second of time.-simResolution :: Int-simResolution = 300---- How strongly the beads are pulled down to the bottom of the screen.--- If this is too high wrt the simResoution then the simulation--- will be unstable and beads will escape the box.-gravityCoeff :: Float-gravityCoeff = 300---- Whether to draw velocity vectors on beads.-showBeadVelocity = False---- Colors of things.-beadColor = makeColor 0.5 0.5 1.0 1.0-beadOutlineColor = makeColor 1.0 1.0 1.0 1.0-nodeColor = makeColor 0.2 0.8 0.2 0.1-leafColor = makeColor 0.8 0.2 0.2 0.1---- The maximum depth of the quad tree.-treeMaxDepth :: Int-treeMaxDepth = 4---- Size of quadtree. Should be > boxSize.-treeSize :: Float-treeSize = 300---- Size of bead box.-boxSize :: Float-boxSize = 280---- Bead setup.-beadRadius, beadSpace, beadCountX, beadCountY, beadBoxSize :: Float--beadRadius = 5-beadSpace = 1-beadBoxSize = 2 * beadRadius + beadSpace-beadCountX = 20-beadCountY = 10--beadStuckCount :: Int-beadStuckCount = 20
− Styrene/Contact.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE MagicHash, BangPatterns #-}---- | Find actors in the world that are in contact with each other.-module Contact where-import World-import QuadTree-import Actor-import Graphics.Gloss.Data.Point-import Graphics.Gloss.Geometry.Line-import Data.Maybe-import Data.List-import GHC.Exts-import GHC.Prim-import Data.Map (Map)-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Map as Map----- Find all pairs of actors in the world that are in contact with each other.-findContacts - :: World - -> ( Set (Index, Index) -- ^ a set of all pairs of actors that are in contact.- , QuadTree Actor) -- ^ also return the quadtree so we can draw it in the window.- -findContacts (World actors _)- = let - -- the initial tree has no actors in it and has a- -- size of 300 (with is half the width of the box).- treeInit = treeZero 300-- -- insert all the actors into the quadtree.- tree' = Map.fold insertActor treeInit actors-- -- the potential contacts are lists of actors- -- that _might_ be in contact.- potentialContacts- = treeElems tree'-- -- filter the lists of potential contacts to determine the actors- -- which are _actually_ in contact.- contactSet = makeContacts potentialContacts- - in (contactSet, tree')- ---- | Make add all these test pairs to a map--- normalise so the actor with the lowest ix is first in the pair.--makeContacts :: [[Actor]] -> Set (Index, Index)-makeContacts contactLists- = makeContacts' Set.empty contactLists --makeContacts' acc xx- = case xx of- -- no more potentials to add, return the current contact set- [] -> acc-- -- add pairs of actors that are actually in contact to the contact set- (list : lists)- -> makeContacts' (makeTests acc list) lists- -makeTests acc [] = acc-makeTests acc (x:xs)- = makeTests (makeTests1 acc x xs) xs- -makeTests1 acc a1 [] = acc-makeTests1 acc a1 (a2 : as)- | inContact a1 a2- = let k1 = actorIx a1- k2 = actorIx a2- contact = (min k1 k2, max k1 k2)- acc' = Set.insert contact acc- in makeTests1 acc' a1 as- - | otherwise- = makeTests1 acc a1 as- ---- See if these two actors are in contact-inContact :: Actor -> Actor -> Bool-inContact a1 a2- | isBead a1 && isWall a2 = inContact_beadWall a1 a2- | isWall a1 && isBead a2 = inContact_beadWall a2 a1- | isBead a1 && isBead a2 = inContact_beadBead a1 a2- | otherwise = False----- | Check whether a bead is in contact with a wall.-inContact_beadWall :: Actor -> Actor -> Bool-inContact_beadWall - bead@(Bead ix mode radius pBead _) - wall@(Wall _ pWall1 pWall2)-- = let -- work out the point on the infinite line between pWall1 and pWall2- -- which is closest to the bead.- pClosest = closestPointOnLine pWall1 pWall2 pBead-- -- the distance between the bead center and pClosest - -- needs to be less than the bead radius for them to touch.- !(F# radius#) = radius- closeEnough = distancePP_contact pBead pClosest `ltFloat#` radius#-- -- uParam gives where pClosest is relative to the endponts of the wall- uParam = closestPointOnLineParam pWall1 pWall2 pBead-- -- pClosest needs to lie on the line segment between pWal1 and pWall2- inSegment = uParam >= 0 && uParam <= 1-- in closeEnough && inSegment----- | Check whether a bead is in concat with another bead.-inContact_beadBead :: Actor -> Actor -> Bool-inContact_beadBead - bead1@(Bead ix1 _ radius1 pBead1 _) - bead2@(Bead ix2 _ radius2 pBead2 _)- =let !dist# = distancePP_contact pBead1 pBead2- !(F# rad) = radius1 + radius2- in (dist# `ltFloat#` rad ) && (dist# `gtFloat#` 0.1#)----- | Return the distance between these two points.-{-# INLINE distancePP_contact #-}-distancePP_contact :: Point -> Point -> Float#-distancePP_contact (F# x1, F# y1) (F# x2, F# y2)- = sqrtFloat# (xd2 `plusFloat#` yd2)- where !xd = x2 `minusFloat#` x1- !xd2 = xd `timesFloat#` xd-- !yd = y2 `minusFloat#` y1- !yd2 = yd `timesFloat#` yd
− Styrene/Main.hs
@@ -1,117 +0,0 @@--import Actor-import Advance-import QuadTree-import Contact-import Collide-import World-import Config--import Graphics.Gloss-import Graphics.Gloss.Geometry-import Graphics.Gloss.Interface.Pure.Simulate-import Graphics.Gloss.Data.Vector--import qualified Data.Map as Map-import Data.Map (Map)--main - = simulate - (InWindow "Polystyrene - right-click-drag rotates"- (600, 600) -- x and y size of window (in pixels).- (10, 10)) -- position of window- black -- background color- simResolution -- simulation resolution - -- (number of steps to take for each second of time)- worldInit -- the initial world.- drawWorld -- a function to convert the world to a Picture.- advanceWorld -- a function to advance the world to- -- the next simulation step.---- Draw ------------------------------------------------------------------------------------------------ | Draw this world as a picture.-drawWorld :: World -> Picture-drawWorld (World actors tree)- = let - -- split the list of actors into beads and walls.- -- this lets us draw all the beads at once without having to keep changing - -- the current color (which is a bit of a performance improvement)- (beads, walls) = splitActors $ Map.elems actors- - picBeads = Color beadColor $ Pictures $ map drawActor beads- picWalls = Pictures $ map drawActor walls- picTree = drawQuadTree tree-- in Scale 0.8 0.8- $ Pictures [picTree, picWalls, picBeads]----- | Split actors into beads and walls-splitActors :: [Actor] -> ([Actor], [Actor])-splitActors as- = splitActors' [] [] as--splitActors' accBeads accWalls [] - = (accBeads, accWalls)--splitActors' accBeads accWalls (a : as) - = case a of- Bead{} -> splitActors' (a : accBeads) accWalls as- Wall{} -> splitActors' accBeads (a : accWalls) as----- | Draw an actor as a picture.-drawActor :: Actor -> Picture -drawActor actor - = case actor of- Bead ix mode radius p@(posX, posY) v@(velX, velY)- -> Translate posX posY $ Pictures [bead, vel]- where bead = circleFilled radius 10- vel = if showBeadVelocity- then Color red $ Line [(0, 0), mulSV 0.1 v]- else Blank-{- color- | mode >= beadStuckCount = red- | otherwise = beadColor--} - Wall _ p1 p2- -> Color (greyN 0.8) $ Line [p1, p2]----- | Draw a quadtree as a picture-drawQuadTree :: QuadTree a -> Picture-drawQuadTree tree - = case tree of- QNode p size tTL tTR tBL tBR- -> Pictures- [ drawQuadTree tTL - , drawQuadTree tTR- , drawQuadTree tBL- , drawQuadTree tBR- , nodeBox p size nodeColor ]-- QLeaf p size elems- -> nodeBox p size leafColor- - QNil (x0, y0) size- -> Blank--nodeBox p@(x0, y0) size color- = Color color- $ Translate x0 y0- $ rectangleWire (size*2) (size*2)----- Make a circle of radius r consisting of n lines.-circleFilled :: Float -> Float -> Picture-circleFilled r n- = Scale r r- $ Polygon (circlePoints n)- - --- A list of n points spaced equally around the unit circle.-circlePoints :: Float -> [(Float, Float)]-circlePoints n- = map (\d -> (cos d, sin d))- [0, 2*pi / n .. 2*pi]
− Styrene/QuadTree.hs
@@ -1,90 +0,0 @@--module QuadTree - ( QuadTree(..)- , treeZero- , treeInsert- , treeElems )-where-import Graphics.Gloss.Data.Point--data QuadTree a- -- Nil cells take up space in the world, but don't contain any elements.- -- They can be at any depth in the tree.- = QNil !Point -- cell center point - !Float -- cell size-- -- Leaf cells are the only ones that contain elements.- -- They are always at the bottom of the tree.- | QLeaf !Point -- cell center point - !Float -- cell size- ![a] -- elements in this cell-- -- Node cells contain more sub-trees- | QNode !Point -- cell center point- !Float -- cell size- !(QuadTree a) !(QuadTree a) -- NW NE- !(QuadTree a) !(QuadTree a) -- SW SE- - deriving (Eq, Show)----- Initial ------------------------------------------------------------------------------------------treeZero size- = QNil (0, 0) size---- Quadrant -------------------------------------------------------------------------------------------- | Insert an element with a bounding box into the tree-treeInsert - :: Int -- ^ maximum depth to place a leaf- -> Int -- ^ current depth- -> Point -- ^ bottom left of bounding box of new element- -> Point -- ^ top right of bounding box of new element- -> a -- ^ element to insert into tree- -> QuadTree a -- ^ current tree- -> QuadTree a--treeInsert depthMax depth p0@(x0, y0) p1@(x1, y1) a tree- = case tree of- QNode p@(x, y) size tNW tNE tSW tSE- -> let - - tNW' | y1 > y && x0 < x = treeInsert depthMax (depth + 1) p0 p1 a tNW- | otherwise = tNW-- tNE' | y1 > y && x1 > x = treeInsert depthMax (depth + 1) p0 p1 a tNE- | otherwise = tNE-- tSW' | y0 < y && x0 < x = treeInsert depthMax (depth + 1) p0 p1 a tSW- | otherwise = tSW-- tSE' | y0 < y && x1 > x = treeInsert depthMax (depth + 1) p0 p1 a tSE- | otherwise = tSE- - in QNode p size tNW' tNE' tSW' tSE'- - QLeaf p@(x, y) size elems- | depth >= depthMax- -> QLeaf p size (a : elems)- - QNil p@(x, y) size- | depth >= depthMax- -> QLeaf p size [a]- - | otherwise- -> treeInsert depthMax depth p0 p1 a- (let s2 = size / 2- in QNode p size - (QNil (x - s2, y + s2) s2) (QNil (x + s2, y + s2) s2)- (QNil (x - s2, y - s2) s2) (QNil (x + s2, y - s2) s2))----- flatten a quadtree into a list of its elements.-treeElems :: QuadTree a -> [[a]]-treeElems tree - = case tree of- QNode _ _ tNW tNE tSW tSE- -> treeElems tNW ++ treeElems tNE ++ treeElems tSW ++ treeElems tSE- - QLeaf _ _ elems -> [elems]- QNil{} -> []
− Styrene/World.hs
@@ -1,90 +0,0 @@-{-# LANGUAGE PatternGuards #-}---- The world contains a map of all the actors, along with the current--- quadtree so we can also draw it on the screen.-module World where--import QuadTree-import Actor-import Config--import qualified Data.Map as Map-import Data.Map (Map)---- The world ----------------------------------------------------------------------------------------data World - = World (Map Index Actor) -- actors- (QuadTree Actor) -- tree---- | The initial world-worldInit :: World-worldInit - = World actorMapInit treeInit--actorMapInit - = Map.fromList - $ map (\a -> (actorIx a, a))- $ (walls ++ beads)--treeInit = treeZero treeSize----- Walls -------------------walls :: [Actor]-walls = zipWith actorSetIndex (box ++ splitter) [10000 ..]--box :: [Actor]-box- = let bs = boxSize- in [ Wall 0 (- bs, -bs) (bs, -bs) -- bot- , Wall 0 (- bs, bs) (bs, bs) -- top-- , Wall 0 (- bs, -bs) (-bs, bs) -- left- , Wall 0 ( bs, -bs) ( bs, bs)] -- right--splitter :: [Actor]-splitter- = [ Wall 0 (-15, -100) (-200, 0) - , Wall 0 ( 15, -100) ( 200, 0) ]----- Beads -------------------beads :: [Actor]-beads - = let -- beads start off with their index just set to 0- beads_raw- = [Bead 0 0 beadRadius (beadPos ix iy) (0, 0)- | ix <- [0 .. beadCountX - 1]- , iy <- [0 .. beadCountY - 1 ] ]- - -- set the unique index on the beads before returning them- in zipWith actorSetIndex beads_raw [0..]- -beadPos ix iy - = ( (ix * beadBoxSize) - (beadBoxSize * beadCountX / 2)- , (iy * beadBoxSize) )----- QuadTree -------------------------------------------------------------------------------------------- | insert an actor into the tree-insertActor :: Actor -> QuadTree Actor -> QuadTree Actor--insertActor actor tree- -- insert a bead into the tree- | bead@(Bead ix _ radius pos@(x, y) vel) <- actor- = let- -- the bottom left and top right of the bead's bounding box.- p0 = (x - radius, y - radius)- p1 = (x + radius, y + radius)-- in treeInsert treeMaxDepth 0 p0 p1 bead tree-- | wall@(Wall ix (x0, y0) (x1, y1)) <- actor- = let- -- the bottom left and top right of the wall's bounding box.- p0 = (min x0 x1, min y0 y1)- p1 = (max x0 x1, max y0 y1)- - in treeInsert treeMaxDepth 0 p0 p1 wall tree-
− Tree/Main.hs
@@ -1,54 +0,0 @@---- | Tree Fractal.--- Based on ANUPlot code by Clem Baker-Finch.--- -import Graphics.Gloss--main = animate (InWindow "Tree" (500, 650) (20, 20))- black (picture 4)----- The picture is a tree fractal, graded from brown to green-picture :: Int -> Float -> Picture -picture degree time- = Translate 0 (-300)- $ tree degree time (dim $ dim brown)----- Basic stump shape-stump :: Color -> Picture-stump color - = Color color- $ Polygon [(30,0), (15,300), (-15,300), (-30,0)]----- Make a tree fractal.-tree :: Int -- Fractal degree- -> Float -- time- -> Color -- Color for the stump- -> Picture--tree 0 time color = stump color-tree n time color - = let smallTree - = Rotate (sin time)- $ Scale 0.5 0.5 - $ tree (n-1) (- time) (greener color)- in Pictures- [ stump color- , Translate 0 300 $ smallTree- , Translate 0 240 $ Rotate 20 smallTree- , Translate 0 180 $ Rotate (-20) smallTree- , Translate 0 120 $ Rotate 40 smallTree- , Translate 0 60 $ Rotate (-40) smallTree ]- ---- A starting colour for the stump-brown :: Color-brown = makeColor8 139 100 35 255----- Make this color a little greener-greener :: Color -> Color-greener c = mixColors 1 10 green c-
− Visibility/Draw.hs
@@ -1,120 +0,0 @@-{-# LANGUAGE PatternGuards #-}-module Draw- ( drawState- , drawWorld)-where-import State-import World-import Geometry.Segment-import Graphics.Gloss-import Graphics.Gloss.Geometry.Line-import qualified Data.Vector.Unboxed as V-import Data.Maybe---drawState :: State -> Picture-drawState state- | ModeDisplayWorld <- stateModeDisplay state- = drawWorldWithViewPos - (stateModeOverlay state)- (stateViewPos state) - (stateTargetPos state)- (stateWorld state)-- | ModeDisplayNormalised <- stateModeDisplay state- = drawWorldWithViewPos - (stateModeOverlay state)- (0, 0) - Nothing- $ normaliseWorld (stateViewPos state)- $ stateWorld state-- | otherwise- = Blank- --drawWorldWithViewPos :: ModeOverlay -> Point -> Maybe Point -> World -> Picture-drawWorldWithViewPos - modeOverlay- pView@(vx, vy) - mTarget- world- = let - -- the world - picWorld = Color white- $ drawWorld world-- -- view position indicator- picView = Color red- $ Translate vx vy- $ ThickCircle 2 4-- -- target position indicator- picTargets- | Just pTarget@(px, py) <- mTarget- = let picTarget = Translate px py $ ThickCircle 2 4-- -- line between view and target pos- picLine = Line [pView, pTarget]- - picSegsHit = Pictures- $ [ Line [p1, p2]- | (_, p1, p2) <- V.toList $ worldSegments world- , isJust $ intersectSegSeg p1 p2 pView pTarget ]- in Color red $ Pictures [picTarget, picLine, picSegsHit]-- | otherwise- = blank-- -- overlay- picOverlay- | ModeOverlayVisApprox <- modeOverlay- = drawVisGrid 10 pView world-- | otherwise- = blank-- in Pictures [picOverlay, picWorld, picView, picTargets]----- | Draw a grid of points showing what is visible from a view position-drawVisGrid :: Float -> Point -> World -> Picture-drawVisGrid cellSize pView world- = let - visible pTarget = not $ any isJust- $ map (\(_, p1, p2) -> intersectSegSeg pView pTarget p1 p2)- $ V.toList - $ worldSegments world- - picGrid = Pictures- $ [ if visible (x, y) - then Color (dim green) $ Translate x y $ rectangleSolid cellSize cellSize- else Color (greyN 0.2) $ Translate x y $ rectangleSolid cellSize cellSize- | x <- [-400, -400 + cellSize .. 400]- , y <- [-400, -400 + cellSize .. 400] ]-- in picGrid----- | Draw the segments in the world.-drawWorld :: World -> Picture-drawWorld world- = drawSegments- $ worldSegments world----- | Draw an array of segments.-drawSegments :: V.Vector Segment -> Picture-drawSegments segments- = Pictures- $ map drawSegment- $ V.toList - $ segments----- | Draw a single segment.-drawSegment :: Segment -> Picture-drawSegment (_, (x1, y1), (x2, y2))- = Line [(f x1, f y1), (f x2, f y2)]- where f = fromRational . toRational-
− Visibility/Geometry/Randomish.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Geometry.Randomish- ( randomishPoints - , randomishInts- , randomishDoubles)-where-import Data.Word-import qualified Data.Vector.Generic as G-import qualified Data.Vector.Unboxed.Mutable as MV-import qualified Data.Vector.Unboxed as V---- | Some uniformly distributed points-randomishPoints- :: Int -- ^ seed- -> Int -- ^ number of points- -> Float -- ^ minimum coordinate- -> Float -- ^ maximum coordinate- -> V.Vector (Float, Float)--randomishPoints seed' n pointMin pointMax- = let pts = randomishFloats (n*2) pointMin pointMax seed'- xs = G.slice 0 n pts- ys = G.slice n n pts- in V.zip xs ys----- | Use the "minimal standard" Lehmer generator to quickly generate some random--- numbers with reasonable statistical properties. By "reasonable" we mean good--- enough for games and test data, but not cryptography or anything where the--- quality of the randomness really matters.--- --- From "Random Number Generators: Good ones are hard to find"--- Stephen K. Park and Keith W. Miller.--- Communications of the ACM, Oct 1988, Volume 31, Number 10.----randomishInts - :: Int -- Length of vector.- -> Int -- Minumum value in output.- -> Int -- Maximum value in output.- -> Int -- Random seed. - -> V.Vector Int -- Vector of random numbers.--randomishInts !len !valMin' !valMax' !seed'- - = let -- a magic number (don't change it)- multiplier :: Word64- multiplier = 16807-- -- a merzenne prime (don't change it)- modulus :: Word64- modulus = 2^(31 :: Integer) - 1-- -- if the seed is 0 all the numbers in the sequence are also 0.- seed - | seed' == 0 = 1- | otherwise = seed'-- !valMin = fromIntegral valMin'- !valMax = fromIntegral valMax' + 1- !range = valMax - valMin-- {-# INLINE f #-}- f x = multiplier * x `mod` modulus- in G.create - $ do - vec <- MV.new len-- let go !ix !x - | ix == len = return ()- | otherwise- = do let x' = f x- MV.write vec ix $ fromIntegral $ (x `mod` range) + valMin- go (ix + 1) x'-- go 0 (f $ f $ f $ fromIntegral seed)- return vec----- | Generate some randomish doubles with terrible statistical properties.--- This is good enough for test data, but not much else.-randomishDoubles - :: Int -- Length of vector- -> Double -- Minimum value in output- -> Double -- Maximum value in output- -> Int -- Random seed.- -> V.Vector Double -- Vector of randomish doubles.--randomishDoubles !len !valMin !valMax !seed- = let range = valMax - valMin-- mx = 2^(30 :: Integer) - 1- mxf = fromIntegral mx- ints = randomishInts len 0 mx seed- - in V.map (\n -> valMin + (fromIntegral n / mxf) * range) ints----- | Generate some randomish doubles with terrible statistical properties.--- This is good enough for test data, but not much else.-randomishFloats- :: Int -- Length of vector- -> Float -- Minimum value in output- -> Float -- Maximum value in output- -> Int -- Random seed.- -> V.Vector Float -- Vector of randomish doubles.--randomishFloats !len !valMin !valMax !seed- = let range = valMax - valMin-- mx = 2^(30 :: Integer) - 1- mxf = fromIntegral mx- ints = randomishInts len 0 mx seed- - in V.map (\n -> valMin + (fromIntegral n / mxf) * range) ints
− Visibility/Geometry/Segment.hs
@@ -1,81 +0,0 @@--module Geometry.Segment- ( Segment- , translateSegment- , splitSegmentsOnY- , splitSegmentsOnX- , chooseSplitX)-where-import Graphics.Gloss-import Graphics.Gloss.Geometry.Line-import Data.Maybe-import Data.Function-import qualified Data.Vector.Unboxed as V---- | A line segement in the 2D plane.-type Segment = (Int, (Float, Float), (Float, Float))----- | Translate both endpoints of a segment.-translateSegment :: Float -> Float -> Segment -> Segment-translateSegment tx ty (n, (x1, y1), (x2, y2))- = (n, (x1 + tx, y1 + ty), (x2 + tx, y2 + ty))- ---- | Split segments that cross the line y = y0, for some y0.-splitSegmentsOnY :: Float -> V.Vector Segment -> V.Vector Segment-splitSegmentsOnY y0 segs- = let - -- TODO: we only need to know IF the seg crosse the line here,- -- not the actual intersection point. Do a faster test.- (segsCross, segsOther)- = V.unstablePartition - (\(_, p1, p2) -> isJust $ intersectSegHorzLine p1 p2 y0)- segs-- -- TODO: going via lists here is bad.- splitCrossingSeg :: Segment -> V.Vector Segment- splitCrossingSeg (n, p1, p2)- = let Just pCross = intersectSegHorzLine p1 p2 y0- in V.fromList [(n, p1, pCross), (n, pCross, p2)]- - -- TODO: vector append requires a copy. - in segsOther V.++ (V.concat $ map splitCrossingSeg $ V.toList segsCross)----- | Split segments that cross the line x = x0, for some x0.-splitSegmentsOnX :: Float -> V.Vector Segment -> V.Vector Segment-splitSegmentsOnX x0 segs- = let - -- TODO: we only need to know IF the seg crosse the line here,- -- not the actual intersection point. Do a faster test.- (segsCross, segsOther)- = V.unstablePartition - (\(_, p1, p2) -> isJust $ intersectSegVertLine p1 p2 x0)- segs-- -- TODO: going via lists here is bad.- splitCrossingSeg :: Segment -> V.Vector Segment- splitCrossingSeg (n, p1, p2)- = let Just pCross = intersectSegVertLine p1 p2 x0- in V.fromList [(n, p1, pCross), (n, pCross, p2)]- - -- TODO: vector append requires a copy. - in segsOther V.++ (V.concat $ map splitCrossingSeg $ V.toList segsCross)----- | Decide where to split the plane.--- TODO: We're just taking the first point of the segment in the middle of the vector.--- It might be better to base the split on:--- - the closest segment--- - the widest sgement--- - the one closes to the middle of the field.--- - some combination of above.----chooseSplitX :: V.Vector Segment -> Float-chooseSplitX segments- = let Just (_, (x1, _), _) = segments V.!? (V.length segments `div` 2)- in x1---
− Visibility/Interface.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE PatternGuards #-}-module Interface- ( handleInput- , stepState)-where-import State-import qualified Graphics.Gloss.Interface.Pure.Game as G---- Input --------------------------------------------------------------------------------------------- | Handle an input event.-handleInput :: G.Event -> State -> State--handleInput (G.EventKey key keyState _ (x, y)) state- -- move the view position.- | G.MouseButton G.LeftButton <- key- , G.Down <- keyState- = state { stateModeInterface = ModeInterfaceMove - , stateViewPos- = ( fromRational $ toRational x- , fromRational $ toRational y) }-- -- set the target position.- | G.MouseButton G.RightButton <- key- , G.Down <- keyState- = state { stateTargetPos- = Just ( fromRational $ toRational x- , fromRational $ toRational y) }-- | G.MouseButton G.LeftButton <- key- , G.Up <- keyState- = state { stateModeInterface = ModeInterfaceIdle }--handleInput (G.EventMotion (x, y)) state- | stateModeInterface state == ModeInterfaceMove- = state { stateViewPos- = ( fromRational $ toRational x- , fromRational $ toRational y) }---- t : Turn target indicator off.-handleInput (G.EventKey key keyState _ _) state- | G.Char 't' <- key- , G.Down <- keyState- = state { stateTargetPos = Nothing }---- w : Display the whole world.-handleInput (G.EventKey key keyState _ _) state- | G.Char 'w' <- key- , G.Down <- keyState- = state { stateModeDisplay = ModeDisplayWorld }---- n : Display the normalised world.-handleInput (G.EventKey key keyState _ _) state- | G.Char 'n' <- key- , G.Down <- keyState- = state { stateModeDisplay = ModeDisplayNormalised }---- a : Toggle approximate visibility-handleInput (G.EventKey key keyState _ _) state- | G.Char 'a' <- key- , G.Down <- keyState- = state { stateModeOverlay- = case stateModeOverlay state of- ModeOverlayVisApprox -> ModeOverlayNone- _ -> ModeOverlayVisApprox } --handleInput _ state- = state---- Step ---------------------------------------------------------------------------------------------- | Advance the state one iteration-stepState :: Float -> State -> State-stepState _ state = state
− Visibility/Main.hs
@@ -1,27 +0,0 @@---- | Visibility on the 2D plane.--- Uses an instance of Warnocks algorithm.--- TODO: animate the line segments, make them spin and move around so we can see--- that it's a dynamic visiblity algorithm -- not pre-computed.--- Draw lines in random shades of color depending on the index.--- Make a key to swap between rectangular and polar projections.--- Allow viewpoint to be set with the mouse.------ TODO: To start with just do brute force visibility by dividing field into cells--- and doing vis based on center point of cell.-----import Interface-import Draw-import State-import World-import Graphics.Gloss.Interface.Pure.Game--main :: IO ()-main- = do world <- initialWorld- let state = initialState world- - play (InWindow "Visibility" (800, 800) (10, 10))- black 100 state- drawState handleInput stepState
− Visibility/State.hs
@@ -1,59 +0,0 @@---- | Game state-module State where-import Graphics.Gloss-import World----- | The game state.-data State- = State- { stateWorld :: World- , stateModeInterface :: ModeInterface- , stateModeDisplay :: ModeDisplay- , stateModeOverlay :: ModeOverlay- , stateViewPos :: Point - , stateTargetPos :: Maybe Point }----- | What mode the interface interaction is in.-data ModeInterface- -- | We're not doing anything inparticular.- = ModeInterfaceIdle-- -- | We're moving the view position.- | ModeInterfaceMove- deriving (Show, Eq)----- | What mode the display is in.-data ModeDisplay- -- | Show the world in rectangular coordinates.- = ModeDisplayWorld-- -- | Show the world normalised so the view position is at the origin.- | ModeDisplayNormalised- deriving (Show, Eq)----- | What overlay to display.-data ModeOverlay- -- | No overlay- = ModeOverlayNone- - -- | Brute force, approximate visibility- | ModeOverlayVisApprox- deriving (Show, Eq)----- | Initial game state.-initialState :: World -> State-initialState world- = State- { stateWorld = world- , stateModeInterface = ModeInterfaceIdle- , stateModeDisplay = ModeDisplayWorld- , stateModeOverlay = ModeOverlayVisApprox- , stateViewPos = (0, 0) - , stateTargetPos = Nothing }-
− Visibility/World.hs
@@ -1,54 +0,0 @@--module World- ( Segment- , World(..)- , initialWorld- , normaliseWorld)-where-import Graphics.Gloss-import Geometry.Randomish-import Geometry.Segment-import qualified Data.Vector.Unboxed as V----- We keep this unpacked so we can use unboxed vector.--- index, x1, y1, x2, y2-data World - = World- { worldSegments :: V.Vector Segment }----- | Generate the initial world.-initialWorld :: IO World-initialWorld- = do let n = 100- let minZ = -300- let maxZ = 300- - let minDelta = -100- let maxDelta = 100- - let centers = randomishPoints 1234 n minZ maxZ- let deltas = randomishPoints 4321 n minDelta maxDelta-- let makePoint n' (cX, cY) (dX, dY)- = (n', (cX, cY), (cX + dX, cY + dY))-- let segs = V.zipWith3 makePoint (V.enumFromTo 0 (n - 1)) centers deltas- - return $ World segs----- | Normalise the world so that the given point is at the origin,--- and split segements that cross the y=0 line.-normaliseWorld :: Point -> World -> World -normaliseWorld (px, py) world- = let segments_trans = V.map (translateSegment (-px) (-py)) - $ worldSegments world- - segments_split = splitSegmentsOnY 0 segments_trans- - in world { worldSegments = segments_split }---
− Zen/Main.hs
@@ -1,64 +0,0 @@---- A nifty animated fractal of a tree, superimposed on a background --- of three red rectangles.-import Graphics.Gloss--main :: IO ()-main - = animate (InWindow "Zen" (800, 600) (5, 5))- (greyN 0.2)- frame ----- Produce one frame of the animation.-frame :: Float -> Picture-frame timeS- = Pictures - -- the red rectangles- [ Translate 0 150 backRec- , Translate 0 0 backRec- , Translate 0 (-150) backRec-- -- the tree- , Translate 0 (-150) $ treeFrac 7 timeS- ]----- One of the red backing rectangles, with a white outline.-backRec :: Picture-backRec - = Pictures- [ Color red (rectangleSolid 400 100)- , Color white (rectangleWire 400 100) ]----- The color for the outline of the tree's branches.-treeOutline :: Color-treeOutline = makeColor 0.3 0.3 1.0 1.0----- The color for the shading of the tree's branches.--- The Alpha here is set to 0.5 so the branches are partly transparent.-treeColor :: Color-treeColor = makeColor 0.0 1.0 0.0 0.5----- The tree fractal.--- The position of the branches changes depending on the animation time--- as well as the iteration number of the fractal.-treeFrac :: Int -> Float -> Picture-treeFrac 0 timeS = Blank-treeFrac n timeS- = Pictures- [ Color treeColor $ rectangleUpperSolid 20 300- , Color treeOutline $ rectangleUpperWire 20 300- , Translate 0 30- $ Rotate (200 * sin timeS / (fromIntegral n) )- $ Scale 0.9 0.9 - $ treeFrac (n-1) timeS-- , Translate 0 70- $ Rotate (-200 * sin timeS / (fromIntegral n))- $ Scale 0.8 0.8 - $ treeFrac (n-1) timeS- ]
gloss-examples.cabal view
@@ -1,5 +1,5 @@ Name: gloss-examples-Version: 1.7.0.1+Version: 1.7.2.1 License: MIT License-file: LICENSE Author: Ben Lippmeier@@ -17,7 +17,6 @@ Synopsis: Examples using the gloss library - Executable gloss-bitmap Build-depends: base == 4.*,@@ -25,26 +24,27 @@ bytestring == 0.9.*, bmp == 1.2.* Main-is: Main.hs- hs-source-dirs: Bitmap- ghc-options: -threaded -O2+ hs-source-dirs: picture/Bitmap+ ghc-options: -threaded -O2 Executable gloss-boids Build-depends: base == 4.*, gloss == 1.7.*- Main-is: Main.hs- other-modules: KDTree2d Vec2- hs-source-dirs: Boids- ghc-options: -threaded -O2+ Main-is: Main.hs+ other-modules: KDTree2d Vec2+ hs-source-dirs: picture/Boids+ ghc-options: -threaded -O2 Executable gloss-clock Build-depends: base == 4.*, gloss == 1.7.*- Main-is: Clock/Main.hs- ghc-options: -threaded -O2+ Main-is: Main.hs+ hs-source-dirs: picture/Clock+ ghc-options: -threaded -O2 Executable gloss-conway@@ -52,27 +52,28 @@ base == 4.*, gloss == 1.7.*, vector >= 0.7 && < 1.0- Main-is: Main.hs- other-modules: Cell World- hs-source-dirs: Conway- ghc-options: -threaded -O2+ Main-is: Main.hs+ other-modules: Cell World+ hs-source-dirs: picture/Conway+ ghc-options: -threaded -O2 Executable gloss-draw Build-depends: base == 4.*, gloss == 1.7.*- Main-is: Main.hs- hs-source-dirs: Draw- ghc-options: -threaded -O2+ Main-is: Main.hs+ hs-source-dirs: picture/Draw+ ghc-options: -threaded -O2 Executable gloss-easy Build-depends: base == 4.*, gloss == 1.7.*- Main-is: Easy/Main.hs- ghc-options: -threaded -O2+ Main-is: Main.hs+ hs-source-dirs: picture/Easy+ ghc-options: -threaded -O2 Executable gloss-eden@@ -80,35 +81,37 @@ base == 4.*, gloss == 1.7.*, random == 1.0.*- Main-is: Main.hs- other-modules: Cell Community World- hs-source-dirs: Eden- ghc-options: -threaded -O2+ Main-is: Main.hs+ other-modules: Cell Community World+ hs-source-dirs: picture/Eden+ ghc-options: -threaded -O2 Executable gloss-flake Build-depends: base == 4.*, gloss == 1.7.*- Main-is: Flake/Main.hs- ghc-options: -threaded -O2+ Main-is: Main.hs+ hs-source-dirs: picture/Flake+ ghc-options: -threaded -O2 Executable gloss-gameevent Build-depends: base == 4.*, gloss == 1.7.*- Main-is: Main.hs- hs-source-dirs: GameEvent- ghc-options: -threaded -O2+ Main-is: Main.hs+ hs-source-dirs: picture/GameEvent+ ghc-options: -threaded -O2 Executable gloss-hello Build-depends: base == 4.*, gloss == 1.7.*- Main-is: Hello/Main.hs- ghc-options: -threaded -O2+ Main-is: Main.hs+ hs-source-dirs: picture/Hello+ ghc-options: -threaded -O2 Executable gloss-lifespan@@ -116,28 +119,29 @@ base == 4.*, gloss == 1.7.*, random == 1.0.*- Main-is: Main.hs- other-modules: Cell Community World- hs-source-dirs: Lifespan- ghc-options: -threaded -O2+ Main-is: Main.hs+ other-modules: Cell Community World+ hs-source-dirs: picture/Lifespan+ ghc-options: -threaded -O2 Executable gloss-machina Build-depends: base == 4.*, gloss == 1.7.*- Main-is: Machina/Main.hs- ghc-options: -threaded -O2-+ Main-is: Main.hs+ hs-source-dirs: picture/Machina+ ghc-options: -threaded -O2+ Executable gloss-occlusion Build-depends: base == 4.*, gloss == 1.7.* Main-is: Main.hs- other-modules: Cell World State Data- hs-source-dirs: Occlusion- ghc-options: -threaded -O2+ other-modules: Cell World State Data+ hs-source-dirs: picture/Occlusion+ ghc-options: -threaded -O2 Executable gloss-styrene@@ -146,18 +150,19 @@ gloss == 1.7.*, containers >= 0.3 && <= 0.5, ghc-prim == 0.2.*- Main-is: Main.hs- other-modules: Actor Advance Collide Config Contact QuadTree World- hs-source-dirs: Styrene- ghc-options: -threaded -O2+ Main-is: Main.hs+ other-modules: Actor Advance Collide Config Contact QuadTree World+ hs-source-dirs: picture/Styrene+ ghc-options: -threaded -O2 Executable gloss-tree Build-depends: base == 4.*, gloss == 1.7.*- Main-is: Tree/Main.hs- ghc-options: -threaded -O2+ Main-is: Main.hs+ hs-source-dirs: picture/Tree+ ghc-options: -threaded -O2 Executable gloss-visibility@@ -165,17 +170,81 @@ base == 4.*, gloss == 1.7.*, vector >= 0.7 && < 1.0- Main-is: Main.hs- other-modules: Draw Interface State World Geometry.Randomish Geometry.Segment- hs-source-dirs: Visibility - ghc-options: -threaded -O2+ Main-is: Main.hs+ other-modules: Draw Interface State World Geometry.Randomish Geometry.Segment+ hs-source-dirs: picture/Visibility + ghc-options: -threaded -O2 Executable gloss-zen Build-depends: base == 4.*, gloss == 1.7.*- Main-is: Zen/Main.hs- ghc-options: -threaded -O2+ Main-is: Main.hs+ hs-source-dirs: picture/Zen+ ghc-options: -threaded -O2+++Executable gloss-crystal+ Build-depends:+ base == 4.*,+ gloss == 1.7.*,+ gloss-raster == 1.7.2.*+ Main-is: Main.hs+ hs-source-dirs: raster/Crystal+ ghc-options: + -Wall -threaded -eventlog+ -Odph -fno-liberate-case+ -funfolding-use-threshold1000+ -funfolding-keeness-factor1000+ -fllvm -optlo-O3+++Executable gloss-ray+ Build-depends:+ base == 4.*,+ gloss == 1.7.*,+ gloss-raster == 1.7.2.*+ Main-is: Main.hs+ other-modules: Light Object Trace Vec3 World+ hs-source-dirs: raster/Ray+ ghc-options: + -Wall -threaded -eventlog+ -Odph -fno-liberate-case+ -funfolding-use-threshold1000+ -funfolding-keeness-factor1000+ -fllvm -optlo-O3++Executable gloss-pulse+ Build-depends:+ base == 4.*,+ gloss == 1.7.*,+ gloss-raster == 1.7.2.*+ Main-is: Main.hs+ hs-source-dirs: raster/Pulse+ ghc-options:+ -Wall -threaded -eventlog+ -Odph -fno-liberate-case+ -funfolding-use-threshold1000+ -funfolding-keeness-factor1000+ -fllvm -optlo-O3++Executable gloss-wave+ Build-depends:+ base == 4.*,+ gloss == 1.7.*,+ gloss-raster == 1.7.2.*,+ vector == 0.9.*,+ ghc-prim+ Main-is: Main.hs+ hs-source-dirs: raster/Wave+ ghc-options:+ -Wall -threaded -eventlog+ -Odph -fno-liberate-case+ -funfolding-use-threshold1000+ -funfolding-keeness-factor1000+ -fllvm -optlo-O3++
+ picture/Bitmap/Main.hs view
@@ -0,0 +1,27 @@++import Graphics.Gloss+import Codec.BMP+import System.Environment++-- | Displays uncompressed 24/32 bit BMP images.+main+ = do args <- getArgs+ case args of+ [fileName] -> run fileName+ _ -> putStr + $ unlines [ "usage: bitmap <file.bmp>"+ , " file.bmp should be a 24 or 32-bit uncompressed BMP file" ]++run fileName+ = do picture@(Bitmap width height _ _)+ <- loadBMP fileName++ animate (InWindow fileName (width, height) (10, 10))+ black (frame width height picture)++frame :: Int -> Int -> Picture -> Float -> Picture+frame width height picture t+ = Color (greyN (abs $ sin (t * 2)))+ $ Pictures + [rectangleSolid (fromIntegral width) (fromIntegral height)+ , picture]
+ picture/Boids/KDTree2d.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE BangPatterns #-}+-- KDTree code+-- by Matthew Sottile <matt@galois.com> <mjsottile@computer.org>+--+module KDTree2d (+ KDTreeNode(..),+ newKDTree,+ kdtAddPoints,+ kdtAddPoint,+ kdtRangeSearch,+ kdtCollisionDetect,+ kdtInBounds,+ dumpKDTree,+ mapKDTree,+ kdtreeToList+) where+import Vec2+import Data.Maybe+import System.IO+++data KDTreeNode a + = Empty+ | Node !(KDTreeNode a) !Vec2 !a !(KDTreeNode a)+ deriving Show+++-- | An empty KDTree+newKDTree :: KDTreeNode a+newKDTree = Empty++-- | Flatten out a KDTree to a list.+kdtreeToList :: KDTreeNode a -> [a]+kdtreeToList Empty = []+kdtreeToList (Node l _ x r) = [x] ++ kdtreeToList l ++ kdtreeToList r+++-- | Apply a worker function to all elements of a KDTree.+mapKDTree :: KDTreeNode a -> (a -> b) -> [b]+mapKDTree Empty _ = []+mapKDTree (Node l p n r) f = f n : (mapKDTree l f ++ mapKDTree r f)+++kdtAddWithDepth :: KDTreeNode a -> Vec2 -> a -> Int -> KDTreeNode a+kdtAddWithDepth Empty pos dat _ + = Node Empty pos dat Empty++kdtAddWithDepth (Node left npos ndata right) pos dat d + | vecDimSelect pos d < vecDimSelect npos d+ = Node (kdtAddWithDepth left pos dat d') npos ndata right++ | otherwise+ = Node left npos ndata (kdtAddWithDepth right pos dat d')+ where d' = if (d == 1) then 0 else 1+++kdtAddPoint :: KDTreeNode a -> Vec2 -> a -> KDTreeNode a+kdtAddPoint t p d + = kdtAddWithDepth t p d 0++kdtInBounds p bMin bMax + = vecLessThan p bMax && vecGreaterThan p bMin+++-- X dimension+kdtRangeSearchRecX :: KDTreeNode a -> Vec2 -> Vec2 -> [(Vec2,a)]+kdtRangeSearchRecX Empty _ _ = []+kdtRangeSearchRecX (Node left npos ndata right) bMin bMax+ | nc < mnc+ = nextfun right bMin bMax++ | nc > mxc+ = nextfun left bMin bMax++ | kdtInBounds npos bMin bMax+ = (npos, ndata) + : (nextfun right bMin bMax ++ nextfun left bMin bMax)++ | otherwise+ = nextfun right bMin bMax ++ nextfun left bMin bMax++ where Vec2 nc _ = npos+ Vec2 mnc _ = bMin+ Vec2 mxc _ = bMax+ nextfun = kdtRangeSearchRecY+++-- Y dimension+kdtRangeSearchRecY :: (KDTreeNode a) -> Vec2 -> Vec2 -> [(Vec2,a)]+kdtRangeSearchRecY Empty _ _ = []+kdtRangeSearchRecY (Node left npos ndata right) bMin bMax+ | nc < mnc+ = nextfun right bMin bMax+ + | nc > mxc+ = nextfun left bMin bMax+ + | (kdtInBounds npos bMin bMax)+ = (npos, ndata)+ : (nextfun right bMin bMax ++ nextfun left bMin bMax)++ | otherwise+ = nextfun right bMin bMax ++ nextfun left bMin bMax++ where Vec2 _ nc = npos+ Vec2 _ mnc = bMin+ Vec2 _ mxc = bMax+ nextfun = kdtRangeSearchRecX+++kdtRangeSearch :: (KDTreeNode a) -> Vec2 -> Vec2 -> [(Vec2,a)]+kdtRangeSearch t bMin bMax + = kdtRangeSearchRecX t bMin bMax+++kdtAddPoints :: [(Vec2,a)] -> (KDTreeNode a) -> (KDTreeNode a)+kdtAddPoints [] t = t+kdtAddPoints ((pt, dat):ps) t + = kdtAddPoints ps $ kdtAddPoint t pt dat+++singleCollision :: Vec2 -> Vec2 -> Vec2 -> Double -> a -> Maybe (Vec2, a)+singleCollision pt start a eps dat+ | sqrd_dist < eps * eps+ = Just (vecAdd start p, dat)+ + | otherwise+ = Nothing++ where b = vecSub pt start+ xhat = (vecDot a b) / (vecDot a a)+ p = vecScale a xhat+ e = vecSub p b+ sqrd_dist = vecDot e e+++kdtCollisionDetect :: KDTreeNode a -> Vec2 -> Vec2 -> Double -> [(Vec2,a)]+kdtCollisionDetect root !start !end !eps + = colls + where Vec2 sx sy = start+ Vec2 ex ey = end+ rmin = Vec2 (min sx ex - eps) (min sy ey - eps)+ rmax = Vec2 (max sx ex + eps) (max sy ey + eps)+ pts = kdtRangeSearch root rmin rmax+ a = vecSub end start+ colls = mapMaybe (\(pt,dat) -> singleCollision pt start a eps dat) pts+ + +-- Dumping --------------------------------------------------------------------+-- | Dump a KDTree to a file+dumpKDTree :: KDTreeNode Int -> FilePath -> IO ()+dumpKDTree kdt name + = do h <- openFile name WriteMode+ hPutStrLn h "n x y z"+ dumpKDTreeInner kdt h+ hClose h+++-- | Dump a KDTree to a handle.+dumpKDTreeInner :: KDTreeNode Int -> Handle -> IO ()+dumpKDTreeInner kdt h + = case kdt of+ Empty -> return ()++ Node l v d r + -> do printVec v h d+ dumpKDTreeInner l h+ dumpKDTreeInner r h+++-- | Print a vector to a handle.+printVec :: Vec2 -> Handle -> Int -> IO ()+printVec (Vec2 x y) h i + = hPutStrLn h $ show i ++ " " ++ show x ++ " " ++ show y+
+ picture/Boids/Main.hs view
@@ -0,0 +1,354 @@+-- Implementation of the Boids flocking algorithm. +-- by Matthew Sottile <matt@galois.com> <mjsottile@computer.org>+-- Described in http://syntacticsalt.com/2011/03/10/functional-flocks/+--+-- Read more about Boids here: http://www.red3d.com/cwr/boids/+-- +import KDTree2d+import Vec2+import System.Random+import System.IO.Unsafe+import Debug.Trace+import Graphics.Gloss+import Graphics.Gloss.Data.Picture+import Graphics.Gloss.Interface.Pure.Simulate+++-- Parameters -----------------------------------------------------------------+cParam = 0.0075++sParam = 0.1+sScale = 1.25++aParam = 1.0 / 1.8+vLimit = 0.0025 * max (maxx - minx) (maxy - miny)+epsilon = 0.40+maxx = 8.0+maxy = 8.0+minx = -8.0+miny = -8.0+++-- Colors ---------------------------------------------------------------------+boidColor = makeColor 1.0 1.0 0.0 1.0+radiusColor = makeColor 0.5 1.0 1.0 0.2+cohesionColor = makeColor 1.0 0.0 0.0 1.0+separationColor = makeColor 0.0 1.0 0.0 1.0+alignmentColor = makeColor 0.0 0.0 1.0 1.0+++-- Types ----------------------------------------------------------------------+data World+ = World+ { width :: Double+ , height :: Double+ , pixWidth :: Int+ , pixHeight :: Int }+ deriving Show+++data Boid+ = Boid+ { identifier :: Int+ , position :: Vec2+ , velocity :: Vec2+ , dbgC :: Vec2+ , dbgS :: Vec2+ , dbgA :: Vec2 }+ deriving Show+++-- Main -----------------------------------------------------------------------+main :: IO ()+main + = do let w = World { width = maxx - minx+ , height = maxy - miny+ , pixWidth = 700+ , pixHeight = 700 }++ let bs = initialize 500 10.0 0.5+ let t = foldl (\t b -> kdtAddPoint t (position b) b) newKDTree bs++ simulate (InWindow "Boids" (pixWidth w, pixHeight w) (10,10))+ (greyN 0.1) 30 t (renderboids w) iterationkd+++-- Coordinate Conversion ------------------------------------------------------+modelToScreen :: World -> (Double, Double) -> (Float, Float)+modelToScreen world (x,y) + = let xscale = fromIntegral (pixWidth world) / width world+ yscale = fromIntegral (pixHeight world) / height world+ in (realToFrac $ x * xscale, realToFrac $ y * yscale)+++scaleFactor :: World -> Float+scaleFactor world+ = let xscale = fromIntegral (pixWidth world) / width world+ yscale = fromIntegral (pixHeight world) / height world+ in realToFrac $ max xscale yscale+++velocityScale :: Float+velocityScale = 10.0 * (realToFrac (max (maxx - minx) (maxy - miny)) :: Float)+++-- Rendering -----------------------------------------------------------------+renderboids :: World -> KDTreeNode Boid -> Picture+renderboids world bs+ = Pictures $ mapKDTree bs (renderboid world)++renderboid :: World -> Boid -> Picture+renderboid world b + = let (Vec2 x y) = position b+ (Vec2 vx vy) = velocity b+ v = velocity b+ (Vec2 dCX dCY) = dbgC b+ (Vec2 dSX dSY) = dbgS b+ (Vec2 dAX dAY) = dbgA b+ sf = 5.0 * (scaleFactor world)+ sf' = 1.0 * (scaleFactor world)+ sf2 = sf * 10+ (xs,ys) = modelToScreen world (x,y)+ vxs = sf * (realToFrac vx) :: Float+ vys = sf * (realToFrac vy) :: Float++ in Pictures + [ Color boidColor $ + Translate xs ys $+ Circle 2++ , Color radiusColor $+ Translate xs ys $+ Circle ((realToFrac epsilon) * sf')++ , Color boidColor $ + Line [(xs, ys), (xs + vxs, ys + vys)]++ , Color cohesionColor $+ Line [(xs, ys), (xs + sf2 * realToFrac dCX, ys + sf2 * realToFrac dCY) ]++ , Color alignmentColor $+ Line [(xs, ys), (xs + sf2 * realToFrac dAX, ys + sf2 * realToFrac dAY) ]++ , Color separationColor $+ Line [(xs, ys), (xs + sf' * realToFrac dSX, ys + sf' * realToFrac dSY)] ]+++-- Initialisation -------------------------------------------------------------+rnlist :: Int -> IO [Double]+rnlist n + = mapM (\_ -> randomRIO (0.0,1.0)) [1..n]+++initialize :: Int -> Double -> Double -> [Boid]+initialize n sp sv + = let nums = unsafePerformIO $ rnlist (n*6) + nums' = map (\i -> (0.5 - i) / 2.0) nums++ makeboids [] [] = []+ makeboids (a:b:c:d:e:f:rest) (id:ids) + = Boid { identifier = id+ , velocity = Vec2 (a*sv) (b*sv)+ , position = Vec2 (d*sp) (e*sp)+ , dbgC = vecZero+ , dbgS = vecZero+ , dbgA = vecZero} + : makeboids rest ids++ in makeboids nums' [1..n]+++-- Vector Helpers -------------------------------------------------------------+-- | Sometimes we want to control runaway of vector scales, so this can+-- be used to enforce an upper bound+limiter :: Vec2 -> Double -> Vec2+limiter x lim = let d = vecNorm x+ in if (d < lim) then x+ else vecScale (vecNormalize x) lim++-- | Vector with all components length epsilon+epsvec :: Vec2+epsvec = Vec2 epsilon epsilon+++-- Boids Logic ----------------------------------------------------------------++-- three rules: +-- cohesion (seek centroid)+-- separation (avoid neighbors),+-- and alignment (fly same way as neighbors)+++-- | Centroid is average position of boids, or the vector sum of all+-- boid positions scaled by 1/(number of boids)+findCentroid :: [Boid] -> Vec2+findCentroid [] = error "Bad centroid"+findCentroid boids + = let n = length boids+ in vecScale (foldl1 vecAdd (map position boids))+ (1.0 / (fromIntegral n))++-- | cohesion : go towards centroid. Parameter dictates fraction of+-- distance from boid to centroid that contributes to velocity+cohesion :: Boid -> [Boid] -> Double -> Vec2+cohesion b boids a = vecScale diff a+ where c = findCentroid boids+ p = position b+ diff = vecSub c p+ ++-- | separation: avoid neighbours+separation :: Boid -> [Boid] -> Double -> Vec2+separation b [] a = vecZero+separation b boids a+ = let diff_positions = map (\i -> vecSub (position i) (position b)) boids+ closeby = filter (\i -> (vecNorm i) < a) diff_positions+ sep = foldl vecSub vecZero closeby+ in vecScale sep sScale+++-- | alignment: fly the same way as neighbours+alignment :: Boid -> [Boid] -> Double -> Vec2+alignment b [] a = vecZero+alignment b boids a + = let v = foldl1 vecAdd (map velocity boids)+ s = 1.0 / (fromIntegral $ length boids)+ v' = vecScale v s+ in vecScale (vecSub v' (velocity b)) a+++-- | Move one boid, with respect to its neighbours.+oneboid :: Boid -> [Boid] -> Boid+oneboid b boids + = let c = cohesion b boids cParam+ s = separation b boids sParam+ a = alignment b boids aParam+ p = position b+ v = velocity b+ id = identifier b+ v' = vecAdd v (vecScale (vecAdd c (vecAdd s a)) 0.1)+ v'' = limiter (vecScale v' 1.0025) vLimit+ p' = vecAdd p v''++ in Boid { identifier = id+ , position = wraparound p'+ , velocity = v''+ , dbgC = c+ , dbgS = s+ , dbgA = a }+++-- | Neighbor finding code+--+-- This is slightly tricky if we want to represent a world that wraps+-- around in one or more dimensions (aka, a torus or cylinder).+--+-- The issue is that we need to split the bounding box that we query the+-- KDTree with when that box extends outside the bounds of the world.+-- Furthermore, when a set of boids are found in the split bounding boxes+-- representing a neighbor after wrapping around, we need to adjust the+-- relative position of those boids with respect to the reference frame+-- of the central boid. For example, if the central boid is hugging the left+-- boundary, and another boid is right next to it hugging the right+-- boundary, their proper distance is likely very small. If the one on the+-- right boundary isn't adjusted, then the distance will actually appear to+-- be very large (approx. the width of the world).++findNeighbors :: KDTreeNode Boid -> Boid -> [Boid]+findNeighbors w b + = let p = position b+ + -- bounds+ vlo = vecSub p epsvec+ vhi = vecAdd p epsvec+ + -- split the boxes+ splith = splitBoxHoriz (vlo, vhi, 0.0, 0.0)+ splitv = concatMap splitBoxVert splith+ + -- adjuster for wraparound+ adj1 ax ay (pos, theboid)+ = (vecAdd pos av, theboid { position = vecAdd p av })++ where av = Vec2 ax ay+ p = position theboid++ adjuster lo hi ax ay + = let neighbors = kdtRangeSearch w lo hi+ in map (adj1 ax ay) neighbors+ + -- do the sequence of range searches+ ns = concatMap (\(lo,hi,ax,ay) -> adjuster lo hi ax ay) splitv+ + -- compute the distances from boid b to members+ dists = map (\(np,n) -> (vecNorm (vecSub p np), n)) ns++ in b : map snd (filter (\(d,_) -> d <= epsilon) dists)+++splitBoxHoriz + :: (Vec2, Vec2, Double, Double) + -> [(Vec2, Vec2, Double, Double)]+ +splitBoxHoriz (lo@(Vec2 lx ly), hi@(Vec2 hx hy), ax, ay) + | hx-lx > w+ = [(Vec2 minx ly, Vec2 maxx hy, ax, ay)]+ + | lx < minx+ = [ (Vec2 minx ly, Vec2 hx hy, ax, ay)+ , (Vec2 (maxx-(minx-lx)) ly, Vec2 maxx hy, (ax-w), ay)]+ + | hx > maxx+ = [ (Vec2 lx ly, Vec2 maxx hy, ax, ay)+ , (Vec2 minx ly, Vec2 (minx + (hx-maxx)) hy, ax+w, ay)]+ + | otherwise+ = [(lo, hi, ax, ay)]++ where w = maxx-minx+++splitBoxVert + :: (Vec2, Vec2, Double, Double)+ -> [(Vec2, Vec2, Double, Double)]++splitBoxVert (lo@(Vec2 lx ly), hi@(Vec2 hx hy), ax, ay) + | hy-ly > h+ = [(Vec2 lx miny, Vec2 hx maxy, ax, ay)]+ + | ly < miny+ = [ (Vec2 lx miny, Vec2 hx hy, ax, ay)+ , (Vec2 lx (maxy-(miny-ly)), Vec2 hx maxy, ax, ay-h) ]+ + | hy > maxy+ = [ (Vec2 lx ly, Vec2 hx maxy, ax, ay)+ , (Vec2 lx miny, Vec2 hx (miny + (hy-maxy)), ax, ay+h) ]++ | otherwise+ = [(lo, hi, ax, ay)]++ where h = maxy-miny+++wraparound :: Vec2 -> Vec2+wraparound (Vec2 x y) + = let w = maxx-minx+ h = maxy-miny+ x' = if x > maxx then x - w else (if x < minx then x+w else x)+ y' = if y > maxy then y - h else (if y < miny then y+h else y)++ in Vec2 x' y'++ +iteration :: ViewPort -> Float -> KDTreeNode Boid -> KDTreeNode Boid+iteration vp step w + = let all = kdtreeToList w+ boids = mapKDTree w (\i -> oneboid i all)+ in foldl (\t b -> kdtAddPoint t (position b) b) newKDTree boids+++iterationkd :: ViewPort -> Float -> KDTreeNode Boid -> KDTreeNode Boid+iterationkd vp step w + = let boids = mapKDTree w (\i -> oneboid i (findNeighbors w i))+ in foldl (\t b -> kdtAddPoint t (position b) b) newKDTree boids+
+ picture/Boids/Vec2.hs view
@@ -0,0 +1,59 @@++{-# LANGUAGE BangPatterns #-}+module Vec2 where++data Vec2 + = Vec2 {-# UNPACK #-}!Double {-# UNPACK #-}!Double+ deriving Show+++vecZero :: Vec2+vecZero = Vec2 0.0 0.0+++vecAdd :: Vec2 -> Vec2 -> Vec2+vecAdd (Vec2 a b) (Vec2 x y)+ = Vec2 (a+x) (b+y)+++vecSub :: Vec2 -> Vec2 -> Vec2+vecSub (Vec2 a b) (Vec2 x y)+ = Vec2 (a-x) (b-y)+++vecScale :: Vec2 -> Double -> Vec2+vecScale (Vec2 a b) !s+ = Vec2 (a*s) (b*s)+++vecDot :: Vec2 -> Vec2 -> Double+vecDot (Vec2 a b) (Vec2 x y)+ = (a*x)+(b*y)+++vecNorm :: Vec2 -> Double+vecNorm v+ = sqrt (vecDot v v)+++vecNormalize :: Vec2 -> Vec2+vecNormalize v+ = vecScale v (1.0 / (vecNorm v))+++vecDimSelect :: Vec2 -> Int -> Double+vecDimSelect (Vec2 a b) n+ = case rem n 2 of+ 0 -> a+ 1 -> b+++vecLessThan :: Vec2 -> Vec2 -> Bool+vecLessThan (Vec2 a b) (Vec2 x y)+ = a < x && b < y+++vecGreaterThan :: Vec2 -> Vec2 -> Bool+vecGreaterThan (Vec2 a b) (Vec2 x y)+ = a > x && b > y+
+ picture/Clock/Main.hs view
@@ -0,0 +1,73 @@++-- A fractal consisting of circles and lines which looks a bit like+-- the workings of a clock.+import Graphics.Gloss++main+ = animate (InWindow "Clock" (600, 600) (20, 20))+ black frame+++-- Build the fractal, scale it so it fits in the window+-- and rotate the whole thing as time moves on.+frame :: Float -> Picture+frame time+ = Color white+ $ Scale 120 120+ $ Rotate (time * 2*pi)+ $ clockFractal 5 time+ ++-- The basic fractal consists of three circles offset from the origin+-- as follows.+--+-- 1+-- |+-- .+-- / \+-- 2 3+--+-- The direction of rotation switches as n increases.+-- Components at higher iterations also spin faster.+--+clockFractal :: Int -> Float -> Picture+clockFractal 0 s = Blank+clockFractal n s = Pictures [circ1, circ2, circ3, lines]+ where+ -- y offset from origin to center of circle 1.+ a = 1 / sin (2 * pi / 6)++ -- x offset from origin to center of circles 2 and 3.+ b = a * cos (2 * pi / 6)++ nf = fromIntegral n+ rot = if n `mod` 2 == 0+ then 50 * s * (log (1 + nf))+ else (-50 * s * (log (1 + nf)))++ -- each element contains a copy of the (n-1) iteration contained+ -- within a larger circle, and some text showing the time since + -- the animation started.+ --+ circNm1 + = Pictures+ [ circle 1+ , Scale (a/2.5) (a/2.5) $ clockFractal (n-1) s+ , if n > 2+ then Color cyan + $ Translate (-0.15) 1+ $ Scale 0.001 0.001 + $ Text (show s) + else Blank+ ]++ circ1 = Translate 0 a $ Rotate rot circNm1+ circ2 = Translate 1 (-b) $ Rotate (-rot) circNm1+ circ3 = Translate (-1) (-b) $ Rotate rot circNm1+ + -- join each iteration to the origin with some lines.+ lines + = Pictures+ [ Line [(0, 0), ( 0, a)]+ , Line [(0, 0), ( 1, -b)]+ , Line [(0, 0), (-1, -b)] ]
+ picture/Conway/Cell.hs view
@@ -0,0 +1,91 @@++module Cell where+import Graphics.Gloss ++-- | A cell in the world.+data Cell+ = -- | A living cell with its age+ CellAlive Int ++ -- | A dead / blank cell.+ | CellDead+ deriving (Show, Eq)+++-- | Sort the living from the dead.+isAlive :: Cell -> Bool+isAlive cell+ = case cell of+ CellAlive _ -> True+ CellDead -> False+++-- | The basic shape of a cell.+cellShape :: Int -> Int -> Int -> Picture+cellShape cellSize posXi posYi+ = let cs = fromIntegral cellSize+ posX = fromIntegral posXi+ posY = fromIntegral posYi+ x1 = posX+ x2 = posX + cs+ y1 = posY + y2 = posY + cs+ in Polygon [(x1, y1), (x1, y2), (x2, y2), (x2, y1)]+ ++-- | Convert a cell to a picture, based on a primitive shape.+-- We pass the shape in to avoid recomputing it for each cell.+pictureOfCell :: Int -> Int -> Int -> Int -> Cell -> Picture+pictureOfCell oldAge cellSize posX posY cell+ = case cell of+ CellAlive age -> Color (ageColor oldAge age) (cellShape cellSize posX posY)+ CellDead -> Color (greyN 0.8) (cellShape cellSize posX posY)++ageColor :: Int -> Int -> Color+ageColor oldAge age+ = let (r, g, b) = rampColorHotToCold 0 (fromIntegral oldAge) (fromIntegral age)+ in makeColor r g b 1.0+ + ++-- Color Ramps -----------------------------------------------------------------------------------+-- | Standard Hot -> Cold hypsometric color ramp.+-- Sequence is red, yellow, green, cyan, blue.+rampColorHotToCold + :: (Ord a, Floating a) + => a + -> a + -> a + -> (a, a, a)+ +rampColorHotToCold vmin vmax vNotNorm+ = let + v | vNotNorm < vmin = vmin+ | vNotNorm > vmax = vmax+ | otherwise = vNotNorm+ + dv = vmax - vmin ++ result | v < vmin + 0.25 * dv+ = ( 0+ , 4 * (v - vmin) / dv+ , 1.0)+ + | v < vmin + 0.5 * dv+ = ( 0+ , 1.0+ , 1 + 4 * (vmin + 0.25 * dv - v) / dv)+ + | v < vmin + 0.75 * dv+ = ( 4 * (v - vmin - 0.5 * dv) / dv+ , 1.0+ , 0.0)+ + | otherwise+ = ( 1.0+ , 1 + 4 * (vmin + 0.75 * dv - v) / dv+ , 0)+ + in result++
+ picture/Conway/Main.hs view
@@ -0,0 +1,64 @@++module Main where+import World+import Cell+import Graphics.Gloss+import qualified Data.Vector as Vec++main :: IO ()+main + = do + let width = 150+ let height = 100+ world <- randomWorld (width, height)+ + simulate (InWindow "John Conway's Game of Life" + (windowSizeOfWorld world) (5, 5))+ white 10 world drawWorld simulateWorld+ ++-- | Convert a world to a picture.+drawWorld+ :: World + -> Picture++drawWorld world + = let (windowWidth, windowHeight) + = windowSizeOfWorld world+ + offsetX = - fromIntegral windowWidth / 2+ offsetY = - fromIntegral windowHeight / 2 + in Translate offsetX offsetY+ $ Pictures + $ Vec.toList + $ Vec.imap (drawCell world) (worldCells world)+++-- | Convert a cell at a particular coordinate to a picture.+drawCell :: World -> Index -> Cell -> Picture+drawCell world index cell + = let cs = fromIntegral (worldCellSize world)+ cp = fromIntegral (worldCellSpace world)++ (x, y) = coordOfIndex world index+ fx = fromIntegral x * (cs + cp) + 1+ fy = fromIntegral y * (cs + cp) + 1++ in pictureOfCell+ (worldCellOldAge world)+ (worldCellSize world)+ fx+ fy+ cell+ ++-- | Get the size of the window needed to display a world.+windowSizeOfWorld :: World -> (Int, Int)+windowSizeOfWorld world+ = let cellSize = worldCellSize world+ cellSpace = worldCellSpace world+ cellPad = cellSize + cellSpace+ height = cellPad * (worldHeight world) + cellSpace+ width = cellPad * (worldWidth world) + cellSpace+ in (width, height)+
+ picture/Conway/World.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE PatternGuards, ParallelListComp, BangPatterns #-}++module World where+import Cell+import System.Random+import Control.Monad+import Graphics.Gloss+import Graphics.Gloss.Interface.Pure.Simulate+import qualified Data.Vector as Vec+type Vec = Vec.Vector++-- Index ----------------------------------------------------------------------+-- | An index into the vector holding all the cells.+type Index = Int++-- | The x y coordinate of a cell.+type Coord = (Int, Int)++indexOfCoord :: World -> Coord -> Index+indexOfCoord world (x, y) + = x + y * (worldWidth world)++coordOfIndex :: World -> Index -> Coord+coordOfIndex world i + = ( i `mod` worldWidth world+ , i `div` worldWidth world)+++-- World ----------------------------------------------------------------------+data World + = World+ { worldCells :: Vec Cell + , worldWidth :: Int + , worldHeight :: Int ++ -- | Width and height of each cell.+ , worldCellSize :: Int++ -- | Number of pixels to leave between each cell.+ , worldCellSpace :: Int++ -- | Cells less than this age are drawn with the color ramp+ , worldCellOldAge :: Int++ -- | Seconds to wait between each simulation step.+ , worldSimulationPeriod :: Float + + -- | Time that has elapsed since we drew the last step+ , worldElapsedTime :: Float }+++-- | Make a new world of a particular size.+randomWorld :: (Int, Int) -> IO World+randomWorld (width, height)+ = do bools <- replicateM (width * height) randomIO + return $ World+ { worldCells = Vec.fromList $ map cellOfBool bools+ , worldWidth = width+ , worldHeight = height+ , worldCellSize = 5+ , worldCellSpace = 1 + , worldCellOldAge = 20+ , worldSimulationPeriod = 0.1 + , worldElapsedTime = 0 }+++-- | Convert a bool to a live or dead cell.+cellOfBool :: Bool -> Cell+cellOfBool b+ = case b of+ True -> CellAlive 0+ False -> CellDead+++-- | Get the cell at a particular coordinate in the world.+getCell :: World -> Coord -> Cell+getCell world coord@(x, y)+ | x < 0 || x >= worldWidth world = CellDead+ | y < 0 || y >= worldHeight world = CellDead++ | otherwise + = worldCells world Vec.! indexOfCoord world coord +++-- | Get the neighbourhood of cells aroudn this coordinate.+getNeighbourhood :: World -> Coord -> [Cell]+getNeighbourhood world (ix, iy)+ = let indexes = [ (x, y) + | x <- [ix - 1 .. ix + 1]+ , y <- [iy - 1 .. iy + 1]+ , not (x == ix && y == iy) ]+ in map (getCell world) indexes+++-- | Compute the next cell state depending on its neighbours.+stepCell :: Cell -> [Cell] -> Cell+stepCell cell neighbours+ = let live = length (filter isAlive neighbours)+ in case cell of+ CellAlive age -> if elem live [2, 3] then CellAlive (age + 1) else CellDead+ CellDead -> if live == 3 then CellAlive 0 else CellDead+++-- | Compute the next state of the cell at this index in the world.+stepIndex :: World -> Int -> Cell -> Cell+stepIndex world index cell+ = let coord = coordOfIndex world index+ neigh = getNeighbourhood world coord+ in stepCell cell neigh++ +-- | Compute the next world state.+stepWorld :: World -> World+stepWorld world+ = world { worldCells = Vec.imap (stepIndex world) (worldCells world) }++ +-- | Simulation function for worlds.+simulateWorld :: ViewPort -> Float -> World -> World+simulateWorld _ time world ++ -- If enough time has passed then it's time to step the world.+ | worldElapsedTime world >= (worldSimulationPeriod world)+ = let world' = stepWorld world+ in world' { worldElapsedTime = 0 }+ + -- Wait some more.+ | otherwise+ = world { worldElapsedTime = worldElapsedTime world + time }++
+ picture/Draw/Main.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE PatternGuards #-}+-- | Simple picture drawing application. +-- Like MSPaint, but you can only draw lines.+import Graphics.Gloss.Interface.Pure.Game+import Graphics.Gloss+import Data.Maybe (maybe)+import Debug.Trace+++main + = do let state = State Nothing []+ play (InWindow "Draw" (600, 600) (0,0))+ white 100 state+ makePicture handleEvent stepWorld+++-- | The game state.+data State + = State (Maybe Path) -- The current line being drawn.+ [Picture] -- All the lines drawn previously.+++-- | A Line Segment+type Segment = ((Float, Float), (Float, Float))+++-- | Convert our state to a picture.+makePicture :: State -> Picture+makePicture (State m xs)+ = Pictures (maybe xs (\x -> Line x : xs) m)+++-- | Handle mouse click and motion events.+handleEvent :: Event -> State -> State+handleEvent event state+ -- If the mouse has moved, then extend the current line.+ | EventMotion (x, y) <- event+ , State (Just ps) ss <- state+ = State (Just ((x, y):ps)) ss ++ -- Start drawing a new line.+ | EventKey (MouseButton LeftButton) Down _ pt@(x,y) <- event+ , State Nothing ss <- state+ = State (Just [pt])+ ((Translate x y $ Scale 0.1 0.1 $ Text "Down") : ss)++ -- Finish drawing a line, and add it to the picture.+ | EventKey (MouseButton LeftButton) Up _ pt@(x,y) <- event+ , State (Just ps) ss <- state+ = State Nothing+ ((Translate x y $ Scale 0.1 0.1 $ Text "up") : Line (pt:ps) : ss)++ | otherwise+ = state+++stepWorld :: Float -> State -> State+stepWorld _ = id+
+ picture/Easy/Main.hs view
@@ -0,0 +1,3 @@++import Graphics.Gloss+main = display (InWindow "My Window" (200, 200) (10, 10)) white (Circle 80)
+ picture/Eden/Cell.hs view
@@ -0,0 +1,38 @@+module Cell where++import Graphics.Gloss++data Cell + = Cell Point -- centre+ Float -- radius+ Int + deriving Show++-- Produce a new cell of a certain relative radius at a certain angle.+-- The factor argument is in the range [0..1] so spawned cells are+-- smaller than their parent.+-- The check whether it fits in the community is elsewhere.+offspring :: Cell -> Float -> Float -> Cell+offspring (Cell (x,y) r gen) alpha factor + = Cell (x + (childR+r) * cos alpha, y + (childR+r) * sin alpha) + childR + (gen + 1)++ where childR = factor * r++-- Do two cells overlap? +-- Used to decide if newly spawned cells can join the community.+overlap :: Cell -> Cell -> Bool+overlap (Cell (x1,y1) r1 _) (Cell (x2,y2) r2 _) + = centreDist < (r1 + r2) * 0.999+ where centreDist = sqrt(xdiff*xdiff + ydiff*ydiff)+ xdiff = x1 - x2+ ydiff = y1 - y2++render :: Cell -> Picture+render (Cell (x,y) r gen) + = let z = fromIntegral gen * 0.1+ color = makeColor 0.0 z 0.5 1.0+ in Color color+ $ Translate x y+ $ Circle r
+ picture/Eden/Community.hs view
@@ -0,0 +1,55 @@+module Community where++import Cell+import Graphics.Gloss++type Community = [Cell]++-- does a (newly spawned) cell fit in the community?+-- that is, does it overlap with any others?+fits :: Cell -> Community -> Bool+fits cell cells + = not $ any (overlap cell) cells++-- For each member of a community, produce one offspring+-- The lists of Floats are the (random) parameters that determine size+-- and location of each offspring.+spawn :: Community -> [Float] -> [Float] -> [Cell]+spawn = zipWith3 offspring++-- Given a collection of cells (one spawned by each member of the+-- community) check if it fits, and if so add it to the community.+-- That check must include new cells that have been added to the+-- community in this process.+survive :: [Cell] -> Community -> Community+survive [] comm = comm+survive (cell:cells) comm+ | fits cell comm = survive cells (cell:comm)+ | otherwise = survive cells comm++-- The next generation of a community+generation :: Community -> [Float] -> [Float] -> Community+generation comm angles scales + = survive (spawn comm angles scales) comm++render :: Community -> Picture+render comm + = Pictures $ map Cell.render comm++initial :: Community+initial = [Cell (0,0) 50 0]+++-- thread the random lists for testing outside IO()+--+life :: Community -> [Float] -> [Float] -> (Community, [Float], [Float])+life comm randomAngles randomScales =+ (generation comm angles scales, randomAngles', randomScales')+ where population = length comm+ (angles, randomAngles') = splitAt population randomAngles+ (scales, randomScales') = splitAt population randomScales++evolution :: Community -> [Float] -> [Float] -> [Community]+evolution comm randomAngles randomScales = comm1 : comms+ where (comm1, ras, rss) = life comm randomAngles randomScales+ comms = evolution comm1 ras rss
+ picture/Eden/Main.hs view
@@ -0,0 +1,19 @@++-- Adapted from ANUPlot version by Clem Baker-Finch+module Main where+import World+import Graphics.Gloss+import Graphics.Gloss.Interface.Pure.Simulate+import System.Random++-- varying prng sequence+main + = do gen <- getStdGen+ simulate (InWindow "Eden" (800, 600) (10, 10))+ (greyN 0.1) -- background color+ 2 -- number of steps per second+ (genesis' gen) -- initial world+ render -- function to convert world to a Picture+ evolve -- function to step the world one iteration++
+ picture/Eden/World.hs view
@@ -0,0 +1,47 @@+module World where++import Graphics.Gloss+import Graphics.Gloss.Interface.Pure.Simulate+import System.Random+import Community+import Cell++maxSteps = 30++-- The World consists of a Community and a random number generator.+-- (The RNG is a model of chaos or hand-of-god.)+data World + = World Community StdGen Int+ deriving (Show)++-- The initial world+genesis :: World+genesis + = World [Cell (0,0) 30 0] (mkStdGen 1023) 0++-- Seeding the prng means every run is identical.+-- To get different runs, need to use gen <- getStdGen in main :: IO()+-- and pass gen in as an argument. Edit Main.hs accordingly.+genesis' :: StdGen -> World+genesis' gen + = World [Cell (0,0) 30 0] gen 0+++-- Consume some random numbers to advance the simulation+evolve :: ViewPort -> Float -> World -> World+evolve vp step world@(World comm gen steps) + | steps < maxSteps + = let (genThis, genNext) = split gen+ (genA, genS) = split genThis+ angles = randomRs (0.0, 2*pi) genA+ scales = randomRs (0.7, 0.9) genS+ in World (generation comm angles scales) genNext (steps + 1)++ | otherwise+ = world++-- Converting the world to a picture is just converting the community component+render :: World -> Picture+render (World comm gen steps) + = Color (makeColor 0.3 0.3 0.6 1.0)+ $ Community.render comm
+ picture/Flake/Main.hs view
@@ -0,0 +1,46 @@++-- | Snowflake Fractal.+-- Based on ANUPlot code by Clem Baker-Finch.+--+import Graphics.Gloss++main = display (InWindow "Snowflake" (500, 500) (20, 20))+ black (picture 3)+++-- Fix a starting edge length of 360+edge = 360 :: Float+++-- Move the fractal into the center of the window and colour it nicely+picture :: Int -> Picture+picture degree + = Color aquamarine+ $ Translate (-edge/2) (-edge * sqrt 3/6)+ $ snowflake degree+ ++-- The fractal function+side :: Int -> Picture+side 0 = Line [(0, 0), (edge, 0)]+side n + = let newSide = Scale (1/3) (1/3) + $ side (n-1)+ in Pictures+ [ newSide+ , Translate (edge/3) 0 $ Rotate 60 newSide + , Translate (edge/2) (-(edge * sqrt 3)/6) $ Rotate (-60) newSide + , Translate (2 * edge/3) 0 $ newSide ]+++-- Put 3 together to form the snowflake+snowflake :: Int -> Picture+snowflake n + = let oneSide = side n+ in Pictures+ [ oneSide + , Translate edge 0 $ Rotate (-120) $ oneSide+ , Translate (edge/2) (edge * sqrt 3/2) $ Rotate 120 $ oneSide]+++
+ picture/GameEvent/Main.hs view
@@ -0,0 +1,14 @@++import Graphics.Gloss++-- | Display the last event received as text.+main+ = play (InWindow "GameEvent" (700, 100) (10, 10))+ white+ 100+ ""+ (\str -> Translate (-340) 0 $ Scale 0.1 0.1 $ Text str)+ (\event _ -> show event)+ (\_ world -> world)+ +
+ picture/Hello/Main.hs view
@@ -0,0 +1,18 @@++-- | Display "Hello World" in a window.+--+import Graphics.Gloss++main + = display + (InWindow+ "Hello World" -- window title+ (400, 150) -- window size+ (10, 10)) -- window position+ white -- background color+ picture -- picture to display++picture + = Translate (-170) (-20) -- shift the text to the middle of the window+ $ Scale 0.5 0.5 -- display it half the original size+ $ Text "Hello World" -- text to display
+ picture/Lifespan/Cell.hs view
@@ -0,0 +1,36 @@+module Cell where++import Graphics.Gloss++data Cell = Cell Point -- centre+ Float -- radius+ Int -- remaining lifetime+ deriving Show++-- Produce a new cell of a certain relative radius at a certain angle.+-- The factor argument is in the range [0..1] so spawned cells are+-- smaller than their parent.+-- The check whether it fits in the community is elsewhere.+offspring :: Cell -> Float -> Float -> Int -> Cell+offspring (Cell (x,y) r _) alpha factor lifespan =+ Cell (x + (childR+r) * cos alpha, y + (childR+r) * sin alpha)+ childR + lifespan+ where childR = factor * r++-- Do two cells overlap? +-- Used to decide if newly spawned cells can join the community.+overlap :: Cell -> Cell -> Bool+overlap (Cell (x1,y1) r1 _) (Cell (x2,y2) r2 _) = centreDist < (r1 + r2) *0.999+ where centreDist = sqrt(xdiff*xdiff + ydiff*ydiff)+ xdiff = x1 - x2+ ydiff = y1 - y2++-- thickness of circle is determined by lifespan+render :: Cell -> Picture+render (Cell (x,y) r life) + = Color (makeColor 0.6 z 0.6 1.0)+ $ Translate x y+ $ ThickCircle (r - thickness / 2) thickness+ where z = fromIntegral life * 0.12+ thickness = fromIntegral life
+ picture/Lifespan/Community.hs view
@@ -0,0 +1,58 @@+module Community where++import Cell+import Graphics.Gloss++type Community = [Cell]++-- does a (newly spawned) cell fit in the community?+-- that is, does it overlap with any others?+fits :: Cell -> Community -> Bool+fits cell cells = not $ any (overlap cell) cells++-- For each member of a community, produce one offspring+-- The lists of Floats are the (random) parameters that determine size++-- and location of each offspring.+spawn :: Community -> [Float] -> [Float] -> [Int] -> [Cell]+spawn = zipWith4 offspring++zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]+zipWith4 f [] _ _ _ = []+zipWith4 f _ [] _ _ = []+zipWith4 f _ _ [] _ = []+zipWith4 f _ _ _ [] = []+zipWith4 f (b:bs) (c:cs) (d:ds) (e:es) =+ f b c d e : zipWith4 f bs cs ds es+++-- Given a collection of cells (one spawned by each member of the+-- community) check if it fits, and if so add it to the community.+-- That check must include new cells that have been added to the+-- community in this process.+survive :: [Cell] -> Community -> Community+survive [] comm = comm+survive (cell:cells) comm+ | fits cell comm = survive cells (cell:comm)+ | otherwise = survive cells comm++age :: Community -> Community+age [] = []+age (Cell c r 0 : cells) = age cells+age (Cell c r life : cells) = Cell c r (life-1) : age cells+++-- The next generation of a community+generation :: Community -> [Float] -> [Float] -> Community+generation comm angles scales =+ survive (spawn comm angles scales (repeat 5)) (age comm)++render :: Community -> Picture+render comm + = Pictures + $ map Cell.render comm++initial :: Community+initial = [Cell (0,0) 50 5]++
+ picture/Lifespan/Main.hs view
@@ -0,0 +1,20 @@++-- Adapted from ANUPlot version by Clem Baker-Finch+module Main where+import World+import Graphics.Gloss+import Graphics.Gloss.Interface.Pure.Simulate+import System.Random++-- varying prng sequence+main + = do gen <- getStdGen+ simulate (InWindow "Lifespan" (800, 600) (10, 10))+ (greyN 0.1) -- background color+ 2 -- number of steps per second+ (genesis' gen) -- initial world+ render -- function to convert world to a Picture+ evolve -- function to step the world one iteration+++
+ picture/Lifespan/World.hs view
@@ -0,0 +1,44 @@+module World where++import Graphics.Gloss+import Graphics.Gloss.Interface.Pure.Simulate+import System.Random+import Community+import Cell++stepsMax = 20++-- The World consists of a Community and a random number generator.+-- (The RNG is a model of chaos or hand-of-god.)+data World + = World Community StdGen Int+ deriving (Show)++-- The initial world+genesis :: World+genesis + = World [Cell (0,0) 50 5] (mkStdGen 1023) 0++-- Seeding the prng means every run is identical.+-- To get different runs, need to use gen <- getStdGen in main :: IO()+-- and pass gen in as an argument. Edit Main.hs accordingly.+genesis' :: StdGen -> World+genesis' gen + = World [Cell (0,0) 50 5] gen 0++-- Consume some random numbers to advance the simulation+evolve :: ViewPort -> Float -> World -> World+evolve _ _ world@(World comm gen step) + | step > stepsMax = world+ | otherwise+ = World (generation comm angles scales) genNext (step + 1)+ where (genThis, genNext) = split gen+ (genA, genS) = split genThis+ angles = randomRs (0.0, 2*pi) genA+ scales = randomRs (0.7, 0.9) genS++-- Converting the world to a picture is just converting the community component+render :: World -> Picture+render (World comm gen _) + = Color (makeColor 0.3 0.3 0.6 1.0)+ $ Community.render comm
+ picture/Machina/Main.hs view
@@ -0,0 +1,30 @@++import Graphics.Gloss++main = animate (InWindow "machina" (800, 600) (10, 10))+ black frame++frame time+ = Scale 0.8 0.8+ $ Rotate (time * 30)+ $ mach time 6+ +mach t 0 = leaf+mach t d+ = Pictures+ [ leaf+ , Translate 0 (-100) + $ Scale 0.8 0.8 + $ Rotate (90 + t * 30) + $ mach (t * 1.5) (d - 1)++ , Translate 0 100 + $ Scale 0.8 0.8 + $ Rotate (90 - t * 30) + $ mach (t * 1.5) (d - 1) ]+ +leaf = Pictures+ [ Color (makeColor 1.0 1.0 1.0 0.5) $ Polygon loop+ , Color (makeColor 0.0 0.0 1.0 0.8) $ Line loop ]++loop = [(-10, -100), (-10, 100), (10, 100), (10, -100), (-10, -100)]
+ picture/Occlusion/Cell.hs view
@@ -0,0 +1,47 @@++module Cell+ ( Cell (..)+ , readCell + , pictureOfCell+ , cellShape)+where+import Data.Char+import Graphics.Gloss++-- | A terrain cell in the world.+data Cell+ = CellEmpty+ | CellWall+ deriving (Show, Eq)+++-- | Read a cell from a character.+readCell :: Char -> Cell+readCell c+ = case c of+ '.' -> CellEmpty+ '#' -> CellWall+ _ -> error $ "readCell: no match for char " ++ show (ord c) ++ " " ++ show c+++-- | The basic shape of a cell.+cellShape :: Int -> Int -> Int -> Picture+cellShape cellSize posXi posYi+ = let cs = fromIntegral cellSize+ posX = fromIntegral posXi+ posY = fromIntegral posYi+ x1 = posX+ x2 = posX + 1+ y1 = posY + y2 = posY + 1+ in Polygon [(x1, y1), (x1, y2), (x2, y2), (x2, y1)]+ ++-- | Convert a cell to a picture, based on a primitive shape.+-- We pass the shape in to avoid recomputing it for each cell.+pictureOfCell :: Int -> Int -> Int -> Cell -> Picture+pictureOfCell cellSize posX posY cell+ = case cell of+ CellEmpty -> Color (greyN 0.2) (cellShape cellSize posX posY)+ CellWall -> Color white (cellShape cellSize posX posY)+
+ picture/Occlusion/Data.hs view
@@ -0,0 +1,40 @@++module Data where++worldData+ = unlines+ [ "WORLD"+ , "32 32"+ , " 01234567890123456789012345678901"+ , "0#..............................#"+ , "1.....................#####......"+ , "2....#.#.#.#..#.#.#.............."+ , "3....#######...#.#....#.#.#......"+ , "4....#######..#.#.#.............."+ , "5....#######...#.#...###.###....."+ , "6................................"+ , "7......#.#.............#.#......."+ , "8......#.#.............#.#......."+ , "9......#.#.............#.#......."+ , "0......#.#####.........#.#......."+ , "1......#.....#.........#.#......."+ , "2......#.###.#.........#.#......."+ , "3......#.#.#.###########.#######."+ , "4......#.#.#...................#."+ , "5......#.#.#####################."+ , "6......#.#......................."+ , "7......#.#...########............"+ , "8......#.#...#......#............"+ , "9......#.#...########............"+ , "0......#.#................####..."+ , "1......#.#.........#####..#..#..."+ , "2......#.###########...####..#..."+ , "3......#.....................#..."+ , "4..#####.###########...####..#..."+ , "5..#.....#.........#####..#..#..."+ , "6..#.#####.....#..........####..."+ , "7..#.#.........#................."+ , "8..#.#......#######.............."+ , "9..#.#.........#................."+ , "0..............#................."+ , "1#..............................#" ]
+ picture/Occlusion/Main.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE PatternGuards #-}++import World+import Data+import State+import Cell+import Graphics.Gloss.Interface.Pure.Game+import Graphics.Gloss.Data.QuadTree+import Graphics.Gloss.Data.Extent+import System.Environment+import Data.Maybe+import Data.List+import Data.Function++main + = do args <- getArgs+ case args of+ [fileName] + -> do world <- loadWorld fileName+ mainWithWorld world+ + _ -> do+ let world = readWorld worldData+ mainWithWorld world+ + +mainWithWorld world+ = play (InWindow "Occlusion"+ (windowSizeOfWorld world) (10, 10))+ black + 10+ (initState world)+ drawState+ (handleInput world)+ (\_ -> id)+ + +-- | Convert the state to a picture.+drawState :: State -> Picture+drawState state+ = let world = stateWorld state++ -- The ray cast by the user.+ p1 = stateLineStart state+ p2 = stateLineEnd state+ picRay = drawRay world p1 p2++ -- The cell hit by the ray (if any)+ mHitCell = castSegIntoWorld world p1 p2+ hitCells = maybeToList mHitCell+ picCellsHit = Pictures $ map (drawHitCell world) hitCells++ -- All the cells in the world.+ cellsAll = flattenQuadTree (worldExtent world) (worldTree world)+ picCellsAll = Pictures $ map (uncurry (drawCell False world)) cellsAll++ -- The cells visible from the designated point.+ cellsVisible + = [ (coord, cell)+ | (coord, cell) <- flattenQuadTree (worldExtent world) (worldTree world)+ , cellAtCoordIsVisibleFromPoint world p1 coord ]++ picCellsVisible = Pictures $ map (uncurry (drawCell True world)) cellsVisible++ -- How big to draw the cells.+ scale = fromIntegral $ worldCellSize world++ (windowSizeX, windowSizeY) + = windowSizeOfWorld+ $ stateWorld state+ + -- Shift the cells so they are centered in the window.+ offsetX = - (fromIntegral $ windowSizeX `div` 2)+ offsetY = - (fromIntegral $ windowSizeY `div` 2)++ in Translate offsetX offsetY+ $ Scale scale scale+ $ Pictures [ picCellsAll, picCellsVisible, picCellsHit, picRay ]+++-- | Draw the cell hit by the ray defined by the user.+drawHitCell :: World -> (Point, Extent, Cell) -> Picture+drawHitCell world (pos@(px, py), extent, cell)+ = let (n, s, e, w) = takeExtent extent+ x = w+ y = s++ posX = fromIntegral x + posY = fromIntegral y+ + in Pictures [ Color blue $ cellShape 1 posX posY ]+++-- | Draw the ray defined by the user.+drawRay :: World -> Point -> Point -> Picture +drawRay world p1@(x, y) p2+ = Pictures+ [ Color red $ Line [p1, p2]+ , Color cyan + $ Translate x y + $ Pictures + [ Line [(-0.3, -0.3), (0.3, 0.3)]+ , Line [(-0.3, 0.3), (0.3, -0.3)] ] ]+++-- | Draw a cell in the world.+drawCell :: Bool -> World -> Coord -> Cell -> Picture+drawCell visible world (x, y) cell + = let cs = fromIntegral (worldCellSize world)+ cp = fromIntegral (worldCellSpace world)++ posX = fromIntegral x + posY = fromIntegral y++ in if visible+ then pictureOfCell (worldCellSize world) posX posY cell+ else Color (greyN 0.4) (cellShape cs posX posY)+
+ picture/Occlusion/State.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE PatternGuards #-}++module State where+import World+import Graphics.Gloss.Interface.Pure.Game++-- | The game state.+data State+ = State+ { stateWorld :: World+ , stateLineStart :: Point+ , stateLineEnd :: Point }+++-- | Initial game state.+initState world+ = State+ { stateWorld = world+ , stateLineStart = (10, 10)+ , stateLineEnd = (10, 10) }+ ++-- | Handle an input event.+handleInput :: World -> Event -> State -> State+handleInput world (EventKey key keyState mods pos) state+ | MouseButton LeftButton <- key+ , Down <- keyState+ , shift mods == Down + = state { stateLineEnd = worldPosOfWindowPos world pos }++ | MouseButton LeftButton <- key+ , Down <- keyState+ = state { stateLineStart = worldPosOfWindowPos world pos + , stateLineEnd = worldPosOfWindowPos world pos }++ | MouseButton RightButton <- key+ , Down <- keyState+ = state { stateLineEnd = worldPosOfWindowPos world pos }++handleInput _ _ state+ = state+
+ picture/Occlusion/World.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE ScopedTypeVariables #-}++module World where+import Cell+import Graphics.Gloss.Interface.Pure.Game+import Graphics.Gloss.Data.Extent+import Graphics.Gloss.Data.QuadTree+import Graphics.Gloss.Algorithms.RayCast+import System.IO+import Control.Monad+++-- | The game world.+data World + = World+ { worldWidth :: Int+ , worldHeight :: Int+ , worldTree :: QuadTree Cell+ , worldCellSize :: Int+ , worldCellSpace :: Int }+ deriving Show+++-- | Get the extent covering the entire world.+worldExtent :: World -> Extent+worldExtent world+ = makeExtent (worldWidth world) 0 (worldHeight world) 0+++-- | Load a world from a file. +loadWorld :: FilePath -> IO World+loadWorld fileName+ = do str <- readFile fileName+ return $ readWorld str+ + +-- | Read a world from a string.+readWorld :: String -> World+readWorld str+ = let ("WORLD" : strWidthHeight : skip : cellLines) + = lines str+ + [width, height] = map read $ words strWidthHeight+ rows = take height $ cellLines++ cells = concat + $ map (readLine width) + $ reverse rows++ extent = makeExtent height 0 width 0++ in World { worldWidth = width+ , worldHeight = height+ , worldTree = makeWorldTree extent cells+ , worldCellSize = 20+ , worldCellSpace = 0 }++readLine :: Int -> String -> [Cell]+readLine width (s:str)+ = map readCell+ $ take width str++++-- | Get the size of the window needed to display a world.+windowSizeOfWorld :: World -> (Int, Int)+windowSizeOfWorld world+ = let cellSize = worldCellSize world+ cellSpace = worldCellSpace world+ cellPad = cellSize + cellSpace+ height = cellPad * (worldHeight world) + cellSpace+ width = cellPad * (worldWidth world) + cellSpace+ in (width, height)+++-- | Create the tree representing the world from a list of all its cells.+makeWorldTree :: Extent -> [Cell] -> QuadTree Cell+makeWorldTree extent cells+ = foldr insert' emptyTree nonEmptyPosCells+ where + insert' (pos, cell) tree+ = case insertByCoord extent pos cell tree of+ Nothing -> tree+ Just tree' -> tree'+ + (width, height) + = sizeOfExtent extent+ + posCells + = zip [(x, y) | y <- [0 .. height - 1]+ , x <- [0 .. width - 1]]+ cells+ + nonEmptyPosCells + = filter (\x -> snd x /= CellEmpty) posCells+++-- | Get the world position coresponding to a point in the window.+worldPosOfWindowPos :: World -> Point -> Point+worldPosOfWindowPos world (x, y)+ = let (windowSizeX, windowSizeY)+ = windowSizeOfWorld world+ + offsetX = fromIntegral $ windowSizeX `div` 2+ offsetY = fromIntegral $ windowSizeY `div` 2+ + scale = fromIntegral $ worldCellSize world+ + x' = (x + offsetX) / scale+ y' = (y + offsetY) / scale++ in (x', y')+++-- | Check if a the cell at a given coordinate is visible from a point.+cellAtCoordIsVisibleFromCoord :: World -> Coord -> Coord -> Bool+cellAtCoordIsVisibleFromCoord world cFrom cTo+ = let (cx, cy) = cFrom+ pFrom = (fromIntegral cx + 0.5 , fromIntegral cy + 0.5)+ in cellAtCoordIsVisibleFromPoint world pFrom cTo+++-- | Check if a cell at a given coordinate is visible from a point.+-- We say it's visible if the center of any of its faces is visible.+cellAtCoordIsVisibleFromPoint :: World -> Point -> Coord -> Bool+cellAtCoordIsVisibleFromPoint world pFrom (x', y')+ = or $ map (cellAtPointIsVisibleFromPoint world pFrom) [pa, pb, pc, pd]+ where x :: Float = fromIntegral x' + 0.5+ y :: Float = fromIntegral y' + 0.5+ pa = (x - 0.4999, y)+ pb = (x + 0.4999, y)+ pc = (x, y - 0.4999)+ pd = (x, y + 0.4999)+ + +-- | Check if a point on some cell (P2) is visible from some other point (P1).+cellAtPointIsVisibleFromPoint :: World -> Point -> Point -> Bool+cellAtPointIsVisibleFromPoint world p1 p2+ = let mOccluder = castSegIntoWorld world p1 p2+ in case mOccluder of+ Nothing -> False+ Just (pos, extent, cell) -> pointInExtent extent p2+++-- | Given a line segment (P1-P2) get the cell closest to P1 that intersects the segment.+castSegIntoWorld :: World -> Point -> Point -> Maybe (Point, Extent, Cell)+castSegIntoWorld world p1 p2+ = castSegIntoCellularQuadTree p1 p2 (worldExtent world) (worldTree world)+++-- | Given a line segment (P1-P2) get the cell closest to P1 that intersects the segment.+traceSegIntoWorld :: World -> Point -> Point -> [(Point, Extent, Cell)]+traceSegIntoWorld world p1 p2+ = traceSegIntoCellularQuadTree p1 p2 (worldExtent world) (worldTree world)++
+ picture/Styrene/Actor.hs view
@@ -0,0 +1,73 @@++module Actor where++-- | 2D position on the screen.+type Position = (Float, Float)++-- | Force and velocity vectors.+type Force = (Float, Float)+type Velocity = (Float, Float)++-- | Time in seconds+type Time = Float++-- | Radius of a bead+type Radius = Float++-- | Each actor has its own unique index.+type Index = Int++-- | The actors in the world.+data Actor+ = Wall !Index -- ^ unique index of this actor+ !Position -- ^ wall starting point+ !Position -- ^ wall ending point++ | Bead !Index -- ^ unique index of this actor + !Int -- ^ whether the bead is stuck+ !Radius -- ^ radius of bead+ !Position -- ^ position of bead+ !Velocity -- ^ velocity of bead++ deriving Show++-- | Equality and ordering of actors will consider their index only.+-- We need Ord so we can put them in Maps and Sets.+instance Eq Actor where+ a1 == a2 = actorIx a1 == actorIx a2+ +instance Ord Actor where+ compare a1 a2 = compare (actorIx a1) (actorIx a2)++-- | Check whether an actor is a bead.+isBead :: Actor -> Bool+isBead (Bead _ _ _ _ _) = True+isBead _ = False+++-- | Check whether an actor is a wall.+isWall :: Actor -> Bool+isWall (Wall _ _ _) = True+isWall _ = False+++-- | Take the index of an actor+actorIx :: Actor -> Index+actorIx actor+ = case actor of+ Wall ix _ _ -> ix+ Bead ix _ _ _ _ -> ix+++-- | Set the index of an actor+actorSetIndex :: Actor -> Index -> Actor+actorSetIndex actor ix+ = case actor of+ Bead _ m r pos vel -> Bead ix m r pos vel + Wall _ p1 p2 -> Wall ix p1 p2+++-- | Set whether a bead is stuck+actorSetMode :: Int -> Actor -> Actor+actorSetMode m (Bead ix _ r p v)+ = Bead ix m r p v
+ picture/Styrene/Advance.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE PatternGuards #-}++-- | Advance the world to the next time step.+module Advance where+import World+import Contact+import QuadTree+import Collide+import Actor+import Config++import Graphics.Gloss.Geometry+import Graphics.Gloss.Interface.Pure.Simulate+import Graphics.Gloss.Data.Point+import Graphics.Gloss.Data.Vector++import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Map (Map)+++-- Advance -------------------------------------------------------------------------------------------++-- | Advance all the actors in this world by a certain time.+advanceWorld + :: ViewPort -- ^ current viewport+ -> Time -- ^ time to advance them for.+ -> World -- ^ the world to advance.+ -> World -- ^ the new world.++advanceWorld viewport time (World actors tree)+ = let + rot = viewPortRotate viewport+ force = rotateV (degToRad $ negate rot) (0, negate gravityCoeff)++ -- move all the actors + actors_moved = Map.map (moveActor_free time force) actors+ + -- find contacts in the world+ (contacts, tree') + = findContacts (World actors_moved tree)++ -- apply contacts to each pair of actors+ actors_bounced + = Set.fold + (applyContact time force) + actors_moved+ contacts++ in World actors_bounced tree'+++-- Move two actors which are known to be in contact.+applyContact + :: Time -- ^ time step+ -> Force -- ^ ambient force on the actors+ -> (Index, Index) -- ^ indicies of the the two actors in contact+ -> Map Index Actor -- ^ the old world+ -> Map Index Actor -- ^ the new world++applyContact time force (ix1, ix2) actors+ = let -- use the indicies to lookup the data for each actor from the map+ Just a1 = Map.lookup ix1 actors+ Just a2 = Map.lookup ix2 actors+ + resultActors+ -- handle a collision between bead and a wall+ | Bead _ _ r1 p1 v1 <- a1+ , Wall{} <- a2+ = let a1' = collideBeadWall a1 a2+ in Map.insert ix1 a1' actors+ + -- handle a collision between two beads+ | Bead ix1 m1 r1 p1 v1 <- a1+ , Bead ix2 m2 r2 p2 v2 <- a2+ = let + (a1', a2')+ -- if one of the beads is stuck then do a safer, static collision.+ -- with this method the beads don't transfer energy into each other+ -- so there is less of a chance of lots of beads being crushed together+ -- if there are many in the same place.+ | m1 >= beadStuckCount || m2 >= beadStuckCount+ = let a1' = collideBeadBead_static a1 a2+ a2' = collideBeadBead_static a2 a1+ in (a1', a2')++ -- otherwise do the real elastic collision+ -- this is much more realistic.+ | otherwise+ = collideBeadBead_elastic a1 a2++ -- write the new data for the actors back into the map+ in Map.insert ix1 a1'+ $ Map.insert ix2 a2' actors+ + in resultActors + ++-- | Move a bead which isn't in contact with anything else.+moveActor_free + :: Time -- ^ time to move it for+ -> Force -- ^ ambient force on the actor during this time+ -> Actor -- ^ the bead to move+ -> Actor -- ^ the new bead++moveActor_free time force actor+ -- move a bead+ | Bead ix stuck radius pos vel <- actor+ = let -- assume all beads have the same mass.+ beadMass = 1+ + -- calculate the new position and velocity of the bead.+ pos' = (pos + time `mulSV` vel)+ vel' = (vel + (time / beadMass) `mulSV` force)++ -- if the bead is travelling slowly then set it as being stuck.+ stuck' + | magV vel' < 20+ = min beadStuckCount (stuck + 1)++ | otherwise + = max 0 (stuck - 2)++ in Bead ix stuck' radius pos' vel'++ -- walls don't move+ | Wall{} <- actor+ = actor
+ picture/Styrene/Collide.hs view
@@ -0,0 +1,167 @@+-- | Physics for bead bouncing.+module Collide where+import World+import Actor+import Graphics.Gloss.Data.Point+import Graphics.Gloss.Data.Vector+import Graphics.Gloss.Geometry++-- Config -----------------------------------------------------------------------------------------+-- How bouncy the beads are+-- at 0.2 and they look like melting plastic.+-- at 0.8 and they look like bouncy rubber balls.+-- at > 1 and they gain energy with each bounce and escape the box.+--+beadBeadLoss = 0.95+beadWallLoss = 0.8+++-- | Move a bead which is in contact with a wall.+collideBeadWall+ :: Actor -- ^ the bead + -> Actor -- ^ the wall that bead is in contact with+ -> Actor -- ^ the new bead++collideBeadWall+ bead@(Bead ix _ radius pBead vIn@(velX, velY))+ wall@(Wall _ pWall1 pWall2)++ = let -- Take the collision point as being the point on the wall which is + -- closest to the bead's center.+ pCollision = closestPointOnLine pWall1 pWall2 pBead+ + -- then do a static, non energy transfering collision.+ in collideBeadPoint_static + bead + pCollision+ beadWallLoss+++-- | Move two beads which have bounced into each other.+collideBeadBead_elastic+ :: Actor -> Actor+ -> (Actor, Actor)++collideBeadBead_elastic+ bead1@(Bead ix1 mode1 r1 p1 v1) + bead2@(Bead ix2 mode2 r2 p2 v2)++ = let mass1 = 1+ mass2 = 1++ -- the axis of collision (towards p2)+ vCollision@(cX, cY) = normaliseV (p2 - p1)+ vCollisionR = (cY, -cX)+ + -- the velocity component of each bead along the axis of collision+ s1 = dotV v1 vCollision+ s2 = dotV v2 vCollision++ -- work out new velocities along the collision+ s1' = (s1 * (mass1 - mass2) + 2 * mass2 * s2) / (mass1 + mass2)+ s2' = (s2 * (mass2 - mass1) + 2 * mass1 * s1) / (mass1 + mass2)+ + -- the velocity components at right angles to the collision+ -- there is no friction in the collision so these don't change+ k1 = dotV v1 vCollisionR+ k2 = dotV v2 vCollisionR+ + -- new bead velocities+ v1' = mulSV s1' vCollision + mulSV k1 vCollisionR+ v2' = mulSV s2' vCollision + mulSV k2 vCollisionR++ v1_slow = mulSV beadBeadLoss v1'+ v2_slow = mulSV beadBeadLoss v2'++ -- work out the point of collision+ u1 = r1 / (r1 + r2)+ u2 = r2 / (r1 + r2)++ pCollision + = p1 + mulSV u1 (p2 - p1)++ -- place the beads just next to each other so they are no longer overlapping.+ p1' = pCollision - (r1 + 0.001) `mulSV` vCollision+ p2' = pCollision + (r2 + 0.001) `mulSV` vCollision++ bead1' = Bead ix1 mode1 r1 p1' v1_slow+ bead2' = Bead ix2 mode2 r2 p2' v2_slow++ in (bead1', bead2')+++collideBeadBead_static+ :: Actor -> Actor + -> Actor+ +collideBeadBead_static+ bead1@(Bead ix1 _ radius1 pBead1 _)+ bead2@(Bead ix2 _ radius2 pBead2 _)++ = let -- Take the collision point as being between the center's of the two beads. + -- For beads which have the same radius the collision point is half way between+ -- their centers and u == 0.5+ u = radius1 / (radius1 + radius2)+ pCollision = pBead1 + mulSV u (pBead2 - pBead1)+ + bead1' = collideBeadPoint_static+ bead1+ pCollision+ beadBeadLoss+ in bead1'+++-- | Move a bead which has collided with something.+collideBeadPoint_static+ :: Actor -- ^ the bead which collided with something+ -> Point -- ^ the point of collision (should be near the bead's surface)+ -> Float -- ^ velocity scaling factor (how much to slow the bead down after the collision)+ -> Actor++collideBeadPoint_static+ bead@(Bead ix mode radius pBead vIn) + pCollision+ velLoss+ = let+ -- take a normal vector from the wall to the bead.+ -- this vector is at a right angle to the wall.+ vNormal = normaliseV (pBead - pCollision)+ + -- the bead at pBead is overlapping with what it collided with, but we don't want that.+ -- place the bead so it's surface is just next to the point of collision.+ pBead_new = pCollision + (radius + 0.01) `mulSV` vNormal++ -- work out the angle of incidence for the bounce.+ -- this is the angle between the surface normal and+ -- the direction of travel for the bead.+ aInc = angleVV vNormal (negate vIn)++ -- aInc2 is the angle between the wall /surface/ and+ -- the direction of travel.+ aInc2 = (pi / 2) - aInc++ -- take the determinant between the surface normal and the direction of travel.+ -- This will tell us what direction the bead hit the wall. + -- The diagram shows the sign of the determinant for the four possiblities.+ --+ -- \ +ve -ve /+ -- \ /+ -- \/ \/+ -- pWall1 ---------- pWall2 pWall1 ---------- pWall2+ -- /\ /\+ -- / \+ -- / -ve +ve \+ --+ determinant = detV vIn vNormal++ -- Use the determinant to rotate the bead's velocity vector for the bounce.+ vOut + | determinant > 0 = rotateV (2 * aInc2) vIn+ | otherwise = rotateV (negate (2 * aInc2)) vIn++ -- Slow down the bead when it hits the wall+ vSlow = velLoss `mulSV` vOut++ bead1_new = Bead ix mode radius pBead_new vSlow++ in bead1_new
+ picture/Styrene/Config.hs view
@@ -0,0 +1,46 @@++module Config where+import Graphics.Gloss++-- Number of simulation steps per second of time.+simResolution :: Int+simResolution = 300++-- How strongly the beads are pulled down to the bottom of the screen.+-- If this is too high wrt the simResoution then the simulation+-- will be unstable and beads will escape the box.+gravityCoeff :: Float+gravityCoeff = 300++-- Whether to draw velocity vectors on beads.+showBeadVelocity = False++-- Colors of things.+beadColor = makeColor 0.5 0.5 1.0 1.0+beadOutlineColor = makeColor 1.0 1.0 1.0 1.0+nodeColor = makeColor 0.2 0.8 0.2 0.1+leafColor = makeColor 0.8 0.2 0.2 0.1++-- The maximum depth of the quad tree.+treeMaxDepth :: Int+treeMaxDepth = 4++-- Size of quadtree. Should be > boxSize.+treeSize :: Float+treeSize = 300++-- Size of bead box.+boxSize :: Float+boxSize = 280++-- Bead setup.+beadRadius, beadSpace, beadCountX, beadCountY, beadBoxSize :: Float++beadRadius = 5+beadSpace = 1+beadBoxSize = 2 * beadRadius + beadSpace+beadCountX = 20+beadCountY = 10++beadStuckCount :: Int+beadStuckCount = 20
+ picture/Styrene/Contact.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE MagicHash, BangPatterns #-}++-- | Find actors in the world that are in contact with each other.+module Contact where+import World+import QuadTree+import Actor+import Graphics.Gloss.Data.Point+import Graphics.Gloss.Geometry.Line+import Data.Maybe+import Data.List+import GHC.Exts+import GHC.Prim+import Data.Map (Map)+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Map as Map+++-- Find all pairs of actors in the world that are in contact with each other.+findContacts + :: World + -> ( Set (Index, Index) -- ^ a set of all pairs of actors that are in contact.+ , QuadTree Actor) -- ^ also return the quadtree so we can draw it in the window.+ +findContacts (World actors _)+ = let + -- the initial tree has no actors in it and has a+ -- size of 300 (with is half the width of the box).+ treeInit = treeZero 300++ -- insert all the actors into the quadtree.+ tree' = Map.fold insertActor treeInit actors++ -- the potential contacts are lists of actors+ -- that _might_ be in contact.+ potentialContacts+ = treeElems tree'++ -- filter the lists of potential contacts to determine the actors+ -- which are _actually_ in contact.+ contactSet = makeContacts potentialContacts+ + in (contactSet, tree')+ ++-- | Make add all these test pairs to a map+-- normalise so the actor with the lowest ix is first in the pair.++makeContacts :: [[Actor]] -> Set (Index, Index)+makeContacts contactLists+ = makeContacts' Set.empty contactLists ++makeContacts' acc xx+ = case xx of+ -- no more potentials to add, return the current contact set+ [] -> acc++ -- add pairs of actors that are actually in contact to the contact set+ (list : lists)+ -> makeContacts' (makeTests acc list) lists+ +makeTests acc [] = acc+makeTests acc (x:xs)+ = makeTests (makeTests1 acc x xs) xs+ +makeTests1 acc a1 [] = acc+makeTests1 acc a1 (a2 : as)+ | inContact a1 a2+ = let k1 = actorIx a1+ k2 = actorIx a2+ contact = (min k1 k2, max k1 k2)+ acc' = Set.insert contact acc+ in makeTests1 acc' a1 as+ + | otherwise+ = makeTests1 acc a1 as+ ++-- See if these two actors are in contact+inContact :: Actor -> Actor -> Bool+inContact a1 a2+ | isBead a1 && isWall a2 = inContact_beadWall a1 a2+ | isWall a1 && isBead a2 = inContact_beadWall a2 a1+ | isBead a1 && isBead a2 = inContact_beadBead a1 a2+ | otherwise = False+++-- | Check whether a bead is in contact with a wall.+inContact_beadWall :: Actor -> Actor -> Bool+inContact_beadWall + bead@(Bead ix mode radius pBead _) + wall@(Wall _ pWall1 pWall2)++ = let -- work out the point on the infinite line between pWall1 and pWall2+ -- which is closest to the bead.+ pClosest = closestPointOnLine pWall1 pWall2 pBead++ -- the distance between the bead center and pClosest + -- needs to be less than the bead radius for them to touch.+ !(F# radius#) = radius+ closeEnough = distancePP_contact pBead pClosest `ltFloat#` radius#++ -- uParam gives where pClosest is relative to the endponts of the wall+ uParam = closestPointOnLineParam pWall1 pWall2 pBead++ -- pClosest needs to lie on the line segment between pWal1 and pWall2+ inSegment = uParam >= 0 && uParam <= 1++ in closeEnough && inSegment+++-- | Check whether a bead is in concat with another bead.+inContact_beadBead :: Actor -> Actor -> Bool+inContact_beadBead + bead1@(Bead ix1 _ radius1 pBead1 _) + bead2@(Bead ix2 _ radius2 pBead2 _)+ =let !dist# = distancePP_contact pBead1 pBead2+ !(F# rad) = radius1 + radius2+ in (dist# `ltFloat#` rad ) && (dist# `gtFloat#` 0.1#)+++-- | Return the distance between these two points.+{-# INLINE distancePP_contact #-}+distancePP_contact :: Point -> Point -> Float#+distancePP_contact (F# x1, F# y1) (F# x2, F# y2)+ = sqrtFloat# (xd2 `plusFloat#` yd2)+ where !xd = x2 `minusFloat#` x1+ !xd2 = xd `timesFloat#` xd++ !yd = y2 `minusFloat#` y1+ !yd2 = yd `timesFloat#` yd
+ picture/Styrene/Main.hs view
@@ -0,0 +1,117 @@++import Actor+import Advance+import QuadTree+import Contact+import Collide+import World+import Config++import Graphics.Gloss+import Graphics.Gloss.Geometry+import Graphics.Gloss.Interface.Pure.Simulate+import Graphics.Gloss.Data.Vector++import qualified Data.Map as Map+import Data.Map (Map)++main + = simulate + (InWindow "Polystyrene - right-click-drag rotates"+ (600, 600) -- x and y size of window (in pixels).+ (10, 10)) -- position of window+ black -- background color+ simResolution -- simulation resolution + -- (number of steps to take for each second of time)+ worldInit -- the initial world.+ drawWorld -- a function to convert the world to a Picture.+ advanceWorld -- a function to advance the world to+ -- the next simulation step.++-- Draw --------------------------------------------------------------------------------------------++-- | Draw this world as a picture.+drawWorld :: World -> Picture+drawWorld (World actors tree)+ = let + -- split the list of actors into beads and walls.+ -- this lets us draw all the beads at once without having to keep changing + -- the current color (which is a bit of a performance improvement)+ (beads, walls) = splitActors $ Map.elems actors+ + picBeads = Color beadColor $ Pictures $ map drawActor beads+ picWalls = Pictures $ map drawActor walls+ picTree = drawQuadTree tree++ in Scale 0.8 0.8+ $ Pictures [picTree, picWalls, picBeads]+++-- | Split actors into beads and walls+splitActors :: [Actor] -> ([Actor], [Actor])+splitActors as+ = splitActors' [] [] as++splitActors' accBeads accWalls [] + = (accBeads, accWalls)++splitActors' accBeads accWalls (a : as) + = case a of+ Bead{} -> splitActors' (a : accBeads) accWalls as+ Wall{} -> splitActors' accBeads (a : accWalls) as+++-- | Draw an actor as a picture.+drawActor :: Actor -> Picture +drawActor actor + = case actor of+ Bead ix mode radius p@(posX, posY) v@(velX, velY)+ -> Translate posX posY $ Pictures [bead, vel]+ where bead = circleFilled radius 10+ vel = if showBeadVelocity+ then Color red $ Line [(0, 0), mulSV 0.1 v]+ else Blank+{- color+ | mode >= beadStuckCount = red+ | otherwise = beadColor+-} + Wall _ p1 p2+ -> Color (greyN 0.8) $ Line [p1, p2]+++-- | Draw a quadtree as a picture+drawQuadTree :: QuadTree a -> Picture+drawQuadTree tree + = case tree of+ QNode p size tTL tTR tBL tBR+ -> Pictures+ [ drawQuadTree tTL + , drawQuadTree tTR+ , drawQuadTree tBL+ , drawQuadTree tBR+ , nodeBox p size nodeColor ]++ QLeaf p size elems+ -> nodeBox p size leafColor+ + QNil (x0, y0) size+ -> Blank++nodeBox p@(x0, y0) size color+ = Color color+ $ Translate x0 y0+ $ rectangleWire (size*2) (size*2)+++-- Make a circle of radius r consisting of n lines.+circleFilled :: Float -> Float -> Picture+circleFilled r n+ = Scale r r+ $ Polygon (circlePoints n)+ + +-- A list of n points spaced equally around the unit circle.+circlePoints :: Float -> [(Float, Float)]+circlePoints n+ = map (\d -> (cos d, sin d))+ [0, 2*pi / n .. 2*pi]
+ picture/Styrene/QuadTree.hs view
@@ -0,0 +1,90 @@++module QuadTree + ( QuadTree(..)+ , treeZero+ , treeInsert+ , treeElems )+where+import Graphics.Gloss.Data.Point++data QuadTree a+ -- Nil cells take up space in the world, but don't contain any elements.+ -- They can be at any depth in the tree.+ = QNil !Point -- cell center point + !Float -- cell size++ -- Leaf cells are the only ones that contain elements.+ -- They are always at the bottom of the tree.+ | QLeaf !Point -- cell center point + !Float -- cell size+ ![a] -- elements in this cell++ -- Node cells contain more sub-trees+ | QNode !Point -- cell center point+ !Float -- cell size+ !(QuadTree a) !(QuadTree a) -- NW NE+ !(QuadTree a) !(QuadTree a) -- SW SE+ + deriving (Eq, Show)+++-- Initial -----------------------------------------------------------------------------------------+treeZero size+ = QNil (0, 0) size++-- Quadrant ----------------------------------------------------------------------------------------++-- | Insert an element with a bounding box into the tree+treeInsert + :: Int -- ^ maximum depth to place a leaf+ -> Int -- ^ current depth+ -> Point -- ^ bottom left of bounding box of new element+ -> Point -- ^ top right of bounding box of new element+ -> a -- ^ element to insert into tree+ -> QuadTree a -- ^ current tree+ -> QuadTree a++treeInsert depthMax depth p0@(x0, y0) p1@(x1, y1) a tree+ = case tree of+ QNode p@(x, y) size tNW tNE tSW tSE+ -> let + + tNW' | y1 > y && x0 < x = treeInsert depthMax (depth + 1) p0 p1 a tNW+ | otherwise = tNW++ tNE' | y1 > y && x1 > x = treeInsert depthMax (depth + 1) p0 p1 a tNE+ | otherwise = tNE++ tSW' | y0 < y && x0 < x = treeInsert depthMax (depth + 1) p0 p1 a tSW+ | otherwise = tSW++ tSE' | y0 < y && x1 > x = treeInsert depthMax (depth + 1) p0 p1 a tSE+ | otherwise = tSE+ + in QNode p size tNW' tNE' tSW' tSE'+ + QLeaf p@(x, y) size elems+ | depth >= depthMax+ -> QLeaf p size (a : elems)+ + QNil p@(x, y) size+ | depth >= depthMax+ -> QLeaf p size [a]+ + | otherwise+ -> treeInsert depthMax depth p0 p1 a+ (let s2 = size / 2+ in QNode p size + (QNil (x - s2, y + s2) s2) (QNil (x + s2, y + s2) s2)+ (QNil (x - s2, y - s2) s2) (QNil (x + s2, y - s2) s2))+++-- flatten a quadtree into a list of its elements.+treeElems :: QuadTree a -> [[a]]+treeElems tree + = case tree of+ QNode _ _ tNW tNE tSW tSE+ -> treeElems tNW ++ treeElems tNE ++ treeElems tSW ++ treeElems tSE+ + QLeaf _ _ elems -> [elems]+ QNil{} -> []
+ picture/Styrene/World.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE PatternGuards #-}++-- The world contains a map of all the actors, along with the current+-- quadtree so we can also draw it on the screen.+module World where++import QuadTree+import Actor+import Config++import qualified Data.Map as Map+import Data.Map (Map)++-- The world ---------------------------------------------------------------------------------------+data World + = World (Map Index Actor) -- actors+ (QuadTree Actor) -- tree++-- | The initial world+worldInit :: World+worldInit + = World actorMapInit treeInit++actorMapInit + = Map.fromList + $ map (\a -> (actorIx a, a))+ $ (walls ++ beads)++treeInit = treeZero treeSize+++-- Walls ------------------+walls :: [Actor]+walls = zipWith actorSetIndex (box ++ splitter) [10000 ..]++box :: [Actor]+box+ = let bs = boxSize+ in [ Wall 0 (- bs, -bs) (bs, -bs) -- bot+ , Wall 0 (- bs, bs) (bs, bs) -- top++ , Wall 0 (- bs, -bs) (-bs, bs) -- left+ , Wall 0 ( bs, -bs) ( bs, bs)] -- right++splitter :: [Actor]+splitter+ = [ Wall 0 (-15, -100) (-200, 0) + , Wall 0 ( 15, -100) ( 200, 0) ]+++-- Beads ------------------+beads :: [Actor]+beads + = let -- beads start off with their index just set to 0+ beads_raw+ = [Bead 0 0 beadRadius (beadPos ix iy) (0, 0)+ | ix <- [0 .. beadCountX - 1]+ , iy <- [0 .. beadCountY - 1 ] ]+ + -- set the unique index on the beads before returning them+ in zipWith actorSetIndex beads_raw [0..]+ +beadPos ix iy + = ( (ix * beadBoxSize) - (beadBoxSize * beadCountX / 2)+ , (iy * beadBoxSize) )+++-- QuadTree ----------------------------------------------------------------------------------------++-- | insert an actor into the tree+insertActor :: Actor -> QuadTree Actor -> QuadTree Actor++insertActor actor tree+ -- insert a bead into the tree+ | bead@(Bead ix _ radius pos@(x, y) vel) <- actor+ = let+ -- the bottom left and top right of the bead's bounding box.+ p0 = (x - radius, y - radius)+ p1 = (x + radius, y + radius)++ in treeInsert treeMaxDepth 0 p0 p1 bead tree++ | wall@(Wall ix (x0, y0) (x1, y1)) <- actor+ = let+ -- the bottom left and top right of the wall's bounding box.+ p0 = (min x0 x1, min y0 y1)+ p1 = (max x0 x1, max y0 y1)+ + in treeInsert treeMaxDepth 0 p0 p1 wall tree+
+ picture/Tree/Main.hs view
@@ -0,0 +1,54 @@++-- | Tree Fractal.+-- Based on ANUPlot code by Clem Baker-Finch.+-- +import Graphics.Gloss++main = animate (InWindow "Tree" (500, 650) (20, 20))+ black (picture 4)+++-- The picture is a tree fractal, graded from brown to green+picture :: Int -> Float -> Picture +picture degree time+ = Translate 0 (-300)+ $ tree degree time (dim $ dim brown)+++-- Basic stump shape+stump :: Color -> Picture+stump color + = Color color+ $ Polygon [(30,0), (15,300), (-15,300), (-30,0)]+++-- Make a tree fractal.+tree :: Int -- Fractal degree+ -> Float -- time+ -> Color -- Color for the stump+ -> Picture++tree 0 time color = stump color+tree n time color + = let smallTree + = Rotate (sin time)+ $ Scale 0.5 0.5 + $ tree (n-1) (- time) (greener color)+ in Pictures+ [ stump color+ , Translate 0 300 $ smallTree+ , Translate 0 240 $ Rotate 20 smallTree+ , Translate 0 180 $ Rotate (-20) smallTree+ , Translate 0 120 $ Rotate 40 smallTree+ , Translate 0 60 $ Rotate (-40) smallTree ]+ ++-- A starting colour for the stump+brown :: Color+brown = makeColor8 139 100 35 255+++-- Make this color a little greener+greener :: Color -> Color+greener c = mixColors 1 10 green c+
+ picture/Visibility/Draw.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE PatternGuards #-}+module Draw+ ( drawState+ , drawWorld)+where+import State+import World+import Geometry.Segment+import Graphics.Gloss+import Graphics.Gloss.Geometry.Line+import qualified Data.Vector.Unboxed as V+import Data.Maybe+++drawState :: State -> Picture+drawState state+ | ModeDisplayWorld <- stateModeDisplay state+ = drawWorldWithViewPos + (stateModeOverlay state)+ (stateViewPos state) + (stateTargetPos state)+ (stateWorld state)++ | ModeDisplayNormalised <- stateModeDisplay state+ = drawWorldWithViewPos + (stateModeOverlay state)+ (0, 0) + Nothing+ $ normaliseWorld (stateViewPos state)+ $ stateWorld state++ | otherwise+ = Blank+ ++drawWorldWithViewPos :: ModeOverlay -> Point -> Maybe Point -> World -> Picture+drawWorldWithViewPos + modeOverlay+ pView@(vx, vy) + mTarget+ world+ = let + -- the world + picWorld = Color white+ $ drawWorld world++ -- view position indicator+ picView = Color red+ $ Translate vx vy+ $ ThickCircle 2 4++ -- target position indicator+ picTargets+ | Just pTarget@(px, py) <- mTarget+ = let picTarget = Translate px py $ ThickCircle 2 4++ -- line between view and target pos+ picLine = Line [pView, pTarget]+ + picSegsHit = Pictures+ $ [ Line [p1, p2]+ | (_, p1, p2) <- V.toList $ worldSegments world+ , isJust $ intersectSegSeg p1 p2 pView pTarget ]+ in Color red $ Pictures [picTarget, picLine, picSegsHit]++ | otherwise+ = blank++ -- overlay+ picOverlay+ | ModeOverlayVisApprox <- modeOverlay+ = drawVisGrid 10 pView world++ | otherwise+ = blank++ in Pictures [picOverlay, picWorld, picView, picTargets]+++-- | Draw a grid of points showing what is visible from a view position+drawVisGrid :: Float -> Point -> World -> Picture+drawVisGrid cellSize pView world+ = let + visible pTarget = not $ any isJust+ $ map (\(_, p1, p2) -> intersectSegSeg pView pTarget p1 p2)+ $ V.toList + $ worldSegments world+ + picGrid = Pictures+ $ [ if visible (x, y) + then Color (dim green) $ Translate x y $ rectangleSolid cellSize cellSize+ else Color (greyN 0.2) $ Translate x y $ rectangleSolid cellSize cellSize+ | x <- [-400, -400 + cellSize .. 400]+ , y <- [-400, -400 + cellSize .. 400] ]++ in picGrid+++-- | Draw the segments in the world.+drawWorld :: World -> Picture+drawWorld world+ = drawSegments+ $ worldSegments world+++-- | Draw an array of segments.+drawSegments :: V.Vector Segment -> Picture+drawSegments segments+ = Pictures+ $ map drawSegment+ $ V.toList + $ segments+++-- | Draw a single segment.+drawSegment :: Segment -> Picture+drawSegment (_, (x1, y1), (x2, y2))+ = Line [(f x1, f y1), (f x2, f y2)]+ where f = fromRational . toRational+
+ picture/Visibility/Geometry/Randomish.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE BangPatterns #-}++module Geometry.Randomish+ ( randomishPoints + , randomishInts+ , randomishDoubles)+where+import Data.Word+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed.Mutable as MV+import qualified Data.Vector.Unboxed as V++-- | Some uniformly distributed points+randomishPoints+ :: Int -- ^ seed+ -> Int -- ^ number of points+ -> Float -- ^ minimum coordinate+ -> Float -- ^ maximum coordinate+ -> V.Vector (Float, Float)++randomishPoints seed' n pointMin pointMax+ = let pts = randomishFloats (n*2) pointMin pointMax seed'+ xs = G.slice 0 n pts+ ys = G.slice n n pts+ in V.zip xs ys+++-- | Use the "minimal standard" Lehmer generator to quickly generate some random+-- numbers with reasonable statistical properties. By "reasonable" we mean good+-- enough for games and test data, but not cryptography or anything where the+-- quality of the randomness really matters.+-- +-- From "Random Number Generators: Good ones are hard to find"+-- Stephen K. Park and Keith W. Miller.+-- Communications of the ACM, Oct 1988, Volume 31, Number 10.+--+randomishInts + :: Int -- Length of vector.+ -> Int -- Minumum value in output.+ -> Int -- Maximum value in output.+ -> Int -- Random seed. + -> V.Vector Int -- Vector of random numbers.++randomishInts !len !valMin' !valMax' !seed'+ + = let -- a magic number (don't change it)+ multiplier :: Word64+ multiplier = 16807++ -- a merzenne prime (don't change it)+ modulus :: Word64+ modulus = 2^(31 :: Integer) - 1++ -- if the seed is 0 all the numbers in the sequence are also 0.+ seed + | seed' == 0 = 1+ | otherwise = seed'++ !valMin = fromIntegral valMin'+ !valMax = fromIntegral valMax' + 1+ !range = valMax - valMin++ {-# INLINE f #-}+ f x = multiplier * x `mod` modulus+ in G.create + $ do + vec <- MV.new len++ let go !ix !x + | ix == len = return ()+ | otherwise+ = do let x' = f x+ MV.write vec ix $ fromIntegral $ (x `mod` range) + valMin+ go (ix + 1) x'++ go 0 (f $ f $ f $ fromIntegral seed)+ return vec+++-- | Generate some randomish doubles with terrible statistical properties.+-- This is good enough for test data, but not much else.+randomishDoubles + :: Int -- Length of vector+ -> Double -- Minimum value in output+ -> Double -- Maximum value in output+ -> Int -- Random seed.+ -> V.Vector Double -- Vector of randomish doubles.++randomishDoubles !len !valMin !valMax !seed+ = let range = valMax - valMin++ mx = 2^(30 :: Integer) - 1+ mxf = fromIntegral mx+ ints = randomishInts len 0 mx seed+ + in V.map (\n -> valMin + (fromIntegral n / mxf) * range) ints+++-- | Generate some randomish doubles with terrible statistical properties.+-- This is good enough for test data, but not much else.+randomishFloats+ :: Int -- Length of vector+ -> Float -- Minimum value in output+ -> Float -- Maximum value in output+ -> Int -- Random seed.+ -> V.Vector Float -- Vector of randomish doubles.++randomishFloats !len !valMin !valMax !seed+ = let range = valMax - valMin++ mx = 2^(30 :: Integer) - 1+ mxf = fromIntegral mx+ ints = randomishInts len 0 mx seed+ + in V.map (\n -> valMin + (fromIntegral n / mxf) * range) ints
+ picture/Visibility/Geometry/Segment.hs view
@@ -0,0 +1,81 @@++module Geometry.Segment+ ( Segment+ , translateSegment+ , splitSegmentsOnY+ , splitSegmentsOnX+ , chooseSplitX)+where+import Graphics.Gloss+import Graphics.Gloss.Geometry.Line+import Data.Maybe+import Data.Function+import qualified Data.Vector.Unboxed as V++-- | A line segement in the 2D plane.+type Segment = (Int, (Float, Float), (Float, Float))+++-- | Translate both endpoints of a segment.+translateSegment :: Float -> Float -> Segment -> Segment+translateSegment tx ty (n, (x1, y1), (x2, y2))+ = (n, (x1 + tx, y1 + ty), (x2 + tx, y2 + ty))+ ++-- | Split segments that cross the line y = y0, for some y0.+splitSegmentsOnY :: Float -> V.Vector Segment -> V.Vector Segment+splitSegmentsOnY y0 segs+ = let + -- TODO: we only need to know IF the seg crosse the line here,+ -- not the actual intersection point. Do a faster test.+ (segsCross, segsOther)+ = V.unstablePartition + (\(_, p1, p2) -> isJust $ intersectSegHorzLine p1 p2 y0)+ segs++ -- TODO: going via lists here is bad.+ splitCrossingSeg :: Segment -> V.Vector Segment+ splitCrossingSeg (n, p1, p2)+ = let Just pCross = intersectSegHorzLine p1 p2 y0+ in V.fromList [(n, p1, pCross), (n, pCross, p2)]+ + -- TODO: vector append requires a copy. + in segsOther V.++ (V.concat $ map splitCrossingSeg $ V.toList segsCross)+++-- | Split segments that cross the line x = x0, for some x0.+splitSegmentsOnX :: Float -> V.Vector Segment -> V.Vector Segment+splitSegmentsOnX x0 segs+ = let + -- TODO: we only need to know IF the seg crosse the line here,+ -- not the actual intersection point. Do a faster test.+ (segsCross, segsOther)+ = V.unstablePartition + (\(_, p1, p2) -> isJust $ intersectSegVertLine p1 p2 x0)+ segs++ -- TODO: going via lists here is bad.+ splitCrossingSeg :: Segment -> V.Vector Segment+ splitCrossingSeg (n, p1, p2)+ = let Just pCross = intersectSegVertLine p1 p2 x0+ in V.fromList [(n, p1, pCross), (n, pCross, p2)]+ + -- TODO: vector append requires a copy. + in segsOther V.++ (V.concat $ map splitCrossingSeg $ V.toList segsCross)+++-- | Decide where to split the plane.+-- TODO: We're just taking the first point of the segment in the middle of the vector.+-- It might be better to base the split on:+-- - the closest segment+-- - the widest sgement+-- - the one closes to the middle of the field.+-- - some combination of above.+--+chooseSplitX :: V.Vector Segment -> Float+chooseSplitX segments+ = let Just (_, (x1, _), _) = segments V.!? (V.length segments `div` 2)+ in x1+++
+ picture/Visibility/Interface.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE PatternGuards #-}+module Interface+ ( handleInput+ , stepState)+where+import State+import qualified Graphics.Gloss.Interface.Pure.Game as G++-- Input ------------------------------------------------------------------------------------------+-- | Handle an input event.+handleInput :: G.Event -> State -> State++handleInput (G.EventKey key keyState _ (x, y)) state+ -- move the view position.+ | G.MouseButton G.LeftButton <- key+ , G.Down <- keyState+ = state { stateModeInterface = ModeInterfaceMove + , stateViewPos+ = ( fromRational $ toRational x+ , fromRational $ toRational y) }++ -- set the target position.+ | G.MouseButton G.RightButton <- key+ , G.Down <- keyState+ = state { stateTargetPos+ = Just ( fromRational $ toRational x+ , fromRational $ toRational y) }++ | G.MouseButton G.LeftButton <- key+ , G.Up <- keyState+ = state { stateModeInterface = ModeInterfaceIdle }++handleInput (G.EventMotion (x, y)) state+ | stateModeInterface state == ModeInterfaceMove+ = state { stateViewPos+ = ( fromRational $ toRational x+ , fromRational $ toRational y) }++-- t : Turn target indicator off.+handleInput (G.EventKey key keyState _ _) state+ | G.Char 't' <- key+ , G.Down <- keyState+ = state { stateTargetPos = Nothing }++-- w : Display the whole world.+handleInput (G.EventKey key keyState _ _) state+ | G.Char 'w' <- key+ , G.Down <- keyState+ = state { stateModeDisplay = ModeDisplayWorld }++-- n : Display the normalised world.+handleInput (G.EventKey key keyState _ _) state+ | G.Char 'n' <- key+ , G.Down <- keyState+ = state { stateModeDisplay = ModeDisplayNormalised }++-- a : Toggle approximate visibility+handleInput (G.EventKey key keyState _ _) state+ | G.Char 'a' <- key+ , G.Down <- keyState+ = state { stateModeOverlay+ = case stateModeOverlay state of+ ModeOverlayVisApprox -> ModeOverlayNone+ _ -> ModeOverlayVisApprox } ++handleInput _ state+ = state++-- Step -------------------------------------------------------------------------------------------+-- | Advance the state one iteration+stepState :: Float -> State -> State+stepState _ state = state
+ picture/Visibility/Main.hs view
@@ -0,0 +1,27 @@++-- | Visibility on the 2D plane.+-- Uses an instance of Warnocks algorithm.+-- TODO: animate the line segments, make them spin and move around so we can see+-- that it's a dynamic visiblity algorithm -- not pre-computed.+-- Draw lines in random shades of color depending on the index.+-- Make a key to swap between rectangular and polar projections.+-- Allow viewpoint to be set with the mouse.+--+-- TODO: To start with just do brute force visibility by dividing field into cells+-- and doing vis based on center point of cell.+--++import Interface+import Draw+import State+import World+import Graphics.Gloss.Interface.Pure.Game++main :: IO ()+main+ = do world <- initialWorld+ let state = initialState world+ + play (InWindow "Visibility" (800, 800) (10, 10))+ black 100 state+ drawState handleInput stepState
+ picture/Visibility/State.hs view
@@ -0,0 +1,59 @@++-- | Game state+module State where+import Graphics.Gloss+import World+++-- | The game state.+data State+ = State+ { stateWorld :: World+ , stateModeInterface :: ModeInterface+ , stateModeDisplay :: ModeDisplay+ , stateModeOverlay :: ModeOverlay+ , stateViewPos :: Point + , stateTargetPos :: Maybe Point }+++-- | What mode the interface interaction is in.+data ModeInterface+ -- | We're not doing anything inparticular.+ = ModeInterfaceIdle++ -- | We're moving the view position.+ | ModeInterfaceMove+ deriving (Show, Eq)+++-- | What mode the display is in.+data ModeDisplay+ -- | Show the world in rectangular coordinates.+ = ModeDisplayWorld++ -- | Show the world normalised so the view position is at the origin.+ | ModeDisplayNormalised+ deriving (Show, Eq)+++-- | What overlay to display.+data ModeOverlay+ -- | No overlay+ = ModeOverlayNone+ + -- | Brute force, approximate visibility+ | ModeOverlayVisApprox+ deriving (Show, Eq)+++-- | Initial game state.+initialState :: World -> State+initialState world+ = State+ { stateWorld = world+ , stateModeInterface = ModeInterfaceIdle+ , stateModeDisplay = ModeDisplayWorld+ , stateModeOverlay = ModeOverlayVisApprox+ , stateViewPos = (0, 0) + , stateTargetPos = Nothing }+
+ picture/Visibility/World.hs view
@@ -0,0 +1,54 @@++module World+ ( Segment+ , World(..)+ , initialWorld+ , normaliseWorld)+where+import Graphics.Gloss+import Geometry.Randomish+import Geometry.Segment+import qualified Data.Vector.Unboxed as V+++-- We keep this unpacked so we can use unboxed vector.+-- index, x1, y1, x2, y2+data World + = World+ { worldSegments :: V.Vector Segment }+++-- | Generate the initial world.+initialWorld :: IO World+initialWorld+ = do let n = 100+ let minZ = -300+ let maxZ = 300+ + let minDelta = -100+ let maxDelta = 100+ + let centers = randomishPoints 1234 n minZ maxZ+ let deltas = randomishPoints 4321 n minDelta maxDelta++ let makePoint n' (cX, cY) (dX, dY)+ = (n', (cX, cY), (cX + dX, cY + dY))++ let segs = V.zipWith3 makePoint (V.enumFromTo 0 (n - 1)) centers deltas+ + return $ World segs+++-- | Normalise the world so that the given point is at the origin,+-- and split segements that cross the y=0 line.+normaliseWorld :: Point -> World -> World +normaliseWorld (px, py) world+ = let segments_trans = V.map (translateSegment (-px) (-py)) + $ worldSegments world+ + segments_split = splitSegmentsOnY 0 segments_trans+ + in world { worldSegments = segments_split }+++
+ picture/Zen/Main.hs view
@@ -0,0 +1,64 @@++-- A nifty animated fractal of a tree, superimposed on a background +-- of three red rectangles.+import Graphics.Gloss++main :: IO ()+main + = animate (InWindow "Zen" (800, 600) (5, 5))+ (greyN 0.2)+ frame +++-- Produce one frame of the animation.+frame :: Float -> Picture+frame timeS+ = Pictures + -- the red rectangles+ [ Translate 0 150 backRec+ , Translate 0 0 backRec+ , Translate 0 (-150) backRec++ -- the tree+ , Translate 0 (-150) $ treeFrac 7 timeS+ ]+++-- One of the red backing rectangles, with a white outline.+backRec :: Picture+backRec + = Pictures+ [ Color red (rectangleSolid 400 100)+ , Color white (rectangleWire 400 100) ]+++-- The color for the outline of the tree's branches.+treeOutline :: Color+treeOutline = makeColor 0.3 0.3 1.0 1.0+++-- The color for the shading of the tree's branches.+-- The Alpha here is set to 0.5 so the branches are partly transparent.+treeColor :: Color+treeColor = makeColor 0.0 1.0 0.0 0.5+++-- The tree fractal.+-- The position of the branches changes depending on the animation time+-- as well as the iteration number of the fractal.+treeFrac :: Int -> Float -> Picture+treeFrac 0 timeS = Blank+treeFrac n timeS+ = Pictures+ [ Color treeColor $ rectangleUpperSolid 20 300+ , Color treeOutline $ rectangleUpperWire 20 300+ , Translate 0 30+ $ Rotate (200 * sin timeS / (fromIntegral n) )+ $ Scale 0.9 0.9 + $ treeFrac (n-1) timeS++ , Translate 0 70+ $ Rotate (-200 * sin timeS / (fromIntegral n))+ $ Scale 0.8 0.8 + $ treeFrac (n-1) timeS+ ]
+ raster/Crystal/Main.hs view
@@ -0,0 +1,107 @@++-- Quasicrystals demo. +-- +-- Based on code from:+-- http://mainisusuallyafunction.blogspot.com/2011/10/quasicrystals-as-sums-of-waves-in-plane.html+--+{-# LANGUAGE BangPatterns #-}+import Graphics.Gloss.Raster.Field+import System.Environment++-- Types ----------------------------------------------------------------------+-- | Angle in radians.+type Angle = Float++-- | Angle offset used for animation.+type Phi = Float++-- | Number of waves to sum for each pixel.+type Degree = Int++-- | Feature size of visualisation.+type Scale = Float++-- | Time in seconds since the program started.+type Time = Float+++-- Point ----------------------------------------------------------------------+-- | Compute a single point of the visualisation.+quasicrystal :: Scale -> Degree -> Time -> Point -> Color+quasicrystal !scale !degree !time !p+ = let -- Scale the time to be the phi value of the animation.+ -- The action seems to slow down at increasing phi values, + -- so we increase phi faster as time moves on.+ phi = 1 + (time ** 1.5) * 0.005++ in rampColor + $ waves degree phi+ $ point scale p+++-- | Sum up all the waves at a particular point.+waves :: Degree -> Phi -> Point -> Float+waves !degree !phi !x = wrap $ waver 0 degree+ where+ !th = pi / phi++ waver :: Float -> Int -> Float+ waver !acc !n+ | n == 0 = acc+ | otherwise = waver (acc + wave (fromIntegral n * th) x)+ (n - 1)+ + wrap n + = let !n_ = truncate n :: Int+ !n' = n - fromIntegral n_+ in if odd n_ then 1 - n'+ else n'+++-- | Generate the value for a single wave.+wave :: Angle -> Point -> Float+wave !th = f where+ !cth = cos th+ !sth = sin th++ {-# INLINE f #-}+ f (x, y) = (cos (cth*x + sth*y) + 1) / 2+++-- | Convert an image point to a point on our wave plane.+point :: Scale -> Point -> Point+point !scale (x, y) = (x * scale, y * scale)+++-- | Color ramp from blue to white.+rampColor :: Float -> Color+rampColor v+ = rawColor v (0.4 + (v * 0.6)) 1 1+++-- Main -----------------------------------------------------------------------+main :: IO ()+main + = do args <- getArgs+ case args of+ [] -> run 800 600 2 30 5++ [sizeX, sizeY, zoom, scale, degree]+ -> run (read sizeX) (read sizeY) (read zoom) (read scale) (read degree)++ _ -> putStr $ unlines+ [ "quazicrystal <sizeX::Int> <sizeY::Int> <zoom::Int> <scale::Float> <degree::Int>"+ , " sizeX, sizeY - visualisation size (default 800, 600)"+ , " zoom - pixel replication factor (default 5)"+ , " scale - feature size of visualisation (default 30)"+ , " degree - number waves to sum for each point (default 5)" + , ""+ , " You'll want to run this with +RTS -N to enable threads" ]+ ++run :: Int -> Int -> Int -> Scale -> Degree -> IO () +run sizeX sizeY zoom scale degree+ = animateField (InWindow "Crystal" (sizeX, sizeY) (10, 10)) + (zoom, zoom)+ (quasicrystal scale degree)+
+ raster/Pulse/Main.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE BangPatterns #-}+import Graphics.Gloss.Raster.Field++main :: IO ()+main + = let get :: Float -> Point -> Color+ get !t _ = makeColor t t t 1.0+ {-# INLINE get #-}+ + in animateField + (InWindow "Pulse" (800, 600) (100, 100))+ (1, 1) get
+ raster/Ray/Light.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE BangPatterns #-}++module Light + ( Light(..)+ , translateLight+ , applyLights)+where+import Object+import Vec3+++-- | A primitive light+data Light+ -- | A point light source, intensity drops off with distance from the point.+ = Light+ { lightPoint :: !Vec3+ , lightColor :: !Color }+ deriving (Eq, Show)++translateLight :: Vec3 -> Light -> Light+translateLight v ll+ = case ll of+ Light pos color -> Light (pos + v) color+{-# INLINE translateLight #-}+++-- | Compute the direct lighting at particular point for a list of lights.+applyLights+ :: [Object] -- ^ Possible occluding objects, used for shadows.+ -> Vec3 -- ^ Point which is being lit.+ -> Vec3 -- ^ Surface normal at this point.+ -> [Light] -- ^ Lights to consider.+ -> Color -- ^ Total lighting at this point.++applyLights !objs !point !normal !lights+ = go lights (Vec3 0 0 0)+ where go [] !total = total+ go (light:rest) !total+ = let !contrib = applyLight objs point normal light+ in go rest (total + contrib)+{-# INLINE applyLights #-}+++-- | Compute the direct lighting at a particular point for a single light.+applyLight+ :: [Object] -- possible occluding objects, used for shadows.+ -> Vec3 -- point which is being lit+ -> Vec3 -- surface normal at this point+ -> Light + -> Color++applyLight !objs !point !normal !(Light lpoint color)+ = let -- vector from the light to the surface point+ !dir = normaliseV3 (lpoint - point)++ -- distance from light source to surface+ !dist = magnitudeV3 (lpoint - point)++ -- check for occluding objects between the light and the surface point+ in if checkRay objs point dir dist+ then Vec3 0 0 0+ else let -- magnitude of reflection+ !mag = (normal `dotV3` dir) / (dist * dist)++ -- the light that is reflected+ !refl = color `mulsV3` mag+ in refl+{-# INLINE applyLight #-} +
+ raster/Ray/Main.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE BangPatterns, PatternGuards #-}+import World+import Trace+import Light+import Object+import Vec3+import System.Environment+import qualified Graphics.Gloss as G+import qualified Graphics.Gloss.Interface.Pure.Game as G+import qualified Graphics.Gloss.Raster.Field as G++main :: IO ()+main + = do args <- getArgs+ case args of+ [] -> run 800 600 4 100 4++ [sizeX, sizeY, zoom, fov, bounces]+ -> run (read sizeX) (read sizeY) (read zoom) (read fov) (read bounces)++ _ -> putStr $ unlines+ [ "trace <sizeX::Int> <sizeY::Int> <zoom::Int> (fov::Int) (bounces::Int)"+ , " sizeX, sizeY - visualisation size (default 800, 600)"+ , " zoom - pixel replication factor (default 4)"+ , " fov - field of view (default 100)"+ , " bounces - ray bounce limit (default 4)"+ , ""+ , " You'll want to run this with +RTS -N to enable threads" ]+ ++-- | World and interface state.+data State+ = State+ { stateTime :: !Float + , stateEyePos :: !Vec3+ , stateEyeLoc :: !Vec3++ , stateLeftClick :: !(Maybe G.Point)++ , stateMoveSpeed :: !Float+ , stateMovingForward :: !Bool+ , stateMovingBackward :: !Bool+ , stateMovingLeft :: !Bool+ , stateMovingRight :: !Bool++ , stateObjects :: ![Object]+ , stateObjectsView :: ![Object]++ , stateLights :: ![Light]+ , stateLightsView :: ![Light] }++ deriving (Eq, Show)+++-- | Initial world and interface state.+initState :: State+initState+ = State+ { stateTime = 0+ , stateEyePos = Vec3 50 (-100) (-700)+ , stateEyeLoc = Vec3 (-50) 200 1296++ , stateLeftClick = Nothing ++ , stateMoveSpeed = 400+ , stateMovingForward = False+ , stateMovingBackward = False+ , stateMovingLeft = False+ , stateMovingRight = False++ , stateObjects = makeObjects 0+ , stateObjectsView = makeObjects 0++ , stateLights = makeLights 0+ , stateLightsView = makeLights 0 }+++-- | Run the game.+run :: Int -> Int -> Int -> Int -> Int -> IO () +run sizeX sizeY zoom fov bounces+ = G.playField + (G.InWindow "Ray" (sizeX, sizeY) (10, 10))+ (zoom, zoom)+ 100+ initState+ (tracePixel sizeX sizeY fov bounces)+ handleEvent+ advanceState+{-# NOINLINE run #-}+++-- | Render a single pixel of the image.+tracePixel :: Int -> Int -> Int -> Int -> State -> G.Point -> G.Color+tracePixel !sizeX !sizeY !fov !bounces !state (x, y)+ = let !sizeX' = fromIntegral sizeX+ !sizeY' = fromIntegral sizeY+ !aspect = sizeX' / sizeY'+ !fov' = fromIntegral fov+ !fovX = fov' * aspect+ !fovY = fov'+ + !ambient = Vec3 0.3 0.3 0.3+ !eyePos = stateEyePos state+ !eyeDir = normaliseV3 ((Vec3 (x * fovX) ((-y) * fovY) 0) - eyePos)++ Vec3 r g b+ = traceRay (stateObjectsView state) + (stateLightsView state) ambient+ eyePos eyeDir+ bounces++ in G.rawColor r g b 1.0+{-# INLINE tracePixel #-}+++-- | Handle an event from the user interface.+handleEvent :: G.Event -> State -> State+handleEvent event state + -- Start translation.+ | G.EventKey (G.MouseButton G.LeftButton) + G.Down _ (x, y) <- event+ = state { stateLeftClick = Just (x, y)}++ -- End transation.+ | G.EventKey (G.MouseButton G.LeftButton) + G.Up _ _ <- event+ = state { stateLeftClick = Nothing }++ -- Moving forward+ | G.EventKey (G.Char 'w') G.Down _ _ <- event+ = state { stateMovingForward = True }++ | G.EventKey (G.Char 'w') G.Up _ _ <- event+ = state { stateMovingForward = False }++ -- Moving backward+ | G.EventKey (G.Char 's') G.Down _ _ <- event+ = state { stateMovingBackward = True }++ | G.EventKey (G.Char 's') G.Up _ _ <- event+ = state { stateMovingBackward = False }++ -- Moving left+ | G.EventKey (G.Char 'a') G.Down _ _ <- event+ = state { stateMovingLeft = True }++ | G.EventKey (G.Char 'a') G.Up _ _ <- event+ = state { stateMovingLeft = False }++ -- Moving right+ | G.EventKey (G.Char 'd') G.Down _ _ <- event+ = state { stateMovingRight = True }++ | G.EventKey (G.Char 'd') G.Up _ _ <- event+ = state { stateMovingRight = False }++ -- Translate the world.+ | G.EventMotion (x, y) <- event+ , Just (oX, oY) <- stateLeftClick state+ , Vec3 eyeX eyeY eyeZ <- stateEyeLoc state+ = let eyeX' = eyeX + (x - oX)+ eyeY' = eyeY+ eyeZ' = eyeZ + (y - oY)++ in setEyeLoc (Vec3 eyeX' eyeY' eyeZ')+ $ state { stateLeftClick = Just (x, y) }+ + | otherwise+ = state+{-# NOINLINE handleEvent #-}+++-- | Advance the world forward in time.+advanceState :: Float -> State -> State+advanceState advTime state+ = let time' = stateTime state + advTime++ speed = stateMoveSpeed state+ move = (if stateMovingForward state + then moveEyeLoc (Vec3 0 0 (-speed * advTime))+ else id)+ . (if stateMovingBackward state+ then moveEyeLoc (Vec3 0 0 (speed * advTime))+ else id)+ . (if stateMovingLeft state+ then moveEyeLoc (Vec3 (speed * advTime) 0 0)+ else id)+ . (if stateMovingRight state+ then moveEyeLoc (Vec3 (-speed * advTime) 0 0)+ else id)++ in setTime time' $ move state+{-# NOINLINE advanceState #-}+++-- | Set the location of the eye.+setEyeLoc :: Vec3 -> State -> State+setEyeLoc eyeLoc state+ = let objects = makeObjects (stateTime state)+ lights = makeLights (stateTime state)+ in state + { stateEyeLoc = eyeLoc+ , stateObjectsView = map (translateObject (stateEyeLoc state)) objects+ , stateLightsView = map (translateLight (stateEyeLoc state)) lights + }+{-# NOINLINE setEyeLoc #-}+++moveEyeLoc :: Vec3 -> State -> State+moveEyeLoc v state+ = let objects = stateObjects state+ lights = stateLights state+ eyeLoc = stateEyeLoc state + v+ in state+ { stateEyeLoc = eyeLoc+ , stateObjectsView = map (translateObject eyeLoc) objects+ , stateLightsView = map (translateLight eyeLoc) lights+ }+{-# NOINLINE moveEyeLoc #-}+++-- | Set the time of the world.+setTime :: Float -> State -> State+setTime time state+ = let objects = makeObjects time+ lights = makeLights time+ in state + { stateTime = time+ , stateObjects = objects+ , stateObjectsView = map (translateObject (stateEyeLoc state)) objects++ , stateLights = lights+ , stateLightsView = map (translateLight (stateEyeLoc state)) lights + }+{-# NOINLINE setTime #-}
+ raster/Ray/Object.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE BangPatterns #-}++module Object + ( Color+ , Object(..)+ , translateObject+ , castRay+ , castRay_continuation+ , checkRay+ , surfaceNormal+ , colorOfObject+ , shineOfObject)+where+import Vec3++type Color = Vec3++-- | An object in the world+data Object+ = Sphere+ { spherePos :: !Vec3+ , sphereRadius :: !Float+ , sphereColor :: !Color+ , sphereShine :: !Float }++ | Plane+ { planePos :: !Vec3+ , planeNormal :: !Vec3+ , planeColor :: !Color+ , planeShine :: !Float }++ | PlaneCheck+ { planeCheckPos :: !Vec3+ , planeCheckNormal :: !Vec3+ , planeCheckShine :: !Float }+ deriving (Eq, Show)+++translateObject :: Vec3 -> Object -> Object+translateObject v obj+ = case obj of+ Sphere{} -> obj { spherePos = spherePos obj + v }+ Plane{} -> obj { planePos = planePos obj + v }+ PlaneCheck{} -> obj { planeCheckPos = planeCheckPos obj + v }+{-# INLINE translateObject #-}+++-- | Find the nearest point of intersection for a ray+castRay :: [Object] -- check for intersections on all these objects+ -> Vec3 -- ray origin+ -> Vec3 -- ray direction+ -> Maybe + ( Object -- object of first intersected+ , Vec3) -- position of intersection, on surface of object++castRay !objs !orig !dir+ = go0 objs+ where -- We haven't hit any objects yet.+ go0 [] = Nothing+ go0 (obj:rest) + = case distanceToObject obj orig dir of+ Nothing -> go0 rest+ Just dist -> go1 rest obj dist++ -- We hit an object before, and we're testing others+ -- to see if they're closer.+ go1 [] !objClose !dist + = Just (objClose, orig + dir `mulsV3` dist)++ go1 (obj:rest) !objClose !dist+ = case distanceToObject obj orig dir of+ Nothing -> go1 rest objClose dist+ Just dist'+ | dist' < dist -> go1 rest obj dist'+ | otherwise -> go1 rest objClose dist+{-# INLINE castRay #-}+++-- | Like castRay, but take continuations for the Nothing and Just branches to +-- eliminate intermediate unboxings.+castRay_continuation+ :: [Object] -- check for intersections on all these objects+ -> Vec3 -- ray origin+ -> Vec3 -- ray direction++ -> a -- continuation when no intersection + -> (Object -> Vec3 -> a) -- continuation with intersection+ -> a++castRay_continuation !objs !orig !dir contNone contJust+ = go0 objs+ where -- We haven't hit any objects yet.+ go0 [] = contNone+ go0 (obj:rest) + = case distanceToObject obj orig dir of+ Nothing -> go0 rest+ Just dist -> go1 rest obj dist++ -- We hit an object before, and we're testing others+ -- to see if they're closer.+ go1 [] !objClose !dist + = contJust objClose (orig + dir `mulsV3` dist)++ go1 (obj:rest) !objClose !dist+ = case distanceToObject obj orig dir of+ Nothing -> go1 rest objClose dist+ Just dist'+ | dist' < dist -> go1 rest obj dist'+ | otherwise -> go1 rest objClose dist+{-# INLINE castRay_continuation #-}+++-- | Simplified version of `castRay` that only checks whether there is some+-- object closer than a given mimimum distance.+checkRay :: [Object] -- ^ Check for intersection on all these objects.+ -> Vec3 -- ^ Ray origin.+ -> Vec3 -- ^ Ray direction.+ -> Float -- ^ Minimum distance.+ -> Bool+ +checkRay !objs !orig !dir !dist+ = go0 objs+ where go0 [] = False+ go0 (obj:rest)+ = case distanceToObject obj orig dir of+ Nothing -> go0 rest+ Just dist'+ | dist' < dist -> True+ | otherwise -> go0 rest+{-# INLINE checkRay #-} +++-- | Compute the distance to the surface of this shape+distanceToObject+ :: Object -- ^ Towards this object.+ -> Vec3 -- ^ Start from this point.+ -> Vec3 -- ^ Along this ray.+ -> Maybe Float -- ^ Distance to intersection, if there is one.++distanceToObject !obj !orig !dir+ = case obj of+ Sphere pos radius _ _+ -> let !p = orig + dir `mulsV3` ((pos - orig) `dotV3` dir) + !d_cp = magnitudeV3 (p - pos)+ in if d_cp >= radius then Nothing+ else if (p - orig) `dotV3` dir <= 0.0 then Nothing+ else Just $ magnitudeV3 (p - orig) - sqrt (radius * radius - d_cp * d_cp)++ Plane pos normal _ _+ -> if dotV3 dir normal >= 0.0 + then Nothing+ else Just (((pos - orig) `dotV3` normal) / (dir `dotV3` normal))++ PlaneCheck pos normal _+ -> if dotV3 dir normal >= 0.0 + then Nothing+ else Just (((pos - orig) `dotV3` normal) / (dir `dotV3` normal))+{-# INLINE distanceToObject #-}++ +-- | Compute the surface normal of the shape at this point+surfaceNormal + :: Object+ -> Vec3 -- ^ A point on the surface of the shape.+ -> Vec3++surfaceNormal obj point+ = case obj of+ Sphere pos _ _ _ -> normaliseV3 (point - pos)+ Plane _ normal _ _ -> normal+ PlaneCheck _ normal _ -> normal+{-# INLINE surfaceNormal #-}+++-- | Get the color of an object at the given point.+colorOfObject :: Object -> Vec3 -> Color+colorOfObject obj point+ = case obj of+ Sphere _ _ c _ -> c+ Plane _ _ c _ -> c+ PlaneCheck{} -> checkers point+{-# INLINE colorOfObject #-}+++-- | Get the shine of an object at the given point.+shineOfObject :: Object -> Vec3 -> Float+shineOfObject obj _point+ = case obj of + Sphere _ _ _ s -> s+ Plane _ _ _ s -> s+ PlaneCheck _ _ s -> s+{-# INLINE shineOfObject #-}++ +-- | A checkerboard pattern along the x/z coords+checkers :: Vec3 -> Vec3+checkers (Vec3 x _ z)+ | ((truncate (z / 100.0) :: Int)`mod` 2 == 0)+ `xor` ((truncate (x / 100.0) :: Int) `mod` 2 == 0)+ `xor` (x < 0.0)+ `xor` (z < 0.0)+ = Vec3 1.0 1.0 1.0+ + | otherwise+ = Vec3 0.4 0.4 0.4+++xor :: Bool -> Bool -> Bool+xor x1 x2+ = case (x1, x2) of+ (False, False) -> False+ (False, True) -> True+ (True, False) -> True+ (True, True) -> False+{-# INLINE xor #-}
+ raster/Ray/Trace.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE BangPatterns #-}++module Trace where+import Object+import Light+import Vec3+++-- Cast a single ray into the scene+traceRay+ :: [Object] -- objects in scene+ -> [Light] -- direct lights in scene+ -> Color -- ambient light in scene+ -> Vec3 -- origin of ray+ -> Vec3 -- direction of ray+ -> Int -- maximum reflection count+ -> Color -- visible color for this ray+ +traceRay !objs !lights !ambient !(Vec3 gX gY gZ) !dir !limit+ = go gX gY gZ dir limit+ where + -- too many reflections,+ -- give up incase we've found two parallel mirrors..+ go _ _ _ _ 0+ = Vec3 0.0 0.0 0.0++ go !oX !oY oZ !dir' !bounces+ = castRay_continuation objs (Vec3 oX oY oZ) dir' + -- ray didn't intersect any objects+ (Vec3 0.0 0.0 0.0)++ -- ray hit an object+ (\obj point@(Vec3 pX' pY' pZ')+ -> let + -- get the surface normal at that point.+ !normal = surfaceNormal obj point++ -- result angle of ray after reflection.+ !newdir = dir - normal `mulsV3` (2.0 * (normal `dotV3` dir))+ + -- determine the direct lighting at this point+ !direct = applyLights objs point normal lights++ -- see if ray hits anything else.+ !refl = go pX' pY' pZ' newdir (bounces - 1)++ -- total lighting is the direct lights plus ambient+ !lighting = direct + ambient+ + -- total incoming light is direct lighting plus reflections+ !color = colorOfObject obj point+ !shine = shineOfObject obj point+ + !light_in = refl `mulsV3` shine + + lighting `mulsV3` (1.0 - shine)+ + -- Outgoing light is incoming light modified by surface color.+ -- We also need to clip it incase the sum of all incoming lights+ -- will be too bright to display.+ !light_out = clipV3 (light_in * color) 1.0++ in light_out)+{-# INLINE traceRay #-}
+ raster/Ray/Vec3.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS -fno-warn-missing-methods #-}++module Vec3+ ( Vec3(..)+ , magnitudeV3+ , normaliseV3+ , mulsV3+ , dotV3+ , clampV3+ , clipV3)+where+++data Vec3+ = Vec3 !Float !Float !Float+ deriving (Eq, Show)+++instance Num Vec3 where+ (+) (Vec3 x1 x2 x3) (Vec3 y1 y2 y3)+ = Vec3 (x1 + y1) (x2 + y2) (x3 + y3)+ {-# INLINE (+) #-}++ (-) (Vec3 x1 x2 x3) (Vec3 y1 y2 y3)+ = Vec3 (x1 - y1) (x2 - y2) (x3 - y3)+ {-# INLINE (-) #-}++ (*) (Vec3 x1 x2 x3) (Vec3 y1 y2 y3)+ = Vec3 (x1 * y1) (x2 * y2) (x3 * y3)+ {-# INLINE (*) #-}+++-- | Yield the magnitude of a vector.+magnitudeV3 :: Vec3 -> Float+magnitudeV3 (Vec3 x y z)+ = sqrt (x * x + y * y + z * z)+{-# INLINE magnitudeV3 #-}+++-- | Normalise a vector to have unit length.+normaliseV3 :: Vec3 -> Vec3+normaliseV3 v+ = v `mulsV3` (1.0 / magnitudeV3 v) +{-# INLINE normaliseV3 #-}+++-- | Multiply a vector by a scalar.+mulsV3 :: Vec3 -> Float -> Vec3 +mulsV3 (Vec3 x1 y1 z1) s+ = Vec3 (s * x1) (s * y1) (s * z1)+{-# INLINE mulsV3 #-}+++-- | Compute the dot product of two vectors.+dotV3 :: Vec3 -> Vec3 -> Float+dotV3 (Vec3 x1 y1 z1) (Vec3 x2 y2 z2)+ = x1 * x2 + y1 * y2 + z1 * z2+{-# INLINE dotV3 #-}+++-- | Clamp a vectors components to some minimum and maximum values.+clampV3 :: Vec3 -> Float -> Float -> Vec3+clampV3 (Vec3 r g b) minVal maxVal+ = Vec3 (clamp r) (clamp g) (clamp b)+ where {-# INLINE clamp #-}+ clamp x + | x <= minVal = minVal+ | x >= maxVal = maxVal+ | otherwise = x+{-# INLINE clampV3 #-}+++-- | Clip a vector's components to some maxiumum value.+clipV3 :: Vec3 -> Float -> Vec3+clipV3 (Vec3 r g b) maxVal+ = Vec3 (clip r) (clip g) (clip b)+ where {-# INLINE clip #-}+ clip x+ | x > maxVal = maxVal+ | otherwise = x+{-# INLINE clipV3 #-}
+ raster/Ray/World.hs view
@@ -0,0 +1,57 @@+++module World+ ( makeLights+ , makeObjects)+where +import Object+import Light+import Vec3+++-- | Lights in the world+{-# NOINLINE makeLights #-}+makeLights :: Float -> [Light]+makeLights _ =+ [ Light+ (Vec3 300.0 (-300.0) (-100.0))+ (Vec3 150000.0 150000.0 150000.0) ]++ +-- | Objects in the world+{-# NOINLINE makeObjects #-}+makeObjects :: Float -> [Object]+makeObjects time =+ [ Sphere + (Vec3 (40 * sin time) 80 0.0)+ 20+ (Vec3 1.0 0.3 1.0)+ 0.4+ + , Sphere+ (Vec3 (200 * sin time) + ((-40) * sin (time + pi/2))+ (200 * cos time))+ 100.0+ (Vec3 0.4 0.4 1.0)+ 0.8++ , Sphere+ (Vec3 (-200.0 * sin time) + ((-40) * sin (time - pi/2))+ (-200 * cos time))+ 100.0+ (Vec3 0.4 0.4 1.0)+ 0.5++ , Sphere+ (Vec3 0.0 (-150.0) (-100.0)) 50.0+ (Vec3 1.0 1.0 1.0)+ 0.8+ + , PlaneCheck+ (Vec3 0.0 100.0 0.0)+ (normaliseV3 (Vec3 0 (-1) (-0.2)))+ 0.2++ ]
+ raster/Wave/Main.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE BangPatterns, MagicHash #-}+import Graphics.Gloss.Raster.Field+import qualified Data.Vector.Unboxed as U+import GHC.Prim+import GHC.Exts++main :: IO ()+main + = let !n = 65536++ !sins = U.fromList [sin ( (i / n) * (2 * pi)) | i <- [0..n]]++ usin :: Float -> Float+ usin x = U.unsafeIndex sins (to64k x)+ {-# INLINE usin #-}++ ucos :: Float -> Float+ ucos x = U.unsafeIndex sins (to64k (x + 0.5))+ {-# INLINE ucos #-}++ get :: Float -> Point -> Color+ get !t (x, y)+ = t `seq` + let !x' = abs $ x + 1+ !y' = abs $ y + 1+ !r1 = abs $ 0.5 * (usin (x' + 0.2 * (usin t)) + ucos y')+ !r2 = abs $ 0.5 * (usin y' + usin (0.3 * t))+ in makeColor' r1 0 r2 1.0+ {-# INLINE get #-}++ in animateField + (InWindow "Wave" (1500, 1000) (100, 100))+ (1, 1)+ get+++-- | Map a signed floating point value to a 64k range.+--+-- The range [0 .. 1] maps to [0 .. 65535]+to64k :: Float -> Int+to64k f+ = let !(F# f') = f * 65536+ w = int2Word# (float2Int# f')+ w' = and# w (int2Word# 0x0ffff#)+ i = word2Int# w'+ in (I# i)+{-# INLINE to64k #-} ++