Skip to content
This repository
branch: master
Heinrich Apfelmus August 24, 2012
file 165 lines (127 sloc) 5.386 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
{-----------------------------------------------------------------------------
reactive-banana-wx
Example:
Asteroids, adapted from
http://www.haskell.org/haskellwiki/WxAsteroids
The original example has a few graphics issues
and I didn't put much work into correcting them.
For more, see also
https://github.com/killerswan/wxAsteroids/issues/1
http://comments.gmane.org/gmane.comp.lang.haskell.wxhaskell.general/1086
------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"

import Graphics.UI.WX hiding (Event)
import Graphics.UI.WXCore as WXCore
import Reactive.Banana
import Reactive.Banana.WX
import System.Random

import Paths (getDataFile)

{-----------------------------------------------------------------------------
Main
------------------------------------------------------------------------------}
-- constants
height, width, diameter :: Int
height = 300
width = 300
diameter = 24

chance :: Double
chance = 0.1

rock, burning, ship :: Bitmap ()
rock = bitmap $ getDataFile "rock.ico"
burning = bitmap $ getDataFile "burning.ico"
ship = bitmap $ getDataFile "ship.ico"

explode :: WXCore.Sound ()
explode = sound $ getDataFile "explode.wav"

main :: IO ()
main = start asteroids

{-----------------------------------------------------------------------------
Game Logic
------------------------------------------------------------------------------}
-- main game function
asteroids :: IO ()
asteroids = do
    ff <- frame [ text := "Asteroids"
                , bgcolor := white
                , resizeable := False ]

    status <- statusField [text := "Welcome to asteroids"]
    set ff [statusBar := [status]]

    t <- timer ff [ interval := 50 ]

    game <- menuPane [ text := "&Game" ]
    new <- menuItem game [ text := "&New\tCtrl+N", help := "New game" ]
    pause <- menuItem game [ text := "&Pause\tCtrl+P"
                           , help := "Pause game"
                           , checkable := True
                           ]
    menuLine game
    quit <- menuQuit game [help := "Quit the game"]

    set new [on command := asteroids]
    set pause [on command := set t [enabled :~ not]]
    set quit [on command := close ff]
    
    set ff [menuBar := [game]]
    
    pp <- panel ff []
    set ff [ layout := minsize (sz width height) $ widget pp ]
    set pp [ on (charKey '-') := set t [interval :~ \i -> i * 2]
           , on (charKey '+') := set t [interval :~ \i -> max 10 (div i 2)]
           ]
    
    -- event network
    let networkDescription :: forall t. Frameworks t => Moment t ()
        networkDescription = do
            -- timer
            etick <- event0 t command
    
            -- keyboard events
            ekey <- event1 pp keyboard
            let eleft = filterE ((== KeyLeft ) . keyKey) ekey
                eright = filterE ((== KeyRight) . keyKey) ekey
        
            -- ship position
            let
                bship :: Behavior t Int
                bship = accumB (width `div` 2) $
                    (goLeft <$ eleft) `union` (goRight <$ eright)
            
                goLeft x = max 0 (x - 5)
                goRight x = min (width-30) (x + 5)
        
            -- rocks
            brandom <- fromPoll (randomRIO (0,1) :: IO Double)
            let
                brocks :: Behavior t [Rock]
                brocks = accumB [] $
                    (advanceRocks <$ etick) `union`
                    (newRock <$> filterE (< chance) (brandom <@ etick))
        
            -- draw the game state
            sink pp [on paint :== stepper (\_dc _ -> return ()) $
                     (drawGameState <$> bship <*> brocks) <@ etick]
            reactimate $ repaint pp <$ etick
        
            -- status bar
            let bstatus :: Behavior t String
                bstatus = (\r -> "rocks: " ++ show (length r)) <$> brocks
            sink status [text :== bstatus]
    
    network <- compile networkDescription
    actuate network


-- rock logic
type Position = Point2 Int
type Rock = [Position] -- lazy list of future y-positions

newRock :: Double -> [Rock] -> [Rock]
newRock r rs = (track . floor $ fromIntegral width * r / chance) : rs

track :: Int -> Rock
track x = [point x (y - diameter) | y <- [0, 6 .. height + 2 * diameter]]

advanceRocks :: [Rock] -> [Rock]
advanceRocks = filter (not . null) . map (drop 1)



-- draw game state
drawGameState :: Int -> [Rock] -> DC a -> b -> IO ()
drawGameState ship rocks dc _view = do
    let
        shipLocation = point ship (height - 2 * diameter)
        positions = map head rocks
        collisions = map (collide shipLocation) positions

    drawShip dc shipLocation
    mapM (drawRock dc) (zip positions collisions)

    when (or collisions) (play explode)

collide :: Position -> Position -> Bool
collide pos0 pos1 =
    let distance = vecLength (vecBetween pos0 pos1)
    in distance <= fromIntegral diameter

drawShip :: DC a -> Point -> IO ()
drawShip dc pos = drawBitmap dc ship pos True []

drawRock :: DC a -> (Point, Bool) -> IO ()
drawRock dc (pos, collides) =
    let rockPicture = if collides then burning else rock
    in drawBitmap dc rockPicture pos True []
Something went wrong with that request. Please try again.