-- A wee asteroids game.
module Main (main) where
import Asteroids.Geometry
import Graphics.HGL.Run (runGraphics)
import Graphics.HGL.Window (Event(..), RedrawMode(..), Window(), closeWindow, getWindowTick, maybeGetWindowEvent, openWindowEx, setGraphic)
import Graphics.HGL.Units (Point())
import Graphics.HGL.Utils (Color(..), drawInWindow, getKey, overGraphics, withColor, withRGB)
import Graphics.HGL.Draw.Monad (Graphic())
import Graphics.HGL.Draw.Text (text, RGB(..))
import Graphics.HGL.Key (isCharKey, isEscapeKey, isLeftKey, isRightKey, isUpKey, keyToChar, Key)
import System.Random (Random,randomRIO)
-- to make ghc happy -- delete for hugs
fromInt :: Num a=> Int-> a
fromInt = fromInteger . toInteger
type Vector= Point
data State =
State { bullets :: [Bullet],
asteroids :: [Asteroid],
ship :: Ship
}
data Ship =
Ship { pos :: Point, -- Position
shp :: Shape, -- Shape
vel :: Vector, -- Velocity (as a vector)
ornt :: Double, -- Orientation (of spaceship)
thrust :: Double, -- Thrust
hAcc :: Double -- Winkelbeschleungigung
} -- deriving Show
data Bullet =
Bullet { bpos :: Point, -- Position
bshp :: Shape, -- Shape
bvel :: Vector, -- Velocity (does not change)
cnt :: Int -- Counter; when it reaches bTTL,
-- the bullet expires and goes away
}
data Asteroid =
Asteroid {fig :: Figure, -- shapely figure :-)
ashp :: Shape, -- Shape
apos :: Point, -- Position
avel :: Vector, -- Velocity (does not change)
size :: ASize -- size: large, medium, wee.
}
data ASize = ALarge | AMedium | AWee
initialState :: State
initialState = State {ship= -- initial ship position: middle of screen,
-- no movement, facing north (i.e. upwards)
setShp(Ship { pos= (fst winSize `div` 2,
snd winSize `div` 2),
vel= (0, 0), ornt= pi/2,
thrust= 0, hAcc= 0}),
bullets= [],
asteroids= []}
-- parameters
winSize :: (Int, Int)
winSize = (1000, 800)
aDelta :: Double
aDelta = 1 -- thrust
vMax :: Double
vMax = 20 -- maximal velocity, in pixels per frame
hDelta :: Double
hDelta = 0.3 -- Winkelbeschleunigung
vB :: Double
vB = 30 -- velocity of a bullet
bTTL :: Int
bTTL = 20 -- a single bullet moves that many frames (i.e. vB*bTTL pixels)
vAst :: Int
vAst = 5 -- all asteroids move that fast
-- This is our space ship (drawn with orientation 0)
spaceShip :: Figure
spaceShip = Polygon [(15, 0), (-15, 10), (-10, 0), (-15, -10), (15, 0)]
-- Auxiliary functions
addWinMod :: (Int,Int) -> (Int,Int) -> (Int,Int)
addWinMod (a, b) (c, d)=
((a+ c) `mod` (fst winSize), (b+ d) `mod` (snd winSize))
setShp :: Ship-> Ship
setShp s = s{shp= shape (Translate (pos s) (Rotate (ornt s) spaceShip))}
setBShp :: Bullet-> Bullet
setBShp b =
b{bshp= shape (Translate (bpos b) (Circle 2))}
setAShp :: Asteroid-> Asteroid
setAShp a =
a{ashp= shape (Translate (apos a) (fig a))}
-- Drawing stuff
drawState :: State-> Graphic
drawState s =
overGraphics (drawShip (ship s):
map drawBullet (bullets s) ++ map drawAsteroid (asteroids s))
drawShip :: Ship-> Graphic
drawShip s =
withColor (if thrust s> 0 then Red else Blue) (drawShape (shp s))
drawBullet :: Bullet-> Graphic
drawBullet b =
withColor Red (drawShape (bshp b))
drawAsteroid :: Asteroid-> Graphic
drawAsteroid a =
withRGB (RGB 100 100 100) (drawShape (ashp a))
-- The asteroids
randomPt :: IO Point
randomPt = random2IO ((0, fst winSize), (0, snd winSize))
random2IO :: ((Int, Int), (Int, Int))-> IO (Int, Int)
random2IO ((xmin, ymin), (xmax, ymax)) =
do x<- randomRIO (xmin, xmax)
y<- randomRIO (ymin, ymax)
return (x, y)
newAsteroid :: IO Asteroid
newAsteroid =
do position <- randomPt
cs <- randomRIO (4, 8) -- number of corners
pts <- mapM (\angle-> do r <- randomRIO (30::Double, 50)
return (polar r angle))
(tail [0::Double, 2*pi/fromInt cs .. 2*pi])
randomRIO (0::Double, 2*pi)
ve <- random2IO ((-vAst, -vAst), (vAst, vAst))
return (setAShp(Asteroid{fig= Polygon pts,
apos= position, avel= ve, size= ALarge}))
createAsteroids :: State-> IO State
createAsteroids s =
do asts <- sequence (replicate 5 newAsteroid)
return s{asteroids= asts}
moveAsteroid :: Asteroid-> Asteroid
moveAsteroid a =
setAShp a{apos= addWinMod (apos a) (avel a)}
checkAsteroids :: State-> [Asteroid]-> IO [Asteroid]
checkAsteroids _ [] = return []
checkAsteroids s (a:as) =
do rest <- checkAsteroids s as
if any (contains (ashp a)) (map bpos (bullets s)) then
-- asteroid hit, it detonates
do dirs <- directions (avel a)
return (explode a dirs ++ rest)
else return (a:rest) where
explode :: Asteroid-> [Point]-> [Asteroid]
explode (Asteroid{size= ALarge, apos= p, fig= f}) =
map (\v-> setAShp (Asteroid{fig= Scale 0.5 f, apos= p,
avel= v, size= AMedium}))
explode (Asteroid{size= AMedium, apos= p, fig= f}) =
map (\v-> setAShp (Asteroid{fig= Scale 0.75 f, apos= p,
avel= v, size= AWee}))
explode (Asteroid{size= AWee}) = const []
directions :: Point-> IO [Point]
directions (vx, vy) =
do num <- randomRIO (1, 3)
vxs <- sequence (replicate num (randomRIO (-vx, vx)))
vys <- sequence (replicate num (randomRIO (-vy, vy)))
return (map (add (vx, vy)) (zip vxs vys))
-- The bullets and the ship
-- create a new bullet, starting from the position of the ship
newBullet :: State-> State
newBullet (s@(State{bullets= b, ship= Ship{pos= position, ornt= o}}))=
s{bullets= Bullet{bpos= position, bvel= polar vB o, cnt= 0}: b}
-- Move and expire bullets
moveBullets :: [Bullet]-> [Bullet]
moveBullets bs =
filter (\b-> cnt b< bTTL) (map moveOne bs) where
moveOne (Bullet{bpos= op, bvel= bv, cnt= c})=
Bullet{bpos= addWinMod op bv, bvel= bv, cnt= c+1}
-- Calculate ship movement and new position
moveShip :: Ship-> Ship
moveShip(Ship {pos= pos0, vel= vel0,
hAcc= hAcc, thrust= t, ornt= o}) =
setShp $
Ship{pos= addWinMod pos0 vel1,
vel= if l> vMax then smult (vMax/l) vel1 else vel1,
thrust= t, ornt= o+ hAcc, hAcc= hAcc} where
vel1= add (polar t o) vel0
l = len vel1
shipCrashed :: State-> Bool
shipCrashed (State{ship= Ship{shp=f}, asteroids= ast}) =
any (intersect f) (map ashp ast)
loop :: Window-> State-> IO ()
loop w s =
do setGraphic w (drawState s)
if shipCrashed s then do
drawInWindow w (text (pos (ship s)) "BOING!")
untl (getKey w >>= return . isEscapeKey)
else do
getWindowTick w
evs<- getEvs
t<- nextState evs s
loop w t where
nextState :: [Event]-> State-> IO State
nextState evs t =
do ast<- checkAsteroids s2 (asteroids s2)
return s2{asteroids= ast} where
s2= State {ship= moveShip (ship s1),
bullets= map setBShp (moveBullets (bullets s1)),
asteroids= map moveAsteroid (asteroids s1)} where
s1= foldl (flip procEv) t evs
-- get list of all events since last tick
getEvs :: IO [Event]
getEvs = do x<- maybeGetWindowEvent w
-- putStrLn ("Reporting event "++ show x)
case x of
Nothing -> return []
Just e -> do rest <- getEvs
return (e : rest)
procEv :: Event-> State-> State
procEv (Key {keysym= k, isDown=down})
| isLeftKey k && down = sethAcc hDelta
| isLeftKey k && not down = sethAcc 0
| isRightKey k && down = sethAcc (- hDelta)
| isRightKey k && not down = sethAcc 0
| isUpKey k && down = setThrust aDelta
| isUpKey k && not down = setThrust 0
| isKey ' ' k && down = newBullet
procEv _ = id
sethAcc :: Double->State-> State
sethAcc a t = s{ship= (ship t){hAcc= a}}
setThrust :: Double-> State-> State
setThrust a t = s{ship= (ship t){thrust= a}}
untl :: IO Bool-> IO ()
untl a = a >>= \ b-> if b then return () else untl a
isKey :: Char-> Key-> Bool
isKey c k = isCharKey k && (keyToChar k == c)
main :: IO ()
main =
runGraphics (do w<- openWindowEx "Asteroids!" Nothing winSize DoubleBuffered
(Just 20)
s<- createAsteroids initialState
loop w s
closeWindow w)