EvanW.hs

{- |
  JSON font loader for bitmaps and SDFs

  Generator: https://evanw.github.io/font-texture-generator/

  Usage (WebGL): https://evanw.github.io/font-texture-generator/example-webgl/
-}

module Resource.Font.EvanW
  ( load
  , Container(..)
  , Character(..)

  , putLine
  , PutChar(..)
  ) where

import RIO

import Data.Aeson (FromJSON, eitherDecodeFileStrict')
import Foreign qualified
import Geomancy (Vec2, vec2, pattern WithVec2)
import RIO.HashMap qualified as HashMap
import RIO.Text qualified as Text
import Vulkan.NamedType ((:::))

import Engine.UI.Layout qualified as Layout

-- * Loading

newtype FontError = FontError Text
  deriving (Eq, Ord, Show, Generic)

instance Exception FontError

data Container = Container
  { name       :: Text
  , size       :: Float
  , bold       :: Bool
  , italic     :: Bool
  , width      :: Float
  , height     :: Float
  , characters :: HashMap Char Character
  }
  deriving (Eq, Ord, Show, Generic)

data Character = Character
  { x       :: Float
  , y       :: Float
  , width   :: Float
  , height  :: Float
  , originX :: Float
  , originY :: Float
  , advance :: Float
  }
  deriving (Eq, Ord, Show, Generic)

instance FromJSON Container
instance FromJSON Character

load :: HasLogFunc env => FilePath -> RIO env Container
load fp = do
  logInfo $ "Loading font " <> fromString fp
  liftIO (eitherDecodeFileStrict' fp) >>= \case
    Left err ->
      throwM . FontError $ Text.pack err
    Right res ->
      pure res

-- * Typesetting

data PutChar = PutChar
  { pcPos    :: Vec2
  , pcSize   :: Vec2
  , pcOffset :: Vec2
  , pcScale  :: Vec2
  } deriving (Show)

instance Foreign.Storable PutChar where
  alignment ~_ = 16

  sizeOf ~_ = 32 -- 4 of pairs of floats

  peek ptr = PutChar
    <$> Foreign.peekElemOff (Foreign.castPtr ptr) 0
    <*> Foreign.peekElemOff (Foreign.castPtr ptr) 1
    <*> Foreign.peekElemOff (Foreign.castPtr ptr) 2
    <*> Foreign.peekElemOff (Foreign.castPtr ptr) 3

  poke ptr PutChar{..} = do
    Foreign.pokeElemOff (Foreign.castPtr ptr) 0 pcPos
    Foreign.pokeElemOff (Foreign.castPtr ptr) 1 pcSize
    Foreign.pokeElemOff (Foreign.castPtr ptr) 2 pcOffset
    Foreign.pokeElemOff (Foreign.castPtr ptr) 3 pcScale

putLine
  :: "WH"        ::: Vec2
  -> "XY"        ::: Vec2
  -> "Alignment" ::: Layout.Alignment
  -> "Size"      ::: Float
  -> "Font"      ::: Container
  -> "Line"      ::: [Char]
  -> ("scale" ::: Float, [PutChar])
putLine (WithVec2 cw ch) (WithVec2 cx cy) Layout.Alignment{..} targetSize font =
  (sizeScale,) . extract . foldl' step (0, 0, [])
  where
    Container
      { size   = fontSize
      , width  = atlasWidth
      , height = atlasHeight
      , characters
      } = font

    sizeScale = targetSize / fontSize

    extract (offX, _offY, bits) = do
      (WithVec2 w h, WithVec2 x y, (offset, scale)) <- bits
      let
        ax = case alignX of
          Layout.Begin  -> -cw / 2
          Layout.Middle -> -offX * sizeScale / 2
          Layout.End    -> cw / 2 - offX * sizeScale

        ay = case alignY of
          Layout.Begin  -> -ch / 2 + targetSize * 1.3
          Layout.Middle -> targetSize * 0.5
          Layout.End    -> ch / 2 - targetSize * 0.5

      pure PutChar
        { pcPos    = vec2 (cx + ax + x * sizeScale) (cy + ay + y * sizeScale)
        , pcSize   = vec2 (w * sizeScale) (h * sizeScale)
        , pcOffset = offset
        , pcScale  = scale
        }

    step (offX, offY, acc) ' ' =
      ( offX + fontSize / 2
      , offY
      , acc
      )

    step (offX, offY, acc) char =
      case HashMap.lookup char characters <|> HashMap.lookup '?' characters of
        Nothing ->
          (offX, offY, acc)
        Just Character{..} ->
          ( offX + advance
          , offY
          , ( vec2 width (-height)
            , vec2 ox oy
            , (uvOffset, uvScale)
            ) : acc
          )
          where
            ox = offX + width / 2 - originX
            oy = offY + height / 2 - originY

            uvOffset = vec2 (x / atlasWidth) (y / atlasHeight)
            uvScale  = vec2 (width / atlasWidth) (height / atlasHeight)