working spaceship

haskelloids.cabal

@@ -61,6 +61,9 @@ executable haskelloids
   build-depends:       base >=4.9 && <4.10
                      , affection
                      , gegl
+                     , babl
+                     , sdl2
+                     , containers
   
   -- Directories containing source files.
   hs-source-dirs:      src

src/Main.hs

@@ -1,4 +1,192 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Main where
 
+import Affection
+import qualified SDL
+import GEGL
+import BABL
+
+import qualified Data.Map as M
+
+import Control.Monad (when)
+
+import Debug.Trace
+
 main :: IO ()
-main = putStrLn "Hello, Haskell!"
+main = withAffection $ AffectionConfig
+  { initComponents = All
+  , windowTitle    = "Haskelloids"
+  , windowConfig   = defaultWindow
+  , preLoop        = return ()
+  , drawLoop       = draw
+  , updateLoop     = update
+  , loadState      = load
+  , cleanUp        = clean
+  }
+
+load :: SDL.Surface -> IO UserData
+load _ = do
+  traceM "loading"
+  root <- gegl_node_new
+  traceM "root node"
+  ship <- gegl_node_new_child root $ Operation "gegl:svg-load"
+    [ Property "path" $ PropertyString "assets/ship.svg"
+    , Property "width" $ PropertyInt 50
+    , Property "height" $ PropertyInt 50
+    ]
+  nop <- gegl_node_new_child root $ Operation "gegl:nop" []
+  over <- gegl_node_new_child root $ defaultOverOperation
+  translate <- gegl_node_new_child root $ Operation "gegl:translate"
+    [ Property "origin-x" $ PropertyDouble 25
+    , Property "origin-y" $ PropertyDouble 25
+    , Property "x"        $ PropertyDouble 400
+    , Property "y"        $ PropertyDouble 300
+    , 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
+    ]
+  -- gegl_node_link_many [over, crop, sink]
+  -- gegl_node_link_many [ship, translate, rotate]
+  gegl_node_link_many [ship, rotate, translate, crop, sink]
+  gegl_node_connect_to rotate "output" over "aux"
+  traceM "nodes complete"
+  myMap <- return $ M.fromList
+    [ (KeyRoot, root)
+    , (KeyTranslate, translate)
+    , (KeyRotate, rotate)
+    , (KeyShip, ship)
+    , (KeyNop, nop)
+    , (KeyCrop, crop)
+    , (KeyOver, over)
+    , (KeySink, sink)
+    ]
+  return $ UserData
+    { nodeGraph = myMap
+    , ship      = Ship
+      { sPos = (400, 300)
+      , sVel = (0, 0)
+      , sRot = 0
+      , sFlange = rotate
+      }
+    , buffer = buffer
+    }
+
+data UserData = UserData
+  { nodeGraph :: M.Map NodeKey GeglNode
+  , ship :: Ship
+  , buffer :: GeglBuffer
+  }
+
+data Ship = Ship
+  { sPos :: (Double, Double)
+  , sVel :: (Double, Double)
+  , sRot :: Double
+  , sFlange :: GeglNode
+  }
+
+data NodeKey
+  = KeyRoot
+  | KeyTranslate
+  | KeyRotate
+  | KeyShip
+  | KeyNop
+  | KeyCrop
+  | KeyOver
+  | KeySink
+  deriving (Ord, Eq)
+
+update :: Double -> Affection UserData ()
+update sec = do
+  -- traceM $ (show $ 1 / sec) ++ " FPS"
+  ad <- get
+  evs <- SDL.pollEvents
+  mapM_ (\e ->
+    case SDL.eventPayload e of
+      SDL.KeyboardEvent dat ->
+        case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
+           SDL.KeycodeLeft -> do
+             ud <- getAffection
+             when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
+               putAffection ud
+                 { ship = (ship ud)
+                   { sRot = (sRot $ ship ud) + 90 * sec
+                   }
+                 }
+           SDL.KeycodeRight -> do
+             ud <- getAffection
+             when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
+               putAffection ud
+                 { ship = (ship ud)
+                   { sRot = (sRot $ ship ud) - 90 * sec
+                   }
+                 }
+           SDL.KeycodeUp ->
+             when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
+               ud <- getAffection
+               let vx = -10 * (sin (toR $ 2 * (sRot $ ship ud))) + fst (sVel $ ship ud)
+                   vy = -10 * (cos (toR $ 2 * (sRot $ ship ud))) + snd (sVel $ ship ud)
+               putAffection ud
+                 { ship = (ship ud)
+                   { sVel = (vx, vy)
+                   }
+                 }
+               traceM $ show (vx, vy) ++ " " ++ show ((*) 2 $ sRot $ ship ud)
+           _ -> return ()
+      SDL.WindowClosedEvent _ -> do
+        traceM "seeya!"
+        put ad
+          { quitEvent = True
+          }
+      _ -> return ()
+    ) evs
+  ud2 <- getAffection
+  let nx = fst (sPos $ ship ud2) + (fst (sVel $ ship ud2)) * sec
+      ny = snd (sPos $ ship ud2) + (snd (sVel $ ship ud2)) * sec
+      nnx =
+        if nx > 800
+        then nx - 850
+        else if nx < -50 then nx + 850 else nx
+      nny =
+        if ny > 600
+        then ny - 650
+        else if ny < -50 then ny + 650 else ny
+  liftIO $ gegl_node_set (nodeGraph ud2 M.! KeyTranslate) $ Operation "gegl:translate"
+    [ Property "x" $ PropertyDouble $ nnx
+    , Property "y" $ PropertyDouble $ nny
+    ]
+  liftIO $ gegl_node_set (nodeGraph ud2 M.! KeyRotate) $ Operation "gegl:rotate"
+    [ Property "degrees" $ PropertyDouble $ sRot $ ship ud2
+    ]
+  putAffection ud2
+    { ship = (ship ud2)
+      { sPos = (nnx, nny)
+      }
+    }
+
+draw :: Affection UserData ()
+draw = do
+  traceM "drawing"
+  ud <- getAffection
+  liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
+  present
+    (GeglRectangle 0 0 800 600)
+    (buffer ud)
+    False
+
+clean :: UserData -> IO ()
+clean ud = return ()
+
+toR :: Double -> Double
+toR deg = deg * pi / 180