{-----------------------------------------------------------------------------
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"
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
import Control.Monad
import System.Random
import qualified Graphics.UI.Threepenny as UI
import Graphics.UI.Threepenny.Core hiding (Event)
import Reactive.Banana
import Reactive.Banana.Threepenny
import Paths (getDataFile)
import System.FilePath
{-----------------------------------------------------------------------------
Main
------------------------------------------------------------------------------}
-- constants
height, width, diameter :: Int
height = 300
width = 300
diameter = 24
chance :: Double
chance = 0.1
-- explode :: WXCore.Sound ()
-- explode = sound $ getDataFile "explode.wav"
{-----------------------------------------------------------------------------
Game Logic
------------------------------------------------------------------------------}
-- main game function
main :: IO ()
main = do
startGUI Config
{ tpPort = 10000
, tpCustomHTML = Nothing
, tpStatic = ""
} asteroids
asteroids :: Window -> IO ()
asteroids window = do
return window # set title "Asteroids"
-- user interface
canvas <- UI.canvas
# set UI.height height
# set UI.width width
# set style [("border","solid black 1px")]
# set (attr "tabindex") "1" -- allow keyboard events here
status <- UI.span # set text "Welcome to asteroids"
-- resources: images and audio
let
loadImage name = do
url <- loadFile window "image/png" =<< getDataFile (name <.> "png")
img <- UI.img # set UI.src url
return $ \(Point x y) -> UI.drawImage img (x,y) canvas
[drawShip, drawRock, drawBurning] <- mapM loadImage (words "ship rock burning")
audio <- do
url <- loadFile window "audio/wav" =<< getDataFile "explode.wav"
UI.audio # set UI.src url
let
clearCanvas = UI.clearCanvas canvas
playExplosion = UI.audioPlay audio
resources = Resources {..}
getBody window #+ [column
[element canvas, element status
,string "Click on the canvas and use the arrow keys to move."]
,element audio]
{-
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)]
]
-}
timer <- UI.timer # set UI.interval 50
-- event network
let networkDescription :: forall t. Frameworks t => Moment t ()
networkDescription = do
-- timer
etick <- event UI.tick timer
-- keyboard events
ekey <- event UI.keydown canvas
let eleft = filterE (== 37) ekey
eright = filterE (== 39) 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
reactimate $ (drawGameState resources <$> bship <*> brocks) <@ etick
-- status bar
let bstatus :: Behavior t String
bstatus = (\r -> "rocks: " ++ show (length r)) <$> brocks
return status # sink UI.text bstatus
network <- compile networkDescription
actuate network
UI.start timer
-- rock logic
type Position = Point
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)
collide :: Position -> Position -> Bool
collide pos0 pos1 =
let distance = vecLength (vecBetween pos0 pos1)
in distance <= fromIntegral diameter
-- draw game state
data Resources = Resources
{ drawShip :: Position -> IO ()
, drawRock :: Position -> IO ()
, drawBurning :: Position -> IO ()
, clearCanvas :: IO ()
, playExplosion :: IO ()
}
drawGameState :: Resources -> Int -> [Rock] -> IO ()
drawGameState r@(Resources{..}) ship rocks = do
let
shipLocation = point ship (height - 2 * diameter)
positions = map head rocks
collisions = map (collide shipLocation) positions
clearCanvas
drawShip shipLocation
mapM_ (drawEnemyRock r) (zip positions collisions)
when (or collisions) playExplosion
drawEnemyRock :: Resources -> (Position, Bool) -> IO ()
drawEnemyRock (Resources{..}) (pos, collides) = draw pos
where draw = if collides then drawBurning else drawRock
{-----------------------------------------------------------------------------
2D Geometry
------------------------------------------------------------------------------}
data Point = Point !Int !Int deriving (Show)
data Vector = Vec !Int !Int deriving (Show)
point = Point
vecX (Vec x _) = x
vecY (Vec _ y) = y
vec x y = Vec x y
-- vecScale (Vec x y) s = Vec (s*x) (s*y)
vecAdd (Vec x1 y1) (Vec x2 y2) = Vec (x1+x2) (y1+y2)
vecSub (Vec x1 y1) (Vec x2 y2) = Vec (x1-x2) (y1-y2)
vecLength :: Vector -> Double
vecLength (Vec x y) = sqrt $ fromIntegral $ x*x + y*y
vecBetween (Point x1 y1) (Point x2 y2) = Vec (x2-x1) (y2-y1)