vulkan-tutorial/examples/example03.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}

import Affection
import qualified SDL
import qualified GEGL as G
import qualified BABL as B

import qualified Data.Map.Strict as M

import Control.Monad (when)

import Foreign.C.Types

import System.Random (randomRIO)

import Debug.Trace

main :: IO ()
main = do
  conf <- return $ AffectionConfig
    { initComponents = All
    , windowTitle    = "Affection: example00"
    , windowConfig   = SDL.defaultWindow
    , preLoop        = drawInit
    , eventLoop      = handle
    , updateLoop     = update
    , drawLoop       = draw
    , loadState      = load
    , cleanUp        = clean
    , canvasSize     = Nothing
    }
  withAffection conf

data UserData = UserData
  { nodeGraph   :: M.Map String G.GeglNode
  , foreground  :: G.GeglBuffer
  , partsys     :: ParticleSystem
  }

load :: IO UserData
load = do
  traceM "loading"
  root <- G.gegl_node_new
  traceM "new root node"
  rect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" $
    props $ do
      prop "x" (0 :: Double)
      prop "y" (0 :: Double)
      prop "width" (800 :: Double)
      prop "height" (600 :: Double)
      prop "color" $ G.RGB 0 0 0
  traceM "rect"
  traceM "checkerboard"
  over <- G.gegl_node_new_child root G.defaultOverOperation
  traceM "over"
  buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
    B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
  sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer"
    [G.Property "buffer" $ G.PropertyBuffer buffer
    ]
  traceM "buffer-sink"
  nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
  traceM "nop"
  crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop"
    [ G.Property "width" $ G.PropertyDouble 800
    , G.Property "height" $ G.PropertyDouble 600
    ]
  traceM "crop"
  G.gegl_node_link_many [rect, over, crop, sink]
  G.gegl_node_connect_to nop "output" over "aux"
  traceM "connections made"
  myMap <- return $ M.fromList
    [ ("root"        , root)
    , ("over"        , over)
    , ("sink"        , sink)
    , ("nop"         , nop)
    , ("crop"        , crop)
    ]
  traceM "loading complete"
  return $ UserData
    { nodeGraph = myMap
    , foreground = buffer
    , partsys = ParticleSystem (ParticleStorage Nothing []) nop buffer
    }

drawInit :: Affection UserData ()
drawInit = return ()
-- drawInit = do
--   UserData{..} <- getAffection
--   present (GeglRectangle 0 0 800 600) foreground True

draw :: Affection UserData ()
draw = do
  traceM "drawing"
  UserData{..} <- getAffection
  drawParticleSystem partsys partDraw
  process $ nodeGraph M.! "sink"
  present
    (G.GeglRectangle 0 0 800 600)
    foreground
    True

update :: Double -> Affection UserData ()
update dt = do
  traceM "updating"
  ad <- get
  ud <- getAffection
  delta <- getDelta
  traceM $ (show $ 1 / delta) ++ " FPS"
  ud2 <- getAffection
  !nps <- updateParticleSystem (partsys ud2) delta partUpd
  putAffection $ ud2 { partsys = nps }

handle (SDL.MouseMotionEvent dat) =
  when (SDL.ButtonLeft `elem` SDL.mouseMotionEventState dat)
  $ do
    ad <- get
    ud <- getAffection
    let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat
    vx <- liftIO $ randomRIO (-20, 20)
    vy <- liftIO $ randomRIO (-20, 20)
    life <- liftIO $ randomRIO (1, 5)
    r <- liftIO $ randomRIO (0,1)
    g <- liftIO $ randomRIO (0,1)
    b <- liftIO $ randomRIO (0,1)
    tempRoot <- liftIO $ G.gegl_node_new
    tempOver <- liftIO $ G.gegl_node_new_child tempRoot
      G.defaultOverOperation
    tempRect <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation
      "gegl:rectangle"
      [ G.Property "x"      $ G.PropertyDouble $ fromIntegral x - 10
      , G.Property "y"      $ G.PropertyDouble $ fromIntegral y - 10
      , G.Property "width"  $ G.PropertyDouble 20
      , G.Property "height" $ G.PropertyDouble 20
      , G.Property "color"  $ G.PropertyColor  $ (G.RGBA r g b 0.5)
      ]
    liftIO $ G.gegl_node_connect_to tempRect "output" tempOver "aux"
    -- traceM $ "position is: " ++ show x ++ " " ++ show y
    -- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy
    ips <- insertParticle (partsys ud) $
      Particle
        { particleTimeToLive = life
        , particleCreation   = elapsedTime ad
        , particlePosition   = (fromIntegral x, fromIntegral y)
        , particleRotation   = Rad 0
        , particleVelocity   = (vx, vy)
        , particlePitchRate  = Rad 0
        , particleRootNode   = tempRoot
        , particleNodeGraph  = M.fromList
          [ ("root", tempRoot)
          , ("over", tempOver)
          , ("rect", tempRect)
          ]
        , particleStackCont  = tempOver
        , particleDrawFlange = tempOver
        }
    putAffection $ ud
      { partsys = ips
      }
    -- when (not $ null $ psParts $ partsys ud) $
    --   liftIO $ G.gegl_node_link
    --     tempOver
    --     (particleStackCont $ head $ psParts $ partsys ud)

handle (SDL.WindowClosedEvent _) = do
  traceM "seeya!"
  quit

handle _ =
  return ()

clean :: UserData -> IO ()
clean ud = do
  G.gegl_node_drop (nodeGraph ud M.! "root")

partUpd :: Double -> Particle -> Affection UserData Particle
partUpd sec p = do
  let !newX = (fst $ particlePosition p) + sec * (fromIntegral $ fst $ particleVelocity p)
      !newY = (snd $ particlePosition p) + sec * (fromIntegral $ snd $ particleVelocity p)
  liftIO $ G.gegl_node_set (particleNodeGraph p M.! "rect") $ G.Operation "gegl:rectangle"
    [ G.Property "x" $ G.PropertyDouble $ newX - 10
    , G.Property "y" $ G.PropertyDouble $ newY - 10
    ]
  let !np = p {particlePosition = (newX, newY)}
  return np

partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData ()
partDraw _ _ _ = return ()
-- partDraw buf node Particle{..} = do
--   present
--     (G.GeglRectangle (floor $ fst particlePosition - 10) (floor $ snd particlePosition - 10) 20 20)
--     buf
--     False
--   -- ud <- getAffection
--   -- drawRect'
--   --   particleDrawFlange
--   --   (G.RGBA 1 0 0 0.5)
--   --   (Fill)
--   --   (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20)
--   --   buf