pituicat/examples/example05.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.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.Matrix as X
import Data.List as L
import Data.Foldable (foldrM, foldlM)
import Data.Maybe (fromJust, catMaybes)
-- import Data.Vector as V
import System.Random (randomRIO)
import Control.Monad as CM (when, unless)
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  :: HS.HashSet (Int, Int)
  , indices      :: [(Int, Int)]
  , cells        :: HM.HashMap (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 <- foldrM (\index@(row, col) acc -> 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 $ HM.insert index Actor
        { actorProperties = tempAProps
        , actorNodes      = tempMap
        }
        acc
    )
    HM.empty
    indices
  traceM "loading complete"
  return UserData
    { nodeGraph    = myMap
    , foreground   = buffer
    , keysDown     = []
    , indices      = indices
    , liveIndices  = HS.empty
    , cells        = cells
    , updateActors = []
    }

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

getNeighbors :: (Int, Int) -> [(Int, Int)]
getNeighbors (row, col) =
  map (\(pr, pc) -> (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"
  ud@UserData{..} <- getAffection
  let livingActors = parMap rpar (cells HM.!) $ HS.toList 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)

  -- let new = HS.fromList $ catMaybes $ parMap rpar (\coord@(row, col) ->
  --       let neighs =
  --             foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 $
  --               getNeighbors coord
  --           ret
  --             | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
  --                 Just coord
  --             | neighs == 3 =
  --                 Just coord
  --             | otherwise =
  --                 Nothing
  --       in ret
  --       ) (HS.toList relevant)

  new <- foldrM (\coord@(row, col) acc -> do
  -- new <- foldlM (\acc coord@(row, col) -> do
    let !neighs = sum $
          map (\n -> if n `elem` liveIndices ud then 1 else 0)$
            getNeighbors coord
        ret
          | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
              HS.insert coord acc
          | neighs == 3 =
              HS.insert coord acc
          | otherwise =
              acc
    return ret
    ) HS.empty relevant

  -- 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 :: HS.HashSet (Int, Int) -> Affection UserData (HS.HashSet (Int, Int))
getRelevant ls = do
    getRelevant' ls
  where
    getRelevant' xs = foldlM (\acc x ->
      let neighs = getNeighbors x
          slice = (x : neighs)
          rels = foldr (\y a ->
          -- rels = foldl (\a y ->
            if y `elem` acc then a else HS.insert y a
            ) HS.empty slice
      in return (acc `HS.union` rels)
      ) HS.empty 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 ()

parHSMap f = (`using` parTraversable rpar) . HM.map f

-- catHSMaybe =
--   foldr (\x acc ->
--     case x of
--       Just a -> a `HS.insert` acc
--       Nothing -> acc
--     ) HS.empty