haskelloids/src/Main.hs

{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
module Main where

import Affection
import qualified SDL
import GEGL
import BABL

import qualified Data.Map as M

import Control.Monad (when)

import System.Random (randomRIO)

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
    ]
  pnop <- gegl_node_new_child root $ Operation "gegl:nop" []
  hnop <- 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
  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 [ship, rotate, translate]
  gegl_node_link_many [pover, hover, sover, crop, 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"
  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)
    ]
  hs <- mapM (\_ -> do
    px <- liftIO $ randomRIO (0, 800)
    py <- liftIO $ randomRIO (0, 600)
    vx <- liftIO $ randomRIO (0, 5)
    vy <- liftIO $ randomRIO (0, 5)
    div <- liftIO $ randomRIO (1, 2)
    tempRoot <- liftIO $ gegl_node_new
    tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
    tempText <- liftIO $ gegl_node_new_child tempRoot $ textOperation
      [ Property "string" $ PropertyString "λ"
      , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
      , Property "size"  $ PropertyDouble 40
      ]
    liftIO $ gegl_node_connect_to tempText "output" tempOver "aux"
    return Haskelloid
      { hPos = (px, py)
      , hVel = (vx, vy)
      , hDiv = div
      , hFlange = tempOver
      , hNodeGraph = M.fromList
        [ ("root", tempRoot)
        , ("over", tempOver)
        , ("text", tempText)
        ]
      }
    ) [1..5]
  liftIO $ gegl_node_link_many $ map hFlange hs
  liftIO $ gegl_node_link (last $ map hFlange hs) hnop
  return $ UserData
    { nodeGraph = myMap
    , ship      = Ship
      { sPos = (400, 300)
      , sVel = (0, 0)
      , sRot = 0
      , sFlange = rotate
      }
    , buffer = buffer
    , shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer
    , haskelloids = hs
    }

data UserData = UserData
  { nodeGraph :: M.Map NodeKey GeglNode
  , ship :: Ship
  , buffer :: GeglBuffer
  , haskelloids :: [Haskelloid]
  , shots :: ParticleSystem
  -- , debris :: ParticleSystem
  }

data Ship = Ship
  { sPos :: (Double, Double)
  , sVel :: (Double, Double)
  , sRot :: Double
  , sFlange :: GeglNode
  }

data Haskelloid = Haskelloid
  { hPos :: (Double, Double)
  , hVel :: (Double, Double)
  , hDiv :: Int
  , hFlange :: GeglNode
  , hNodeGraph :: M.Map String GeglNode
  }

data NodeKey
  = KeyRoot
  | KeyTranslate
  | KeyRotate
  | KeyShip
  | KeyPNop
  | KeyHNop
  | KeyCrop
  | KeyShipOver
  | 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) + 180 * sec
                   }
                 }
           SDL.KeycodeRight -> do
             ud <- getAffection
             when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
               putAffection ud
                 { ship = (ship ud)
                   { sRot = (sRot $ ship ud) - 180 * 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)
               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 ((*) 2 $ sRot $ ship ud)
           SDL.KeycodeSpace ->
             when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
               ud <- getAffection
               ad <- get
               tempRoot <- liftIO $ gegl_node_new
               tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle"
                 [ Property "x" $ (PropertyDouble $ (fst $ sPos $ ship ud) + 23)
                 , Property "y" $ (PropertyDouble $ (snd $ sPos $ ship ud) + 23)
                 , 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 = 10
                   , particleCreation = elapsedTime ad
                   , particlePosition =
                     ( (fst $ sPos $ ship ud) + 23
                     , (snd $ sPos $ ship ud) + 23
                     )
                   , particleRotation = Rad 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 = Rad 0
                   , particleRootNode = tempRoot
                   , particleNodeGraph = M.fromList
                     [ ("root", tempRoot)
                     , ("over", tempOver)
                     , ("rect", tempRect)
                     ]
                   , particleStackCont = tempOver
                   , particleDrawFlange = tempOver
                   }
               putAffection $ ud
                 { shots = ips
                 }
                   -- XXX: Continue here
           _ -> 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
      (nnx, nny) = wrapAround (nx, ny) 50
  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
    ]
  ups <- updateParticleSystem (shots ud2) sec shotsUpd shotsDraw
  nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
  putAffection ud2
    { ship = (ship ud2)
      { sPos = (nnx, nny)
      }
    , shots = ups
    , haskelloids = nhs
    }

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

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

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) 2
  liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
    [ Property "x" $ (PropertyDouble $ nnx - 2)
    , Property "y" $ (PropertyDouble $ nny - 2)
    ]
  return part
    { particlePosition = (nnx, nny)
    }

shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
shotsDraw buf node Particle{..} = do
  -- present
  --   (GeglRectangle (floor $ fst particlePosition - 2) (floor $ snd particlePosition - 2) 4 4)
  --   buf
  --   False
  return ()

updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
updateHaskelloid sec h@Haskelloid{..} = return h