Main.hs

module Main (main) where

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 qualified as Break
import KB.Text.Layout.Html qualified as Html
import KB.Text.Layout.Measure (Span (..), Style)
import KB.Text.Layout.Measure qualified as Measure
import KB.Text.Shape qualified as TextShape

unit, gutter, pad :: Float
unit = 11
gutter = 16
pad = 12

main :: IO ()
main = do
  args <- getArgs
  let (headFile, bodyFile) = case args of
        a : b : _ -> (a, b)
        [a] -> (a, a)
        [] -> ("assets/Ubuntu-B.kbts.zst", "assets/NotoSans-Regular.kbts.zst")
  TextShape.withContext \shape -> do
    headFont <- Demo.pushFont shape headFile
    bodyFont <- Demo.pushFont shape bodyFile
    ctx <- Measure.createLayoutContext shape
    heading <- Measure.newStyle ctx headFont 1.4
    body <- Measure.newStyle ctx bodyFont 1.0
    pill <- Measure.newStyle ctx bodyFont 1.0
    printf "heading em %.3f units, body em %.3f units at a shared cap grid\n" heading.em body.em

    let atomPill label = do
          w <- (+ 0.6) <$> Measure.measure ctx pill label
          pure (AtomSpan pill label w)
    v24 <- atomPill "v2.4"
    rc1 <- atomPill "v2.5-rc1"

    prepped <- traverse (Measure.prepareStyled ctx) (corpus heading body v24 rc1)

    let
      cssFont family style extra = Demo.fontCss unit style [family] <> extra
      styleCss k
        | k == heading.key = cssFont "Head" heading ";color:#101828"
        | k == pill.key = cssFont "Body" pill ";background:#e3e8ff;border-radius:6px;text-align:center;color:#3538cd"
        | otherwise = cssFont "Body" body ";color:#475467"
      section cols containerPx =
        let
          colPx = (containerPx - gutter * fromIntegral (cols - 1)) / fromIntegral cols
          textW = (colPx - 2 * pad) / unit
          card prep =
            let
              ranges = Break.layoutGreedy prep textW
              opts = (Demo.options unit textW body (cssFont "Body" body "")){Html.styleCss = styleCss}
            in
              (Html.height opts (length ranges) + 2 * pad, Html.render opts prep ranges)
          (placed, height) = pack cols gutter (map card prepped)
          cardDiv (col, y, h, inner) =
            Demo.at
              (fromIntegral col * (colPx + gutter))
              y
              ( ";width:"
                  <> Demo.px (colPx - 2 * pad)
                  <> ";height:"
                  <> Demo.px (h - 2 * pad)
                  <> ";padding:"
                  <> Demo.px pad
                  <> ";background:#f7f7fb;border-radius:8px"
              )
              inner
        in
          Text.concat
            [ Demo.caption (Text.pack (printf "%d column(s) at %.0fpx, %.1f caps of text per column" cols containerPx textW))
            , Demo.canvas containerPx height (Text.concat (map cardDiv placed))
            ]
      fontFace = Demo.fontFaces [("Head", headFile), ("Body", bodyFile)]
      sections = [section 3 820, section 2 544, section 1 268, section 2 360]
    Text.IO.writeFile "masonry.html" $
      Html.page "kb-text-layout masonry" (fontFace <> Text.intercalate "<hr>" sections)
    printf "wrote masonry.html (%d cards)\n" (length prepped)

pack :: Int -> Float -> [(Float, Text)] -> ([(Int, Float, Float, Text)], Float)
pack cols spacing measured = (reverse placed, maximum ended - spacing)
  where
    (ended, placed) = foldl' place (replicate cols 0, []) measured
    place (heights, acc) (h, inner) =
      let
        (y, col) = minimum (zip heights [0 :: Int ..])
        grown = [if i == col then y + h + spacing else v | (i, v) <- zip [0 ..] heights]
      in
        (grown, (col, y, h, inner) : acc)

corpus :: Style -> Style -> Span -> Span -> [[Span]]
corpus heading body v24 rc1 =
  [
    [ TextSpan heading "Prepare once\n\n"
    , TextSpan body "Every card below is shaped a single time. Each section is a pure re-walk over cached widths: repacking, recolumning, and narrowing never touch the shaper."
    ]
  ,
    [ TextSpan heading "Soft hyphens\n\n"
    , TextSpan body "Antidis\173establish\173ment\173arian\173ism keeps its dignity when the columns tighten."
    ]
  ,
    [ TextSpan heading "Glue\n\n"
    , TextSpan body "Non\160breaking\160spaces hold 100\8239km together no matter how ragged the right edge gets."
    ]
  ,
    [ TextSpan heading "Atoms\n\n"
    , TextSpan body "Some things go as pills: "
    , v24
    , TextSpan body " and "
    , rc1
    , TextSpan body " never split, only wrap whole."
    ]
  ,
    [ TextSpan heading "Emergency breaks\n\n"
    , TextSpan body "Tokens like Donaudampfschifffahrtsgesellschaftskapitaen still fit, one grapheme at a time."
    ]
  ,
    [ TextSpan heading "URLs\n\n"
    , TextSpan body "Long paths wrap at their slashes: /usr/share/fonts/truetype/noto/NotoSans-Regular.ttf needs no spaces."
    ]
  ,
    [ TextSpan heading "Hard breaks\n\n"
    , TextSpan body "Line one.\nLine two.\nLine three keeps its own paragraph."
    ]
  , [TextSpan heading "Short\n\n", TextSpan body "Small card."]
  ,
    [ TextSpan heading "Prose\n\n"
    , TextSpan body "A longer card to unbalance the columns. The packer drops each card into the currently shortest column, so tall neighbors push later cards sideways instead of down."
    ]
  ,
    [ TextSpan heading "Ragged\n\n"
    , TextSpan body "Medium copy, enough for a few lines at most widths."
    ]
  ,
    [ TextSpan heading "Baselines "
    , TextSpan body "share across fonts and sizes: the 1.4-cap bold heading font and the 1.0-cap body font sit on one line "
    , TextSpan heading "without "
    , TextSpan body "stretching the fixed 2-cap line box."
    ]
  ]