nek0/haskelloids
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

progress

Browse source
This commit is contained in:
nek0 2017-11-04 16:26:29 +01:00
parent a503b2cb75
commit 669d28de0d
5 changed files with 50 additions and 48 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
haskelloids.cabal
View file

@ -61,7 +61,7 @@ executable haskelloids
-- other-extensions: -- other-extensions:
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: base >=4.9 && <4.10 build-depends: base >=4.9 && <4.11
, affection , affection
, gegl , gegl
, babl , babl

31
src/Commons.hs
View file

@ -24,8 +24,8 @@ clean ud = do
mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud) mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud)
gegl_node_drop $ nodeGraph ud M.! KeyRoot gegl_node_drop $ nodeGraph ud M.! KeyRoot
load :: SDL.Surface -> IO UserData load :: IO UserData
load _ = do load = do
traceM "loading" traceM "loading"
root <- gegl_node_new root <- gegl_node_new
traceM "root node" traceM "root node"
@ -86,7 +86,6 @@ load _ = do
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1 , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
] ]
vignette <- gegl_node_new_child root $ Operation "gegl:vignette" [] 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" pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize"
[ Property "size-x" $ PropertyInt 3 [ Property "size-x" $ PropertyInt 3
, Property "size-y" $ PropertyInt 3 , Property "size-y" $ PropertyInt 3
@ -119,13 +118,16 @@ load _ = do
, (KeyFGOver, fgover) , (KeyFGOver, fgover)
, (KeyFGNop, fgnop) , (KeyFGNop, fgnop)
] ]
traceM "built map"
hs <- catMaybes <$> foldM (\acc _ -> do hs <- catMaybes <$> foldM (\acc _ -> do
px <- liftIO $ randomRIO (0, 800) px <- liftIO $ randomRIO (0, 800)
py <- liftIO $ randomRIO (0, 600) py <- liftIO $ randomRIO (0, 600)
insertHaskelloid acc Nothing (px, py) insertHaskelloid acc Nothing (px, py)
) [] ([0..9] :: [Int]) ) [] ([0..9] :: [Int])
traceM "built haskelloids"
liftIO $ gegl_node_link_many $ map hFlange hs liftIO $ gegl_node_link_many $ map hFlange hs
liftIO $ gegl_node_link (last $ map hFlange hs) hnop liftIO $ gegl_node_link (last $ map hFlange hs) hnop
traceM "linking haskelloids and returning UserData"
return $ UserData return $ UserData
{ nodeGraph = myMap { nodeGraph = myMap
, ship = Ship , ship = Ship
@ -144,33 +146,40 @@ load _ = do
insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid] insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid]
insertHaskelloid hasks split (px, py) = do insertHaskelloid hasks split (px, py) = do
-- liftIO $ traceIO "inserting haskelloid" liftIO $ traceIO "inserting haskelloid"
vx <- liftIO $ randomRIO (-10, 10) vx <- liftIO $ randomRIO (-10, 10)
vy <- liftIO $ randomRIO (-10, 10) vy <- liftIO $ randomRIO (-10, 10)
rdiv <- case split of rdiv <- case split of
Nothing -> liftIO $ randomRIO (1, 2) Nothing -> liftIO $ randomRIO (1, 2)
Just x -> return $ x + 1 Just x -> return $ x + 1
rot <- liftIO $ randomRIO (0, 360) rot <- liftIO $ randomRIO ((-180) , 180)
pitch <- liftIO $ randomRIO (-45, 45) pitch <- liftIO $ randomRIO ((-(pi/2)), pi/2)
tempRoot <- liftIO $ gegl_node_new tempRoot <- liftIO $ gegl_node_new
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load" tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:png-load"
[ Property "path" $ PropertyString "assets/haskelloid.svg" [ Property "path" $ PropertyString "assets/haskelloid.png"
, Property "width" $ PropertyInt (100 `div` rdiv)
, Property "height" $ PropertyInt (100 `div` rdiv)
] ]
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" tempTrans <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2) [ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2)
, Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2) , Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2)
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
] ]
liftIO $ traceIO "translated"
tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate" tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate"
[ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv) [ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
, Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv) , Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
, Property "degrees" $ PropertyDouble rot , Property "degrees" $ PropertyDouble rot
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic , 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" _ <- liftIO $ gegl_node_connect_to tempTrans "output" tempOver "aux"
return $ Just Haskelloid return $ Just Haskelloid
{ hPos = { hPos =

23
src/InGame.hs
View file

@ -13,11 +13,12 @@ import Debug.Trace
import Types import Types
import Commons import Commons
handleGameEvent :: Double -> SDL.Event -> Affection UserData () handleGameEvent :: SDL.EventPayload -> Affection UserData ()
handleGameEvent sec e = do handleGameEvent e = do
ad <- get ad <- get
wd <- getAffection wd <- getAffection
case SDL.eventPayload e of sec <- getDelta
case e of
SDL.KeyboardEvent dat -> SDL.KeyboardEvent dat ->
case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
SDL.KeycodeLeft -> do SDL.KeycodeLeft -> do
@ -25,7 +26,7 @@ handleGameEvent sec e = do
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $ when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $
putAffection ud putAffection ud
{ ship = (ship ud) { ship = (ship ud)
{ sRot = (sRot $ ship ud) + 270 * sec { sRot = (sRot $ ship ud) + 15 * sec
} }
} }
SDL.KeycodeRight -> do SDL.KeycodeRight -> do
@ -33,7 +34,7 @@ handleGameEvent sec e = do
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
putAffection ud putAffection ud
{ ship = (ship ud) { ship = (ship ud)
{ sRot = (sRot $ ship ud) - 270 * sec { sRot = (sRot $ ship ud) - 15 * sec
} }
} }
SDL.KeycodeUp -> SDL.KeycodeUp ->
@ -72,14 +73,12 @@ handleGameEvent sec e = do
{ particleTimeToLive = 5 { particleTimeToLive = 5
, particleCreation = elapsedTime ad , particleCreation = elapsedTime ad
, particlePosition = (posX, posY) , particlePosition = (posX, posY)
, particleRotation = Rad 0 , particleRotation = 0
, particleVelocity = , 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 * (sin $ toR $ sRot $ ship ud))
, (floor $ -200 * (cos $ toR $ sRot $ ship ud)) , (floor $ -200 * (cos $ toR $ sRot $ ship ud))
) )
, particlePitchRate = Rad 0 , particlePitchRate = 0
, particleRootNode = tempRoot , particleRootNode = tempRoot
, particleNodeGraph = M.fromList , particleNodeGraph = M.fromList
[ ("root", tempRoot) [ ("root", tempRoot)
@ -97,12 +96,10 @@ handleGameEvent sec e = do
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
liftIO $ traceIO "reloading" liftIO $ traceIO "reloading"
liftIO $ clean wd liftIO $ clean wd
nd <- liftIO $ load $ drawSurface ad nd <- liftIO $ load
putAffection nd putAffection nd
_ -> return () _ -> return ()
SDL.WindowClosedEvent _ -> do SDL.WindowClosedEvent _ -> do
traceM "seeya!" traceM "seeya!"
put ad quit
{ quitEvent = True
}
_ -> return () _ -> return ()

40
src/Main.hs
View file

@ -24,11 +24,14 @@ main = withAffection $ AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "Haskelloids" , windowTitle = "Haskelloids"
, windowConfig = defaultWindow , windowConfig = defaultWindow
, initScreenMode = SDL.Windowed
, preLoop = return () , preLoop = return ()
, drawLoop = draw , drawLoop = draw
, updateLoop = update , updateLoop = update
, loadState = load , loadState = load
, cleanUp = clean , cleanUp = clean
, canvasSize = Nothing
, eventLoop = handleGameEvent
} }
update :: Double -> Affection UserData () update :: Double -> Affection UserData ()
@ -45,13 +48,13 @@ update sec = do
putAffection pd putAffection pd
{ pixelSize = pixelSize wd -1 { pixelSize = pixelSize wd -1
} }
evs <- SDL.pollEvents -- evs <- SDL.pollEvents
mapM_ (\e -> -- mapM_ (\e ->
case state wd of -- case state wd of
InGame -> -- InGame ->
handleGameEvent sec e -- handleGameEvent sec e
_ -> error "not yet implemented" -- _ -> error "not yet implemented"
) evs -- ) evs
ud2 <- getAffection ud2 <- getAffection
nhs <- mapM (updateHaskelloid sec) (haskelloids ud2) nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
-- liftIO $ traceIO $ show $ length nhs -- liftIO $ traceIO $ show $ length nhs
@ -69,7 +72,7 @@ update sec = do
liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyRotate) $ Operation "gegl:rotate" liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyRotate) $ Operation "gegl:rotate"
[ Property "degrees" $ PropertyDouble $ sRot $ ship ud3 [ Property "degrees" $ PropertyDouble $ sRot $ ship ud3
] ]
ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw ups <- updateParticleSystem (shots ud3) sec shotsUpd
ud4 <- getAffection ud4 <- getAffection
putAffection ud4 putAffection ud4
{ ship = (ship ud3) { ship = (ship ud3)
@ -93,21 +96,13 @@ wrapAround (nx, ny) width = (nnx, nny)
draw :: Affection UserData () draw :: Affection UserData ()
draw = do draw = do
ud <- getAffection ud <- getAffection
drawParticleSystem (shots ud) (\_ _ _ -> return())
liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink 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 present
(GeglRectangle 0 0 800 600) (GeglRectangle 0 0 800 600)
(buffer ud) (buffer ud)
True True
render Nothing Nothing
shotsUpd :: Double -> Particle -> Affection UserData Particle shotsUpd :: Double -> Particle -> Affection UserData Particle
shotsUpd sec part@Particle{..} = do shotsUpd sec part@Particle{..} = do
@ -183,14 +178,15 @@ haskelloidShotDown h = do
{ haskelloids = newHaskelloids { haskelloids = newHaskelloids
} }
shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
shotsDraw _ _ _ = return ()
updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
updateHaskelloid sec h@Haskelloid{..} = do updateHaskelloid sec h@Haskelloid{..} = do
let newX = (fst $ hPos) + sec * (fst $ hVel) let newX = (fst $ hPos) + sec * (fst $ hVel)
newY = (snd $ hPos) + sec * (snd $ 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) (nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate" liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble $ nnx [ Property "x" $ PropertyDouble $ nnx

2
src/Types.hs
View file

@ -1,6 +1,6 @@
module Types where module Types where
import Affection import Affection hiding (StateMachine)
import qualified SDL import qualified SDL
import GEGL import GEGL
import BABL import BABL