haskell-in-space-0.1: Asteroids-space.hs

module 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(..), withColor)
import Graphics.HGL.Draw.Monad (Graphic())
import Graphics.HGL.Key (isLeftKey, isRightKey, isUpKey)

data State = State { ship  :: Ship }
data Ship =
   Ship { pos    :: Point,
          shp    :: Shape,
          vel    :: Point,
          ornt   :: Double,
          thrust :: Double,
          hAcc   :: Double }
spaceShip :: Figure
spaceShip = Polygon [(15, 0), (-15, 10),
                     (-10, 0), (-15, -10), (15, 0)]
winSize :: (Int, Int)
winSize = (1000, 800)
aDelta :: Double
aDelta = 1
vMax :: Double
vMax = 20
hDelta :: Double
hDelta = 0.3
initialState :: State
initialState =
  State {ship= setShp $
     Ship{pos= (fst winSize `div` 2,
                snd winSize `div` 2),
          vel= (0, 0), ornt= pi/2,
          thrust= 0, hAcc= 0}}

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))}
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 = drawShip (ship s)
drawShip :: Ship-> Graphic
drawShip s =
   withColor (if thrust s> 0 then Red else Blue)
             (drawShape (shp s))
loop :: Window-> State-> IO ()
loop w s =
  do setGraphic w (drawState s)
     getWindowTick w
     evs<- getEvs
     s<- nextState evs s
     loop w s where
       nextState :: [Event]-> State-> IO State
       nextState evs s =
         do return s1{ship= moveShip (ship s1)} where
            s1= foldl (flip procEv) s 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
       procEv _ = id
       sethAcc :: Double->State-> State
       sethAcc a s = s{ship= (ship s){hAcc= a}}
       setThrust :: Double-> State-> State
       setThrust a s = s{ship= (ship s){thrust= a}}
main :: IO ()
main = runGraphics $
  do w<- openWindowEx "Space --- The Final Frontier"
                      Nothing winSize DoubleBuffered
                      (Just 30)
     loop w initialState
     closeWindow w