diff --git a/Bitmap/Main.hs b/Bitmap/Main.hs deleted file mode 100644 --- a/Bitmap/Main.hs +++ /dev/null @@ -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 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] diff --git a/Boids/KDTree2d.hs b/Boids/KDTree2d.hs deleted file mode 100644 --- a/Boids/KDTree2d.hs +++ /dev/null @@ -1,175 +0,0 @@ -{-# LANGUAGE BangPatterns #-} --- KDTree code --- by Matthew Sottile --- -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 - diff --git a/Boids/Main.hs b/Boids/Main.hs deleted file mode 100644 --- a/Boids/Main.hs +++ /dev/null @@ -1,354 +0,0 @@ --- Implementation of the Boids flocking algorithm. --- by Matthew Sottile --- 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 - diff --git a/Boids/Vec2.hs b/Boids/Vec2.hs deleted file mode 100644 --- a/Boids/Vec2.hs +++ /dev/null @@ -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 - diff --git a/Clock/Main.hs b/Clock/Main.hs deleted file mode 100644 --- a/Clock/Main.hs +++ /dev/null @@ -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)] ] diff --git a/Conway/Cell.hs b/Conway/Cell.hs deleted file mode 100644 --- a/Conway/Cell.hs +++ /dev/null @@ -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 - - diff --git a/Conway/Main.hs b/Conway/Main.hs deleted file mode 100644 --- a/Conway/Main.hs +++ /dev/null @@ -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) - diff --git a/Conway/World.hs b/Conway/World.hs deleted file mode 100644 --- a/Conway/World.hs +++ /dev/null @@ -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 } - - diff --git a/Draw/Main.hs b/Draw/Main.hs deleted file mode 100644 --- a/Draw/Main.hs +++ /dev/null @@ -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 - diff --git a/Easy/Main.hs b/Easy/Main.hs deleted file mode 100644 --- a/Easy/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ - -import Graphics.Gloss -main = display (InWindow "My Window" (200, 200) (10, 10)) white (Circle 80) diff --git a/Eden/Cell.hs b/Eden/Cell.hs deleted file mode 100644 --- a/Eden/Cell.hs +++ /dev/null @@ -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 diff --git a/Eden/Community.hs b/Eden/Community.hs deleted file mode 100644 --- a/Eden/Community.hs +++ /dev/null @@ -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 diff --git a/Eden/Main.hs b/Eden/Main.hs deleted file mode 100644 --- a/Eden/Main.hs +++ /dev/null @@ -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 - - diff --git a/Eden/World.hs b/Eden/World.hs deleted file mode 100644 --- a/Eden/World.hs +++ /dev/null @@ -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 diff --git a/Flake/Main.hs b/Flake/Main.hs deleted file mode 100644 --- a/Flake/Main.hs +++ /dev/null @@ -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] - - - diff --git a/GameEvent/Main.hs b/GameEvent/Main.hs deleted file mode 100644 --- a/GameEvent/Main.hs +++ /dev/null @@ -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) - - diff --git a/Hello/Main.hs b/Hello/Main.hs deleted file mode 100644 --- a/Hello/Main.hs +++ /dev/null @@ -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 diff --git a/Lifespan/Cell.hs b/Lifespan/Cell.hs deleted file mode 100644 --- a/Lifespan/Cell.hs +++ /dev/null @@ -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 diff --git a/Lifespan/Community.hs b/Lifespan/Community.hs deleted file mode 100644 --- a/Lifespan/Community.hs +++ /dev/null @@ -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] - - diff --git a/Lifespan/Main.hs b/Lifespan/Main.hs deleted file mode 100644 --- a/Lifespan/Main.hs +++ /dev/null @@ -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 - - - diff --git a/Lifespan/World.hs b/Lifespan/World.hs deleted file mode 100644 --- a/Lifespan/World.hs +++ /dev/null @@ -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 diff --git a/Machina/Main.hs b/Machina/Main.hs deleted file mode 100644 --- a/Machina/Main.hs +++ /dev/null @@ -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)] diff --git a/Occlusion/Cell.hs b/Occlusion/Cell.hs deleted file mode 100644 --- a/Occlusion/Cell.hs +++ /dev/null @@ -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) - diff --git a/Occlusion/Data.hs b/Occlusion/Data.hs deleted file mode 100644 --- a/Occlusion/Data.hs +++ /dev/null @@ -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#..............................#" ] diff --git a/Occlusion/Main.hs b/Occlusion/Main.hs deleted file mode 100644 --- a/Occlusion/Main.hs +++ /dev/null @@ -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) - diff --git a/Occlusion/State.hs b/Occlusion/State.hs deleted file mode 100644 --- a/Occlusion/State.hs +++ /dev/null @@ -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 - diff --git a/Occlusion/World.hs b/Occlusion/World.hs deleted file mode 100644 --- a/Occlusion/World.hs +++ /dev/null @@ -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) - - diff --git a/Styrene/Actor.hs b/Styrene/Actor.hs deleted file mode 100644 --- a/Styrene/Actor.hs +++ /dev/null @@ -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 diff --git a/Styrene/Advance.hs b/Styrene/Advance.hs deleted file mode 100644 --- a/Styrene/Advance.hs +++ /dev/null @@ -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 diff --git a/Styrene/Collide.hs b/Styrene/Collide.hs deleted file mode 100644 --- a/Styrene/Collide.hs +++ /dev/null @@ -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 diff --git a/Styrene/Config.hs b/Styrene/Config.hs deleted file mode 100644 --- a/Styrene/Config.hs +++ /dev/null @@ -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 diff --git a/Styrene/Contact.hs b/Styrene/Contact.hs deleted file mode 100644 --- a/Styrene/Contact.hs +++ /dev/null @@ -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 diff --git a/Styrene/Main.hs b/Styrene/Main.hs deleted file mode 100644 --- a/Styrene/Main.hs +++ /dev/null @@ -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] diff --git a/Styrene/QuadTree.hs b/Styrene/QuadTree.hs deleted file mode 100644 --- a/Styrene/QuadTree.hs +++ /dev/null @@ -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{} -> [] diff --git a/Styrene/World.hs b/Styrene/World.hs deleted file mode 100644 --- a/Styrene/World.hs +++ /dev/null @@ -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 - diff --git a/Tree/Main.hs b/Tree/Main.hs deleted file mode 100644 --- a/Tree/Main.hs +++ /dev/null @@ -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 - diff --git a/Visibility/Draw.hs b/Visibility/Draw.hs deleted file mode 100644 --- a/Visibility/Draw.hs +++ /dev/null @@ -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 - diff --git a/Visibility/Geometry/Randomish.hs b/Visibility/Geometry/Randomish.hs deleted file mode 100644 --- a/Visibility/Geometry/Randomish.hs +++ /dev/null @@ -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 diff --git a/Visibility/Geometry/Segment.hs b/Visibility/Geometry/Segment.hs deleted file mode 100644 --- a/Visibility/Geometry/Segment.hs +++ /dev/null @@ -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 - - - diff --git a/Visibility/Interface.hs b/Visibility/Interface.hs deleted file mode 100644 --- a/Visibility/Interface.hs +++ /dev/null @@ -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 diff --git a/Visibility/Main.hs b/Visibility/Main.hs deleted file mode 100644 --- a/Visibility/Main.hs +++ /dev/null @@ -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 diff --git a/Visibility/State.hs b/Visibility/State.hs deleted file mode 100644 --- a/Visibility/State.hs +++ /dev/null @@ -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 } - diff --git a/Visibility/World.hs b/Visibility/World.hs deleted file mode 100644 --- a/Visibility/World.hs +++ /dev/null @@ -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 } - - - diff --git a/Zen/Main.hs b/Zen/Main.hs deleted file mode 100644 --- a/Zen/Main.hs +++ /dev/null @@ -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 - ] diff --git a/gloss-examples.cabal b/gloss-examples.cabal --- a/gloss-examples.cabal +++ b/gloss-examples.cabal @@ -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 + + diff --git a/picture/Bitmap/Main.hs b/picture/Bitmap/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Bitmap/Main.hs @@ -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 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] diff --git a/picture/Boids/KDTree2d.hs b/picture/Boids/KDTree2d.hs new file mode 100644 --- /dev/null +++ b/picture/Boids/KDTree2d.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE BangPatterns #-} +-- KDTree code +-- by Matthew Sottile +-- +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 + diff --git a/picture/Boids/Main.hs b/picture/Boids/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Boids/Main.hs @@ -0,0 +1,354 @@ +-- Implementation of the Boids flocking algorithm. +-- by Matthew Sottile +-- 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 + diff --git a/picture/Boids/Vec2.hs b/picture/Boids/Vec2.hs new file mode 100644 --- /dev/null +++ b/picture/Boids/Vec2.hs @@ -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 + diff --git a/picture/Clock/Main.hs b/picture/Clock/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Clock/Main.hs @@ -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)] ] diff --git a/picture/Conway/Cell.hs b/picture/Conway/Cell.hs new file mode 100644 --- /dev/null +++ b/picture/Conway/Cell.hs @@ -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 + + diff --git a/picture/Conway/Main.hs b/picture/Conway/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Conway/Main.hs @@ -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) + diff --git a/picture/Conway/World.hs b/picture/Conway/World.hs new file mode 100644 --- /dev/null +++ b/picture/Conway/World.hs @@ -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 } + + diff --git a/picture/Draw/Main.hs b/picture/Draw/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Draw/Main.hs @@ -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 + diff --git a/picture/Easy/Main.hs b/picture/Easy/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Easy/Main.hs @@ -0,0 +1,3 @@ + +import Graphics.Gloss +main = display (InWindow "My Window" (200, 200) (10, 10)) white (Circle 80) diff --git a/picture/Eden/Cell.hs b/picture/Eden/Cell.hs new file mode 100644 --- /dev/null +++ b/picture/Eden/Cell.hs @@ -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 diff --git a/picture/Eden/Community.hs b/picture/Eden/Community.hs new file mode 100644 --- /dev/null +++ b/picture/Eden/Community.hs @@ -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 diff --git a/picture/Eden/Main.hs b/picture/Eden/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Eden/Main.hs @@ -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 + + diff --git a/picture/Eden/World.hs b/picture/Eden/World.hs new file mode 100644 --- /dev/null +++ b/picture/Eden/World.hs @@ -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 diff --git a/picture/Flake/Main.hs b/picture/Flake/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Flake/Main.hs @@ -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] + + + diff --git a/picture/GameEvent/Main.hs b/picture/GameEvent/Main.hs new file mode 100644 --- /dev/null +++ b/picture/GameEvent/Main.hs @@ -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) + + diff --git a/picture/Hello/Main.hs b/picture/Hello/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Hello/Main.hs @@ -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 diff --git a/picture/Lifespan/Cell.hs b/picture/Lifespan/Cell.hs new file mode 100644 --- /dev/null +++ b/picture/Lifespan/Cell.hs @@ -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 diff --git a/picture/Lifespan/Community.hs b/picture/Lifespan/Community.hs new file mode 100644 --- /dev/null +++ b/picture/Lifespan/Community.hs @@ -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] + + diff --git a/picture/Lifespan/Main.hs b/picture/Lifespan/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Lifespan/Main.hs @@ -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 + + + diff --git a/picture/Lifespan/World.hs b/picture/Lifespan/World.hs new file mode 100644 --- /dev/null +++ b/picture/Lifespan/World.hs @@ -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 diff --git a/picture/Machina/Main.hs b/picture/Machina/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Machina/Main.hs @@ -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)] diff --git a/picture/Occlusion/Cell.hs b/picture/Occlusion/Cell.hs new file mode 100644 --- /dev/null +++ b/picture/Occlusion/Cell.hs @@ -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) + diff --git a/picture/Occlusion/Data.hs b/picture/Occlusion/Data.hs new file mode 100644 --- /dev/null +++ b/picture/Occlusion/Data.hs @@ -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#..............................#" ] diff --git a/picture/Occlusion/Main.hs b/picture/Occlusion/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Occlusion/Main.hs @@ -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) + diff --git a/picture/Occlusion/State.hs b/picture/Occlusion/State.hs new file mode 100644 --- /dev/null +++ b/picture/Occlusion/State.hs @@ -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 + diff --git a/picture/Occlusion/World.hs b/picture/Occlusion/World.hs new file mode 100644 --- /dev/null +++ b/picture/Occlusion/World.hs @@ -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) + + diff --git a/picture/Styrene/Actor.hs b/picture/Styrene/Actor.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Actor.hs @@ -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 diff --git a/picture/Styrene/Advance.hs b/picture/Styrene/Advance.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Advance.hs @@ -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 diff --git a/picture/Styrene/Collide.hs b/picture/Styrene/Collide.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Collide.hs @@ -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 diff --git a/picture/Styrene/Config.hs b/picture/Styrene/Config.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Config.hs @@ -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 diff --git a/picture/Styrene/Contact.hs b/picture/Styrene/Contact.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Contact.hs @@ -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 diff --git a/picture/Styrene/Main.hs b/picture/Styrene/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Main.hs @@ -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] diff --git a/picture/Styrene/QuadTree.hs b/picture/Styrene/QuadTree.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/QuadTree.hs @@ -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{} -> [] diff --git a/picture/Styrene/World.hs b/picture/Styrene/World.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/World.hs @@ -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 + diff --git a/picture/Tree/Main.hs b/picture/Tree/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Tree/Main.hs @@ -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 + diff --git a/picture/Visibility/Draw.hs b/picture/Visibility/Draw.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/Draw.hs @@ -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 + diff --git a/picture/Visibility/Geometry/Randomish.hs b/picture/Visibility/Geometry/Randomish.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/Geometry/Randomish.hs @@ -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 diff --git a/picture/Visibility/Geometry/Segment.hs b/picture/Visibility/Geometry/Segment.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/Geometry/Segment.hs @@ -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 + + + diff --git a/picture/Visibility/Interface.hs b/picture/Visibility/Interface.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/Interface.hs @@ -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 diff --git a/picture/Visibility/Main.hs b/picture/Visibility/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/Main.hs @@ -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 diff --git a/picture/Visibility/State.hs b/picture/Visibility/State.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/State.hs @@ -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 } + diff --git a/picture/Visibility/World.hs b/picture/Visibility/World.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/World.hs @@ -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 } + + + diff --git a/picture/Zen/Main.hs b/picture/Zen/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Zen/Main.hs @@ -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 + ] diff --git a/raster/Crystal/Main.hs b/raster/Crystal/Main.hs new file mode 100644 --- /dev/null +++ b/raster/Crystal/Main.hs @@ -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, 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) + diff --git a/raster/Pulse/Main.hs b/raster/Pulse/Main.hs new file mode 100644 --- /dev/null +++ b/raster/Pulse/Main.hs @@ -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 diff --git a/raster/Ray/Light.hs b/raster/Ray/Light.hs new file mode 100644 --- /dev/null +++ b/raster/Ray/Light.hs @@ -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 #-} + diff --git a/raster/Ray/Main.hs b/raster/Ray/Main.hs new file mode 100644 --- /dev/null +++ b/raster/Ray/Main.hs @@ -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 (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 #-} diff --git a/raster/Ray/Object.hs b/raster/Ray/Object.hs new file mode 100644 --- /dev/null +++ b/raster/Ray/Object.hs @@ -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 #-} diff --git a/raster/Ray/Trace.hs b/raster/Ray/Trace.hs new file mode 100644 --- /dev/null +++ b/raster/Ray/Trace.hs @@ -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 #-} diff --git a/raster/Ray/Vec3.hs b/raster/Ray/Vec3.hs new file mode 100644 --- /dev/null +++ b/raster/Ray/Vec3.hs @@ -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 #-} diff --git a/raster/Ray/World.hs b/raster/Ray/World.hs new file mode 100644 --- /dev/null +++ b/raster/Ray/World.hs @@ -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 + + ] diff --git a/raster/Wave/Main.hs b/raster/Wave/Main.hs new file mode 100644 --- /dev/null +++ b/raster/Wave/Main.hs @@ -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 #-} + +