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, eitherDecodeStrict')
import Foreign qualified
import Geomancy (Vec2, vec2, pattern WithVec2)
import Geomancy.Layout qualified as Layout
import Geomancy.Layout.Alignment (Alignment)
import Geomancy.Layout.Box (Box(..))
import Geomancy.Layout.Box qualified as Box
import GHC.Stack (withFrozenCallStack)
import RIO.HashMap qualified as HashMap
import RIO.Text qualified as Text
import Vulkan.NamedType ((:::))

import Resource.Source (Source)
import Resource.Source qualified as Source

-- * 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
  :: ( MonadIO m
     , MonadReader env m
     , HasLogFunc env
     , HasCallStack
     )
  => Source -> m Container
load =
  withFrozenCallStack $
    Source.load \bytes ->
      case eitherDecodeStrict' bytes of
        Left err ->
          liftIO . throwIO . 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" ::: Alignment
  -> "Size"      ::: Float
  -> "Font"      ::: Container
  -> "Line"      ::: [Char]
  -> ("scale" ::: Float, [PutChar])
putLine bs bp a targetSize font =
  (sizeScale,) . extract . foldl' step (0, [])
  where
    parent = Box
      { position = bp
      , size = bs
      }

    Container
      { size   = fontSize
      , width  = atlasWidth
      , height = atlasHeight
      , characters
      } = font

    sizeScale = targetSize / fontSize
    baseline = 0.7125

    extract (offX, bits) =
      Box.withTRBL (Layout.placeSize a (vec2 (offX * sizeScale) targetSize) parent) \t _r _b l -> do
        (WithVec2 w h, WithVec2 x y, (pcOffset, pcScale)) <- bits
        let
          pcPos =
            vec2
              (l + x * sizeScale)
              (t + y * sizeScale + baseline * targetSize)

          pcSize =
            vec2
              (w * sizeScale)
              (h * sizeScale)

        pure PutChar{..}

    step (offX, acc) = \case
      ' ' ->
        ( offX + fontSize / 2
        , acc
        )

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

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