Ktxf.hs

module Resource.Font.Ktxf
  ( Font.Bundle(..)
  , load

  , Stack(..)
  , allocateMonoStacks
  , allocateStack1

  , shape
  , Layout.ShapedText
  , place
  , Layout.Strategy(..)
  , Layout.LineEnd(..)
  , PutChar(..)
  ) where

import RIO

import Geomancy (Vec2, vec2, withVec2)
import Geomancy.Layout.Alignment (Alignment(..))
import Geomancy.Layout.Box (Box(..))
import UnliftIO.Resource (MonadResource)
import UnliftIO.Resource qualified as Resource

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

import Codec.Ktx2.Font (Bundle(..), loadBundleFile, loadBundleBytes)
import Codec.Ktx2.Font qualified as Font
import Codec.Ktx2.Font.Layout qualified as Layout
import Codec.Ktx2.Font.Shaping qualified as Shaping
import Graphics.MSDF.Atlas.Compact qualified as Atlas

-- * Loading

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

instance Exception FontError

load
  :: ( MonadIO m
     , MonadReader env m
     , HasLogFunc env
     , HasCallStack
     )
  => Source -> m Bundle
load = \case
  Source.File _label path ->
    liftIO $ loadBundleFile path
  embedded ->
    Source.load (liftIO . loadBundleBytes) embedded

-- | A shaping context for one bundle, annotated with its texture id.
data Stack = Stack
  { context :: Font.StackContext Int32
  , style   :: Layout.TextStyle
  }

allocateMonoStacks :: (MonadResource m, Traversable t) => t (Int32, Font.Bundle) -> m (t Stack)
allocateMonoStacks = traverse (uncurry allocateStack1)

allocateStack1 :: MonadResource m => Int32 -> Font.Bundle -> m Stack
allocateStack1 textureId bundle = do
  stack <- liftIO $ Font.createStackContext (Identity bundle)
  _key <- Resource.register $ Font.destroyStackContext stack
  let context = Font.mapWithBundle (Identity (bundle, const textureId)) stack
  style <- liftIO $ Layout.bundleStyle context bundle
  pure Stack{context, style}

-- * Typesetting

-- BUG: pipeline-specific, should be moved to pipeline models

-- XXX: those can be collapsed to just an index into glyph storage (and the boxes are already storable)
data PutChar = PutChar
  { pcPos    :: Vec2 -- quads, static base + dynamic cursor'd positions in ems * shared dynamic scale
  , pcSize   :: Vec2 -- static base * shared dynamic scale
  , pcOffset :: Vec2 -- uv, static
  , pcScale  :: Vec2
  , pcDistanceLower :: Float
  , pcDistanceRange :: Float
  , pcTextureId :: Int32
  } deriving (Show)

-- | Shape and measure the text once, so it can be placed into any box.
shape :: Stack -> Text -> IO Layout.ShapedText
shape Stack{context, style} = Layout.shapeText context style

place
  :: Box -- ^ Parent box, screen units
  -> Alignment -- ^ Line alignment inside the box, block alignment along it
  -> Float -- ^ Line height, in cap-height units
  -> Layout.Strategy
  -> Float -- ^ Target size, screen units per cap height
  -> Stack
  -> Layout.ShapedText
  -> [PutChar]
place parent (Alignment alignment) lineHeight strategy targetSize Stack{context} shaped =
  withVec2 alignment \alignX alignY ->
  withVec2 parent.size \parentWidth parentHeight -> do
    let
      maxWidth = parentWidth / targetSize

      placed = Layout.placeText
        Layout.LayoutOptions
          { cursor = Shaping.initialCursorDown lineHeight
          , strategy
          , align = Layout.AlignLeft
          }
        maxWidth
        shaped

      -- XXX: ignoring glyph height and using cap height (the sizes are normalized to it)
      textHeight = 1 + (fromIntegral (length placed) - 1) * lineHeight

      blockOffset =
        parent.position
          - parent.size * 0.5
          + vec2 0 ((parentHeight - textHeight * targetSize) * alignY + targetSize)

    line <- placed
    let lineOffset = vec2 ((maxWidth - line.width) * alignX * targetSize) 0

    ((font, atlas_), glyphs) <- line.runs
    (pcTextureId, atlas) <- maybeToList $ (,) <$> Font.lookupBundled font context <*> atlas_
    Shaping.PlacedGlyph{glyph = atlasBox, plane = quadBox} <- glyphs
    guard $ quadBox.w > 0 && quadBox.h > 0
    let
      Atlas.Box{x=ax,y=ay,w=aw,h=ah} = atlasBox
      pcOffset = vec2 ax ay
      pcScale = vec2 aw ah
    let
      Atlas.Box{x,y,w,h} = quadBox
      pcPos = vec2 (x * targetSize) (-y * targetSize) + blockOffset + lineOffset
      pcSize = vec2 (w * targetSize) (h * targetSize)
      Atlas.Compact
        { _distanceLower = pcDistanceLower
        , _distanceRange = pcDistanceRange
        } = atlas
    pure PutChar{..}