Main.hs

module Main (main) where

import Data.Foldable (for_)
import Data.Text qualified as Text
import Data.Text.IO qualified as Text.IO
import Data.Vector qualified as Vector
import System.Environment (getArgs)
import Text.Printf (printf)

import Demo qualified

import KB.Text.Layout.Analysis (BreakKind (..))
import KB.Text.Layout.Break (LineEnd (..), LineRange)
import KB.Text.Layout.Break qualified as Break
import KB.Text.Layout.Html qualified as Html
import KB.Text.Layout.Measure (PreparedText)
import KB.Text.Layout.Measure qualified as Measure
import KB.Text.Shape qualified as TextShape

unit, lineHeight, colW :: Float
unit = 11
lineHeight = 2
colW = 300

gapsOf :: PreparedText -> Float -> LineRange -> [(Float, Float)]
gapsOf prep target line
  | line.from.grapheme /= 0 || line.to.grapheme /= 0 = []
  | otherwise = go 0 line.from.segment []
  where
    segs = prep.segments
    exempt = line.ended == HardBroken || line.ended == Finished
    separators =
      sum
        [ Text.length s.text
        | j <- [line.from.segment .. line.to.segment - 1]
        , let s = segs Vector.! j
        , s.kind == Space
        ]
    extraPerChar
      | exempt || separators == 0 = 0
      | otherwise = (target - line.width) / fromIntegral separators
    go x j acc
      | j >= line.to.segment = reverse acc
      | otherwise =
          let s = segs Vector.! j
          in case s.kind of
               Space ->
                 let x' = x + s.width + extraPerChar * fromIntegral (Text.length s.text)
                 in go x' (j + 1) ((x, x') : acc)
               SoftHyphen -> go x (j + 1) acc
               HardBreak -> go x (j + 1) acc
               ZeroWidthBreak -> go x (j + 1) acc
               _ -> go (x + s.width) (j + 1) acc

riverJoins :: [[(Float, Float)]] -> Int
riverJoins rows = sum (zipWith joins rows (drop 1 rows))
  where
    joins above below = length [() | a <- above, b <- below, fst a < snd b, fst b < snd a]

widestGap :: [[(Float, Float)]] -> Float
widestGap rows = maximum (0 : [hi - lo | row <- rows, (lo, hi) <- row])

main :: IO ()
main = do
  args <- getArgs
  let fontFile = case args of
        a : _ -> a
        [] -> "assets/NotoSans-Regular.kbts.zst"
  TextShape.withContext \shape -> do
    font <- Demo.pushFont shape fontFile
    ctx <- Measure.createLayoutContext shape
    body <- Measure.newStyle ctx font 1.0

    prepPlain <- Measure.prepare ctx body Demo.rivers
    prepHyph <- Measure.prepare ctx body (Demo.softHyphenate Demo.rivers)
    let
      w = colW / unit
      variants =
        [ ("engine: greedy", prepPlain, Break.layoutGreedy prepPlain w)
        , ("engine: greedy + hyphenation", prepHyph, Break.layoutGreedy prepHyph w)
        , ("engine: Knuth-Plass", prepPlain, Break.layoutOptimal prepPlain w)
        , ("engine: Knuth-Plass + hyphenation", prepHyph, Break.layoutOptimal prepHyph w)
        ]
      cssFont = Demo.fontCss unit body ["Body"]
      opts = (Demo.options unit w body cssFont){Html.justify = True}
      metrics (_, prep, ranges) =
        let rows = map (gapsOf prep w) ranges
        in (riverJoins rows, widestGap rows * unit)
      column title content = "<div>" <> Demo.captionWidth colW title <> content <> "</div>"
      engineColumn v@(name, prep, ranges) =
        let (joins, widest) = metrics v
        in column
             (name <> Text.pack (printf ": %d river joins, widest gap %.1fpx" joins widest))
             (Html.render opts prep ranges)
      native =
        Text.concat
          [ "<div style=\"width:" <> Text.pack (printf "%.2fpx" colW)
          , ";text-align:justify;white-space:pre-wrap"
          , ";line-height:" <> Text.pack (printf "%.2fpx" (lineHeight * unit))
          , ";text-box-trim:trim-both;text-box-edge:cap alphabetic"
          , ";" <> Html.escape cssFont <> "\">"
          , Html.escape Demo.rivers
          , "</div>"
          ]
      fontFace = Demo.fontFaces [("Body", fontFile)]
      columns =
        Text.concat
          [ "<div style=\"display:flex;gap:28px;align-items:start\">"
          , column "browser: native text-align justify (breaks match engine greedy)" native
          , Text.concat (map engineColumn variants)
          , "</div>"
          ]
    for_ variants \v@(name, _, ranges) -> do
      let (joins, widest) = metrics v
      printf "%-34s %2d lines, %2d river joins, widest gap %5.1fpx\n" (Text.unpack name) (length ranges) joins widest
    Text.IO.writeFile "justify.html" $
      Html.page "kb-text-layout justification" (fontFace <> columns)
    printf "wrote justify.html\n"