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 $
["<style>"]
<> [ "@font-face{font-family:\"" <> name <> "\";src:url(\"" <> faceUrl path <> "\")}"
| (name, path) <- faces
]
<> ["</style>"]
-- | 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 =
"<div style=\"position:relative;width:" <> px w <> ";height:" <> px h <> "\">" <> inner <> "</div>"
at :: Float -> Float -> Text -> Text -> Text
at x y extra inner =
"<div style=\"position:absolute;left:" <> px x <> ";top:" <> px y <> extra <> "\">" <> inner <> "</div>"
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 =
"<p style=\"font:12px monospace" <> extra <> "\">" <> Html.escape t <> "</p>"