gloss-examples 1.0.1.0 → 1.1.0.0
raw patch · 7 files changed
+430/−14 lines, 7 filesdep ~glossnew-component:exe:gloss-occlusion
Dependency ranges changed: gloss
Files
- Occlusion/Cell.hs +47/−0
- Occlusion/Data.hs +40/−0
- Occlusion/Main.hs +122/−0
- Occlusion/State.hs +42/−0
- Occlusion/World.hs +156/−0
- Styrene/Contact.hs +1/−1
- gloss-examples.cabal +22/−13
+ Occlusion/Cell.hs view
@@ -0,0 +1,47 @@++module Cell+ ( Cell (..)+ , readCell + , pictureOfCell+ , cellShape)+where+import Data.Char+import Graphics.Gloss++-- | A terrain cell in the world.+data Cell+ = CellEmpty+ | CellWall+ deriving (Show, Eq)+++-- | Read a cell from a character.+readCell :: Char -> Cell+readCell c+ = case c of+ '.' -> CellEmpty+ '#' -> CellWall+ _ -> error $ "readCell: no match for char " ++ show (ord c) ++ " " ++ show c+++-- | The basic shape of a cell.+cellShape :: Int -> Int -> Int -> Picture+cellShape cellSize posXi posYi+ = let cs = fromIntegral cellSize+ posX = fromIntegral posXi+ posY = fromIntegral posYi+ x1 = posX+ x2 = posX + 1+ y1 = posY + y2 = posY + 1+ in Polygon [(x1, y1), (x1, y2), (x2, y2), (x2, y1)]+ ++-- | Convert a cell to a picture, based on a primitive shape.+-- We pass the shape in to avoid recomputing it for each cell.+pictureOfCell :: Int -> Int -> Int -> Cell -> Picture+pictureOfCell cellSize posX posY cell+ = case cell of+ CellEmpty -> Color (greyN 0.2) (cellShape cellSize posX posY)+ CellWall -> Color white (cellShape cellSize posX posY)+
+ Occlusion/Data.hs view
@@ -0,0 +1,40 @@++module Data where++worldData+ = unlines+ [ "WORLD"+ , "32 32"+ , " 01234567890123456789012345678901"+ , "0#..............................#"+ , "1.....................#####......"+ , "2....#.#.#.#..#.#.#.............."+ , "3....#######...#.#....#.#.#......"+ , "4....#######..#.#.#.............."+ , "5....#######...#.#...###.###....."+ , "6................................"+ , "7......#.#.............#.#......."+ , "8......#.#.............#.#......."+ , "9......#.#.............#.#......."+ , "0......#.#####.........#.#......."+ , "1......#.....#.........#.#......."+ , "2......#.###.#.........#.#......."+ , "3......#.#.#.###########.#######."+ , "4......#.#.#...................#."+ , "5......#.#.#####################."+ , "6......#.#......................."+ , "7......#.#...########............"+ , "8......#.#...#......#............"+ , "9......#.#...########............"+ , "0......#.#................####..."+ , "1......#.#.........#####..#..#..."+ , "2......#.###########...####..#..."+ , "3......#.....................#..."+ , "4..#####.###########...####..#..."+ , "5..#.....#.........#####..#..#..."+ , "6..#.#####.....#..........####..."+ , "7..#.#.........#................."+ , "8..#.#......#######.............."+ , "9..#.#.........#................."+ , "0..............#................."+ , "1#..............................#" ]
+ Occlusion/Main.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE PatternGuards #-}++import World+import Data+import State+import Cell+import Graphics.Gloss.Game+import Graphics.Gloss.Data.QuadTree+import Graphics.Gloss.Data.Extent+import Graphics.Gloss.Shapes+import System.Environment+import Data.Maybe+import Data.List+import Data.Function++main + = do args <- getArgs+ case args of+ [fileName] + -> do world <- loadWorld fileName+ mainWithWorld world+ + _ -> do+ let world = readWorld worldData+ mainWithWorld world+ + +mainWithWorld world+ = do let gameState = initState world+ gameInWindow + "Occlusion"+ (windowSizeOfWorld world)+ (10, 10)+ black + 10+ gameState+ drawState+ (handleInput world)+ (\_ -> id)+ + +-- | Convert the state to a picture.+drawState :: State -> Picture+drawState state+ = let + world = stateWorld state++ -- The ray cast by the user.+ p1 = stateLineStart state+ p2 = stateLineEnd state+ picRay = drawRay world p1 p2++ -- The cell hit by the ray (if any)+ mHitCell = castSegIntoWorld world p1 p2+ hitCells = maybeToList mHitCell+ picCellsHit = Pictures $ map (drawHitCell world) hitCells++ -- All the cells in the world.+ cellsAll = flattenQuadTree (worldExtent world) (worldTree world)+ picCellsAll = Pictures $ map (uncurry (drawCell False world)) cellsAll++ -- The cells visible from the designated point.+ cellsVisible = [ (coord, cell)+ | (coord, cell) <- flattenQuadTree (worldExtent world) (worldTree world)+ , cellAtCoordIsVisibleFromPoint world p1 coord ]++ picCellsVisible = Pictures $ map (uncurry (drawCell True world)) cellsVisible++ -- How big to draw the cells.+ scale = fromIntegral $ worldCellSize world++ (windowSizeX, windowSizeY) + = windowSizeOfWorld+ $ stateWorld state+ + -- Shift the cells so they are centered in the window.+ offsetX = - (fromIntegral $ windowSizeX `div` 2)+ offsetY = - (fromIntegral $ windowSizeY `div` 2)++ in Translate offsetX offsetY+ $ Scale scale scale+ $ Pictures [ picCellsAll, picCellsVisible, picCellsHit, picRay ]+++-- | Draw the cell hit by the ray defined by the user.+drawHitCell :: World -> (Point, Extent, Cell) -> Picture+drawHitCell world (pos@(px, py), extent, cell)+ = let (n, s, e, w) = takeExtent extent+ x = w+ y = s++ posX = fromIntegral x + posY = fromIntegral y+ + in Pictures [ Color blue $ cellShape 1 posX posY ]+++-- | Draw the ray defined by the user.+drawRay :: World -> Point -> Point -> Picture +drawRay world p1@(x, y) p2+ = Pictures+ [ Color red $ Line [p1, p2]+ , Color cyan + $ Translate x y + $ Pictures + [ Line [(-0.3, -0.3), (0.3, 0.3)]+ , Line [(-0.3, 0.3), (0.3, -0.3)] ] ]+++-- | Draw a cell in the world.+drawCell :: Bool -> World -> Coord -> Cell -> Picture+drawCell visible world (x, y) cell + = let cs = fromIntegral (worldCellSize world)+ cp = fromIntegral (worldCellSpace world)++ posX = fromIntegral x + posY = fromIntegral y++ in if visible+ then pictureOfCell (worldCellSize world) posX posY cell+ else Color (greyN 0.4) (cellShape cs posX posY)+
+ Occlusion/State.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE PatternGuards #-}++module State where+import World+import Graphics.Gloss.Game++-- | The game state.+data State+ = State+ { stateWorld :: World+ , stateLineStart :: Point+ , stateLineEnd :: Point }+++-- | Initial game state.+initState world+ = State+ { stateWorld = world+ , stateLineStart = (10, 10)+ , stateLineEnd = (10, 10) }+ ++-- | Handle an input event.+handleInput :: World -> Event -> State -> State+handleInput world (EventKey key keyState mods pos) state+ | MouseButton LeftButton <- key+ , Down <- keyState+ , shift mods == Down + = state { stateLineEnd = worldPosOfWindowPos world pos }++ | MouseButton LeftButton <- key+ , Down <- keyState+ = state { stateLineStart = worldPosOfWindowPos world pos + , stateLineEnd = worldPosOfWindowPos world pos }++ | MouseButton RightButton <- key+ , Down <- keyState+ = state { stateLineEnd = worldPosOfWindowPos world pos }++handleInput _ _ state+ = state+
+ Occlusion/World.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE ScopedTypeVariables #-}++module World where+import Cell+import Graphics.Gloss.Game+import Graphics.Gloss.Data.Extent+import Graphics.Gloss.Data.QuadTree+import Graphics.Gloss.Algorithms.RayCast+import System.IO+import Control.Monad+++-- | The game world.+data World + = World+ { worldWidth :: Int+ , worldHeight :: Int+ , worldTree :: QuadTree Cell+ , worldCellSize :: Int+ , worldCellSpace :: Int }+ deriving Show+++-- | Get the extent covering the entire world.+worldExtent :: World -> Extent+worldExtent world+ = makeExtent (worldWidth world) 0 (worldHeight world) 0+++-- | Load a world from a file. +loadWorld :: FilePath -> IO World+loadWorld fileName+ = do str <- readFile fileName+ return $ readWorld str+ + +-- | Read a world from a string.+readWorld :: String -> World+readWorld str+ = let ("WORLD" : strWidthHeight : skip : cellLines) + = lines str+ + [width, height] = map read $ words strWidthHeight+ rows = take height $ cellLines++ cells = concat + $ map (readLine width) + $ reverse rows++ extent = makeExtent height 0 width 0++ in World { worldWidth = width+ , worldHeight = height+ , worldTree = makeWorldTree extent cells+ , worldCellSize = 20+ , worldCellSpace = 0 }++readLine :: Int -> String -> [Cell]+readLine width (s:str)+ = map readCell+ $ take width str++++-- | Get the size of the window needed to display a world.+windowSizeOfWorld :: World -> (Int, Int)+windowSizeOfWorld world+ = let cellSize = worldCellSize world+ cellSpace = worldCellSpace world+ cellPad = cellSize + cellSpace+ height = cellPad * (worldHeight world) + cellSpace+ width = cellPad * (worldWidth world) + cellSpace+ in (width, height)+++-- | Create the tree representing the world from a list of all its cells.+makeWorldTree :: Extent -> [Cell] -> QuadTree Cell+makeWorldTree extent cells+ = foldr insert' emptyTree nonEmptyPosCells+ where + insert' (pos, cell) tree+ = case insertByCoord extent pos cell tree of+ Nothing -> tree+ Just tree' -> tree'+ + (width, height) + = sizeOfExtent extent+ + posCells + = zip [(x, y) | y <- [0 .. height - 1]+ , x <- [0 .. width - 1]]+ cells+ + nonEmptyPosCells + = filter (\x -> snd x /= CellEmpty) posCells+++-- | Get the world position coresponding to a point in the window.+worldPosOfWindowPos :: World -> Point -> Point+worldPosOfWindowPos world (x, y)+ = let (windowSizeX, windowSizeY)+ = windowSizeOfWorld world+ + offsetX = fromIntegral $ windowSizeX `div` 2+ offsetY = fromIntegral $ windowSizeY `div` 2+ + scale = fromIntegral $ worldCellSize world+ + x' = (x + offsetX) / scale+ y' = (y + offsetY) / scale++ in (x', y')+++-- | Check if a the cell at a given coordinate is visible from a point.+cellAtCoordIsVisibleFromCoord :: World -> Coord -> Coord -> Bool+cellAtCoordIsVisibleFromCoord world cFrom cTo+ = let (cx, cy) = cFrom+ pFrom = (fromIntegral cx + 0.5 , fromIntegral cy + 0.5)+ in cellAtCoordIsVisibleFromPoint world pFrom cTo+++-- | Check if a cell at a given coordinate is visible from a point.+-- We say it's visible if the center of any of its faces is visible.+cellAtCoordIsVisibleFromPoint :: World -> Point -> Coord -> Bool+cellAtCoordIsVisibleFromPoint world pFrom (x', y')+ = or $ map (cellAtPointIsVisibleFromPoint world pFrom) [pa, pb, pc, pd]+ where x :: Float = fromIntegral x' + 0.5+ y :: Float = fromIntegral y' + 0.5+ pa = (x - 0.4999, y)+ pb = (x + 0.4999, y)+ pc = (x, y - 0.4999)+ pd = (x, y + 0.4999)+ + +-- | Check if a point on some cell (P2) is visible from some other point (P1).+cellAtPointIsVisibleFromPoint :: World -> Point -> Point -> Bool+cellAtPointIsVisibleFromPoint world p1 p2+ = let mOccluder = castSegIntoWorld world p1 p2+ in case mOccluder of+ Nothing -> False+ Just (pos, extent, cell) -> pointInExtent extent p2+++-- | Given a line segment (P1-P2) get the cell closest to P1 that intersects the segment.+castSegIntoWorld :: World -> Point -> Point -> Maybe (Point, Extent, Cell)+castSegIntoWorld world p1 p2+ = castSegIntoCellularQuadTree p1 p2 (worldExtent world) (worldTree world)+++-- | Given a line segment (P1-P2) get the cell closest to P1 that intersects the segment.+traceSegIntoWorld :: World -> Point -> Point -> [(Point, Extent, Cell)]+traceSegIntoWorld world p1 p2+ = traceSegIntoCellularQuadTree p1 p2 (worldExtent world) (worldTree world)++
Styrene/Contact.hs view
@@ -102,7 +102,7 @@ closeEnough = distancePP_contact pBead pClosest `ltFloat#` radius# -- uParam gives where pClosest is relative to the endponts of the wall- uParam = closestPointOnLine_param pWall1 pWall2 pBead+ uParam = closestPointOnLineParam pWall1 pWall2 pBead -- pClosest needs to lie on the line segment between pWal1 and pWall2 inSegment = uParam >= 0 && uParam <= 1
gloss-examples.cabal view
@@ -1,9 +1,9 @@ Name: gloss-examples-Version: 1.0.1.0+Version: 1.1.0.0 License: MIT License-file: LICENSE Author: Ben Lippmeier-Maintainer: gloss@ouroborus.net+Maintainer: benl@ouroborus.net Build-Type: Simple Cabal-Version: >=1.6 Stability: experimental@@ -20,21 +20,21 @@ Executable gloss-easy Build-depends: base >= 3 && < 5, - gloss >= 1.0 && < 1.1+ gloss >= 1.0 && < 1.2 Main-is: Easy/Main.hs ghc-options: -O2 Executable gloss-clock Build-depends: base >= 3 && < 5, - gloss >= 1.0 && < 1.1+ gloss >= 1.0 && < 1.2 Main-is: Clock/Main.hs ghc-options: -O2 Executable gloss-eden Build-depends: base >= 3 && < 5, - gloss >= 1.0 && < 1.1, + gloss >= 1.0 && < 1.2, random > 1.0 && < 1.1 Main-is: Main.hs other-modules: Cell Community World@@ -44,21 +44,21 @@ Executable gloss-flake Build-depends: base >= 3 && < 5, - gloss >= 1.0 && < 1.1+ gloss >= 1.0 && < 1.2 Main-is: Flake/Main.hs ghc-options: -O2 Executable gloss-hello Build-depends: base >= 3 && < 5, - gloss >= 1.0 && < 1.1+ gloss >= 1.0 && < 1.2 Main-is: Hello/Main.hs ghc-options: -O2 Executable gloss-lifespan Build-depends: base >= 3 && < 5, - gloss >= 1.0 && < 1.1, + gloss >= 1.0 && < 1.2, random > 1.0 && < 1.1 Main-is: Main.hs other-modules: Cell Community World@@ -68,7 +68,7 @@ Executable gloss-styrene Build-depends: base >= 3 && < 5,- gloss >= 1.0 && < 1.1,+ gloss >= 1.0 && < 1.2, containers >= 0.2 && < 0.4, ghc-prim >= 0.1 && < 0.3 Main-is: Main.hs@@ -79,30 +79,39 @@ Executable gloss-tree Build-depends: base >= 3 && < 5, - gloss >= 1.0 && < 1.1+ gloss >= 1.0 && < 1.2 Main-is: Tree/Main.hs ghc-options: -O2 Executable gloss-zen Build-depends: base >= 3 && < 5, - gloss >= 1.0 && < 1.1+ gloss >= 1.0 && < 1.2 Main-is: Zen/Main.hs ghc-options: -O2 Executable gloss-machina Build-depends: base >= 3 && < 5, - gloss >= 1.0 && < 1.1+ gloss >= 1.0 && < 1.2 Main-is: Machina/Main.hs ghc-options: -O2 Executable gloss-conway Build-depends: base >= 3 && < 5, - gloss >= 1.0 && < 1.1,+ gloss >= 1.0 && < 1.2, vector >= 0.5 && < 0.6 Main-is: Main.hs other-modules: Cell World hs-source-dirs: Conway+ ghc-options: -O2++Executable gloss-occlusion+ Build-depends: + base >= 3 && < 5, + gloss >= 1.1 && < 1.2+ Main-is: Main.hs+ other-modules: Cell World State Data+ hs-source-dirs: Occlusion ghc-options: -O2