tracer/src/Test.hs

67 lines
1.7 KiB
Haskell

module Test where
import Affection as A
import Control.Monad.IO.Class (liftIO)
import Data.Matrix (toLists)
import NanoVG
import Types
import Floorplan
import Foreign.C.Types (CFloat(..))
loadMap :: Affection UserData ()
loadMap = do
ud <- getAffection
let fc = FloorConfig (10, 10) [] (50,50)
matrix <- liftIO $ buildHallFloorIO fc
putAffection ud
{ stateData = MenuData
{ mapMat = matrix
, initCoords = (50, 250)
}
}
drawMap :: Affection UserData ()
drawMap = do
ud <- getAffection
let matrix = mapMat (stateData ud)
mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [1..] ls))
(zip [1..] (toLists matrix))
drawTile :: Int -> Int -> TileState -> Affection UserData ()
drawTile row col tile = do
ctx <- nano <$> getAffection
(xinit, yinit) <- initCoords <$> stateData <$> getAffection
let tileWidth = 20 :: CFloat
tileHeight = 10 :: CFloat
liftIO $ do
save ctx
beginPath ctx
let x = fromIntegral xinit + (fromIntegral col * tileWidth / 2) +
(fromIntegral row * tileWidth / 2)
y = fromIntegral yinit + (fromIntegral row * tileHeight / 2) -
(fromIntegral col * 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 + tileWidth / 2) (y + tileHeight / 2)
lineTo ctx (x + tileWidth) y
lineTo ctx (x + tileWidth / 2) (y - tileHeight / 2)
closePath ctx
fill ctx
restore ctx