haskelloids/src/Main.hs

{-# 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 = 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
  -- 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)
    False

clean :: UserData -> IO ()
clean ud = return ()

toR :: Double -> Double
toR deg = deg * pi / 180