diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `kb-text-layout` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## 0.1.0.0 - 2026-08-15 + +Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2026 IC Rainbow + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,81 @@ +# kb-text-layout + +Multiline text measurement & layout on top of [kb-text-shape], inspired by [pretext]. +Prepare a text once, then lay it out at any width. + +[kb-text-shape]: https://github.com/dpwiz/kb-text-shape +[pretext]: https://github.com/chenglou/pretext + +```haskell +import Data.Text.IO qualified as Text +import KB.Text.Layout.Break qualified as Break +import KB.Text.Layout.Measure qualified as Measure +import KB.Text.Shape qualified as KBTS + +main :: IO () +main = + KBTS.withContext \shape -> do + font <- KBTS.pushFontFromFile shape "demos/assets/Ubuntu-R.ttf" 0 + + ctx <- Measure.createLayoutContext shape + style <- Measure.newStyle ctx font 1.0 + prepared <- Measure.prepare ctx style "Soft hy\173phen\173ation and non\160breaking\160spaces." + + let maxWidth = 24 + let ranges = Break.layoutGreedy prepared maxWidth + putStrLn $ "Stats: " <> show (Break.layoutStats ranges) + putStrLn "" + -- Stats: LayoutStats {lineCount = 2, maxLineWidth = 13.909091} + + putStrLn "Ranges:" + mapM_ print ranges + -- LineRange {from = Cursor {segment = 0, grapheme = 0}, to = Cursor {segment = 9, grapheme = 0}, width = 13.909091, ended = Wrapped} + -- LineRange {from = Cursor {segment = 10, grapheme = 0}, to = Cursor {segment = 15, grapheme = 0}, width = 13.470421, ended = Finished} + putStrLn "" + + putStrLn "Lines:" + let laidout = map (Break.materializeLineRange prepared) ranges + -- Soft hyphenation and + -- non breaking spaces. + mapM_ Text.putStrLn laidout +``` + +Everything after `prepare` is pure: relayout at another width is a fold over cached widths, with no shaper calls. + +## Units + +To make sizes comparable across different fonts layout space is cap-height-normalized. +`newStyle ctx font 1.0` scales the font so a capital `H` is exactly 1.0 layout units tall. +`Style.em` carries the em size in the same units for renderers that need CSS or pixel sizes. + +Line height is a caller-chosen number of cap units. +Ascenders and descenders overhang the fixed line box, so vertical font metrics never enter layout. + +> ⚠️ Fonts without a cap-height metric fail at load time. + +## Demos + +The demo executables live in `demos/` behind the `demos` package flag (off by default). + +- `demo`: basic layout showing a ragged vs justified comparison. +- `masonry`: packs a card corpus by shortest column. +- `justify`: five columns of the same text at 300px. + * Browser's own `text-align: justify`. + * Greedy (fastest). + * Greedy with soft hyphens from the `hyphenation` package. + * `layoutOptimal` (slowest, for extra nice). + * `layoutOptimal` plus hyphenation. +- `obstacles`: Routes justified text around exclusion shapes. + +Use `make demos` to run everything and rebuild the HTML pages. + +Use `stack bench` to see the relative cost of each layout. + +## Limitations + +- Grapheme clusters come from kb-text-shape's `KB.Text.Shape.Segmentation`, so combining marks, Hangul jamo, flag pairs, and ZWJ emoji stay whole through emergency breaks and slicing. kbts skips UAX #29 GB11 and LB8a, so the wrapper refuses to cut, or break, adjacent to a ZWJ. +- No dictionary-based segmenter for Thai/Lao/Khmer/Myanmar; no algorithmic breaker provides one. +- Spans are shaped whole, so widths reflect joined and kerned forms. At a chosen break, a line that ends mid-join renders letterforms whose widths differ slightly from the joined measurement; a re-shape refinement pass does not exist yet. +- Pretext's preprocessing rules are largely subsumed by kbts line breaking. `Analysis` adds the two missing tailorings: URL query-separator splits scoped to slash-containing tokens, and en/em-dash digit-range suppression. +- `prepare` needs the open `TextShape.Context`; the `PreparedText` does not. Prepared texts can be laid out, sliced, and emergency-broken after the context closes. +- `pushFontFromFile` and `pushFontFromMemory` reject missing files and fonts without `unitsPerEm` or a cap-height metric at load time, so bad fonts fail fast. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,51 @@ +module Main (main) where + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Test.Tasty.Bench (bcompare, bench, bgroup, defaultMain, nf, whnf, whnfIO) +import Text.Printf (printf) + +import Demo qualified + +import KB.Text.Layout.Break qualified as Break +import KB.Text.Layout.Measure qualified as Measure +import KB.Text.Shape qualified as TextShape + +main :: IO () +main = + TextShape.withContext \shape -> do + font <- TextShape.pushFontFromFile shape "demos/assets/NotoSans-Regular.ttf" 0 + ctx <- Measure.createLayoutContext shape + body <- Measure.newStyle ctx font 1.0 + hyphenated <- evaluate (force (Demo.softHyphenate Demo.rivers)) + prepPlain <- Measure.prepare ctx body Demo.rivers + prepHyph <- Measure.prepare ctx body hyphenated + let + atPx px = px / 11 + runAndMeasure layoutF prep w = (Break.layoutStats (layoutF prep w)).maxLineWidth + vsGreedy = bcompare "$NF == \"greedy\"" + printf + "%d segments plain, %d segments hyphenated\n" + (length prepPlain.segments) + (length prepHyph.segments) + defaultMain + [ bgroup + "layout at 300px" + [ bench "greedy" (whnf (runAndMeasure Break.layoutGreedy prepPlain) (atPx 300)) + , vsGreedy $ bench "greedy + hyphenation" (whnf (runAndMeasure Break.layoutGreedy prepHyph) (atPx 300)) + , vsGreedy $ bench "Knuth-Plass" (whnf (runAndMeasure Break.layoutOptimal prepPlain) (atPx 300)) + , vsGreedy $ bench "Knuth-Plass + hyphenation" (whnf (runAndMeasure Break.layoutOptimal prepHyph) (atPx 300)) + ] + , bgroup + "re-layout across widths" + [ bench (name <> " " <> show px <> "px") (whnf (force layoutF prepPlain) (atPx (fromIntegral px))) + | (name, layoutF) <- [("greedy", Break.layoutGreedy), ("Knuth-Plass", Break.layoutOptimal)] + , px <- [150, 300, 600 :: Int] + ] + , bgroup + "prepare (cached metrics)" + [ bench "softHyphenate" (nf Demo.softHyphenate Demo.rivers) + , bench "prepare plain" (whnfIO (Measure.prepare ctx body Demo.rivers)) + , bench "prepare hyphenated" (whnfIO (Measure.prepare ctx body hyphenated)) + ] + ] diff --git a/demos/bubbles/Main.hs b/demos/bubbles/Main.hs new file mode 100644 --- /dev/null +++ b/demos/bubbles/Main.hs @@ -0,0 +1,104 @@ +module Main (main) where + +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, maxBubble, containerW, pad, gap :: Float +unit = 11 +maxBubble = 18 +containerW = 26 +pad = 9 +gap = 10 + +data Side = Them | Us + +main :: IO () +main = do + args <- getArgs + let (bodyFile, emojiFile) = case args of + a : b : _ -> (a, b) + [a] -> (a, a) + [] -> + ( "assets/NotoSans-Regular.kbts.zst" + , "assets/NotoColorEmoji.kbts.zst" + ) + TextShape.withContext \shape -> do + bodyFont <- Demo.pushFont shape bodyFile + _emojiFont <- Demo.pushFont shape emojiFile + ctx <- Measure.createLayoutContext shape + body <- Measure.newStyle ctx bodyFont 1.0 + mark <- Measure.newStyle ctx bodyFont 1.0 + + pill <- AtomSpan mark "v2.4" . (+ 0.6) <$> Measure.measure ctx mark "v2.4" + prepped <- traverse (traverse (Measure.prepareStyled ctx)) (conversation body pill) + + let + cssFont style = Demo.fontCss unit style ["Body", "Emoji"] + styleCss k + | k == mark.key = cssFont mark <> ";background:#fff3a8;border-radius:4px;text-align:center" + | otherwise = cssFont body + bubble (side, prep) = + let + w = Break.shrinkwrap prep maxBubble + ranges = Break.layoutGreedy prep w + opts = (Demo.options unit w body (cssFont body)){Html.styleCss = styleCss} + h = Html.height opts (length ranges) + 2 * pad + boxW = w * unit + 2 * pad + (x, bg, fg) = case side of + Them -> (0 :: Float, "#f0f0f3", "#1f2430") + Us -> (containerW * unit - boxW, "#dceaff", "#103a75") + in + ( h + , \y -> + Demo.at + x + y + ( ";width:" + <> Demo.px (boxW - 2 * pad) + <> ";height:" + <> Demo.px (h - 2 * pad) + <> ";padding:" + <> Demo.px pad + <> ";background:" + <> bg + <> ";color:" + <> fg + <> ";border-radius:12px" + ) + (Html.render opts prep ranges) + ) + stack y = \case + [] -> ([], y - gap) + (h, render) : rest -> + let (divs, total) = stack (y + h + gap) rest + in (render y : divs, total) + (bubbleDivs, totalH) = stack 0 (map bubble prepped) + fontFace = Demo.fontFaces [("Body", bodyFile), ("Emoji", emojiFile)] + container = Demo.canvas (containerW * unit) totalH (Text.concat bubbleDivs) + Text.IO.writeFile "bubbles.html" $ + Html.page "kb-text-layout bubbles" (fontFace <> container) + printf "wrote bubbles.html (%d bubbles)\n" (length prepped) + +conversation :: Style -> Span -> [(Side, [Span])] +conversation body pill = + [ (Them, [t "Hey! Does the engine handle emoji families like \128104\8205\128105\8205\128103 yet?"]) + , (Us, [t "Yep. They measure as one cluster and never split across lines \128077"]) + , (Them, [t "And long words? Antidis\173establish\173ment\173arian\173ism used to blow up the bubbles."]) + , (Us, [t "Soft hy\173phens and grapheme emergency breaks both work, and non\160breaking\160spaces hold on."]) + , (Them, [t "Where does the font live? /usr/share/fonts/truetype/noto/NotoSans-Regular.ttf"]) + , (Us, [t "Shipping it in ", pill, t " \8212 bubbles shrinkwrap to their widest line, so short replies stay snug."]) + , (Them, [t "ok"]) + , (Us, [t "\127881"]) + ] + where + t = TextSpan body diff --git a/demos/demo/Main.hs b/demos/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demos/demo/Main.hs @@ -0,0 +1,97 @@ +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 "
" blocks) + printf "wrote demo.html\n" diff --git a/demos/justify/Main.hs b/demos/justify/Main.hs new file mode 100644 --- /dev/null +++ b/demos/justify/Main.hs @@ -0,0 +1,118 @@ +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 = "
" <> Demo.captionWidth colW title <> content <> "
" + 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 + [ "
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 + , "
" + ] + fontFace = Demo.fontFaces [("Body", fontFile)] + columns = + Text.concat + [ "
" + , column "browser: native text-align justify (breaks match engine greedy)" native + , Text.concat (map engineColumn variants) + , "
" + ] + 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" diff --git a/demos/lib/Demo.hs b/demos/lib/Demo.hs new file mode 100644 --- /dev/null +++ b/demos/lib/Demo.hs @@ -0,0 +1,121 @@ +module Demo + ( -- * Sample text + rivers + , softHyphenate + + -- * Fonts + , pushFont + , fontFaces + , fontCss + + -- * HTML building blocks + , options + , canvas + , at + , px + , caption + , captionWidth + ) where + +import Codec.Compression.Zstd qualified as Zstd +import Data.ByteString qualified as ByteString +import Data.Char (isLetter) +import Data.List (isSuffixOf) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Text.Hyphenation (english_US, hyphenate) +import Text.Printf (printf) + +import KB.Text.Layout.Html qualified as Html +import KB.Text.Layout.Measure (Style) +import KB.Text.Layout.Measure qualified +import KB.Text.Shape qualified as TextShape + +rivers :: Text +rivers = + Text.unlines + [ "The relationship between typographic colour and reading comfort has been studied extensively since the early twentieth century. When lines of justified text contain excessive inter-word spacing, the eye perceives pale horizontal streaks — \"rivers\" — that cut vertically through the paragraph, disrupting the smooth lateral scanning motion that skilled readers depend upon. These rivers are not merely an aesthetic blemish; they constitute a measurable impediment to reading speed and comprehension." + , "" + , "Traditional typesetting systems addressed this problem through a combination of techniques: hyphenation dictionaries that permitted words to break at syllable boundaries, letterspacing adjustments that distributed small amounts of additional space between individual characters, and — most significantly — global optimization algorithms that evaluated thousands of possible line-break combinations to find the arrangement minimizing total spacing deviation across the entire paragraph." + , "" + , "The Knuth-Plass algorithm, developed by Donald Knuth and Michael Plass for the TeX typesetting system in 1981, remains the gold standard for paragraph optimization. Rather than greedily filling each line from left to right, the algorithm constructs a graph of all feasible breakpoints and finds the shortest path — the combination of breaks that produces the most uniform spacing throughout. Even a simplified implementation produces dramatically better results than the greedy approach used by web browsers and most word processors." + , "" + , "Modern CSS justification operates on a strictly greedy, line-by-line basis: the browser fills each line with as many words as will fit, then distributes the remaining space uniformly between words. This approach requires no lookahead and executes quickly, but it produces wildly inconsistent spacing — particularly in narrow columns where a single long word can force enormous gaps across the preceding line. The result: rivers of white space that would have horrified any compositor working with metal type." + ] + +softHyphenate :: Text -> Text +softHyphenate = Text.concat . map piece . Text.groupBy sameClass + where + sameClass a b = isLetter a == isLetter b + piece run + | Text.length run >= 5 + , isLetter (Text.head run) = + Text.intercalate "\xAD" (map Text.pack (hyphenate english_US (Text.unpack run))) + | otherwise = run + +pushFont :: TextShape.Context -> FilePath -> IO TextShape.Font +pushFont ctx path + | ".zst" `isSuffixOf` path = do + compressed <- ByteString.readFile path + case Zstd.decompress compressed of + Zstd.Decompress bytes -> TextShape.pushFontFromMemory ctx bytes 0 + failed -> error (path <> ": " <> show failed) + | otherwise = TextShape.pushFontFromFile ctx path 0 + +fontFaces :: [(Text, String)] -> Text +fontFaces faces = + Text.concat $ + [""] + +-- | Point browsers to the TTF font source. +faceUrl :: String -> Text +faceUrl path = case mapMaybe strip [".kbts.zst", ".kbts"] of + base : _ -> base <> ".ttf" + [] -> packed + where + strip suffix = Text.stripSuffix suffix packed + packed = Text.pack path + +fontCss :: Float -> Style -> [Text] -> Text +fontCss unit style families = + Text.pack (printf "font:%.2fpx " (style.em * unit)) + <> Text.concat ["\"" <> family <> "\"," | family <- families] + <> "sans-serif" + +options :: Float -> Float -> Style -> Text -> Html.Options +options unit width base css = + Html.Options + { width + , lineHeight = 2 + , unit + , baseCap = base.size + , justify = False + , baseCss = css + , styleCss = const css + } + +canvas :: Float -> Float -> Text -> Text +canvas w h inner = + "
px w <> ";height:" <> px h <> "\">" <> inner <> "
" + +at :: Float -> Float -> Text -> Text -> Text +at x y extra inner = + "
px x <> ";top:" <> px y <> extra <> "\">" <> inner <> "
" + +px :: Float -> Text +px v = Text.pack (printf "%.2fpx" v) + +caption :: Text -> Text +caption = captionStyled "" + +captionWidth :: Float -> Text -> Text +captionWidth w = captionStyled (Text.pack (printf ";width:%.0fpx" w)) + +captionStyled :: Text -> Text -> Text +captionStyled extra t = + "

extra <> "\">" <> Html.escape t <> "

" diff --git a/demos/lib/KB/Text/Layout/Html.hs b/demos/lib/KB/Text/Layout/Html.hs new file mode 100644 --- /dev/null +++ b/demos/lib/KB/Text/Layout/Html.hs @@ -0,0 +1,100 @@ +module KB.Text.Layout.Html + ( -- * Rendering laid-out lines + render + , Options (..) + , height + + -- * Page scaffolding + , page + , escape + ) where + +import Data.Text (Text) +import Data.Text qualified as Text +import Text.Printf (printf) + +import KB.Text.Layout.Break (LineEnd (..), LineRange (..), LineSlice (..), materializeSlices) +import KB.Text.Layout.Measure (PreparedText) + +render :: Options -> PreparedText -> [LineRange] -> Text +render opts prepared ranges = + Text.concat $ + concat + [ + [ "
px opts.width + , ";height:" <> pxAbs (height opts (length ranges)) + , "\">" + ] + , zipWith renderLine [0 :: Int ..] ranges + , ["
"] + ] + where + px v = pxAbs (v * opts.unit) + renderLine i range = + Text.concat $ + concat + [ + [ "
px (fromIntegral i * opts.lineHeight) + , ";text-box-trim:trim-both;text-box-edge:cap alphabetic" + , ";white-space:pre" <> spacing <> ";" <> escape opts.baseCss <> "\">" + ] + , map renderSlice slices + , ["
"] + ] + where + slices = materializeSlices prepared range + separators = sum [Text.count " " s.text + Text.count "\xA0" s.text | s <- slices, not s.atom] + slack = opts.width - range.width + spacing + | opts.justify + , range.ended /= HardBroken + , range.ended /= Finished + , abs slack > 1e-4 + , separators > 0 = + ";word-spacing:" <> pxAbs (slack * opts.unit / fromIntegral separators) + | otherwise = "" + renderSlice slice = + Text.concat + [ " px slice.width <> ";word-spacing:normal;" else "" + , escape (opts.styleCss slice.style) + , "\">" + , escape slice.text + , "" + ] + +data Options = Options + { width :: Float + , lineHeight :: Float + , unit :: Float + , baseCap :: Float + , justify :: Bool + , baseCss :: Text + , styleCss :: Int -> Text + } + +height :: Options -> Int -> Float +height opts lineCount + | lineCount <= 0 = 0 + | otherwise = (fromIntegral (lineCount - 1) * opts.lineHeight + opts.baseCap) * opts.unit + +pxAbs :: Float -> Text +pxAbs v = Text.pack (printf "%.2fpx" v) + +page :: Text -> Text -> Text +page title body = + Text.concat + [ "" + , escape title + , "" + , body + , "" + ] + +escape :: Text -> Text +escape = Text.concatMap \case + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + c -> Text.singleton c diff --git a/demos/masonry/Main.hs b/demos/masonry/Main.hs new file mode 100644 --- /dev/null +++ b/demos/masonry/Main.hs @@ -0,0 +1,147 @@ +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 "
" 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." + ] + ] diff --git a/demos/obstacles/Main.hs b/demos/obstacles/Main.hs new file mode 100644 --- /dev/null +++ b/demos/obstacles/Main.hs @@ -0,0 +1,138 @@ +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]) diff --git a/kb-text-layout.cabal b/kb-text-layout.cabal new file mode 100644 --- /dev/null +++ b/kb-text-layout.cabal @@ -0,0 +1,319 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.39.6. +-- +-- see: https://github.com/sol/hpack + +name: kb-text-layout +version: 0.1.0.0 +synopsis: Multiline text measurement & layout. +category: Text +author: IC Rainbow +maintainer: aenor.realm@gmail.com +copyright: 2026 IC Rainbow +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://gitlab.com/dpwiz/text-layout + +flag demos + description: Build the demo executables and benchmarks. + manual: True + default: False + +library + exposed-modules: + KB.Text.Layout.Analysis + KB.Text.Layout.Break + KB.Text.Layout.Measure + KB.Text.Layout.Segmentation + other-modules: + Paths_kb_text_layout + autogen-modules: + Paths_kb_text_layout + hs-source-dirs: + src + default-extensions: + BlockArguments + DerivingStrategies + DuplicateRecordFields + ImplicitParams + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + StrictData + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wredundant-constraints + build-depends: + base >=4.16 && <5 + , containers + , kb-text-shape >=0.2.1.0 && <0.3 + , text + , vector + default-language: GHC2021 + +library demos + exposed-modules: + Demo + KB.Text.Layout.Html + other-modules: + Paths_kb_text_layout + autogen-modules: + Paths_kb_text_layout + hs-source-dirs: + demos/lib + default-extensions: + BlockArguments + DerivingStrategies + DuplicateRecordFields + ImplicitParams + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + StrictData + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wredundant-constraints + build-depends: + base >=4.16 && <5 + , bytestring + , hyphenation + , kb-text-layout + , kb-text-shape + , text + , zstd + default-language: GHC2021 + if !flag(demos) + buildable: False + +executable kb-text-layout-bubbles + main-is: Main.hs + other-modules: + Paths_kb_text_layout + autogen-modules: + Paths_kb_text_layout + hs-source-dirs: + demos/bubbles + default-extensions: + BlockArguments + DerivingStrategies + DuplicateRecordFields + ImplicitParams + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + StrictData + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wredundant-constraints + build-depends: + base >=4.16 && <5 + , demos + , kb-text-layout + , kb-text-shape + , text + default-language: GHC2021 + if !flag(demos) + buildable: False + +executable kb-text-layout-demo + main-is: Main.hs + other-modules: + Paths_kb_text_layout + autogen-modules: + Paths_kb_text_layout + hs-source-dirs: + demos/demo + default-extensions: + BlockArguments + DerivingStrategies + DuplicateRecordFields + ImplicitParams + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + StrictData + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wredundant-constraints + build-depends: + base >=4.16 && <5 + , demos + , kb-text-layout + , kb-text-shape + , text + default-language: GHC2021 + if !flag(demos) + buildable: False + +executable kb-text-layout-justify + main-is: Main.hs + other-modules: + Paths_kb_text_layout + autogen-modules: + Paths_kb_text_layout + hs-source-dirs: + demos/justify + default-extensions: + BlockArguments + DerivingStrategies + DuplicateRecordFields + ImplicitParams + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + StrictData + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wredundant-constraints + build-depends: + base >=4.16 && <5 + , demos + , kb-text-layout + , kb-text-shape + , text + , vector + default-language: GHC2021 + if !flag(demos) + buildable: False + +executable kb-text-layout-masonry + main-is: Main.hs + other-modules: + Paths_kb_text_layout + autogen-modules: + Paths_kb_text_layout + hs-source-dirs: + demos/masonry + default-extensions: + BlockArguments + DerivingStrategies + DuplicateRecordFields + ImplicitParams + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + StrictData + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wredundant-constraints + build-depends: + base >=4.16 && <5 + , demos + , kb-text-layout + , kb-text-shape + , text + default-language: GHC2021 + if !flag(demos) + buildable: False + +executable kb-text-layout-obstacles + main-is: Main.hs + other-modules: + Paths_kb_text_layout + autogen-modules: + Paths_kb_text_layout + hs-source-dirs: + demos/obstacles + default-extensions: + BlockArguments + DerivingStrategies + DuplicateRecordFields + ImplicitParams + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + StrictData + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wredundant-constraints + build-depends: + base >=4.16 && <5 + , demos + , kb-text-layout + , kb-text-shape + , text + default-language: GHC2021 + if !flag(demos) + buildable: False + +test-suite kb-text-layout-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_kb_text_layout + autogen-modules: + Paths_kb_text_layout + hs-source-dirs: + test + default-extensions: + BlockArguments + DerivingStrategies + DuplicateRecordFields + ImplicitParams + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + StrictData + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wredundant-constraints + build-depends: + base >=4.16 && <5 + , demos + , kb-text-layout + , tasty + , tasty-hunit + , text + , vector + default-language: GHC2021 + if !flag(demos) + buildable: False + +benchmark kb-text-layout-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + other-modules: + Paths_kb_text_layout + autogen-modules: + Paths_kb_text_layout + hs-source-dirs: + bench + default-extensions: + BlockArguments + DerivingStrategies + DuplicateRecordFields + ImplicitParams + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + StrictData + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wredundant-constraints + build-depends: + base >=4.16 && <5 + , deepseq + , demos + , kb-text-layout + , kb-text-shape + , tasty-bench + default-language: GHC2021 + if !flag(demos) + buildable: False diff --git a/src/KB/Text/Layout/Analysis.hs b/src/KB/Text/Layout/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/KB/Text/Layout/Analysis.hs @@ -0,0 +1,106 @@ +module KB.Text.Layout.Analysis + ( -- * Splitting text into break units + analyze + , Segment (..) + , BreakKind (..) + ) where + +import Data.Char (isDigit, isSpace) +import Data.List (intersperse) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Vector qualified as Vector + +import KB.Text.Layout.Segmentation qualified as Segmentation + +analyze :: Text -> [Segment] +analyze t = go 0 (tailorSoftBreaks t (Segmentation.softBreaks t)) (map toSegment (Text.groupBy sameKind t)) + where + sameKind a b = classify a == classify b && groupable (classify a) + toSegment piece = Segment{text = piece, kind = classify (Text.head piece)} + go _ _ [] = [] + go off soft (s : rest) = + let + end = off + Text.length s.text + (inside, later) = span (< end) (dropWhile (<= off) soft) + pieces + | s.kind == Word, not (null inside) = intersperse breakOpportunity (cutAt off inside s.text) + | otherwise = [s] + in + pieces <> go end later rest + breakOpportunity = Segment{text = "", kind = ZeroWidthBreak} + cutAt off cuts txt = pieces 0 (map (subtract off) cuts) + where + pieces prev = \case + [] -> [Segment{text = Text.drop prev txt, kind = Word}] + p : rest -> Segment{text = Text.take (p - prev) (Text.drop prev txt), kind = Word} : pieces p rest + +data Segment = Segment + { text :: Text + , kind :: BreakKind + } + deriving stock (Eq, Show) + +data BreakKind + = Word + | Space + | PreservedSpace + | Tab + | Glue + | ZeroWidthBreak + | SoftHyphen + | HardBreak + | Atomic + deriving stock (Eq, Ord, Show) + +tailorSoftBreaks :: Text -> [Int] -> [Int] +tailorSoftBreaks t soft = merge (filter (not . insideRange) soft) querySplits + where + n = Text.length t + chars = Vector.fromList (Text.unpack t) + at i = chars Vector.! i + insideRange p = + p >= 2 + && p < n + && (at (p - 1) == '\x2013' || at (p - 1) == '\x2014') + && isDigit (at (p - 2)) + && isDigit (at p) + slashToken = + Vector.fromList $ + concatMap + (\run -> replicate (Text.length run) (not (isSpace (Text.head run)) && Text.any (== '/') run)) + (Text.groupBy (\a b -> isSpace a == isSpace b) t) + querySplits = + [ p + | p <- [1 .. n - 1] + , at p == '&' || at p == '=' || at p == '#' + , slashToken Vector.! p + ] + merge xs [] = xs + merge [] ys = ys + merge (x : xs) (y : ys) + | x < y = x : merge xs (y : ys) + | x > y = y : merge (x : xs) ys + | otherwise = x : merge xs ys + +classify :: Char -> BreakKind +classify = \case + ' ' -> Space + '\t' -> Tab + '\n' -> HardBreak + '\r' -> HardBreak + '\xA0' -> Glue + '\x202F' -> Glue + '\x2060' -> Glue + '\xFEFF' -> Glue + '\x200B' -> ZeroWidthBreak + '\xAD' -> SoftHyphen + _ -> Word + +groupable :: BreakKind -> Bool +groupable = \case + Word -> True + Space -> True + Glue -> True + Tab -> True + _ -> False diff --git a/src/KB/Text/Layout/Break.hs b/src/KB/Text/Layout/Break.hs new file mode 100644 --- /dev/null +++ b/src/KB/Text/Layout/Break.hs @@ -0,0 +1,466 @@ +module KB.Text.Layout.Break + ( -- * Breaking prepared text into lines + layoutGreedy + , layoutOptimal + , LineRange (..) + , Cursor (..) + , LineEnd (..) + + -- * Breaking one line at a time + , layoutNextLineRange + + -- * Extracting line contents + , materializeSlices + , LineSlice (..) + , materializeLineRange + + -- * Inspecting layouts + , layoutStats + , LayoutStats (..) + , lineStretch + , LineStretch (..) + , shrinkwrap + ) where + +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector + +import KB.Text.Layout.Analysis (BreakKind (..)) +import KB.Text.Layout.Measure (MeasuredSegment (..), PreparedText (..)) + +layoutGreedy :: PreparedText -> Float -> [LineRange] +layoutGreedy prepared maxWidth = go (Cursor 0 0) + where + go cursor = + case layoutNextLineRange prepared maxWidth cursor of + Nothing -> [] + Just (line, Nothing) -> [line] + Just (line, Just next) -> line : go next + +layoutOptimal :: PreparedText -> Float -> [LineRange] +layoutOptimal prepared target = + case chosen of + Just lns -> lns + Nothing -> layoutGreedy prepared target + where + segs = prepared.segments + total = Vector.length segs + + flowWidth seg = case seg.kind of + SoftHyphen -> 0 + _ -> seg.width + spaceWidth seg = case seg.kind of + Space -> seg.width + _ -> 0 + prefixFlow = Vector.scanl' (\acc seg -> acc + flowWidth seg) 0 segs + prefixSpace = Vector.scanl' (\acc seg -> acc + spaceWidth seg) 0 segs + + candidates :: Vector Breakpoint + candidates = + Vector.fromList $ + concatMap breakable [0 .. total - 1] <> [Breakpoint{to = total, next = total, hyphen = False, forced = True}] + where + breakable i = case (segs Vector.! i).kind of + Space -> [plain i] + Tab -> [plain i] + PreservedSpace -> [plain i] + ZeroWidthBreak -> [plain i] + SoftHyphen -> [Breakpoint{to = i, next = i + 1, hyphen = True, forced = False}] + HardBreak -> [Breakpoint{to = i, next = i + 1, hyphen = False, forced = True}] + Atomic -> [Breakpoint{to = i, next = i, hyphen = False, forced = False}, Breakpoint{to = i + 1, next = i + 1, hyphen = False, forced = False}] + Word -> [] + Glue -> [] + plain i = Breakpoint{to = i, next = i + 1, hyphen = False, forced = False} + + skipSpaces i + | i < total, (segs Vector.! i).kind == Space = skipSpaces (i + 1) + | otherwise = i + + lineStart i = skipSpaces i + + lineOf from cand = + let + a = lineStart from + hyphenWidth = if cand.hyphen then (segs Vector.! cand.to).width else 0 + natural = prefixFlow Vector.! cand.to - prefixFlow Vector.! a + hyphenWidth + stretchable = prefixSpace Vector.! cand.to - prefixSpace Vector.! a + in + (a, natural, stretchable) + + badness natural stretchable free + | slack >= 0 = + if free then + Just 0 + else + if stretchable <= 0 then + Just $! if slack < 1e-4 then 0 else looseNoGlue + slack * 1000 + else + Just $! 100 * ratio * ratio * ratio + | negate slack > shrink + 1e-4 = Nothing + | otherwise = Just $! 100 * tightness * tightness * tightness + where + looseNoGlue :: Float + looseNoGlue = 1e7 + + slack = target - natural + ratio = slack / (0.5 * stretchable) + shrink = stretchable / 3 + tightness = negate slack / max shrink 1e-6 + + demerits b hyphen = (10 + b) * (10 + b) + (if hyphen then 2500 else 0) + + lastForcedBefore :: Vector Int + lastForcedBefore = Vector.fromList $ scanl step (-1) [0 .. Vector.length candidates - 2] + where + step acc j = if (candidates Vector.! j).forced then j else acc + + best :: Vector (Maybe (Float, Int)) + best = Vector.generate (Vector.length candidates) bestAt + where + bestAt j = + let + cand = candidates Vector.! j + floor_ = lastForcedBefore Vector.! j + fromStart + | floor_ == -1 = attempt (-1) 0 + | otherwise = Nothing + fromPrev i + | i < max floor_ 0 = [] + | otherwise = case best Vector.! i of + Nothing -> rest + Just (cost, _) -> maybe rest (: rest) do + d <- lineCost (candidates Vector.! i).next + pure (cost + d, i) + where + rest = fromPrev (i - 1) + attempt i from = (\d -> (d, i)) <$> lineCost from + lineCost from = + let (_a, natural, stretchable) = lineOf from cand + in demerits <$> badness natural stretchable cand.forced <*> pure cand.hyphen + options = maybe [] (: []) fromStart <> fromPrev (j - 1) + in + case options of + [] -> Nothing + _ -> Just $! minimum options + + chosen = do + let final = Vector.length candidates - 1 + _ <- best Vector.! final + let walk j acc + | j == -1 = acc + | otherwise = case best Vector.! j of + Nothing -> acc + Just (_, i) -> + let + cand = candidates Vector.! j + from = if i == -1 then 0 else (candidates Vector.! i).next + (a, natural, _) = lineOf from cand + ended + | cand.hyphen = Hyphenated + | cand.to >= total = Finished + | cand.forced = HardBroken + | otherwise = Wrapped + line = + LineRange + { from = Cursor a 0 + , to = Cursor cand.to 0 + , width = natural + , ended + } + in + walk i $ if a >= total then acc else (line : acc) + pure $! walk final [] + +data LineRange = LineRange + { from :: Cursor + , to :: Cursor + , width :: Float + , ended :: LineEnd + } + deriving stock (Eq, Show) + +data Cursor = Cursor + { segment :: Int + , grapheme :: Int + } + deriving stock (Eq, Ord, Show) + +data LineEnd + = Wrapped + | Hyphenated + | Overflowed + | HardBroken + | Finished + deriving stock (Eq, Ord, Show) + +data Breakpoint = Breakpoint + { to :: Int + , next :: Int + , hyphen :: Bool + , forced :: Bool + } + +layoutNextLineRange :: PreparedText -> Float -> Cursor -> Maybe (LineRange, Maybe Cursor) +layoutNextLineRange prepared maxWidth cursor + | start.segment >= total = Nothing + | otherwise = Just (scanSeg start.segment start.grapheme 0 0 Nothing) + where + segs = prepared.segments + total = Vector.length segs + start = skipSpaces cursor + + skipSpaces c + | c.segment < total + , c.grapheme == 0 + , (segs Vector.! c.segment).kind == Space = + skipSpaces Cursor{segment = c.segment + 1, grapheme = 0} + | otherwise = c + + emit to width ended = LineRange{from = start, to, width, ended} + + scanSeg i g acc visible cand + | i >= total = (emit (Cursor total 0) visible Finished, Nothing) + | otherwise = + let + seg = segs Vector.! i + segWidth = if g == 0 then seg.width else sum (map snd (dropChars g seg.graphemeWidths)) + after = Cursor (i + 1) 0 + spaceLike = + scanSeg + (i + 1) + 0 + (acc + segWidth) + visible + (Just Candidate{to = Cursor i 0, width = visible, end = Wrapped, next = after}) + fitOrBreak + | acc + segWidth <= maxWidth + epsilon = + scanSeg (i + 1) 0 (acc + segWidth) (acc + segWidth) cand + | otherwise = + case cand of + Just c -> (emit c.to c.width c.end, Just c.next) + Nothing -> emergency seg i g acc + in + case seg.kind of + HardBreak -> (emit (Cursor i 0) visible HardBroken, Just after) + Space -> spaceLike + PreservedSpace -> spaceLike + Tab -> spaceLike + ZeroWidthBreak -> spaceLike + SoftHyphen + | visible + segWidth <= maxWidth + epsilon -> + scanSeg (i + 1) 0 acc visible $ + Just + Candidate + { to = Cursor i 0 + , width = visible + segWidth + , end = Hyphenated + , next = after + } + | otherwise -> scanSeg (i + 1) 0 acc visible cand + Atomic -> + let candBefore + | acc > 0 + , maybe True (\c -> c.width < visible) cand = + Just Candidate{to = Cursor i 0, width = visible, end = Wrapped, next = Cursor i 0} + | otherwise = cand + in if acc + segWidth <= maxWidth + epsilon then + scanSeg (i + 1) 0 (acc + segWidth) (acc + segWidth) $ + Just Candidate{to = after, width = acc + segWidth, end = Wrapped, next = after} + else case candBefore of + Just c -> (emit c.to c.width c.end, Just c.next) + Nothing -> (emit after (acc + segWidth) Overflowed, Just after) + Word -> fitOrBreak + Glue -> fitOrBreak + + emergency seg i g acc = + let + ws = dropChars g seg.graphemeWidths + counted = countFits acc ws + count + | counted == 0 && acc <= epsilon = 1 + | otherwise = counted + taken = take count ws + g' = g + sum (map fst taken) + takenWidth = sum (map snd taken) + in + if count == 0 then + (emit (Cursor i g) acc Overflowed, Just (Cursor i g)) + else + (emit (Cursor i g') (acc + takenWidth) Overflowed, Just (advanceCursor seg i g')) + + countFits = fits 0 + where + fits n w = \case + [] -> n + (_, cw) : rest + | w + cw <= maxWidth + epsilon -> fits (n + 1) (w + cw) rest + | otherwise -> n + + advanceCursor seg i g' + | g' >= Text.length seg.text = Cursor (i + 1) 0 + | otherwise = Cursor i g' + +data Candidate = Candidate + { to :: Cursor + , width :: Float + , end :: LineEnd + , next :: Cursor + } + +epsilon :: Float +epsilon = 1e-4 + +materializeSlices :: PreparedText -> LineRange -> [LineSlice] +materializeSlices prepared line = mergeSlices $ mapMaybe slice [line.from.segment .. line.to.segment] <> hyphen + where + segs = prepared.segments + hyphen = + [ LineSlice + { text = "-" + , style = seg.style + , width = seg.width + , atom = False + } + | line.ended == Hyphenated + , let seg = segs Vector.! line.to.segment + ] + slice j + | j >= Vector.length segs = Nothing + | otherwise = + let + seg = segs Vector.! j + startG = if j == line.from.segment then line.from.grapheme else 0 + endG = if j == line.to.segment then line.to.grapheme else Text.length seg.text + piece = Text.take (endG - startG) (Text.drop startG seg.text) + pieceWidth + | startG == 0 && endG == Text.length seg.text = + seg.width + | otherwise = + sum . map snd $ + takeChars (endG - startG) $ + dropChars startG seg.graphemeWidths + in + case seg.kind of + SoftHyphen -> Nothing + HardBreak -> Nothing + ZeroWidthBreak -> Nothing + _ + | Text.null piece -> Nothing + | otherwise -> + Just + LineSlice + { text = piece + , style = seg.style + , width = pieceWidth + , atom = seg.kind == Atomic + } + +data LineSlice = LineSlice + { text :: Text + , style :: Int + , width :: Float + , atom :: Bool + } + deriving stock (Eq, Show) + +mergeSlices :: [LineSlice] -> [LineSlice] +mergeSlices = \case + [] -> [] + a : b : rest + | not a.atom + , not b.atom + , a.style == b.style -> + mergeSlices $ + LineSlice + { text = a.text <> b.text + , style = a.style + , width = a.width + b.width + , atom = False + } + : rest + a : rest -> + a : mergeSlices rest + +materializeLineRange :: PreparedText -> LineRange -> Text +materializeLineRange prepared line = visible <> suffix + where + segs = prepared.segments + suffix = if line.ended == Hyphenated then "-" else "" + visible = Text.concat (mapMaybe piece [line.from.segment .. line.to.segment]) + piece j + | j >= Vector.length segs = Nothing + | otherwise = + let + seg = segs Vector.! j + startG = if j == line.from.segment then line.from.grapheme else 0 + endG = if j == line.to.segment then line.to.grapheme else Text.length seg.text + in + case seg.kind of + SoftHyphen -> Nothing + HardBreak -> Nothing + ZeroWidthBreak -> Nothing + _ -> Just (Text.take (endG - startG) (Text.drop startG seg.text)) + +layoutStats :: [LineRange] -> LayoutStats +layoutStats = foldl' step LayoutStats{lineCount = 0, maxLineWidth = 0} + where + step stats line = + LayoutStats + { lineCount = stats.lineCount + 1 + , maxLineWidth = max stats.maxLineWidth line.width + } + +data LayoutStats = LayoutStats + { lineCount :: Int + , maxLineWidth :: Float + } + deriving stock (Eq, Show) + +lineStretch :: PreparedText -> LineRange -> LineStretch +lineStretch prepared line = LineStretch{spaces = length inside, width = sum inside} + where + segs = prepared.segments + upper + | line.to.grapheme == 0 = line.to.segment - 1 + | otherwise = line.to.segment + inside = + [ seg.width + | j <- [line.from.segment .. min upper (Vector.length segs - 1)] + , let seg = segs Vector.! j + , seg.kind == Space + ] + +data LineStretch = LineStretch + { spaces :: Int + , width :: Float + } + deriving stock (Eq, Show) + +shrinkwrap :: PreparedText -> Float -> Float +shrinkwrap prepared maxWidth = go (40 :: Int) 0 maxWidth + where + countAt w = (layoutStats (layoutGreedy prepared w)).lineCount + target = countAt maxWidth + go k lo hi + | k <= 0 = (layoutStats (layoutGreedy prepared hi)).maxLineWidth + | countAt mid <= target = go (k - 1) lo mid + | otherwise = go (k - 1) mid hi + where + mid = (lo + hi) / 2 + +dropChars :: Int -> [(Int, Float)] -> [(Int, Float)] +dropChars n xs + | n <= 0 = xs + | otherwise = case xs of + [] -> [] + (len, _) : rest -> dropChars (n - len) rest + +takeChars :: Int -> [(Int, Float)] -> [(Int, Float)] +takeChars n xs + | n <= 0 = [] + | otherwise = case xs of + [] -> [] + x@(len, _) : rest -> x : takeChars (n - len) rest diff --git a/src/KB/Text/Layout/Measure.hs b/src/KB/Text/Layout/Measure.hs new file mode 100644 --- /dev/null +++ b/src/KB/Text/Layout/Measure.hs @@ -0,0 +1,172 @@ +module KB.Text.Layout.Measure + ( -- * Layout context + createLayoutContext + , clearCache + , LayoutContext + + -- * Preparing text for layout + , prepare + , prepareStyled + , PreparedText (..) + , MeasuredSegment (..) + , Span (..) + + -- * Measuring + , measure + + -- * Styles + , newStyle + , Style (..) + ) where + +import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Traversable (mapAccumL) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import KB.Text.Layout.Analysis (BreakKind (..), Segment (..), analyze) +import KB.Text.Layout.Segmentation qualified as Segmentation +import KB.Text.Shape qualified as TextShape +import KB.Text.Shape.Font qualified as Font + +prepare :: LayoutContext -> Style -> Text -> IO PreparedText +prepare ctx style t = prepareStyled ctx [TextSpan style t] + +prepareStyled :: LayoutContext -> [Span] -> IO PreparedText +prepareStyled ctx spans = do + segments <- Vector.fromList . concat <$> traverse spanSegments spans + pure PreparedText{segments} + where + spanSegments = \case + AtomSpan style label w -> + pure + [ MeasuredSegment + { text = label + , kind = Atomic + , width = w + , style = style.key + , graphemeWidths = [(Text.length label, w)] + } + ] + TextSpan style t -> do + advance <- charAdvances ctx style t + spaceWidth <- measure ctx style " " + hyphenWidth <- measure ctx style "-" + let + prefix = Vector.scanl' (+) 0 advance + slice off n = prefix Vector.! (off + n) - prefix Vector.! off + clusterWidths off = \case + [] -> [] + c : rest -> + let k = Text.length c + in (k, slice off k) : clusterWidths (off + k) rest + segmentAt off seg = + let + n = Text.length seg.text + width = case seg.kind of + SoftHyphen -> hyphenWidth + ZeroWidthBreak -> 0 + HardBreak -> 0 + Tab -> fromIntegral n * spaceWidth + _ -> slice off n + graphemeWidths = case seg.kind of + Word -> clusterWidths off (Segmentation.clusters seg.text) + Glue -> clusterWidths off (Segmentation.clusters seg.text) + _ -> [(n, width)] + in + ( off + n + , MeasuredSegment{text = seg.text, kind = seg.kind, width, style = style.key, graphemeWidths} + ) + pure (snd (mapAccumL segmentAt 0 (analyze t))) + +data PreparedText = PreparedText + { segments :: Vector MeasuredSegment + } + +data MeasuredSegment = MeasuredSegment + { text :: Text + , kind :: BreakKind + , width :: Float + , style :: Int + , graphemeWidths :: [(Int, Float)] + } + +data Span + = TextSpan Style Text + | AtomSpan Style Text Float + +charAdvances :: LayoutContext -> Style -> Text -> IO (Vector Float) +charAdvances ctx style t + | Text.null t = pure Vector.empty + | otherwise = do + runs <- TextShape.run ctx.shape (TextShape.withFont_ style.font (TextShape.text_ t)) + contributions <- concat <$> traverse runContributions runs + pure (Vector.map (* style.scale) (Vector.accum (+) (Vector.replicate n 0) contributions)) + where + n = Text.length t + runContributions (run, glyphs) = do + info <- Font.getFontInfo run.font + let toGrid = style.grid / fromIntegral info.unitsPerEm + pure + [ (g.codepointIndex, fromIntegral g.advanceX * toGrid) + | g <- glyphs + , g.codepointIndex >= 0 + , g.codepointIndex < n + ] + +measure :: LayoutContext -> Style -> Text -> IO Float +measure ctx style t + | Text.null t = pure 0 + | otherwise = + Map.lookup (style.key, t) <$> readIORef ctx.metrics >>= \case + Just w -> pure w + Nothing -> do + runs <- TextShape.run ctx.shape (TextShape.withFont_ style.font (TextShape.text_ t)) + let runWidth (run, glyphs) = do + info <- Font.getFontInfo run.font + let toGrid = style.grid / fromIntegral info.unitsPerEm + pure (sum [fromIntegral g.advanceX | g <- glyphs] * toGrid) + w <- (* style.scale) . sum <$> traverse runWidth runs + modifyIORef' ctx.metrics (Map.insert (style.key, t) w) + pure w + +newStyle :: LayoutContext -> Font.Font -> Float -> IO Style +newStyle ctx font size = do + info <- Font.getFontInfo font + key <- atomicModifyIORef' ctx.styleKeys \n -> (n + 1, n) + pure + Style + { key + , font + , size + , em = size * Font.emToCaps info + , scale = size / fromIntegral info.capitalHeight + , grid = fromIntegral info.unitsPerEm + } + +data Style = Style + { key :: Int + , font :: Font.Font + , size :: Float + , em :: Float + , scale :: Float + , grid :: Float + } + +createLayoutContext :: TextShape.Context -> IO LayoutContext +createLayoutContext shape = do + metrics <- newIORef Map.empty + styleKeys <- newIORef 0 + pure LayoutContext{shape, metrics, styleKeys} + +clearCache :: LayoutContext -> IO () +clearCache ctx = writeIORef ctx.metrics Map.empty + +data LayoutContext = LayoutContext + { shape :: TextShape.Context + , metrics :: IORef (Map (Int, Text) Float) + , styleKeys :: IORef Int + } diff --git a/src/KB/Text/Layout/Segmentation.hs b/src/KB/Text/Layout/Segmentation.hs new file mode 100644 --- /dev/null +++ b/src/KB/Text/Layout/Segmentation.hs @@ -0,0 +1,34 @@ +module KB.Text.Layout.Segmentation + ( -- * Break opportunities in character offsets + softBreaks + , wordBreaks + , boundaries + + -- * Grapheme clusters + , clusters + ) where + +import Data.IntMap.Strict qualified as IntMap +import Data.List (scanl') +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Internal.Encoding.Utf8 (utf8Length) + +import KB.Text.Shape.Segmentation (clusters) +import KB.Text.Shape.Segmentation qualified as Segmentation + +softBreaks :: Text -> [Int] +softBreaks t = charOffsets t (Segmentation.softBreaks t) + +wordBreaks :: Text -> [Int] +wordBreaks t = charOffsets t (Segmentation.wordBreaks t) + +boundaries :: Text -> [Int] +boundaries t = charOffsets t (Segmentation.boundaries t) + +charOffsets :: Text -> [Int] -> [Int] +charOffsets t = map toChar + where + starts = IntMap.fromDistinctAscList (zip byteStarts [0 ..]) + byteStarts = scanl' (\off c -> off + utf8Length c) 0 (Text.unpack t) + toChar o = maybe 0 snd (IntMap.lookupLE o starts) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,213 @@ +module Main (main) where + +import Data.Foldable (for_) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Vector qualified as Vector +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import KB.Text.Layout.Analysis (BreakKind (..)) +import KB.Text.Layout.Analysis qualified as Analysis +import KB.Text.Layout.Break (Cursor (..), LineEnd (..), LineStretch (..)) +import KB.Text.Layout.Break qualified as Break +import KB.Text.Layout.Html qualified as Html +import KB.Text.Layout.Measure (MeasuredSegment (..), PreparedText (..)) +import KB.Text.Layout.Segmentation qualified as Segmentation + +main :: IO () +main = + defaultMain $ + testGroup + "kb-text-layout" + [ testCase "single line" do + (Break.layoutStats (Break.layoutGreedy (fromSegments prepared) 200)).lineCount @?= 1 + , testCase "break at space" do + (Break.layoutStats (Break.layoutGreedy (fromSegments prepared) 100)).lineCount @?= 2 + , testCase "emergency graphemes" do + materialized prepared 30 @?= ["hel", "lo", "wor", "ld"] + , testCase "soft hyphen" do + materialized hyphenated 30 @?= ["hy-", "phen"] + , testCase "soft hyphen too wide to use" do + materialized wideHyphen 30 @?= ["hyphen"] + , testCase "hard break" do + materialized broken 1000 @?= ["one", "two"] + , testCase "glue holds" do + materialized glued 60 @?= ["aaa\xA0\&bb", "b"] + , testCase "atomic breaks before" do + materialized [word 50 "word", atom 40 "[pill]"] 60 @?= ["word", "[pill]"] + , testCase "atomic breaks after" do + materialized [atom 40 "[pill]", word 50 "word"] 60 @?= ["[pill]", "word"] + , testCase "atomic never splits" do + materialized [word 30 "abc", space, atom 100 "[wide-pill]"] 60 + @?= ["abc", "[wide-pill]"] + , testCase "stepping matches walk" do + stepped prepared (replicate 10 30) @?= materialized prepared 30 + , testCase "variable widths route lines" do + stepped rhythm [70, 30] @?= ["aaa bbb", "ccc"] + , testCase "narrower route reflows" do + stepped rhythm [40, 40, 40] @?= ["aaa", "bbb", "ccc"] + , testCase "slices merge same-style runs" do + let prep = fromSegments styled + map (\s -> (s.text, s.style)) (concatMap (Break.materializeSlices prep) (Break.layoutGreedy prep 200)) + @?= [("aaa bbb ", 1), ("ccc", 2)] + , testCase "slices mark atoms with widths" do + let prep = fromSegments [styledWord 1 30 "hi", styledSpace 1, atom 40 "[pill]"] + map (\s -> (s.text, s.atom, s.width)) (concatMap (Break.materializeSlices prep) (Break.layoutGreedy prep 200)) + @?= [("hi ", False, 40), ("[pill]", True, 40)] + , testCase "slices absorb the soft hyphen" do + let prep = fromSegments hyphenated + map (\s -> (s.text, s.width)) (concatMap (Break.materializeSlices prep) (take 1 (Break.layoutGreedy prep 30))) + @?= [("hy-", 25)] + , testCase "slices concat to materialized text" do + for_ [prepared, hyphenated, broken, glued, rhythm, styled] \xs -> + for_ [25, 30, 60, 200] \w -> do + let prep = fromSegments xs + for_ (Break.layoutGreedy prep w) \line -> + Text.concat (map (\s -> s.text) (Break.materializeSlices prep line)) + @?= Break.materializeLineRange prep line + , testCase "emergency breaks respect clusters" do + let accented = + [ MeasuredSegment + { text = "a\x301\&bc" + , kind = Word + , width = 30 + , style = 0 + , graphemeWidths = [(2, 10), (1, 10), (1, 10)] + } + ] + materialized accented 10 @?= ["a\x301", "b", "c"] + materialized accented 20 @?= ["a\x301\&b", "c"] + , testCase "kbts clusters marks, zwj sequences, and flags" do + Segmentation.clusters "a\x301\&bc" @?= ["a\x301", "b", "c"] + Segmentation.clusters "\128104\8205\128105\8205\128103 ok" + @?= ["\128104\8205\128105\8205\128103", " ", "o", "k"] + Segmentation.clusters "\127482\127462\127482\127462" @?= ["\127482\127462", "\127482\127462"] + , testCase "kbts break positions arrive as Char offsets" do + Segmentation.boundaries "" @?= [] + Segmentation.boundaries "\128512\&a" @?= [0, 1, 2] + Segmentation.boundaries "a\128104\8205\128105\8205\128103b" @?= [0, 1, 6, 7] + Segmentation.softBreaks "\26085\26412\35486 ok" @?= [1, 2, 4, 6] + Segmentation.softBreaks "go \128105\127997\8205\128640 now" @?= [3, 8, 11] + Segmentation.wordBreaks "one two" @?= [0, 3, 4, 7] + , testCase "kbts soft breaks split words at line break opportunities" do + map (\s -> (s.text, s.kind)) (Analysis.analyze "well-known") + @?= [("well-", Word), ("", ZeroWidthBreak), ("known", Word)] + map (\s -> s.text) (Analysis.analyze "\26085\26412\12290\35486") + @?= ["\26085", "", "\26412\12290", "", "\35486"] + map (\s -> s.text) (Analysis.analyze "ab\128104\8205\128105\8205\128103\&cd") + @?= ["ab\128104\8205\128105\8205\128103", "", "cd"] + map (\s -> (s.text, s.kind)) (Analysis.analyze "plain words") + @?= [("plain", Word), (" ", Space), ("words", Word)] + , testCase "tailored breaks split url queries and hold dash ranges" do + map (\s -> s.text) (Analysis.analyze "see example.com/a?b=1&c#d now") + @?= ["see", " ", "example.com/", "", "a?", "", "b", "", "=1", "", "&c", "", "#d", " ", "now"] + map (\s -> s.text) (Analysis.analyze "pages 3\8211\&5 and 2+2=4 at AT&T") + @?= ["pages", " ", "3\8211\&5", " ", "and", " ", "2+2=4", " ", "at", " ", "AT&T"] + map (\s -> s.text) (Analysis.analyze "10:30-11:00") @?= ["10:30-11:00"] + , testCase "line ends carry their reason" do + let ends xs w = map (\l -> l.ended) (Break.layoutGreedy (fromSegments xs) w) + ends prepared 30 @?= [Overflowed, Wrapped, Overflowed, Finished] + ends hyphenated 30 @?= [Hyphenated, Finished] + ends broken 1000 @?= [HardBroken, Finished] + ends rhythm 70 @?= [Wrapped, Finished] + , testCase "line stretch counts interior spaces only" do + let + prep = fromSegments rhythm + stretches w = map (Break.lineStretch prep) (Break.layoutGreedy prep w) + stretches 200 @?= [LineStretch{spaces = 2, width = 20}] + stretches 70 @?= [LineStretch{spaces = 1, width = 10}, LineStretch{spaces = 0, width = 0}] + , testCase "shrinkwrap tightens without adding lines" do + Break.shrinkwrap (fromSegments rhythm) 80 @?= 70 + Break.shrinkwrap (fromSegments rhythm) 200 @?= 110 + Break.shrinkwrap (fromSegments prepared) 45 @?= 30 + , testCase "optimal layout beats greedy on loose middle lines" do + let + squeeze = [word 60 "aaaaaa", space, word 10 "b", space, word 10 "c", space, word 60 "dddddd"] + prep = fromSegments squeeze + materialized squeeze 77 @?= ["aaaaaa", "b c", "dddddd"] + map (Break.materializeLineRange prep) (Break.layoutOptimal prep 77) @?= ["aaaaaa b", "c dddddd"] + , testCase "optimal layout agrees with greedy where greedy is fine" do + let optimal xs w = map (Break.materializeLineRange (fromSegments xs)) (Break.layoutOptimal (fromSegments xs) w) + optimal rhythm 70 @?= ["aaa bbb", "ccc"] + optimal hyphenated 30 @?= ["hy-", "phen"] + optimal broken 1000 @?= ["one", "two"] + , testCase "optimal layout falls back to greedy when infeasible" do + map (Break.materializeLineRange (fromSegments glued)) (Break.layoutOptimal (fromSegments glued) 60) + @?= materialized glued 60 + , testCase "html renderer escapes and anchors baselines" do + let + prep = fromSegments [styledWord 1 30 "a Float -> [Text] +materialized xs maxWidth = + map (Break.materializeLineRange prep) (Break.layoutGreedy prep maxWidth) + where + prep = fromSegments xs + +stepped :: [MeasuredSegment] -> [Float] -> [Text] +stepped xs = go (Just (Cursor 0 0)) + where + prep = fromSegments xs + go _ [] = [] + go Nothing _ = [] + go (Just cursor) (w : rest) = + case Break.layoutNextLineRange prep w cursor of + Nothing -> [] + Just (line, next) -> Break.materializeLineRange prep line : go next rest + +prepared, hyphenated, wideHyphen, broken, glued, rhythm, styled :: [MeasuredSegment] +prepared = [word 50 "hello", space, word 50 "world"] +hyphenated = [word 20 "hy", seg SoftHyphen 5 "\xAD", word 30 "phen"] +wideHyphen = [word 20 "hy", seg SoftHyphen 15 "\xAD", word 9 "phen"] +broken = [word 30 "one", seg HardBreak 0 "\n", word 30 "two"] +glued = [word 30 "aaa", seg Glue 10 "\xA0", word 30 "bbb"] +rhythm = [word 30 "aaa", space, word 30 "bbb", space, word 30 "ccc"] +styled = [styledWord 1 30 "aaa", styledSpace 1, styledWord 1 30 "bbb", styledSpace 1, styledWord 2 30 "ccc"] + +word :: Float -> Text -> MeasuredSegment +word = styledWord 0 + +styledWord :: Int -> Float -> Text -> MeasuredSegment +styledWord sk w t = MeasuredSegment{text = t, kind = Word, width = w, style = sk, graphemeWidths = graphemes} + where + n = Text.length t + graphemes = replicate n (1, w / fromIntegral n) + +styledSpace :: Int -> MeasuredSegment +styledSpace sk = MeasuredSegment{text = " ", kind = Space, width = 10, style = sk, graphemeWidths = [(1, 10)]} + +seg :: BreakKind -> Float -> Text -> MeasuredSegment +seg kind w t = MeasuredSegment{text = t, kind, width = w, style = 0, graphemeWidths = [(Text.length t, w)]} + +atom :: Float -> Text -> MeasuredSegment +atom w label = MeasuredSegment{text = label, kind = Atomic, width = w, style = 0, graphemeWidths = [(Text.length label, w)]} + +space :: MeasuredSegment +space = seg Space 10 " " + +fromSegments :: [MeasuredSegment] -> PreparedText +fromSegments xs = PreparedText{segments = Vector.fromList xs}