Merge pull request #1 from nek0/v2

V2 rewrite now merged to master

.gitignore

@@ -1,3 +1,8 @@
 .cabal-sandbox/
 cabal.sandbox.config
 dist/
+*.prof
+*.aux
+*.hp
+*.ps
+*.swp

assets/haskelloid.svg

@@ -1,16 +1,80 @@
-<?xml version="1.0" encoding="UTF-8"?>
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
-<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="481.8897pt" height="340.1574pt" viewBox="0 0 481.8897 340.1574" version="1.1">
+<svg
-<defs>
+   xmlns:dc="http://purl.org/dc/elements/1.1/"
-<clipPath id="clip1">
+   xmlns:cc="http://creativecommons.org/ns#"
-  <path d="M 0 340.15625 L 481.890625 340.15625 L 481.890625 0 L 0 0 L 0 340.15625 Z M 0 340.15625 "/>
+   xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
-</clipPath>
+   xmlns:svg="http://www.w3.org/2000/svg"
-</defs>
+   xmlns="http://www.w3.org/2000/svg"
-<g id="surface0">
+   xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
-<g clip-path="url(#clip1)" clip-rule="nonzero">
+   xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
-<path style=" stroke:none;fill-rule: nonzero; fill: rgb(40%,40%,40%); fill-opacity: 1;" d="M 0 340.15625 L 113.386719 170.078125 L 0 0 L 85.039062 0 L 198.425781 170.078125 L 85.039062 340.15625 L 0 340.15625 Z M 0 340.15625 "/>
+   width="481.8897pt"
-<path style=" stroke:none;fill-rule: nonzero; fill: rgb(60%,60%,60%); fill-opacity: 1;" d="M 113.386719 340.15625 L 226.773438 170.078125 L 113.386719 0 L 198.425781 0 L 425.195312 340.15625 L 340.15625 340.15625 L 269.292969 233.859375 L 198.425781 340.15625 L 113.386719 340.15625 Z M 113.386719 340.15625 "/>
+   height="340.1574pt"
-<path style=" stroke:none;fill-rule: nonzero; fill: rgb(40%,40%,40%); fill-opacity: 1;" d="M 387.402344 240.945312 L 349.609375 184.253906 L 481.890625 184.25 L 481.890625 240.945312 L 387.402344 240.945312 Z M 387.402344 240.945312 "/>
+   viewBox="0 0 481.8897 340.1574"
-<path style=" stroke:none;fill-rule: nonzero; fill: rgb(40%,40%,40%); fill-opacity: 1;" d="M 330.710938 155.90625 L 292.914062 99.214844 L 481.890625 99.210938 L 481.890625 155.90625 L 330.710938 155.90625 Z M 330.710938 155.90625 "/>
+   version="1.1"
-</g>
+   id="svg18"
-</g>
+   sodipodi:docname="haskelloid.svg"
-</svg>
+   inkscape:export-filename="/home/nek0/workspace/Haskell/haskelloids/assets/haskelloid.png"
+   inkscape:export-xdpi="62"
+   inkscape:export-ydpi="62"
+   inkscape:version="0.92.2 (5c3e80d, 2017-08-06)">
+  <metadata
+     id="metadata22">
+    <rdf:RDF>
+      <cc:Work
+         rdf:about="">
+        <dc:format>image/svg+xml</dc:format>
+        <dc:type
+           rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
+      </cc:Work>
+    </rdf:RDF>
+  </metadata>
+  <sodipodi:namedview
+     pagecolor="#ffffff"
+     bordercolor="#666666"
+     borderopacity="1"
+     objecttolerance="10"
+     gridtolerance="10"
+     guidetolerance="10"
+     inkscape:pageopacity="0"
+     inkscape:pageshadow="2"
+     inkscape:window-width="1598"
+     inkscape:window-height="820"
+     id="namedview20"
+     showgrid="false"
+     inkscape:zoom="0.52034733"
+     inkscape:cx="234.77911"
+     inkscape:cy="226.77161"
+     inkscape:window-x="0"
+     inkscape:window-y="26"
+     inkscape:window-maximized="1"
+     inkscape:current-layer="svg18" />
+  <defs
+     id="defs5">
+    <clipPath
+       id="clip1">
+      <path
+         d="M 0 340.15625 L 481.890625 340.15625 L 481.890625 0 L 0 0 L 0 340.15625 Z M 0 340.15625 "
+         id="path2" />
+    </clipPath>
+  </defs>
+  <path
+     style="clip-rule:nonzero;fill:#9e4e2e;fill-opacity:1;fill-rule:nonzero;stroke:none"
+     d="M 0,340.15625 113.38672,170.07812 0,0 H 85.039062 L 198.42578,170.07812 85.039062,340.15625 Z m 0,0"
+     id="path7"
+     inkscape:connector-curvature="0" />
+  <path
+     style="clip-rule:nonzero;fill:#d18161;fill-opacity:1;fill-rule:nonzero;stroke:none"
+     d="M 113.38672,340.15625 226.77344,170.07812 113.38672,0 h 85.03906 L 425.19531,340.15625 H 340.15625 L 269.29297,233.85937 198.42578,340.15625 Z m 0,0"
+     id="path9"
+     inkscape:connector-curvature="0" />
+  <path
+     style="clip-rule:nonzero;fill:#9e4e2e;fill-opacity:1;fill-rule:nonzero;stroke:none"
+     d="m 387.40234,240.94531 -37.79297,-56.6914 132.28125,-0.004 v 56.69531 z m 0,0"
+     id="path11"
+     inkscape:connector-curvature="0" />
+  <path
+     style="clip-rule:nonzero;fill:#9e4e2e;fill-opacity:1;fill-rule:nonzero;stroke:none"
+     d="m 330.71094,155.90625 -37.79688,-56.691406 188.97656,-0.0039 v 56.695316 z m 0,0"
+     id="path13"
+     inkscape:connector-curvature="0" />
+</svg>

cabal.config

@@ -0,0 +1 @@
+constraints: affection +debug

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
+  other-modules:      Types 
-                    , 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
+                     , affection <= 0.0.0.7
-                     , gegl
+                     , sdl2 >= 2.1.3.1
-                     , babl
+                     , OpenGL
-                     , sdl2
+
                      , containers
                      , random
+                     , linear
+                     , stm
+                     , nanovg
   
   -- Directories containing source files.
   hs-source-dirs:      src

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 ()
+wrapAround :: (Fractional t, Ord t, Num t) => V2 t -> t -> V2 t
-clean ud = do
+wrapAround (V2 nx ny) width = (V2 nnx nny)
-  mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud)
+  where
-  gegl_node_drop $ nodeGraph ud M.! KeyRoot
+    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
+newHaskelloids :: Affection UserData [Haskelloid]
-load = do
+newHaskelloids = do
-  traceM "loading"
+  img <- haskImage <$> getAffection
-  root <- gegl_node_new
+  liftIO $ mapM (\_ -> do
-  traceM "root node"
+    posx <- randomRIO (0, 800)
-  bg <- gegl_node_new_child root $ Operation "gegl:rectangle"
+    posy <- randomRIO (0, 600)
-    [ Property "x" $ PropertyDouble 0
+    velx <- randomRIO (-10, 10)
-    , Property "y" $ PropertyDouble 0
+    vely <- randomRIO (-10, 10)
-    , Property "width" $ PropertyDouble 800
+    rot <- randomRIO (-180, 180)
-    , Property "height" $ PropertyDouble 600
+    pitch <- randomRIO (-pi, pi)
-    , Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1
+    div <- randomRIO (1, 2)
-    ]
+    return $ Haskelloid
-  ship <- gegl_node_new_child root $ Operation "gegl:svg-load"
+      (V2 posx posy)
-    [ Property "path" $ PropertyString "assets/ship.svg"
+      (V2 velx vely)
-    , Property "width" $ PropertyInt 50
+      rot
-    , Property "height" $ PropertyInt 50
+      pitch
-    ]
+      div
-  pnop <- gegl_node_new_child root $ Operation "gegl:nop" []
+      img
-  hnop <- gegl_node_new_child root $ Operation "gegl:nop" []
+    ) [1..10]
-  fgnop <- gegl_node_new_child root $ Operation "gegl:nop" []
+
-  sover <- gegl_node_new_child root $ defaultOverOperation
+updateHaskelloid :: Double -> Haskelloid -> Haskelloid
-  hover <- gegl_node_new_child root $ defaultOverOperation
+updateHaskelloid dsec has =
-  pover <- gegl_node_new_child root $ defaultOverOperation
+  has
-  bgover <- gegl_node_new_child root $ defaultOverOperation
+    { hPos = wrapAround
-  fgover <- gegl_node_new_child root $ defaultOverOperation
+      (hPos has + hVel has * V2 sec sec)
-  translate <- gegl_node_new_child root $ Operation "gegl:translate"
+      (100 / fromIntegral (hDiv has))
-    [ Property "x"        $ PropertyDouble 375
+    , hRot = hRot has + hPitch has * sec
-    , 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
     }
+  where
+    sec = realToFrac dsec
 
-insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid]
+clamp :: Ord a => a -> a -> a -> a
-insertHaskelloid hasks split (px, py) = do
+clamp a' low up
-  -- liftIO $ traceIO "inserting haskelloid"
+  | a' < low = low
-  vx <- liftIO $ randomRIO (-10, 10)
+  | a' > up = up
-  vy <- liftIO $ randomRIO (-10, 10)
+  | otherwise = a'
-  rdiv <- case split of
+
-    Nothing -> liftIO $ randomRIO (1, 2)
+drawImage :: Context -> Image -> V2 Float -> V2 Float -> Float -> Float -> IO ()
-    Just x -> return $ x + 1
+drawImage ctx img pos dim rot alpha = do
-  rot <- liftIO $ randomRIO (0, 360)
+  let (V2 x y) = fmap CFloat pos
-  pitch <- liftIO $ randomRIO (-45, 45)
+      (V2 w h) = fmap CFloat dim
-  tempRoot <- liftIO $ gegl_node_new
+  save ctx
-  tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
+  translate ctx (x + (w/2)) (y + (h/2))
-  tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load"
+  rotate ctx (degToRad $ CFloat rot)
-    [ Property "path" $ PropertyString "assets/haskelloid.svg"
+  translate ctx (-(w/2)) (-(h/2))
-    , Property "width" $ PropertyInt (100 `div` rdiv)
+  sPaint <- imagePattern ctx 0 0 w h 0 img (CFloat alpha)
-    , Property "height" $ PropertyInt (100 `div` rdiv)
+  beginPath ctx
-    ]
+  rect ctx 0 0 w h
-  tempTrans <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:translate"
+  fillPaint ctx sPaint
-    [ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2)
+  fill ctx
-    , Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2)
+  resetTransform ctx
-    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
+  restore ctx
-    ]
+
-  tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate"
+drawSpinner :: Context -> Float -> Float -> Float -> Float -> IO ()
-    [ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
+drawSpinner ctx x y cr ct = do
-    , Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
+  let a0 = 0+t*6
-    , Property "degrees" $ PropertyDouble rot
+      a1 = pi + t*6
-    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
+      r0 = r
-    ]
+      r1 = r*0.75
-  liftIO $ gegl_node_link_many [tempSvg, tempRot, tempTrans]
+      (cx, cy) = (CFloat x, CFloat y)
-  _ <- liftIO $ gegl_node_connect_to tempTrans "output" tempOver "aux"
+      r = CFloat cr
-  return $ Just  Haskelloid
+      t = CFloat ct
-    { hPos =
+  save ctx
-      ( px + (100 / 2 / fromIntegral rdiv)
+  beginPath ctx
-      , py + (100 / 2 / fromIntegral rdiv)
+  arc ctx cx cy r0 a0 a1 CW
-      )
+  arc ctx cx cy r1 a1 a0 CCW
-    , hVel = (vx, vy)
+  closePath ctx
-    , hRot = rot
+  let ax = cx+cos a0 * (r0+r1)*0.5
-    , hPitch = pitch
+      ay = cy+sin a0 * (r0+r1)*0.5
-    , hDiv = rdiv
+      bx = cx+cos a1 * (r0+r1)*0.5
-    , hFlange = tempOver
+      by = cy+sin a1 * (r0+r1)*0.5
-    , hNodeGraph = M.fromList
+  paint <- linearGradient ctx ax ay bx by (rgba 255 255 255 0) (rgba 255 255 255 128)
-      [ ("root", tempRoot)
+  fillPaint ctx paint
-      , ("over", tempOver)
+  fill ctx
-      , ("svg", tempSvg)
+  restore ctx
-      , ("trans", tempTrans)
+
-      , ("rot", tempRot)
+drawHaskelloid :: Haskelloid -> Affection UserData ()
-      ]
+drawHaskelloid (Haskelloid pos _ rot _ div img) = do
-    } : hasks
+  ctx <- nano <$> getAffection
+  liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 255
+  where
+    dim = (fmap (/ fromIntegral div) (V2 100 100))

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 ()
+dVel :: Float
-handleGameEvent e = do
+dVel = 100
-  ad <- get
+
-  wd <- getAffection
+pewVel :: Float
-  sec <- getDelta
+pewVel = 200
-  case e of
+
-    SDL.KeyboardEvent dat ->
+pewTTL :: Double
-      case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
+pewTTL = 10
-        SDL.KeycodeLeft -> do
+
-          ud <- getAffection
+dRot :: Float
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $
+dRot = 150
-            putAffection ud
+
-              { ship = (ship ud)
+loadGame :: Affection UserData () -> Affection UserData () -> Affection UserData ()
-                { sRot = (sRot $ ship ud) + 270 * sec
+loadGame stateChange clean = do
-                }
+  liftIO $ logIO A.Debug "loading game"
-              }
+  ud <- getAffection
-        SDL.KeycodeRight -> do
+  nhs <- newHaskelloids
-          ud <- getAffection
+  kid <- partSubscribe (subKeyboard $ subsystems ud) (handleGameKeys stateChange clean)
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
+  putAffection ud
-            putAffection ud
+    { stateUUIDs = UUIDClean [] [kid]
-              { ship = (ship ud)
+    , haskelloids = nhs
-                { sRot = (sRot $ ship ud) - 270 * sec
+    , ship = (ship ud)
-                }
+      { sPos = V2 400 300
-              }
+      , sVel = V2 0 0
-        SDL.KeycodeUp ->
+      , sRot = 0
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
+      }
-            ud <- getAffection
+    , shots = []
-            let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud)
+    , state = InGame
-                vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud)
+    , wonlost = Nothing
-            putAffection ud
+    }
-              { ship = (ship ud)
+
-                { sVel = (vx, vy)
+handleGameKeys :: Affection UserData () -> Affection UserData () -> KeyboardMessage -> Affection UserData ()
-                }
+handleGameKeys stateChange clean kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
-              }
+  case SDL.keysymKeycode (msgKbdKeysym kbdev) of
-            -- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
+    SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
-        SDL.KeycodeSpace ->
+      liftIO $ logIO A.Debug "PEW!"
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
+      shoot
-            ud <- getAffection
+    SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
-            liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $ Operation "gegl:pixelize"
+      ud <- getAffection
-              [ Property "size-x" $ PropertyInt 8
+      unless (isNothing $ wonlost ud) $ do
-              , Property "size-y" $ PropertyInt 8
+        liftIO $ logIO A.Debug "Reloading"
-              ]
+        clean
-            -- ad <- get
+    SDL.KeycodeEscape -> do
-            let posX = (fst $ sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud)
+      liftIO $ logIO A.Debug "Leave to Menu"
-                posY = (snd $ sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
+      stateChange
-            tempRoot <- liftIO $ gegl_node_new
+    SDL.KeycodeW -> accelShip dVel
-            tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle"
+    SDL.KeycodeS -> accelShip (-dVel)
-              [ Property "x" $ PropertyDouble $ posX
+    SDL.KeycodeA -> rotateShip dRot
-              , Property "y" $ PropertyDouble $ posY
+    SDL.KeycodeD -> rotateShip (-dRot)
-              , 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
-        }
     _ -> 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

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
+    }

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
+main = do
-  { initComponents = All
+  logIO A.Debug "Starting"
-  , windowTitle    = "Haskelloids"
+  withAffection AffectionConfig
-  , windowConfig   = defaultWindow
+    { initComponents = All
-  , preLoop        = return ()
+    , windowTitle    = "Haskelloids"
-  , drawLoop       = draw
+    , windowConfig   = SDL.defaultWindow
-  , updateLoop     = update
+      { SDL.windowOpenGL = Just SDL.defaultOpenGL
-  , loadState      = load
+        { SDL.glProfile        = SDL.Core SDL.Normal 3 2
-  , cleanUp        = clean
+        , SDL.glColorPrecision = V4 8 8 8 1
-  , canvasSize     = Nothing
+        }
-  , initScreenMode = SDL.Windowed
+      }
-  , eventLoop      = handleGameEvent
+    , 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"
+  ud <- getAffection
-  ad <- get
+  smUpdate (state ud) sec
-  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
-    }
 
-wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
+handle :: [SDL.EventPayload] -> Affection UserData ()
-wrapAround (nx, ny) width = (nnx, nny)
+handle e = do
-  where
+  (Subsystems w k) <- subsystems <$> getAffection
-    nnx =
+  _ <- consumeSDLEvents w =<< consumeSDLEvents k e
-      if nx > 800
+  return ()
-      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
 
 draw :: Affection UserData ()
 draw = do
   ud <- getAffection
-  liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
+  -- window <- drawWindow <$> get
-  -- mintr <- liftIO $ gegl_rectangle_intersect
+  -- pf <- liftIO $ SDL.getWindowPixelFormat window
-  --   (GeglRectangle 0 0 800 600)
+  -- liftIO $ logIO A.Debug $ "Window pixel format: " ++ show pf
-  --   (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50)
+  liftIO $ beginFrame (nano ud) 800 600 1
-  -- maybe (return ()) (\intr ->
+  smDraw (state ud)
-  --   present
+  liftIO $ endFrame (nano ud)
-  --     (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 ()

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

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 [] []
+      }

src/Types.hs

@@ -1,58 +1,115 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
 module Types where
 
 import Affection
 import qualified SDL
-import GEGL
+import NanoVG hiding (V2(..))
-import BABL
+import Linear
-import qualified Data.Map as M
+
+import Control.Concurrent.STM
+import Control.Monad.IO.Class (liftIO)
 
 data UserData = UserData
-  { nodeGraph :: M.Map NodeKey GeglNode
+  { ship :: Ship
-  , ship :: Ship
-  , buffer :: GeglBuffer
   , 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)
+  { sPos :: V2 Float
-  , sVel :: (Double, Double)
+  , sVel :: V2 Float
-  , sRot :: Double
+  , sRot :: Float
-  , sFlange :: GeglNode
+  , sImg :: Image
   }
 
-data Haskelloid = Haskelloid
+data Pew = Pew
-  { hPos :: (Double, Double)
+  { pPos :: V2 Float
-  , hVel :: (Double, Double)
+  , pVel :: V2 Float
-  , hRot :: Double
+  , pTTL :: Double
-  , hPitch :: Double
-  , hDiv :: Int
-  , hFlange :: GeglNode
-  , hNodeGraph :: M.Map String GeglNode
   } deriving (Eq)
 
-data NodeKey
+data Haskelloid = Haskelloid
-  = KeyRoot
+  { hPos :: V2 Float
-  | KeyTranslate
+  , hVel :: V2 Float
-  | KeyRotate
+  , hRot :: Float
-  | KeyShip
+  , hPitch :: Float
-  | KeyPNop
+  , hDiv :: Int
-  | KeyHNop
+  , hImg :: Image
-  | KeyCrop
+  } deriving (Eq)
-  | KeyShipOver
-  | KeySink
-  | KeyWon
-  | KeyLost
-  | KeyPixelize
-  | KeyFGOver
-  | KeyFGNop
-  deriving (Ord, 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