diff --git a/.gitignore b/.gitignore
index 05d4d64..c720a2c 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,8 @@
.cabal-sandbox/
cabal.sandbox.config
dist/
+*.prof
+*.aux
+*.hp
+*.ps
+*.swp
diff --git a/assets/Modulo.ttf b/assets/Modulo.ttf
new file mode 100644
index 0000000..cfed4fc
Binary files /dev/null and b/assets/Modulo.ttf differ
diff --git a/assets/haskelloid.png b/assets/haskelloid.png
new file mode 100644
index 0000000..a4b7813
Binary files /dev/null and b/assets/haskelloid.png differ
diff --git a/assets/haskelloid.svg b/assets/haskelloid.svg
index e03949b..33da05d 100644
--- a/assets/haskelloid.svg
+++ b/assets/haskelloid.svg
@@ -1,16 +1,80 @@
-
-
\ No newline at end of file
+
+
diff --git a/assets/ship.png b/assets/ship.png
new file mode 100644
index 0000000..d247a53
Binary files /dev/null and b/assets/ship.png differ
diff --git a/cabal.config b/cabal.config
new file mode 100644
index 0000000..2544e4b
--- /dev/null
+++ b/cabal.config
@@ -0,0 +1 @@
+constraints: affection +debug
diff --git a/haskelloids.cabal b/haskelloids.cabal
index 504b840..6a72335 100644
--- a/haskelloids.cabal
+++ b/haskelloids.cabal
@@ -51,23 +51,31 @@ executable haskelloids
-- .hs or .lhs file containing the Main module.
main-is: Main.hs
ghc-options: -Wall
+ extra-libraries: GLEW
-- Modules included in this executable, other than Main.
- other-modules: InGame
- , Types
+ other-modules: Types
, Commons
+ , StateMachine
+ , Menu
+ , InGame
+ , Init
+ default-extensions: OverloadedStrings
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
-- Other library packages from which modules are imported.
build-depends: base >=4.9 && <4.11
- , affection
- , gegl
- , babl
- , sdl2
+ , affection <= 0.0.0.7
+ , sdl2 >= 2.1.3.1
+ , OpenGL
+
, containers
, random
+ , linear
+ , stm
+ , nanovg
-- Directories containing source files.
hs-source-dirs: src
diff --git a/src/Commons.hs b/src/Commons.hs
index 286c0b7..ba9a293 100644
--- a/src/Commons.hs
+++ b/src/Commons.hs
@@ -1,192 +1,122 @@
+{-# LANGUAGE RecordWildCards #-}
+
module Commons where
import Affection
import qualified SDL
-import GEGL
-import BABL
import qualified Data.Map as M
-import Data.Maybe (catMaybes)
+import Data.List (delete)
+import Data.Maybe (catMaybes, isJust)
-import Control.Monad (foldM)
+import Control.Monad (foldM, unless, when)
+import Control.Monad.IO.Class (liftIO)
import System.Random (randomRIO)
-import Debug.Trace
+import NanoVG as N hiding (V2(..))
+
+import Linear as L hiding (rotate)
+
+import Foreign.C.Types (CFloat(..))
import Types
toR :: Double -> Double
toR deg = deg * pi / 180
-clean :: UserData -> IO ()
-clean ud = do
- mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud)
- gegl_node_drop $ nodeGraph ud M.! KeyRoot
+wrapAround :: (Fractional t, Ord t, Num t) => V2 t -> t -> V2 t
+wrapAround (V2 nx ny) width = (V2 nnx nny)
+ where
+ nnx
+ | nx > 800 + half = nx - (800 + width)
+ | nx < -half = nx + 800 + width
+ | otherwise = nx
+ nny
+ | ny > 600 + half = ny - (600 + width)
+ | ny < -half = ny + 600 + width
+ | otherwise = ny
+ half = width / 2
-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
- ]
- ship <- 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
- ]
- buffer <- 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 buffer
- ]
- 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"
- 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
- -- ]
- gegl_node_link_many [ship, 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"
- traceM "nodes complete"
- myMap <- return $ M.fromList
- [ (KeyRoot, root)
- , (KeyTranslate, translate)
- , (KeyRotate, rotate)
- , (KeyShip, ship)
- , (KeyPNop, pnop)
- , (KeyHNop, hnop)
- , (KeyCrop, crop)
- , (KeyShipOver, sover)
- , (KeySink, sink)
- , (KeyWon, won)
- , (KeyLost, lost)
- , (KeyPixelize, pixelize)
- , (KeyFGOver, fgover)
- , (KeyFGNop, fgnop)
- ]
- hs <- catMaybes <$> foldM (\acc _ -> do
- px <- liftIO $ randomRIO (0, 800)
- py <- liftIO $ 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) hnop
- return $ UserData
- { nodeGraph = myMap
- , ship = Ship
- { sPos = (375, 275)
- , sVel = (0, 0)
- , sRot = 0
- , sFlange = rotate
- }
- , buffer = buffer
- , shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer
- , haskelloids = hs
- , wonlost = False
- , pixelSize = 3
- , state = InGame
+newHaskelloids :: Affection UserData [Haskelloid]
+newHaskelloids = do
+ img <- haskImage <$> getAffection
+ liftIO $ mapM (\_ -> do
+ posx <- randomRIO (0, 800)
+ posy <- randomRIO (0, 600)
+ velx <- randomRIO (-10, 10)
+ vely <- randomRIO (-10, 10)
+ rot <- randomRIO (-180, 180)
+ pitch <- randomRIO (-pi, pi)
+ div <- randomRIO (1, 2)
+ return $ Haskelloid
+ (V2 posx posy)
+ (V2 velx vely)
+ rot
+ pitch
+ div
+ img
+ ) [1..10]
+
+updateHaskelloid :: Double -> Haskelloid -> Haskelloid
+updateHaskelloid dsec has =
+ has
+ { hPos = wrapAround
+ (hPos has + hVel has * V2 sec sec)
+ (100 / fromIntegral (hDiv has))
+ , hRot = hRot has + hPitch has * sec
}
+ where
+ sec = realToFrac dsec
-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 (0, 360)
- pitch <- liftIO $ randomRIO (-45, 45)
- 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)
- ]
- 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
- ]
- 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 $ 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
+clamp :: Ord a => a -> a -> a -> a
+clamp a' low up
+ | a' < low = low
+ | a' > up = up
+ | otherwise = a'
+
+drawImage :: Context -> Image -> V2 Float -> V2 Float -> Float -> Float -> IO ()
+drawImage ctx img pos dim rot alpha = do
+ let (V2 x y) = fmap CFloat pos
+ (V2 w h) = fmap CFloat dim
+ save ctx
+ translate ctx (x + (w/2)) (y + (h/2))
+ rotate ctx (degToRad $ CFloat rot)
+ translate ctx (-(w/2)) (-(h/2))
+ sPaint <- imagePattern ctx 0 0 w h 0 img (CFloat alpha)
+ beginPath ctx
+ rect ctx 0 0 w h
+ fillPaint ctx sPaint
+ fill ctx
+ resetTransform ctx
+ restore ctx
+
+drawSpinner :: Context -> Float -> Float -> Float -> Float -> IO ()
+drawSpinner ctx x y cr ct = do
+ let a0 = 0+t*6
+ a1 = pi + t*6
+ r0 = r
+ r1 = r*0.75
+ (cx, cy) = (CFloat x, CFloat y)
+ r = CFloat cr
+ t = CFloat ct
+ save ctx
+ beginPath ctx
+ arc ctx cx cy r0 a0 a1 CW
+ arc ctx cx cy r1 a1 a0 CCW
+ closePath ctx
+ let ax = cx+cos a0 * (r0+r1)*0.5
+ ay = cy+sin a0 * (r0+r1)*0.5
+ bx = cx+cos a1 * (r0+r1)*0.5
+ by = cy+sin a1 * (r0+r1)*0.5
+ paint <- linearGradient ctx ax ay bx by (rgba 255 255 255 0) (rgba 255 255 255 128)
+ fillPaint ctx paint
+ fill ctx
+ restore ctx
+
+drawHaskelloid :: Haskelloid -> Affection UserData ()
+drawHaskelloid (Haskelloid pos _ rot _ div img) = do
+ ctx <- nano <$> getAffection
+ liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 255
+ where
+ dim = (fmap (/ fromIntegral div) (V2 100 100))
diff --git a/src/InGame.hs b/src/InGame.hs
index 5dae5ad..1eefe50 100644
--- a/src/InGame.hs
+++ b/src/InGame.hs
@@ -1,109 +1,257 @@
+{-# LANGUAGE RecordWildCards #-}
module InGame where
-import Affection
+import Affection as A
import qualified SDL
-import GEGL
-import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Maybe (isNothing, catMaybes)
-import Control.Monad (when)
+import Control.Monad (when, unless)
+import Control.Monad.IO.Class (liftIO)
-import Debug.Trace
+import System.Random (randomRIO)
+
+import Linear
+
+import NanoVG hiding (V2(..))
+
+import Foreign.C.Types (CFloat(..))
import Types
import Commons
-handleGameEvent :: SDL.EventPayload -> Affection UserData ()
-handleGameEvent e = do
- ad <- get
- wd <- getAffection
- sec <- getDelta
- case e of
- SDL.KeyboardEvent dat ->
- case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
- SDL.KeycodeLeft -> do
- ud <- getAffection
- when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $
- putAffection ud
- { ship = (ship ud)
- { sRot = (sRot $ ship ud) + 270 * sec
- }
- }
- SDL.KeycodeRight -> do
- ud <- getAffection
- when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
- putAffection ud
- { ship = (ship ud)
- { sRot = (sRot $ ship ud) - 270 * sec
- }
- }
- SDL.KeycodeUp ->
- when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
- ud <- getAffection
- let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud)
- vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud)
- putAffection ud
- { ship = (ship ud)
- { sVel = (vx, vy)
- }
- }
- -- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
- SDL.KeycodeSpace ->
- when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
- ud <- getAffection
- liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $ Operation "gegl:pixelize"
- [ Property "size-x" $ PropertyInt 8
- , Property "size-y" $ PropertyInt 8
- ]
- -- ad <- get
- 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) + (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 = 0
- , particleRootNode = tempRoot
- , particleNodeGraph = M.fromList
- [ ("root", tempRoot)
- , ("over", tempOver)
- , ("rect", tempRect)
- ]
- , particleStackCont = tempOver
- , particleDrawFlange = tempOver
- }
- putAffection $ ud
- { shots = ips
- , pixelSize = 8
- }
- SDL.KeycodeR ->
- when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
- liftIO $ traceIO "reloading"
- liftIO $ clean wd
- nd <- liftIO $ load
- putAffection nd
- _ -> return ()
- SDL.WindowClosedEvent _ -> do
- traceM "seeya!"
- put ad
- { quitEvent = True
- }
+dVel :: Float
+dVel = 100
+
+pewVel :: Float
+pewVel = 200
+
+pewTTL :: Double
+pewTTL = 10
+
+dRot :: Float
+dRot = 150
+
+loadGame :: Affection UserData () -> Affection UserData () -> Affection UserData ()
+loadGame stateChange clean = do
+ liftIO $ logIO A.Debug "loading game"
+ ud <- getAffection
+ nhs <- newHaskelloids
+ kid <- partSubscribe (subKeyboard $ subsystems ud) (handleGameKeys stateChange clean)
+ putAffection ud
+ { stateUUIDs = UUIDClean [] [kid]
+ , haskelloids = nhs
+ , ship = (ship ud)
+ { sPos = V2 400 300
+ , sVel = V2 0 0
+ , sRot = 0
+ }
+ , shots = []
+ , state = InGame
+ , wonlost = Nothing
+ }
+
+handleGameKeys :: Affection UserData () -> Affection UserData () -> KeyboardMessage -> Affection UserData ()
+handleGameKeys stateChange clean kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
+ case SDL.keysymKeycode (msgKbdKeysym kbdev) of
+ SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
+ liftIO $ logIO A.Debug "PEW!"
+ shoot
+ SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
+ ud <- getAffection
+ unless (isNothing $ wonlost ud) $ do
+ liftIO $ logIO A.Debug "Reloading"
+ clean
+ SDL.KeycodeEscape -> do
+ liftIO $ logIO A.Debug "Leave to Menu"
+ stateChange
+ SDL.KeycodeW -> accelShip dVel
+ SDL.KeycodeS -> accelShip (-dVel)
+ SDL.KeycodeA -> rotateShip dRot
+ SDL.KeycodeD -> rotateShip (-dRot)
_ -> return ()
+
+shoot :: Affection UserData ()
+shoot = do
+ ud <- getAffection
+ let Ship{..} = ship ud
+ npew = Pew ppos pVel pewTTL
+ ppos = sPos + ((V2 0 25) `rotVec` sRot)
+ pVel = sVel + ((V2 0 pewVel) `rotVec` sRot)
+ putAffection ud
+ { shots = npew : shots ud
+ }
+
+accelShip :: Float -> Affection UserData ()
+accelShip vel = do
+ ud <- getAffection
+ dt <- getDelta
+ let s = ship ud
+ nVel = sVel s + fmap (realToFrac dt *) ((V2 0 vel) `rotVec` sRot s)
+ putAffection ud
+ { ship = s
+ { sVel = nVel
+ }
+ }
+
+rotateShip :: Float -> Affection UserData ()
+rotateShip deg = do
+ ud <- getAffection
+ dt <- getDelta
+ putAffection ud
+ { ship = (ship ud)
+ { sRot = (sRot $ ship ud) - deg * realToFrac dt
+ }
+ }
+
+rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
+rotVec (V2 x y) deg = V2 nx ny
+ where
+ nx = x * (cos $ dtor deg) + y * (sin $ dtor deg)
+ ny = x * (sin $ dtor deg) - y * (cos $ dtor deg)
+ dtor = (pi / 180 *)
+
+updateGame :: Double -> Affection UserData ()
+updateGame sec = do
+ ud <- getAffection
+ let nhs = map (updateHaskelloid sec) (haskelloids ud)
+ npews = filter (\p -> pTTL p > 0) $ map (updatePew sec) (shots ud)
+ putAffection ud
+ { haskelloids = nhs
+ , shots = npews
+ , ship = updateShip sec (ship ud)
+ }
+ checkShotDown
+ ud2 <- getAffection
+ when
+ ( ( any (checkCollision (ship ud2)) (haskelloids ud2)
+ || any (checkFriendlyFire (ship ud2)) (shots ud2)
+ )
+ && isNothing (wonlost ud2)
+ )
+ (putAffection ud2
+ { wonlost = Just Lost
+ }
+ )
+ when (isNothing (wonlost ud2) && null (haskelloids ud2))
+ (putAffection ud2
+ { wonlost = Just Won
+ }
+ )
+
+checkShotDown :: Affection UserData ()
+checkShotDown =
+ do
+ ud <- getAffection
+ let shoots = shots ud
+ hasks = haskelloids ud
+ pairs = catMaybes $ concatMap (crossOut hasks) shoots
+ deadHasks = map fst pairs
+ nhask = foldl (\acc a -> filter (\x -> a /= x) acc) hasks deadHasks
+ npews = foldl (\acc a -> filter (\x -> a /= x) acc) shoots (map snd pairs)
+ children <- liftIO $ concat <$> mapM (\Haskelloid{..} -> do
+ n1velx <- randomRIO (-10, 10)
+ n1vely <- randomRIO (-10, 10)
+ n1rot <- randomRIO (-180, 180)
+ n1pitch <- randomRIO (-pi, pi)
+ n2velx <- randomRIO (-10, 10)
+ n2vely <- randomRIO (-10, 10)
+ n2rot <- randomRIO (-180, 180)
+ n2pitch <- randomRIO (-pi, pi)
+ let ndiv = hDiv + 1
+ if ndiv > 5
+ then return []
+ else return $
+ [ Haskelloid hPos (V2 n1velx n1vely) n1rot n1pitch ndiv hImg
+ , Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg
+ ]
+ ) deadHasks
+ putAffection ud
+ { shots = npews
+ , haskelloids = nhask ++ children
+ }
+ where
+ crossOut :: [Haskelloid] -> Pew -> [Maybe (Haskelloid, Pew)]
+ crossOut hs p =
+ foldl (\acc h ->
+ if distance (pPos p) (hPos h) < (50 / fromIntegral (hDiv h))
+ then Just (h, p) : acc
+ else Nothing : acc
+ ) [] hs
+
+checkCollision :: Ship -> Haskelloid -> Bool
+checkCollision s h =
+ distance (sPos s) (hPos h) < minDist
+ where
+ minDist = 20 + (50 / fromIntegral (hDiv h))
+
+checkFriendlyFire :: Ship -> Pew -> Bool
+checkFriendlyFire s p =
+ distance (sPos s) (pPos p) < 20
+
+updateShip :: Double -> Ship -> Ship
+updateShip ddt s@Ship{..} = s
+ { sPos = wrapAround (sPos + fmap (dt *) sVel) 40
+ }
+ where
+ dt = realToFrac ddt
+
+updatePew :: Double -> Pew -> Pew
+updatePew ddt p@Pew{..} = p
+ { pPos = wrapAround (pPos + fmap (dt *) pVel) 0
+ , pTTL = pTTL - ddt
+ }
+ where
+ dt = realToFrac ddt
+
+drawGame :: Affection UserData ()
+drawGame = do
+ ud <- getAffection
+ mapM_ drawHaskelloid (haskelloids ud)
+ mapM_ drawPew (shots ud)
+ case wonlost ud of
+ Just Lost -> liftIO $ do
+ let ctx = nano ud
+ save ctx
+ fontSize ctx 120
+ fontFace ctx "modulo"
+ textAlign ctx (S.fromList [AlignCenter,AlignTop])
+ fillColor ctx (rgba 255 255 255 255)
+ textBox ctx 0 200 800 "YOU LOST!"
+ fillColor ctx (rgba 255 128 0 255)
+ fontSize ctx 40
+ textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
+ restore ctx
+ Just Won -> liftIO $ do
+ let ctx = nano ud
+ save ctx
+ fontSize ctx 120
+ fontFace ctx "modulo"
+ textAlign ctx (S.fromList [AlignCenter,AlignTop])
+ fillColor ctx (rgba 255 255 255 255)
+ textBox ctx 0 200 800 "YOU WON!"
+ fillColor ctx (rgba 128 255 0 255)
+ fontSize ctx 40
+ textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
+ restore ctx
+ Nothing -> drawShip (ship ud)
+
+drawShip :: Ship -> Affection UserData ()
+drawShip Ship{..} = do
+ ctx <- nano <$> getAffection
+ liftIO $ drawImage ctx (sImg) (sPos - fmap (/2) dim) dim sRot 255
+ where
+ dim = V2 40 40
+
+drawPew :: Pew -> Affection UserData ()
+drawPew Pew{..} = do
+ ctx <- nano <$> getAffection
+ liftIO $ do
+ let (V2 x y) = fmap CFloat pPos
+ save ctx
+ beginPath ctx
+ fillColor ctx (rgba 255 128 0 255)
+ circle ctx x y 2
+ fill ctx
+ restore ctx
diff --git a/src/Init.hs b/src/Init.hs
new file mode 100644
index 0000000..d377e12
--- /dev/null
+++ b/src/Init.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Init where
+
+import Affection as A
+
+import SDL (($=))
+import qualified SDL
+
+import qualified Graphics.Rendering.OpenGL as GL
+
+import qualified Data.Set as S
+import Data.Maybe
+
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.STM
+
+import System.Random
+import System.Exit (exitFailure)
+
+import Linear
+
+import NanoVG hiding (V2)
+
+import Foreign.C.Types (CInt(..))
+
+-- Internal imports
+
+import Types
+
+foreign import ccall unsafe "glewInit"
+ glewInit :: IO CInt
+
+load :: IO UserData
+load = do
+ -- liftIO $ logIO A.Debug "Let's drop some Hints for SDL"
+ -- SDL.HintRenderDriver $= SDL.OpenGL
+ liftIO $ logIO A.Debug "init GLEW"
+ _ <- glewInit
+ liftIO $ logIO A.Debug "loading state"
+ liftIO $ logIO A.Debug "create context"
+ nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
+ liftIO $ logIO A.Debug "load ship image"
+ mshipImage <- createImage nvgCtx (FileName "assets/ship.png") 0
+ when (isNothing mshipImage) $ do
+ logIO Error "Failed to load asset ship"
+ exitFailure
+ mhaskImage <- liftIO $
+ createImage nvgCtx (FileName "assets/haskelloid.png") 0
+ when (isNothing mhaskImage) $
+ liftIO $ logIO Error "Failed to load asset haskelloid"
+ mfont <- createFont nvgCtx "modulo" (FileName "assets/Modulo.ttf")
+ when (isNothing mfont) $ do
+ logIO Error "Failed to load font"
+ exitFailure
+ liftIO $ logIO A.Debug "Initializing subsystems"
+ subs <- Subsystems
+ <$> (return . Window =<< newTVarIO [])
+ <*> (return . Keyboard =<< newTVarIO [])
+ liftIO $ logIO A.Debug "Setting viewport"
+ GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
+ liftIO $ logIO A.Debug "Returning UserData"
+ return UserData
+ { ship = Ship
+ { sPos = V2 400 300
+ , sVel = V2 0 0
+ , sRot = 0
+ , sImg = fromJust mshipImage
+ }
+ , haskelloids = []
+ , shots = []
+ , wonlost = Nothing
+ , state = Menu
+ , fade = FadeIn 1
+ , nano = nvgCtx
+ , font = fromJust mfont
+ , subsystems = subs
+ , haskImage = fromJust mhaskImage
+ }
diff --git a/src/Main.hs b/src/Main.hs
index 4ad41c6..41171b4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,233 +1,87 @@
-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
module Main where
-import Affection
+import Affection as A
+import SDL (($=))
import qualified SDL
-import GEGL
+import qualified Graphics.Rendering.OpenGL as GL
-import Data.List (delete)
import qualified Data.Map as M
-import Data.Maybe (catMaybes)
-import Control.Monad (when, foldM)
+import Linear as L
-import Debug.Trace
+import NanoVG hiding (V2(..), V4(..))
+
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
-- internal imports
import Types
-import InGame
import Commons
+import StateMachine ()
+import Init
main :: IO ()
-main = withAffection $ AffectionConfig
- { initComponents = All
- , windowTitle = "Haskelloids"
- , windowConfig = defaultWindow
- , preLoop = return ()
- , drawLoop = draw
- , updateLoop = update
- , loadState = load
- , cleanUp = clean
- , canvasSize = Nothing
- , initScreenMode = SDL.Windowed
- , eventLoop = handleGameEvent
- }
+main = do
+ logIO A.Debug "Starting"
+ withAffection AffectionConfig
+ { initComponents = All
+ , windowTitle = "Haskelloids"
+ , windowConfig = SDL.defaultWindow
+ { SDL.windowOpenGL = Just SDL.defaultOpenGL
+ { SDL.glProfile = SDL.Core SDL.Normal 3 2
+ , SDL.glColorPrecision = V4 8 8 8 1
+ }
+ }
+ , initScreenMode = SDL.Windowed
+ , canvasSize = Nothing
+ , loadState = load
+ , preLoop = pre >> smLoad Menu
+ , eventLoop = handle
+ , updateLoop = update
+ , drawLoop = draw
+ , cleanUp = (\_ -> return ())
+ }
+
+pre :: Affection UserData ()
+pre = do
+ subs <- subsystems <$> getAffection
+ liftIO $ logIO A.Debug "Setting global resize event listener"
+ _ <- partSubscribe (subWindow subs) $ \msg -> case msg of
+ MsgWindowResize _ _ (V2 w h) -> do
+ liftIO $ logIO A.Debug "Window has been resized"
+ let nw = floor $ fromIntegral h * (800/600)
+ dw = floor $ (fromIntegral w - fromIntegral nw) / 2
+ GL.viewport $= (GL.Position dw 0, GL.Size nw h)
+ _ -> return ()
+ _ <- partSubscribe (subKeyboard subs) $ \kbdev ->
+ when (msgKbdKeyMotion kbdev == SDL.Pressed) $
+ case SDL.keysymKeycode (msgKbdKeysym kbdev) of
+ SDL.KeycodeF -> do
+ dt <- getDelta
+ liftIO $ logIO A.Debug $ "FPS: " ++ show (1/dt)
+ SDL.KeycodeO -> toggleScreen
+ _ -> return ()
+ return ()
update :: Double -> Affection UserData ()
update sec = do
- -- traceM $ (show $ 1 / sec) ++ " FPS"
- ad <- get
- wd <- getAffection
- 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 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.! 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
- ud4 <- getAffection
- putAffection ud4
- { ship = (ship ud3)
- { sPos = (nnx, nny)
- }
- , shots = ups
- }
+ ud <- getAffection
+ smUpdate (state ud) sec
-wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
-wrapAround (nx, ny) width = (nnx, nny)
- where
- nnx =
- if nx > 800
- then nx - (800 + width)
- else if nx < -width then nx + 800 + width else nx
- nny =
- if ny > 600
- then ny - (600 + width)
- else if ny < -width then ny + 600 + width else ny
+handle :: [SDL.EventPayload] -> Affection UserData ()
+handle e = do
+ (Subsystems w k) <- subsystems <$> getAffection
+ _ <- consumeSDLEvents w =<< consumeSDLEvents k e
+ return ()
draw :: Affection UserData ()
draw = do
ud <- getAffection
- 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
-
-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
- }
-
-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
- (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 ()
+ -- window <- drawWindow <$> get
+ -- pf <- liftIO $ SDL.getWindowPixelFormat window
+ -- liftIO $ logIO A.Debug $ "Window pixel format: " ++ show pf
+ liftIO $ beginFrame (nano ud) 800 600 1
+ smDraw (state ud)
+ liftIO $ endFrame (nano ud)
diff --git a/src/Menu.hs b/src/Menu.hs
new file mode 100644
index 0000000..bffa789
--- /dev/null
+++ b/src/Menu.hs
@@ -0,0 +1,86 @@
+module Menu where
+
+import Affection as A
+import qualified SDL
+
+import Debug.Trace
+
+import Data.Maybe
+import qualified Data.Set as S
+
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
+
+import qualified Data.Map as M
+
+import NanoVG hiding (V2(..), V4(..))
+
+import Linear
+
+import Foreign.C.Types
+
+-- internal imports
+
+import Types
+import Commons
+
+loadMenu :: (Affection UserData ()) -> Affection UserData ()
+loadMenu stateChange = do
+ liftIO $ logIO A.Debug "Loading Menu"
+ ud <- getAffection
+ hs <- newHaskelloids
+ kbdUUID <- partSubscribe (subKeyboard $ subsystems ud)
+ (\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
+ case SDL.keysymKeycode (msgKbdKeysym kbdev) of
+ SDL.KeycodeEscape -> do
+ liftIO $ logIO A.Debug "seeya"
+ quit
+ SDL.KeycodeSpace -> do
+ liftIO $ logIO A.Debug "Leaving Menu to Game"
+ stateChange
+ _ -> return ()
+ )
+ putAffection ud
+ { haskelloids = hs
+ , fade = FadeIn 1
+ , state = Menu
+ , stateUUIDs = UUIDClean [] [kbdUUID]
+ -- , shots = (shots ud)
+ -- { partSysParts = ParticleStorage Nothing [] }
+ }
+
+updateMenu :: Double -> Affection UserData ()
+updateMenu sec = do
+ ud <- getAffection
+ let nhs = map (updateHaskelloid sec) (haskelloids ud)
+ case fade ud of
+ FadeIn ttl -> do
+ putAffection ud
+ { fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
+ , haskelloids = nhs
+ }
+ FadeOut ttl -> do
+ putAffection ud
+ { fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
+ , haskelloids = nhs
+ }
+
+drawMenu :: Affection UserData ()
+drawMenu = do
+ ud <- getAffection
+ mapM_ drawHaskelloid (haskelloids ud)
+ liftIO $ do
+ let ctx = nano ud
+ alpha fio = case fio of
+ FadeIn d -> (floor (255 * (1 - d)))
+ FadeOut d -> (floor (255 * d))
+ save ctx
+ fontSize ctx 120
+ fontFace ctx "modulo"
+ textAlign ctx (S.fromList [AlignCenter,AlignTop])
+ fillColor ctx (rgba 255 255 255 255)
+ textBox ctx 0 200 800 "HASKELLOIDS"
+ fillColor ctx (rgba 0 128 255 (alpha $ fade ud))
+ fontSize ctx 40
+ textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit"
+ restore ctx
diff --git a/src/StateMachine.hs b/src/StateMachine.hs
new file mode 100644
index 0000000..946da7b
--- /dev/null
+++ b/src/StateMachine.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module StateMachine where
+
+import Affection
+
+import Types
+import InGame
+import Menu
+
+instance StateMachine State UserData where
+ smLoad Menu = loadMenu (smClean Menu >> smLoad InGame)
+
+ smLoad InGame = loadGame (smClean InGame >> smLoad Menu) (smClean InGame >> smLoad InGame)
+
+ smUpdate Menu = updateMenu
+
+ smUpdate InGame = updateGame
+
+ smDraw Menu = drawMenu
+
+ smDraw InGame = drawGame
+
+ smEvent _ _ = return ()
+
+ smClean _ = do
+ ud <- getAffection
+ let (UUIDClean uuwin uukbd) = stateUUIDs ud
+ (Subsystems win kbd) = subsystems ud
+ mapM_ (partUnSubscribe win) uuwin
+ mapM_ (partUnSubscribe kbd) uukbd
+ putAffection ud
+ { stateUUIDs = UUIDClean [] []
+ }
diff --git a/src/Types.hs b/src/Types.hs
index b7b37b9..4ec6ede 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -1,58 +1,115 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
module Types where
import Affection
import qualified SDL
-import GEGL
-import BABL
-import qualified Data.Map as M
+import NanoVG hiding (V2(..))
+import Linear
+
+import Control.Concurrent.STM
+import Control.Monad.IO.Class (liftIO)
data UserData = UserData
- { nodeGraph :: M.Map NodeKey GeglNode
- , ship :: Ship
- , buffer :: GeglBuffer
+ { ship :: Ship
, haskelloids :: [Haskelloid]
- , shots :: ParticleSystem
+ , shots :: [Pew]
-- , debris :: ParticleSystem
- , wonlost :: Bool
+ , wonlost :: Maybe WonLost
, pixelSize :: Int
, state :: State
+ , fade :: MenuFade
+ , nano :: Context
+ , font :: Font
+ , subsystems :: Subsystems
+ , haskImage :: Image
+ , stateUUIDs :: UUIDClean
}
data Ship = Ship
- { sPos :: (Double, Double)
- , sVel :: (Double, Double)
- , sRot :: Double
- , sFlange :: GeglNode
+ { sPos :: V2 Float
+ , sVel :: V2 Float
+ , sRot :: Float
+ , sImg :: Image
}
-data Haskelloid = Haskelloid
- { hPos :: (Double, Double)
- , hVel :: (Double, Double)
- , hRot :: Double
- , hPitch :: Double
- , hDiv :: Int
- , hFlange :: GeglNode
- , hNodeGraph :: M.Map String GeglNode
+data Pew = Pew
+ { pPos :: V2 Float
+ , pVel :: V2 Float
+ , pTTL :: Double
} deriving (Eq)
-data NodeKey
- = KeyRoot
- | KeyTranslate
- | KeyRotate
- | KeyShip
- | KeyPNop
- | KeyHNop
- | KeyCrop
- | KeyShipOver
- | KeySink
- | KeyWon
- | KeyLost
- | KeyPixelize
- | KeyFGOver
- | KeyFGNop
- deriving (Ord, Eq)
+data Haskelloid = Haskelloid
+ { hPos :: V2 Float
+ , hVel :: V2 Float
+ , hRot :: Float
+ , hPitch :: Float
+ , hDiv :: Int
+ , hImg :: Image
+ } deriving (Eq)
data State
= Menu
- | HighScore
+ -- | HighScore
| InGame
+
+data MenuFade
+ = FadeIn Double
+ | FadeOut Double
+
+data WonLost
+ = Won
+ | Lost
+ deriving (Eq)
+
+data Subsystems = Subsystems
+ { subWindow :: Window
+ , subKeyboard :: Keyboard
+ }
+
+data UUIDClean = UUIDClean
+ { uuWindow :: [MsgId WindowMessage]
+ , uuKeyboard :: [MsgId KeyboardMessage]
+ }
+
+newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
+
+instance Participant Window WindowMessage UserData where
+ partSubscribers (Window t) = do
+ subTups <- liftIO $ readTVarIO t
+ return $ map snd subTups
+
+ partSubscribe (Window t) funct = do
+ uuid <- genUUID
+ liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+ return $ MsgId uuid MsgWindowEmptyEvent
+
+ partUnSubscribe (Window t) (MsgId uuid _) =
+ liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
+ where
+ filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool
+ filterMsg (u, _) p = u /= p
+
+instance SDLSubsystem Window UserData where
+ consumeSDLEvents = consumeSDLWindowEvents
+
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
+
+instance Participant Keyboard KeyboardMessage UserData where
+ partSubscribers (Keyboard t) = do
+ subTups <- liftIO $ readTVarIO t
+ return $ map snd subTups
+
+ partSubscribe (Keyboard t) funct = do
+ uuid <- genUUID
+ liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+ return $ MsgId uuid MsgKeyboardEmptyEvent
+
+ partUnSubscribe (Keyboard t) (MsgId uuid _) =
+ liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
+ where
+ filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool
+ filterMsg (u, _) p = u /= p
+
+instance SDLSubsystem Keyboard UserData where
+ consumeSDLEvents = consumeSDLKeyboardEvents