initiating rewrite

This commit is contained in:
nek0 2017-12-16 11:55:30 +01:00
parent 25d45277a0
commit 31fd771e64
8 changed files with 295 additions and 740 deletions

View file

@ -57,6 +57,7 @@ executable haskelloids
, Types , Types
, Commons , Commons
, StateMachine , StateMachine
, Menu
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: -- other-extensions:
@ -64,11 +65,11 @@ executable haskelloids
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: base >=4.9 && <4.11 build-depends: base >=4.9 && <4.11
, affection , affection
, gegl
, babl
, sdl2 >= 2.1.3.1 , sdl2 >= 2.1.3.1
, containers , containers
, random , random
, nanovg
, linear
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: src hs-source-dirs: src

View file

@ -9,9 +9,9 @@ import BABL
import qualified Data.Map as M import qualified Data.Map as M
import Data.List (delete) import Data.List (delete)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes, isJust)
import Control.Monad (foldM, unless) import Control.Monad (foldM, unless, when)
import System.Random (randomRIO) import System.Random (randomRIO)
@ -22,296 +22,6 @@ import Types
toR :: Double -> Double toR :: Double -> Double
toR deg = deg * pi / 180 toR deg = deg * pi / 180
clean :: UserData -> IO ()
clean ud = do
mapM_ (gegl_node_drop . (\h -> hNodeGraph h M.! "root")) (haskelloids ud)
gegl_node_drop $ nodeGraph ud M.! KeyRoot
load :: IO UserData
load = do
traceM "loading"
root <- gegl_node_new
traceM "root node"
bg <- gegl_node_new_child root $ Operation "gegl:rectangle"
[ Property "x" $ PropertyDouble 0
, Property "y" $ PropertyDouble 0
, Property "width" $ PropertyDouble 800
, Property "height" $ PropertyDouble 600
, Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1
]
shipNode <- gegl_node_new_child root $ Operation "gegl:svg-load"
[ Property "path" $ PropertyString "assets/ship.svg"
, Property "width" $ PropertyInt 50
, Property "height" $ PropertyInt 50
]
pnop <- gegl_node_new_child root $ Operation "gegl:nop" []
hnop <- gegl_node_new_child root $ Operation "gegl:nop" []
fgnop <- gegl_node_new_child root $ Operation "gegl:nop" []
sover <- gegl_node_new_child root defaultOverOperation
hover <- gegl_node_new_child root defaultOverOperation
pover <- 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"
[ Property "x" $ PropertyDouble 375
, Property "y" $ PropertyDouble 275
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
fgtranslate <- gegl_node_new_child root $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble 150
, Property "y" $ PropertyDouble 250
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
rotate <- gegl_node_new_child root $ Operation "gegl:rotate"
[ Property "origin-x" $ PropertyDouble 25
, Property "origin-y" $ PropertyDouble 25
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
crop <- gegl_node_new_child root $ Operation "gegl:crop"
[ Property "width" $ PropertyDouble 800
, Property "height" $ PropertyDouble 600
]
nbuffer <- gegl_buffer_new (Just $ GeglRectangle 0 0 800 600) =<<
babl_format (PixelFormat BABL.RGBA CFfloat)
sink <- gegl_node_new_child root $ Operation "gegl:copy-buffer"
[ Property "buffer" $ PropertyBuffer nbuffer
]
won <- gegl_node_new_child root $ textOperation
[ Property "string" $ PropertyString "YOU WON!"
, Property "font" $ PropertyString "Modulo"
, 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 "font" $ PropertyString "Modulo"
, Property "size" $ PropertyDouble 100
, 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"
[ Property "size-x" $ PropertyInt 3
, Property "size-y" $ PropertyInt 3
]
-- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation"
-- [ Property "pattern" $ PropertyInt 8
-- ]
menuHeading <- gegl_node_new_child root $ textOperation
[ Property "string" $ PropertyString "Haskelloids"
, Property "font" $ PropertyString "Modulo"
, Property "size" $ PropertyDouble 100
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
]
menuText <- gegl_node_new_child root $ textOperation
[ Property "string" $ PropertyString "Press [Space] to start"
, Property "font" $ PropertyString "Modulo"
, Property "size" $ PropertyDouble 50
, Property "alignment" $ PropertyInt 1
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
]
menuTranslateHeading <- gegl_node_new_child root $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble 150
, Property "y" $ PropertyDouble 100
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
menuTranslateText <- gegl_node_new_child root $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble 130
, Property "y" $ PropertyDouble 300
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
menuOver <- gegl_node_new_child root defaultOverOperation
gegl_node_link menuHeading menuTranslateHeading
gegl_node_link_many [menuText, menuTranslateText, menuOver]
_ <- gegl_node_connect_to menuTranslateHeading "output" menuOver "aux"
gegl_node_link_many [shipNode, rotate, translate]
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 pnop "output" pover "aux"
_ <- gegl_node_connect_to hnop "output" hover "aux"
_ <- gegl_node_connect_to bg "output" bgover "aux"
liftIO $ gegl_node_link fgnop fgtranslate
-- _ <- gegl_node_connect_to fgtranslate "output" fgover "aux"
_ <- gegl_node_connect_to fgnop "output" fgover "aux"
traceM "nodes complete"
myMap <- return $ M.fromList
[ (KeyRoot, root)
, (KeyShip, shipNode)
, (KeyShipTranslate, translate)
, (KeyShipRotate, rotate)
, (KeyPNop, pnop)
, (KeyHNop, hnop)
, (KeyCrop, crop)
, (KeyShipOver, sover)
, (KeySink, sink)
, (KeyWon, won)
, (KeyLost, lost)
, (KeyPixelize, pixelize)
, (KeyFGOver, fgover)
, (KeyFGNop, fgnop)
, (KeyFGTrans, fgtranslate)
, (KeyMenuHeading, menuTranslateHeading)
, (KeyMenuText, menuText)
, (KeyMenuOver, menuOver)
]
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
{ sPos = (375, 275)
, sVel = (0, 0)
, sRot = 0
, sFlange = rotate
}
, buffer = nbuffer
, shots = ParticleSystem (ParticleStorage Nothing []) pnop nbuffer
-- , haskelloids = hs
, haskelloids = []
, wonlost = False
, pixelSize = 3
, state = Menu
, fade = FadeIn 1
}
insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid]
insertHaskelloid hasks split (px, py) = do
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 ((-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: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 $ 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 =
( px + (100 / 2 / fromIntegral rdiv)
, py + (100 / 2 / fromIntegral rdiv)
)
, hVel = (vx, vy)
, hRot = rot
, hPitch = pitch
, hDiv = rdiv
, hFlange = tempOver
, hNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("svg", tempSvg)
, ("trans", tempTrans)
, ("rot", tempRot)
]
} : hasks
haskelloidShotDown :: Haskelloid -> Affection UserData ()
haskelloidShotDown h = do
ud <- getAffection
-- liftIO $ traceIO $ show $ length $ haskelloids ud
let redHaskelloids = delete h (haskelloids ud)
newHaskelloids <- catMaybes <$> foldM
(\acc _ ->
if hDiv h < 4
then
liftIO $ insertHaskelloid acc (Just $ hDiv h) $ hPos h
else
return $ Nothing : acc
)
(map Just redHaskelloids) ([0..1] :: [Int])
liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
liftIO $ gegl_node_link_many $ map hFlange newHaskelloids
if not $ null newHaskelloids
then
liftIO $ gegl_node_link
(last $ map hFlange newHaskelloids)
(nodeGraph ud M.! KeyHNop)
else do
liftIO $ traceIO "YOU WON!"
_ <- liftIO $ gegl_node_link
(nodeGraph ud M.! KeyWon)
(nodeGraph ud M.! KeyFGTrans)
_ <- liftIO $ gegl_node_connect_to
(nodeGraph ud M.! KeyFGTrans)
"output"
(nodeGraph ud M.! KeyFGOver)
"aux"
_ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
putAffection ud
{ wonlost = True
}
ud2 <- getAffection
putAffection ud2
{ haskelloids = newHaskelloids
}
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
(nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
-- liftIO $ traceIO $ "moving to: " ++ show nnx ++ " " ++ show nny
liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble nnx
, Property "y" $ PropertyDouble nny
]
liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
[ Property "degrees" $ PropertyDouble newRot
]
ud <- getAffection
lost <-
case state ud of
InGame -> liftIO $ gegl_rectangle_intersect
(GeglRectangle (floor nnx) (floor nny) (100 `div` hDiv) (100 `div` hDiv))
(GeglRectangle
(floor $ fst $ sPos $ ship ud)
(floor $ snd $ sPos $ ship ud)
50
50
)
_ -> return Nothing
maybe (return ()) (const $ do
lose
putAffection ud {wonlost = True}
) lost
return h
{ hPos = (nnx, nny)
, hRot = newRot
}
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)
where where
@ -323,62 +33,3 @@ wrapAround (nx, ny) width = (nnx, nny)
| ny > 600 = ny - (600 + width) | ny > 600 = ny - (600 + width)
| ny < -width = ny + 600 + width | ny < -width = ny + 600 + width
| otherwise = ny | otherwise = ny
shotsUpd :: Double -> Particle -> Affection UserData Particle
shotsUpd sec part@Particle{..} = do
let newX = fst particlePosition + sec * fromIntegral (fst particleVelocity)
newY = snd particlePosition + sec * fromIntegral (snd particleVelocity)
(nnx, nny) = wrapAround (newX, newY) 4
liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
[ Property "x" $ PropertyDouble nnx
, Property "y" $ PropertyDouble nny
]
ud <- getAffection
inters <- catMaybes <$> mapM (\h -> do
col <- liftIO $ gegl_rectangle_intersect
(GeglRectangle (floor nnx) (floor nny) 4 4)
(GeglRectangle
(floor $ fst $ hPos h)
(floor $ snd $ hPos h)
(100 `div` hDiv h)
(100 `div` hDiv h)
)
case col of
Just _ -> return $ Just h
Nothing -> return Nothing
) (haskelloids ud)
unless (null inters) $
haskelloidShotDown $ head inters
lost <- liftIO $ gegl_rectangle_intersect
(GeglRectangle (floor nnx) (floor nny) 4 4)
(GeglRectangle
(floor $ fst $ sPos $ ship ud)
(floor $ snd $ sPos $ ship ud)
50
50
)
maybe (return ()) (const lose) lost
return part
{ particlePosition = (nnx, nny)
, particleTimeToLive = if not $ null inters then 0 else particleTimeToLive
}
shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
shotsDraw _ _ _ = return ()
lose :: Affection UserData ()
lose = do
ud <- getAffection
liftIO $ traceIO "YOU LOST!"
_ <- liftIO $ gegl_node_link
(nodeGraph ud M.! KeyLost)
(nodeGraph ud M.! KeyFGTrans)
_ <- liftIO $ gegl_node_connect_to
(nodeGraph ud M.! KeyFGTrans)
"output"
(nodeGraph ud M.! KeyFGOver)
"aux"
_ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
putAffection ud
{ wonlost = True
}

View file

@ -5,7 +5,7 @@ import qualified SDL
import GEGL import GEGL
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes, isJust, fromJust, isNothing)
import Control.Monad (when, foldM) import Control.Monad (when, foldM)
@ -40,7 +40,7 @@ loadGame = do
liftIO $ traceIO "nodes linked" liftIO $ traceIO "nodes linked"
putAffection ud putAffection ud
{ haskelloids = hs { haskelloids = hs
, wonlost = False , wonlost = Nothing
, shots = ParticleSystem , shots = ParticleSystem
(ParticleStorage Nothing []) (ParticleStorage Nothing [])
(nodeGraph ud M.! KeyPNop) (nodeGraph ud M.! KeyPNop)
@ -108,11 +108,10 @@ updateGame sec = do
putAffection ud3 putAffection ud3
{ haskelloids = nhs { haskelloids = nhs
} }
-- liftIO $ traceIO $ show $ length nhs
ud3 <- getAffection ud3 <- getAffection
-- ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
ups <- updateParticleSystem (shots ud3) sec shotsUpd ups <- updateParticleSystem (shots ud3) sec shotsUpd
ud4 <- getAffection ud4 <- getAffection
when (isJust $ wonlost ud3) (winlose $ fromJust $ wonlost ud3)
putAffection ud4 putAffection ud4
{ shots = ups { shots = ups
} }
@ -136,81 +135,99 @@ handleGameEvent e = do
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeLeft -> do SDL.KeycodeLeft -> do
ud <- getAffection ud <- getAffection
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $ when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
putAffection ud && (isNothing $ wonlost ud)) $ do
{ ship = (ship ud) let rawRot = (sRot $ ship ud) + 15 * sec
{ sRot = (sRot $ ship ud) + 15 * sec newRot
| rawRot > 360 = rawRot - 360
| rawRot < 0 = rawRot + 360
| otherwise = rawRot
putAffection ud
{ ship = (ship ud)
{ sRot = newRot
}
} }
}
SDL.KeycodeRight -> do SDL.KeycodeRight -> do
ud <- getAffection ud <- getAffection
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
putAffection ud && (isNothing $ wonlost ud)) $ do
{ ship = (ship ud) let rawRot = (sRot $ ship ud) - 15 * sec
{ sRot = (sRot $ ship ud) - 15 * sec newRot
| rawRot > 360 = rawRot - 360
| rawRot < 0 = rawRot + 360
| otherwise = rawRot
putAffection ud
{ ship = (ship ud)
{ sRot = newRot
}
} }
}
SDL.KeycodeUp -> SDL.KeycodeUp ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
ud <- getAffection && (isNothing $ wonlost wd)) $ do
let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud) ud <- getAffection
vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud) 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
{ sVel = (vx, vy) { ship = (ship ud)
{ sVel = (vx, vy)
}
} }
} -- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
SDL.KeycodeSpace -> SDL.KeycodeSpace ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
ud <- getAffection && (isNothing $ wonlost wd)) $ do
liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $ Operation "gegl:pixelize" ud <- getAffection
[ Property "size-x" $ PropertyInt 8 liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $
, Property "size-y" $ PropertyInt 8 Operation "gegl:pixelize"
] [ Property "size-x" $ PropertyInt 8
-- ad <- get , Property "size-y" $ PropertyInt 8
let posX = fst (sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud)
posY = snd (sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
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 = 0
, particleVelocity =
( (floor $ -200 * (sin $ toR $ sRot $ ship ud))
, (floor $ -200 * (cos $ toR $ sRot $ ship ud))
)
, particlePitchRate = 0
, particleRootNode = tempRoot
, particleNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("rect", tempRect)
] ]
, particleStackCont = tempOver -- ad <- get
, particleDrawFlange = tempOver let posX = fst (sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud)
posY = snd (sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
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 = 0
, particleVelocity =
( (floor $ -200 * (sin $ toR $ sRot $ ship ud))
, (floor $ -200 * (cos $ toR $ sRot $ ship ud))
)
, particlePitchRate = 0
, particleRootNode = tempRoot
, particleNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("rect", tempRect)
]
, particleStackCont = tempOver
, particleDrawFlange = tempOver
}
putAffection $ ud
{ shots = ips
, pixelSize = 8
} }
putAffection $ ud
{ shots = ips
, pixelSize = 8
}
SDL.KeycodeR -> SDL.KeycodeR ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && wonlost wd) $ do when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
liftIO $ traceIO "reloading" && isJust (wonlost wd)) $ do
liftIO $ clean wd liftIO $ traceIO "reloading"
nd <- liftIO $ load liftIO $ clean wd
putAffection nd nd <- liftIO $ load
putAffection nd
loadGame
_ -> return () _ -> return ()
SDL.WindowClosedEvent _ -> do SDL.WindowClosedEvent _ -> do
traceM "seeya!" traceM "seeya!"

81
src/Init.hs Normal file
View file

@ -0,0 +1,81 @@
module Init where
import Affection
import SDL (($=))
import qualified SDL
import qualified Data.Set as S
import Data.Maybe
import System.Random
import NanoVG
-- Internal imports
import Types
load :: IO UserData
load = do
nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes])
mhaskImage <- createImage nvgCtx "assets/haskelloid.svg" 0
mshipImage <- createImage nvgCtx "assets/ship.svg" 0
when (isNothing mhasImage || isNothing mshipImage) $
logIO Error "Failed loading image assets"
hasks <- mapM (\_ -> do
posx <- randomRIO (0, 800)
posy <- randomRIO (0, 600)
velx <- randomRIO (-10, 10)
vely <- randomRIO (-10, 10)
rot <- randomRIO (0, 2*pi)
pitch <- randomRIO (-pi, pi)
div <- randomRIO (1, 2)
return Haskelloid
(V2 posx posy)
(V2 velx vely)
rot
pitch
div
(fromJust mhaskImage)
) [1..10]
return UserData
{ ship = Ship
{ sPos = V2 400 300
, sVel = V2 0 0
, sRot = 0
, sImg = fromust mshipImage
}
, haskelloids = []
, wonlost = Nothing
, state = Menu
, fade = FadeIn 1
, nano = nvgCtx
}
-- _ <- SDL.setMouseLocationMode SDL.RelativeLocation
-- GL.depthFunc $= ust GL.Less
-- pane <- GL.genObjectName
-- GL.BindVertexArrayObject $= Just pane
-- verts <- GL.genObejctName
-- let vertCoord =
-- [ (-1), (-1), 0
-- , 1 , (-1), 0
-- , (-1), 1 , 0
-- , 1 , 1 , 0
-- , (-1), 1 , 0
-- , 1 , (-1), 0
-- ]
-- withArray vertCoord $ \ptr
-- GL.bufferData GL.ArrayBuffer $=
-- ( fromIntegral $ length vertCoord * 3 * sizeOf (0 :: Double)
-- , ptr
-- , GL.StaticDraw
-- )
-- GL.vertexAttribPointer (GL.AttribLocation 0) $=
-- ( GL.ToFloat
-- , GL.VertexArrayDescriptor 4 GL.Float 0 (plusPtr nullPtr 0)
-- )
-- GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled

View file

@ -1,222 +1,63 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Main where module Main where
import Affection hiding (StateMachine(..)) import Affection
import SDL (($=))
import qualified SDL import qualified SDL
import GEGL
import Data.List (delete) import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Control.Monad (when, foldM) import Linear as L
import Debug.Trace
-- internal imports -- internal imports
import Types import Types
import Commons import Commons
import StateMachine import StateMachine ()
import Init
import Menu
import InGame
main :: IO () main :: IO ()
main = withAffection AffectionConfig main = do
{ initComponents = All logIO Debug "Starting"
, windowTitle = "Haskelloids" withAffection AffectionConfig
, windowConfig = defaultWindow { initComponents = All
, initScreenMode = SDL.Windowed , windowTitle = "Haskelloids"
, preLoop = return () , windowConfig = defaultWindow
, drawLoop = draw { SDL.windowOpenGL = Just SDL.defaultOpenGL
, updateLoop = update { SDL.glProfile = SDL.Core SDL.Normal 3 3
, loadState = load }
, cleanUp = clean }
, canvasSize = Nothing , initScreenMode = SDL.Windowed
, eventLoop = handleGameEvent , canvasSize = Nothing
} , loadState = load
, preLoop = smLoad Menu
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
}
update :: Double -> Affection UserData () update :: Double -> Affection UserData ()
update sec = do update sec = do
ud <- getAffection ud <- getAffection
smUpdate (state ud) sec smUpdate (state ud) sec
-- update sec = do handle :: SDL.EventPayload -> Affection UserData ()
-- -- traceM $ (show $ 1 / sec) ++ " FPS" handle e = do
-- ad <- get ud <- getAffection
-- wd <- getAffection smEvent (state ud) e
-- when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize wd > 3) $ do
-- liftIO $ gegl_node_set (nodeGraph wd M.! KeyPixelize) $ Operation "gegl:pixelize"
-- [ Property "size-x" $ PropertyInt $ pixelSize wd - 1
-- , Property "size-y" $ PropertyInt $ pixelSize wd - 1
-- ]
-- pd <- getAffection
-- putAffection pd
-- { pixelSize = pixelSize wd -1
-- }
-- -- 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
-- putAffection ud2
-- { haskelloids = nhs
-- }
-- 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.! KeyShipTranslate) $ Operation "gegl:translate"
-- [ Property "x" $ PropertyDouble $ nnx
-- , Property "y" $ PropertyDouble $ nny
-- ]
-- liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyShipRotate) $ Operation "gegl:rotate"
-- [ Property "degrees" $ PropertyDouble $ sRot $ ship ud3
-- ]
-- ups <- updateParticleSystem (shots ud3) sec shotsUpd
-- ud4 <- getAffection
-- putAffection ud4
-- { ship = (ship ud3)
-- { sPos = (nnx, nny)
-- }
-- , shots = ups
-- }
draw :: Affection UserData () draw :: Affection UserData ()
draw = do draw = do
GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
ud <- getAffection ud <- getAffection
smDraw (state ud) GL.currentProgram $= (Just . GLU.program $ program sd)
-- drawParticleSystem (shots ud) (\_ _ _ -> return()) let proj = ortho (-1) 1 (-1) 1 (-1) 1
-- liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink view = lookAt
-- present (V3 0 0 (-1))
-- (GeglRectangle 0 0 800 600) (V3 0 0 0)
-- (buffer ud) (V3 0 1 0)
-- True model = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 0 0 0)
-- render Nothing Nothing
-- shotsUpd :: Double -> Particle -> Affection UserData Particle
-- shotsUpd sec part@Particle{..} = do
-- let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
-- newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)
-- (nnx, nny) = wrapAround (newX, newY) 4
-- liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
-- [ Property "x" $ PropertyDouble $ nnx
-- , Property "y" $ PropertyDouble $ nny
-- ]
-- ud <- getAffection
-- inters <- catMaybes <$> mapM (\h -> do
-- col <- liftIO $ gegl_rectangle_intersect
-- (GeglRectangle (floor nnx) (floor nny) 4 4)
-- (GeglRectangle
-- (floor $ fst $ hPos h)
-- (floor $ snd $ hPos h)
-- (100 `div` hDiv h)
-- (100 `div` hDiv h)
-- )
-- case col of
-- Just _ -> return $ Just h
-- Nothing -> return Nothing
-- ) (haskelloids ud)
-- when (not $ null inters) $
-- haskelloidShotDown $ head inters
-- lost <- liftIO $ gegl_rectangle_intersect
-- (GeglRectangle (floor nnx) (floor nny) 4 4)
-- (GeglRectangle
-- (floor $ fst $ sPos $ ship ud)
-- (floor $ snd $ sPos $ ship ud)
-- 50
-- 50
-- )
-- maybe (return ()) (\_ ->
-- lose
-- ) lost
-- return part
-- { particlePosition = (nnx, nny)
-- , particleTimeToLive = if (not $ null inters) then 0 else particleTimeToLive
-- }
haskelloidShotDown :: Haskelloid -> Affection UserData ()
haskelloidShotDown h = do
liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
ud <- getAffection
let redHaskelloids = delete h (haskelloids ud)
liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
newHaskelloids <- catMaybes <$> foldM
(\acc _ ->
if hDiv h < 4
then
liftIO $ insertHaskelloid acc (Just $ hDiv h) $ hPos h
else
return $ Nothing : acc
)
(map Just redHaskelloids) ([0..1] :: [Int])
liftIO $ gegl_node_link_many $ map hFlange newHaskelloids
if not $ null newHaskelloids
then
liftIO $ gegl_node_link
(last $ map hFlange newHaskelloids)
(nodeGraph ud M.! KeyHNop)
else do
liftIO $ traceIO "YOU WON!"
liftIO $ gegl_node_link
(nodeGraph ud M.! KeyWon)
(nodeGraph ud M.! KeyFGNop)
putAffection ud
{ wonlost = True
}
putAffection ud
{ haskelloids = newHaskelloids
}
-- updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
-- updateHaskelloid sec h@Haskelloid{..} = do
-- let newX = (fst $ hPos) + sec * (fst $ hVel)
-- newY = (snd $ hPos) + sec * (snd $ hVel)
-- rawRot = hRot + hPitch * sec
-- newRot
-- | rawRot > 180 = rawRot - 360
-- | rawRot < -180 = 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
-- , Property "y" $ PropertyDouble $ nny
-- ]
-- liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
-- [ Property "degrees" $ PropertyDouble newRot
-- ]
-- ud <- getAffection
-- lost <- liftIO $ gegl_rectangle_intersect
-- (GeglRectangle (floor nnx) (floor nny) (100 `div` hDiv) (100 `div` hDiv))
-- (GeglRectangle
-- (floor $ fst $ sPos $ ship ud)
-- (floor $ snd $ sPos $ ship ud)
-- 50
-- 50
-- )
-- maybe (return ()) (\_ ->
-- lose
-- ) lost
-- return h
-- { hPos = (nnx, nny)
-- , hRot = newRot
-- }
lose :: Affection UserData ()
lose = do
ud <- getAffection
liftIO $ traceIO "YOU LOST!"
_ <- liftIO $ gegl_node_link
(nodeGraph ud M.! KeyLost)
(nodeGraph ud M.! KeyFGNop)
putAffection ud
{ wonlost = True
}
_ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
return ()

View file

@ -7,13 +7,68 @@ import Debug.Trace
import Types import Types
handleMenuEvent :: Double -> SDL.Event -> Affection UserData () handleMenuEvent :: SDL.EventPayload -> Affection UserData ()
handleMenuEvent sec e = do handleMenuEvent e =
ad <- get case e of
case SDL.eventPayload e of SDL.KeyboardEvent dat ->
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeSpace ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
ud <- getAffection
liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyFGNop) "input"
smLoad InGame
_ -> return ()
SDL.WindowClosedEvent _ -> do SDL.WindowClosedEvent _ -> do
traceM "seeya!" ad <- get
put ad put ad
{ quitEvent = True { quitEvent = True
} }
_ -> return () _ -> return ()
loadMenu :: Affection UserData ()
loadMenu = do
ud <- getAffection
liftIO $ gegl_node_connect_to
(nodeGraph ud M.! KeyMenuOver)
"output"
(nodeGraph ud M.! KeyFGOver)
"aux"
hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do
px <- randomRIO (0, 800)
py <- randomRIO (0, 600)
insertHaskelloid acc Nothing (px, py)
) [] ([0..9] :: [Int])
liftIO $ gegl_node_link_many $ map hFlange hs
liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop)
-- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyPNop) "input"
putAffection ud
{ haskelloids = hs
, fade = FadeIn 1
, state = Menu
, shots = (shots ud)
{ partSysParts = ParticleStorage Nothing [] }
}
updateMenu :: Double -> Affection UserData ()
updateMenu sec = do
ud <- getAffection
nhs <- mapM (updateHaskelloid sec) (haskelloids ud)
case fade ud of
FadeIn ttl -> do
liftIO $ gegl_node_set (nodeGraph ud M.! KeyMenuText) $
Operation "gegl:text"
[ Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 (1.1 - ttl)
]
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
, haskelloids = nhs
}
FadeOut ttl -> do
liftIO $ gegl_node_set (nodeGraph ud M.! KeyMenuText) $
Operation "gegl:text"
[ Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 ttl
]
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
, haskelloids = nhs
}

View file

@ -2,7 +2,7 @@
module StateMachine where module StateMachine where
import Affection hiding (StateMachine(..)) import Affection
import qualified SDL import qualified SDL
import GEGL import GEGL
@ -16,91 +16,21 @@ import System.Random (randomRIO)
import Types import Types
import Commons import Commons
import InGame import InGame
import Menu
class StateMachine a us where
smLoad :: a -> Affection us ()
smUpdate :: a -> Double -> Affection us ()
smEvent :: a -> Double -> SDL.Event -> Affection us ()
smDraw :: a -> Affection us ()
smClean :: a -> Affection us ()
instance StateMachine State UserData where instance StateMachine State UserData where
smLoad Menu = do smLoad Menu = loadMenu
ud <- getAffection
liftIO $ gegl_node_connect_to
(nodeGraph ud M.! KeyMenuOver)
"output"
(nodeGraph ud M.! KeyFGOver)
"aux"
hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do
px <- randomRIO (0, 800)
py <- randomRIO (0, 600)
insertHaskelloid acc Nothing (px, py)
) [] ([0..9] :: [Int])
liftIO $ gegl_node_link_many $ map hFlange hs
liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop)
liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyPNop) "input"
putAffection ud
{ haskelloids = hs
, fade = FadeIn 1
, state = Menu
, shots = (shots ud)
{ partSysParts = ParticleStorage Nothing [] }
}
smLoad InGame = loadGame smLoad InGame = loadGame
smUpdate Menu sec = do smUpdate Menu = updateMenu
ud <- getAffection
nhs <- mapM (updateHaskelloid sec) (haskelloids ud)
case fade ud of
FadeIn ttl -> do
liftIO $ gegl_node_set (nodeGraph ud M.! KeyMenuText) $
Operation "gegl:text"
[ Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 (1.1 - ttl)
]
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
, haskelloids = nhs
}
FadeOut ttl -> do
liftIO $ gegl_node_set (nodeGraph ud M.! KeyMenuText) $
Operation "gegl:text"
[ Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 ttl
]
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
, haskelloids = nhs
}
smUpdate InGame sec = updateGame sec smUpdate InGame sec = updateGame sec
smEvent Menu _ e = do smEvent Menu = handleMenuEvent
ad <- get
case SDL.eventPayload e of
SDL.KeyboardEvent dat ->
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeSpace ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
ud <- getAffection
liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyFGNop) "input"
smLoad InGame
_ -> return ()
SDL.WindowClosedEvent _ ->
put ad
{ quitEvent = True
}
_ -> return ()
-- smEvent InGame sec e = handleGameEvent (smLoad Menu) sec e smEvent InGame = handleGameEvent
smEvent InGame _ e = handleGameEvent (SDL.eventPayload e)
smDraw Menu = do smDraw Menu = return ()
ud <- getAffection
liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
present
(GeglRectangle 0 0 800 600)
(buffer ud)
True
smDraw InGame = drawGame smDraw InGame = drawGame

View file

@ -2,64 +2,38 @@
module Types where module Types where
import Affection hiding (StateMachine) import Affection
import qualified SDL import qualified SDL
import GEGL import NanoVG
import qualified Data.Map as M
data UserData = UserData data UserData = UserData
{ nodeGraph :: M.Map NodeKey GeglNode { ship :: Ship
, ship :: Ship
, buffer :: GeglBuffer
, haskelloids :: [Haskelloid] , haskelloids :: [Haskelloid]
, shots :: ParticleSystem -- , shots :: ParticleSystem
-- , debris :: ParticleSystem -- , debris :: ParticleSystem
, wonlost :: Bool , wonlost :: Maybe WonLost
, pixelSize :: Int , pixelSize :: Int
, state :: State , state :: State
, fade :: MenuFade , fade :: MenuFade
, neno :: Context
} }
data Ship = Ship data Ship = Ship
{ sPos :: (Double, Double) { sPos :: V2 Double
, sVel :: (Double, Double) , sVel :: V2 Double
, sRot :: Double , sRot :: Double
, sFlange :: GeglNode , sImg :: Image
} }
data Haskelloid = Haskelloid data Haskelloid = Haskelloid
{ hPos :: (Double, Double) { hPos :: V2 Double
, hVel :: (Double, Double) , hVel :: V2 Double
, hRot :: Double , hRot :: Double
, hPitch :: Double , hPitch :: Double
, hDiv :: Int , hDiv :: Int
, hFlange :: GeglNode , hImg :: Image
, hNodeGraph :: M.Map String GeglNode
} deriving (Eq) } deriving (Eq)
data NodeKey
= KeyRoot
| KeyShip
| KeyShipTranslate
| KeyShipRotate
| KeyPNop
| KeyHNop
| KeyCrop
| KeyShipOver
| KeySink
| KeyWon
| KeyLost
| KeyPixelize
| KeyFGOver
| KeyFGNop
| KeyFGTrans
| KeyMenuHeading
| KeyMenuText
| KeyMenuStart
| KeyMenuHighscore
| KeyMenuOver
deriving (Ord, Eq)
data State data State
= Menu = Menu
| HighScore | HighScore
@ -68,3 +42,8 @@ data State
data MenuFade data MenuFade
= FadeIn Double = FadeIn Double
| FadeOut Double | FadeOut Double
data WonLost
= Won
| Lost
deriving (Eq)