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, overGraphics, withColor)
import Graphics.HGL.Draw.Monad (Graphic())
import Graphics.HGL.Draw.Text (text)
import Graphics.HGL.Key (isControlLKey, isDownKey, isLeftKey, isRightKey, isUpKey)
-- to make ghc happy -- delete for hugs
fromInt :: Num a=> Int-> a
fromInt n = fromInteger (toInteger n)
data State = State { ship :: Ship, bullets :: [Bullet], asteroids :: [Asteroid], game :: Game }
data Ship =
Ship { pos :: Point,
shp :: Shape,
vel :: Point,
ornt :: Double,
thrust :: Double,
hAcc :: Double,
bbox :: BBox}
deriving (Eq)
data Bullet =
Bullet { posB :: Point,
shpB :: Shape,
velB :: Point,
time :: Int,
bboxb :: BBox}
deriving (Eq)
data Asteroid =
Asteroid { posA :: Point,
shpA :: Shape,
velA :: Point,
size :: Int,
bboxa :: BBox}
deriving (Eq)
data Game = Over | Continue
deriving (Eq)
type BBox = (Point, Point)
spaceShip :: Figure
spaceShip = Polygon [(10, 4), (-10, 10), (-15, 0), (-10, -10), (10, -4), (0, -4) , (0, 4), (10, 4)]
spaceShipBox :: BBox
spaceShipBox = ((-15, -15), (15, 15))
asteroid :: [Point]
asteroid = [(8, 0), (2, 6), (-6, 4), (-6, -4), (2, -6), (8, 0)]
asteroidBox :: BBox
asteroidBox = ((-8, -8), (8, 8))
asteroidS :: Figure
asteroidS = Polygon asteroid
asteroidM :: Figure
asteroidM = Polygon (map (\(x, y) -> (2*x, 2*y)) asteroid)
asteroidL :: Figure
asteroidL = Polygon (map (\(x, y) -> (4*x, 4*y)) asteroid)
asteroidList :: [Figure]
asteroidList = asteroidS:asteroidM:asteroidL:[]
bulletBox :: BBox
bulletBox = ((-2, -2), (2, 2))
bullet :: Figure
bullet = Polygon [(2, 0), (-1, -1), (-1, 1), (2, 0)]
winSize :: (Int, Int)
winSize = (1000, 800)
aDelta :: Double
aDelta = 1
vMax :: Double
vMax = 20
hDelta :: Double
hDelta = 0.3
maxBTime :: Int
maxBTime = 48
maxAsteroids :: Int
maxAsteroids = 6
minAstDir :: Double
minAstDir = (- pi)
maxAstDir :: Double
maxAstDir = pi
-- asteroidNumber :: IO Int
-- asteroidNumber = randomRIO (1, maxAsteroids)
asteroidNumber :: Int
asteroidNumber = maxAsteroids
-- asteroidDirection :: IO Double
-- asteroidDirection = randomRIO (minAstDir, maxAstDir)
asteroidDirection :: Double
asteroidDirection = 1.0
boxAsteroid :: Point -> Int -> BBox
boxAsteroid p s = translate (resize asteroidBox sze) p
where sze = s + 1
translate :: BBox -> Point -> BBox
translate (a, b) c = (addWinMod a c, addWinMod b c)
resize :: BBox -> Int -> BBox
resize ((xa, ya), (xb, yb)) s = ((s * xa, s * ya), (s * xb, s * yb))
initialState :: State
initialState =
State {ship= setShp $
Ship{pos= shipPos, vel= (0, 0), ornt= pi/2,
thrust= 0, hAcc= 0, bbox = translate spaceShipBox shipPos},
bullets = [], asteroids =
Asteroid{posA = ast1, velA = (1, 1),
bboxa = boxAsteroid ast1 2,
shpA = shape (Translate ast1 asteroidL), size = 2}:
Asteroid{posA = ast2, velA = (1, -1),
bboxa = boxAsteroid ast2 2,
shpA = shape (Translate ast2 asteroidL), size = 2}:
Asteroid{posA = ast3, velA = (-1, 1),
bboxa = boxAsteroid ast3 2,
shpA = shape (Translate ast3 asteroidL), size = 2}:
Asteroid{posA = ast4, velA = (-1, -1),
bboxa = boxAsteroid ast4 2,
shpA = shape (Translate ast4 asteroidL), size = 2}:[],
game = Continue}
where
minXP = 100
minYP = 100
maxXP = fst winSize - 100
maxYP = snd winSize - 100
ast1 = (minXP, minYP)
ast2 = (minXP, maxYP)
ast3 = (maxXP, minYP)
ast4 = (maxXP, maxYP)
shipPos = (fst winSize `div` 2, snd winSize `div` 2)
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
setShp :: Ship-> Ship
setShp s = s{shp= shape (Translate (pos s)
(Rotate (ornt s) spaceShip)),
bbox = translate spaceShipBox (pos s)}
moveAsteroids :: [Asteroid] -> [Asteroid]
moveAsteroids [] = []
moveAsteroids (Asteroid{posA = pa, velA = va, size = s}:as) =
Asteroid{posA = position, shpA = shape (Translate position (asteroidList !! s)),
velA = va, size = s, bboxa = boxAsteroid position s}:(moveAsteroids as)
where position = addWinMod pa va
moveBullets :: [Bullet] -> [Bullet]
moveBullets [] = []
moveBullets (Bullet{posB = pb, velB = vb, time = tb}:bs)
| tb >= maxBTime = moveBullets bs
| otherwise = Bullet{posB = position, shpB = shape (Translate position bullet),
velB = vb, time = tb + 1, bboxb = translate bulletBox position}:(moveBullets bs)
where position = addWinMod pb vb
addWinMod :: (Int,Int) -> (Int,Int) -> (Int,Int)
addWinMod (a, b) (c, d)=
((a+ c) `mod` (fst winSize),
(b+ d) `mod` (snd winSize))
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 Blue else if thrust s< 0 then Yellow else Green)
(drawShape (shp s))
drawAsteroid :: Asteroid -> Graphic
drawAsteroid a = withColor White (drawShape (shpA a))
drawBullet :: Bullet -> Graphic
drawBullet b = withColor Red (drawShape (shpB b))
lostState :: State -> State
lostState st = st{game = Over} -- nicht komplett
wonState :: State -> State
wonState st = st{game = Over} -- auch nicht komplett
bounding :: BBox -> BBox -> Bool
bounding ((xa, ya), (xb, yb)) ((xc, yc), (xd, yd))
| yd < ya || yc > yb || xd < xa || xc > xb = False
| otherwise = True
checkIntersections :: State -> State
checkIntersections st@State{ship = s, asteroids = a, bullets = b}
| a == [] = wonState st
| or [intersect (shp s) x | Asteroid{shpA = x, bboxa = xa} <- a, bounding xa (bbox s)] = lostState st
| otherwise = st{asteroids = (interSecAst intersecting) ++ [x | x <- a, not (elem x intersecting)],
bullets = [bul | bul@Bullet{shpB = x} <- b,
not (or [intersect x y | Asteroid{shpA = y} <- intersecting])]}
where intersecting = [x | x@Asteroid{shpA = xa, bboxa = ya} <- a,
or [intersect xa xb| Bullet{shpB = xb, bboxb = yb} <- b,
bounding ya yb]]
interSecAst :: [Asteroid] -> [Asteroid]
interSecAst [] = []
interSecAst (a:as)
| s == 0 = interSecAst as
| otherwise = [Asteroid{posA = p, size = (s - 1),
shpA = shape (Translate p (asteroidList !! (s - 1))),
velA = rot (asteroidDirection + (pi - (fromInt (mod n (maxAsteroids + 1))))) (3 - s, 3 - s),
bboxa = translate (resize asteroidBox (s + 1)) p} | n <- [1..asteroidNumber]] ++
interSecAst as
where
s = (size a)
p = (posA a)
loop :: Window-> State-> IO ()
loop w s =
do setGraphic w (drawState s)
getWindowTick w
evs<- getEvs
t <- nextState evs s
loop w t
where
-- gameOver :: State -> IO ()
-- gameOver s
-- | (game s) == Over =
-- do drawInWindow w (text (fst winSize `div` 2, snd winSize `div` 2) "You lost!!!!")
-- | [(0::Int)| x <- (asteroids s)] == [] =
-- do drawInWindow w (text (fst winSize `div` 2, snd winSize `div` 2) "You won!")
-- | otherwise = loop w s
nextState :: [Event]-> State-> IO State
nextState evs t =
do return $ checkIntersections s1{ship= moveShip (ship s1),
asteroids = moveAsteroids (asteroids s1),
bullets = moveBullets (bullets s1)}
where
s1= foldl (flip procEv) t evs
getEvs :: IO [Event]
getEvs = do x<- maybeGetWindowEvent w
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
| isDownKey k && down = setThrust (- aDelta)
| isDownKey k && not down = setThrust 0
| isControlLKey k && down = shoot
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}}
shoot :: State -> State
shoot t@State{ship = Ship{pos = pos0, ornt = r}, bullets = b} =
t{bullets= b ++ [Bullet{time = 0, velB = speed,
posB = pos0, shpB = shape (Translate (addWinMod pos0 speed) bullet),
bboxb = translate bulletBox pos0}]}
where speed = (rot r (round (1.5 * vMax), 0))
main :: IO ()
main = runGraphics $
do w<- openWindowEx "Starshiptroopers II: Bugwars (ft. Spaceman Spiff)"
Nothing winSize DoubleBuffered
(Just 30)
loop w initialState
closeWindow w