diff --git a/gloss-examples.cabal b/gloss-examples.cabal --- a/gloss-examples.cabal +++ b/gloss-examples.cabal @@ -1,5 +1,5 @@ Name: gloss-examples -Version: 1.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 diff --git a/picture/Bitmap/Main.hs b/picture/Bitmap/Main.hs --- a/picture/Bitmap/Main.hs +++ b/picture/Bitmap/Main.hs @@ -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 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 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 diff --git a/picture/Boids/Main.hs b/picture/Boids/Main.hs --- a/picture/Boids/Main.hs +++ b/picture/Boids/Main.hs @@ -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 diff --git a/picture/Clock/Main.hs b/picture/Clock/Main.hs --- a/picture/Clock/Main.hs +++ b/picture/Clock/Main.hs @@ -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)] ] diff --git a/picture/Conway/Cell.hs b/picture/Conway/Cell.hs --- a/picture/Conway/Cell.hs +++ b/picture/Conway/Cell.hs @@ -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 - + diff --git a/picture/Conway/Main.hs b/picture/Conway/Main.hs --- a/picture/Conway/Main.hs +++ b/picture/Conway/Main.hs @@ -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) diff --git a/picture/Conway/World.hs b/picture/Conway/World.hs --- a/picture/Conway/World.hs +++ b/picture/Conway/World.hs @@ -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 } diff --git a/picture/Eden/Cell.hs b/picture/Eden/Cell.hs --- a/picture/Eden/Cell.hs +++ b/picture/Eden/Cell.hs @@ -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 diff --git a/picture/Eden/Community.hs b/picture/Eden/Community.hs --- a/picture/Eden/Community.hs +++ b/picture/Eden/Community.hs @@ -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] diff --git a/picture/Eden/Main.hs b/picture/Eden/Main.hs --- a/picture/Eden/Main.hs +++ b/picture/Eden/Main.hs @@ -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 diff --git a/picture/Eden/World.hs b/picture/Eden/World.hs --- a/picture/Eden/World.hs +++ b/picture/Eden/World.hs @@ -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 diff --git a/picture/Flake/Main.hs b/picture/Flake/Main.hs --- a/picture/Flake/Main.hs +++ b/picture/Flake/Main.hs @@ -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] diff --git a/picture/Graph/Main.hs b/picture/Graph/Main.hs --- a/picture/Graph/Main.hs +++ b/picture/Graph/Main.hs @@ -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 diff --git a/picture/Hello/Main.hs b/picture/Hello/Main.hs --- a/picture/Hello/Main.hs +++ b/picture/Hello/Main.hs @@ -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 diff --git a/picture/Lifespan/Cell.hs b/picture/Lifespan/Cell.hs --- a/picture/Lifespan/Cell.hs +++ b/picture/Lifespan/Cell.hs @@ -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 diff --git a/picture/Lifespan/Community.hs b/picture/Lifespan/Community.hs --- a/picture/Lifespan/Community.hs +++ b/picture/Lifespan/Community.hs @@ -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] diff --git a/picture/Lifespan/Main.hs b/picture/Lifespan/Main.hs --- a/picture/Lifespan/Main.hs +++ b/picture/Lifespan/Main.hs @@ -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 diff --git a/picture/Lifespan/World.hs b/picture/Lifespan/World.hs --- a/picture/Lifespan/World.hs +++ b/picture/Lifespan/World.hs @@ -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 diff --git a/picture/Machina/Main.hs b/picture/Machina/Main.hs --- a/picture/Machina/Main.hs +++ b/picture/Machina/Main.hs @@ -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)] diff --git a/picture/Occlusion/Cell.hs b/picture/Occlusion/Cell.hs --- a/picture/Occlusion/Cell.hs +++ b/picture/Occlusion/Cell.hs @@ -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) diff --git a/picture/Occlusion/Data.hs b/picture/Occlusion/Data.hs --- a/picture/Occlusion/Data.hs +++ b/picture/Occlusion/Data.hs @@ -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#..............................#" ] diff --git a/picture/Occlusion/Main.hs b/picture/Occlusion/Main.hs --- a/picture/Occlusion/Main.hs +++ b/picture/Occlusion/Main.hs @@ -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) + diff --git a/picture/Occlusion/State.hs b/picture/Occlusion/State.hs --- a/picture/Occlusion/State.hs +++ b/picture/Occlusion/State.hs @@ -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 diff --git a/picture/Occlusion/World.hs b/picture/Occlusion/World.hs --- a/picture/Occlusion/World.hs +++ b/picture/Occlusion/World.hs @@ -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) diff --git a/picture/Styrene/Actor.hs b/picture/Styrene/Actor.hs --- a/picture/Styrene/Actor.hs +++ b/picture/Styrene/Actor.hs @@ -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 diff --git a/picture/Styrene/Advance.hs b/picture/Styrene/Advance.hs --- a/picture/Styrene/Advance.hs +++ b/picture/Styrene/Advance.hs @@ -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 diff --git a/picture/Styrene/Collide.hs b/picture/Styrene/Collide.hs --- a/picture/Styrene/Collide.hs +++ b/picture/Styrene/Collide.hs @@ -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 diff --git a/picture/Styrene/Config.hs b/picture/Styrene/Config.hs --- a/picture/Styrene/Config.hs +++ b/picture/Styrene/Config.hs @@ -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 diff --git a/picture/Styrene/Contact.hs b/picture/Styrene/Contact.hs --- a/picture/Styrene/Contact.hs +++ b/picture/Styrene/Contact.hs @@ -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 diff --git a/picture/Styrene/Main.hs b/picture/Styrene/Main.hs --- a/picture/Styrene/Main.hs +++ b/picture/Styrene/Main.hs @@ -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] diff --git a/picture/Styrene/QuadTree.hs b/picture/Styrene/QuadTree.hs --- a/picture/Styrene/QuadTree.hs +++ b/picture/Styrene/QuadTree.hs @@ -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{} -> [] diff --git a/picture/Styrene/World.hs b/picture/Styrene/World.hs --- a/picture/Styrene/World.hs +++ b/picture/Styrene/World.hs @@ -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 + diff --git a/picture/Tree/Main.hs b/picture/Tree/Main.hs --- a/picture/Tree/Main.hs +++ b/picture/Tree/Main.hs @@ -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 diff --git a/picture/Visibility/Draw.hs b/picture/Visibility/Draw.hs --- a/picture/Visibility/Draw.hs +++ b/picture/Visibility/Draw.hs @@ -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 diff --git a/picture/Visibility/Geometry/Randomish.hs b/picture/Visibility/Geometry/Randomish.hs --- a/picture/Visibility/Geometry/Randomish.hs +++ b/picture/Visibility/Geometry/Randomish.hs @@ -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 diff --git a/picture/Visibility/Geometry/Segment.hs b/picture/Visibility/Geometry/Segment.hs --- a/picture/Visibility/Geometry/Segment.hs +++ b/picture/Visibility/Geometry/Segment.hs @@ -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 diff --git a/picture/Visibility/Interface.hs b/picture/Visibility/Interface.hs --- a/picture/Visibility/Interface.hs +++ b/picture/Visibility/Interface.hs @@ -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 diff --git a/picture/Visibility/Main.hs b/picture/Visibility/Main.hs --- a/picture/Visibility/Main.hs +++ b/picture/Visibility/Main.hs @@ -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 diff --git a/picture/Visibility/State.hs b/picture/Visibility/State.hs --- a/picture/Visibility/State.hs +++ b/picture/Visibility/State.hs @@ -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 } diff --git a/picture/Visibility/World.hs b/picture/Visibility/World.hs --- a/picture/Visibility/World.hs +++ b/picture/Visibility/World.hs @@ -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 } diff --git a/picture/Zen/Main.hs b/picture/Zen/Main.hs --- a/picture/Zen/Main.hs +++ b/picture/Zen/Main.hs @@ -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 + ]