diff --git a/quad/quad/generic.rkt b/quad/quad/generic.rkt index d90e58f5..04b33d48 100644 --- a/quad/quad/generic.rkt +++ b/quad/quad/generic.rkt @@ -7,8 +7,8 @@ (end quad) (inner quad) - (size quad [condition]) - (offset quad [condition]) + (size quad [signal]) + (offset quad [signal]) (origin quad) (set-origin! quad where) diff --git a/quad/quad/position.rkt b/quad/quad/position.rkt index f009c428..73728bb6 100644 --- a/quad/quad/position.rkt +++ b/quad/quad/position.rkt @@ -18,8 +18,8 @@ (define (coerce-int x) (if (integer? x) (inexact->exact x) x)) -(define/contract (anchor->point q anchor) - (quad? symbol? . -> . point?) +(define/contract (anchor->point q anchor [signal #f]) + ((quad? symbol?) (any/c) . ->* . point?) (unless (valid-anchor? anchor) (raise-argument-error 'relative-anchor-pt "valid anchor" anchor)) (match-define (list x-fac y-fac) @@ -27,20 +27,22 @@ [(nw) '(0 0 )] [(n) '(0.5 0 )] [(ne) '(1 0 )] [( w) '(0 0.5)] [(c) '(0.5 0.5)] [( e) '(1 0.5)] [(sw) '(0 1 )] [(s) '(0.5 1 )] [(se) '(1 1 )])) - (pt (coerce-int (* (pt-x (size q)) x-fac)) (coerce-int (* (pt-y (size q)) y-fac)))) + (match-define (list x y) (size q signal)) + (pt (coerce-int (* x x-fac)) (coerce-int (* y y-fac)))) +(define point/c ((quad?) (any/c) . ->* . point?)) -(define/contract (inner-point q) - (quad? . -> . point?) - (pt+ (origin q) (anchor->point q (inner q)) (offset q))) +(define/contract (inner-point q [signal #f]) + point/c + (pt+ (origin q) (anchor->point q (inner q) signal) (offset q))) -(define/contract (start-point q) - (quad? . -> . point?) - (anchor->point q (start q))) +(define/contract (start-point q [signal #f]) + point/c + (anchor->point q (start q) signal)) -(define/contract (end-point q) - (quad? . -> . point?) - (pt+ (origin q) (anchor->point q (end q)))) ; no offset because end-point is calculated without padding +(define/contract (end-point q [signal #f]) + point/c + (pt+ (origin q) (anchor->point q (end q) signal))) ; no offset because end-point is calculated without padding (define/contract (position q [previous-end-pt (pt 0 0)]) diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index 0b6a1e4d..e5207f97 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -1,8 +1,15 @@ #lang debug racket/base -(require racket/match racket/function racket/dict "generic.rkt") +(require racket/match racket/function racket/promise racket/dict "generic.rkt") (provide (all-defined-out)) (module+ test (require rackunit)) +(define (default-size-proc q sig) + (match (elems q) + [(list (? char-whitespace? c)) (case sig + [(start end) '(0 0)] + [else '(1 1)])] + [else '(1 1)])) + (struct $quad (attrs elems) #:transparent #:mutable #:methods gen:quad [(define (elems q) ($quad-elems q)) @@ -10,8 +17,12 @@ (define (start q) (hash-ref (attrs q) 'start 'nw)) (define (end q) (hash-ref (attrs q) 'end 'ne)) (define (inner q) (hash-ref (attrs q) 'inner (λ () (start q)))) - (define (size q [condition #f]) (hash-ref (attrs q) 'size '(1 1))) - (define (offset q [condition #f]) (hash-ref (attrs q) 'offset '(0 0))) + (define (size q [signal #f]) (let ([v (hash-ref (attrs q) 'size (λ () (default-size-proc q signal)))]) + (cond + [(procedure? v) (v signal)] + [(promise? v) (force v)] + [else v]))) + (define (offset q [signal #f]) (hash-ref (attrs q) 'offset '(0 0))) (define (origin q) (hash-ref (attrs q) 'origin '(0 0))) (define (set-origin! q val) (set-$quad-attrs! q (hash-set (attrs q) 'origin val))) (define (draw q [surface #f] [origin #f]) ((hash-ref (attrs q) 'draw (λ () (λ () (println ""))))))]) @@ -24,7 +35,7 @@ [(list #f xs ...) (apply quad #:type type (hasheq) xs)] [(list (list (? symbol? sym) rest ...) (? quad-elem? elems) ...) (type (apply hasheq (cons sym rest)) elems)] [(list (? dict? attrs) (? quad-elem? elems) ...) (type (for/hasheq ([(k v) (in-dict attrs)]) - (values k v)) elems)] + (values k v)) elems)] [(list (? quad-attrs? attrs) (? quad-elem? elems) ...) (type attrs elems)] [(list (? quad-elem? elems) ...) (apply quad #:type type #f elems)] [else (error 'bad-quad-input)])) diff --git a/quad/quad/wrap.rkt b/quad/quad/wrap.rkt index cd2b2150..cda33555 100644 --- a/quad/quad/wrap.rkt +++ b/quad/quad/wrap.rkt @@ -1,38 +1,47 @@ #lang debug racket/base (require racket/contract racket/list racket/match txexpr sugar/debug sugar/define sugar/list racket/promise racket/function (only-in racket/control call/prompt) - "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt") + "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt" "position.rkt") + +(define/contract (distance q [signal #f]) + ((any/c) (any/c) . ->* . real?) + (cond + [(quad? q) + (match-define (list ∆x ∆y) (map - (end-point q signal) (start-point q signal))) + (cond + [(zero? ∆x) ∆y] + [(zero? ∆y) ∆x] + [else (sqrt (+ (* ∆x ∆x) (* ∆y ∆y)))])] + [else 0])) + (define+provide/contract (wrap xs - [target-size (current-line-width)] - [debug #f] - #:break-val [break-val 'break] - #:mandatory-break-proc [mandatory-break? (const #f)] - #:optional-break-proc [optional-break? (const #f)] - #:finish-segment-proc [finish-segment-proc values] - #:size-proc [size-proc (const 1)]) - ((any/c) (integer? any/c - #:break-val any/c - #:mandatory-break-proc procedure? - #:optional-break-proc procedure? - #:size-proc procedure? - #:finish-segment-proc procedure?) . ->* . (listof any/c)) + [target-size (current-line-width)] + [debug #f] + #:break-val [break-val 'break] + #:mandatory-break-proc [mandatory-break? (const #f)] + #:optional-break-proc [optional-break? (const #f)] + #:finish-segment-proc [finish-segment-proc values]) + ((any/c) (real? any/c + #:break-val any/c + #:mandatory-break-proc procedure? + #:optional-break-proc procedure? + #:finish-segment-proc procedure?) . ->* . (listof any/c)) (define start-signal (gensym)) (define (finish-segment pieces) (finish-segment-proc (reverse (dropf pieces optional-break?)))) (define last-optional-break-k #f) (call/prompt ;; continuation boundary for last-optional-break-k (thunk - (define (capture-optional-break-k!) (let/cc k (set! last-optional-break-k k) #f)) + (define (capture-optional-break-k!) (when debug (report 'capture)) (let/cc k (set! last-optional-break-k k) #f)) (for/fold ([segments null] [pieces null] - [size-so-far start-signal] + [dist-so-far start-signal] #:result (append* (reverse (cons (finish-segment pieces) segments)))) ([x (in-list xs)]) - (define-values (size-start size-mid size-end) (size-proc x)) - (define at-start? (eq? size-so-far start-signal)) - (define underflow? (and (not at-start?) (<= (+ size-so-far size-end) target-size))) + (define at-start? (eq? dist-so-far start-signal)) + (define underflow? (and (not at-start?) (<= (+ dist-so-far (distance x 'end)) target-size))) (define (add-to-segment) (values segments (cons x pieces) (if at-start? - size-start - (+ size-so-far size-mid)))) + (distance x 'start) + (+ dist-so-far (distance x))))) (define (insert-break) ;; when break is found, q is omitted from accumulation ;; and any preceding optional breaks are dropped (that would be trailing before the break) @@ -42,7 +51,7 @@ (insert-break)] [(optional-break? x) (cond - [at-start? (when debug (report x 'skipping-opt-break-at-beginning)) (values segments null size-so-far)] + [at-start? (when debug (report x 'skipping-opt-break-at-beginning)) (values segments null dist-so-far)] [(and underflow? (capture-optional-break-k!)) (when debug (report x 'resuming-breakpoint)) (set! last-optional-break-k #f) ;; prevents continuation loop (insert-break)] @@ -54,29 +63,28 @@ (last-optional-break-k #t)] [else (when debug (report x 'falling-back)) (match-define-values (vals _ _) (insert-break)) - (values vals (list x) size-start)]))))) ;; fallback if no last-breakpoint-k exists + (values vals (list x) (distance x 'start))]))))) ;; fallback if no last-breakpoint-k exists -(define x (q (hasheq 'size (delay (values 1 1 1))) #\x)) -(define zwx (q (hasheq 'size (delay (values 0 0 0))) #\z)) -(define a (q (hasheq 'size (delay (values 1 1 1))) #\a)) -(define b (q (hasheq 'size (delay (values 1 1 1))) #\b)) -(define c (q (hasheq 'size (delay (values 1 1 1))) #\c)) -(define d (q (hasheq 'size (delay (values 1 1 1))) #\d)) -(define sp (q (hasheq 'size (delay (values 0 1 0))) #\space)) -(define br (q (hasheq 'size (delay (values 0 0 0))) #\newline)) + +(define x (q #f #\x)) +(define zwx (q (list 'size (pt 0 0)) #\z)) +(define a (q #f #\a)) +(define b (q #f #\b)) +(define c (q #f #\c)) +(define d (q #f #\d)) +(define sp (q (list 'size (λ (sig) + (case sig + [(start end) (pt 0 0)] + [else (pt 1 1)]))) #\space)) +(define br (q (list 'size (pt 0 0)) #\newline)) (define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space))))) (define (linewrap xs size [debug #f]) (wrap xs size debug - #:break-val 'lb - #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline)))) - #:optional-break-proc optional-break? - #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ () - (if (memv (car (elems q)) '(#\space)) - (delay (values 0 1 0)) - (delay (values 1 1 1)))))]) - (if (promise? val) (force val) (val)))))) + #:break-val 'lb + #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline)))) + #:optional-break-proc optional-break?)) (module+ test (require rackunit) @@ -100,6 +108,7 @@ (check-equal? (linewrap (list a sp b) 3) (list a sp b)) (check-equal? (linewrap (list x sp x x) 3) (list x 'lb x x))) + (test-case "leading & trailing spaces" (check-equal? (linewrap (list sp x) 2) (list x)) @@ -107,7 +116,7 @@ (check-equal? (linewrap (list sp x sp) 2) (list x)) (check-equal? (linewrap (list sp sp x sp sp) 2) (list x)) (check-equal? (linewrap (list sp sp x sp sp x sp) 1) (list x 'lb x))) - + (test-case "zero width nonbreakers" (check-equal? (linewrap (list sp zwx) 2) (list zwx)) @@ -138,8 +147,8 @@ (check-equal? (linewrap (list x x x sp x x) 2) (list x x 'lb x 'lb x x)) (check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x))) - (define (visual-wrap str int) - (apply string (for/list ([b (in-list (linewrap (atomize str) int))]) + (define (visual-wrap str int [debug #f]) + (apply string (for/list ([b (in-list (linewrap (atomize str) int debug))]) (cond [(quad? b) (car (elems b))] [else #\|])))) @@ -163,16 +172,12 @@ (check-equal? (visual-wrap "My dog has fleas" 15) "My dog has|fleas") (check-equal? (visual-wrap "My dog has fleas" 16) "My dog has fleas")) - (define (pagewrap xs size [debug #f]) (wrap xs size debug - #:break-val 'pb - #:mandatory-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page)))) - #:optional-break-proc (λ (x) (eq? x 'lb)) - #:size-proc (λ (q) (case q - [(lb) (values 0 0 0)] - [else (values 1 1 1)])))) - (define pbr (q (hasheq 'size (delay (values 0 0 0))) #\page)) + #:break-val 'pb + #:mandatory-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page)))) + #:optional-break-proc (λ (x) (eq? x 'lb)))) + (define pbr (q '(size (0 0)) #\page)) (test-case "soft page breaks" @@ -208,11 +213,6 @@ #:break-val 'lb #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline)))) #:optional-break-proc optional-break? - #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ () - (if (memv (car (elems q)) '(#\space)) - (delay (values 0 1 0)) - (delay (values 1 1 1)))))]) - (if (promise? val) (force val) (val)))) #:finish-segment-proc (λ (pcs) (list ($slug #f pcs))))) (module+ test diff --git a/quad/quad/wrap2.rkt b/quad/quad/wrap2.rkt deleted file mode 100644 index 310fe5f5..00000000 --- a/quad/quad/wrap2.rkt +++ /dev/null @@ -1,108 +0,0 @@ -#lang debug racket/base -(require racket/contract racket/list racket/match txexpr sugar/debug sugar/define sugar/list racket/promise racket/function (only-in racket/control call/prompt) - "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt" "position.rkt") - -(define/contract (distance q [signal #f]) - ((quad?) (any/c) . ->* . real?) - (match-define (list x0 y0) (start-point q)) - (match-define (list x1 y1) (end-point q)) - ;; pythagorically - (sqrt (+ (expt (- x1 x0) 2) (expt (- y1 y0) 2)))) - - -(define+provide/contract (wrap xs - [target-size (current-line-width)] - [debug #f] - #:break-val [break-val 'break] - #:mandatory-break-proc [mandatory-break? (const #f)] - #:optional-break-proc [optional-break? (const #f)] - #:finish-segment-proc [finish-segment-proc values]) - ((any/c) (real? any/c - #:break-val any/c - #:mandatory-break-proc procedure? - #:optional-break-proc procedure? - #:finish-segment-proc procedure?) . ->* . (listof any/c)) - (define start-signal (gensym)) - (define (finish-segment pieces) (finish-segment-proc (reverse (dropf pieces optional-break?)))) - (define last-optional-break-k #f) - (call/prompt ;; continuation boundary for last-optional-break-k - (thunk - (define (capture-optional-break-k!) (let/cc k (set! last-optional-break-k k) #f)) - (for/fold ([segments null] - [pieces null] - [size-so-far start-signal] - #:result (append* (reverse (cons (finish-segment pieces) segments)))) - ([x (in-list xs)]) - (define at-start? (eq? size-so-far start-signal)) - (define underflow? (and (not at-start?) (<= (+ size-so-far (size x 'end)) target-size))) - (define (add-to-segment) (values segments (cons x pieces) (if at-start? - (size x 'start) - (+ size-so-far (size x))))) - (define (insert-break) - ;; when break is found, q is omitted from accumulation - ;; and any preceding optional breaks are dropped (that would be trailing before the break) - (values (list* (list break-val) (finish-segment pieces) segments) null start-signal)) - (cond - [(mandatory-break? x) (when debug (report x 'got-mandatory-break)) - (insert-break)] - [(optional-break? x) - (cond - [at-start? (when debug (report x 'skipping-opt-break-at-beginning)) (values segments null size-so-far)] - [(and underflow? (capture-optional-break-k!)) (when debug (report x 'resuming-breakpoint)) - (set! last-optional-break-k #f) ;; prevents continuation loop - (insert-break)] - [else (when debug (report x 'add-optional-break)) - (add-to-segment)])] - [(or at-start? underflow?) (when debug (report x 'add-ordinary-char)) - (add-to-segment)] - [last-optional-break-k (when debug (report x 'invoking-last-breakpoint)) - (last-optional-break-k #t)] - [else (when debug (report x 'falling-back)) - (match-define-values (vals _ _) (insert-break)) - (values vals (list x) (size x 'start))]))))) ;; fallback if no last-breakpoint-k exists - - - -(define x (q (hasheq) #\x)) -(define zwx (q (hasheq 'size (delay (values 0 0 0))) #\z)) -(define a (q (hasheq 'size (delay (values 1 1 1))) #\a)) -(define b (q (hasheq 'size (delay (values 1 1 1))) #\b)) -(define c (q (hasheq 'size (delay (values 1 1 1))) #\c)) -(define d (q (hasheq 'size (delay (values 1 1 1))) #\d)) -(define sp (q (hasheq 'size (delay (values 0 1 0))) #\space)) -(define br (q (hasheq 'size (delay (values 0 0 0))) #\newline)) -(define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space))))) - -(define (linewrap xs size [debug #f]) - (wrap xs size debug - #:break-val 'lb - #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline)))) - #:optional-break-proc optional-break? - #| - #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ () - (if (memv (car (elems q)) '(#\space)) - (delay (values 0 1 0)) - (delay (values 1 1 1)))))]) - (if (promise? val) (force val) (val)))) - - |# - )) - -(module+ test - (require rackunit) - - (test-case - "chars" - (check-equal? (linewrap (list) 1) null) - (check-equal? (linewrap (list x) 1) (list x)) - #| - (check-equal? (linewrap (list x x) 1) (list x 'lb x)) - (check-equal? (linewrap (list x x x) 1) (list x 'lb x 'lb x)) - (check-equal? (linewrap (list x x x) 2) (list x x 'lb x)) - (check-equal? (linewrap (list x x x x) 2) (list x x 'lb x x)) - (check-equal? (linewrap (list x x x x x) 3) (list x x x 'lb x x)) - (check-equal? (linewrap (list x x x x x) 1) (list x 'lb x 'lb x 'lb x 'lb x)) - (check-equal? (linewrap (list x x x x x) 10) (list x x x x x)) -|# - - )) \ No newline at end of file