;; 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
    layout-paragraph
    make-hyphenation-trie
    find-hyphenation-points
    hyphenate-word
    typeset
    typeset-plain)
  (begin
    (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 (fn (s e) (list s e)) starts ends)))))))
    (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 (slice words start end))
                  (line-widths (slice widths start end)))
                (position-line line-words line-widths space-width x0 y))))
          line-ranges)))
    (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 (fn (s e) (slice word s e)) starts ends))))))
    (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))))))

(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))))))))

(import (sx text-layout))