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 Control.Monad (when)
import Control.Monad.IO.Class (liftIO)

import Data.Matrix (toLists)

import NanoVG hiding (V2(..))

import Types

import Floorplan

import Linear

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

import Debug.Trace

loadMap :: Affection UserData ()
loadMap = do
  ud <- getAffection
  let fc = FloorConfig (20, 20) [(5,5), (45, 95)] (50,100)
      (Subsystems _ m) = subsystems ud
  matrix <- liftIO $ buildHallFloorIO fc
  uu <- partSubscribe m movePlayer
  putAffection ud
    { stateData = MenuData
      { mapMat = matrix
      , initCoords = (0, 500)
      , playerCoords = (20, 20)
      }
    , uuid = [uu]
    }

relativizeMouseCoords :: V2 Int32 -> IO (V2 Double)
relativizeMouseCoords (V2 ix iy) = do
  (GL.Position vx vy, GL.Size vw vh) <- get GL.viewport
  let rx = ix - vx
      ry = iy - vy
      hx = fromIntegral vw / 2
      hy = fromIntegral vh / 2
      dx = fromIntegral rx - hx
      dy = fromIntegral ry - hy
  return $ V2 (dx / hx) (dy / hy)

movePlayer :: MouseMessage -> Affection UserData ()
movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] mv2@(V2 mx my) _) = do
  ud <- getAffection
  rela@(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
  let dr = (- ry) + (- rx)
      dc = (- rx) - (- ry) / 2
      (pr, pc) = playerCoords $ stateData ud
  liftIO $ traceIO $ "delta: " ++ show (V2 rx ry)
  liftIO $ traceIO $ "movement: " ++ show (V2 dr dc)
  putAffection ud
    { stateData = (stateData ud)
      { playerCoords = (pr - dr, pc - dc)
      }
    }
movePlayer _ = return ()

drawMap :: Affection UserData ()
drawMap = do
  ud <- getAffection
  let matrix = mapMat (stateData ud)
  mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [0..] ls))
    (zip [0..] (toLists matrix))

drawTile :: Int -> Int -> TileState -> Affection UserData ()
drawTile row col tile = do
  ud <- getAffection
  let ctx = nano ud
      (xinit, yinit) = initCoords $ stateData ud
      (pr, pc) = playerCoords $ stateData ud
      tileWidth = 20 :: Double
      tileHeight = 10 :: Double
  liftIO $ do
    save ctx
    beginPath ctx
    let x = realToFrac $ 650 + ((fromIntegral col - pc) +
          (fromIntegral row - pr)) * (tileWidth / 2)
        y = realToFrac $ 360 + ((fromIntegral row - pr) -
          (fromIntegral col - pc)) * (tileHeight / 2)
    fillColor ctx (case tile of
      Wall -> rgba 128 128 128 255
      Door -> rgba 255 128 128 255
      Hall -> rgba 255 255 255 255
      Offi -> rgba 0   255 0   255
      Toil -> rgba 0   0   255 255
      Kitc -> rgba 255 0   0   255
      Elev -> rgba 0   0   0   255
      _    -> rgba 255 255 0   255
      )
    moveTo ctx x y
    lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight / 2)
    lineTo ctx (x + realToFrac tileWidth) y
    lineTo ctx (x + realToFrac tileWidth / 2) (y - realToFrac tileHeight / 2)
    closePath ctx
    fill ctx
    when (floor pr + 1 == row && floor pc + 1 == col) $ do
      beginPath ctx
      circle ctx 640 360 5
      closePath ctx
      fillColor ctx (rgba 0 255 255 255)
      fill ctx
    restore ctx