moving things out of module and show graphics

This commit is contained in:
nek0 2018-02-17 02:36:06 +01:00
parent b43dbe0455
commit 53321a2576
8 changed files with 137 additions and 51 deletions

View file

@ -9,42 +9,10 @@ import Control.Monad (foldM)
import System.Random
import Types.Map
import Debug.Trace
data TileState
= Wall
-- | Wind
| Door
| Hall
| Offi
| Toil
| Kitc
| Elev
| Unde
deriving (Eq)
instance Show TileState where
show Wall = "#"
-- show Wind = "~"
show Door = "+"
show Hall = "_"
show Offi = "."
show Toil = "o"
show Kitc = "k"
show Elev = "x"
show Unde = " "
data FloorConfig = FloorConfig
{ elevator :: (Int, Int)
, facilities :: [(Int, Int)]
, size :: (Int, Int)
} deriving (Show)
data Boundaries = Boundaries
{ matmin :: (Int, Int)
, matmax :: (Int, Int)
} deriving (Show, Eq)
buildHallFloorIO :: FloorConfig -> IO (Matrix TileState)
buildHallFloorIO fc = do
rand <- newStdGen
@ -390,19 +358,6 @@ buildDoorsGraph mat =
buildGraph amat root (br, maxCol br (bc + 1))
in buildGraph mat [GHall []] (2, 2)
data GraphDirection = North | South | East | West
deriving (Show, Eq)
data Graph
= GHall
{ connects :: [Graph]
}
| GRoom
{ neighbs :: [(GraphDirection, TileState)]
, bounds :: Boundaries
}
deriving (Show, Eq)
buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
buildDoors input graph = do
traceIO ("graph: " ++ show (tail graph))

View file

@ -50,4 +50,5 @@ load = do
, nano = nvg
, uuid = []
, world = w
, stateData = None
}

View file

@ -6,12 +6,14 @@ import Affection
import Types
import Test
instance StateMachine State UserData where
smLoad Menu = return ()
smLoad Menu = loadMap
smUpdate Menu = const $ return ()
smDraw Menu = return ()
smDraw Menu = drawMap
smEvent _ evs = do
Subsystems w m <- subsystems <$> getAffection

66
src/Test.hs Normal file
View file

@ -0,0 +1,66 @@
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

View file

@ -1,5 +1,6 @@
module Types
( module Types.UserData
( module T
) where
import Types.UserData
import Types.UserData as T
import Types.Map as T

48
src/Types/Map.hs Normal file
View file

@ -0,0 +1,48 @@
module Types.Map where
data TileState
= Wall
-- | Wind
| Door
| Hall
| Offi
| Toil
| Kitc
| Elev
| Unde
deriving (Eq)
instance Show TileState where
show Wall = "#"
-- show Wind = "~"
show Door = "+"
show Hall = "_"
show Offi = "."
show Toil = "o"
show Kitc = "k"
show Elev = "x"
show Unde = " "
data FloorConfig = FloorConfig
{ elevator :: (Int, Int)
, facilities :: [(Int, Int)]
, size :: (Int, Int)
} deriving (Show)
data Boundaries = Boundaries
{ matmin :: (Int, Int)
, matmax :: (Int, Int)
} deriving (Show, Eq)
data GraphDirection = North | South | East | West
deriving (Show, Eq)
data Graph
= GHall
{ connects :: [Graph]
}
| GRoom
{ neighbs :: [(GraphDirection, TileState)]
, bounds :: Boundaries
}
deriving (Show, Eq)

View file

@ -13,10 +13,13 @@ import NanoVG hiding (V2(..), V3(..))
import qualified Data.Map.Strict as M
import Data.Text (Text(..))
import Data.Matrix
import Data.Ecstasy
import Linear
import Types.Map
data UserData = UserData
{ state :: State
, subsystems :: Subsystems
@ -24,12 +27,20 @@ data UserData = UserData
, nano :: Context
, uuid :: [UUID]
, world :: Entity 'WorldOf
, stateData :: StateData
}
data State
= Menu
| Test
data StateData
= None
| MenuData
{ mapMat :: Matrix TileState
, initCoords :: (Int, Int)
}
data ImgId
= ImgFloor

View file

@ -19,9 +19,11 @@ executable tracer-game
main-is: Main.hs
other-modules: Types
, Types.UserData
, Types.Map
, StateMachine
, Floorplan
, Init
, Test
default-extensions: OverloadedStrings
, DeriveGeneric
, DataKinds