making things work

This commit is contained in:
nek0 2017-12-20 02:00:28 +01:00
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

View file

@ -58,6 +58,7 @@ executable haskelloids
, Commons
, StateMachine
, Menu
, InGame
, Init
default-extensions: OverloadedStrings

View file

@ -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 =

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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 [] []
}

View file

@ -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