some fixes, some more bugs
This commit is contained in:
nek0
parent
131d8bb2b7
commit
910a0ab4f8
1 changed files with 128 additions and 118 deletions
246
src/Main.hs
246
src/Main.hs
|
|
@ -51,6 +51,7 @@ load _ = do
|
||||||
hover <- gegl_node_new_child root $ defaultOverOperation
|
hover <- gegl_node_new_child root $ defaultOverOperation
|
||||||
pover <- gegl_node_new_child root $ defaultOverOperation
|
pover <- gegl_node_new_child root $ defaultOverOperation
|
||||||
bgover <- gegl_node_new_child root $ defaultOverOperation
|
bgover <- gegl_node_new_child root $ defaultOverOperation
|
||||||
|
fgover <- gegl_node_new_child root $ defaultOverOperation
|
||||||
translate <- gegl_node_new_child root $ Operation "gegl:translate"
|
translate <- gegl_node_new_child root $ Operation "gegl:translate"
|
||||||
[ Property "x" $ PropertyDouble 375
|
[ Property "x" $ PropertyDouble 375
|
||||||
, Property "y" $ PropertyDouble 275
|
, Property "y" $ PropertyDouble 275
|
||||||
|
|
@ -89,7 +90,7 @@ load _ = do
|
||||||
-- [ Property "pattern" $ PropertyInt 8
|
-- [ Property "pattern" $ PropertyInt 8
|
||||||
-- ]
|
-- ]
|
||||||
gegl_node_link_many [ship, rotate, translate]
|
gegl_node_link_many [ship, rotate, translate]
|
||||||
gegl_node_link_many [bgover, pover, hover, sover, crop, pixelize, vignette, sink]
|
gegl_node_link_many [bgover, pover, hover, sover, crop, fgover, pixelize, vignette, sink]
|
||||||
_ <- gegl_node_connect_to translate "output" sover "aux"
|
_ <- gegl_node_connect_to translate "output" sover "aux"
|
||||||
_ <- gegl_node_connect_to pnop "output" pover "aux"
|
_ <- gegl_node_connect_to pnop "output" pover "aux"
|
||||||
_ <- gegl_node_connect_to hnop "output" hover "aux"
|
_ <- gegl_node_connect_to hnop "output" hover "aux"
|
||||||
|
|
@ -108,6 +109,7 @@ load _ = do
|
||||||
, (KeyWon, won)
|
, (KeyWon, won)
|
||||||
, (KeyLost, lost)
|
, (KeyLost, lost)
|
||||||
, (KeyPixelize, pixelize)
|
, (KeyPixelize, pixelize)
|
||||||
|
, (KeyFGOver, fgover)
|
||||||
]
|
]
|
||||||
hs <- catMaybes <$> foldM (\acc _ -> do
|
hs <- catMaybes <$> foldM (\acc _ -> do
|
||||||
px <- liftIO $ randomRIO (0, 800)
|
px <- liftIO $ randomRIO (0, 800)
|
||||||
|
|
@ -170,122 +172,120 @@ data NodeKey
|
||||||
| KeyWon
|
| KeyWon
|
||||||
| KeyLost
|
| KeyLost
|
||||||
| KeyPixelize
|
| KeyPixelize
|
||||||
|
| KeyFGOver
|
||||||
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
|
wd <- getAffection
|
||||||
if (not $ wonlost wd)
|
mapM_ (\e ->
|
||||||
then do
|
case SDL.eventPayload e of
|
||||||
evs <- SDL.pollEvents
|
SDL.KeyboardEvent dat ->
|
||||||
mapM_ (\e ->
|
case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
|
||||||
case SDL.eventPayload e of
|
SDL.KeycodeLeft -> do
|
||||||
SDL.KeyboardEvent dat ->
|
ud <- getAffection
|
||||||
case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
|
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $
|
||||||
SDL.KeycodeLeft -> do
|
putAffection ud
|
||||||
|
{ 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 && not (wonlost wd)) $ do
|
||||||
ud <- getAffection
|
ud <- getAffection
|
||||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
|
let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud)
|
||||||
putAffection ud
|
vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud)
|
||||||
{ ship = (ship ud)
|
putAffection ud
|
||||||
{ sRot = (sRot $ ship ud) + 180 * sec
|
{ ship = (ship ud)
|
||||||
}
|
{ sVel = (vx, vy)
|
||||||
}
|
}
|
||||||
SDL.KeycodeRight -> do
|
}
|
||||||
|
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
|
||||||
|
SDL.KeycodeSpace ->
|
||||||
|
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
|
||||||
ud <- getAffection
|
ud <- getAffection
|
||||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
|
-- ad <- get
|
||||||
putAffection ud
|
let posX = (fst $ sPos $ ship ud) + 23 - 30 * sin (toR $ sRot $ ship ud)
|
||||||
{ ship = (ship ud)
|
posY = (snd $ sPos $ ship ud) + 23 - 30 * cos (toR $ sRot $ ship ud)
|
||||||
{ sRot = (sRot $ ship ud) - 180 * sec
|
tempRoot <- liftIO $ gegl_node_new
|
||||||
}
|
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
|
||||||
}
|
}
|
||||||
SDL.KeycodeUp ->
|
putAffection $ ud
|
||||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
|
{ shots = ips
|
||||||
ud <- getAffection
|
}
|
||||||
let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud)
|
_ -> return ()
|
||||||
vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud)
|
SDL.WindowClosedEvent _ -> do
|
||||||
putAffection ud
|
traceM "seeya!"
|
||||||
{ ship = (ship ud)
|
put ad
|
||||||
{ sVel = (vx, vy)
|
{ quitEvent = True
|
||||||
}
|
}
|
||||||
}
|
_ -> return ()
|
||||||
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
|
) evs
|
||||||
SDL.KeycodeSpace ->
|
ud2 <- getAffection
|
||||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
|
nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
|
||||||
ud <- getAffection
|
-- liftIO $ traceIO $ show $ length nhs
|
||||||
-- ad <- get
|
putAffection ud2
|
||||||
let posX = (fst $ sPos $ ship ud) + 23 - 30 * sin (toR $ sRot $ ship ud)
|
{ haskelloids = nhs
|
||||||
posY = (snd $ sPos $ ship ud) + 23 - 30 * cos (toR $ sRot $ ship ud)
|
}
|
||||||
tempRoot <- liftIO $ gegl_node_new
|
ud3 <- getAffection
|
||||||
tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle"
|
let nx = fst (sPos $ ship ud3) + (fst (sVel $ ship ud3)) * sec
|
||||||
[ Property "x" $ PropertyDouble $ posX
|
ny = snd (sPos $ ship ud3) + (snd (sVel $ ship ud3)) * sec
|
||||||
, Property "y" $ PropertyDouble $ posY
|
(nnx, nny) = wrapAround (nx, ny) 50
|
||||||
, Property "width" $ PropertyDouble 4
|
liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyTranslate) $ Operation "gegl:translate"
|
||||||
, Property "height" $ PropertyDouble 4
|
[ Property "x" $ PropertyDouble $ nnx
|
||||||
, Property "color" $ PropertyColor $ (GEGL.RGBA 1 1 1 1)
|
, Property "y" $ PropertyDouble $ nny
|
||||||
]
|
]
|
||||||
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
|
liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyRotate) $ Operation "gegl:rotate"
|
||||||
_ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux"
|
[ Property "degrees" $ PropertyDouble $ sRot $ ship ud3
|
||||||
ips <- insertParticle (shots ud) $
|
]
|
||||||
Particle
|
ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
|
||||||
{ particleTimeToLive = 5
|
ud4 <- getAffection
|
||||||
, particleCreation = elapsedTime ad
|
putAffection ud4
|
||||||
, particlePosition = (posX, posY)
|
{ ship = (ship ud3)
|
||||||
, particleRotation = Rad 0
|
{ sPos = (nnx, nny)
|
||||||
, 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
|
|
||||||
}
|
}
|
||||||
ud3 <- getAffection
|
, shots = ups
|
||||||
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)
|
||||||
|
|
@ -357,12 +357,8 @@ shotsUpd sec part@Particle{..} = do
|
||||||
50
|
50
|
||||||
50
|
50
|
||||||
)
|
)
|
||||||
maybe (return ()) (\_ -> do
|
maybe (return ()) (\_ ->
|
||||||
liftIO $ traceIO "YOU LOST!"
|
lose
|
||||||
liftIO $ gegl_node_link (nodeGraph ud M.! KeyLost) (nodeGraph ud M.! KeyPixelize)
|
|
||||||
putAffection ud
|
|
||||||
{ wonlost = True
|
|
||||||
}
|
|
||||||
) lost
|
) lost
|
||||||
return part
|
return part
|
||||||
{ particlePosition = (nnx, nny)
|
{ particlePosition = (nnx, nny)
|
||||||
|
|
@ -393,7 +389,11 @@ haskelloidShotDown h = do
|
||||||
(nodeGraph ud M.! KeyHNop)
|
(nodeGraph ud M.! KeyHNop)
|
||||||
else do
|
else do
|
||||||
liftIO $ traceIO "YOU WON!"
|
liftIO $ traceIO "YOU WON!"
|
||||||
liftIO $ gegl_node_link (nodeGraph ud M.! KeyWon) (nodeGraph ud M.! KeyPixelize)
|
_ <- liftIO $ gegl_node_connect_to
|
||||||
|
(nodeGraph ud M.! KeyWon)
|
||||||
|
"output"
|
||||||
|
(nodeGraph ud M.! KeyFGOver)
|
||||||
|
"aux"
|
||||||
putAffection ud
|
putAffection ud
|
||||||
{ wonlost = True
|
{ wonlost = True
|
||||||
}
|
}
|
||||||
|
|
@ -426,12 +426,8 @@ updateHaskelloid sec h@Haskelloid{..} = do
|
||||||
50
|
50
|
||||||
50
|
50
|
||||||
)
|
)
|
||||||
maybe (return ()) (\_ -> do
|
maybe (return ()) (\_ ->
|
||||||
liftIO $ traceIO "YOU LOST!"
|
lose
|
||||||
liftIO $ gegl_node_link (nodeGraph ud M.! KeyLost) (nodeGraph ud M.! KeyPixelize)
|
|
||||||
putAffection ud
|
|
||||||
{ wonlost = True
|
|
||||||
}
|
|
||||||
) lost
|
) lost
|
||||||
return h
|
return h
|
||||||
{ hPos = (nnx, nny)
|
{ hPos = (nnx, nny)
|
||||||
|
|
@ -483,3 +479,17 @@ insertHaskelloid hs split (px, py) = do
|
||||||
, ("rot", tempRot)
|
, ("rot", tempRot)
|
||||||
]
|
]
|
||||||
} : hs
|
} : hs
|
||||||
|
|
||||||
|
lose :: Affection UserData ()
|
||||||
|
lose = do
|
||||||
|
ud <- getAffection
|
||||||
|
liftIO $ traceIO "YOU LOST!"
|
||||||
|
_ <- liftIO $ gegl_node_connect_to
|
||||||
|
(nodeGraph ud M.! KeyLost)
|
||||||
|
"output"
|
||||||
|
(nodeGraph ud M.! KeyFGOver)
|
||||||
|
"aux"
|
||||||
|
putAffection ud
|
||||||
|
{ wonlost = True
|
||||||
|
}
|
||||||
|
liftIO $ gegl_node_drop $ nodeGraph ud M.! KeyShip
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue