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 , Commons
, StateMachine , StateMachine
, Menu , Menu
, InGame
, Init , Init
default-extensions: OverloadedStrings default-extensions: OverloadedStrings

View file

@ -38,23 +38,25 @@ wrapAround (V2 nx ny) width = (V2 nnx nny)
| otherwise = ny | otherwise = ny
half = width / 2 half = width / 2
newHaskelloids :: Image -> Affection UserData [Haskelloid] newHaskelloids :: Affection UserData [Haskelloid]
newHaskelloids img = liftIO $ mapM (\_ -> do newHaskelloids = do
posx <- randomRIO (0, 800) img <- haskImage <$> getAffection
posy <- randomRIO (0, 600) liftIO $ mapM (\_ -> do
velx <- randomRIO (-10, 10) posx <- randomRIO (0, 800)
vely <- randomRIO (-10, 10) posy <- randomRIO (0, 600)
rot <- randomRIO (-180, 180) velx <- randomRIO (-10, 10)
pitch <- randomRIO (-pi, pi) vely <- randomRIO (-10, 10)
div <- randomRIO (1, 2) rot <- randomRIO (-180, 180)
return $ Haskelloid pitch <- randomRIO (-pi, pi)
(V2 posx posy) div <- randomRIO (1, 2)
(V2 velx vely) return $ Haskelloid
rot (V2 posx posy)
pitch (V2 velx vely)
div rot
img pitch
) [1..10] div
img
) [1..10]
updateHaskelloid :: Double -> Haskelloid -> Haskelloid updateHaskelloid :: Double -> Haskelloid -> Haskelloid
updateHaskelloid dsec has = updateHaskelloid dsec has =

View file

@ -1,235 +1,81 @@
{-# LANGUAGE RecordWildCards #-}
module InGame where module InGame where
import Affection import Affection as A
import qualified SDL import qualified SDL
import GEGL
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe (catMaybes, isJust, fromJust, isNothing) 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 System.Random (randomRIO)
import Debug.Trace import Linear
import Types import Types
import Commons import Commons
import Menu import Menu
loadGame :: Affection UserData () loadGame :: Affection UserData () -> Affection UserData ()
loadGame = do loadGame stateChange = do
liftIO $ traceIO "loading game" liftIO $ logIO A.Debug "loading game"
ud <- getAffection ud <- getAffection
_ <- liftIO $ gegl_node_connect_to nhs <- newHaskelloids
(nodeGraph ud M.! KeyShipTranslate) kid <- partSubscribe (subKeyboard $ subsystems ud)
"output" (\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
(nodeGraph ud M.! KeyShipOver) case SDL.keysymKeycode (msgKbdKeysym kbdev) of
"aux" SDL.KeycodeSpace -> do
liftIO $ traceIO "nodes connected" liftIO $ logIO Debug "TODO: PEW!"
hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do SDL.KeycodeR -> do
coords <- liftIO excludeShip liftIO $ logIO Debug "Reloading"
insertHaskelloid acc Nothing coords putAffection ud
) [] ([0..9] :: [Int]) { stateUUIDs = UUIDClean [] []
liftIO $ traceIO "inserted haskelloids" }
liftIO $ gegl_node_link_many $ map hFlange hs loadGame stateChange
liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop) SDL.KeycodeEscape -> do
liftIO $ gegl_node_disconnect liftIO $ logIO Debug "Leave to Menu"
(nodeGraph ud M.! KeyFGOver) stateChange
"aux" _ -> return ()
liftIO $ traceIO "nodes linked" )
putAffection ud putAffection ud
{ haskelloids = hs { stateUUIDs = UUIDClean [] [kid]
, wonlost = Nothing , haskelloids = nhs
, shots = ParticleSystem , ship = (ship ud)
(ParticleStorage Nothing []) { sPos = V2 400 300
(nodeGraph ud M.! KeyPNop) , sVel = V2 0 0
(buffer ud)
, ship = Ship
{ sPos = (375, 275)
, sVel = (0, 0)
, sRot = 0 , sRot = 0
, sFlange = nodeGraph ud M.! KeyShipRotate
} }
, pixelSize = 3
, state = InGame , 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 :: Double -> Affection UserData ()
updateGame sec = do updateGame sec = do
ad <- get
ud <- getAffection ud <- getAffection
when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize ud > 3) $ do let nhs = map (updateHaskelloid sec) (haskelloids ud)
pd <- getAffection putAffection ud
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
{ haskelloids = nhs { haskelloids = nhs
, ship = updateShip sec (ship ud)
} }
ud3 <- getAffection
ups <- updateParticleSystem (shots ud3) sec shotsUpd updateShip :: Double -> Ship -> Ship
ud4 <- getAffection updateShip ddt s@Ship{..} = s
when (isJust $ wonlost ud3) (winlose $ fromJust $ wonlost ud3) { sPos = wrapAround (sPos + fmap (dt *) sVel) 40
putAffection ud4 }
{ shots = ups where
} dt = realToFrac ddt
drawGame :: Affection UserData () drawGame :: Affection UserData ()
drawGame = do drawGame = do
ud <- getAffection ud <- getAffection
liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink mapM_ drawHaskelloid (haskelloids ud)
present drawShip (ship ud)
(GeglRectangle 0 0 800 600)
(buffer ud)
True
handleGameEvent :: SDL.EventPayload -> Affection UserData () drawShip :: Ship -> Affection UserData ()
handleGameEvent e = do drawShip Ship{..} = do
ad <- get ctx <- nano <$> getAffection
wd <- getAffection liftIO $ drawImage ctx (sImg) (sPos - fmap (/2) dim) dim sRot 255
sec <- getDelta where
case e of dim = V2 40 40
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 ()

View file

@ -49,6 +49,7 @@ pre = do
liftIO $ logIO A.Debug "Setting global resize event listener" liftIO $ logIO A.Debug "Setting global resize event listener"
_ <- partSubscribe (subWindow subs) $ \msg -> case msg of _ <- partSubscribe (subWindow subs) $ \msg -> case msg of
MsgWindowResize _ _ (V2 w h) -> do MsgWindowResize _ _ (V2 w h) -> do
liftIO $ logIO A.Debug "Window has been resized"
let nw = floor $ fromIntegral h * (800/600) let nw = floor $ fromIntegral h * (800/600)
dw = floor $ (fromIntegral w - fromIntegral nw) / 2 dw = floor $ (fromIntegral w - fromIntegral nw) / 2
GL.viewport $= (GL.Position dw 0, GL.Size nw h) GL.viewport $= (GL.Position dw 0, GL.Size nw h)

View file

@ -24,32 +24,27 @@ import Foreign.C.Types
import Types import Types
import Commons import Commons
handleMenuEvent :: (Affection UserData ()) -> [SDL.EventPayload] -> Affection UserData () loadMenu :: (Affection UserData ()) -> Affection UserData ()
handleMenuEvent _ es = do loadMenu stateChange = do
(Subsystems w k) <- subsystems <$> getAffection
_ <- consumeSDLEvents w =<< consumeSDLEvents k es
return ()
loadMenu :: Affection UserData ()
loadMenu = do
liftIO $ logIO A.Debug "Loading Menu" liftIO $ logIO A.Debug "Loading Menu"
ud <- getAffection ud <- getAffection
hs <- newHaskelloids (haskImage ud) hs <- newHaskelloids
_ <- partSubscribe (subKeyboard $ subsystems ud) kbdUUID <- partSubscribe (subKeyboard $ subsystems ud)
(\kbdev -> case SDL.keysymKeycode (msgKbdKeysym kbdev) of (\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
SDL.KeycodeEscape -> do case SDL.keysymKeycode (msgKbdKeysym kbdev) of
liftIO $ logIO A.Debug "seeya" SDL.KeycodeEscape -> do
quit liftIO $ logIO A.Debug "seeya"
SDL.KeycodeF -> do quit
when (msgKbdKeyMotion kbdev == SDL.Pressed) $ do SDL.KeycodeSpace -> do
liftIO $ logIO A.Debug "screen toggling" liftIO $ logIO A.Debug "Leaving Menu to Game"
toggleScreen stateChange
_ -> return () _ -> return ()
) )
putAffection ud putAffection ud
{ haskelloids = hs { haskelloids = hs
, fade = FadeIn 1 , fade = FadeIn 1
, state = Menu , state = Menu
, stateUUIDs = UUIDClean [] [kbdUUID]
-- , shots = (shots ud) -- , shots = (shots ud)
-- { partSysParts = ParticleStorage Nothing [] } -- { partSysParts = ParticleStorage Nothing [] }
} }
@ -83,12 +78,9 @@ drawMenu = do
fontSize ctx 120 fontSize ctx 120
fontFace ctx "modulo" fontFace ctx "modulo"
textAlign ctx (S.fromList [AlignCenter,AlignTop]) 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) fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "HASKELLOIDS" textBox ctx 0 200 800 "HASKELLOIDS"
fillColor ctx (rgba 255 128 0 (alpha $ fade ud)) fillColor ctx (rgba 255 128 0 (alpha $ fade ud))
fontSize ctx 40 fontSize ctx 40
textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit" textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit"
restore ctx 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 Types
import Commons import Commons
-- import InGame import InGame
import Menu import Menu
instance StateMachine State UserData where 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 Menu = updateMenu
-- smUpdate InGame sec = updateGame sec smUpdate InGame = updateGame
smDraw Menu = drawMenu smDraw Menu = drawMenu
-- smDraw InGame = drawGame smDraw InGame = drawGame
smEvent _ _ = return () 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 , font :: Font
, subsystems :: Subsystems , subsystems :: Subsystems
, haskImage :: Image , haskImage :: Image
, stateUUIDs :: UUIDClean
} }
data Ship = Ship data Ship = Ship
@ -60,6 +61,11 @@ data Subsystems = Subsystems
, subKeyboard :: Keyboard , subKeyboard :: Keyboard
} }
data UUIDClean = UUIDClean
{ uuWindow :: [MsgId WindowMessage]
, uuKeyboard :: [MsgId KeyboardMessage]
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
instance Participant Window WindowMessage UserData where instance Participant Window WindowMessage UserData where
@ -67,10 +73,16 @@ instance Participant Window WindowMessage UserData where
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
return $ map snd subTups 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 = partUnSubscribe (Window t) (MsgId uuid _) =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= 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 instance SDLSubsystem Window UserData where
consumeSDLEvents = consumeSDLWindowEvents consumeSDLEvents = consumeSDLWindowEvents
@ -82,15 +94,16 @@ instance Participant Keyboard KeyboardMessage UserData where
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
return $ map snd subTups 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 = partUnSubscribe (Keyboard t) (MsgId uuid _) =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= 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 instance SDLSubsystem Keyboard UserData where
consumeSDLEvents = consumeSDLKeyboardEvents consumeSDLEvents = consumeSDLKeyboardEvents
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid