Shaping.hs

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

import Codec.Ktx2.Font qualified as Font
import Control.Concurrent (withMVar)
import Control.Exception (evaluate)
import Data.List (mapAccumL)
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Traversable (for)
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@Font.StackContext{shapeContext} action =
  withMVar shapeContext \kbts ->
    shapeScaled kbts (collectRun ctx) cur 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

{- | Shape a block as one unbroken line, keeping the cluster index of each glyph.

The pen starts at the origin and never resets, not even on newlines, so the
placements can be sliced into lines later by whoever knows the cluster ranges.
See "Codec.Ktx2.Font.Layout".
-}
shapeClusters
  :: Font.StackContext a
  -> ((?shapeContext :: Handles.ShapeContext) => IO ())
  -> IO [ClusterRun]
shapeClusters ctx@Font.StackContext{shapeContext} action =
  withMVar shapeContext \kbts ->
    unsafeShapeClusters kbts ctx action

-- | 'shapeClusters' for callers already holding the locked context.
unsafeShapeClusters
  :: TextShape.Context
  -> Font.StackContext a
  -> ((?shapeContext :: Handles.ShapeContext) => IO ())
  -> IO [ClusterRun]
unsafeShapeClusters kbts ctx = shapeScaled kbts (collectClusters ctx) 0

{- | Shape and collect the runs together with their cap-height scale.

The font metrics are read straight from the font memory, so the lookup
happens while the fonts are known to be alive, not when the caller
gets around to forcing the results.
-}
shapeScaled
  :: TextShape.Context
  -> (acc -> (Float, (TextShape.Run, [TextShape.Glyph])) -> (acc, placed))
  -> acc
  -> ((?shapeContext :: Handles.ShapeContext) => IO ())
  -> IO [placed]
shapeScaled kbts collect acc action = do
  runs <- TextShape.run kbts action
  scaled <- for runs \run@(TextShape.Run{font}, _glyphs) -> do
    scale <- capHeightScale font
    (,run) <$> evaluate scale
  pure . snd $ mapAccumL collect acc scaled

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
    {- ^ The direction the lines advance in.

    The glyph boxes come out Y-up, like the font's own units, so text that reads
    top to bottom advances along the negative axis. Use 'initialCursorDown' and
    'initialCursorUp' instead of picking the sign by hand.
    -}
  }
  deriving (Eq, Show)

-- | A cursor for text that reads bottom to top.
initialCursorUp
  :: Float -- ^ Line height multiplier.
  -> Cursor
initialCursorUp = initialCursor 1

-- | A cursor for text that reads top to bottom. This is the usual one.
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 in the atlas. The size is normalized to the UV of the texture.
  , plane :: 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.
  }
  deriving (Eq, Show)

-- | Text runs with uniform direction and script, placed along a single pen.
type ClusterRun =
  ( (KBTS.Font, Maybe Atlas.Compact)
  , [ClusterGlyph]
  )

data ClusterGlyph = ClusterGlyph
  { cluster :: Int -- ^ Index of the codepoint the glyph came from.
  , advance :: Float -- ^ Pen advance contributed by the glyph, in cap-height units.
  , placed :: Maybe PlacedGlyph -- ^ Nothing for glyphs without a box, like newlines.
  }
  deriving (Eq, Show)

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

    place pen@Cursor{curX, curY} glyph =
      ( advance fontUnitScale pen glyph
      , placedGlyph fontUnitScale atlas_ curX curY glyph
      )

collectClusters :: Font.StackContext a -> Float -> (Float, (TextShape.Run, [TextShape.Glyph])) -> (Float, ClusterRun)
collectClusters ctx pen (fontUnitScale, (TextShape.Run{font}, glyphs)) =
  ((font, atlas_),) <$> mapAccumL place pen glyphs
  where
    atlas_ = Font.lookupAtlas font ctx

    place penX glyph@TextShape.Glyph{codepointIndex} =
      ( penX + step
      , ClusterGlyph
          { cluster = codepointIndex
          , advance = step
          , placed = placedGlyph fontUnitScale atlas_ penX 0 glyph
          }
      )
      where
        step = glyphAdvance fontUnitScale glyph

-- | Normalize font metrics using "cap height"
capHeightScale :: KBTS.Font -> IO Float
capHeightScale font = do
  info <- KBTS.getFontInfo font
  case info.capitalHeight of
    n | n <= 0 -> error "capHeight not set"
      | otherwise -> pure $ 1 / fromIntegral n

{- | Look up the glyph boxes and put the plane at the pen position.

The glyph planes and the positioning offsets are both Y-up, so the offsets
are applied as-is. Only the line advance follows 'ySign'.
-}
placedGlyph :: Float -> Maybe Atlas.Compact -> Float -> Float -> TextShape.Glyph -> Maybe PlacedGlyph
placedGlyph fontUnitScale atlas_ penX penY TextShape.Glyph{codepoint, offsetX, offsetY, id=glyphId}
  | codepoint == '\n' = Nothing
  | otherwise = do
      atlas <- atlas_
      (glyph, plane) <- Atlas.lookupGlyph (fromIntegral glyphId) atlas
      pure PlacedGlyph
        { codepoint
        , glyphId = fromIntegral glyphId
        , glyph
        , plane =
            Atlas.moveBox
              (penX + fromIntegral offsetX * fontUnitScale)
              (penY + fromIntegral offsetY * fontUnitScale)
              plane
        }

-- | The pen step of a glyph along the line. Newlines move the cursor, not the pen.
glyphAdvance :: Float -> TextShape.Glyph -> Float
glyphAdvance fontUnitScale glyph@TextShape.Glyph{advanceX}
  | glyph.codepoint == '\n' = 0
  | otherwise = fromIntegral advanceX * fontUnitScale

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