-
Notifications
You must be signed in to change notification settings - Fork 4
/
Asteroids.hs
128 lines (101 loc) · 3.52 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
{-# LANGUAGE CPP #-}
{-# OPTIONS -pgmP cpp #-}
module Asteroids where
import Graphics.UI.WX
import Graphics.UI.WXCore hiding (window,bitmap)
import Control.Monad
#ifdef __UHC__
import Language.UHC.JS.Marshal
import Language.UHC.JS.Types
import Language.UHC.JS.Prelude
foreign import js "Math.random()"
random :: IO Double
#else
random = undefined
_trace = undefined
str = undefined
#endif
rand _ = unsafePerformIO random
randoms :: [Double]
randoms =
let inf = undefined : inf
in map rand inf
height :: Int
height = 300
width :: Int
width = 300
diameter :: Int
diameter = 24
chance :: Double
chance = 0.1
asteroids :: IO ()
asteroids =
do
vrocks <- varCreate randomRocks
vship <- varCreate $ div width 2
w <- window Nothing [area := rect (pt 0 0) (sz width height)]
t <- timer w [ interval := 50
, on command := advance vrocks w
]
set w [
on paint := draw vrocks vship
, on leftKey := varUpdate vship (\x -> max 0 (x - 5)) >> return ()
, on rightKey := varUpdate vship (\x -> min width (x + 5)) >> return ()
, on (charKey 'q') := set t [interval :~ \i -> i * 2]
, on (charKey 'w') := (_trace (str "slowdown") >> set t [interval :~ \i -> max 10 (div i 2)])
]
--advance :: (Textual w, Paint w1) => w -> Var [[a]] -> w1 -> IO ()
advance :: (Paint w) => Var [[a]] -> w -> IO ()
advance vrocks f =
do
(r : rs) <- varGet vrocks
varSet vrocks rs
repaint f
randomRocks = flatten [] (map fresh randoms)
flatten :: [[a]] -> [[[a]]] -> [[a]]
flatten rocks (t : ts) =
let now = map head rocks
later = filter (not . null) (map tail rocks)
in now : flatten (t ++ later) ts
flatten rocks [] = error "Empty rocks list not expected in function flatten"
fresh :: Double -> [[Point2 Int]]
fresh r
| r > chance = []
| otherwise = [track (floor (fromIntegral width * r / chance))]
track :: Int -> [Point2 Int]
track x = [point x (y - diameter) | y <- [0, 6 .. height + 2 * diameter]]
--draw :: Var [[Point2 Int]] -> Var Int -> DC a -> b -> IO ()
draw :: Var [[Point2 Int]] -> Var Int -> GraphicsContext -> b -> IO ()
draw vrocks vship dc _view =
do
rocks <- varGet vrocks
x <- varGet vship
let
shipLocation = point x (height - 2 * diameter)
positions = head rocks
collisions = map (collide shipLocation) positions
drawShip dc shipLocation
mapM (drawRock dc) (zip positions collisions)
--when (or collisions) (play explode)
when (or collisions) (return ())
collide :: Point2 Int -> Point2 Int -> Bool
collide pos0 pos1 =
let distance = vecLength (vecBetween pos0 pos1)
in distance <= fromIntegral diameter
--drawShip :: DC a -> Point -> IO ()
drawShip :: GraphicsContext_ a -> Point -> IO ()
drawShip dc pos = drawBitmap dc ship pos True []
--drawRock :: DC a -> (Point, Bool) -> IO ()
drawRock :: GraphicsContext_ a -> (Point, Bool) -> IO ()
drawRock dc (pos, collides)=
let rockPicture = if collides then burning else rock
in do --consoleLog (str (show (pointX pos) ++ "," ++ show (pointY pos)))
drawBitmap dc rockPicture pos True []
rock :: GraphicsBitmap
rock = bitmap "../resources/rock.ico"
burning :: GraphicsBitmap
burning = bitmap "../resources/burning.ico"
ship :: GraphicsBitmap
ship = bitmap "../resources/ship.ico"
main :: IO ()
main = start asteroids