Main.hs

module Main (main) where

import Data.List (sortOn)
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 (..), LineRange)
import KB.Text.Layout.Break qualified as Break
import KB.Text.Layout.Html qualified as Html
import KB.Text.Layout.Measure qualified as Measure
import KB.Text.Shape qualified as TextShape

unit, lineHeight, canvasW, margin, minLine :: Float
unit = 11
lineHeight = 2
canvasW = 560
margin = 8
minLine = 60

data Obstacle
  = Rect Float Float Float Float
  | Circle Float Float Float

obstacles :: [Obstacle]
obstacles =
  [ Rect 380 40 180 120
  , Circle 110 420 105
  , Circle 280 800 120
  ]

corpus :: Text
corpus =
  Text.unlines
    [ "Text that routes around obstacles is the signature move of editorial layout: pull quotes, images, and decorative figures push the prose aside, and the prose closes back around them as if nothing happened. The engine side of this is deliberately small. Every call to the line stepper takes its own width, so the geometry lives entirely in the caller: intersect each line's vertical band with the obstacles, subtract the blocked intervals from the column, and hand the widest surviving gap to the layout engine."
    , ""
    , "Rectangles block a constant horizontal range for every band they touch. Circles are more interesting: the blocked half-width follows the chord of the circle at the band's nearest point, so lines tighten gradually as they approach the widest part of the circle and relax again past it, producing the smooth waisted contour that makes wrapped text look deliberate rather than accidental."
    , ""
    , "Justification sharpens the effect. A ragged edge hides the shape of the column; stretching every wrapped line to exactly the width of its gap makes both margins of the routed text follow the obstacle outlines, and the blank bands where an obstacle spans the whole column read as intentional white space. Prepare once, then let every line pick its own width: the same prepared text would reflow instantly around obstacles dragged to new positions."
    , ""
    , "The picking policy is the one real decision left to the caller. This demo takes the widest surviving gap in each band, and the pillar planted mid-column below shows the consequence: each band offers two gaps, only one of them gets the line, and the other flank reads as blank margin — the stepper never splits a line across an obstacle. An editorial engine might prefer a consistent side, or route parallel columns through both gaps independently. None of that touches the engine: the stepper only ever sees a width."
    , ""
    , "With the circle dead on the column's axis the two gaps shrink in lockstep and every comparison is a tie, so the tiebreak settles the whole passage onto one flank; nudge the circle off-centre or let another obstacle lean on one side, and the winner can flip band by band instead. Bands squeezed too narrow on both flanks produce no line at all, and the cursor simply carries the prose to the next band with room to breathe."
    ]

blockedAt :: Float -> Float -> Obstacle -> [(Float, Float)]
blockedAt bandTop bandBottom = \case
  Rect x y w h
    | bandBottom > y - margin && bandTop < y + h + margin -> [(x - margin, x + w + margin)]
    | otherwise -> []
  Circle cx cy r ->
    let
      r' = r + margin
      dy
        | cy < bandTop = bandTop - cy
        | cy > bandBottom = cy - bandBottom
        | otherwise = 0
    in
      if dy >= r' then
        []
      else
        let half = sqrt (r' * r' - dy * dy)
        in [(cx - half, cx + half)]

freeAt :: Float -> Float -> [(Float, Float)]
freeAt bandTop bandBottom = go 0 blocked
  where
    blocked = sortOn fst (concatMap (blockedAt bandTop bandBottom) obstacles)
    go x = \case
      []
        | x < canvasW -> [(x, canvasW)]
        | otherwise -> []
      (lo, hi) : rest
        | lo > x -> (x, min lo canvasW) : go (max x hi) rest
        | otherwise -> go (max x hi) rest

widest :: [(Float, Float)] -> Maybe (Float, Float)
widest = \case
  [] -> Nothing
  xs -> Just (last (sortOn (\(lo, hi) -> hi - lo) xs))

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

    prep <- Measure.prepare ctx body (Demo.softHyphenate corpus)
    let
      cssFont = Demo.fontCss unit body ["Body"]
      optsFor w = (Demo.options unit w body cssFont){Html.justify = True}
      route :: Int -> Cursor -> [(Int, Float, Float, LineRange)]
      route band cursor
        | band > 200 = []
        | otherwise =
            let
              bandTop = fromIntegral band * lineHeight * unit
              bandBottom = bandTop + lineHeight * unit
            in
              case widest (freeAt bandTop bandBottom) of
                Just (lo, hi)
                  | hi - lo >= minLine ->
                      case Break.layoutNextLineRange prep ((hi - lo) / unit) cursor of
                        Nothing -> []
                        Just (line, next) ->
                          (band, lo, (hi - lo) / unit, line)
                            : maybe [] (route (band + 1)) next
                _ -> route (band + 1) cursor
      routed = route 0 (Cursor 0 0)
      lineDiv (band, lo, w, line) =
        Demo.at
          lo
          ((fromIntegral band * lineHeight + lineHeight - body.size) * unit)
          ""
          (Html.render (optsFor w) prep [line])
      obstacleDiv = \case
        Rect x y w h ->
          Demo.at x y (";width:" <> Demo.px w <> ";height:" <> Demo.px h <> ";background:#e8ecff;border:1px solid #b9c6f5;border-radius:6px") ""
        Circle cx cy r ->
          Demo.at (cx - r) (cy - r) (";width:" <> Demo.px (2 * r) <> ";height:" <> Demo.px (2 * r) <> ";background:#ffe9d6;border:1px solid #f2c49b;border-radius:50%") ""

      totalH = case routed of
        [] -> 0
        _ -> (fromIntegral (maximum [b | (b, _, _, _) <- routed]) + 1) * lineHeight * unit
      fontFace = Demo.fontFaces [("Body", fontFile)]
      canvas = Demo.canvas canvasW totalH (Text.concat (map obstacleDiv obstacles) <> Text.concat (map lineDiv routed))
    Text.IO.writeFile "obstacles.html" $
      Html.page "kb-text-layout obstacle routing" (fontFace <> canvas)
    printf "wrote obstacles.html (%d lines over %d bands)\n" (length routed) (1 + maximum [b | (b, _, _, _) <- routed])