67 lines
1.7 KiB
Haskell
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
|