Measure.hs

module KB.Text.Layout.Measure
  ( -- * Layout context
    createLayoutContext
  , clearCache
  , LayoutContext

    -- * Preparing text for layout
  , prepare
  , prepareStyled
  , PreparedText (..)
  , MeasuredSegment (..)
  , Span (..)

    -- * Measuring
  , measure

    -- * Styles
  , newStyle
  , Style (..)
  ) where

import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Traversable (mapAccumL)
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import KB.Text.Layout.Analysis (BreakKind (..), Segment (..), analyze)
import KB.Text.Layout.Segmentation qualified as Segmentation
import KB.Text.Shape qualified as TextShape
import KB.Text.Shape.Font qualified as Font

prepare :: LayoutContext -> Style -> Text -> IO PreparedText
prepare ctx style t = prepareStyled ctx [TextSpan style t]

prepareStyled :: LayoutContext -> [Span] -> IO PreparedText
prepareStyled ctx spans = do
  segments <- Vector.fromList . concat <$> traverse spanSegments spans
  pure PreparedText{segments}
  where
    spanSegments = \case
      AtomSpan style label w ->
        pure
          [ MeasuredSegment
              { text = label
              , kind = Atomic
              , width = w
              , style = style.key
              , graphemeWidths = [(Text.length label, w)]
              }
          ]
      TextSpan style t -> do
        advance <- charAdvances ctx style t
        spaceWidth <- measure ctx style " "
        hyphenWidth <- measure ctx style "-"
        let
          prefix = Vector.scanl' (+) 0 advance
          slice off n = prefix Vector.! (off + n) - prefix Vector.! off
          clusterWidths off = \case
            [] -> []
            c : rest ->
              let k = Text.length c
              in (k, slice off k) : clusterWidths (off + k) rest
          segmentAt off seg =
            let
              n = Text.length seg.text
              width = case seg.kind of
                SoftHyphen -> hyphenWidth
                ZeroWidthBreak -> 0
                HardBreak -> 0
                Tab -> fromIntegral n * spaceWidth
                _ -> slice off n
              graphemeWidths = case seg.kind of
                Word -> clusterWidths off (Segmentation.clusters seg.text)
                Glue -> clusterWidths off (Segmentation.clusters seg.text)
                _ -> [(n, width)]
            in
              ( off + n
              , MeasuredSegment{text = seg.text, kind = seg.kind, width, style = style.key, graphemeWidths}
              )
        pure (snd (mapAccumL segmentAt 0 (analyze t)))

data PreparedText = PreparedText
  { segments :: Vector MeasuredSegment
  }

data MeasuredSegment = MeasuredSegment
  { text :: Text
  , kind :: BreakKind
  , width :: Float
  , style :: Int
  , graphemeWidths :: [(Int, Float)]
  }

data Span
  = TextSpan Style Text
  | AtomSpan Style Text Float

charAdvances :: LayoutContext -> Style -> Text -> IO (Vector Float)
charAdvances ctx style t
  | Text.null t = pure Vector.empty
  | otherwise = do
      runs <- TextShape.run ctx.shape (TextShape.withFont_ style.font (TextShape.text_ t))
      contributions <- concat <$> traverse runContributions runs
      pure (Vector.map (* style.scale) (Vector.accum (+) (Vector.replicate n 0) contributions))
  where
    n = Text.length t
    runContributions (run, glyphs) = do
      info <- Font.getFontInfo run.font
      let toGrid = style.grid / fromIntegral info.unitsPerEm
      pure
        [ (g.codepointIndex, fromIntegral g.advanceX * toGrid)
        | g <- glyphs
        , g.codepointIndex >= 0
        , g.codepointIndex < n
        ]

measure :: LayoutContext -> Style -> Text -> IO Float
measure ctx style t
  | Text.null t = pure 0
  | otherwise =
      Map.lookup (style.key, t) <$> readIORef ctx.metrics >>= \case
        Just w -> pure w
        Nothing -> do
          runs <- TextShape.run ctx.shape (TextShape.withFont_ style.font (TextShape.text_ t))
          let runWidth (run, glyphs) = do
                info <- Font.getFontInfo run.font
                let toGrid = style.grid / fromIntegral info.unitsPerEm
                pure (sum [fromIntegral g.advanceX | g <- glyphs] * toGrid)
          w <- (* style.scale) . sum <$> traverse runWidth runs
          modifyIORef' ctx.metrics (Map.insert (style.key, t) w)
          pure w

newStyle :: LayoutContext -> Font.Font -> Float -> IO Style
newStyle ctx font size = do
  info <- Font.getFontInfo font
  key <- atomicModifyIORef' ctx.styleKeys \n -> (n + 1, n)
  pure
    Style
      { key
      , font
      , size
      , em = size * Font.emToCaps info
      , scale = size / fromIntegral info.capitalHeight
      , grid = fromIntegral info.unitsPerEm
      }

data Style = Style
  { key :: Int
  , font :: Font.Font
  , size :: Float
  , em :: Float
  , scale :: Float
  , grid :: Float
  }

createLayoutContext :: TextShape.Context -> IO LayoutContext
createLayoutContext shape = do
  metrics <- newIORef Map.empty
  styleKeys <- newIORef 0
  pure LayoutContext{shape, metrics, styleKeys}

clearCache :: LayoutContext -> IO ()
clearCache ctx = writeIORef ctx.metrics Map.empty

data LayoutContext = LayoutContext
  { shape :: TextShape.Context
  , metrics :: IORef (Map (Int, Text) Float)
  , styleKeys :: IORef Int
  }