Layout.hs

{- | Multiline text layout on top of the bundled fonts.

Text is shaped and measured once, then broken into lines and placed
with the usual cursor conventions from "Codec.Ktx2.Font.Shaping".
Only the shaping needs the font context; breaking and placing are pure,
so the same 'ShapedText' can be laid out again for every new width.

All the widths are in cap-height units, matching the glyph planes.
Multiply by font size to match your projection settings.
-}
module Codec.Ktx2.Font.Layout
  ( -- * Styles
    TextStyle
  , bundleStyle
    -- * Shaping
  , ShapedText
  , shapeText
    -- * Placing
  , placeText
  , LayoutOptions(..)
  , Strategy(..)
  , Align(..)
    -- * All at once
  , layoutText
  , layoutTextWith
    -- * Results
  , PlacedLine(..)
  , placedRuns
  , Break.LineEnd(..)
    -- * Measuring
  , measureText
  , shrinkwrapText
  , clearLayoutCache
  ) where

import Codec.Ktx2.Font qualified as Font
import Codec.Ktx2.Font.Shaping (PlacedGlyph(..))
import Codec.Ktx2.Font.Shaping qualified as Shaping
import Control.Concurrent (withMVar)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Vector (Vector, (!))
import Data.Vector qualified as Vector
import Graphics.MSDF.Atlas.Compact qualified as Atlas
import KB.Text.Layout.Analysis (BreakKind(..))
import KB.Text.Layout.Break qualified as Break
import KB.Text.Layout.Measure qualified as Measure
import KB.Text.Shape.Font (withFontData)

{- | A font bundle prepared for measuring.

The bundle must stay alive for as long as the style is in use,
same as with the stack context itself.
-}
data TextStyle = TextStyle
  { style :: Measure.Style
  , bundle :: Font.Bundle
  , breakHyphen :: Hyphen -- ^ Appended to lines broken inside a word.
  }

bundleStyle :: Font.StackContext a -> Font.Bundle -> IO TextStyle
bundleStyle ctx bundle = do
  style <- withFontData bundle.fontData \font ->
    Measure.newStyle ctx.layout font 1.0
  breakHyphen <- shapeHyphen ctx bundle
  pure TextStyle{style, bundle, breakHyphen}

-- | A @-@ shaped once at the origin, to be moved to the end of a line.
data Hyphen = Hyphen
  { font :: (Shaping.Font, Maybe Shaping.Compact)
  , glyphs :: [PlacedGlyph]
  }

shapeHyphen :: Font.StackContext a -> Font.Bundle -> IO Hyphen
shapeHyphen ctx bundle =
  Shaping.shape (Shaping.initialCursorDown 0) ctx (Shaping.withFont_ bundle (Shaping.text_ "-")) >>= \case
    [(font, glyphs)] -> pure Hyphen{font, glyphs}
    runs -> fail $ "Expected a single run for the hyphen, got " <> show (length runs)

data Strategy
  = Greedy -- ^ Pack each line as full as possible. Fast, good for editable text.
  | Optimal -- ^ Minimize raggedness across the whole paragraph.
  deriving stock (Eq, Show)

data Align = AlignLeft | AlignCenter | AlignRight
  deriving stock (Eq, Show)

data LayoutOptions = LayoutOptions
  { cursor :: Shaping.Cursor
  , strategy :: Strategy
  , align :: Align
  }
  deriving stock (Eq, Show)

{- | Text shaped as a single unbroken line and measured for breaking.

Placing it into lines is pure, see 'placeText'.
-}
data ShapedText = ShapedText
  { prepared :: Measure.PreparedText
  , offsets :: Vector Int -- ^ Codepoint offset of each measured segment, plus the total.
  , advances :: Vector Float -- ^ Pen position before each codepoint, plus the total.
  , fonts :: [(Shaping.Font, Maybe Shaping.Compact)] -- ^ The shaped runs, in pen order.
  , glyphs :: Vector [(Int, PlacedGlyph)] -- ^ Placed glyphs of each codepoint, tagged with their run.
  , breakHyphen :: Hyphen
  }

-- | Shape and measure the text. This is the only step that needs the fonts.
shapeText :: Font.StackContext a -> TextStyle -> Text -> IO ShapedText
shapeText ctx ts t = do
  (prepared, runs) <- withMVar ctx.shapeContext \kbts -> do
    prepared <- Measure.prepare ctx.layout ts.style t
    runs <-
      if Text.null t then
        pure []
      else
        Shaping.unsafeShapeClusters kbts ctx $
          Shaping.withFont_ ts.bundle (Shaping.text_ t)
    pure (prepared, runs)
  let
    size = Text.length t
    clusters =
      [ (run, g)
      | (run, (_font, runGlyphs)) <- zip [0 ..] runs
      , g <- runGlyphs
      , g.cluster >= 0
      , g.cluster < size
      ]
    offsets = Vector.scanl' (\off seg -> off + Text.length seg.text) 0 prepared.segments
    advances = Vector.scanl' (+) 0 $
      Vector.accum (+) (Vector.replicate size 0)
        [ (g.cluster, g.advance)
        | (_run, g) <- clusters
        ]
    glyphs = Vector.map reverse $
      Vector.accum (flip (:)) (Vector.replicate size [])
        [ (g.cluster, (run, placed))
        | (run, g) <- clusters
        , Just placed <- [g.placed]
        ]
  pure ShapedText
    { prepared
    , offsets
    , advances
    , fonts = map fst runs
    , glyphs
    , breakHyphen = ts.breakHyphen
    }

data PlacedLine = PlacedLine
  { runs :: [Shaping.PlacedRun]
  , text :: Text -- ^ What landed on the line, including the trailing @-@ when hyphenated.
  , width :: Float -- ^ Visible line width, excluding trailing spaces.
  , ended :: Break.LineEnd
  , origin :: (Float, Float) -- ^ Line pen start, after alignment.
  }

{- | Break the shaped text to fit the maximum width and place the lines.

Each line is a run of visible pieces shifted as a whole to the line start,
closing up over the invisible segments between them, so the glyphs keep
their shaped positions relative to each other.
-}
placeText :: LayoutOptions -> Float -> ShapedText -> [PlacedLine]
placeText opts maxWidth st =
  zipWith placeLine [0 :: Int ..] ranges
  where
    ranges = case opts.strategy of
      Greedy -> Break.layoutGreedy st.prepared maxWidth
      Optimal -> Break.layoutOptimal st.prepared maxWidth

    segments = st.prepared.segments
    lastSegment = Vector.length segments - 1

    placeLine line range = PlacedLine
      { runs = lineRuns <> hyphenRuns
      , text = Break.materializeLineRange st.prepared range
      , width = range.width
      , ended = range.ended
      , origin = (x0, y)
      }
      where
        x0 = opts.cursor.curX + case opts.align of
          AlignLeft -> 0
          AlignCenter -> max 0 (maxWidth - range.width) / 2
          AlignRight -> max 0 (maxWidth - range.width)
        y = opts.cursor.curY + fromIntegral line * opts.cursor.lineHeight * opts.cursor.ySign

        pieces =
          [ (c0, c1)
          | j <- [range.from.segment .. min range.to.segment lastSegment]
          , visible (segments ! j).kind
          , let c0 = st.offsets ! j + if j == range.from.segment then range.from.grapheme else 0
          , let c1 = if j == range.to.segment then st.offsets ! j + range.to.grapheme else st.offsets ! (j + 1)
          , c0 < c1
          ]

        shifts = case pieces of
          [] -> []
          (c0, _) : _ -> scanl (-) (x0 - st.advances ! c0) gaps

        gaps = zipWith (\(_, c1) (c0, _) -> st.advances ! c0 - st.advances ! c1) pieces (drop 1 pieces)

        pen = foldl' (\_ ((_, c1), dx) -> dx + st.advances ! c1) x0 (zip pieces shifts)

        lineRuns =
          [ (fontAtlas, placed)
          | (run, fontAtlas) <- zip [0 :: Int ..] st.fonts
          , let placed =
                  [ shift dx g
                  | ((c0, c1), dx) <- zip pieces shifts
                  , c <- [c0 .. c1 - 1]
                  , (run', g) <- st.glyphs ! c
                  , run' == run
                  ]
          , not (null placed)
          ]

        hyphenRuns =
          [ (st.breakHyphen.font, map (shift pen) st.breakHyphen.glyphs)
          | range.ended == Break.Hyphenated
          ]

        shift dx g@PlacedGlyph{plane} = g{plane = Atlas.moveBox dx y plane}

    visible = \case
      SoftHyphen -> False
      HardBreak -> False
      ZeroWidthBreak -> False
      _ -> True

{- | Break text to fit the maximum width, then shape and place the lines.

Left-aligned greedy layout. Use 'layoutTextWith' for more options.
-}
layoutText :: Shaping.Cursor -> Font.StackContext a -> TextStyle -> Float -> Text -> IO [PlacedLine]
layoutText cursor = layoutTextWith LayoutOptions{cursor, strategy = Greedy, align = AlignLeft}

-- | 'shapeText' followed by 'placeText'.
layoutTextWith :: LayoutOptions -> Font.StackContext a -> TextStyle -> Float -> Text -> IO [PlacedLine]
layoutTextWith opts ctx ts maxWidth t =
  placeText opts maxWidth <$> shapeText ctx ts t

-- | Flatten the lines for rendering.
placedRuns :: [PlacedLine] -> [Shaping.PlacedRun]
placedRuns = concatMap (.runs)

-- | Measure text width as a single unbroken line.
measureText :: Font.StackContext a -> TextStyle -> Text -> IO Float
measureText ctx ts t =
  withMVar ctx.shapeContext \_kbts ->
    Measure.measure ctx.layout ts.style t

-- | The smallest maximum width that doesn't add more lines than the given one.
shrinkwrapText :: Font.StackContext a -> TextStyle -> Float -> Text -> IO Float
shrinkwrapText ctx ts maxWidth t =
  withMVar ctx.shapeContext \_kbts -> do
    prep <- Measure.prepare ctx.layout ts.style t
    pure $ Break.shrinkwrap prep maxWidth

-- | Drop the measurement caches, e.g. after evicting some fonts.
clearLayoutCache :: Font.StackContext a -> IO ()
clearLayoutCache ctx = Measure.clearCache ctx.layout