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

View file

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

View file

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

View file

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

View file

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

View file

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