affection/examples/example05.1.hs

{-# LANGUAGE RecordWildCards, BangPatterns #-}

import Affection
import qualified SDL
import qualified GEGL as G
import qualified BABL as B
import qualified Data.Map.Strict as M
import qualified Data.Matrix as X
import Data.List as L
import Data.Maybe (fromJust, catMaybes)
-- import Data.Vector as V
import System.Random (randomRIO)
import Control.Monad as CM (when, unless, foldM)
import qualified Control.Monad.Parallel as MP
import Control.Parallel.Strategies
import Foreign.C.Types
import Foreign.Marshal.Utils

import Debug.Trace

dimension :: Int
dimension = 60

resolution :: Int
resolution = 600

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

data UserData = UserData
  { nodeGraph    :: M.Map String G.GeglNode
  , foreground   :: G.GeglBuffer
  , keysDown     :: [SDL.Keycode]
  , liveIndices  :: [(Int, Int)]
  , indices      :: [(Int, Int)]
  -- , cells        :: [((Int, Int), Actor String)]
  -- , updateActors :: [Actor String]
  }

load :: IO UserData
load = do
  traceM "loading"
  root <- G.gegl_node_new
  traceM "new root node"
  let bgProps = props $ do
        prop "x" (0 :: Double)
        prop "y" (0 :: Double)
        prop "width" (fromIntegral resolution :: Double)
        prop "height" (fromIntegral resolution :: Double)
        prop "color" $ G.RGB 0 0 0
  bg <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" bgProps
  traceM "background"
  over <- G.gegl_node_new_child root G.defaultOverOperation
  traceM "over"
  buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 resolution resolution) =<<
    B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
  sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $
    props $
    prop "buffer" buffer
  traceM "buffer-sink"
  crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $
    props $ do
      prop "width" (fromIntegral resolution :: Double)
      prop "height" (fromIntegral resolution :: Double)
  G.gegl_node_link_many [bg, over, crop, sink]
  nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
  _ <- G.gegl_node_connect_to nop "output" over "aux"
  traceM "connections made"
  myMap <- return $ M.fromList
    [ ("root"        , root)
    , ("over"        , over)
    , ("background"  , bg)
    , ("sink"        , sink)
    , ("nop"         , nop)
    , ("crop"        , crop)
    ]
  traceM "building matrix"
  let !emptyMatrix = X.matrix dimension dimension (const False)
      !indices = [(row, col) | row <- [1..dimension], col <- [1..dimension]]
  -- traceM "building cells"
  -- cells <- foldM (\acc index@(row, col) -> do
  --     tempOver <- G.gegl_node_new_child root $ G.defaultOverOperation
  --     let !scale = (fromIntegral resolution) / (fromIntegral dimension)
  --         tempProps =
  --           props $ do
  --             prop "x" (((fromIntegral col) - 1) * scale :: Double)
  --             prop "y" (((fromIntegral row) - 1) * scale :: Double)
  --             prop "width" (scale :: Double)
  --             prop "height" (scale :: Double)
  --             prop "color" $ G.RGB 1 1 1
  --     tempRect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle"
  --       tempProps
  --     G.gegl_node_connect_to tempRect "output" tempOver "aux"
  --     let tempMap = M.fromList
  --           [ ("over", tempOver)
  --           , ("rect", tempRect)
  --           ]
  --         tempAProps =
  --           map (\p -> ActorProperty
  --             { apName    = G.propertyName p
  --             , apValue   = G.propertyValue p
  --             , apMapping = Just "rect"
  --             }) tempProps
  --     traceIO $ show index
  --     return $ (index, Actor
  --       { actorProperties = tempAProps
  --       , actorNodes      = tempMap
  --       }) : acc
  --   )
  --   ([] :: [((Int, Int), Actor String)])
  --   indices
  --   :: IO [((Int, Int), Actor String)]
  traceM "loading complete"
  return UserData
    { nodeGraph    = myMap
    , foreground   = buffer
    , keysDown     = []
    , indices      = indices
    , liveIndices  = []
    -- , cells        = cells
    -- , updateActors = []
    }

loadList :: Affection UserData ()
loadList = do
  ud@UserData{..} <- getAffection
  init <- foldM (\acc coord -> do
    trig <- liftIO $ randomRIO (True, False)
    if trig then return (coord : acc) else return acc
    ) [] indices
  putAffection ud
    { liveIndices = init
    }

getNeighbors :: (Int, Int) -> Affection UserData [(Int, Int)]
getNeighbors (row, col) =
  do
    UserData{..} <- getAffection
    mapM (\(pr, pc) ->
      return (overflow(row + pr), overflow(col + pc))
      ) lcs
  where
    overflow x
      | x < 1         = dimension
      | x > dimension = 1
      | otherwise     = x

lcs :: [(Int, Int)]
lcs =
  [ (-1, -1)
  , (-1, 0)
  , (-1, 1)
  , (0, -1)
  -- , (0, 0)
  , (0, 1)
  , (1, -1)
  , (1, 0)
  , (1, 1)
  ]

draw :: Affection UserData ()
draw = do
  traceM "drawing"
  ad <- get
  ud@UserData{..} <- getAffection
  SDL.rendererDrawColor (windowRenderer ad) SDL.$= (SDL.V4 0 0 0 255)
  SDL.clear (windowRenderer ad)
  SDL.rendererDrawColor (windowRenderer ad) SDL.$= (SDL.V4 255 255 255 255)
  MP.mapM_ (\(row, col) ->
    let scale = floor (fromIntegral resolution / fromIntegral dimension)
    in
      SDL.fillRect
        (windowRenderer ad)
        (Just ( SDL.Rectangle
          (SDL.P (SDL.V2
            (CInt $ fromIntegral $ (col - 1) * scale)
            (CInt $ fromIntegral $ (row - 1) * scale)
            ))
          (SDL.V2
            (CInt $ fromIntegral $ scale)
            (CInt $ fromIntegral $ scale)
            )
          ))
    ) liveIndices
  -- render Nothing Nothing
  -- let livingActors = catMaybes $ parMap rpar (\i -> lookup i cells) liveIndices
  -- unless (null livingActors) $ do
  --   liftIO $ G.gegl_node_link_many $
  --     parMap rpar (\a -> (actorNodes a) M.! "over") livingActors
  --   _ <- liftIO $ G.gegl_node_link ((actorNodes $ last livingActors) M.! "over")
  --     (nodeGraph M.! "nop")
  --   return ()
  -- process (nodeGraph M.! "sink")
  -- present (G.GeglRectangle 0 0 resolution resolution) foreground True
  -- render
  --   Nothing
  --   Nothing
  -- _ <- liftIO $ MP.mapM
  --   (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input"
  --   ) livingActors
  -- putAffection ud
  --   { updateActors = []
  --   }

update :: Double -> Affection UserData ()
update dt = do
  traceM "updating"

  ud <- getAffection
  elapsed <- getElapsedTime

  traceM $ show (1 / dt) ++ " FPS"
  traceM $ show $ keysDown ud

  relevant <- getRelevant (liveIndices ud)

  new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do
    neighs <-
      foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$>
        getNeighbors coord
    let ret
          | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
              Just coord
          | neighs == 3 =
              Just coord
          | otherwise =
              Nothing
    return ret
    ) relevant
    
  ud2 <- getAffection
  putAffection ud2
    { liveIndices = new
    }

  mapM_ (\code ->
    when (code == SDL.KeycodeR) loadList
    ) (keysDown ud)

getRelevant :: [(Int, Int)] -> Affection UserData [(Int, Int)]
getRelevant ls =
    getRelevant' ls
  where
    getRelevant' xs = foldM (\acc x -> do
      neighs <- getNeighbors x
      let slice = (x : neighs)
          rels = foldl (\a y ->
            if y `elem` acc then a else y : a
            ) [] slice
      return (acc ++ rels)
      ) [] xs

handle :: SDL.EventPayload -> Affection UserData ()
handle (SDL.KeyboardEvent dat) =
  when (not (SDL.keyboardEventRepeat dat)) $ do
    ud <- getAffection
    if (SDL.keyboardEventKeyMotion dat == SDL.Pressed)
    then
      putAffection ud
        { keysDown =
            SDL.keysymKeycode (SDL.keyboardEventKeysym dat) : keysDown ud
        }
    else
      putAffection ud
        { keysDown =
            delete (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) (keysDown ud)
        }

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

handle _ =
  return ()

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