tracer/src/MainGame/WorldMap.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}
module MainGame.WorldMap where

import Affection as A

import Algebra.Graph as AG hiding (Context(..))

import qualified SDL
import NanoVG hiding (V2(..))

import Control.Monad (when, void)
import Control.Monad.State.Strict (evalStateT)
import Control.Monad.Trans.Resource (ResIO, runResourceT)
import Control.Concurrent.MVar
import Control.Concurrent (forkIO)
import Control.Parallel.Strategies hiding (dot)

import Data.Map.Strict as Map
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Matrix as M
import Data.Ecstasy as E
import Data.Maybe
import Data.List as L
import qualified Data.Vector as V
import Data.String

import System.Random (randomRIO)

import Linear hiding (E)

import Foreign.C.Types (CFloat(..))

-- internal imports

import Interior
import Util
import Types
import Floorplan
import MindMap
import NPC
import Animation
import Collision

loadMap :: UserData -> Affection ()
loadMap ud = do
  ad <- get
  let (Subsystems _ _ k j t) = subsystems ud
  uu0 <- partSubscribe k (emitKbdActionMessage ud)
  uu1 <- partSubscribe j (emitJoyActionMessage ud)
  uu2 <- partSubscribe t (movePlayer2 ud)
  uu3 <- partSubscribe t (playerInteract2 ud)
  uu4 <- partSubscribe t (changeMaps2 ud)
  void $ liftIO $ swapMVar (stateProgress ud) (0, "Ohai!")
  _ <- liftIO $ forkIO $ loadMapFork ud ad (stateMVar ud) (stateProgress ud)
  void $ liftIO $ swapMVar (stateData ud) None
  void $ liftIO $ swapMVar (uuid ud) [ uu0, uu1, uu2, uu3, uu4 ]
  void $ liftIO $ swapMVar (state ud) (Main WorldMap)

changeMaps :: UserData -> KeyboardMessage -> Affection ()
changeMaps ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
  | SDL.keysymKeycode sym == SDL.KeycodeF1 = do
  curState <- liftIO $ readMVar (state ud)
  case curState of
    Main MindMap ->
      void $ liftIO $ swapMVar (state ud) (Main WorldMap)
    Main WorldMap ->
      void $ liftIO $ swapMVar (state ud) (Main MindMap)
    _ -> return ()
  | otherwise = return ()
changeMaps _ _ = return ()

changeMaps2 :: UserData -> ActionMessage -> Affection ()
changeMaps2 ud (ActionMessage ActSwitchMap _) = do
  curState <- liftIO $ readMVar (state ud)
  case curState of
    Main MindMap ->
      void $ liftIO $ swapMVar (state ud) (Main WorldMap)
    Main WorldMap ->
      void $ liftIO $ swapMVar (state ud) (Main MindMap)
    _ -> return ()
changeMaps2 _ _ = return ()

loadMapFork
  :: UserData
  -> AffectionData
  -> MVar (SystemState Entity (AffectionState AffectionData ResIO), StateData)
  -> MVar (Float, T.Text)
  -> IO ()
loadMapFork ud ad future progress = do
  let loadSteps = 23
      increment = 1 / loadSteps
      fc = FloorConfig
        (V2 10 10)
        [(V2 5 5), (V2 5 20)]
        (40, 40)
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Building floor"
    )))
  (mat, gr) <- buildHallFloorIO fc progress increment -- 11 increments inside
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Converting to images"
    )))
  let !imgmat = convertTileToImg mat
      !doors = Prelude.foldl
        (\acc coord@(r, c) -> if mat M.! coord == Door
          then V2 r c : acc
          else acc
          )
        []
        ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
      !exits = Prelude.foldl
        (\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty
          then ReachPoint RoomExit (V2 r c) NE 0 : acc
          else acc
          )
        []
        ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Placing furniture"
    )))
  (!inter, !rawrps) <- placeInteriorIO mat imgmat exits (V.toList gr)
  let !rps = ReachPoint Elevator (fcElevator fc) SE 0 : rawrps
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Creating WorldState"
    )))
  wState <- liftIO $ readMVar (worldState ud)
  (nws, mmimgmat) <- runResourceT $ evalStateT (runState (yieldSystemT wState $ do
    liftIO $ modifyMVar_ progress (return . (\(p, _) ->
      ( p + increment
      , "Registering copiers into WorldState"
      )))
    let !copiers = Prelude.filter (\a -> pointType a == Copier) rps
    mapM_ (\(ReachPoint _ icoord _ _) -> do
      let reachCoord = fmap ((+ 0.5) . fromIntegral) icoord
      void $ createEntity $ newEntity
        { pos       = Just $ reachCoord - V2 1 0
        , obstacle  = Just $ Boundaries (10/36, 8/36) (28/36, 30/36)
        , anim      = Just $ AnimState (AnimId AnimCopier "open" N) 0 0
        , objAccess = Just [(V2 1 0, NW)]
        , objType   = Just ObjCopier
        , objState  = Just "idle"
        }
      )
      (A.log
        A.Debug
        ("number of copiers: " <> fromString (show $ length copiers))
        copiers
        )
    liftIO $ modifyMVar_ progress (return . (\(p, _) ->
      ( p + increment
      , "Registering computers into WorldState"
      )))
    let !computers = Prelude.filter ((Computer ==) . pointType) rps
    mapM_ (\(ReachPoint _ icoord dir _) -> do
      let reachCoord = fmap ((+ 0.5) . fromIntegral) icoord
          access = case dir of
            N  -> V2 1 (-1)
            NE -> V2 0 (-1)
            NW -> V2 1 0
            x -> error ("computer placement " ++ show x ++ " not defined")
      void $ createEntity $ newEntity
        { pos       = Just $ reachCoord - fmap fromIntegral access
        , anim      = Just $ AnimState (AnimId AnimComputer "off" dir) 0 0
        , rot       = Just dir
        , objAccess = Just [(access, dir)]
        , objType   = Just ObjComputer
        , objState  = Just "off"
        }
      )
      (A.log
        A.Debug
        ("number of computers: " <> fromString (show $ length computers))
        computers
        )
    liftIO $ modifyMVar_ progress (return . (\(p, _) ->
      ( p + increment
      , "Registering toilets into WorldState"
      )))
    let !toilets = Prelude.filter (\a -> pointType a == Toilet) rps
    mapM_ (\(ReachPoint _ icoord dir _) -> do
      let reachCoord = fmap ((+ 0.5) . fromIntegral) icoord
      void $ createEntity $ newEntity
        { pos       = Just $ reachCoord - V2 0 (-1)
        , obstacle  = Just $ Boundaries (0, 0) (1, 1)
        , anim      = Just $ AnimState (AnimId AnimToilet "free" N) 0 0
        , objAccess = Just [(V2 0 (-1), dir)]
        , objType   = Just ObjToilet
        }
      )
      (A.log
        A.Debug
        ("number of toilets: " <> fromString (show  $ length toilets))
        toilets
        )
    liftIO $ modifyMVar_ progress (return . (\(p, _) ->
      ( p + increment
      , "Preparing MindMap graph"
      )))
    (mmintmat, mmgraph) <- liftIO $ buildFloorMap . springField <$>
      buildMindMap (length computers) 2
    liftIO $ modifyMVar_ progress (return . (\(p, _) ->
      ( p + increment
      , "Unfolding and Converting MindMap to images"
      )))
    let !mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat
        !pmmpos = (+ 0.5) . (fromIntegral :: Int -> Double) . floor <$> mmPos
          (fromJust $ find (\a -> mmId a == 0) (vertexList mmgraph))
        !delta = (0, 0) :
          Prelude.filter (/= (0,0)) ((,) <$> [-1 .. 1] <*> [-1 .. 1]) :: [(Int, Int)]
        !mmmpos = Prelude.foldl (\acc (dr, dc) ->
          let (V2 pmr pmc) = floor <$> pmmpos
              seekpos = (pmr + fromIntegral dr, pmc + fromIntegral dc)
          in  if isNothing (mmimgmat M.! seekpos) && mmintmat M.! seekpos == 0
              && isNothing acc
            then Just (pmmpos + (fromIntegral <$> V2 dr dc))
            else acc
          ) Nothing delta
    void $ createEntity $ newEntity
      { pos           = Just (V2 10.5 10.5)
      , mmpos         = mmmpos
      , vel           = Just (V2 0 0)
      , xyvel         = Just (V2 0 0)
      , mmvel         = Just (V2 0 0)
      , player        = Just ()
      , rot           = Just SE
      , clearanceLvl  = Just 0
      , anim          = Just $ AnimState (AnimId AnimIntruder "standing" SE) 0 0
      }
    liftIO $ A.logIO
      A.Debug
      ("number of placed NPCs: " <> fromString (show $ length computers))
    liftIO $ modifyMVar_ progress (return . (\(p, _) ->
      ( p + increment
      , "Registering NPCs into WorldState"
      )))
    mapM_ (\cpr -> do
      fact <- liftIO $ randomRIO (0.5, 1.5)
      stats <- liftIO $ NPCStats
        <$> (randomRIO (0, 1))
        <*> pure 0
        <*> (randomRIO (0, 1))
        <*> (randomRIO (0, 1))
        <*> (randomRIO (0, 1))
        <*> (randomRIO (0, 1))
      police <- liftIO $ randomRIO (0 :: Int, 9 :: Int)
      let room = V.head
            (V.filter
              ((inBounds $ pointCoord cpr) . bounds)
              (V.fromList $
                V.toList (Types.connects (V.head gr)) ++ (V.toList (V.tail gr)))
              )
      void $ createEntity $ newEntity
        { pos            = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr))
        , vel            = Just (V2 0 0)
        , velFact        = Just fact
        , rot            = Just SE
        , npcMoveState   = Just (NPCWalking [[pointCoord cpr]])
        , npcWorkplace   = Just cpr
        , npcActionState = Just ASWork
        , npcStats       = Just stats
        , clearanceLvl   = Just (clearance room)
        , anim           = Just $ AnimState
          (AnimId (if police == 0 then AnimPoliceM else AnimJDoeM) "standing" SE) 0 0
        }
      ) computers
    liftIO $ modifyMVar_ progress (return . (\(p, _) ->
      ( p + increment
      , "Registering doors into WorldState"
      )))
    mapM_ (\door -> do
      let rooms = V.foldl
            (\acc coord ->
              let rs = V.filter ((inBounds coord) . bounds) graph
              in
                if not (V.null rs)
                then (coord, V.head rs) `V.cons` acc
                else acc
              )
            V.empty
            (V.fromList coords)
          graph = V.fromList $
            (V.toList $ Types.connects (V.head gr)) ++ (V.toList $ V.tail gr)
          coords = Prelude.map (door +) deltas
          deltas =
            [ V2 0 1
            , V2 1 0
            , V2 (-1) 0
            , V2 0 (-1)
            ]
          wall = Prelude.filter
            (\ddelta ->
              let V2 r c = door + ddelta
              in
                fromMaybe False (isWall <$> imgmat M.! (r, c)))
            deltas
          orientation
            | head wall == V2 0 1 || head wall == V2 0 (-1) = NW
            | head wall == V2 1 0 || head wall == V2 (-1) 0 = NE
            | otherwise = error ("strange wall: " ++ show wall)
      void $ createEntity $ newEntity
        { pos            = Just (fmap ((+ 0.5) . fromIntegral) door)
        , clearanceLvl   = Just (V.maximum $
          0 `V.cons` V.map clearance (V.map snd rooms))
        , anim           = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 1
        , obstacle       = Just $ case orientation of
          NW -> Boundaries (4/9, 0) (5/9, 1)
          NE -> Boundaries (0, 4/9) (1, 5/9)
          _  -> error "strange orientation for door"
        , ignoreObstacle = Just ()
        , rot            = Just orientation
        , objAccess      = Just $ case orientation of
          NW ->
            [ ((V2 (-1) 0), SE)
            , ((V2   1  0), NW)
            ]
          NE ->
            [ ((V2 0    1), SW)
            , ((V2 0 (-1)), NE)
            ]
          _  -> error "strange orientation for door"
        , objType        = Just ObjDoor
        , objState       = Just "shut"
        }
      ) doors
    liftIO $ modifyMVar_ progress (return . (\(p, _) ->
      ( p + increment
      , "Handing over"
      )))
    return mmimgmat
    )) ad
  let !retMat = M.fromList (nrows inter) (ncols inter) $
        Prelude.map
          (\a -> if a == Just ImgEmpty || a == Just ImgEmptyNoWalk
            then Nothing
            else a)
          (M.toList inter)
  void $ putMVar future (nws, MainData
      { mapMat = mat
      , imgMat = retMat
      , reachPoints = V.fromList rps
      , mmImgMat = mmimgmat
      , roomGraph = gr
      })

movePlayerKbd :: UserData -> KeyboardMessage -> Affection ()
movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
  | SDL.keysymKeycode sym == SDL.KeycodeW = do
    wState <- liftIO $ readMVar (worldState ud)
    (nws, _) <- yieldSystemT wState $
      emap allEnts $ do
        with player
        (V2 vx _) <- query xyvel
        let ry = if (press == SDL.Pressed)
              then 1
              else 0
        return $ unchanged
          { xyvel = Set $ V2 vx ry
          }
    void $ liftIO $ swapMVar (worldState ud) nws
  | SDL.keysymKeycode sym == SDL.KeycodeS = do
    wState <- liftIO $ readMVar (worldState ud)
    (nws, _) <- yieldSystemT wState $
      emap allEnts $ do
        with player
        (V2 vx _) <- query xyvel
        let ry = if (press == SDL.Pressed)
              then -1
              else 0
        return $ unchanged
          { xyvel = Set $ V2 vx ry
          }
    void $ liftIO $ swapMVar (worldState ud) nws
  | SDL.keysymKeycode sym == SDL.KeycodeA = do
    wState <- liftIO $ readMVar (worldState ud)
    (nws, _) <- yieldSystemT wState $
      emap allEnts $ do
        with player
        (V2 _ vy) <- query xyvel
        let rx = if (press == SDL.Pressed)
              then -1
              else 0
        return $ unchanged
          { xyvel = Set $ V2 rx vy
          }
    void $ liftIO $ swapMVar (worldState ud) nws
  | SDL.keysymKeycode sym == SDL.KeycodeD = do
    wState <- liftIO $ readMVar (worldState ud)
    (nws, _) <- yieldSystemT wState $
      emap allEnts $ do
        with player
        (V2 _ vy) <- query xyvel
        let rx = if (press == SDL.Pressed)
              then 1
              else 0
        return $ unchanged
          { xyvel = Set $ V2 rx vy
          }
    void $ liftIO $ swapMVar (worldState ud) nws
  | otherwise = return ()
movePlayerKbd _ _ = return ()

movePlayer2 :: UserData -> ActionMessage -> Affection ()
movePlayer2 ud (ActionMessage mov _) = do
  wState <- liftIO $ readMVar (worldState ud)
  (nws, _) <- yieldSystemT wState $
    emap allEnts $ do
      with player
      V2 vx vy <- query xyvel
      return $ unchanged
        { xyvel = Set $ case mov of
          ActUp f -> V2 vx (-f)
          ActDown f -> V2 vx f
          ActLeft f -> V2 (-f) vy
          ActRight f -> V2 f vy
          _          -> V2 vx vy
        }
  void $ liftIO $ swapMVar (worldState ud) nws

playerInteract2 :: UserData -> ActionMessage -> Affection ()
playerInteract2 ud (ActionMessage ActActivate _) = do
  wState <- liftIO $ readMVar (worldState ud)
  (nws, _) <- yieldSystemT wState $ do
    pdata <- efor allEnts $ do
      with player
      with pos
      with rot
      pos' <- query pos
      rot' <- query rot
      ent <- queryEnt
      return (pos', rot', ent)
    let (ppos, pdir, pent) = head pdata
    mrelEnts <- efor allEnts $ do
      with pos
      with objAccess
      with objType
      with objState
      reldirs <- query objAccess
      pos' <- query pos
      otype <- query objType
      ostate <- query objState
      ent <- queryEnt
      if any (\(rel, dir) -> ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
        (fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
        pdir == dir) reldirs
      then return $ Just (otype, ostate, ent)
      else return Nothing
    let relEnts = catMaybes mrelEnts
    liftIO $ A.logIO A.Debug ("relEnts: " <> fromString (show relEnts))
    -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
    mapM_ (\(t, s, e) ->
      setEntity e =<< objectTransition t s True e (Just pent)
      ) relEnts
  void $ liftIO $ swapMVar (worldState ud) nws
playerInteract2 _ _ = return ()

drawMap :: UserData -> Affection ()
drawMap ud = do
  sData <- liftIO $ readMVar (stateData ud)
  wState <- liftIO $ readMVar (worldState ud)
  let ctx = nano ud
  case sData of
    None -> liftIO $ do
      progress <- readMVar (stateProgress ud)
      drawLoadScreen ud progress
    _ -> do
      dt <- getDelta
      (_, dat) <- yieldSystemT wState $ do
          efor allEnts $ do
            with pos
            pos' <- query pos
            player' <- queryMaybe player
            stat <- queryMaybe anim
            mbnds <- queryMaybe obstacle
            t <- queryMaybe objType
            s <- queryMaybe objState
            pa <- queryMaybe objPlayerActivated
            ttl <- queryMaybe objStateTime
            let maxt = fromMaybe 1 (actionTime <$> t <*> s)
                first = if isJust player'
                  then Just
                    pos'
                  else Nothing
                secnd = if isJust stat
                  then Just
                    ( pos'
                    , fromJust stat
                    , mbnds
                    )
                  else Nothing
                third = if isJust t && isJust s
                  then Just
                    ( pos'
                    , fromMaybe False pa
                    , realToFrac (1 - fromMaybe 0 ttl / maxt)
                    )
                  else Nothing
            return (first, secnd, third)
      let ((playerPos:_), posanims, posActions) = Prelude.foldl
            (\(amppo, ampan, ampac) (mppo, mpan, mpac) ->
              ( if isJust mppo then fromJust mppo : amppo else amppo
              , if isJust mpan then fromJust mpan : ampan else ampan
              , if isJust mpac then fromJust mpac : ampac else ampac
              )
              )
            ([], [], [])
            dat
          V2 pr pc = playerPos
          MainData _ _ _ _ gr = sData
          seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr)
          room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
          mat = imgMat sData
          cols = fromIntegral (ncols mat)
          rows = fromIntegral (nrows mat)
          tileWidth = 64 :: Double
          tileHeight = 32 :: Double
          x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
          y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
          partposanims = M.fromList
            (nrows $ mapMat sData)
            (ncols $ mapMat sData)
            ((reverse . fst)
              (Prelude.foldl
                (\(done, proc) coord ->
                  let (ndone, nproc) = processList proc coord
                  in  (ndone : done, nproc)
                  )
                ([], posanims)
                ((,)
                  <$> [1 .. (nrows $ mapMat sData)]
                  <*> [1 .. (ncols $ mapMat sData)]
                  )
                )
              )
          processList
            :: [(V2 Double, AnimState, Maybe (Boundaries Double))]
            -> (Int, Int)
            -> ( [(V2 Double, AnimState, Maybe (Boundaries Double))]
               , [(V2 Double, AnimState, Maybe (Boundaries Double))]
               )
          processList list (r, c) =
            let delimiter (V2 nr nc, _, _) =
                  floor nr == r && floor nc == c
            in  L.partition delimiter list
      liftIO $ do
        beginPath ctx
        moveTo ctx (x + realToFrac tileWidth / 2) y
        lineTo ctx
          (x + cols * (realToFrac tileWidth / 2))
          (y - (realToFrac tileHeight / 2) * (cols - 1))
        lineTo ctx
          (x + (realToFrac tileWidth / 2) * (cols + rows - 1))
          (y + (rows - cols) * (realToFrac tileHeight / 2))
        lineTo ctx
          (x + (realToFrac tileWidth / 2) * rows)
          (y + (realToFrac tileHeight / 2) * (rows - 1))
        closePath ctx
        fillColor ctx (rgb 255 255 255)
        fill ctx
        let coordList = concatMap
              (\(i, ls) -> Prelude.map
                (\(j, t) -> ((i, j), t))
                (reverse $ zip [1..] ls)
                )
              (zip [1..] (toLists mat))
            filterList = Prelude.filter
              (\((frow, fcol), _) ->
                ((realToFrac (sx frow fcol) > -tileWidth &&
                  realToFrac (sy frow fcol) > -tileHeight) &&
                ((realToFrac (sx frow fcol) :: Double) < 1280 &&
                (realToFrac ((sy frow fcol)- (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720))
                )
              coordList
            !posanimList = Prelude.map
              (\((row, col), tile) -> ((row, col), tile, partposanims M.! (row, col)))
              filterList
            sx row col = realToFrac $ 640 + ((fromIntegral col - pc) +
              (fromIntegral row - pr)) * (tileWidth / 2) :: CFloat
            sy row col = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
              (fromIntegral col - pc)) * (tileHeight / 2) :: CFloat
        void $ sequence $ parMap rpar
        -- mapM_
          (\((row, col), tile, posanim) ->
            drawTile ud ctx posanim pr pc row col tile
            )
          posanimList
        -- void $ sequence $ parMap rpar (\(i, ls) -> void $ sequence $ parMap rpar
        --     (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
        --     (reverse $ zip [1..] ls))
        --   (zip [1..] (toLists mat))
        mapM_ (\(V2 sr sc, pa, perc) -> when pa $ do
          let lx = realToFrac $ 640 + ((sc - pc) +
                (sr - pr)) * (tileWidth / 2) :: CFloat
              ly = realToFrac $ 360 - (tileHeight / 2) + ((sr - pr) -
                (sc - pc)) * (tileHeight / 2) :: CFloat
          fillColor ctx (rgb 0 255 0)
          strokeColor ctx (rgb 0 255 0)
          strokeWidth ctx 2
          beginPath ctx
          rect ctx (lx - 25) (ly - 50) 50 10
          stroke ctx
          closePath ctx
          beginPath ctx
          rect ctx (lx - 25 * perc) (ly - 50) (50 * perc) 10
          fill ctx
          closePath ctx
          ) posActions
        fontSize ctx 20
        aFonts <- readMVar (assetFonts ud)
        fontFace ctx (aFonts Map.! FontBedstead)
        textAlign ctx (S.fromList [AlignCenter,AlignTop])
        fillColor ctx (rgb 255 128 0)
        textBox ctx 0 0 200 (
          "FPS: "
          <> T.pack (Prelude.take 5 $ show (1/dt))
          <> " Clearance: "
          <> (if not (Prelude.null room)
            then T.pack (show $ clearance $ V.head room)
            else "0"
            )
          <> "\nFor answers call 6350"
          )

drawTile
  :: UserData
  -> Context
  -> [(V2 Double, AnimState, Maybe (Boundaries Double))]
  -> Double
  -> Double
  -> Int
  -> Int
  -> Maybe ImgId
  -> IO ()
drawTile ud ctx posanims pr pc row col img = do
  let (bef, beh) = L.partition delimiter sorted
  aImages <- readMVar (assetImages ud)
  save ctx
  mapM_ (flip drawAnim fact) beh
  maybe (return ()) (Types.draw ud x (y - 42) 64 74
    (if fromMaybe False (isWall <$> img) then fact else 1))
    ((aImages Map.!) <$> case img of
      Just ImgEmpty -> Nothing
      _ -> img
      )
  mapM_ (flip drawAnim fact) bef
  restore ctx
  -- when (floor pr == row && floor pc == col) $ do
  --   A.logIO A.Debug ("sorted: " ++ show sorted)
  --   A.logIO A.Debug ("beh: " ++ show beh)
  --   A.logIO A.Debug ("bef: " ++ show bef)
  where
    delimiter (V2 nr nc, as, mbnds) =
      animFloats (asId as) ||
      all delimit mb
      where
        delimit b
          | nnr > fst (matmax b) || nnc < snd (matmin b) =
            True
          | nnr > fst (matmin b) && nnr < fst (matmax b) =
            nnc <= snd (matmin b)
          | nnc > snd (matmin b) && nnc < snd (matmax b) =
            nnr >= fst (matmax b)
          | otherwise =
            False
        nnr = case mbnds of
          Just (Boundaries (_, _) (maxr, _)) -> maxr
          Nothing -> nr - fromIntegral ((floor nr) :: Int) :: Double
        nnc = case mbnds of
          Just (Boundaries (_, minc) (_, _)) -> minc
          Nothing -> nc - fromIntegral ((floor nc) :: Int) :: Double
    tileWidth = 64 :: Double
    tileHeight = 32 :: Double
    sorted = sortOn (\(V2 sr sc, _, mbnds) ->
      let comp srow scol =
            ((floor $ (1 - scol) * 100) :: Int) + ((floor $ srow * 100) :: Int)
      in
        case mbnds of
          Just (Boundaries (minr, minc) (maxr, maxc)) ->
            comp (minr + ((maxr - minr) / 2)) (minc + (maxc - minc) / 2)
          _ ->
            comp
              (sr - (fromIntegral ((floor sr) :: Int)))
              (sc - (fromIntegral ((floor sc) :: Int)))
      ) posanims
    minrs = Prelude.map (fst . matmin) mb
    maxrs = Prelude.map (fst . matmax) mb
    mincs = Prelude.map (snd . matmin) mb
    maxcs = Prelude.map (snd . matmax) mb
    x = realToFrac $ 640 + ((fromIntegral col - pc) +
      (fromIntegral row - pr)) * (tileWidth / 2) :: CFloat
    y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
      (fromIntegral col - pc)) * (tileHeight / 2) :: CFloat
    dist = distance (V2 (fromIntegral row) (fromIntegral col))
      (V2 (realToFrac pr - 1) (realToFrac pc)) / 4
    fact =
      if pr <= fromIntegral row + (if L.null maxrs then 0.5 else minimum maxrs) &&
         pc >= fromIntegral col + (if L.null mincs then 0.5 else maximum mincs)
      then min 1 dist
      else 1
    mb = maybe [] collisionObstacle img
    drawAnim (V2 nr nc, as, _) factor = do
      let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32
          ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58
      Types.draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as

updateMap :: UserData -> Double -> Affection ()
updateMap ud dt = do
  osData <- liftIO $ readMVar (stateData ud)
  if osData == None
  then do
    mstart <- liftIO $ tryTakeMVar (stateMVar ud)
    case mstart of
      Just (nws, mendat) -> do
        void $ liftIO $ swapMVar (worldState ud) nws
        void $ liftIO $ swapMVar (stateData ud) mendat
        void $ liftIO $ swapMVar (state ud) (Main WorldMap)
        updateMap ud 0.1
        updateMap ud 0.1
        updateMap ud 0.1
        updateMap ud 19
        liftIO $ logIO A.Debug "Loaded game data"
      Nothing -> return ()
  else do
    wState <- liftIO $ readMVar (worldState ud)
    sData <- liftIO $ readMVar (stateData ud)
    aAnim <- liftIO $ readMVar (assetAnimations ud)
    (nws, _) <- yieldSystemT wState $ do
      obstacleBounds <- efor allEnts $ do
        with obstacle
        with pos
        b <- query obstacle
        pos' <- query pos
        return (pos', b)
      emap allEnts $ do
        pos'@(V2 pr pc) <- query pos
        vel' <- queryMaybe vel
        rot' <- fromMaybe N <$> queryMaybe rot
        fact' <- fromMaybe 1 <$> queryMaybe velFact
        xyv2 <- queryMaybe xyvel
        stat <- query anim
        let an = aAnim Map.! asId stat
            mat = mapMat sData
            ntime = asElapsedTime stat + dt
            npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel')
            dpos@(V2 dpr dpc) = npos - pos'
            aId = asId stat
            lll = (,)
              <$> (
                if dpr < 0
                then [(floor dpr :: Int) .. 0]
                else [0 .. (ceiling dpr :: Int)])
              <*> (
                if dpc < 0
                then [(floor dpc :: Int) .. 0]
                else [0 .. (ceiling dpc :: Int)])
            colldpos = dpos * Prelude.foldl
              (\acc a ->
                let ret = checkBoundsCollision2 pos' npos dt acc a
                in A.log A.Verbose (fromString $ show ret) ret)
              (V2 1 1)
              (
                nub $ concatMap
                (\(dr, dc) ->
                  let bs = (++)
                        (fromMaybe [] $ collisionObstacle <$> M.unsafeGet
                          (min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr)
                          (min (ncols mat) $ max 1 $ fromIntegral $ floor pc + dc)
                          (imgMat sData))
                        (Prelude.map snd $ Prelude.filter
                          (\((V2 br bc), _) ->
                            floor pr + dr == floor br &&
                            floor pc + dc == floor bc
                            )
                          obstacleBounds)
                  in  Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
                        Boundaries
                          (minr + fromIntegral dr, minc + fromIntegral dc)
                          (maxr + fromIntegral dr, maxc + fromIntegral dc)
                        ) bs
                  )
                lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
                )
            nstate =
              let velo = fromMaybe (V2 0 0) vel'
                  nstat = if ntime > fromIntegral (asCurrentFrame stat + 1) *
                    (animDuration an / fromIntegral (length $ animSprites an))
                    then
                      let nframe = asCurrentFrame stat + 1
                      in  case animPlay an of
                            APLoop ->
                              let (nnframe, nntime) =
                                    if nframe >= length (animSprites an)
                                    then (0, 0)
                                    else (nframe, ntime)
                              in  stat
                                    { asCurrentFrame = nnframe
                                    , asElapsedTime  = nntime
                                    }
                            APOnce ->
                              let nnframe = if nframe >= length (animSprites an)
                                    then nframe - 1
                                    else nframe
                              in  stat
                                    { asCurrentFrame = nnframe
                                    , asElapsedTime  = ntime
                                    }
                    else
                      stat
                        { asElapsedTime = ntime
                        }
              in
                case aiName aId of
                  "walking"
                    | sqrt (velo `dot` velo) > 0 ->
                      nstat
                        { asId = aId
                          { aiDirection = fromMaybe rot' (direction velo)
                          }
                        }
                    | otherwise ->
                      nstat
                        { asId = aId
                          { aiDirection = fromMaybe rot' (direction velo)
                          , aiName = "standing"
                          }
                        , asCurrentFrame = 0
                        }
                  "standing"
                    | sqrt (velo `dot` velo) > 0 ->
                      nstat
                        { asId = aId
                          { aiDirection = fromMaybe rot' (direction velo)
                          , aiName = "walking"
                          }
                        , asCurrentFrame = 0
                        }
                    | otherwise ->
                      nstat
                        { asId = aId
                          { aiDirection = fromMaybe rot' (direction velo)
                          }
                        }
                  _ -> nstat
            ent = unchanged
              { pos  = Set $ pos' + colldpos
              , rot  = Set $ fromMaybe rot' (direction (fromMaybe (V2 0 0) vel'))
              , anim = Set nstate
              , vel  = case xyv2 of
                Just (V2 rx ry) ->
                  let 
                    V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
                  in
                    Set $ 2 * V2 dr dc
                Nothing -> Keep
              }
        return ent
      -- allRelEnts <- efor allEnts $ do
      --   with pos
      --   with rot
      --   with clearanceLvl
      --   without objType
      --   pos' <- query pos
      --   rot' <- query rot
      --   clvl <- query clearanceLvl
      --   entn <- queryEnt
      --   return (entn, pos', rot', clvl)
      tses <- efor allEnts $ do
        with objType
        with objState
        t <- query objType
        s <- query objState
        e <- queryEnt
        return (t, s, e)
      mapM_ (\(t, s, e) ->
        objectAction dt t s e
        ) tses
    (nws2, _) <- yieldSystemT nws $ updateNPCs
      (imgMat sData)
      (mapMat sData)
      nws
      (V.filter
        (\p -> pointType p /= RoomExit)
        (reachPoints sData)
        )
      dt
    void $ liftIO $ swapMVar (worldState ud) nws2