module Main where
-- import Control.Applicative
import Control.Concurrent.Chan
import Control.Concurrent hiding (yield)
import Control.Monad hiding (forever)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Data.List
import qualified Graphics.UI.SDL as SDL
import Reactive.Thread
data UpOrDown = Up | Down
deriving (Eq, Ord, Show)
type KeyboardChan = Chan (UpOrDown, SDL.Keysym)
heldOf :: KeyboardChan -> [SDL.SDLKey] -> Update o (UpdateVar [SDL.SDLKey])
heldOf origKeyChan keys = parallel [] $ do
keyChan <- liftIO $ dupChan origKeyChan
evalStateT (foreverT $ go keyChan) []
where
go keyChan = do
(upOrDown, sym) <- liftIO $ readChan keyChan
let key = SDL.symKey sym
when (key `elem` keys) $ do
held <- get
let held' = case upOrDown of
Up -> delete key held
Down -> key : held
put held'
lift $ yield held'
keyboard
:: KeyboardChan
-> a
-> [(SDL.SDLKey, a)]
-> Update o (UpdateVar a)
keyboard keyChan z keys = parallel z $ do
held <- heldOf keyChan (map fst keys)
forever $ do
heldKeys <- query held
case heldKeys of
[] -> yield z
(key:_) -> maybe (return ()) yield $ lookup key keys
type Thread o = Update o ()
type Time = Double
constantTick :: Double {-FPS-} -> Update o (UpdateVar Time)
constantTick fps = parallel 0 $ evalStateT (foreverT go) 0
where
go = do
liftIO . threadDelay $ floor (1000 * 1000 / fps)
t' <- gets succ
put t'
lift $ yield t'
velocity
:: Double -- ^ Initial position.
-> UpdateVar Time -- ^ Time.
-> UpdateVar Double -- ^ Velocity.
-> Update o (UpdateVar Double)
velocity z timeVar velVar = parallel z $ do
zeroTime <- query timeVar
evalStateT (foreverT go) (z, zeroTime)
where
go = do
(pos, time) <- get
time' <- lift $ query timeVar
vel <- lift $ query velVar
let dt = time' - time
pos' <- if dt > 0 && vel /= 0
then do
let pos' = pos + dt * vel
lift $ yield pos'
return pos'
else return pos
put (pos', time')
data Sprite = Sprite !Double !Double
deriving (Show)
player
:: UpdateVar Time
-> KeyboardChan
-> Update o (UpdateVar Sprite)
player timer keyChan = parallel (Sprite 0 0) $ do
xVel <- keyboard keyChan 0 [(SDL.SDLK_LEFT, -1), (SDL.SDLK_RIGHT, 1)]
yVel <- keyboard keyChan 0 [(SDL.SDLK_UP, -1), (SDL.SDLK_DOWN, 1)]
x <- velocity 0 timer xVel
y <- velocity 0 timer yVel
forever $ do
sprite <- Sprite
`liftM` query x
`ap` query y
yield sprite
gameLoop :: SDL.Surface -> KeyboardChan -> Thread ()
gameLoop surface keyChan = do
timer <- constantTick 60
p <- player timer keyChan
forever $ do
sprite <- query p
liftIO $ do
let format = SDL.surfaceGetPixelFormat surface
black <- SDL.mapRGB format 0 0 0
void $ SDL.fillRect surface Nothing black
drawSprite surface sprite
SDL.flip surface
drawSprite :: SDL.Surface -> Sprite -> IO ()
drawSprite surface (Sprite x y) = do
let format = SDL.surfaceGetPixelFormat surface
color <- SDL.mapRGB format 0 128 255
void $ SDL.fillRect surface (Just region) color
where
region = SDL.Rect
(floor x) (floor y)
width height
width = 32
height = 32
main :: IO ()
main = SDL.withInit [SDL.InitEverything] $ do
surface <- SDL.setVideoMode initialWidth initialHeight 32
[SDL.HWSurface, SDL.Resizable, SDL.RLEAccel, SDL.DoubleBuf]
keyboardChan <- newChan
gameThreadID <- forkIO $ runUpdate (gameLoop surface keyboardChan)
_ <- eventLoop keyboardChan
killThread gameThreadID
where
initialWidth = 640
initialHeight = 480
eventLoop keyboardChan = pollEvent
where
pollEvent = SDL.pollEvent >>= handleEvent
handleEvent event = case event of
SDL.NoEvent -> SDL.waitEvent >>= handleEvent
SDL.KeyDown SDL.Keysym { SDL.symKey = SDL.SDLK_ESCAPE }
-> return () -- Stop.
SDL.KeyDown sym -> do
writeChan keyboardChan (Down, sym)
pollEvent
SDL.KeyUp sym -> do
writeChan keyboardChan (Up, sym)
pollEvent
_ -> pollEvent