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.IO.Class (liftIO)
import Control.Monad.State.Strict (evalStateT)
import Control.Concurrent.MVar
import Control.Concurrent (forkIO)

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 (sortOn, partition, find)

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 Object
import Animation

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

changeMaps :: KeyboardMessage -> Affection UserData ()
changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
  | SDL.keysymKeycode sym == SDL.KeycodeF1 = do
  ud <- getAffection
  case state ud of
    Main MindMap ->
      putAffection ud
        { state = Main WorldMap
        }
    Main WorldMap ->
      putAffection ud
        { state = Main MindMap
        }
    _ -> return ()
  | otherwise = return ()
changeMaps _ = return ()

changeMaps2 :: ActionMessage -> Affection UserData ()
changeMaps2 (ActionMessage ActSwitchMap _) = do
  ud <- getAffection
  case state ud of
    Main MindMap ->
      putAffection ud
        { state = Main WorldMap
        }
    Main WorldMap ->
      putAffection ud
        { state = Main MindMap
        }
    _ -> return ()
changeMaps2 _ = return ()

loadMapFork
  :: UserData
  -> AffectionData UserData
  -> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), 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)]
        (50, 50)
  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
      !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 gr
  let !rps = ReachPoint Elevator (fcElevator fc) SE 0 : rawrps
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Creating WorldState"
    )))
  (nws, mmimgmat) <- evalStateT (runState (yieldSystemT (worldState ud) $ 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: " ++ 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
        , objAccess = Just (access, dir)
        , objType   = Just ObjComputer
        , objState  = Just "off"
        }
      ) (A.log A.Debug ("number of computers: " ++ 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: " ++ 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
      , anim          = Just $ AnimState (AnimId AnimIntruder "standing" SE) 0 0
      }
    liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length computers)
    liftIO $ modifyMVar_ progress (return . (\(p, _) ->
      ( p + increment
      , "Registering NPCs into WorldState"
      )))
    mapM_ (\cpr -> do
      fact <- liftIO $ randomRIO (0.5, 1.5)
      -- fut <- liftIO newEmptyMVar
      stats <- liftIO $ NPCStats
        <$> (randomRIO (0, 1))
        <*> (randomRIO (0, 1))
        <*> (randomRIO (0, 1))
        <*> (randomRIO (0, 1))
        <*> (randomRIO (0, 1))
        <*> (randomRIO (0, 1))
      let room = head
            (Prelude.filter
              ((inBounds $ pointCoord cpr) . bounds)
              (Types.connects (head gr) ++ 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 AnimJDoeM "standing" SE) 0 0
        }
      ) computers
    liftIO $ modifyMVar_ progress (return . (\(p, _) ->
      ( p + increment
      , "Registering doors into WorldState"
      )))
    let doors = Prelude.filter ((RoomExit ==) . pointType) rps
    mapM_ (\door -> do
      let rooms = Prelude.foldl
            (\acc coord ->
              let rs = Prelude.filter ((inBounds coord) . bounds) graph
              in
                if not (Prelude.null rs)
                then (coord, head rs) : acc
                else acc
              )
            []
            coords
          [coord] = Prelude.filter
            (\(V2 r c) -> (Door ==) $ (mat M.! (r, c)))
            coords
          graph = Types.connects (head gr) ++ tail gr
          coords = Prelude.map (pointCoord door +) deltas
          dcoords = Prelude.map (coord +) deltas
          deltas =
            [ V2 0 1
            , V2 1 0
            , V2 (-1) 0
            , V2 0 (-1)
            ]
          wall = Prelude.filter
            (\delta ->
              let V2 r c = coord + delta
              in
                fromMaybe False (isWall <$> imgmat M.! (r, c)))
            deltas
          orientation
            | head wall == V2 0 1 || head wall == V2 0 (-1) = NE
            | head wall == V2 1 0 || head wall == V2 (-1) 0 = NW
            | otherwise                                     = error ("strange wall: " ++ show wall)
      void $ createEntity $ newEntity
        { pos          = Just (fmap ((+ 0.5) . fromIntegral) coord)
        , clearanceLvl = Just (maximum $ Prelude.map clearance (Prelude.map snd rooms))
        , anim         = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 0
        }
      ) 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)
  putMVar future (nws, MainData
      { mapMat = mat
      , imgMat = retMat
      , reachPoints = rps
      , mmImgMat = mmimgmat
      , roomGraph = gr
      })

-- mouseToPlayer :: V2 Int32 -> Affection UserData ()
-- mouseToPlayer mv2 = do
--   ud <- getAffection
--   (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
--   (nws, _) <- yieldSystemT (worldState ud) $
--     emap allEnts $ do
--       with player
--       return $ unchanged
--         { xyvel = Set $ V2 rx ry
--         }
--   putAffection ud
--     { worldState = nws
--     }
-- 
-- movePlayer :: MouseMessage -> Affection UserData ()
-- movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m
-- movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) =
--   mouseToPlayer m
-- movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
--   ud <- getAffection
--   (nws, _) <- yieldSystemT (worldState ud) $
--     emap allEnts $ do
--       with player
--       return $ unchanged
--         { xyvel = Set $ V2 0 0
--         }
--   putAffection ud
--     { worldState = nws
--     }
-- movePlayer _ = return ()

movePlayerKbd :: KeyboardMessage -> Affection UserData ()
movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
  | SDL.keysymKeycode sym == SDL.KeycodeW = do
    ud <- getAffection
    (nws, _) <- yieldSystemT (worldState ud) $
      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
          }
    putAffection ud
      { worldState = nws
      }
  | SDL.keysymKeycode sym == SDL.KeycodeS = do
    ud <- getAffection
    (nws, _) <- yieldSystemT (worldState ud) $
      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
          }
    putAffection ud
      { worldState = nws
      }
  | SDL.keysymKeycode sym == SDL.KeycodeA = do
    ud <- getAffection
    (nws, _) <- yieldSystemT (worldState ud) $
      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
          }
    putAffection ud
      { worldState = nws
      }
  | SDL.keysymKeycode sym == SDL.KeycodeD = do
    ud <- getAffection
    (nws, _) <- yieldSystemT (worldState ud) $
      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
          }
    putAffection ud
      { worldState = nws
      }
  | otherwise = return ()
movePlayerKbd _ = return ()

movePlayer2 :: ActionMessage -> Affection UserData ()
movePlayer2 (ActionMessage mov _) = do
  ud <- getAffection
  (nws, _) <- yieldSystemT (worldState ud) $
    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
        }
  putAffection ud
    { worldState = nws
    }
movePlayer2 _ = return ()

playerInteract :: MouseMessage -> Affection UserData ()
playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
  ud <- getAffection
  (V2 rx ry) <- liftIO $ (* V2 640 360) <$> relativizeMouseCoords m
  let dr = ((ry / 32) / sin (atan 0.5) / 2) + (rx / 64)
      dc = (rx / 64) - ((ry / 32) / sin (atan 0.5) / 2)
  (nws, _) <- yieldSystemT (worldState ud) $ do
    emap allEnts $ do
      with player
      with rot
      rot' <- query rot
      let ndir = direction (V2 dr dc)
      return $ unchanged
        { rot = Set $ fromMaybe rot' ndir
        }
    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
      (rel, dir) <- query objAccess
      pos' <- query pos
      otype <- query objType
      ostate <- query objState
      ent <- queryEnt
      if ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
        (fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
        (fmap floor (ppos + V2 dr dc) :: V2 Int) == (fmap floor pos' ::V2 Int) &&
        pdir == dir
      then return $ Just (otype, ostate, ent)
      else return Nothing
    let relEnts = catMaybes mrelEnts
    liftIO $ A.logIO A.Debug ("relEnts: " ++ 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
  putAffection ud
    { worldState = nws
    }
playerInteract _ = return ()

playerInteract2 :: ActionMessage -> Affection UserData ()
playerInteract2 (ActionMessage ActActivate _) = do
  ud <- getAffection
  (nws, _) <- yieldSystemT (worldState ud) $ 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
      (rel, dir) <- query objAccess
      pos' <- query pos
      otype <- query objType
      ostate <- query objState
      ent <- queryEnt
      if ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
        (fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
        pdir == dir
      then return $ Just (otype, ostate, ent)
      else return Nothing
    let relEnts = catMaybes mrelEnts
    liftIO $ A.logIO A.Debug ("relEnts: " ++ 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
  putAffection ud
    { worldState = nws
    }
playerInteract2 _ = return ()

drawMap :: Affection UserData ()
drawMap = do
  ud <- getAffection
  let ctx = nano ud
  case stateData ud of
    None -> liftIO $ do
      progress <- readMVar (stateProgress ud)
      drawLoadScreen ud progress
    _ -> do
      dt <- getDelta
      (_, (playerPos, posanims, posActions)) <- yieldSystemT (worldState ud) $ do
        pc <- efor allEnts $ do
          with player
          with pos
          query pos
        posanims <- efor allEnts $ do
          with anim
          with pos
          stat <- query anim
          pos' <- query pos
          mbnds <- queryMaybe obstacle
          return (pos', stat, mbnds)
        posActions <- efor allEnts $ do
          with objType
          with objState
          with objStateTime
          with objPlayerActivated
          with pos
          pos' <- query pos
          t <- query objType
          s <- query objState
          pa <- query objPlayerActivated
          let maxt = actionTime t s
          ttl <- query objStateTime
          return (pos', pa, realToFrac (1 - ttl / maxt))
        return (head pc, posanims, posActions)
      let V2 pr pc = playerPos
          MainData _ _ _ _ gr = stateData ud
          seekGraph = Types.connects (head gr) ++ tail gr
          room = Prelude.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
          mat = imgMat (stateData ud)
          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 $ stateData ud)
            (ncols $ mapMat $ stateData ud)
            ((reverse . fst)
              (Prelude.foldl
                (\(done, proc) coord ->
                  let (ndone, nproc) = processList proc coord
                  in  (ndone : done, nproc)
                  )
                ([], posanims)
                ((,)
                  <$> [1 .. (nrows $ mapMat $ stateData ud)]
                  <*> [1 .. (ncols $ mapMat $ stateData ud)]
                  )
                )
              )
          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
        mapM_ (\(i, ls) -> mapM_
            (\(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
        fontFace ctx (assetFonts ud 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 $ head room) else "0"
            )

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 =
  when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
    ((realToFrac x :: Double) < 1280 &&
    (realToFrac (y - (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) $
      do
        let (bef, beh) = L.partition delimiter sorted
        save ctx
        mapM_ drawAnim beh
        maybe (return ()) (draw ud x (y - 42) 64 74 fact)
          ((assetImages ud Map.!) <$> case img of
            Just ImgEmpty -> Nothing
            _ -> img
            )
        mapM_ drawAnim 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
      -- any (\m -> nr < fromIntegral (floor nr :: Int) + m) maxrs &&
      -- any (\m -> nc > fromIntegral (floor nc :: Int) + m) mincs
    tileWidth = 64 :: Double
    tileHeight = 32 :: Double
    sorted = sortOn (\(V2 sr sc, _, mbnds) -> case mbnds of
      Just (Boundaries (_, _) (maxr, maxc)) -> maxr + (1 - maxc) * 10
      _ -> (sr - (fromIntegral ((floor sr) :: Int))) +
        (1 - (sc - (fromIntegral ((floor sc) :: Int)))) * 10
      ) posanims
    -- sorted = 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 isWall (fromJust img) &&
         (pr <= fromIntegral row + minimum maxrs &&
         pc >= fromIntegral col + maximum mincs)
      then min 1 dist
      else 1
    mb = maybe [] collisionObstacle img
    drawAnim (V2 nr nc, as, _) = do
      let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32
          ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58
      draw ud ax ay 64 74 1 as

updateMap :: Double -> Affection UserData ()
updateMap dt = do
  ud <- getAffection
  -- empty <- liftIO $ isEmptyMVar (stateMVar ud)
  if stateData ud == None -- && empty
  then do
    mstart <- liftIO $ tryTakeMVar (stateMVar ud)
    case mstart of
      Just (nws, mendat) -> do
        putAffection ud
          { worldState = nws
          , stateData = mendat
          , state = Main WorldMap
          }
        updateMap 0.1
        updateMap 0.1
        updateMap 0.1
        updateMap 19
        liftIO $ logIO A.Debug "Loaded game data"
      Nothing -> return ()
  else do
    (nws, _) <- yieldSystemT (worldState ud) $ do
      emap allEnts $ do
        with player
        with xyvel
        with vel
        V2 rx ry <- query xyvel
        let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
        return $ unchanged
          { vel = Set $ 2 * V2 dr dc
          }
      emap allEnts $ do
        with anim
        stat <- query anim
        let an = assetAnimations ud Map.! asId stat
            ntime = asElapsedTime stat + dt
            nstate = 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
                  }
        return $ unchanged
          { anim = Set nstate
          }
      emap allEnts $ do
        without player
        with vel
        with velFact
        with pos
        with rot
        with anim
        pos' <- query pos
        vel' <- query vel
        rot' <- query rot
        fact' <- query velFact
        stat <- query anim
        let npos = pos' + fmap (* (dt * fact')) vel'
            aId = asId stat
            nstat = case aiName aId of
              "walking"
                | sqrt (vel' `dot` vel') > 0 ->
                  stat
                    { asId = aId
                      { aiDirection = fromMaybe rot' (direction vel')
                      }
                    }
                | otherwise ->
                  stat
                    { asId = aId
                      { aiDirection = fromMaybe rot' (direction vel')
                      , aiName = "standing"
                      }
                    , asCurrentFrame = 0
                    }
              "standing"
                | sqrt (vel' `dot` vel') > 0 ->
                  stat
                    { asId = aId
                      { aiDirection = fromMaybe rot' (direction vel')
                      , aiName = "walking"
                      }
                    , asCurrentFrame = 0
                    }
                | otherwise ->
                  stat
                    { asId = aId
                      { aiDirection = fromMaybe rot' (direction vel')
                      }
                    }
              x -> error ("unknown animation name" ++ x)
            ent = unchanged
              { pos = Set npos
              , rot = Set $ fromMaybe rot' (direction vel')
              , anim = Set nstat
              }
        return ent
      obstacleBounds <- efor allEnts $ do
        with obstacle
        with pos
        b <- query obstacle
        pos' <- query pos
        return (pos', b)
      emap allEnts $ do
        with player
        with vel
        with pos
        with rot
        with anim
        pos'@(V2 pr pc) <- query pos
        vel' <- query vel
        rot' <- query rot
        stat <- query anim
        let npos = pos' + fmap (* dt) vel'
            dpos@(V2 dpr dpc) = npos - pos'
            aId = asId stat
            nstat = case aiName aId of
              "walking"
                | sqrt (colldpos `dot` colldpos) > 0 ->
                  stat
                    { asId = aId
                      { aiDirection = fromMaybe rot' (direction vel')
                      }
                    }
                | otherwise ->
                  stat
                    { asId = aId
                      { aiDirection = fromMaybe rot' (direction vel')
                      , aiName = "standing"
                      }
                    , asCurrentFrame = 0
                    }
              "standing"
                | sqrt (colldpos `dot` colldpos) > 0 ->
                  stat
                    { asId = aId
                      { aiDirection = fromMaybe rot' (direction vel')
                      , aiName = "walking"
                      }
                    , asCurrentFrame = 0
                    }
                | otherwise ->
                  stat
                    { asId = aId
                      { aiDirection = fromMaybe rot' (direction vel')
                      }
                    }
              x -> error ("unknown animation name" ++ x)
            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 (show ret) ret)
              (V2 1 1)
              (
                concatMap
                (\(dr, dc) ->
                  let bs = (++)
                        (maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet
                          (fromIntegral $ floor pr + dr)
                          (fromIntegral $ floor pc + dc)
                          (imgMat (stateData ud))))
                        (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)
                )
            ent = unchanged
              { pos = Set $ pos' + colldpos
              , rot = Set (fromMaybe rot' $ direction vel')
              , anim = Set nstat
              }
        -- liftIO $ A.logIO A.Debug ("player position: " ++ show (pos' + colldpos))
        return ent
      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 $ stateData ud)
      nws
      (Prelude.filter
        (\p -> pointType p /= RoomExit)
        (reachPoints $ stateData ud)
        )
      dt
    putAffection ud
      { worldState = nws2
      }

checkBoundsCollision2
  :: V2 Double
  -> V2 Double
  -> Double
  -> V2 Double
  -> Boundaries Double
  -> V2 Double
checkBoundsCollision2
  pre@(V2 pr pc) nex dt acc (Boundaries (minr, minc) (maxr, maxc))
    | colltr < dt && colltc < dt = V2 0 0
    | colltr < dt                = V2 0 0
    | colltc < dt                = V2 0 0
    | otherwise                  = acc
    where
      V2 vr vc = fmap (/ dt) (nex - pre)
      colltr
        | vr > 0 && prr <= maxr && (prc + 0.15 >= minc && prc - 0.15 <= maxc) =
          ((fromIntegral (floor pr :: Int) + minr - 0.15) - pr) / vr
        | vr < 0 && prr >= minr && (prc + 0.15 >= minc && prc - 0.15 <= maxc) =
          ((fromIntegral (floor pr :: Int) + maxr + 0.15) - pr) / vr
        | otherwise = dt
      colltc
        | vc > 0 && prc <= maxc && (prr + 0.15 >= minr && prr - 0.15 <= maxr) =
          ((fromIntegral (floor pc :: Int) + minc - 0.15) - pc) / vc
        | vc < 0 && prc >= minc && (prr + 0.15 >= minr && prr - 0.15 <= maxr) =
          ((fromIntegral (floor pc :: Int) + maxc + 0.15) - pc) / vc
        | otherwise = dt
      prr = pr - fromIntegral (floor pr :: Int)
      prc = pc - fromIntegral (floor pc :: Int)