progress
This commit is contained in:
nek0
parent
a503b2cb75
commit
669d28de0d
5 changed files with 50 additions and 48 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
40
src/Main.hs
40
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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
module Types where
|
||||
|
||||
import Affection
|
||||
import Affection hiding (StateMachine)
|
||||
import qualified SDL
|
||||
import GEGL
|
||||
import BABL
|
||||
|
|
|
|||
Loading…
Reference in a new issue