tracer/src/Test.hs

module Test where

import Affection as A hiding (get)

import SDL (get, ($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get)
import NanoVG hiding (V2(..))

import Control.Monad (when, unless, void)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.MVar
import Control.Concurrent (forkOS)

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 (sortOn)

import System.Random (randomRIO)

import Linear hiding (E)

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

import Debug.Trace

-- internal imports

import Interior
import Util
import Types
import Floorplan
import NPC

loadMap :: Affection UserData ()
loadMap = do
  ud <- getAffection
  let fc = FloorConfig
        (10, 10)
        []
        (50, 50)
      (Subsystems _ m) = subsystems ud
  (mat, gr) <- liftIO $ buildHallFloorIO fc
  let imgmat = convertTileToImg mat
      exits = Prelude.foldl
        (\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty
          then ReachPoint RoomExit (V2 r c) : acc
          else acc
          )
        []
        ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
  (inter, rps) <- liftIO $ placeInteriorIO mat imgmat exits gr
  liftIO $ logIO A.Debug ("number of reachpoints: " ++ show (length rps))
  let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps
  npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex)
  liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
  (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
    createEntity $ newEntity
      { pos           = Just (V2 10.5 10.5)
      , vel           = Just (V2 0 0)
      , player        = Just ()
      , rot           = Just SE
      , anim          = Just $ AnimState (AnimId 0 "standing" SE) 0 0
      }
    void $ mapM_ (\npcpos@(V2 nr nc) -> do
      fact <- liftIO $ randomRIO (0.5, 1.5)
      future <- liftIO $ newEmptyMVar
      _ <- liftIO $ forkOS $ getPath (fmap floor npcpos) future nnex inter
      createEntity $ newEntity
        { pos           = Just (V2 (nr + 0.5) (nc + 0.5))
        , vel           = Just (V2 0 0)
        , velFact       = Just fact
        , rot           = Just SE
        , npcState      = Just (NPCStanding 0 future)
        , anim          = Just $ AnimState (AnimId 0 "standing" SE) 0 0
        }
      ) npcposs
  uu <- partSubscribe m movePlayer
  putAffection ud
    { worldState = nws
    , stateData = MenuData
      { mapMat = mat
      , imgMat = M.fromList (nrows inter) (ncols inter) $
        Prelude.map
          (\a -> if a == Just ImgEmpty then Nothing else a)
          (M.toList inter)
      , initCoords = (0, 500)
      , reachPoints = rps
      }
    , uuid = [uu]
    }

mouseToPlayer :: V2 Int32 -> Affection UserData ()
mouseToPlayer mv2 = do
  ud <- getAffection
  (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
  let dr = (ry / sin (atan (1/2)) / 2) + rx
      dc = rx - (ry / sin (atan (1/2)) / 2)
  (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
    emap allEnts $ do
      with player
      pure $ unchanged
        { vel = Set $ 4 * V2 dr dc
        }
  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, _) <- liftIO $ yieldSystemT (worldState ud) $ do
    emap allEnts $ do
      with player
      pure $ unchanged
        { vel = Set $ V2 0 0
        }
  putAffection ud
    { worldState = nws
    }
movePlayer _ = return ()

drawMap :: Affection UserData ()
drawMap = do
  ud <- getAffection
  dt <- getDelta
  (_, (playerPos, playerRot, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do
    (pc, dir) <- fmap head $ efor allEnts $ do
      with player
      with pos
      with rot
      pos' <- query pos
      rot' <- query rot
      pure (pos', rot')
    posanims <- efor allEnts $ do
      with anim
      with pos
      state <- query anim
      pos' <- query pos
      return (pos', state)
    return (pc, dir, posanims)
  let V2 pr pc = playerPos
      mat = imgMat (stateData ud)
      ctx = nano 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)
  liftIO $ do -- draw floor
    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) -> do
        drawTile ud ctx posanims pr pc i j t
        )
        (reverse $ zip [1..] ls))
      (zip [1..] (toLists mat))
    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.append` (T.pack $ Prelude.take 5 $ show (1/dt)))

drawTile
  :: UserData
  -> Context
  -> [(V2 Double, AnimState)]
  -> 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 < 1280 && realToFrac (y - (74 - realToFrac tileHeight)) < 720)) $
      do
        let lt = Prelude.filter (\(V2 nr nc, _) ->
              (any (\m -> nr < (fromIntegral (floor nr :: Int)) + m) maxrs &&
              any (\m -> nc > (fromIntegral (floor nc :: Int)) + m) maxcs)
              ) sorted
            ge = Prelude.filter (\(V2 nr nc, _) -> not
              (any (\m -> nr < (fromIntegral (floor nr :: Int)) + m) maxrs &&
              any (\m -> nc > (fromIntegral (floor nc :: Int)) + m) maxcs)
              ) sorted
        save ctx
        mapM_ drawAnim lt
        when (isJust img) drawImage
        mapM_ drawAnim ge
        restore ctx
  where
    ai = assetImages ud
    anims = assetAnimations ud
    tileWidth = 64 :: Double
    tileHeight = 32 :: Double
    filtered = Prelude.filter
      (\((V2 ar ac), _) -> floor ar == row && floor ac == col) posanims
    sorted = sortOn (\(V2 sr sc, _) -> sc + sr * maxCol) filtered
    maxCol = maximum (Prelude.map (\(V2 _ mc, _) -> mc) filtered)
    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 + minimum maxrs &&
         pc >= fromIntegral col + maximum mincs) &&
         isWall (fromJust img)
      then min 1 dist
      else 1
    mb = imgObstacle img
    drawAnim (V2 nr nc, as) = do
      let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32
          ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16
          a = anims Map.! asId as
      beginPath ctx
      paint <- imagePattern ctx (ax - 32) (ay - 58) 64 74 0
        (animSprites a !! asCurrentFrame as) 1
      rect ctx (ax - 32) (ay - 58) 64 74
      fillPaint ctx paint
      fill ctx
    drawImage = do
      beginPath ctx
      paint <- imagePattern
        ctx x (y - (74 - realToFrac tileHeight))
        (realToFrac tileWidth) 74
        0
        (ai Map.! fromJust img)
        fact
      rect ctx x (y - (74 - realToFrac tileHeight)) (realToFrac tileWidth) 74
      fillPaint ctx paint
      fill ctx

drawAnims
  :: Context
  -> Map AnimId Animation
  -> SystemState Entity IO
  -> [(V2 Double, AnimState)]
  -> Double
  -> Double
  -> Int
  -> Int
  -> Maybe ImgId
  -> IO ()
drawAnims ctx anims ws posanims pr pc r c tile =
  mapM_ (\(V2 nr nc, as) -> do
    let x = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32
        y = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16
        anim = anims Map.! asId as
    beginPath ctx
    paint <- imagePattern ctx (x - 32) (y - 58) 64 74 0
      (animSprites anim !! asCurrentFrame as) 1
    rect ctx (x - 32) (y - 58) 64 74
    fillPaint ctx paint
    fill ctx
    ) filtered
  where
    filtered = Prelude.filter
      (\((V2 ar ac), _) -> floor ar == r && floor ac == c) posanims
    sorted = sortOn (\(V2 sr sc, _) -> sc + sr * maxCol) filtered
    maxCol = maximum (Prelude.map (\(V2 _ mc, _) -> mc) filtered)

updateMap :: Double -> Affection UserData ()
updateMap dt = do
  let direction :: V2 Double -> Direction -> Direction
      direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0
        then
          let xuu =
                (acos ((vel' `dot` V2 0 1) / sqrt (vel' `dot` vel'))) / pi * 180
              xu = if vr < 0 then 360 - xuu else xuu
              d
                |               xu < 22.5  = NE
                | xu > 22.5  && xu < 67.5  = E
                | xu > 67.5  && xu < 112.5 = SE
                | xu > 112.5 && xu < 157.5 = S
                | xu > 157.5 && xu < 202.5 = SW
                | xu > 202.5 && xu < 247.5 = W
                | xu > 247.5 && xu < 292.5 = NW
                | xu > 292.5 && xu < 337.5 = N
                | xu > 337.5               = NE
          in d
        else rot'
  ud <- getAffection
  (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
    emap allEnts $ do
      with anim
      state <- query anim
      let anim = assetAnimations ud Map.! asId state
          ntime = asElapsedTime state + dt
          nstate = if ntime > (fromIntegral $ asCurrentFrame state) *
            (animDuration anim / (fromIntegral $ length $ animSprites anim))
            then
              let nframe = asCurrentFrame state + 1
              in  case animPlay anim of
                    APLoop ->
                      let (nnframe, nntime) =
                            if nframe >= (length $ animSprites anim)
                            then (0, 0)
                            else (nframe, ntime)
                      in  state
                            { asCurrentFrame = nnframe
                            , asElapsedTime  = nntime
                            }
                    APOnce ->
                      let nnframe = if nframe >= (length $ animSprites anim)
                            then nframe - 1
                            else nframe
                      in  state
                            { asCurrentFrame = nnframe
                            , asElapsedTime  = ntime
                            }
            else
              state
                { asElapsedTime = ntime
                }
      return $ unchanged
        { anim = Set nstate
        }
    emap allEnts $ do
      without player
      with vel
      with velFact
      with pos
      with rot
      with anim
      pos'@(V2 pr pc) <- query pos
      vel' <- query vel
      rot' <- query rot
      fact' <- query velFact
      state <- query anim
      let npos@(V2 nr nc) = pos' + fmap (* (dt * fact')) vel'
          dpos = npos - pos'
          aId = asId state
          ent = unchanged
            { pos = Set $ npos
            , rot = Set $ direction vel' rot'
            , anim = Set state
              { asId = aId
                { aiDirection = direction vel' rot'
                }
              }
            }
      return ent
    emap allEnts $ do
      with player
      with vel
      with pos
      with rot
      with anim
      pos'@(V2 pr pc) <- query pos
      vel'@(V2 vr vc) <- query vel
      rot' <- query rot
      state <- query anim
      let npos@(V2 nr nc) = pos' + fmap (* dt) vel'
          dpos@(V2 dpr dpc) = npos - pos'
          aId = asId state
          len = sqrt (dpos `dot` dpos)
          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)])
          ent = unchanged
            { pos = Set $ pos' + 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 = fromMaybe [] (imgObstacle <$> (M.safeGet
                        (fromIntegral $ floor pr + dr)
                        (fromIntegral $ floor pc + dc)
                        (imgMat (stateData ud))))
                  in  Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
                        Boundaries
                          (minr + fromIntegral dr, minc + fromIntegral dc)
                          (maxr + fromIntegral dr, maxc + fromIntegral dc)
                        ) bs
                  )
                (A.log A.Verbose (show lll ++ " " ++ show len) lll)
              )
            , rot = Set (direction vel' rot')
            , anim = Set state
              { asId = aId
                { aiDirection = direction vel' rot'
                }
              }
            }
      return ent
    updateNPCs
      (imgMat $ stateData ud)
      (Prelude.filter
        (\p -> pointType p /= RoomExit)
        (reachPoints $ stateData ud)
        )
      dt
  putAffection ud
    { worldState = nws
    }

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