Shaping.hs

module Codec.Ktx2.Font.Shaping
  ( -- * Input
    shapeText
  , shape
  , TextShape.text_
  , TextShape.char_
  , withFont_
  , shapeWith
  , Cursor(..)
  , initialCursorUp
  , initialCursorDown
    -- * Output
  , PlacedRun
  , PlacedGlyph(..)
  -- * Re-exports
  , KBTS.Font
  , Atlas.Compact(..)
  , Atlas.Box(..)
  ) where

import Codec.Ktx2.Font qualified as Font
import Control.Concurrent (withMVar)
import Data.List (mapAccumL)
import Data.Text (Text)
import Data.Text qualified as Text
import Graphics.MSDF.Atlas.Compact qualified as Atlas
import KB.Text.Shape qualified as TextShape
import KB.Text.Shape.FFI.Handles qualified as Handles
import KB.Text.Shape.Font qualified as KBTS

{- | Perform text segmentation and shaping on a block of text
-}
shapeText :: Cursor -> Font.StackContext a -> Text -> IO [PlacedRun]
shapeText cur ctx t =
  if Text.null t then
    pure []
  else
    shape cur ctx (TextShape.text_ t)

{- | Perform text segmentation and shaping.

Feed data using functions like 'TextShape.text_'.

The next step would be converting the resulting glyph "runs" into API specific data.

The atlas texture coordinates are normalized to 0..1 range.

The glyph "model" coordinates are normallized to fonts' "capital height".
Multiply by font size to match your projection settings.
-}
shape
  :: Cursor
  -> Font.StackContext a
  -> ((?shapeContext :: Handles.ShapeContext) => IO ())
  -> IO [PlacedRun]
shape cur ctx action  = snd <$> shapeWith (collectRun ctx) cur ctx action

{- | Run shaping and process results using a custom accumulator function
-}
shapeWith
  :: (acc -> (TextShape.Run, [TextShape.Glyph]) -> (acc, placed)) -- ^ Results-collecting function
  -> acc -- initial accumulator
  -> Font.StackContext a -- ^ shaping context with
  -> ((?shapeContext :: Handles.ShapeContext) => IO ())
  -> IO (acc, [placed])
shapeWith collectFun cur Font.StackContext{shapeContext} action =
  withMVar shapeContext \kbts ->
    mapAccumL collectFun cur <$> TextShape.run kbts action

withFont_ :: (?shapeContext :: Handles.ShapeContext) => Font.Bundle -> IO () -> IO ()
withFont_ Font.Bundle{fontData} action =
  KBTS.withFontData fontData \font ->
    TextShape.withFont_ font action

data Cursor = Cursor
  { curX, curY :: Float
  , lineHeight :: Float -- ^ Space between the baselines, as a multiple of the font size.
  , ySign :: Float -- ^ Should match atlas yOrigin and screen direction.
  }
  deriving (Eq, Show)

initialCursorUp
  :: Float -- ^ Line height multiplier.
  -> Cursor
initialCursorUp = initialCursor (-1)

initialCursorDown
  :: Float -- ^ Line height multiplier.
  -> Cursor
initialCursorDown = initialCursor 1

initialCursor
  :: Float -- ^ Y axis signum
  -> Float -- ^ Line height multiplier.
  -> Cursor
initialCursor ySign lineHeight = Cursor
  { curX = 0
  , curY = 0
  , lineHeight
  , ySign
  }

-- | Text runs with uniform direction and script.
type PlacedRun =
  ( (KBTS.Font, Maybe Atlas.Compact)
  , [PlacedGlyph]
  )

data PlacedGlyph = PlacedGlyph
  { codepoint :: Char -- ^ Unicode codepoint associated with the glyph. Mostly for debugging.
  , glyphId :: Int -- ^ Glyph ID in font and atlas. You can use this to look up the glyph boxes from GPU if you upload the glyph data as arrays.
  , glyph :: Atlas.Box -- ^ Glyph box on screen. The size and offsets are normalized so you can run the shaping once, then transform the whole block as you need.
  , plane :: Atlas.Box -- ^ Glyph box in atlas. The size is normalized to UV of the texure.
  }
  deriving (Eq, Show)

collectRun :: Font.StackContext a -> Cursor -> (TextShape.Run, [TextShape.Glyph]) -> (Cursor, PlacedRun)
collectRun ctx cur (TextShape.Run{font}, glyphs) = placeRun <$> mapAccumL (place fontUnitScale atlas_) cur glyphs
  where
    fontUnitScale = capHeightScale font
    atlas_ = Font.lookupAtlas font ctx

    placeRun :: [(Char, Int, Maybe (Atlas.Box, Atlas.Box))] -> PlacedRun
    placeRun placed =
      ( (font, atlas_)
      , do
          (codepoint, glyphId, Just (glyph, plane)) <- placed
          pure PlacedGlyph{codepoint, glyphId, glyph, plane}
      )

-- | Normalize font metrics using "cap height"
capHeightScale :: KBTS.Font -> Float
capHeightScale font = case KBTS.capHeight font of
 0 -> error "capHeight not set"
 n -> 1 / n

-- -- | Normalize font metrics using "units per em"
-- emScale :: KBTS.Font -> Float
-- emScale font = 1 / KBTS.unitsPerEm font

place :: Float -> Maybe Atlas.Compact -> Cursor -> TextShape.Glyph -> (Cursor, (Char, Int, Maybe (Atlas.Box, Atlas.Box)))
place fontUnitScale atlas_ cur@Cursor{..} glyph@TextShape.Glyph{codepoint, offsetX, offsetY, id=glyphId} =
  ( nextCur
  , (codepoint, fromIntegral glyphId, if codepoint == '\n' then Nothing else params_)
  )
  where
    nextCur = advance fontUnitScale cur glyph

    params_ = atlas_ >>= Atlas.lookupGlyph (fromIntegral glyphId) >>= pure . fmap placeGlyph
    placeGlyph =
      Atlas.moveBox
        (curX + fromIntegral offsetX * fontUnitScale)
        (curY + fromIntegral offsetY * fontUnitScale * ySign)

advance :: Float -> Cursor -> TextShape.Glyph -> Cursor
advance fontUnitScale cur@Cursor{..} TextShape.Glyph{advanceX, advanceY, codepoint} =
  if codepoint == '\n' then
    cur
      { curX = 0
      , curY = curY + lineHeight * ySign
      }
  else
    cur
      { curX = curX + fromIntegral advanceX * fontUnitScale
      , curY = curY + fromIntegral advanceY * fontUnitScale * ySign
      }