Bitmap font

2 files changed, 56 insertions, 0 deletions

diff --git a/src/Game.hs b/src/Game.hs
index 1e0245b..53be0ad 100644
--- a/src/Game.hs
+++ b/src/Game.hs
@@ -5,6 +5,7 @@ import Data.IORef
 import Data.Maybe (fromMaybe)
 import Data.Text (pack)
 import Foreign.C.Types (CInt)
+import qualified Game.BitmapFont as BF
 import qualified Game.Controller as C
 import qualified Game.Entities as E
 import qualified Game.Hud as H
@@ -44,6 +45,7 @@ data Env = Env
     controls :: IORef C.Controls,
     map :: M.Map,
     sprites :: S.SpriteSheet,
+    font :: BF.BitmapFont,
     entities :: IORef E.Entities,
     hud :: H.Hud,
     state :: IORef GS.State
@@ -73,9 +75,11 @@ main = do
   renderRect <- newIORef defaultRenderRect
   tsTexture <- SDL.Image.loadTexture renderer "data/tiles.png"
   ssTexture <- SDL.Image.loadTexture renderer "data/sprites.png"
+  bfTexture <- SDL.Image.loadTexture renderer "data/font.png"
   controls <- newIORef =<< C.init
   map' <- M.load "data/map.json" tsTexture
   sprites <- S.load "data/sprites.json" ssTexture
+  font <- BF.load "data/font.json" bfTexture
   state <-
     newIORef
       GS.State
@@ -98,6 +102,7 @@ main = do
         controls = controls,
         map = map',
         sprites = sprites,
+        font = font,
         entities = entities,
         hud = hud,
         state = state
@@ -140,6 +145,7 @@ gameLoop = do
       map' = env.map
       entities = env.entities
       hud = env.hud
+      font = env.font
 
   events <- map SDL.eventPayload <$> SDL.pollEvents
 
@@ -163,6 +169,7 @@ gameLoop = do
       M.render renderer map'
       H.render renderer hud
       E.render renderer updated
+      BF.renderText renderer font 120 178 "This is a test!"
 
     SDL.rendererRenderTarget renderer $= Nothing
     SDL.clear renderer
diff --git a/src/Game/BitmapFont.hs b/src/Game/BitmapFont.hs
new file mode 100644
index 0000000..d42f293
--- /dev/null
+++ b/src/Game/BitmapFont.hs
@@ -0,0 +1,49 @@
+module Game.BitmapFont (BitmapFont, load, renderText) where
+
+import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+import Foreign.C.Types (CInt)
+import qualified Game.Utils as U
+import qualified SDL
+import Text.JSON
+
+data FontDesc = FontDesc Int Int (Map Char (SDL.Rectangle CInt))
+
+data BitmapFont = BitmapFont FontDesc SDL.Texture
+
+instance JSON FontDesc where
+  showJSON = undefined
+  readJSON (JSObject obj) = do
+    w <- valFromObj "width" obj
+    h <- valFromObj "height" obj
+    m <- valFromObj "map" obj
+    pure $ FontDesc w h $ Map.fromList (zipWith (curry (toRect w h)) m [0 ..])
+    where
+      -- we store a Map from char to the SDL rect containing the glyph
+      toRect :: Int -> Int -> (Char, Int) -> (Char, SDL.Rectangle CInt)
+      toRect w h (c, i) = (c, U.rect (i * w) 0 w h)
+  readJSON _ = mzero
+
+-- | Load a bitmap font description from a JSON file.
+--
+-- The texture is expected to have the glyphs in a single line plus a special one at the end to be used when a character is not found in the font map.
+load :: String -> SDL.Texture -> IO BitmapFont
+load filename tex = do
+  d <- readFile filename
+  case decode d :: Result FontDesc of
+    Ok desc -> pure $ BitmapFont desc tex
+    Error e -> error e
+
+-- | Render a string at position x, y using the prodided bitmap font.
+renderText :: SDL.Renderer -> BitmapFont -> Int -> Int -> String -> IO ()
+renderText renderer (BitmapFont (FontDesc w h m) tex) x y text = mapM_ renderOne (zip [0 ..] text)
+  where
+    renderOne :: (Int, Char) -> IO ()
+    renderOne (i, c) =
+      SDL.copy renderer tex (Just src) (Just dst)
+      where
+        -- find the glyph or render the special one as error
+        src = fromMaybe (U.rect (length m * w) 0 w h) (Map.lookup c m)
+        dst = U.rect (x + i * w) y w h