tracer/src/Test.hs
2018-02-18 03:11:41 +01:00

114 lines
3.1 KiB
Haskell

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