Main.hs

module Main (main) where

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

import Demo qualified

import KB.Text.Layout.Break (Cursor (..))
import KB.Text.Layout.Break qualified as Break
import KB.Text.Layout.Html qualified as Html
import KB.Text.Layout.Measure (Span (..))
import KB.Text.Layout.Measure qualified as Measure
import KB.Text.Shape qualified as TextShape

sample :: Text
sample =
  Text.concat
    [ "Layout in the pretext style: prepare once, then lay out at any width without touching the shaper. "
    , "Soft hy\173phen\173ation and non\160breaking\160spaces are modeled, and Antidisestablishmentarianism overflows gracefully.\n"
    , "A second paragraph after a hard line break."
    ]

main :: IO ()
main = do
  args <- getArgs
  let (bodyFile, accentFile) = case args of
        a : b : _ -> (a, b)
        [a] -> (a, a)
        [] ->
          ( "assets/Ubuntu-R.kbts.zst"
          , "assets/Ubuntu-R.kbts.zst"
          )
  TextShape.withContext \shape -> do
    bodyFont <- Demo.pushFont shape bodyFile
    accentFont <- Demo.pushFont shape accentFile
    ctx <- Measure.createLayoutContext shape
    body <- Measure.newStyle ctx bodyFont 1.0
    accent <- Measure.newStyle ctx accentFont 1.0

    let pxSize = 11 :: Float

    prepared <- Measure.prepare ctx body sample
    for_ [480, 260, 90 :: Float] \maxWidth -> do
      let
        ranges = Break.layoutGreedy prepared (maxWidth / pxSize)
        stats = Break.layoutStats ranges
      printf "== %.0fpx -> %d lines, widest %.2f ==\n" maxWidth stats.lineCount (stats.maxLineWidth * pxSize)
      for_ ranges \line ->
        printf "%8.2f  %s\n" (line.width * pxSize) (Text.unpack (Break.materializeLineRange prepared line))

    pillWidth <- (+ 1.5) <$> Measure.measure ctx accent "v2.4"
    rich <-
      Measure.prepareStyled
        ctx
        [ TextSpan body "Release "
        , AtomSpan accent "[v2.4]" pillWidth
        , TextSpan body " ships styled spans and atomic pills next to plain text runs."
        ]
    printf "== styled + atomic at 180px ==\n"
    for_ (Break.layoutGreedy rich (180 / pxSize)) \line ->
      printf "%8.2f  %s\n" (line.width * pxSize) (Text.unpack (Break.materializeLineRange rich line))

    printf "== routed around an obstacle (per-line widths) ==\n"
    let
      route :: [Float] -> Cursor -> IO ()
      route ws cursor = case ws of
        [] -> pure ()
        w : rest ->
          case Break.layoutNextLineRange prepared (w / pxSize) cursor of
            Nothing -> pure ()
            Just (line, next) -> do
              printf "%6.0f | %s\n" w (Text.unpack (Break.materializeLineRange prepared line))
              maybe (pure ()) (route rest) next
    route (cycle [300, 220, 160, 160, 220, 300 :: Float]) (Cursor 0 0)

    let
      cssFont u style = Demo.fontCss u style ["Demo"]
      styleCss u k
        | k == accent.key = cssFont u accent <> ";background:#e8ecff;border-radius:6px;text-align:center"
        | otherwise = cssFont u body
      options u w = (Demo.options u w body (cssFont u body)){Html.styleCss = styleCss u}
      block prep w = Html.render (options pxSize (w / pxSize)) prep (Break.layoutGreedy prep (w / pxSize))
      onceRanges = Break.layoutGreedy prepared (260 / pxSize)
      scaled u = Html.render (options u (260 / pxSize)) prepared onceRanges
      fontFace = Demo.fontFaces [("Demo", bodyFile)]
      blocks =
        map (block prepared) [480, 260, 90]
          <> [block rich 180]
          <> [Demo.caption "same line ranges, laid out once, rendered at unit 8 / 11 / 14"]
          <> map scaled [8, 11, 14]
    Text.IO.writeFile "demo.html" $
      Html.page "kb-text-layout demo" (fontFace <> Text.intercalate "<hr>" blocks)
    printf "wrote demo.html\n"