moving things out of module and show graphics

src/Floorplan.hs

@@ -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))

src/Init.hs

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

src/StateMachine.hs

@@ -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

src/Test.hs

@@ -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

src/Types.hs

@@ -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

src/Types/Map.hs

@@ -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)

src/Types/UserData.hs

@@ -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
 

tracer-game.cabal

@@ -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