giles
1884c28763
- Added sublist helper (portable list extraction, avoids 3-arg slice which fails in browser WASM kernel) - Replaced reduce + 0 lwid with manual sum loop (reduce has browser compat issues with dict-set! error in call stack) - Imperative DOM update via effect for clean paragraph re-rendering on signal changes (clear container, create new spans) - String slice in hyphenate-word kept (works on strings) Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
395 lines
13 KiB
Plaintext
395 lines
13 KiB
Plaintext
;; Pretext — DOM-free text layout (pure SX)
|
|
;;
|
|
;; Cheng Lou's insight: text measurement is IO, but text *layout* is
|
|
;; pure arithmetic. One `perform` for glyph metrics, everything else
|
|
;; is deterministic functions over numbers.
|
|
;;
|
|
;; Architecture:
|
|
;; (perform (text-measure :font font :size size :text text))
|
|
;; → {:widths (...) :height N :ascent N :descent N}
|
|
;;
|
|
;; break-lines, position-glyphs, hyphenate — all pure SX.
|
|
;;
|
|
;; Knuth-Plass optimal line breaking (DP over break candidates).
|
|
;; Liang's hyphenation (trie over character patterns).
|
|
|
|
(define-library
|
|
(sx text-layout)
|
|
(export
|
|
measure-text
|
|
line-badness
|
|
compute-demerits
|
|
sum-widths
|
|
find-breaks
|
|
break-lines
|
|
break-lines-greedy
|
|
position-line
|
|
position-lines
|
|
pretext-position-line
|
|
pretext-layout-lines
|
|
layout-paragraph
|
|
make-hyphenation-trie
|
|
find-hyphenation-points
|
|
hyphenate-word
|
|
typeset
|
|
typeset-plain)
|
|
(begin
|
|
(define
|
|
sublist
|
|
(fn
|
|
(lst start end)
|
|
(let
|
|
loop
|
|
((i 0) (src lst) (acc (list)))
|
|
(cond
|
|
(>= i end)
|
|
(reverse acc)
|
|
(empty? src)
|
|
(reverse acc)
|
|
(>= i start)
|
|
(loop (+ i 1) (rest src) (cons (first src) acc))
|
|
:else (loop (+ i 1) (rest src) acc)))))
|
|
(define
|
|
measure-text
|
|
(fn
|
|
(font size text)
|
|
(perform (list (quote text-measure) font size text))))
|
|
(define
|
|
line-badness
|
|
(fn
|
|
(used max-width)
|
|
(let
|
|
((slack (- max-width used)))
|
|
(if
|
|
(< slack 0)
|
|
100000
|
|
(let
|
|
((ratio (/ slack max-width)))
|
|
(* (* ratio ratio) (* ratio 1000)))))))
|
|
(define
|
|
compute-demerits
|
|
(fn
|
|
(badness penalty)
|
|
(let
|
|
((base (+ 1 badness)))
|
|
(+ (* base base) (* penalty penalty)))))
|
|
(define
|
|
sum-widths
|
|
(fn
|
|
(widths space-width from to)
|
|
(let
|
|
loop
|
|
((k from) (total 0))
|
|
(if
|
|
(>= k to)
|
|
(let
|
|
((spaces (max 0 (- (- to from) 1))))
|
|
(+ total (* spaces space-width)))
|
|
(loop (+ k 1) (+ total (nth widths k)))))))
|
|
(define
|
|
find-breaks
|
|
(fn
|
|
(widths space-width max-width)
|
|
(let
|
|
((n (len widths)))
|
|
(if
|
|
(<= n 0)
|
|
(list)
|
|
(let
|
|
((dp (map (fn (i) (if (= i 0) (list 0 -1) (list 999999999 -1))) (range (+ n 1)))))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(let
|
|
((prev-cost (first (nth dp i))))
|
|
(let
|
|
try-j
|
|
((j i))
|
|
(when
|
|
(< j n)
|
|
(let
|
|
((used (sum-widths widths space-width i (+ j 1))))
|
|
(when
|
|
(<= used (* max-width 1.15))
|
|
(let
|
|
((bad (line-badness used max-width))
|
|
(penalty 0))
|
|
(let
|
|
((cost (+ prev-cost (compute-demerits bad penalty)))
|
|
(entry (nth dp (+ j 1))))
|
|
(when
|
|
(< cost (first entry))
|
|
(set!
|
|
dp
|
|
(map-indexed
|
|
(fn
|
|
(idx e)
|
|
(if (= idx (+ j 1)) (list cost i) e))
|
|
dp)))
|
|
(try-j (+ j 1))))))))))
|
|
(range n))
|
|
(let
|
|
trace
|
|
((pos n) (breaks (list)))
|
|
(let
|
|
((prev (nth (nth dp pos) 1)))
|
|
(if (<= prev 0) breaks (trace prev (cons prev breaks))))))))))
|
|
(define
|
|
break-lines
|
|
(fn
|
|
(widths space-width max-width)
|
|
(let
|
|
((breaks (find-breaks widths space-width max-width))
|
|
(n (len widths)))
|
|
(if
|
|
(= n 0)
|
|
(list)
|
|
(let
|
|
((starts (cons 0 breaks)))
|
|
(let
|
|
((ends (append (rest starts) (list n))))
|
|
(map-indexed (fn (i s) (list s (nth ends i))) starts)))))))
|
|
(define
|
|
break-lines-greedy
|
|
(fn
|
|
(widths space-width max-width)
|
|
(let
|
|
((n (len widths)))
|
|
(if
|
|
(= n 0)
|
|
(list)
|
|
(let
|
|
((lines (list)) (start 0) (used 0))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(let
|
|
((w (nth widths i))
|
|
(needed (if (= i start) w (+ used space-width w))))
|
|
(if
|
|
(and (> needed max-width) (not (= i start)))
|
|
(do
|
|
(set! lines (append lines (list (list start i))))
|
|
(set! start i)
|
|
(set! used w))
|
|
(set! used needed))))
|
|
(range n))
|
|
(append lines (list (list start n))))))))
|
|
(define
|
|
position-line
|
|
(fn
|
|
(words widths space-width x0 y)
|
|
(let
|
|
loop
|
|
((i 0) (x x0) (result (list)))
|
|
(if
|
|
(>= i (len words))
|
|
(reverse result)
|
|
(let
|
|
((w (nth words i)) (width (nth widths i)))
|
|
(loop
|
|
(+ i 1)
|
|
(+ x width space-width)
|
|
(cons {:width width :x x :y y :word w} result)))))))
|
|
(define
|
|
position-lines
|
|
(fn
|
|
(words widths line-ranges space-width line-height x0 y0)
|
|
(map-indexed
|
|
(fn
|
|
(line-idx range)
|
|
(let
|
|
((start (first range))
|
|
(end (nth range 1))
|
|
(y (+ y0 (* line-idx line-height))))
|
|
(let
|
|
((line-words (sublist words start end))
|
|
(line-widths (sublist widths start end)))
|
|
(position-line line-words line-widths space-width x0 y))))
|
|
line-ranges)))
|
|
(define
|
|
pretext-position-line
|
|
(fn
|
|
(words widths gap-w)
|
|
(let
|
|
loop
|
|
((i 0) (x 0) (acc (list)))
|
|
(if
|
|
(>= i (len words))
|
|
acc
|
|
(loop
|
|
(+ i 1)
|
|
(+ x (nth widths i) gap-w)
|
|
(append acc (list {:width (nth widths i) :x x :word (nth words i)})))))))
|
|
(define
|
|
pretext-layout-lines
|
|
(fn
|
|
(words widths ranges space-width max-width line-height)
|
|
(let
|
|
((n-lines (len ranges)))
|
|
(map
|
|
(fn
|
|
(line-idx)
|
|
(let
|
|
((range (nth ranges line-idx))
|
|
(y (* line-idx line-height)))
|
|
(let
|
|
((start (first range)) (end (nth range 1)))
|
|
(let
|
|
((lw (sublist words start end))
|
|
(lwid (sublist widths start end)))
|
|
(let
|
|
((total-w (let sum-loop ((k 0) (t 0)) (if (>= k (len lwid)) t (sum-loop (+ k 1) (+ t (nth lwid k))))))
|
|
(n-gaps (max 1 (- (len lw) 1)))
|
|
(is-last (= line-idx (- n-lines 1))))
|
|
(let
|
|
((gap (if is-last space-width (/ (- max-width total-w) n-gaps))))
|
|
{:y y :words (pretext-position-line lw lwid gap)}))))))
|
|
(range n-lines)))))
|
|
(define
|
|
make-hyphenation-trie
|
|
(fn
|
|
(patterns)
|
|
(let
|
|
((trie {:children {} :levels (list)}))
|
|
(for-each
|
|
(fn
|
|
(pattern)
|
|
(let
|
|
((chars (list)) (levels (list)) (current-level 0))
|
|
(for-each
|
|
(fn
|
|
(ch)
|
|
(if
|
|
(and (>= (char-code ch) 48) (<= (char-code ch) 57))
|
|
(set! current-level (parse-number ch))
|
|
(do
|
|
(set! chars (append chars (list ch)))
|
|
(set! levels (append levels (list current-level)))
|
|
(set! current-level 0))))
|
|
(map (fn (i) (char-at pattern i)) (range (len pattern))))
|
|
(set! levels (append levels (list current-level)))
|
|
(let
|
|
insert
|
|
((node trie) (i 0))
|
|
(if
|
|
(>= i (len chars))
|
|
(dict-set! node :levels levels)
|
|
(let
|
|
((ch (nth chars i)) (children (get node :children)))
|
|
(when
|
|
(not (has-key? children ch))
|
|
(dict-set! children ch {:children {} :levels (list)}))
|
|
(insert (get children ch) (+ i 1)))))))
|
|
patterns)
|
|
trie)))
|
|
(define
|
|
find-hyphenation-points
|
|
(fn
|
|
(trie word)
|
|
(let
|
|
((n (len word))
|
|
(padded (str "." word "."))
|
|
(pn (+ n 2))
|
|
(levels (map (fn (_) 0) (range (+ n 1)))))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(let
|
|
walk
|
|
((node trie) (j i))
|
|
(when
|
|
(< j pn)
|
|
(let
|
|
((ch (char-at padded j))
|
|
(children (get node :children)))
|
|
(when
|
|
(has-key? children ch)
|
|
(let
|
|
((child (get children ch)))
|
|
(when
|
|
(not (empty? (get child :levels)))
|
|
(let
|
|
((pat-levels (get child :levels)))
|
|
(for-each
|
|
(fn
|
|
(k)
|
|
(when
|
|
(< (+ i k) (+ n 1))
|
|
(let
|
|
((old (nth levels (+ i k)))
|
|
(new-val (nth pat-levels k)))
|
|
(when
|
|
(> new-val old)
|
|
(set!
|
|
levels
|
|
(map-indexed
|
|
(fn
|
|
(idx v)
|
|
(if (= idx (+ i k)) new-val v))
|
|
levels))))))
|
|
(range (len pat-levels)))))
|
|
(walk child (+ j 1))))))))
|
|
(range pn))
|
|
(filter
|
|
(fn
|
|
(i)
|
|
(and (> i 1) (< i (- n 1)) (= (mod (nth levels i) 2) 1)))
|
|
(range (+ n 1))))))
|
|
(define
|
|
hyphenate-word
|
|
(fn
|
|
(trie word)
|
|
(let
|
|
((points (find-hyphenation-points trie word)))
|
|
(if
|
|
(empty? points)
|
|
(list word)
|
|
(let
|
|
((starts (cons 0 points))
|
|
(ends (append points (list (len word)))))
|
|
(map-indexed (fn (i s) (slice word s (nth ends i))) starts))))))
|
|
(define
|
|
layout-paragraph
|
|
(fn
|
|
(words font size max-width line-height-factor)
|
|
(let
|
|
((metrics (map (fn (w) (measure-text font size w)) words))
|
|
(widths (map (fn (m) (get m :width)) metrics))
|
|
(height
|
|
(if (empty? metrics) size (get (first metrics) :height)))
|
|
(line-height (* height (or line-height-factor 1.4)))
|
|
(space-metrics (measure-text font size " "))
|
|
(space-width (get space-metrics :width)))
|
|
(let
|
|
((line-ranges (break-lines widths space-width max-width))
|
|
(positioned
|
|
(position-lines
|
|
words
|
|
widths
|
|
(break-lines widths space-width max-width)
|
|
space-width
|
|
line-height
|
|
0
|
|
0)))
|
|
{:lines positioned :width max-width :line-height line-height :font-height height :line-ranges line-ranges :height (* (len line-ranges) line-height)}))))
|
|
(define
|
|
typeset-plain
|
|
(fn
|
|
(text font size max-width)
|
|
(let
|
|
((words (split text " ")))
|
|
(layout-paragraph words font size max-width 1.4))))
|
|
(define
|
|
typeset
|
|
(fn
|
|
(text &key font size max-width line-height)
|
|
(let
|
|
((words (split text " "))
|
|
(f (or font "serif"))
|
|
(s (or size 16))
|
|
(w (or max-width 600))
|
|
(lh (or line-height 1.4)))
|
|
(layout-paragraph words f s w lh))))))
|
|
|
|
(import (sx text-layout)) |