gloss-examples 1.9.2.1 → 1.9.3.1
raw patch · 41 files changed
+1493/−1456 lines, 41 filesdep ~basedep ~ghc-primdep ~gloss
Dependency ranges changed: base, ghc-prim, gloss, gloss-algorithms, gloss-raster, gloss-rendering, repa, repa-algorithms, repa-io
Files
- gloss-examples.cabal +111/−74
- picture/Bitmap/Main.hs +8/−8
- picture/Boids/Main.hs +1/−1
- picture/Clock/Main.hs +45/−45
- picture/Conway/Cell.hs +57/−57
- picture/Conway/Main.hs +41/−41
- picture/Conway/World.hs +64/−64
- picture/Eden/Cell.hs +19/−19
- picture/Eden/Community.hs +6/−6
- picture/Eden/Main.hs +7/−7
- picture/Eden/World.hs +15/−15
- picture/Flake/Main.hs +18/−18
- picture/Graph/Main.hs +1/−1
- picture/Hello/Main.hs +10/−10
- picture/Lifespan/Cell.hs +5/−5
- picture/Lifespan/Community.hs +2/−2
- picture/Lifespan/Main.hs +7/−7
- picture/Lifespan/World.hs +13/−13
- picture/Machina/Main.hs +19/−19
- picture/Occlusion/Cell.hs +22/−22
- picture/Occlusion/Data.hs +36/−36
- picture/Occlusion/Main.hs +70/−70
- picture/Occlusion/State.hs +21/−21
- picture/Occlusion/World.hs +79/−79
- picture/Styrene/Actor.hs +28/−28
- picture/Styrene/Advance.hs +83/−83
- picture/Styrene/Collide.hs +114/−114
- picture/Styrene/Config.hs +18/−18
- picture/Styrene/Contact.hs +75/−75
- picture/Styrene/Main.hs +55/−55
- picture/Styrene/QuadTree.hs +61/−61
- picture/Styrene/World.hs +48/−48
- picture/Tree/Main.hs +24/−24
- picture/Visibility/Draw.hs +73/−73
- picture/Visibility/Geometry/Randomish.hs +63/−63
- picture/Visibility/Geometry/Segment.hs +45/−45
- picture/Visibility/Interface.hs +39/−39
- picture/Visibility/Main.hs +6/−6
- picture/Visibility/State.hs +30/−30
- picture/Visibility/World.hs +26/−26
- picture/Zen/Main.hs +28/−28
gloss-examples.cabal view
@@ -1,5 +1,5 @@ Name: gloss-examples-Version: 1.9.2.1+Version: 1.9.3.1 License: MIT License-file: LICENSE Author: Ben Lippmeier@@ -17,16 +17,22 @@ Synopsis: Examples using the gloss library +Flag llvm+ Description: Compile via LLVM. This produces much better object code,+ but your GHC needs to have been built against the LLVM compiler.++ Default: False+ source-repository head type: git location: https://github.com/benl23x5/gloss Executable gloss-bitmap Build-depends:- base == 4.7.*,+ base == 4.8.*, bytestring == 0.10.*, bmp == 1.2.*,- gloss == 1.9.2.*+ gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: picture/Bitmap ghc-options: -threaded -O2@@ -34,8 +40,8 @@ Executable gloss-boids Build-depends:- base == 4.7.*,- gloss == 1.9.2.*+ base == 4.8.*,+ gloss == 1.9.3.* Main-is: Main.hs other-modules: KDTree2d Vec2 hs-source-dirs: picture/Boids@@ -44,8 +50,8 @@ Executable gloss-clock Build-depends: - base == 4.7.*,- gloss == 1.9.2.*+ base == 4.8.*,+ gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: picture/Clock ghc-options: -threaded -O2@@ -53,9 +59,9 @@ Executable gloss-conway Build-depends: - base == 4.7.*,+ base == 4.8.*, vector == 0.10.*,- gloss == 1.9.2.*+ gloss == 1.9.3.* Main-is: Main.hs other-modules: Cell World hs-source-dirs: picture/Conway@@ -64,8 +70,8 @@ Executable gloss-draw Build-depends:- base == 4.7.*,- gloss == 1.9.2.*+ base == 4.8.*,+ gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: picture/Draw ghc-options: -threaded -O2@@ -73,8 +79,8 @@ Executable gloss-easy Build-depends:- base == 4.7.*,- gloss == 1.9.2.*+ base == 4.8.*,+ gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: picture/Easy ghc-options: -threaded -O2@@ -82,9 +88,9 @@ Executable gloss-eden Build-depends: - base == 4.7.*,+ base == 4.8.*, random == 1.1.*,- gloss == 1.9.2.*+ gloss == 1.9.3.* Main-is: Main.hs other-modules: Cell Community World hs-source-dirs: picture/Eden@@ -93,8 +99,8 @@ Executable gloss-flake Build-depends:- base == 4.7.*,- gloss == 1.9.2.*+ base == 4.8.*,+ gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: picture/Flake ghc-options: -threaded -O2@@ -102,8 +108,8 @@ Executable gloss-gameevent Build-depends: - base == 4.7.*,- gloss == 1.9.2.*+ base == 4.8.*,+ gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: picture/GameEvent ghc-options: -threaded -O2@@ -111,8 +117,8 @@ Executable gloss-hello Build-depends: - base == 4.7.*, - gloss == 1.9.2.*+ base == 4.8.*, + gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: picture/Hello ghc-options: -threaded -O2@@ -120,8 +126,8 @@ Executable gloss-lifespan Build-depends: - base == 4.7.*, - gloss == 1.9.2.*,+ base == 4.8.*, + gloss == 1.9.3.*, random == 1.1.* Main-is: Main.hs other-modules: Cell Community World@@ -131,8 +137,8 @@ Executable gloss-machina Build-depends: - base == 4.7.*, - gloss == 1.9.2.*+ base == 4.8.*, + gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: picture/Machina ghc-options: -threaded -O2@@ -140,9 +146,9 @@ Executable gloss-occlusion Build-depends: - base == 4.7.*, - gloss == 1.9.2.*,- gloss-algorithms == 1.9.2.*+ base == 4.8.*, + gloss == 1.9.3.*,+ gloss-algorithms == 1.9.3.* Main-is: Main.hs other-modules: Cell World State Data hs-source-dirs: picture/Occlusion@@ -151,10 +157,10 @@ Executable gloss-styrene Build-depends: - base == 4.7.*,- ghc-prim == 0.3.*,+ base == 4.8.*,+ ghc-prim == 0.4.*, containers == 0.5.*,- gloss == 1.9.2.*+ gloss == 1.9.3.* Main-is: Main.hs other-modules: Actor Advance Collide Config Contact QuadTree World hs-source-dirs: picture/Styrene@@ -163,8 +169,8 @@ Executable gloss-tree Build-depends: - base == 4.7.*, - gloss == 1.9.2.*+ base == 4.8.*, + gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: picture/Tree ghc-options: -threaded -O2@@ -172,9 +178,9 @@ Executable gloss-visibility Build-depends: - base == 4.7.*, + base == 4.8.*, vector == 0.10.*,- gloss == 1.9.2.*+ gloss == 1.9.3.* Main-is: Main.hs other-modules: Draw Interface State World Geometry.Randomish Geometry.Segment hs-source-dirs: picture/Visibility @@ -183,8 +189,8 @@ Executable gloss-zen Build-depends: - base == 4.7.*, - gloss == 1.9.2.*+ base == 4.8.*, + gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: picture/Zen ghc-options: -threaded -O2@@ -192,27 +198,33 @@ Executable gloss-crystal Build-depends:- base == 4.7.*,- gloss == 1.9.2.*,- gloss-raster == 1.9.2.*+ base == 4.8.*,+ gloss == 1.9.3.*,+ gloss-raster == 1.9.3.* Main-is: Main.hs hs-source-dirs: raster/Crystal++ extensions:+ PatternGuards+ BangPatterns+ ghc-options: -Wall -threaded -rtsopts -eventlog -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000++ if flag(llvm)+ ghc-options: -fllvm -optlo-O3- extensions:- PatternGuards- BangPatterns+ Executable gloss-ray Build-depends:- base == 4.7.*,- gloss == 1.9.2.*,- gloss-raster == 1.9.2.*+ base == 4.8.*,+ gloss == 1.9.3.*,+ gloss-raster == 1.9.3.* Main-is: Main.hs other-modules: Light Object Trace Vec3 World hs-source-dirs: raster/Ray@@ -221,14 +233,17 @@ -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000++ if flag(llvm)+ ghc-options: -fllvm -optlo-O3 Executable gloss-pulse Build-depends:- base == 4.7.*,- gloss == 1.9.2.*,- gloss-raster == 1.9.2.*+ base == 4.8.*,+ gloss == 1.9.3.*,+ gloss-raster == 1.9.3.* Main-is: Main.hs hs-source-dirs: raster/Pulse ghc-options:@@ -236,16 +251,19 @@ -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000++ if flag(llvm)+ ghc-options: -fllvm -optlo-O3 Executable gloss-wave Build-depends:- base == 4.7.*,- ghc-prim == 0.3.*,+ base == 4.8.*,+ ghc-prim == 0.4.*, vector == 0.10.*,- gloss == 1.9.2.*,- gloss-raster == 1.9.2.*+ gloss == 1.9.3.*,+ gloss-raster == 1.9.3.* Main-is: Main.hs hs-source-dirs: raster/Wave ghc-options:@@ -254,16 +272,20 @@ -funfolding-use-threshold1000 -funfolding-keeness-factor1000 + if flag(llvm)+ ghc-options:+ -fllvm -optlo-O3 + Executable gloss-fluid Build-depends:- base == 4.7.*,- ghc-prim == 0.3.*,+ base == 4.8.*,+ ghc-prim == 0.4.*, vector == 0.10.*,- repa == 3.3.*,- repa-io == 3.3.*,- repa-algorithms == 3.3.*,- gloss == 1.9.2.*+ repa == 3.4.*,+ repa-io == 3.4.*,+ repa-algorithms == 3.4.*,+ gloss == 1.9.3.* Main-is: Main.hs other-modules: Args Config FieldElt Model UserEvent@@ -271,21 +293,27 @@ Stage.Advection Stage.Boundary Stage.Diffusion Stage.Linear Stage.Project Stage.Sources hs-source-dirs: raster/Fluid/src-repa++ extensions:+ PatternGuards+ ghc-options: -Wall -threaded -rtsopts -eventlog -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000++ if flag(llvm)+ ghc-options: -fllvm -optlo-O3- extensions:- PatternGuards+ Executable gloss-snow Build-depends:- base == 4.7.*,- repa == 3.3.*,- gloss == 1.9.2.*+ base == 4.8.*,+ repa == 3.4.*,+ gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: raster/Snow ghc-options:@@ -293,32 +321,41 @@ -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000++ if flag(llvm)+ ghc-options: -fllvm -optlo-O3 Executable gloss-mandel Build-depends:- base == 4.7.*,- repa == 3.3.*,- gloss == 1.9.2.*+ base == 4.8.*,+ repa == 3.4.*,+ gloss == 1.9.3.* Main-is: Main.hs other-modules: Solver hs-source-dirs: raster/Mandel++ extensions:+ PatternGuards+ ghc-options: -Wall -threaded -rtsopts -eventlog -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000++ if flag(llvm)+ ghc-options: -fllvm -optlo-O3- extensions:- PatternGuards + Executable gloss-graph Build-depends:- base == 4.7.*,+ base == 4.8.*, containers == 0.5.*,- gloss == 1.9.2.*+ gloss == 1.9.3.* Main-is: Main.hs hs-source-dirs: picture/Graph ghc-options:@@ -327,10 +364,10 @@ Executable gloss-render Build-depends:- base == 4.7.*,+ base == 4.8.*, containers == 0.5.*,- gloss == 1.9.2.*,- gloss-rendering == 1.9.2.*,+ gloss == 1.9.3.*,+ gloss-rendering == 1.9.3.*, GLFW-b Main-is: Main.hs hs-source-dirs: picture/Render
picture/Bitmap/Main.hs view
@@ -5,18 +5,18 @@ -- | Displays uncompressed 24/32 bit BMP images. main- = do args <- getArgs- case args of- [fileName] -> run fileName- _ -> putStr - $ unlines [ "usage: bitmap <file.bmp>"- , " file.bmp should be a 24 or 32-bit uncompressed BMP file" ]+ = do args <- getArgs+ case args of+ [fileName] -> run fileName+ _ -> putStr + $ unlines [ "usage: bitmap <file.bmp>"+ , " file.bmp should be a 24 or 32-bit uncompressed BMP file" ] run fileName- = do picture@(Bitmap width height _ _)+ = do picture@(Bitmap width height _ _) <- loadBMP fileName - animate (InWindow fileName (width, height) (10, 10))+ animate (InWindow fileName (width, height) (10, 10)) black (frame width height picture) frame :: Int -> Int -> Picture -> Float -> Picture
picture/Boids/Main.hs view
@@ -163,7 +163,7 @@ limiter :: Vec2 -> Double -> Vec2 limiter x lim = let d = vecNorm x in if (d < lim) then x- else vecScale (vecNormalize x) lim+ else vecScale (vecNormalize x) lim -- | Vector with all components length epsilon epsvec :: Vec2
picture/Clock/Main.hs view
@@ -1,27 +1,27 @@ -- A fractal consisting of circles and lines which looks a bit like--- the workings of a clock.+-- the workings of a clock. import Graphics.Gloss main- = animate (InWindow "Clock" (600, 600) (20, 20))- black frame+ = 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- +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+-- 1 -- | -- . -- / \@@ -31,43 +31,43 @@ -- Components at higher iterations also spin faster. -- clockFractal :: Int -> Float -> Picture-clockFractal 0 s = Blank-clockFractal n s = Pictures [circ1, circ2, circ3, lines]+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)+ -- 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)+ -- 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)))+ 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- ]+ -- 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)] ]+ circ1 = Translate 0 a $ Rotate rot circNm1+ circ2 = Translate 1 (-b) $ Rotate (-rot) circNm1+ circ3 = Translate (-1) (-b) $ Rotate rot circNm1+ + -- join each iteration to the origin with some lines.+ lines + = Pictures+ [ Line [(0, 0), ( 0, a)]+ , Line [(0, 0), ( 1, -b)]+ , Line [(0, 0), (-1, -b)] ]
picture/Conway/Cell.hs view
@@ -1,91 +1,91 @@ module Cell where-import Graphics.Gloss +import Graphics.Gloss -- | A cell in the world. data Cell- = -- | A living cell with its age- CellAlive Int + = -- | A living cell with its age+ CellAlive Int - -- | A dead / blank cell.- | CellDead- deriving (Show, Eq)+ -- | 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+ 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)]- + = 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.+-- 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)+ 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.+-- Sequence is red, yellow, green, cyan, blue. rampColorHotToCold - :: (Ord a, Floating a) - => a - -> a - -> a - -> (a, a, a)- + :: (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 + = 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+ result | v < vmin + 0.25 * dv+ = ( 0+ , 4 * (v - vmin) / dv+ , 1.0)+ + | v < vmin + 0.5 * dv+ = ( 0+ , 1.0+ , 1 + 4 * (vmin + 0.25 * dv - v) / dv)+ + | v < vmin + 0.75 * dv+ = ( 4 * (v - vmin - 0.5 * dv) / dv+ , 1.0+ , 0.0)+ + | otherwise+ = ( 1.0+ , 1 + 4 * (vmin + 0.75 * dv - v) / dv+ , 0)+ + in result - +
picture/Conway/Main.hs view
@@ -3,62 +3,62 @@ import World import Cell import Graphics.Gloss-import qualified Data.Vector as Vec+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- +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+ :: 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)+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)+ = 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+ (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- + 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)+ = let cellSize = worldCellSize world+ cellSpace = worldCellSpace world+ cellPad = cellSize + cellSpace+ height = cellPad * (worldHeight world) + cellSpace+ width = cellPad * (worldWidth world) + cellSpace+ in (width, height)
picture/Conway/World.hs view
@@ -6,126 +6,126 @@ import Control.Monad import Graphics.Gloss import Graphics.Gloss.Interface.Pure.Simulate-import qualified Data.Vector as Vec-type Vec = Vec.Vector+import qualified Data.Vector as Vec+type Vec = Vec.Vector -- Index ---------------------------------------------------------------------- -- | An index into the vector holding all the cells.-type Index = Int+type Index = Int -- | The x y coordinate of a cell.-type Coord = (Int, Int)+type Coord = (Int, Int) indexOfCoord :: World -> Coord -> Index-indexOfCoord world (x, y) - = x + y * (worldWidth world)+indexOfCoord world (x, y) + = x + y * (worldWidth world) coordOfIndex :: World -> Index -> Coord-coordOfIndex world i - = ( i `mod` worldWidth world- , i `div` worldWidth world)+coordOfIndex world i + = ( i `mod` worldWidth world+ , i `div` worldWidth world) -- World -----------------------------------------------------------------------data World - = World- { worldCells :: Vec Cell - , worldWidth :: Int - , worldHeight :: Int +data World + = World+ { worldCells :: Vec Cell + , worldWidth :: Int + , worldHeight :: Int - -- | Width and height of each cell.- , worldCellSize :: Int+ -- | Width and height of each cell.+ , worldCellSize :: Int - -- | Number of pixels to leave between each cell.- , worldCellSpace :: Int+ -- | Number of pixels to leave between each cell.+ , worldCellSpace :: Int - -- | Cells less than this age are drawn with the color ramp- , worldCellOldAge :: 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 }+ -- | 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 }+ = 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+ 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+ | x < 0 || x >= worldWidth world = CellDead+ | y < 0 || y >= worldHeight world = CellDead - | otherwise - = worldCells world Vec.! indexOfCoord world coord + | 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+ = 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+ = 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+ = 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) }+ = 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 }+ -- If enough time has passed then it's time to step the world.+ | worldElapsedTime world >= (worldSimulationPeriod world)+ = let world' = stepWorld world+ in world' { worldElapsedTime = 0 }+ + -- Wait some more.+ | otherwise+ = world { worldElapsedTime = worldElapsedTime world + time }
picture/Eden/Cell.hs view
@@ -3,36 +3,36 @@ import Graphics.Gloss data Cell - = Cell Point -- centre- Float -- radius- Int - deriving Show+ = 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 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)+ = Cell (x + (childR+r) * cos alpha, y + (childR+r) * sin alpha) + childR + (gen + 1) - where childR = factor * r+ 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+ = 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+ = let z = fromIntegral gen * 0.1+ color = makeColor 0.0 z 0.5 1.0+ in Color color+ $ Translate x y+ $ Circle r
picture/Eden/Community.hs view
@@ -9,13 +9,13 @@ -- that is, does it overlap with any others? fits :: Cell -> Community -> Bool fits cell cells - = not $ any (overlap 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+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.@@ -24,17 +24,17 @@ survive :: [Cell] -> Community -> Community survive [] comm = comm survive (cell:cells) comm- | fits cell comm = survive cells (cell:comm)- | otherwise = survive 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+ = survive (spawn comm angles scales) comm render :: Community -> Picture render comm - = Pictures $ map Cell.render comm+ = Pictures $ map Cell.render comm initial :: Community initial = [Cell (0,0) 50 0]
picture/Eden/Main.hs view
@@ -8,12 +8,12 @@ -- 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- (W.genesis' gen) -- initial world- W.render -- function to convert world to a Picture- W.evolve -- function to step the world one iteration+ = do gen <- getStdGen+ simulate (InWindow "Eden" (800, 600) (10, 10))+ (greyN 0.1) -- background color+ 2 -- number of steps per second+ (W.genesis' gen) -- initial world+ W.render -- function to convert world to a Picture+ W.evolve -- function to step the world one iteration
picture/Eden/World.hs view
@@ -6,42 +6,42 @@ import Community import Cell -maxSteps = 30+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)+ = World Community StdGen Int+ deriving (Show) -- The initial world genesis :: World genesis - = World [Cell (0,0) 30 0] (mkStdGen 1023) 0+ = 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+ = 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)+ | 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+ | 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+ = Color (makeColor 0.3 0.3 0.6 1.0)+ $ Community.render comm
picture/Flake/Main.hs view
@@ -1,11 +1,11 @@ -- | Snowflake Fractal.--- Based on ANUPlot code by Clem Baker-Finch.+-- Based on ANUPlot code by Clem Baker-Finch. -- import Graphics.Gloss main = display (InWindow "Snowflake" (500, 500) (20, 20))- black (picture 3)+ black (picture 3) -- Fix a starting edge length of 360@@ -15,32 +15,32 @@ -- 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- + = 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 ]+ = 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]+ = let oneSide = side n+ in Pictures+ [ oneSide + , Translate edge 0 $ Rotate (-120) $ oneSide+ , Translate (edge/2) (edge * sqrt 3/2) $ Rotate 120 $ oneSide]
picture/Graph/Main.hs view
@@ -278,7 +278,7 @@ sceneWindow :: Scene -> IO () sceneWindow sc - = play (InWindow "Graph Drawing - ctrl + left mouse button to drag" windowSize (10, 10))+ = play (InWindow "Graph Drawing - shift + left mouse button to drag" windowSize (10, 10)) black 30 sc drawScene handleEvent updatePositions
picture/Hello/Main.hs view
@@ -3,16 +3,16 @@ -- import Graphics.Gloss -main +main = display (InWindow- "Hello World" -- window title- (400, 150) -- window size- (10, 10)) -- window position- white -- background color- picture -- picture to display+ "Hello World" -- window title+ (400, 150) -- window size+ (10, 10)) -- window position+ white -- background color+ picture -- picture to display -picture - = Translate (-170) (-20) -- shift the text to the middle of the window- $ Scale 0.5 0.5 -- display it half the original size- $ Text "Hello World" -- text to display+picture + = Translate (-170) (-20) -- shift the text to the middle of the window+ $ Scale 0.5 0.5 -- display it half the original size+ $ Text "Hello World" -- text to display
picture/Lifespan/Cell.hs view
@@ -29,8 +29,8 @@ -- 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+ = Color (makeColor 0.6 z 0.6 1.0)+ $ Translate x y+ $ ThickCircle (r - thickness / 2) thickness+ where z = fromIntegral life * 0.12+ thickness = fromIntegral life
picture/Lifespan/Community.hs view
@@ -49,8 +49,8 @@ render :: Community -> Picture render comm - = Pictures - $ map Cell.render comm+ = Pictures + $ map Cell.render comm initial :: Community initial = [Cell (0,0) 50 5]
picture/Lifespan/Main.hs view
@@ -8,13 +8,13 @@ -- 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- (W.genesis' gen) -- initial world- W.render -- function to convert world to a Picture- W.evolve -- function to step the world one iteration+ = do gen <- getStdGen+ simulate (InWindow "Lifespan" (800, 600) (10, 10))+ (greyN 0.1) -- background color+ 2 -- number of steps per second+ (W.genesis' gen) -- initial world+ W.render -- function to convert world to a Picture+ W.evolve -- function to step the world one iteration
picture/Lifespan/World.hs view
@@ -6,39 +6,39 @@ import Community import Cell -stepsMax = 20+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+ = World Community StdGen Int deriving (Show) -- The initial world genesis :: World genesis - = World [Cell (0,0) 50 5] (mkStdGen 1023) 0+ = 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+ = 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+ | 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+ = Color (makeColor 0.3 0.3 0.6 1.0)+ $ Community.render comm
picture/Machina/Main.hs view
@@ -1,30 +1,30 @@ import Graphics.Gloss -main = animate (InWindow "machina" (800, 600) (10, 10))+main = animate (InWindow "machina" (800, 600) (10, 10)) black frame frame time- = Scale 0.8 0.8- $ Rotate (time * 30)- $ mach time 6- + = 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)+ [ 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 ]+ , 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)]+loop = [(-10, -100), (-10, 100), (10, 100), (10, -100), (-10, -100)]
picture/Occlusion/Cell.hs view
@@ -1,47 +1,47 @@ module Cell- ( Cell (..)- , readCell - , pictureOfCell- , cellShape)+ ( Cell (..)+ , readCell + , pictureOfCell+ , cellShape) where import Data.Char import Graphics.Gloss -- | A terrain cell in the world. data Cell- = CellEmpty- | CellWall- deriving (Show, Eq)+ = 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+ '.' -> 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)]- + = 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.+-- 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)+ CellEmpty -> Color (greyN 0.2) (cellShape cellSize posX posY)+ CellWall -> Color white (cellShape cellSize posX posY)
picture/Occlusion/Data.hs view
@@ -2,39 +2,39 @@ 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#..............................#" ]+ = unlines+ [ "WORLD"+ , "32 32"+ , " 01234567890123456789012345678901"+ , "0#..............................#"+ , "1.....................#####......"+ , "2....#.#.#.#..#.#.#.............."+ , "3....#######...#.#....#.#.#......"+ , "4....#######..#.#.#.............."+ , "5....#######...#.#...###.###....."+ , "6................................"+ , "7......#.#.............#.#......."+ , "8......#.#.............#.#......."+ , "9......#.#.............#.#......."+ , "0......#.#####.........#.#......."+ , "1......#.....#.........#.#......."+ , "2......#.###.#.........#.#......."+ , "3......#.#.#.###########.#######."+ , "4......#.#.#...................#."+ , "5......#.#.#####################."+ , "6......#.#......................."+ , "7......#.#...########............"+ , "8......#.#...#......#............"+ , "9......#.#...########............"+ , "0......#.#................####..."+ , "1......#.#.........#####..#..#..."+ , "2......#.###########...####..#..."+ , "3......#.....................#..."+ , "4..#####.###########...####..#..."+ , "5..#.....#.........#####..#..#..."+ , "6..#.#####.....#..........####..."+ , "7..#.#.........#................."+ , "8..#.#......#######.............."+ , "9..#.#.........#................."+ , "0..............#................."+ , "1#..............................#" ]
picture/Occlusion/Main.hs view
@@ -13,106 +13,106 @@ import Data.Function main - = do args <- getArgs- case args of- [fileName] - -> do world <- loadWorld fileName- mainWithWorld world- - _ -> do- let world = readWorld worldData- mainWithWorld world- - + = 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)- - + (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+ = let world = stateWorld state - -- The ray cast by the user.- p1 = stateLineStart state- p2 = stateLineEnd state- picRay = drawRay world p1 p2+ -- 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+ -- 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+ -- 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 + -- The cells visible from the designated point.+ cellsVisible = [ (coord, cell)- | (coord, cell) <- flattenQuadTree (worldExtent world) (worldTree world)- , cellAtCoordIsVisibleFromPoint world p1 coord ]+ | (coord, cell) <- flattenQuadTree (worldExtent world) (worldTree world)+ , cellAtCoordIsVisibleFromPoint world p1 coord ] - picCellsVisible = Pictures $ map (uncurry (drawCell True world)) cellsVisible+ picCellsVisible = Pictures $ map (uncurry (drawCell True world)) cellsVisible - -- How big to draw the cells.- scale = fromIntegral $ worldCellSize world+ -- 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)+ (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 ]+ 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+ = 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 ]+ 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)] ] ]+ [ 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)+ = let cs = fromIntegral (worldCellSize world)+ cp = fromIntegral (worldCellSpace world) - posX = fromIntegral x - posY = fromIntegral y+ 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)- + in if visible+ then pictureOfCell (worldCellSize world) posX posY cell+ else Color (greyN 0.4) (cellShape cs posX posY)+
picture/Occlusion/State.hs view
@@ -6,37 +6,37 @@ -- | The game state. data State- = State- { stateWorld :: World- , stateLineStart :: Point- , stateLineEnd :: Point }+ = State+ { stateWorld :: World+ , stateLineStart :: Point+ , stateLineEnd :: Point } -- | Initial game state. initState world- = State- { stateWorld = world- , stateLineStart = (10, 10)- , stateLineEnd = (10, 10) }- + = 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+ , shift mods == Down + = state { stateLineEnd = worldPosOfWindowPos world pos } - | MouseButton LeftButton <- key- , Down <- keyState- = state { stateLineStart = worldPosOfWindowPos world pos - , 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 }+ | MouseButton RightButton <- key+ , Down <- keyState+ = state { stateLineEnd = worldPosOfWindowPos world pos } handleInput _ _ state- = state+ = state
picture/Occlusion/World.hs view
@@ -11,66 +11,66 @@ -- | The game world.-data World - = World- { worldWidth :: Int- , worldHeight :: Int- , worldTree :: QuadTree Cell- , worldCellSize :: Int- , worldCellSpace :: Int }- deriving Show+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+ = makeExtent (worldWidth world) 0 (worldHeight world) 0 --- | Load a world from a file. +-- | Load a world from a file. loadWorld :: FilePath -> IO World loadWorld fileName- = do str <- readFile fileName- return $ readWorld str- - + = 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+ = let ("WORLD" : strWidthHeight : skip : cellLines) + = lines str+ + [width, height] = map read $ words strWidthHeight+ rows = take height $ cellLines - cells = concat - $ map (readLine width) - $ reverse rows+ cells = concat + $ map (readLine width) + $ reverse rows - extent = makeExtent height 0 width 0+ extent = makeExtent height 0 width 0 - in World { worldWidth = width- , worldHeight = height- , worldTree = makeWorldTree extent cells- , worldCellSize = 20- , worldCellSpace = 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+ = 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)+ = 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.@@ -78,79 +78,79 @@ 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+ 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+ = 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')+ 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+ = 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.+-- 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)+ 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+ = 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)+ = 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)+ = traceSegIntoCellularQuadTree p1 p2 (worldExtent world) (worldTree world)
picture/Styrene/Actor.hs view
@@ -2,72 +2,72 @@ module Actor where -- | 2D position on the screen.-type Position = (Float, Float)+type Position = (Float, Float) -- | Force and velocity vectors.-type Force = (Float, Float)-type Velocity = (Float, Float)+type Force = (Float, Float)+type Velocity = (Float, Float) -- | Time in seconds-type Time = Float+type Time = Float -- | Radius of a bead-type Radius = Float+type Radius = Float -- | Each actor has its own unique index.-type Index = Int+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+ = 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+ | 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+ deriving Show -- | Equality and ordering of actors will consider their index only.--- We need Ord so we can put them in Maps and Sets.+-- We need Ord so we can put them in Maps and Sets. instance Eq Actor where- a1 == a2 = actorIx a1 == actorIx a2- + a1 == a2 = actorIx a1 == actorIx a2+ instance Ord Actor where- compare a1 a2 = compare (actorIx a1) (actorIx a2)+ compare a1 a2 = compare (actorIx a1) (actorIx a2) -- | Check whether an actor is a bead. isBead :: Actor -> Bool-isBead (Bead _ _ _ _ _) = True-isBead _ = False+isBead (Bead _ _ _ _ _) = True+isBead _ = False -- | Check whether an actor is a wall. isWall :: Actor -> Bool-isWall (Wall _ _ _) = True-isWall _ = False+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+ 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+ 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+ = Bead ix m r p v
picture/Styrene/Advance.hs view
@@ -16,116 +16,116 @@ 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)+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.+ :: 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 rot) (0, negate gravityCoeff)+ = let + rot = viewPortRotate viewport+ force = rotateV (degToRad rot) (0, negate gravityCoeff) - -- move all the actors - actors_moved = Map.map (moveActor_free time force) actors+ -- 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)+ -- 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+ -- apply contacts to each pair of actors+ actors_bounced + = Set.fold + (applyContact time force) + actors_moved+ contacts - in World actors_bounced tree'+ 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+ :: 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+ = 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')+ | 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+ -- 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 - + -- 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+ :: 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)+ -- 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)+ -- 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)+ | otherwise + = max 0 (stuck - 2) - in Bead ix stuck' radius pos' vel'+ in Bead ix stuck' radius pos' vel' - -- walls don't move- | Wall{} <- actor- = actor+ -- walls don't move+ | Wall{} <- actor+ = actor
picture/Styrene/Collide.hs view
@@ -9,160 +9,160 @@ -- 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.+-- 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+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+ :: 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)+ 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+ = 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+ -- 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)+ :: Actor -> Actor+ -> (Actor, Actor) collideBeadBead_elastic- bead1@(Bead ix1 mode1 r1 p1 v1) - bead2@(Bead ix2 mode2 r2 p2 v2)+ bead1@(Bead ix1 mode1 r1 p1 v1) + bead2@(Bead ix2 mode2 r2 p2 v2) - = let mass1 = 1- mass2 = 1+ = let mass1 = 1+ mass2 = 1 - -- the axis of collision (towards p2)- vCollision@(cX, cY) = normalizeV (p2 - p1)- vCollisionR = (cY, -cX)- - -- the velocity component of each bead along the axis of collision- s1 = dotV v1 vCollision- s2 = dotV v2 vCollision+ -- the axis of collision (towards p2)+ vCollision@(cX, cY) = normalizeV (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+ -- 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'+ v1_slow = mulSV beadBeadLoss v1'+ v2_slow = mulSV beadBeadLoss v2' - -- work out the point of collision- u1 = r1 / (r1 + r2)- u2 = r2 / (r1 + r2)+ -- work out the point of collision+ u1 = r1 / (r1 + r2)+ u2 = r2 / (r1 + r2) - pCollision - = p1 + mulSV u1 (p2 - p1)+ 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+ -- 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+ bead1' = Bead ix1 mode1 r1 p1' v1_slow+ bead2' = Bead ix2 mode2 r2 p2' v2_slow - in (bead1', bead2')+ in (bead1', bead2') collideBeadBead_static- :: Actor -> Actor - -> Actor- + :: Actor -> Actor + -> Actor+ collideBeadBead_static- bead1@(Bead ix1 _ radius1 pBead1 _)- bead2@(Bead ix2 _ radius2 pBead2 _)+ 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'+ = 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+ :: 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+ 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 = normalizeV (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+ -- take a normal vector from the wall to the bead.+ -- this vector is at a right angle to the wall.+ vNormal = normalizeV (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)+ -- 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+ -- 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+ -- 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+ -- 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+ -- Slow down the bead when it hits the wall+ vSlow = velLoss `mulSV` vOut - bead1_new = Bead ix mode radius pBead_new vSlow+ bead1_new = Bead ix mode radius pBead_new vSlow - in bead1_new+ in bead1_new
picture/Styrene/Config.hs view
@@ -4,43 +4,43 @@ -- Number of simulation steps per second of time. simResolution :: Int-simResolution = 300+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.+-- If this is too high wrt the simResoution then the simulation+-- will be unstable and beads will escape the box. gravityCoeff :: Float-gravityCoeff = 300+gravityCoeff = 300 -- Whether to draw velocity vectors on beads.-showBeadVelocity = False+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+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+treeMaxDepth = 4 -- Size of quadtree. Should be > boxSize. treeSize :: Float-treeSize = 300+treeSize = 300 -- Size of bead box. boxSize :: Float-boxSize = 280+boxSize = 280 -- Bead setup. beadRadius, beadSpace, beadCountX, beadCountY, beadBoxSize :: Float -beadRadius = 5-beadSpace = 1-beadBoxSize = 2 * beadRadius + beadSpace-beadCountX = 20-beadCountY = 10+beadRadius = 5+beadSpace = 1+beadBoxSize = 2 * beadRadius + beadSpace+beadCountX = 20+beadCountY = 10 beadStuckCount :: Int-beadStuckCount = 20+beadStuckCount = 20
picture/Styrene/Contact.hs view
@@ -12,125 +12,125 @@ 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+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 - -> ( -- a set of all pairs of actors that are in contact.- Set (Index, Index) + :: World + -> ( -- a set of all pairs of actors that are in contact.+ Set (Index, Index) -- also return the quadtree so we can draw it in the window.- , QuadTree Actor) - + , QuadTree Actor) + 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+ = 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+ -- 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'+ -- 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')- + -- 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.+-- 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' Set.empty contactLists makeContacts' acc xx = case xx of- -- no more potentials to add, return the current contact set- [] -> acc+ -- 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+ -- 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+ = 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- + | 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+ | 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)+ 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+ = 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#+ -- 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+ -- 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+ -- pClosest needs to lie on the line segment between pWal1 and pWall2+ inSegment = uParam >= 0 && uParam <= 1 - in tagToEnum# closeEnough && inSegment+ in tagToEnum# 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 tagToEnum# (dist# `ltFloat#` rad ) && tagToEnum# (dist# `gtFloat#` 0.1#)+ bead1@(Bead ix1 _ radius1 pBead1 _) + bead2@(Bead ix2 _ radius2 pBead2 _)+ =let !dist# = distancePP_contact pBead1 pBead2+ !(F# rad) = radius1 + radius2+ in tagToEnum# (dist# `ltFloat#` rad ) && tagToEnum# (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+ = sqrtFloat# (xd2 `plusFloat#` yd2)+ where !xd = x2 `minusFloat#` x1+ !xd2 = xd `timesFloat#` xd - !yd = y2 `minusFloat#` y1- !yd2 = yd `timesFloat#` yd + !yd = y2 `minusFloat#` y1+ !yd2 = yd `timesFloat#` yd
picture/Styrene/Main.hs view
@@ -13,21 +13,21 @@ import Graphics.Gloss.Interface.Pure.Simulate import Graphics.Gloss.Data.Vector -import qualified Data.Map as Map-import Data.Map (Map)+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.+ (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 ------------------------------------------------------------------------------------------- @@ -35,80 +35,80 @@ 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+ -- 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+ 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]+ 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' [] [] as -splitActors' accBeads accWalls [] - = (accBeads, accWalls)+splitActors' accBeads accWalls [] + = (accBeads, accWalls) -splitActors' accBeads accWalls (a : as) +splitActors' accBeads accWalls (a : as) = case a of- Bead{} -> splitActors' (a : accBeads) accWalls as- Wall{} -> splitActors' accBeads (a : accWalls) as+ 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- Wall _ p1 p2- -> Color (greyN 0.8) $ Line [p1, p2]+ 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+ 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 ]+ 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+ 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)+ = 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)- - + = 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]+ = map (\d -> (cos d, sin d))+ [0, 2*pi / n .. 2*pi]
picture/Styrene/QuadTree.hs view
@@ -1,90 +1,90 @@ module QuadTree - ( QuadTree(..)- , treeZero- , treeInsert- , treeElems )+ ( 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+ -- 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+ -- 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)+ -- 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+ = 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+ :: 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+ 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+ 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+ 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))+ 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{} -> []+ QNode _ _ tNW tNE tSW tSE+ -> treeElems tNW ++ treeElems tNE ++ treeElems tSW ++ treeElems tSE+ + QLeaf _ _ elems -> [elems]+ QNil{} -> []
picture/Styrene/World.hs view
@@ -1,68 +1,68 @@ {-# 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.+-- 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)+import qualified Data.Map as Map+import Data.Map (Map) -- The world -------------------------------------------------------------------data World - = World (Map Index Actor) -- actors- (QuadTree Actor) -- tree+data World + = World (Map Index Actor) -- actors+ (QuadTree Actor) -- tree -- | The initial world worldInit :: World-worldInit - = World actorMapInit treeInit+worldInit + = World actorMapInit treeInit -actorMapInit - = Map.fromList - $ map (\a -> (actorIx a, a))- $ (walls ++ beads)+actorMapInit + = Map.fromList + $ map (\a -> (actorIx a, a))+ $ (walls ++ beads) treeInit = treeZero treeSize -- Walls ------------------ walls :: [Actor]-walls = zipWith actorSetIndex (box ++ splitter) [10000 ..]+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+ = 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+ , 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) ]+ = [ 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) )+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 -------------------------------------------------------------------@@ -71,20 +71,20 @@ 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)+ -- 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+ 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- + | wall@(Wall ix (x0, y0) (x1, y1)) <- actor+ = let+ -- the bottom left and top right of the wall's bounding box.+ p0 = (min x0 x1, min y0 y1)+ p1 = (max x0 x1, max y0 y1)+ + in treeInsert treeMaxDepth 0 p0 p1 wall tree+
picture/Tree/Main.hs view
@@ -1,47 +1,47 @@ -- | Tree Fractal.--- Based on ANUPlot code by Clem Baker-Finch.--- +-- Based on ANUPlot code by Clem Baker-Finch.+-- import Graphics.Gloss main = animate (InWindow "Tree" (500, 650) (20, 20))- black (picture 4)+ black (picture 4) -- The picture is a tree fractal, graded from brown to green-picture :: Int -> Float -> Picture +picture :: Int -> Float -> Picture picture degree time- = Translate 0 (-300)- $ tree degree time (dim $ dim brown)+ = 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)]+ = 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 :: 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 ]- + = 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
picture/Visibility/Draw.hs view
@@ -1,120 +1,120 @@ {-# LANGUAGE PatternGuards #-} module Draw- ( drawState- , drawWorld)+ ( 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 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)+ | 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+ | ModeDisplayNormalised <- stateModeDisplay state+ = drawWorldWithViewPos + (stateModeOverlay state)+ (0, 0) + Nothing+ $ normaliseWorld (stateViewPos state)+ $ stateWorld state - | otherwise- = Blank- + | otherwise+ = Blank+ drawWorldWithViewPos :: ModeOverlay -> Point -> Maybe Point -> World -> Picture drawWorldWithViewPos - modeOverlay- pView@(vx, vy) - mTarget- world- = let - -- the world - picWorld = Color white- $ drawWorld world+ 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+ -- 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+ -- 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]+ -- 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+ | otherwise+ = blank - -- overlay- picOverlay- | ModeOverlayVisApprox <- modeOverlay- = drawVisGrid 10 pView world+ -- overlay+ picOverlay+ | ModeOverlayVisApprox <- modeOverlay+ = drawVisGrid 10 pView world - | otherwise- = blank+ | otherwise+ = blank - in Pictures [picOverlay, picWorld, picView, picTargets]+ 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] ]+ = 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+ in picGrid -- | Draw the segments in the world. drawWorld :: World -> Picture drawWorld world- = drawSegments- $ worldSegments world+ = drawSegments+ $ worldSegments world -- | Draw an array of segments. drawSegments :: V.Vector Segment -> Picture drawSegments segments- = Pictures- $ map drawSegment- $ V.toList - $ 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+ = Line [(f x1, f y1), (f x2, f y2)]+ where f = fromRational . toRational
picture/Visibility/Geometry/Randomish.hs view
@@ -1,21 +1,21 @@ {-# LANGUAGE BangPatterns #-} module Geometry.Randomish- ( randomishPoints - , randomishInts- , randomishDoubles)+ ( 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+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+ :: Int -- ^ seed+ -> Int -- ^ number of points+ -> Float -- ^ minimum coordinate+ -> Float -- ^ maximum coordinate -> V.Vector (Float, Float) randomishPoints seed' n pointMin pointMax@@ -35,81 +35,81 @@ -- 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.+ :: 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+ + = 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+ -- 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'+ -- 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+ !valMin = fromIntegral valMin'+ !valMax = fromIntegral valMax' + 1+ !range = valMax - valMin - {-# INLINE f #-}- f x = multiplier * x `mod` modulus+ {-# INLINE f #-}+ f x = multiplier * x `mod` modulus in G.create - $ do - vec <- MV.new len+ $ 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'+ 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+ 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.+ :: 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+ = 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+ 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.+ :: 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+ = 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+ mx = 2^(30 :: Integer) - 1+ mxf = fromIntegral mx+ ints = randomishInts len 0 mx seed+ + in V.map (\n -> valMin + (fromIntegral n / mxf) * range) ints
picture/Visibility/Geometry/Segment.hs view
@@ -1,81 +1,81 @@ module Geometry.Segment- ( Segment- , translateSegment- , splitSegmentsOnY- , splitSegmentsOnX- , chooseSplitX)+ ( 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+import qualified Data.Vector.Unboxed as V -- | A line segement in the 2D plane.-type Segment = (Int, (Float, Float), (Float, Float))+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))- + = (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+ = 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)+ -- 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+ = 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)+ -- 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.+-- 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+ = let Just (_, (x1, _), _) = segments V.!? (V.length segments `div` 2)+ in x1
picture/Visibility/Interface.hs view
@@ -1,70 +1,70 @@ {-# LANGUAGE PatternGuards #-} module Interface- ( handleInput- , stepState)+ ( handleInput+ , stepState) where import State-import qualified Graphics.Gloss.Interface.Pure.Game as G+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) }+ -- 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) }+ -- 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 }+ | 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) }+ | 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 }+ | 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 }+ | 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 }+ | 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 } + | G.Char 'a' <- key+ , G.Down <- keyState+ = state { stateModeOverlay+ = case stateModeOverlay state of+ ModeOverlayVisApprox -> ModeOverlayNone+ _ -> ModeOverlayVisApprox } handleInput _ state- = state+ = state -- Step ------------------------------------------------------------------------------------------- -- | Advance the state one iteration
picture/Visibility/Main.hs view
@@ -8,7 +8,7 @@ -- 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.+-- and doing vis based on center point of cell. -- import Interface@@ -19,9 +19,9 @@ main :: IO () main- = do world <- initialWorld- let state = initialState world- - play (InWindow "Visibility" (800, 800) (10, 10))- black 100 state+ = do world <- initialWorld+ let state = initialState world+ + play (InWindow "Visibility" (800, 800) (10, 10))+ black 100 state drawState handleInput stepState
picture/Visibility/State.hs view
@@ -7,53 +7,53 @@ -- | The game state. data State- = State- { stateWorld :: World- , stateModeInterface :: ModeInterface- , stateModeDisplay :: ModeDisplay- , stateModeOverlay :: ModeOverlay- , stateViewPos :: Point - , stateTargetPos :: Maybe Point }+ = 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 not doing anything inparticular.+ = ModeInterfaceIdle - -- | We're moving the view position.- | ModeInterfaceMove- deriving (Show, Eq)+ -- | 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 in rectangular coordinates.+ = ModeDisplayWorld - -- | Show the world normalised so the view position is at the origin.- | ModeDisplayNormalised- deriving (Show, Eq)+ -- | 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)+ -- | 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 }+ = State+ { stateWorld = world+ , stateModeInterface = ModeInterfaceIdle+ , stateModeDisplay = ModeDisplayWorld+ , stateModeOverlay = ModeOverlayVisApprox+ , stateViewPos = (0, 0) + , stateTargetPos = Nothing }
picture/Visibility/World.hs view
@@ -1,9 +1,9 @@ module World- ( Segment- , World(..)- , initialWorld- , normaliseWorld)+ ( Segment+ , World(..)+ , initialWorld+ , normaliseWorld) where import Graphics.Gloss import Geometry.Randomish@@ -14,41 +14,41 @@ -- We keep this unpacked so we can use unboxed vector. -- index, x1, y1, x2, y2 data World - = World- { worldSegments :: V.Vector Segment }+ = 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+ = 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 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+ 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 }+ = let segments_trans = V.map (translateSegment (-px) (-py)) + $ worldSegments world+ + segments_split = splitSegmentsOnY 0 segments_trans+ + in world { worldSegments = segments_split }
picture/Zen/Main.hs view
@@ -1,46 +1,46 @@ -- A nifty animated fractal of a tree, superimposed on a background --- of three red rectangles.+-- of three red rectangles. import Graphics.Gloss main :: IO () main - = animate (InWindow "Zen" (800, 600) (5, 5))+ = animate (InWindow "Zen" (800, 600) (5, 5)) (greyN 0.2)- frame + 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+ = Pictures + -- the red rectangles+ [ Translate 0 150 backRec+ , Translate 0 0 backRec+ , Translate 0 (-150) backRec - -- the tree- , Translate 0 (-150) $ treeFrac 7 timeS- ]+ -- the tree+ , Translate 0 (-150) $ treeFrac 7 timeS+ ] -- One of the red backing rectangles, with a white outline. backRec :: Picture-backRec +backRec = Pictures- [ Color red (rectangleSolid 400 100)- , Color white (rectangleWire 400 100) ]+ [ 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+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.+-- 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+treeColor = makeColor 0.0 1.0 0.0 0.5 -- The tree fractal.@@ -50,15 +50,15 @@ 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+ [ 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- ]+ , Translate 0 70+ $ Rotate (-200 * sin timeS / (fromIntegral n))+ $ Scale 0.8 0.8 + $ treeFrac (n-1) timeS+ ]