From daaf82e511e06c2fd5ab782403c594a7804535c3 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 6 Feb 2018 23:05:42 -0800 Subject: [PATCH] break --- quad/quad/atomize.rkt | 2 +- quad/quad/break.rkt | 173 +++++++++++++++++++++--------------------- 2 files changed, 89 insertions(+), 86 deletions(-) diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index 18162763..2c215aa9 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -15,7 +15,7 @@ (define/contract (atomize qx) ;; normalize a quad by reducing it to one-character quads. ;; propagate attrs downward. - (quad? . -> . atomic-quads?) + (quad? . -> . (listof atomic-quad?)) (let loop ([x qx][attrs (current-default-attrs)]) (match x [(? char? c) (list (q attrs c))] diff --git a/quad/quad/break.rkt b/quad/quad/break.rkt index 8b7e79df..acbd9900 100644 --- a/quad/quad/break.rkt +++ b/quad/quad/break.rkt @@ -1,94 +1,97 @@ -#lang racket/base -(require racket/contract racket/list txexpr sugar/debug +#lang sugar/debug racket/base +(require racket/contract racket/list txexpr sugar/debug racket/promise "param.rkt" "qexpr.rkt" "atomize.rkt") (module+ test (require rackunit)) -(define/contract (break qs-in [target-size (current-line-width)] - #:size-proc [size-proc (λ () 1)] - #:break-start-key [break-start-key 'break-start] - #:break-end-key [break-end-key 'break-end] - #:breakable-proc [breakable? (λ (q) #t)]) - (((listof qexpr?)) (integer? #:size-proc procedure? - #:break-start-key symbol? - #:break-end-key symbol? - #:breakable-proc procedure?) . ->* . (listof qexpr?)) +(define/contract (break xs-in [target-size (current-line-width)]) + (((listof (or/c promise? procedure?))) (integer?) . ->* . (listof any/c)) (define last-breakpoint-k (λ (x) (error 'no-breakpoint-found))) (define (capture-k!) (let/cc k (set! last-breakpoint-k k) #f)) - (for/fold ([qs null] - [acc-size 0] - #:result (reverse qs)) - ([q (in-list qs-in)] - [next-q (in-list (append (cdr qs-in) (list #f)))]) - (define next-acc-size (and next-q (+ acc-size (size-proc next-q)))) + (define start-key 'start) + (define end-key 'end) + (for/fold ([xs null] + [size-so-far 0] + #:result (reverse xs)) + ([(x idx) (in-indexed xs-in)]) + (define-values (size-start size-mid size-end) (if (promise? x) (force x) (x))) (cond - [(or (not next-acc-size) (and (breakable? next-q) (capture-k!))) - (values (cons (attr-set q break-end-key "true") qs) 0)] - [(zero? acc-size) (if (breakable? q) - (values (cons q qs) 0) - (values (cons (attr-set q break-start-key "true") qs) next-acc-size))] - [(< next-acc-size target-size) (values (cons q qs) next-acc-size)] + [(zero? size-so-far) ;; looking for break-start + (values (cons (and (positive? size-start) start-key) xs) size-start)] ;; size-start is either zero or positive + ;; looking for break-end + [(or (= idx (sub1 (length xs-in))) ; x is last element, thus must be break-end + (and (positive? size-end) (capture-k!))) ; store possible break-end candidate + (values (cons end-key xs) 0)] + [(< (+ size-so-far size-end) target-size) ;; check condition based on size-end (as if x were breakpoint) ... + (values (cons #f xs) (+ size-so-far size-mid))] ;; but recur based on size-mid + ;; todo bug: but this doesn't work right with a trailing sequence of word spaces [else (last-breakpoint-k #t)]))) -(module+ test - (check-equal? (break (atomize "aaa bb cc ddddd") 5 - #:size-proc (λ (q) 1) - #:break-start-key 'line-start - #:break-end-key 'line-end - #:breakable-proc (λ (q) (equal? (second q) " "))) - '((q ((line-start "true")) "a") - (q "a") - (q ((line-end "true")) "a") - (q " ") - (q ((line-start "true")) "b") - (q "b") - (q " ") - (q "c") - (q ((line-end "true")) "c") - (q " ") - (q ((line-start "true")) "d") - (q "d") - (q "d") - (q "d") - (q ((line-end "true")) "d"))) - (check-equal? - (break (atomize "aaa bb cc ddddd") 6 - #:size-proc (λ (q) 1) - #:break-start-key 'line-start - #:break-end-key 'line-end - #:breakable-proc (λ (q) (equal? (second q) " "))) - '((q ((line-start "true")) "a") - (q "a") - (q "a") - (q " ") - (q "b") - (q ((line-end "true")) "b") - (q " ") - (q ((line-start "true")) "c") - (q ((line-end "true")) "c") - (q " ") - (q ((line-start "true")) "d") - (q "d") - (q "d") - (q "d") - (q ((line-end "true")) "d"))) +;; todo bug: break lists have to be >= 2 elements +;; todo bug: constrain breaking to certain junctures +(define char (delay (values 1 1 1))) +(define space (delay (values 0 1 0))) +(break (list char char char space char char space char char space char char char char char) 2) - (check-equal? (break (atomize "aaa bb cc ddddd") 8 - #:size-proc (λ (q) 1) - #:break-start-key 'line-start - #:break-end-key 'line-end - #:breakable-proc (λ (q) (equal? (second q) " "))) - '((q ((line-start "true")) "a") - (q "a") - (q "a") - (q " ") - (q "b") - (q ((line-end "true")) "b") - (q " ") - (q ((line-start "true")) "c") - (q "c") - (q " ") - (q "d") - (q "d") - (q "d") - (q "d") - (q ((line-end "true")) "d")))) \ No newline at end of file +#;(module+ test + (check-equal? (break (atomize "aaa bb cc ddddd") 5 + #:size-proc (λ (q) 1) + #:break-start-key 'line-start + #:break-end-key 'line-end + #:breakable-proc (λ (q) (equal? (second q) " "))) + '((q ((line-start "true")) "a") + (q "a") + (q ((line-end "true")) "a") + (q " ") + (q ((line-start "true")) "b") + (q "b") + (q " ") + (q "c") + (q ((line-end "true")) "c") + (q " ") + (q ((line-start "true")) "d") + (q "d") + (q "d") + (q "d") + (q ((line-end "true")) "d"))) + (check-equal? + (break (atomize "aaa bb cc ddddd") 6 + #:size-proc (λ (q) 1) + #:break-start-key 'line-start + #:break-end-key 'line-end + #:breakable-proc (λ (q) (equal? (second q) " "))) + '((q ((line-start "true")) "a") + (q "a") + (q "a") + (q " ") + (q "b") + (q ((line-end "true")) "b") + (q " ") + (q ((line-start "true")) "c") + (q ((line-end "true")) "c") + (q " ") + (q ((line-start "true")) "d") + (q "d") + (q "d") + (q "d") + (q ((line-end "true")) "d"))) + + (check-equal? (break (atomize "aaa bb cc ddddd") 8 + #:size-proc (λ (q) 1) + #:break-start-key 'line-start + #:break-end-key 'line-end + #:breakable-proc (λ (q) (equal? (second q) " "))) + '((q ((line-start "true")) "a") + (q "a") + (q "a") + (q " ") + (q "b") + (q ((line-end "true")) "b") + (q " ") + (q ((line-start "true")) "c") + (q "c") + (q " ") + (q "d") + (q "d") + (q "d") + (q "d") + (q ((line-end "true")) "d")))) \ No newline at end of file