making things work
This commit is contained in:
parent
dc1b65e3fa
commit
e9a9e2cf7b
8 changed files with 122 additions and 257 deletions
Binary file not shown.
Before Width: | Height: | Size: 44 KiB After Width: | Height: | Size: 6.3 KiB |
|
@ -58,6 +58,7 @@ executable haskelloids
|
|||
, Commons
|
||||
, StateMachine
|
||||
, Menu
|
||||
, InGame
|
||||
, Init
|
||||
|
||||
default-extensions: OverloadedStrings
|
||||
|
|
|
@ -38,23 +38,25 @@ wrapAround (V2 nx ny) width = (V2 nnx nny)
|
|||
| otherwise = ny
|
||||
half = width / 2
|
||||
|
||||
newHaskelloids :: Image -> Affection UserData [Haskelloid]
|
||||
newHaskelloids img = liftIO $ mapM (\_ -> do
|
||||
posx <- randomRIO (0, 800)
|
||||
posy <- randomRIO (0, 600)
|
||||
velx <- randomRIO (-10, 10)
|
||||
vely <- randomRIO (-10, 10)
|
||||
rot <- randomRIO (-180, 180)
|
||||
pitch <- randomRIO (-pi, pi)
|
||||
div <- randomRIO (1, 2)
|
||||
return $ Haskelloid
|
||||
(V2 posx posy)
|
||||
(V2 velx vely)
|
||||
rot
|
||||
pitch
|
||||
div
|
||||
img
|
||||
) [1..10]
|
||||
newHaskelloids :: Affection UserData [Haskelloid]
|
||||
newHaskelloids = do
|
||||
img <- haskImage <$> getAffection
|
||||
liftIO $ mapM (\_ -> do
|
||||
posx <- randomRIO (0, 800)
|
||||
posy <- randomRIO (0, 600)
|
||||
velx <- randomRIO (-10, 10)
|
||||
vely <- randomRIO (-10, 10)
|
||||
rot <- randomRIO (-180, 180)
|
||||
pitch <- randomRIO (-pi, pi)
|
||||
div <- randomRIO (1, 2)
|
||||
return $ Haskelloid
|
||||
(V2 posx posy)
|
||||
(V2 velx vely)
|
||||
rot
|
||||
pitch
|
||||
div
|
||||
img
|
||||
) [1..10]
|
||||
|
||||
updateHaskelloid :: Double -> Haskelloid -> Haskelloid
|
||||
updateHaskelloid dsec has =
|
||||
|
|
250
src/InGame.hs
250
src/InGame.hs
|
@ -1,235 +1,81 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
module InGame where
|
||||
|
||||
import Affection
|
||||
import Affection as A
|
||||
import qualified SDL
|
||||
import GEGL
|
||||
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes, isJust, fromJust, isNothing)
|
||||
|
||||
import Control.Monad (when, foldM)
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
import System.Random (randomRIO)
|
||||
|
||||
import Debug.Trace
|
||||
import Linear
|
||||
|
||||
import Types
|
||||
import Commons
|
||||
import Menu
|
||||
|
||||
loadGame :: Affection UserData ()
|
||||
loadGame = do
|
||||
liftIO $ traceIO "loading game"
|
||||
loadGame :: Affection UserData () -> Affection UserData ()
|
||||
loadGame stateChange = do
|
||||
liftIO $ logIO A.Debug "loading game"
|
||||
ud <- getAffection
|
||||
_ <- liftIO $ gegl_node_connect_to
|
||||
(nodeGraph ud M.! KeyShipTranslate)
|
||||
"output"
|
||||
(nodeGraph ud M.! KeyShipOver)
|
||||
"aux"
|
||||
liftIO $ traceIO "nodes connected"
|
||||
hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do
|
||||
coords <- liftIO excludeShip
|
||||
insertHaskelloid acc Nothing coords
|
||||
) [] ([0..9] :: [Int])
|
||||
liftIO $ traceIO "inserted haskelloids"
|
||||
liftIO $ gegl_node_link_many $ map hFlange hs
|
||||
liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop)
|
||||
liftIO $ gegl_node_disconnect
|
||||
(nodeGraph ud M.! KeyFGOver)
|
||||
"aux"
|
||||
liftIO $ traceIO "nodes linked"
|
||||
nhs <- newHaskelloids
|
||||
kid <- partSubscribe (subKeyboard $ subsystems ud)
|
||||
(\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
|
||||
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
|
||||
SDL.KeycodeSpace -> do
|
||||
liftIO $ logIO Debug "TODO: PEW!"
|
||||
SDL.KeycodeR -> do
|
||||
liftIO $ logIO Debug "Reloading"
|
||||
putAffection ud
|
||||
{ stateUUIDs = UUIDClean [] []
|
||||
}
|
||||
loadGame stateChange
|
||||
SDL.KeycodeEscape -> do
|
||||
liftIO $ logIO Debug "Leave to Menu"
|
||||
stateChange
|
||||
_ -> return ()
|
||||
)
|
||||
putAffection ud
|
||||
{ haskelloids = hs
|
||||
, wonlost = Nothing
|
||||
, shots = ParticleSystem
|
||||
(ParticleStorage Nothing [])
|
||||
(nodeGraph ud M.! KeyPNop)
|
||||
(buffer ud)
|
||||
, ship = Ship
|
||||
{ sPos = (375, 275)
|
||||
, sVel = (0, 0)
|
||||
{ stateUUIDs = UUIDClean [] [kid]
|
||||
, haskelloids = nhs
|
||||
, ship = (ship ud)
|
||||
{ sPos = V2 400 300
|
||||
, sVel = V2 0 0
|
||||
, sRot = 0
|
||||
, sFlange = nodeGraph ud M.! KeyShipRotate
|
||||
}
|
||||
, pixelSize = 3
|
||||
, state = InGame
|
||||
}
|
||||
liftIO $ traceIO "game loaded"
|
||||
present
|
||||
(GeglRectangle 0 0 800 600)
|
||||
(buffer ud)
|
||||
True
|
||||
|
||||
excludeShip :: IO (Double, Double)
|
||||
excludeShip = do
|
||||
px <- randomRIO (0, 800)
|
||||
py <- randomRIO (0, 600)
|
||||
inter <- gegl_rectangle_intersect
|
||||
(GeglRectangle px py 100 100)
|
||||
(GeglRectangle 350 250 100 100) -- Ship's starting position and size
|
||||
case inter of
|
||||
Just _ ->
|
||||
excludeShip
|
||||
Nothing ->
|
||||
return (fromIntegral px, fromIntegral py)
|
||||
|
||||
updateGame :: Double -> Affection UserData ()
|
||||
updateGame sec = do
|
||||
ad <- get
|
||||
ud <- getAffection
|
||||
when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize ud > 3) $ do
|
||||
pd <- getAffection
|
||||
liftIO $ gegl_node_set (nodeGraph pd M.! KeyPixelize) $ Operation "gegl:pixelize"
|
||||
[ Property "size-x" $ PropertyInt $ pixelSize pd - 1
|
||||
, Property "size-y" $ PropertyInt $ pixelSize pd - 1
|
||||
]
|
||||
putAffection ud
|
||||
{ pixelSize = pixelSize ud -1
|
||||
}
|
||||
let nx = fst (sPos $ ship ud) + fst (sVel $ ship ud) * sec
|
||||
ny = snd (sPos $ ship ud) + snd (sVel $ ship ud) * sec
|
||||
(nnx, nny) = wrapAround (nx, ny) 50
|
||||
liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipTranslate) $ Operation "gegl:translate"
|
||||
[ Property "x" $ PropertyDouble nnx
|
||||
, Property "y" $ PropertyDouble nny
|
||||
]
|
||||
liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipRotate) $ Operation "gegl:rotate"
|
||||
[ Property "degrees" $ PropertyDouble $ sRot $ ship ud
|
||||
]
|
||||
td <- getAffection
|
||||
putAffection td
|
||||
{ ship = (ship ud)
|
||||
{ sPos = (nnx, nny)
|
||||
}
|
||||
}
|
||||
ud2 <- getAffection
|
||||
nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
|
||||
ud3 <- getAffection
|
||||
putAffection ud3
|
||||
let nhs = map (updateHaskelloid sec) (haskelloids ud)
|
||||
putAffection ud
|
||||
{ haskelloids = nhs
|
||||
, ship = updateShip sec (ship ud)
|
||||
}
|
||||
ud3 <- getAffection
|
||||
ups <- updateParticleSystem (shots ud3) sec shotsUpd
|
||||
ud4 <- getAffection
|
||||
when (isJust $ wonlost ud3) (winlose $ fromJust $ wonlost ud3)
|
||||
putAffection ud4
|
||||
{ shots = ups
|
||||
}
|
||||
|
||||
updateShip :: Double -> Ship -> Ship
|
||||
updateShip ddt s@Ship{..} = s
|
||||
{ sPos = wrapAround (sPos + fmap (dt *) sVel) 40
|
||||
}
|
||||
where
|
||||
dt = realToFrac ddt
|
||||
|
||||
drawGame :: Affection UserData ()
|
||||
drawGame = do
|
||||
ud <- getAffection
|
||||
liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
|
||||
present
|
||||
(GeglRectangle 0 0 800 600)
|
||||
(buffer ud)
|
||||
True
|
||||
mapM_ drawHaskelloid (haskelloids ud)
|
||||
drawShip (ship ud)
|
||||
|
||||
handleGameEvent :: SDL.EventPayload -> Affection UserData ()
|
||||
handleGameEvent e = do
|
||||
ad <- get
|
||||
wd <- getAffection
|
||||
sec <- getDelta
|
||||
case e of
|
||||
SDL.KeyboardEvent dat ->
|
||||
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
|
||||
SDL.KeycodeLeft -> do
|
||||
ud <- getAffection
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
|
||||
&& (isNothing $ wonlost ud)) $ do
|
||||
let rawRot = (sRot $ ship ud) + 15 * sec
|
||||
newRot
|
||||
| rawRot > 360 = rawRot - 360
|
||||
| rawRot < 0 = rawRot + 360
|
||||
| otherwise = rawRot
|
||||
putAffection ud
|
||||
{ ship = (ship ud)
|
||||
{ sRot = newRot
|
||||
}
|
||||
}
|
||||
SDL.KeycodeRight -> do
|
||||
ud <- getAffection
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
|
||||
&& (isNothing $ wonlost ud)) $ do
|
||||
let rawRot = (sRot $ ship ud) - 15 * sec
|
||||
newRot
|
||||
| rawRot > 360 = rawRot - 360
|
||||
| rawRot < 0 = rawRot + 360
|
||||
| otherwise = rawRot
|
||||
putAffection ud
|
||||
{ ship = (ship ud)
|
||||
{ sRot = newRot
|
||||
}
|
||||
}
|
||||
SDL.KeycodeUp ->
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
|
||||
&& (isNothing $ wonlost wd)) $ do
|
||||
ud <- getAffection
|
||||
let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud)
|
||||
vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud)
|
||||
putAffection ud
|
||||
{ ship = (ship ud)
|
||||
{ sVel = (vx, vy)
|
||||
}
|
||||
}
|
||||
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
|
||||
SDL.KeycodeSpace ->
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
|
||||
&& (isNothing $ wonlost wd)) $ do
|
||||
ud <- getAffection
|
||||
liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $
|
||||
Operation "gegl:pixelize"
|
||||
[ Property "size-x" $ PropertyInt 8
|
||||
, Property "size-y" $ PropertyInt 8
|
||||
]
|
||||
-- ad <- get
|
||||
let posX = fst (sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud)
|
||||
posY = snd (sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
|
||||
tempRoot <- liftIO gegl_node_new
|
||||
tempRect <- liftIO $ gegl_node_new_child tempRoot $
|
||||
Operation "gegl:rectangle"
|
||||
[ Property "x" $ PropertyDouble posX
|
||||
, Property "y" $ PropertyDouble posY
|
||||
, Property "width" $ PropertyDouble 4
|
||||
, Property "height" $ PropertyDouble 4
|
||||
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
|
||||
]
|
||||
tempOver <- liftIO $ gegl_node_new_child tempRoot defaultOverOperation
|
||||
_ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux"
|
||||
ips <- insertParticle (shots ud)
|
||||
Particle
|
||||
{ particleTimeToLive = 5
|
||||
, particleCreation = elapsedTime ad
|
||||
, particlePosition = (posX, posY)
|
||||
, particleRotation = 0
|
||||
, particleVelocity =
|
||||
( (floor $ -200 * (sin $ toR $ sRot $ ship ud))
|
||||
, (floor $ -200 * (cos $ toR $ sRot $ ship ud))
|
||||
)
|
||||
, particlePitchRate = 0
|
||||
, particleRootNode = tempRoot
|
||||
, particleNodeGraph = M.fromList
|
||||
[ ("root", tempRoot)
|
||||
, ("over", tempOver)
|
||||
, ("rect", tempRect)
|
||||
]
|
||||
, particleStackCont = tempOver
|
||||
, particleDrawFlange = tempOver
|
||||
}
|
||||
putAffection $ ud
|
||||
{ shots = ips
|
||||
, pixelSize = 8
|
||||
}
|
||||
SDL.KeycodeR ->
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
|
||||
&& isJust (wonlost wd)) $ do
|
||||
liftIO $ traceIO "reloading"
|
||||
liftIO $ clean wd
|
||||
nd <- liftIO $ load
|
||||
putAffection nd
|
||||
loadGame
|
||||
_ -> return ()
|
||||
SDL.WindowClosedEvent _ -> do
|
||||
traceM "seeya!"
|
||||
quit
|
||||
_ -> return ()
|
||||
drawShip :: Ship -> Affection UserData ()
|
||||
drawShip Ship{..} = do
|
||||
ctx <- nano <$> getAffection
|
||||
liftIO $ drawImage ctx (sImg) (sPos - fmap (/2) dim) dim sRot 255
|
||||
where
|
||||
dim = V2 40 40
|
||||
|
|
|
@ -49,6 +49,7 @@ pre = do
|
|||
liftIO $ logIO A.Debug "Setting global resize event listener"
|
||||
_ <- partSubscribe (subWindow subs) $ \msg -> case msg of
|
||||
MsgWindowResize _ _ (V2 w h) -> do
|
||||
liftIO $ logIO A.Debug "Window has been resized"
|
||||
let nw = floor $ fromIntegral h * (800/600)
|
||||
dw = floor $ (fromIntegral w - fromIntegral nw) / 2
|
||||
GL.viewport $= (GL.Position dw 0, GL.Size nw h)
|
||||
|
|
36
src/Menu.hs
36
src/Menu.hs
|
@ -24,32 +24,27 @@ import Foreign.C.Types
|
|||
import Types
|
||||
import Commons
|
||||
|
||||
handleMenuEvent :: (Affection UserData ()) -> [SDL.EventPayload] -> Affection UserData ()
|
||||
handleMenuEvent _ es = do
|
||||
(Subsystems w k) <- subsystems <$> getAffection
|
||||
_ <- consumeSDLEvents w =<< consumeSDLEvents k es
|
||||
return ()
|
||||
|
||||
loadMenu :: Affection UserData ()
|
||||
loadMenu = do
|
||||
loadMenu :: (Affection UserData ()) -> Affection UserData ()
|
||||
loadMenu stateChange = do
|
||||
liftIO $ logIO A.Debug "Loading Menu"
|
||||
ud <- getAffection
|
||||
hs <- newHaskelloids (haskImage ud)
|
||||
_ <- partSubscribe (subKeyboard $ subsystems ud)
|
||||
(\kbdev -> case SDL.keysymKeycode (msgKbdKeysym kbdev) of
|
||||
SDL.KeycodeEscape -> do
|
||||
liftIO $ logIO A.Debug "seeya"
|
||||
quit
|
||||
SDL.KeycodeF -> do
|
||||
when (msgKbdKeyMotion kbdev == SDL.Pressed) $ do
|
||||
liftIO $ logIO A.Debug "screen toggling"
|
||||
toggleScreen
|
||||
_ -> return ()
|
||||
hs <- newHaskelloids
|
||||
kbdUUID <- partSubscribe (subKeyboard $ subsystems ud)
|
||||
(\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
|
||||
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
|
||||
SDL.KeycodeEscape -> do
|
||||
liftIO $ logIO A.Debug "seeya"
|
||||
quit
|
||||
SDL.KeycodeSpace -> do
|
||||
liftIO $ logIO A.Debug "Leaving Menu to Game"
|
||||
stateChange
|
||||
_ -> return ()
|
||||
)
|
||||
putAffection ud
|
||||
{ haskelloids = hs
|
||||
, fade = FadeIn 1
|
||||
, state = Menu
|
||||
, stateUUIDs = UUIDClean [] [kbdUUID]
|
||||
-- , shots = (shots ud)
|
||||
-- { partSysParts = ParticleStorage Nothing [] }
|
||||
}
|
||||
|
@ -83,12 +78,9 @@ drawMenu = do
|
|||
fontSize ctx 120
|
||||
fontFace ctx "modulo"
|
||||
textAlign ctx (S.fromList [AlignCenter,AlignTop])
|
||||
-- (Bounds (V4 b0 b1 b2 b3)) <- textBoxBounds ctx x y' 150 "HASKELLOIDS"
|
||||
fillColor ctx (rgba 255 255 255 255)
|
||||
textBox ctx 0 200 800 "HASKELLOIDS"
|
||||
fillColor ctx (rgba 255 128 0 (alpha $ fade ud))
|
||||
fontSize ctx 40
|
||||
textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit"
|
||||
restore ctx
|
||||
-- t <- getElapsedTime
|
||||
-- liftIO $ drawSpinner (nano ud) 100 100 100 t
|
||||
|
|
|
@ -14,20 +14,30 @@ import System.Random (randomRIO)
|
|||
|
||||
import Types
|
||||
import Commons
|
||||
-- import InGame
|
||||
import InGame
|
||||
import Menu
|
||||
|
||||
instance StateMachine State UserData where
|
||||
smLoad Menu = loadMenu
|
||||
smLoad Menu = loadMenu (smClean Menu >> smLoad InGame)
|
||||
|
||||
-- smLoad InGame = loadGame
|
||||
smLoad InGame = loadGame (smClean InGame >> smLoad Menu)
|
||||
|
||||
smUpdate Menu = updateMenu
|
||||
|
||||
-- smUpdate InGame sec = updateGame sec
|
||||
smUpdate InGame = updateGame
|
||||
|
||||
smDraw Menu = drawMenu
|
||||
|
||||
-- smDraw InGame = drawGame
|
||||
smDraw InGame = drawGame
|
||||
|
||||
smEvent _ _ = return ()
|
||||
|
||||
smClean _ = do
|
||||
ud <- getAffection
|
||||
let (UUIDClean uuwin uukbd) = stateUUIDs ud
|
||||
(Subsystems win kbd) = subsystems ud
|
||||
mapM_ (partUnSubscribe win) uuwin
|
||||
mapM_ (partUnSubscribe kbd) uukbd
|
||||
putAffection ud
|
||||
{ stateUUIDs = UUIDClean [] []
|
||||
}
|
||||
|
|
35
src/Types.hs
35
src/Types.hs
|
@ -23,6 +23,7 @@ data UserData = UserData
|
|||
, font :: Font
|
||||
, subsystems :: Subsystems
|
||||
, haskImage :: Image
|
||||
, stateUUIDs :: UUIDClean
|
||||
}
|
||||
|
||||
data Ship = Ship
|
||||
|
@ -60,6 +61,11 @@ data Subsystems = Subsystems
|
|||
, subKeyboard :: Keyboard
|
||||
}
|
||||
|
||||
data UUIDClean = UUIDClean
|
||||
{ uuWindow :: [MsgId WindowMessage]
|
||||
, uuKeyboard :: [MsgId KeyboardMessage]
|
||||
}
|
||||
|
||||
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
|
||||
|
||||
instance Participant Window WindowMessage UserData where
|
||||
|
@ -67,10 +73,16 @@ instance Participant Window WindowMessage UserData where
|
|||
subTups <- liftIO $ readTVarIO t
|
||||
return $ map snd subTups
|
||||
|
||||
partSubscribe (Window t) = generalSubscribe t
|
||||
partSubscribe (Window t) funct = do
|
||||
uuid <- genUUID
|
||||
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
|
||||
return $ MsgId uuid MsgWindowEmptyEvent
|
||||
|
||||
partUnSubscribe (Window t) uuid =
|
||||
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
|
||||
partUnSubscribe (Window t) (MsgId uuid _) =
|
||||
liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
|
||||
where
|
||||
filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool
|
||||
filterMsg (u, _) p = u /= p
|
||||
|
||||
instance SDLSubsystem Window UserData where
|
||||
consumeSDLEvents = consumeSDLWindowEvents
|
||||
|
@ -82,15 +94,16 @@ instance Participant Keyboard KeyboardMessage UserData where
|
|||
subTups <- liftIO $ readTVarIO t
|
||||
return $ map snd subTups
|
||||
|
||||
partSubscribe (Keyboard t) = generalSubscribe t
|
||||
partSubscribe (Keyboard t) funct = do
|
||||
uuid <- genUUID
|
||||
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
|
||||
return $ MsgId uuid MsgKeyboardEmptyEvent
|
||||
|
||||
partUnSubscribe (Keyboard t) uuid =
|
||||
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
|
||||
partUnSubscribe (Keyboard t) (MsgId uuid _) =
|
||||
liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
|
||||
where
|
||||
filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool
|
||||
filterMsg (u, _) p = u /= p
|
||||
|
||||
instance SDLSubsystem Keyboard UserData where
|
||||
consumeSDLEvents = consumeSDLKeyboardEvents
|
||||
|
||||
generalSubscribe t funct = do
|
||||
uuid <- genUUID
|
||||
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
|
||||
return uuid
|
||||
|
|
Loading…
Reference in a new issue