more beautiful winning and losing
This commit is contained in:
nek0
parent
ac2a71cdc4
commit
8257b69c97
1 changed files with 131 additions and 111 deletions
242
src/Main.hs
242
src/Main.hs
|
|
@ -62,6 +62,16 @@ load _ = do
|
||||||
sink <- gegl_node_new_child root $ Operation "gegl:copy-buffer"
|
sink <- gegl_node_new_child root $ Operation "gegl:copy-buffer"
|
||||||
[ Property "buffer" $ PropertyBuffer buffer
|
[ Property "buffer" $ PropertyBuffer buffer
|
||||||
]
|
]
|
||||||
|
won <- gegl_node_new_child root $ textOperation
|
||||||
|
[ Property "string" $ PropertyString "YOU WON!"
|
||||||
|
, Property "size" $ PropertyDouble 100
|
||||||
|
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
|
||||||
|
]
|
||||||
|
lost <- gegl_node_new_child root $ textOperation
|
||||||
|
[ Property "string" $ PropertyString "YOU LOST!"
|
||||||
|
, Property "size" $ PropertyDouble 100
|
||||||
|
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
|
||||||
|
]
|
||||||
gegl_node_link_many [ship, rotate, translate]
|
gegl_node_link_many [ship, rotate, translate]
|
||||||
gegl_node_link_many [pover, hover, sover, crop, sink]
|
gegl_node_link_many [pover, hover, sover, crop, sink]
|
||||||
_ <- gegl_node_connect_to translate "output" sover "aux"
|
_ <- gegl_node_connect_to translate "output" sover "aux"
|
||||||
|
|
@ -78,6 +88,8 @@ load _ = do
|
||||||
, (KeyCrop, crop)
|
, (KeyCrop, crop)
|
||||||
, (KeyShipOver, sover)
|
, (KeyShipOver, sover)
|
||||||
, (KeySink, sink)
|
, (KeySink, sink)
|
||||||
|
, (KeyWon, won)
|
||||||
|
, (KeyLost, lost)
|
||||||
]
|
]
|
||||||
hs <- catMaybes <$> foldM (\acc _ -> do
|
hs <- catMaybes <$> foldM (\acc _ -> do
|
||||||
px <- liftIO $ randomRIO (0, 800)
|
px <- liftIO $ randomRIO (0, 800)
|
||||||
|
|
@ -97,6 +109,7 @@ load _ = do
|
||||||
, buffer = buffer
|
, buffer = buffer
|
||||||
, shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer
|
, shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer
|
||||||
, haskelloids = hs
|
, haskelloids = hs
|
||||||
|
, wonlost = False
|
||||||
}
|
}
|
||||||
|
|
||||||
data UserData = UserData
|
data UserData = UserData
|
||||||
|
|
@ -106,6 +119,7 @@ data UserData = UserData
|
||||||
, haskelloids :: [Haskelloid]
|
, haskelloids :: [Haskelloid]
|
||||||
, shots :: ParticleSystem
|
, shots :: ParticleSystem
|
||||||
-- , debris :: ParticleSystem
|
-- , debris :: ParticleSystem
|
||||||
|
, wonlost :: Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
data Ship = Ship
|
data Ship = Ship
|
||||||
|
|
@ -135,118 +149,124 @@ data NodeKey
|
||||||
| KeyCrop
|
| KeyCrop
|
||||||
| KeyShipOver
|
| KeyShipOver
|
||||||
| KeySink
|
| KeySink
|
||||||
|
| KeyWon
|
||||||
|
| KeyLost
|
||||||
deriving (Ord, Eq)
|
deriving (Ord, Eq)
|
||||||
|
|
||||||
update :: Double -> Affection UserData ()
|
update :: Double -> Affection UserData ()
|
||||||
update sec = do
|
update sec = do
|
||||||
-- traceM $ (show $ 1 / sec) ++ " FPS"
|
-- traceM $ (show $ 1 / sec) ++ " FPS"
|
||||||
ad <- get
|
ad <- get
|
||||||
evs <- SDL.pollEvents
|
wd <- getAffection
|
||||||
mapM_ (\e ->
|
if (not $ wonlost wd)
|
||||||
case SDL.eventPayload e of
|
then do
|
||||||
SDL.KeyboardEvent dat ->
|
evs <- SDL.pollEvents
|
||||||
case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
|
mapM_ (\e ->
|
||||||
SDL.KeycodeLeft -> do
|
case SDL.eventPayload e of
|
||||||
ud <- getAffection
|
SDL.KeyboardEvent dat ->
|
||||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
|
case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
|
||||||
putAffection ud
|
SDL.KeycodeLeft -> do
|
||||||
{ ship = (ship ud)
|
|
||||||
{ sRot = (sRot $ ship ud) + 180 * sec
|
|
||||||
}
|
|
||||||
}
|
|
||||||
SDL.KeycodeRight -> do
|
|
||||||
ud <- getAffection
|
|
||||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
|
|
||||||
putAffection ud
|
|
||||||
{ ship = (ship ud)
|
|
||||||
{ sRot = (sRot $ ship ud) - 180 * sec
|
|
||||||
}
|
|
||||||
}
|
|
||||||
SDL.KeycodeUp ->
|
|
||||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
|
|
||||||
ud <- getAffection
|
ud <- getAffection
|
||||||
let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud)
|
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
|
||||||
vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud)
|
putAffection ud
|
||||||
putAffection ud
|
{ ship = (ship ud)
|
||||||
{ ship = (ship ud)
|
{ sRot = (sRot $ ship ud) + 180 * sec
|
||||||
{ sVel = (vx, vy)
|
}
|
||||||
}
|
}
|
||||||
}
|
SDL.KeycodeRight -> do
|
||||||
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
|
|
||||||
SDL.KeycodeSpace ->
|
|
||||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
|
|
||||||
ud <- getAffection
|
ud <- getAffection
|
||||||
-- ad <- get
|
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
|
||||||
let posX = (fst $ sPos $ ship ud) + 23 - 30 * sin (toR $ sRot $ ship ud)
|
putAffection ud
|
||||||
posY = (snd $ sPos $ ship ud) + 23 - 30 * cos (toR $ sRot $ ship ud)
|
{ ship = (ship ud)
|
||||||
tempRoot <- liftIO $ gegl_node_new
|
{ sRot = (sRot $ ship ud) - 180 * sec
|
||||||
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 = Rad 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
|
|
||||||
, particleRootNode = tempRoot
|
|
||||||
, particleNodeGraph = M.fromList
|
|
||||||
[ ("root", tempRoot)
|
|
||||||
, ("over", tempOver)
|
|
||||||
, ("rect", tempRect)
|
|
||||||
]
|
|
||||||
, particleStackCont = tempOver
|
|
||||||
, particleDrawFlange = tempOver
|
|
||||||
}
|
}
|
||||||
putAffection $ ud
|
SDL.KeycodeUp ->
|
||||||
{ shots = ips
|
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
|
||||||
}
|
ud <- getAffection
|
||||||
_ -> return ()
|
let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud)
|
||||||
SDL.WindowClosedEvent _ -> do
|
vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud)
|
||||||
traceM "seeya!"
|
putAffection ud
|
||||||
put ad
|
{ ship = (ship ud)
|
||||||
{ quitEvent = True
|
{ sVel = (vx, vy)
|
||||||
}
|
}
|
||||||
_ -> return ()
|
}
|
||||||
) evs
|
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
|
||||||
ud2 <- getAffection
|
SDL.KeycodeSpace ->
|
||||||
nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
|
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
|
||||||
-- liftIO $ traceIO $ show $ length nhs
|
ud <- getAffection
|
||||||
putAffection ud2
|
-- ad <- get
|
||||||
{ haskelloids = nhs
|
let posX = (fst $ sPos $ ship ud) + 23 - 30 * sin (toR $ sRot $ ship ud)
|
||||||
}
|
posY = (snd $ sPos $ ship ud) + 23 - 30 * cos (toR $ sRot $ ship ud)
|
||||||
ud3 <- getAffection
|
tempRoot <- liftIO $ gegl_node_new
|
||||||
let nx = fst (sPos $ ship ud3) + (fst (sVel $ ship ud3)) * sec
|
tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle"
|
||||||
ny = snd (sPos $ ship ud3) + (snd (sVel $ ship ud3)) * sec
|
[ Property "x" $ PropertyDouble $ posX
|
||||||
(nnx, nny) = wrapAround (nx, ny) 50
|
, Property "y" $ PropertyDouble $ posY
|
||||||
liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyTranslate) $ Operation "gegl:translate"
|
, Property "width" $ PropertyDouble 4
|
||||||
[ Property "x" $ PropertyDouble $ nnx
|
, Property "height" $ PropertyDouble 4
|
||||||
, Property "y" $ PropertyDouble $ nny
|
, Property "color" $ PropertyColor $ (GEGL.RGBA 1 1 1 1)
|
||||||
]
|
]
|
||||||
liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyRotate) $ Operation "gegl:rotate"
|
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
|
||||||
[ Property "degrees" $ PropertyDouble $ sRot $ ship ud3
|
_ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux"
|
||||||
]
|
ips <- insertParticle (shots ud) $
|
||||||
ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
|
Particle
|
||||||
ud4 <- getAffection
|
{ particleTimeToLive = 5
|
||||||
putAffection ud4
|
, particleCreation = elapsedTime ad
|
||||||
{ ship = (ship ud3)
|
, particlePosition = (posX, posY)
|
||||||
{ sPos = (nnx, nny)
|
, particleRotation = Rad 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
|
||||||
|
, particleRootNode = tempRoot
|
||||||
|
, particleNodeGraph = M.fromList
|
||||||
|
[ ("root", tempRoot)
|
||||||
|
, ("over", tempOver)
|
||||||
|
, ("rect", tempRect)
|
||||||
|
]
|
||||||
|
, particleStackCont = tempOver
|
||||||
|
, particleDrawFlange = tempOver
|
||||||
|
}
|
||||||
|
putAffection $ ud
|
||||||
|
{ shots = ips
|
||||||
|
}
|
||||||
|
_ -> return ()
|
||||||
|
SDL.WindowClosedEvent _ -> do
|
||||||
|
traceM "seeya!"
|
||||||
|
put ad
|
||||||
|
{ quitEvent = True
|
||||||
|
}
|
||||||
|
_ -> return ()
|
||||||
|
) evs
|
||||||
|
ud2 <- getAffection
|
||||||
|
nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
|
||||||
|
-- liftIO $ traceIO $ show $ length nhs
|
||||||
|
putAffection ud2
|
||||||
|
{ haskelloids = nhs
|
||||||
}
|
}
|
||||||
, shots = ups
|
ud3 <- getAffection
|
||||||
}
|
let nx = fst (sPos $ ship ud3) + (fst (sVel $ ship ud3)) * sec
|
||||||
|
ny = snd (sPos $ ship ud3) + (snd (sVel $ ship ud3)) * sec
|
||||||
|
(nnx, nny) = wrapAround (nx, ny) 50
|
||||||
|
liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyTranslate) $ Operation "gegl:translate"
|
||||||
|
[ Property "x" $ PropertyDouble $ nnx
|
||||||
|
, Property "y" $ PropertyDouble $ nny
|
||||||
|
]
|
||||||
|
liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyRotate) $ Operation "gegl:rotate"
|
||||||
|
[ Property "degrees" $ PropertyDouble $ sRot $ ship ud3
|
||||||
|
]
|
||||||
|
ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
|
||||||
|
ud4 <- getAffection
|
||||||
|
putAffection ud4
|
||||||
|
{ ship = (ship ud3)
|
||||||
|
{ sPos = (nnx, nny)
|
||||||
|
}
|
||||||
|
, shots = ups
|
||||||
|
}
|
||||||
|
else return ()
|
||||||
|
|
||||||
wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
|
wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
|
||||||
wrapAround (nx, ny) width = (nnx, nny)
|
wrapAround (nx, ny) width = (nnx, nny)
|
||||||
|
|
@ -278,7 +298,7 @@ draw = do
|
||||||
present
|
present
|
||||||
(GeglRectangle 0 0 800 600)
|
(GeglRectangle 0 0 800 600)
|
||||||
(buffer ud)
|
(buffer ud)
|
||||||
False
|
(not $ wonlost ud)
|
||||||
|
|
||||||
clean :: UserData -> IO ()
|
clean :: UserData -> IO ()
|
||||||
clean _ = return ()
|
clean _ = return ()
|
||||||
|
|
@ -319,10 +339,10 @@ shotsUpd sec part@Particle{..} = do
|
||||||
50
|
50
|
||||||
)
|
)
|
||||||
maybe (return ()) (\_ -> do
|
maybe (return ()) (\_ -> do
|
||||||
ad <- get
|
|
||||||
liftIO $ traceIO "YOU LOST!"
|
liftIO $ traceIO "YOU LOST!"
|
||||||
put ad
|
liftIO $ gegl_node_link (nodeGraph ud M.! KeyLost) (nodeGraph ud M.! KeySink)
|
||||||
{ quitEvent = True
|
putAffection ud
|
||||||
|
{ wonlost = True
|
||||||
}
|
}
|
||||||
) lost
|
) lost
|
||||||
return part
|
return part
|
||||||
|
|
@ -352,10 +372,10 @@ haskelloidShotDown h = do
|
||||||
(last $ map hFlange newHaskelloids)
|
(last $ map hFlange newHaskelloids)
|
||||||
(nodeGraph ud M.! KeyHNop)
|
(nodeGraph ud M.! KeyHNop)
|
||||||
else do
|
else do
|
||||||
ad <- get
|
|
||||||
liftIO $ traceIO "YOU WON!"
|
liftIO $ traceIO "YOU WON!"
|
||||||
put ad
|
liftIO $ gegl_node_link (nodeGraph ud M.! KeyWon) (nodeGraph ud M.! KeySink)
|
||||||
{ quitEvent = True
|
putAffection ud
|
||||||
|
{ wonlost = True
|
||||||
}
|
}
|
||||||
putAffection ud
|
putAffection ud
|
||||||
{ haskelloids = newHaskelloids
|
{ haskelloids = newHaskelloids
|
||||||
|
|
@ -387,10 +407,10 @@ updateHaskelloid sec h@Haskelloid{..} = do
|
||||||
50
|
50
|
||||||
)
|
)
|
||||||
maybe (return ()) (\_ -> do
|
maybe (return ()) (\_ -> do
|
||||||
ad <- get
|
|
||||||
liftIO $ traceIO "YOU LOST!"
|
liftIO $ traceIO "YOU LOST!"
|
||||||
put ad
|
liftIO $ gegl_node_link (nodeGraph ud M.! KeyLost) (nodeGraph ud M.! KeySink)
|
||||||
{ quitEvent = True
|
putAffection ud
|
||||||
|
{ wonlost = True
|
||||||
}
|
}
|
||||||
) lost
|
) lost
|
||||||
return h
|
return h
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue