-
Notifications
You must be signed in to change notification settings - Fork 71
/
Asteroids.hs
164 lines (127 loc) · 5.25 KB
/
Asteroids.hs
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://wiki.haskell.org/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 []