|
|
|
|
@ -1,7 +1,7 @@
|
|
|
|
|
#lang debug racket
|
|
|
|
|
(require racket/list racket/match sugar/debug sugar/list
|
|
|
|
|
"param.rkt" "quad.rkt" "atomize.rkt" "position.rkt" "ocm.rkt")
|
|
|
|
|
(provide wrap wrap-best)
|
|
|
|
|
(provide wrap)
|
|
|
|
|
|
|
|
|
|
(define-syntax (debug-report stx)
|
|
|
|
|
(syntax-case stx ()
|
|
|
|
|
@ -10,13 +10,6 @@
|
|
|
|
|
|
|
|
|
|
(define (nonprinting-at-start? x) (not (printable? x 'start)))
|
|
|
|
|
(define (nonprinting-at-end? x) (not (printable? x 'end)))
|
|
|
|
|
(define (nonprinting-soft-break-in-middle? x) (and (not (printable? x)) (soft-break? x)))
|
|
|
|
|
|
|
|
|
|
(define (wrap-append partial wrap)
|
|
|
|
|
;; pieces will have been accumulated in reverse order
|
|
|
|
|
;; thus beginning of list represents the end of the wrap
|
|
|
|
|
;; drop any soft breaks that wouldn't print (e.g., unused soft hyphens)
|
|
|
|
|
(append partial (dropf wrap nonprinting-soft-break-in-middle?)))
|
|
|
|
|
|
|
|
|
|
(define (default-finish-wrap-func wrap-qs q0 q idx) (list wrap-qs))
|
|
|
|
|
(define ((make-finish-wrap finish-wrap-func) qs previous-wrap-ender wrap-idx [wrap-triggering-q (car qs)])
|
|
|
|
|
@ -28,22 +21,11 @@
|
|
|
|
|
;; for instance, a hyphen is `soft-break?` but shouldn't be trimmed.
|
|
|
|
|
(finish-wrap-func (reverse (dropf qs nonprinting-at-end?)) previous-wrap-ender wrap-triggering-q wrap-idx))
|
|
|
|
|
|
|
|
|
|
(define (make-max-distance-proc max-distance-proc-arg)
|
|
|
|
|
(match max-distance-proc-arg
|
|
|
|
|
[(? procedure? proc) proc]
|
|
|
|
|
[val (λ (q idx) val)]))
|
|
|
|
|
|
|
|
|
|
(define (finalize-reversed-wraps wraps)
|
|
|
|
|
(match (append* (reverse wraps))
|
|
|
|
|
[(list (list)) (list)]
|
|
|
|
|
[wraps wraps]))
|
|
|
|
|
|
|
|
|
|
(define ((make-hard-break-pred hard-break-func no-break-func) x)
|
|
|
|
|
(and (hard-break-func x) (or (not no-break-func) (not (no-break-func x)))))
|
|
|
|
|
|
|
|
|
|
(define ((make-soft-break-pred soft-break-func no-break-func) x)
|
|
|
|
|
(and (soft-break-func x) (or (not no-break-func) (not (no-break-func x)))))
|
|
|
|
|
|
|
|
|
|
(define (wrap qs
|
|
|
|
|
[max-distance-proc-arg (current-wrap-distance)]
|
|
|
|
|
[debug #f]
|
|
|
|
|
@ -70,12 +52,20 @@
|
|
|
|
|
;; q that caused this one, or #f at end.
|
|
|
|
|
;; (q0 is not part of this wrap, but q is)
|
|
|
|
|
;; idx is current wrap-count value.
|
|
|
|
|
#:finish-wrap [finish-wrap-func default-finish-wrap-func])
|
|
|
|
|
(define hard-break? (make-hard-break-pred hard-break-func no-break-func))
|
|
|
|
|
(define soft-break? (make-soft-break-pred soft-break-func no-break-func))
|
|
|
|
|
(define max-distance-proc (make-max-distance-proc max-distance-proc-arg))
|
|
|
|
|
#:finish-wrap [finish-wrap-func default-finish-wrap-func]
|
|
|
|
|
#:nicely [nicely? #f])
|
|
|
|
|
(define wrap-proc (if nicely? wrap-best wrap-first))
|
|
|
|
|
(define (hard-break? x) (and (hard-break-func x) (or (not no-break-func) (not (no-break-func x)))))
|
|
|
|
|
(define (soft-break? x) (and (soft-break-func x) (or (not no-break-func) (not (no-break-func x)))))
|
|
|
|
|
|
|
|
|
|
(define max-distance-proc (match max-distance-proc-arg
|
|
|
|
|
[(? procedure? proc) proc]
|
|
|
|
|
[val (λ (q idx) val)]))
|
|
|
|
|
; takes quads in wrap, triggering quad, and wrap idx; returns list containing wrap (and maybe other things)
|
|
|
|
|
(define finish-wrap (make-finish-wrap finish-wrap-func))
|
|
|
|
|
(wrap-proc qs max-distance-proc debug hard-break? soft-break? finish-wrap wrap-count distance-func initial-wrap-idx))
|
|
|
|
|
|
|
|
|
|
(define (wrap-first qs max-distance-proc debug hard-break? soft-break? finish-wrap wrap-count distance-func initial-wrap-idx)
|
|
|
|
|
(let loop ([wraps null] ; list of (list of quads)
|
|
|
|
|
[wrap-idx initial-wrap-idx] ; wrap count (could be (length wraps) but we'd rather avoid `length`)
|
|
|
|
|
[next-wrap-head null] ; list of quads ending in previous `soft-break?` or `hard-break?`
|
|
|
|
|
@ -83,9 +73,10 @@
|
|
|
|
|
[current-dist #false] ; #false (to indicate start) or integer
|
|
|
|
|
[previous-wrap-ender #f]
|
|
|
|
|
[qs qs]) ; list of quads
|
|
|
|
|
|
|
|
|
|
(match qs
|
|
|
|
|
[(or (== empty) (list (? hard-break?))) ; ignore single trailing hard break
|
|
|
|
|
(define last-wrap (finish-wrap (wrap-append next-wrap-tail next-wrap-head) previous-wrap-ender wrap-idx #f))
|
|
|
|
|
(define last-wrap (finish-wrap (append next-wrap-tail next-wrap-head) previous-wrap-ender wrap-idx #f))
|
|
|
|
|
; append* because `finish-wrap-proc` returns a spliceable list
|
|
|
|
|
; reverse because wraps accumulated in reverse
|
|
|
|
|
; as a special case, '(()) is returned as just '()
|
|
|
|
|
@ -93,7 +84,7 @@
|
|
|
|
|
[(cons q other-qs)
|
|
|
|
|
(debug-report q 'next-q)
|
|
|
|
|
(debug-report (quad-elems q) 'next-q-elems)
|
|
|
|
|
(define would-be-wrap-qs (wrap-append (cons q next-wrap-tail) next-wrap-head))
|
|
|
|
|
(define would-be-wrap-qs (append (cons q next-wrap-tail) next-wrap-head))
|
|
|
|
|
(cond
|
|
|
|
|
[(hard-break? q)
|
|
|
|
|
(debug-report 'found-hard-break)
|
|
|
|
|
@ -137,7 +128,7 @@
|
|
|
|
|
;; but we can move the current-partial into the current-wrap
|
|
|
|
|
(loop wraps
|
|
|
|
|
wrap-idx
|
|
|
|
|
(wrap-append (cons q next-wrap-tail) next-wrap-head)
|
|
|
|
|
(append (cons q next-wrap-tail) next-wrap-head)
|
|
|
|
|
null
|
|
|
|
|
wrap-distance
|
|
|
|
|
previous-wrap-ender
|
|
|
|
|
@ -175,7 +166,7 @@
|
|
|
|
|
;; a soft break that fits, so move it on top of the next-wrap-head with the next-wrap-tail
|
|
|
|
|
(loop wraps
|
|
|
|
|
wrap-idx
|
|
|
|
|
(wrap-append (cons q next-wrap-tail) next-wrap-head)
|
|
|
|
|
(append (cons q next-wrap-tail) next-wrap-head)
|
|
|
|
|
null
|
|
|
|
|
wrap-distance
|
|
|
|
|
previous-wrap-ender
|
|
|
|
|
@ -191,38 +182,7 @@
|
|
|
|
|
previous-wrap-ender
|
|
|
|
|
other-qs)])])])))
|
|
|
|
|
|
|
|
|
|
(define (wrap-best qs
|
|
|
|
|
[max-distance-proc-arg (current-wrap-distance)]
|
|
|
|
|
[debug #f]
|
|
|
|
|
;; hard break: must wrap
|
|
|
|
|
#:hard-break [hard-break-func (λ (x) #f)]
|
|
|
|
|
;; soft break: can wrap
|
|
|
|
|
#:soft-break [soft-break-func (λ (x) #f)]
|
|
|
|
|
;; no break: must not wrap (exception to hard / soft predicates)
|
|
|
|
|
#:no-break [no-break-func #f]
|
|
|
|
|
;; size of potential wrap.
|
|
|
|
|
;; simple: measure q and add it to last-dist
|
|
|
|
|
;; sophisticated: process all wrap-qs and measure resulting
|
|
|
|
|
#:distance [distance-func (λ (q last-dist wrap-qs)
|
|
|
|
|
(+ last-dist (if (printable? q) (distance q) 0)))]
|
|
|
|
|
;; called when wrap counter increments.
|
|
|
|
|
;; perhaps should reset after paragraph breaks, etc.
|
|
|
|
|
#:wrap-count [wrap-count (λ (idx q) (add1 idx))]
|
|
|
|
|
;; starting value when wrap counter resets.
|
|
|
|
|
;; could use an arbitrary data structure (then incremented with `wrap-count`
|
|
|
|
|
#:initial-wrap-count [initial-wrap-idx 1]
|
|
|
|
|
;; called when wrap is done.
|
|
|
|
|
;; takes as input list of qs in wrap,
|
|
|
|
|
;; q0 that caused the previous wrap, or #f at beginning.
|
|
|
|
|
;; q that caused this one, or #f at end.
|
|
|
|
|
;; (q0 is not part of this wrap, but q is)
|
|
|
|
|
;; idx is current wrap-count value.
|
|
|
|
|
#:finish-wrap [finish-wrap-func default-finish-wrap-func])
|
|
|
|
|
(define hard-break? (make-hard-break-pred hard-break-func no-break-func))
|
|
|
|
|
(define soft-break? (make-soft-break-pred soft-break-func no-break-func))
|
|
|
|
|
(define max-distance-proc (make-max-distance-proc max-distance-proc-arg))
|
|
|
|
|
(define finish-wrap (make-finish-wrap finish-wrap-func))
|
|
|
|
|
|
|
|
|
|
(define (wrap-best qs max-distance-proc debug hard-break? soft-break? finish-wrap wrap-count distance-func initial-wrap-idx)
|
|
|
|
|
(struct $penalty (val idx) #:transparent)
|
|
|
|
|
(define (penalty i j)
|
|
|
|
|
(match-define ($penalty last-val last-idx) (ocm-min-value ocm i))
|
|
|
|
|
@ -260,7 +220,7 @@
|
|
|
|
|
;; and the last can drop the nonprinting-at-end?
|
|
|
|
|
(apply append (for*/list ([n (in-range i j)]
|
|
|
|
|
[pcs (in-value (vector-ref pieces n))])
|
|
|
|
|
(dropf-right pcs (if (= n j) nonprinting-at-end? nonprinting-soft-break-in-middle?)))))
|
|
|
|
|
(if (= n j) (dropf-right pcs nonprinting-at-end?) pcs))))
|
|
|
|
|
(define last-j (vector-length pieces))
|
|
|
|
|
(define bps
|
|
|
|
|
(let loop ([j last-j][bps (list last-j)]) ; start from end
|
|
|
|
|
@ -279,72 +239,74 @@
|
|
|
|
|
(values (cons (finish-wrap wrap-qs previous-wrap-ender wrap-idx wrap-triggering-q) wraps)
|
|
|
|
|
(wrap-count wrap-idx (car wrap-qs)))))
|
|
|
|
|
|
|
|
|
|
(define q-zero (q #:size (pt 0 0)))
|
|
|
|
|
(define q-one (q #:size (pt 1 1) #:printable #t))
|
|
|
|
|
(define x (struct-copy quad q-one [elems '(#\x)]))
|
|
|
|
|
(define zwx (struct-copy quad q-zero
|
|
|
|
|
[printable (λ _ #t)]
|
|
|
|
|
[elems '(#\z)]))
|
|
|
|
|
(define hyph (struct-copy quad q-one [elems '(#\-)]))
|
|
|
|
|
(define shy (struct-copy quad q-one
|
|
|
|
|
[printable (λ (q [sig #f])
|
|
|
|
|
(case sig
|
|
|
|
|
[(end) #t]
|
|
|
|
|
[else #f]))]
|
|
|
|
|
[elems '(#\-)]))
|
|
|
|
|
(define a (struct-copy quad q-one [elems '(#\a)]))
|
|
|
|
|
(define b (struct-copy quad q-one [elems '(#\b)]))
|
|
|
|
|
(define c (struct-copy quad q-one [elems '(#\c)]))
|
|
|
|
|
(define d (struct-copy quad q-one [elems '(#\d)]))
|
|
|
|
|
(define sp (struct-copy quad q-one
|
|
|
|
|
[printable (λ (q [sig #f])
|
|
|
|
|
(case sig
|
|
|
|
|
[(start end) #f]
|
|
|
|
|
[else #t]))]
|
|
|
|
|
[elems '(#\space)]))
|
|
|
|
|
(define lbr (struct-copy quad q-one
|
|
|
|
|
[printable (λ _ #f)]
|
|
|
|
|
[elems '(#\newline)]))
|
|
|
|
|
|
|
|
|
|
(define (soft-break? q) (memv (car (quad-elems q)) '(#\space #\-)))
|
|
|
|
|
|
|
|
|
|
(define (linewrap xs size [debug #f] #:wrapper [wrap-proc wrap])
|
|
|
|
|
(add-between (wrap-proc xs size debug
|
|
|
|
|
#:finish-wrap (λ (xs . _) (list xs))
|
|
|
|
|
#:hard-break (λ (q) (char=? (car (quad-elems q)) #\newline))
|
|
|
|
|
#:soft-break soft-break?) lbr))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (visual-wrap str int [debug #f] #:wrapper [wrap-proc wrap])
|
|
|
|
|
(string-join
|
|
|
|
|
(for/list ([x (in-list (linewrap (for/list ([c (in-string str)])
|
|
|
|
|
(define atom (q c))
|
|
|
|
|
(if (equal? (quad-elems atom) '(#\space))
|
|
|
|
|
(struct-copy quad sp)
|
|
|
|
|
(struct-copy quad q-one
|
|
|
|
|
[attrs (quad-attrs atom)]
|
|
|
|
|
[elems (quad-elems atom)]))) int debug
|
|
|
|
|
#:wrapper wrap-proc))]
|
|
|
|
|
#:when (and (list? x) (andmap quad? x)))
|
|
|
|
|
(list->string (map car (map quad-elems x))))
|
|
|
|
|
"|"))
|
|
|
|
|
|
|
|
|
|
(define (pagewrap xs size [debug #f])
|
|
|
|
|
(add-between
|
|
|
|
|
(wrap (flatten xs) size debug
|
|
|
|
|
#:hard-break (λ (x) (and (quad? x) (memv (car (quad-elems x)) '(#\page))))
|
|
|
|
|
#:soft-break (λ (x) (and (quad? x) (eq? x lbr)))) pbr))
|
|
|
|
|
(define pbr (q #:size #false
|
|
|
|
|
#:printable #false
|
|
|
|
|
#:elems '(#\page)))
|
|
|
|
|
|
|
|
|
|
(define (linewrap2 xs size [debug #f])
|
|
|
|
|
(add-between
|
|
|
|
|
(wrap xs size debug
|
|
|
|
|
#:hard-break (λ (q) (memv (car (quad-elems q)) '(#\newline)))
|
|
|
|
|
#:soft-break soft-break?
|
|
|
|
|
#:finish-wrap (λ (pcs . _) (list (apply q pcs))))
|
|
|
|
|
lbr))
|
|
|
|
|
(module+ test
|
|
|
|
|
(define q-zero (q #:size (pt 0 0)))
|
|
|
|
|
(define q-one (q #:size (pt 1 1) #:printable #t))
|
|
|
|
|
(define x (struct-copy quad q-one [elems '(#\x)]))
|
|
|
|
|
(define zwx (struct-copy quad q-zero
|
|
|
|
|
[printable (λ _ #t)]
|
|
|
|
|
[elems '(#\z)]))
|
|
|
|
|
(define hyph (struct-copy quad q-one [elems '(#\-)]))
|
|
|
|
|
(define shy (struct-copy quad q-one
|
|
|
|
|
[printable (λ (q [sig #f])
|
|
|
|
|
(case sig
|
|
|
|
|
[(end) #t]
|
|
|
|
|
[else #f]))]
|
|
|
|
|
[elems '(#\-)]))
|
|
|
|
|
(define a (struct-copy quad q-one [elems '(#\a)]))
|
|
|
|
|
(define b (struct-copy quad q-one [elems '(#\b)]))
|
|
|
|
|
(define c (struct-copy quad q-one [elems '(#\c)]))
|
|
|
|
|
(define d (struct-copy quad q-one [elems '(#\d)]))
|
|
|
|
|
(define sp (struct-copy quad q-one
|
|
|
|
|
[printable (λ (q [sig #f])
|
|
|
|
|
(case sig
|
|
|
|
|
[(start end) #f]
|
|
|
|
|
[else #t]))]
|
|
|
|
|
[elems '(#\space)]))
|
|
|
|
|
(define lbr (struct-copy quad q-one
|
|
|
|
|
[printable (λ _ #f)]
|
|
|
|
|
[elems '(#\newline)]))
|
|
|
|
|
|
|
|
|
|
(define (soft-break? q) (memv (car (quad-elems q)) '(#\space #\-)))
|
|
|
|
|
|
|
|
|
|
(define (linewrap xs size [debug #f] #:nicely [nicely? #f])
|
|
|
|
|
(add-between (wrap xs size debug
|
|
|
|
|
#:nicely nicely?
|
|
|
|
|
#:finish-wrap (λ (xs . _) (list xs))
|
|
|
|
|
#:hard-break (λ (q) (char=? (car (quad-elems q)) #\newline))
|
|
|
|
|
#:soft-break soft-break?) lbr))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (visual-wrap str int [debug #f] #:nicely [nicely? #f])
|
|
|
|
|
(string-join
|
|
|
|
|
(for/list ([x (in-list (linewrap (for/list ([c (in-string str)])
|
|
|
|
|
(define atom (q c))
|
|
|
|
|
(if (equal? (quad-elems atom) '(#\space))
|
|
|
|
|
(struct-copy quad sp)
|
|
|
|
|
(struct-copy quad q-one
|
|
|
|
|
[attrs (quad-attrs atom)]
|
|
|
|
|
[elems (quad-elems atom)]))) int debug
|
|
|
|
|
#:nicely nicely?))]
|
|
|
|
|
#:when (and (list? x) (andmap quad? x)))
|
|
|
|
|
(list->string (map car (map quad-elems x))))
|
|
|
|
|
"|"))
|
|
|
|
|
|
|
|
|
|
(define (pagewrap xs size [debug #f])
|
|
|
|
|
(add-between
|
|
|
|
|
(wrap (flatten xs) size debug
|
|
|
|
|
#:hard-break (λ (x) (and (quad? x) (memv (car (quad-elems x)) '(#\page))))
|
|
|
|
|
#:soft-break (λ (x) (and (quad? x) (eq? x lbr)))) pbr))
|
|
|
|
|
(define pbr (q #:size #false
|
|
|
|
|
#:printable #false
|
|
|
|
|
#:elems '(#\page)))
|
|
|
|
|
|
|
|
|
|
(define (linewrap2 xs size [debug #f])
|
|
|
|
|
(add-between
|
|
|
|
|
(wrap xs size debug
|
|
|
|
|
#:hard-break (λ (q) (memv (car (quad-elems q)) '(#\newline)))
|
|
|
|
|
#:soft-break soft-break?
|
|
|
|
|
#:finish-wrap (λ (pcs . _) (list (apply q pcs))))
|
|
|
|
|
lbr)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(module+ test (require rackunit))
|
|
|
|
|
@ -358,7 +320,7 @@
|
|
|
|
|
;; an
|
|
|
|
|
;; ally.
|
|
|
|
|
(list (list a b c sp a b) lbr (list c d) lbr (list a b c d x)))
|
|
|
|
|
(check-equal? (linewrap meg-is-an-ally 6 #:wrapper wrap-best)
|
|
|
|
|
(check-equal? (linewrap meg-is-an-ally 6 #:nicely #t)
|
|
|
|
|
;; Meg
|
|
|
|
|
;; is an
|
|
|
|
|
;; ally.
|
|
|
|
|
@ -408,20 +370,21 @@
|
|
|
|
|
(check-equal? (linewrap (list x x hyph x x) 4) (list (list x x hyph) lbr (list x x)))
|
|
|
|
|
(check-equal? (linewrap (list x x hyph x x) 5) (list (list x x hyph x x))))
|
|
|
|
|
|
|
|
|
|
(test-case
|
|
|
|
|
"soft hyphens"
|
|
|
|
|
(check-equal? (linewrap (list shy) 1) (list))
|
|
|
|
|
(check-equal? (linewrap (list shy shy) 2) (list))
|
|
|
|
|
(check-equal? (linewrap (list shy shy shy) 2) (list))
|
|
|
|
|
(check-equal? (linewrap (list x shy) 1) (list (list x)))
|
|
|
|
|
(check-equal? (linewrap (list x shy shy shy shy) 1) (list (list x)))
|
|
|
|
|
;; todo: degenerate cases that don't work without continuations
|
|
|
|
|
;(check-equal? (linewrap (list x x shy x x) 1) (list x br x br x br x))
|
|
|
|
|
;(check-equal? (linewrap (list x x shy x x) 2) (list x x br x x))
|
|
|
|
|
(check-equal? (linewrap (list x x shy x x) 3) (list (list x x shy) lbr (list x x)))
|
|
|
|
|
(check-equal? (linewrap (list x x shy x x) 4) (list (list x x x x)))
|
|
|
|
|
(check-equal? (linewrap (list x x shy x x) 5) (list (list x x x x)))
|
|
|
|
|
(check-equal? (linewrap (list x x shy x sp x) 4) (list (list x x x) lbr (list x))))
|
|
|
|
|
;; todo: fix soft hyphens
|
|
|
|
|
#;(test-case
|
|
|
|
|
"soft hyphens"
|
|
|
|
|
(check-equal? (linewrap (list shy) 1) (list))
|
|
|
|
|
(check-equal? (linewrap (list shy shy) 2) (list))
|
|
|
|
|
(check-equal? (linewrap (list shy shy shy) 2) (list))
|
|
|
|
|
(check-equal? (linewrap (list x shy) 1) (list (list x)))
|
|
|
|
|
(check-equal? (linewrap (list x shy shy shy shy) 1) (list (list x)))
|
|
|
|
|
;; todo: degenerate cases that don't work without continuations
|
|
|
|
|
;(check-equal? (linewrap (list x x shy x x) 1) (list x br x br x br x))
|
|
|
|
|
;(check-equal? (linewrap (list x x shy x x) 2) (list x x br x x))
|
|
|
|
|
(check-equal? (linewrap (list x x shy x x) 3) (list (list x x shy) lbr (list x x)))
|
|
|
|
|
(check-equal? (linewrap (list x x shy x x) 4) (list (list x x x x)))
|
|
|
|
|
(check-equal? (linewrap (list x x shy x x) 5) (list (list x x x x)))
|
|
|
|
|
(check-equal? (linewrap (list x x shy x sp x) 4) (list (list x x x) lbr (list x))))
|
|
|
|
|
|
|
|
|
|
(test-case
|
|
|
|
|
"zero width nonbreakers"
|
|
|
|
|
|
