blob: dd92a3aa1f1c0731ea954ddfbd490c073028e376 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
module Game.BitmapFont (BitmapFont, load, renderText, renderTextSolid) where
import Control.Monad
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Foreign.C.Types (CInt)
import Game.Utils qualified as U
import SDL (($=))
import SDL qualified
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 provided 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
-- | Render a string like renderText but with a translucid background.
renderTextSolid :: SDL.Renderer -> BitmapFont -> Int -> Int -> String -> IO ()
renderTextSolid renderer font@(BitmapFont (FontDesc w h _) _) x y text = do
oldBlend <- SDL.get $ SDL.rendererDrawBlendMode renderer
SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend
oldColor <- SDL.get $ SDL.rendererDrawColor renderer
SDL.rendererDrawColor renderer $= SDL.V4 32 32 32 192
_ <- SDL.fillRect renderer (Just (U.rect (x - 5) (y - 5) (length text * w + 10) (h + 10)))
SDL.rendererDrawColor renderer $= oldColor
SDL.rendererDrawBlendMode renderer $= oldBlend
renderText renderer font x y text
|
