From ce13d7eaa45b59647325b97e40906c54dbcf4b38 Mon Sep 17 00:00:00 2001
From: "Juan J. Martinez" <jjm@usebox.net>
Date: Thu, 23 Feb 2023 12:21:24 +0000
Subject: Bitmap font

---
 data/font.json         |   5 +++++
 data/font.png          | Bin 0 -> 7342 bytes
 game.cabal             |   2 ++
 src/Game.hs            |   7 +++++++
 src/Game/BitmapFont.hs |  49 +++++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 63 insertions(+)
 create mode 100644 data/font.json
 create mode 100644 data/font.png
 create mode 100644 src/Game/BitmapFont.hs

diff --git a/data/font.json b/data/font.json
new file mode 100644
index 0000000..d33dd03
--- /dev/null
+++ b/data/font.json
@@ -0,0 +1,5 @@
+{
+    "width": 6,
+    "height": 10,
+    "map": "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!?()@:/'., "
+}
diff --git a/data/font.png b/data/font.png
new file mode 100644
index 0000000..9f44e46
Binary files /dev/null and b/data/font.png differ
diff --git a/game.cabal b/game.cabal
index 45c71a4..93a1f96 100644
--- a/game.cabal
+++ b/game.cabal
@@ -20,6 +20,7 @@ library
         Game.Hud
         Game.Map
         Game.Sprites
+        Game.BitmapFont
         Game.Entities
         Game.Entities.Types
         Game.Entities.Const
@@ -36,6 +37,7 @@ library
         , mtl
         , text >= 1.1.0.0 && < 2.1
         , vector>=0.10.9.0 && <0.14
+        , containers
         , sdl2
         , sdl2-image
         , json
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
-- 
cgit v1.2.3