Haskell roguelike - Entities & Drawing
Entities
Having selected a tileset we now need a type to represent a tile. I decided to create two types, a Tile and an Entity type. The Tile type represents a single tile from the tileset. A Entity is a thing that exists in the game world, something what will be stored in the world map. I.e. I’ll work with entities and draw their Tile
03_tiles/src/GameCore.hs (31 to 39)
data Tile = Tile { _tlName :: !Text
, _tlPic :: !(Int, Int)
, _tlId :: !Int
} deriving (Show, Eq, Ord)
data Entity = Entity { _enType :: !E.EntityType
, _enTile :: !Tile
, _enProps :: !(Map Text Text)
} deriving (Show, Eq, Ord)
A tile has
- A name
- A (row, column) offset named pic
- An id
An entity has
- A type
- A tile, i.e. the tile to draw for this entity
- Properties
It is possible to combine these two concepts into a single type. I decided to have them separate so that I could have a single entity that changes its tile based on some state.
Next some basic entity types for a the first world
03_tiles/src/EntityType.hs (8 to 13)
Entity and tile setup
As you can see we now have four entity types. We are going to need four tiles to represent the entities in the world and somewhere to store this.
The code below has two maps, EntityType to Tile (default tile) and one to Entity.
03_tiles/src/Entities.hs (13 to 14)
In a complete game there could be many tiles, and setting up the tile to entity relationship manually would be tedious, lets not do that.
03_tiles/src/Entities.hs (20 to 24)
let is = [ (E.Blank , (41, 13))
, (E.Door , (26, 15))
, (E.DoorClosed, (21, 15))
, (E.Wall , ( 9, 14))
]
Given this setup we need a way to populate the two maps above
03_tiles/src/Entities.hs (18 to 55)
(tiles, entities) =
let is = [ (E.Blank , (41, 13))
, (E.Door , (26, 15))
, (E.DoorClosed, (21, 15))
, (E.Wall , ( 9, 14))
]
in
let mkData (typ, pos@(x, y)) (tiles', entities') =
let (entity, tile) = mkEntityAndTile (x * 100 + y) typ pos in
( Map.insert typ tile tiles'
, Map.insert typ entity entities'
)
in
foldr
mkData
( Map.fromList [(E.Unknown, tileUnknown)]
, Map.fromList [(E.Unknown, entityUnknown)]
)
is
getEntity :: E.EntityType -> Entity
getEntity e = Map.findWithDefault entityUnknown e entities
getTile :: E.EntityType -> Tile
getTile e = Map.findWithDefault tileUnknown e tiles
mkEntityAndTile :: Int -> E.EntityType -> (Int, Int) -> (Entity, Tile)
mkEntityAndTile id typ pic =
let t = Tile { _tlId = id, _tlName = show typ, _tlPic = pic } in
let a = Entity { _enType = typ, _enTile = t, _enProps = Map.empty} in
(a, t)
tileUnknown :: Tile
entityUnknown :: Entity
(entityUnknown, tileUnknown) = mkEntityAndTile 201 E.Unknown (2, 1)
The code start with (tiles, entities) =
does just that.
- It creates both maps
- It creates an id for the tile by using (100 * row + column), e.g.
(9, 14)
creates an id of 914
There are also some helper functions getEntity and getTile that lookup a tile/entity and return the “unknown” value if it is not found.
Preparing to draw
First we need a draw command, so that the backend can respond to requests from the UI to start a draw.
03_tiles/src/GameCore.hs (67 to 70)
Often in a rogue like there will be a default background tile. That is a tile that is used when there are no entities on that position.
As a starting point for drawing, lets tell the UI what tile that is and have it draw a full grid of that tile. In the next chapter we’ll draw something more interesting
03_tiles/src/GameCore.hs (49 to 57)
data UiConfig = UiConfig { ucCmd :: !Text
, ucData :: !UiConfigData
}
deriving (Generic)
data UiConfigData = UiConfigData { udKeys :: ![UiKey]
, udBlankId :: !Int
}
deriving (Generic)
Responding to a redraw request
buildConfig is changed to send the blank tile
03_tiles/src/GameEngine.hs (124 to 132)
buildConfig :: Config -> UiConfigData
buildConfig cfg =
UiConfigData { udKeys = buildKeys (cfg ^. cfgKeys)
, udBlankId = E.getTile E.Blank ^. tlId
}
where
buildKeys ks = buildKey <$> Map.toList ks
buildKey (s, a) = UiKey s a
In the previous version the engine responded with the word “TODO”. Now runCmd gets the most recent world from the TVar w <- atomically $ readTVar worldV
and then calls drawAndSend
You’ll see this pattern through the code, the top level functions work with the TVar and thus needs to deal with IO. As far as possible everything else is pure and not in IO.
03_tiles/src/GameEngine.hs (85 to 95)
runCmd :: Host.Connection -> TVar World -> Text -> [Text] -> IO ()
runCmd conn worldV cmd cmdData =
case cmd of
"redraw" ->
case parseScreenSize cmdData of
Nothing -> sendError conn "missing / invalid screen size"
Just (sx, sy) -> do
updatePlayer (plScreenSize .~ (sx, sy))
w <- atomically $ readTVar worldV
drawAndSend w
sendLog conn "draw"
Finally drawAndSend sends a UiDrawCommand with the most recent screen size. _1
gets the first value (row) from the (row, column) plScreenSize tuple. This is the same as writing
03_tiles/src/GameEngine.hs (154 to 159)
drawAndSend :: World -> IO ()
drawAndSend world = do
let cmd = Ae.encodeText UiDrawCommand { drCmd = "draw"
, drScreenWidth = world ^. wdPlayer ^. plScreenSize ^. _1
}
sendData (world ^. wdPlayer ^. plConn) cmd
Tileset image
The UI is going to need the tileset PNG, here a route is added to Scotty to serve the file
03_tiles/src/GameHost.hs (46 to 47)
The frontend needs to load the tiles so they are available for drawing. A hidden image tag handles this
03_tiles/html/rogue.html (46 to 47)
Drawing the tiles
The UI needs to store the Id of the blank tile when it gets a config command
03_tiles/html/rogue.js (93 to 95)
The UI must then respond to a draw command
- Get a unique id for this draw session
- Get a drawing context for the canvas
- Draw the background in a single draw to fill the screen from a cached image
03_tiles/html/rogue.js (122 to 132)
case "draw": {
config.drawId = Math.random();
const colWidth = cmd.screenWidth;
const ctx = document.getElementById("tilesCanvas").getContext("2d");
//Draw background image of blank tiles
ctx.drawImage( getCachedBlankCanvas(), 0, 0 );
break;
}
To create the cached background image
- Get the size of the real canvas
- Create a new in memory canvas cbg
- For every row*column draw the blank tile
- Store the cached canvas for the next call
03_tiles/html/rogue.js (31 to 58)
function tileFromTileId( id ){
const x = Math.trunc( id / 100 );
const y = id - (x * 100);
return [x, y];
}
function getCachedBlankCanvas(){
if( !config.blank ){
const ctxMain = document.getElementById("tilesCanvas");
//Create a grid of blank cells for the background
var cbg = document.createElement('canvas');
cbg.width = ctxMain.width;
cbg.height = ctxMain.height;
var ctxbg = cbg.getContext('2d');
var [blankX, blankY] = tileFromTileId( config.blankId );
for( x = 0; x < config.gridWidth; ++x ){
for( y = 0; y < config.gridHeight; ++y ){
drawTile( ctxbg, tilesMain, config.tileWidth, config.tileHeight, x, y, blankX, blankY );
}
}
config.blank = cbg;
}
return config.blank;
}
Lastly the code that draws a tile is just a wrapper over the canvas drawImage function. All it does is translate from (row, column) to (x, y) by using the configured tile size
03_tiles/html/rogue.js (14 to 26)
function drawTile( ctx, img, twidth, theight, dx, dy, trow, tcol ){
ctx.drawImage(
img, //img
trow * twidth, //sx
tcol * theight, //sy
twidth, //sWidth
theight, //sHeight
dx * twidth, //dx
dy * theight, //dy
twidth, //dWidth
theight //dHeight
);
}
If you run this project (stack run
) and browse to http://localhost:61492/
, you should see a grid of the blank tiles
While this may not see that impressive, it does mean that the vast majority of the frontend code is now complete. There will be very few additions to the frontend logic from now on.
Chapters
Changes
As mentioned in the introduction, each chapter will end by showing the full set of code changes from the previous chapter. This should help give you an idea of what changed. Ignore these patch files if you don’t find them useful.
src/Entities.hs
diff -w -B -a -d -u -b --new-file 01_web_ui/src/Entities.hs 03_tiles/src/Entities.hs
--- 01_web_ui/src/Entities.hs
+++ 03_tiles/src/Entities.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Entities where
+
+import Protolude hiding (Map)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+
+import GameCore
+import qualified EntityType as E
+
+
+tiles :: Map E.EntityType Tile
+entities :: Map E.EntityType Entity
+
+
+
+(tiles, entities) =
+
+ let is = [ (E.Blank , (41, 13))
+ , (E.Door , (26, 15))
+ , (E.DoorClosed, (21, 15))
+ , (E.Wall , ( 9, 14))
+ ]
+
+ in
+ let mkData (typ, pos@(x, y)) (tiles', entities') =
+ let (entity, tile) = mkEntityAndTile (x * 100 + y) typ pos in
+ ( Map.insert typ tile tiles'
+ , Map.insert typ entity entities'
+ )
+ in
+ foldr
+ mkData
+ ( Map.fromList [(E.Unknown, tileUnknown)]
+ , Map.fromList [(E.Unknown, entityUnknown)]
+ )
+ is
+
+
+getEntity :: E.EntityType -> Entity
+getEntity e = Map.findWithDefault entityUnknown e entities
+
+getTile :: E.EntityType -> Tile
+getTile e = Map.findWithDefault tileUnknown e tiles
+
+
+mkEntityAndTile :: Int -> E.EntityType -> (Int, Int) -> (Entity, Tile)
+mkEntityAndTile id typ pic =
+ let t = Tile { _tlId = id, _tlName = show typ, _tlPic = pic } in
+ let a = Entity { _enType = typ, _enTile = t, _enProps = Map.empty} in
+ (a, t)
+
+
+tileUnknown :: Tile
+entityUnknown :: Entity
+(entityUnknown, tileUnknown) = mkEntityAndTile 201 E.Unknown (2, 1)
+
src/EntityType.hs
diff -w -B -a -d -u -b --new-file 01_web_ui/src/EntityType.hs 03_tiles/src/EntityType.hs
--- 01_web_ui/src/EntityType.hs
+++ 03_tiles/src/EntityType.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module EntityType where
+
+import Protolude
+
+
+data EntityType = Blank
+ | Door
+ | DoorClosed
+ | Wall
+ | Unknown
+ deriving (Show, Eq, Ord)
+
src/GameCore.hs
diff -w -B -a -d -u -b --new-file 01_web_ui/src/GameCore.hs 03_tiles/src/GameCore.hs
--- 01_web_ui/src/GameCore.hs
+++ 03_tiles/src/GameCore.hs
@@ -14,7 +14,7 @@
import Control.Lens.TH (makeLenses)
import qualified GameHost as Host
-
+import qualified EntityType as E
data Player = Player { _plConn :: !Host.Connection
, _plScreenSize :: !(Int, Int)
@@ -28,6 +28,16 @@
}
+data Tile = Tile { _tlName :: !Text
+ , _tlPic :: !(Int, Int)
+ , _tlId :: !Int
+ } deriving (Show, Eq, Ord)
+
+data Entity = Entity { _enType :: !E.EntityType
+ , _enTile :: !Tile
+ , _enProps :: !(Map Text Text)
+ } deriving (Show, Eq, Ord)
+
data UiMessage = UiMessage { umCmd :: !Text
@@ -35,12 +45,14 @@
}
deriving (Generic)
+
data UiConfig = UiConfig { ucCmd :: !Text
, ucData :: !UiConfigData
}
deriving (Generic)
-newtype UiConfigData = UiConfigData { udKeys :: [UiKey]
+data UiConfigData = UiConfigData { udKeys :: ![UiKey]
+ , udBlankId :: !Int
}
deriving (Generic)
@@ -44,12 +56,21 @@
}
deriving (Generic)
+
data UiKey = UiKey { ukShortcut :: !Text
, ukAction :: !Text
}
deriving (Generic)
+
+data UiDrawCommand = UiDrawCommand
+ { drCmd :: !Text
+ , drScreenWidth :: !Int
+ } deriving (Generic)
+
+
+
instance Ae.ToJSON UiMessage where
toJSON = Ae.genericToJSON Ae.defaultOptions { Ae.fieldLabelModifier = renField 2 True }
@@ -62,6 +83,9 @@
instance Ae.ToJSON UiKey where
toJSON = Ae.genericToJSON Ae.defaultOptions { Ae.fieldLabelModifier = renField 2 True }
+instance Ae.ToJSON UiDrawCommand where
+ toJSON = Ae.genericToJSON Ae.defaultOptions { Ae.fieldLabelModifier = renField 2 True }
+
-- | drop prefix, and then lower case
-- | renField 3 "tskBla" == "bla"
@@ -72,9 +96,8 @@
mkLower t = Txt.toLower (Txt.take 1 t) <> Txt.drop 1 t
-
-
makeLenses ''World
makeLenses ''Config
makeLenses ''Player
-
+makeLenses ''Entity
+makeLenses ''Tile
src/GameEngine.hs
diff -w -B -a -d -u -b --new-file 01_web_ui/src/GameEngine.hs 03_tiles/src/GameEngine.hs
--- 01_web_ui/src/GameEngine.hs
+++ 03_tiles/src/GameEngine.hs
@@ -11,12 +11,14 @@
import qualified Data.Aeson.Text.Extended as Ae
import qualified Data.ByteString.Lazy as BSL
import qualified Codec.Compression.BZip as Bz
-import Control.Lens ((^.), (.~), (%~))
-import Control.Concurrent.STM (atomically, newTVar, modifyTVar', TVar)
+import Control.Lens (_1, (^.), (.~), (%~))
+import Control.Concurrent.STM (atomically, readTVar, newTVar, modifyTVar', TVar)
import GameCore
import qualified GameHost as Host
import GameHost (conSendData, conReceiveText)
+import qualified Entities as E
+import qualified EntityType as E
runGame :: IO ()
@@ -95,7 +90,10 @@
Nothing -> sendError conn "missing / invalid screen size"
Just (sx, sy) -> do
updatePlayer (plScreenSize .~ (sx, sy))
- sendLog conn $ "TODO: " <> cmd
+ w <- atomically $ readTVar worldV
+ drawAndSend w
+ sendLog conn "draw"
+
"key" ->
sendLog conn $ "TODO: " <> cmd <> ": " <> show cmdData
@@ -124,9 +120,12 @@
sendData conn . Ae.encodeText $ UiConfig "config" (buildConfig config)
+
buildConfig :: Config -> UiConfigData
buildConfig cfg =
- UiConfigData $ buildKeys (cfg ^. cfgKeys)
+ UiConfigData { udKeys = buildKeys (cfg ^. cfgKeys)
+ , udBlankId = E.getTile E.Blank ^. tlId
+ }
where
buildKeys ks = buildKey <$> Map.toList ks
@@ -153,3 +150,11 @@
pure (x, y)
+
+drawAndSend :: World -> IO ()
+drawAndSend world = do
+ let cmd = Ae.encodeText UiDrawCommand { drCmd = "draw"
+ , drScreenWidth = world ^. wdPlayer ^. plScreenSize ^. _1
+ }
+ sendData (world ^. wdPlayer ^. plConn) cmd
+
html/rogue.js
diff -w -B -a -d -u -b --new-file 01_web_ui/src/GameHost.hs 03_tiles/src/GameHost.hs
--- 01_web_ui/src/GameHost.hs
+++ 03_tiles/src/GameHost.hs
@@ -49,6 +42,11 @@
Sc.get "/ping" $
Sc.text "pong"
+
+ Sc.get "/tiles.png" $
+ Sc.file "html/DungeonCrawl_ProjectUtumnoTileset_0.png"
+
+
Sc.get "/:res" $ do
res <- Sc.param "res"
Sc.file $ "html/" <> res
--- 01_web_ui/html/rogue.html
+++ 03_tiles/html/rogue.html
@@ -42,6 +41,11 @@
<!-- layer for mouse clicks etc, on top of all drawing layers -->
<div id="topInteractionLayer" style="display:block; position: absolute; left: 0; top: 0; z-index: 1000;"></div>
</div>
+
+
+ <!-- load the tiles as an image-->
+ <img src="tiles.png" style="display:none" id="tilesMain"/>
+
</body>
</html>
--- 01_web_ui/html/rogue.js
+++ 03_tiles/html/rogue.js
@@ -1,9 +1,9 @@
var sendCmd = ( c, d ) => {}
var tilesMain = null;
-
var config = { "drawId": 0,
"help": "",
+ "blank": null,
"tileWidth": 32,
"tileHeight": 32,
"gridWidth": 0,
@@ -11,6 +11,52 @@
};
+function drawTile( ctx, img, twidth, theight, dx, dy, trow, tcol ){
+ ctx.drawImage(
+ img, //img
+ trow * twidth, //sx
+ tcol * theight, //sy
+ twidth, //sWidth
+ theight, //sHeight
+ dx * twidth, //dx
+ dy * theight, //dy
+ twidth, //dWidth
+ theight //dHeight
+ );
+}
+
+
+
+
+function tileFromTileId( id ){
+ const x = Math.trunc( id / 100 );
+ const y = id - (x * 100);
+ return [x, y];
+}
+
+function getCachedBlankCanvas(){
+ if( !config.blank ){
+ const ctxMain = document.getElementById("tilesCanvas");
+
+ //Create a grid of blank cells for the background
+ var cbg = document.createElement('canvas');
+ cbg.width = ctxMain.width;
+ cbg.height = ctxMain.height;
+ var ctxbg = cbg.getContext('2d');
+ var [blankX, blankY] = tileFromTileId( config.blankId );
+
+ for( x = 0; x < config.gridWidth; ++x ){
+ for( y = 0; y < config.gridHeight; ++y ){
+ drawTile( ctxbg, tilesMain, config.tileWidth, config.tileHeight, x, y, blankX, blankY );
+ }
+ }
+
+ config.blank = cbg;
+ }
+
+ return config.blank;
+}
+
function sendKey(k){
@@ -42,17 +83,18 @@
sendCmd("init", gridSizeStr());
};
-
-
ws.onmessage = function (evt) {
var bytes = new Uint8Array(evt.data);
var m = bzip2.simple(bzip2.array(bytes));
cmd = JSON.parse(m);
+ switch( cmd.cmd ){
+
+ case "config": {
+ config.tiles = {};
+ config.blankId = cmd.data.blankId;
- switch( cmd.cmd ){
- case "config":
//Load keys
config.help = "";
for( var i in cmd.data.keys ){
@@ -64,17 +106,33 @@
sendCmd("redraw", gridSizeStr());
break;
+ }
- case "log":
+ case "log": {
console.log( cmd.message );
break;
+ }
- case "error":
+ case "error": {
alert( cmd.message );
break;
}
+ case "draw": {
+ config.drawId = Math.random();
+
+ const colWidth = cmd.screenWidth;
+ const ctx = document.getElementById("tilesCanvas").getContext("2d");
+
+ //Draw background image of blank tiles
+ ctx.drawImage( getCachedBlankCanvas(), 0, 0 );
+
+ break;
+ }
+
+ }
+
Mousetrap.unpause();
};
@@ -144,10 +196,6 @@
};
}
-window.addEventListener('resize', debounce(resizeCanvas, 250), false);
-
-
-
+window.addEventListener('resize', debounce(resizeCanvas, 250), false);
Mousetrap.bind( "?", () => alert( config.help ) );
-