From 669d28de0d326061c3a7c6727397a8591d677888 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 4 Nov 2017 16:26:29 +0100 Subject: [PATCH] progress --- haskelloids.cabal | 2 +- src/Commons.hs | 31 ++++++++++++++++++++----------- src/InGame.hs | 23 ++++++++++------------- src/Main.hs | 40 ++++++++++++++++++---------------------- src/Types.hs | 2 +- 5 files changed, 50 insertions(+), 48 deletions(-) diff --git a/haskelloids.cabal b/haskelloids.cabal index 9f4a275..504b840 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -61,7 +61,7 @@ executable haskelloids -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base >=4.9 && <4.10 + build-depends: base >=4.9 && <4.11 , affection , gegl , babl diff --git a/src/Commons.hs b/src/Commons.hs index 95486f0..e724291 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -24,8 +24,8 @@ clean ud = do mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud) gegl_node_drop $ nodeGraph ud M.! KeyRoot -load :: SDL.Surface -> IO UserData -load _ = do +load :: IO UserData +load = do traceM "loading" root <- gegl_node_new traceM "root node" @@ -86,7 +86,6 @@ load _ = do , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1 ] vignette <- gegl_node_new_child root $ Operation "gegl:vignette" [] - -- pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize" pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize" [ Property "size-x" $ PropertyInt 3 , Property "size-y" $ PropertyInt 3 @@ -119,13 +118,16 @@ load _ = do , (KeyFGOver, fgover) , (KeyFGNop, fgnop) ] + traceM "built map" hs <- catMaybes <$> foldM (\acc _ -> do px <- liftIO $ randomRIO (0, 800) py <- liftIO $ randomRIO (0, 600) insertHaskelloid acc Nothing (px, py) ) [] ([0..9] :: [Int]) + traceM "built haskelloids" liftIO $ gegl_node_link_many $ map hFlange hs liftIO $ gegl_node_link (last $ map hFlange hs) hnop + traceM "linking haskelloids and returning UserData" return $ UserData { nodeGraph = myMap , ship = Ship @@ -144,33 +146,40 @@ load _ = do insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid] insertHaskelloid hasks split (px, py) = do - -- liftIO $ traceIO "inserting haskelloid" + liftIO $ traceIO "inserting haskelloid" vx <- liftIO $ randomRIO (-10, 10) vy <- liftIO $ randomRIO (-10, 10) rdiv <- case split of Nothing -> liftIO $ randomRIO (1, 2) Just x -> return $ x + 1 - rot <- liftIO $ randomRIO (0, 360) - pitch <- liftIO $ randomRIO (-45, 45) + rot <- liftIO $ randomRIO ((-180) , 180) + pitch <- liftIO $ randomRIO ((-(pi/2)), pi/2) tempRoot <- liftIO $ gegl_node_new tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation - tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load" - [ Property "path" $ PropertyString "assets/haskelloid.svg" - , Property "width" $ PropertyInt (100 `div` rdiv) - , Property "height" $ PropertyInt (100 `div` rdiv) + tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:png-load" + [ Property "path" $ PropertyString "assets/haskelloid.png" ] + liftIO $ traceIO "svg loaded" + tempScale <- gegl_node_new_child tempRoot $ Operation "gegl:scale-size" + [ Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic + , Property "x" $ PropertyDouble (100 / (fromIntegral rdiv) :: Double) + , Property "y" $ PropertyDouble (100 / (fromIntegral rdiv) :: Double) + ] + liftIO $ traceIO "scaled" tempTrans <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:translate" [ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2) , Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2) , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic ] + liftIO $ traceIO "translated" tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate" [ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv) , Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv) , Property "degrees" $ PropertyDouble rot , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic ] - liftIO $ gegl_node_link_many [tempSvg, tempRot, tempTrans] + liftIO $ traceIO $ "rotated: " ++ show rot + liftIO $ gegl_node_link_many [tempSvg, tempScale, tempRot, tempTrans] _ <- liftIO $ gegl_node_connect_to tempTrans "output" tempOver "aux" return $ Just Haskelloid { hPos = diff --git a/src/InGame.hs b/src/InGame.hs index e0e86a0..99630fa 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -13,11 +13,12 @@ import Debug.Trace import Types import Commons -handleGameEvent :: Double -> SDL.Event -> Affection UserData () -handleGameEvent sec e = do +handleGameEvent :: SDL.EventPayload -> Affection UserData () +handleGameEvent e = do ad <- get wd <- getAffection - case SDL.eventPayload e of + sec <- getDelta + case e of SDL.KeyboardEvent dat -> case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of SDL.KeycodeLeft -> do @@ -25,7 +26,7 @@ handleGameEvent sec e = do when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $ putAffection ud { ship = (ship ud) - { sRot = (sRot $ ship ud) + 270 * sec + { sRot = (sRot $ ship ud) + 15 * sec } } SDL.KeycodeRight -> do @@ -33,7 +34,7 @@ handleGameEvent sec e = do when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ putAffection ud { ship = (ship ud) - { sRot = (sRot $ ship ud) - 270 * sec + { sRot = (sRot $ ship ud) - 15 * sec } } SDL.KeycodeUp -> @@ -72,14 +73,12 @@ handleGameEvent sec e = do { particleTimeToLive = 5 , particleCreation = elapsedTime ad , particlePosition = (posX, posY) - , particleRotation = Rad 0 + , particleRotation = 0 , particleVelocity = - -- ( (floor $ -200 * (sin $ toR $ (sRot $ ship ud) + (fst $ sVel $ ship ud))) - -- , (floor $ -200 * (cos $ toR $ (sRot $ ship ud) + (snd $ sVel $ ship ud))) ( (floor $ -200 * (sin $ toR $ sRot $ ship ud)) , (floor $ -200 * (cos $ toR $ sRot $ ship ud)) ) - , particlePitchRate = Rad 0 + , particlePitchRate = 0 , particleRootNode = tempRoot , particleNodeGraph = M.fromList [ ("root", tempRoot) @@ -97,12 +96,10 @@ handleGameEvent sec e = do when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do liftIO $ traceIO "reloading" liftIO $ clean wd - nd <- liftIO $ load $ drawSurface ad + nd <- liftIO $ load putAffection nd _ -> return () SDL.WindowClosedEvent _ -> do traceM "seeya!" - put ad - { quitEvent = True - } + quit _ -> return () diff --git a/src/Main.hs b/src/Main.hs index 1a72bce..5c6f1b8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -24,11 +24,14 @@ main = withAffection $ AffectionConfig { initComponents = All , windowTitle = "Haskelloids" , windowConfig = defaultWindow + , initScreenMode = SDL.Windowed , preLoop = return () , drawLoop = draw , updateLoop = update , loadState = load , cleanUp = clean + , canvasSize = Nothing + , eventLoop = handleGameEvent } update :: Double -> Affection UserData () @@ -45,13 +48,13 @@ update sec = do putAffection pd { pixelSize = pixelSize wd -1 } - evs <- SDL.pollEvents - mapM_ (\e -> - case state wd of - InGame -> - handleGameEvent sec e - _ -> error "not yet implemented" - ) evs + -- evs <- SDL.pollEvents + -- mapM_ (\e -> + -- case state wd of + -- InGame -> + -- handleGameEvent sec e + -- _ -> error "not yet implemented" + -- ) evs ud2 <- getAffection nhs <- mapM (updateHaskelloid sec) (haskelloids ud2) -- liftIO $ traceIO $ show $ length nhs @@ -69,7 +72,7 @@ update sec = do liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyRotate) $ Operation "gegl:rotate" [ Property "degrees" $ PropertyDouble $ sRot $ ship ud3 ] - ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw + ups <- updateParticleSystem (shots ud3) sec shotsUpd ud4 <- getAffection putAffection ud4 { ship = (ship ud3) @@ -93,21 +96,13 @@ wrapAround (nx, ny) width = (nnx, nny) draw :: Affection UserData () draw = do ud <- getAffection + drawParticleSystem (shots ud) (\_ _ _ -> return()) liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink - -- mintr <- liftIO $ gegl_rectangle_intersect - -- (GeglRectangle 0 0 800 600) - -- (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50) - -- maybe (return ()) (\intr -> - -- present - -- (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50) - -- (buffer ud) - -- False - -- ) mintr - -- XXX: above part crashes regularly for no apparent reason present (GeglRectangle 0 0 800 600) (buffer ud) True + render Nothing Nothing shotsUpd :: Double -> Particle -> Affection UserData Particle shotsUpd sec part@Particle{..} = do @@ -183,14 +178,15 @@ haskelloidShotDown h = do { haskelloids = newHaskelloids } -shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData () -shotsDraw _ _ _ = return () - updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid updateHaskelloid sec h@Haskelloid{..} = do let newX = (fst $ hPos) + sec * (fst $ hVel) newY = (snd $ hPos) + sec * (snd $ hVel) - newRot = hRot + hPitch * sec + rawRot = hRot + hPitch * sec + newRot + | rawRot > 360 = rawRot - 360 + | rawRot < -360 = rawRot + 360 + | otherwise = rawRot (nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv) liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate" [ Property "x" $ PropertyDouble $ nnx diff --git a/src/Types.hs b/src/Types.hs index 88cd3a2..5ca5b7b 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,6 +1,6 @@ module Types where -import Affection +import Affection hiding (StateMachine) import qualified SDL import GEGL import BABL