diff --git a/quad/core-types.rkt b/quad/core-types.rkt index be0fafb7..bb37bc7e 100644 --- a/quad/core-types.rkt +++ b/quad/core-types.rkt @@ -37,6 +37,7 @@ (define-type+predicate QuadName Symbol) (define-type+predicate QuadAttrKey Symbol) (define-type+predicate QuadAttrValue (U Float Index String Symbol Boolean Quad QuadAttrs QuadList Integer)) + ;; QuadAttr could be a list, but that would take twice as many cons cells. ;; try the economical approach. (define-type+predicate QuadAttr (Pairof QuadAttrKey QuadAttrValue)) @@ -48,7 +49,8 @@ (define-type QuadListItem (U String Quad)) (define-type+predicate QuadList (Listof QuadListItem)) -(define-type+predicate GroupQuadList (Listof Quad)) +(define-type GroupQuadListItem Quad) +(define-type+predicate GroupQuadList (Listof GroupQuadListItem)) (define-type (Treeof A) (Rec as (U A (Listof as)))) @@ -56,9 +58,12 @@ (define-type+predicate Quad (List* QuadName QuadAttrs QuadList)) (define-type+predicate GroupQuad (List* QuadName QuadAttrs GroupQuadList)) (define-predicate quad? Quad) -(define/typed (quad name attrs items) - (QuadName QuadAttrs QuadList . -> . Quad) - `(,name ,attrs ,@items)) + +;; quad wants to be generic +;; if it's a function, it must impose a type on its output value +;; whereas if it's syntax, it can avoid demanding or imposing any typing +(define-syntax-rule (quad name attrs items) + (list* name attrs items)) (define-type+predicate QuadSet (List QuadName QuadAttrs (Listof Quad))) diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index d3b2d23e..a974ff25 100644 --- a/quad/quads-typed.rkt +++ b/quad/quads-typed.rkt @@ -17,8 +17,6 @@ (for/list : (Listof Any) ([(x i) (in-indexed xs)] #:when (even? i)) x)) - - (define/typed (quad-name q) (Quad . -> . QuadName) (car q)) @@ -139,35 +137,32 @@ (define-syntax (define-quad-type stx) (syntax-case stx () - [(_ id) + [(_ id) + #'(define-quad-type id #f)] + [(_ id wants-group?) (with-syntax ([id? (format-id #'id "~a?" #'id)] - ;; [id-integer (string->number (symbol->string (gensym "")))] - [idsym (format-id #'id "~asym" #'id)] [IdQuad (format-id #'id "~aQuad" (string-titlecase (symbol->string (syntax->datum #'id))))] [IdQuad? (format-id #'id "~aQuad?" (string-titlecase (symbol->string (syntax->datum #'id))))] - [IdGroupQuad (format-id #'id "~aGroupQuad" (string-titlecase (symbol->string (syntax->datum #'id))))] - [IdGroupQuad? (format-id #'id "~aGroupQuad?" (string-titlecase (symbol->string (syntax->datum #'id))))] [quads->id (format-id #'id "quads->~a" #'id)]) - #'(begin + #`(begin ;; quad converter (define/typed (quads->id qs) - ((Listof Quad) . -> . Quad) + ((Listof Quad) . -> . IdQuad) (apply id (gather-common-attrs qs) qs)) - - ;; (define-type IdInteger id-integer) ; for experimental quad names (= faster, smaller fixnum names) - (define-type IdQuad (List* 'id QuadAttrs (Listof (U String Quad)))) + + (define-type IdQuad (List* 'id QuadAttrs #,(if (syntax->datum #'wants-group?) + #'GroupQuadList + #'QuadList))) (define-predicate IdQuad? IdQuad) - - ;; group version of quad has no strings in its quad-list - (define-type IdGroupQuad (List* 'id QuadAttrs (Listof Quad))) - (define-predicate IdGroupQuad? IdGroupQuad) (define id? IdQuad?) (define/typed (id [attrs '()] #:zzz [zzz 0] . xs) - (() ((U QuadAttrs HashableList) #:zzz Zero) #:rest QuadListItem . ->* . Quad) + (() ((U QuadAttrs HashableList) #:zzz Zero) #:rest #,(if (syntax->datum #'wants-group?) + #'GroupQuadListItem + #'QuadListItem) . ->* . IdQuad) (quad 'id (if (QuadAttrs? attrs) - attrs - (make-quadattrs attrs)) xs))))])) + attrs + (make-quadattrs attrs)) xs))))])) (define/typed (whitespace? x [nbsp? #f]) ((Any) (Boolean) . ->* . Boolean) @@ -183,7 +178,9 @@ (define-syntax (define-break-type stx) (syntax-case stx () - [(_ id) + [(_ id) + #'(define-break-type id #f)] + [(_ id wants-group?) (with-syntax ([split-on-id-breaks (format-id #'id "split-on-~a-breaks" #'id)] [id-break (format-id #'id "~a-break" #'id)] [id-break? (format-id #'id "~a-break?" #'id)] @@ -191,9 +188,9 @@ [multi-id? (format-id #'id "multi~a?" #'id)] [quads->multi-id (format-id #'id "quads->multi~a" #'id)]) #'(begin - (define-quad-type id) - (define-quad-type id-break) - (define-quad-type multi-id) + (define-quad-type id wants-group?) + (define-quad-type id-break) ; break is not necessarily a group + (define-quad-type multi-id wants-group?) ; multi-id is always a group ;; breaker (: split-on-id-breaks ((Listof Quad) . -> . (Listof (Listof Quad)))) (define (split-on-id-breaks xs) @@ -231,7 +228,7 @@ (define-quad-type flag) (define-quad-type doc) (define-quad-type input) -(define-quad-type piece) +(define-quad-type piece #t) (define-quad-type run) @@ -242,8 +239,9 @@ (if (and (not (null? ql)) (string? (car ql))) (car ql) "")) -(define-break-type page) -(define-break-type column) -(define-break-type block) -(define-break-type line) + +(define-break-type page #t) +(define-break-type column #t) +(define-break-type block #t) +(define-break-type line #t) diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt index 48d2a538..3fe22516 100644 --- a/quad/utils-typed.rkt +++ b/quad/utils-typed.rkt @@ -66,7 +66,7 @@ ;; ordinary flatten won't work because a quad is a bare list, ;; and flatten will go too far. ;; this version adds a check for quadness to the flattener. -(define/typed (flatten-quadtree quad-tree) +(define/typed+provide (flatten-quadtree quad-tree) ((Treeof Quad) . -> . (Listof Quad)) (let loop ([sexp quad-tree][acc : (Listof Quad) null]) (cond [(null? sexp) acc] @@ -171,25 +171,43 @@ result)) +;; these helper functions isolate the generic functionality. +;; problem with quad-attr-set and other Quad->Quad functions +;; is that they strip out type. +;; whereas these "surgical" alternatives can be used when preserving type is essential +(define/typed+provide (attr-change qas kvs) + (QuadAttrs HashableList . -> . QuadAttrs) + (merge-attrs qas kvs)) + +(define/typed+provide (attr-delete qas . ks) + (QuadAttrs QuadAttrKey * . -> . QuadAttrs) + (filter (λ([qa : QuadAttr]) (not (ormap (λ(k) (equal? (car qa) k)) ks))) qas)) + + ;; functionally update a quad attr. Similar to hash-set (define/typed+provide (quad-attr-set q k v) - (Quad QuadAttrKey QuadAttrValue . -> . Quad) + (case-> + (GroupQuad QuadAttrKey QuadAttrValue . -> . GroupQuad) + (Quad QuadAttrKey QuadAttrValue . -> . Quad)) (quad-attr-set* q (list k v))) ;; functionally update multiple quad attrs. Similar to hash-set* (define/typed+provide (quad-attr-set* q kvs) - (Quad HashableList . -> . Quad) - (quad (quad-name q) (merge-attrs (quad-attrs q) kvs) (quad-list q))) - + (case-> + (GroupQuad HashableList . -> . GroupQuad) + (Quad HashableList . -> . Quad)) + (quad (quad-name q) (attr-change (quad-attrs q) kvs) (quad-list q))) ;; functionally remove multiple quad attrs. Similar to hash-remove* (define/typed+provide (quad-attr-remove* q . ks) - (Quad QuadAttrKey * . -> . Quad) + (case-> + (GroupQuad QuadAttrKey * . -> . GroupQuad) + (Quad QuadAttrKey * . -> . Quad)) (if (not (empty? (quad-attrs q))) ;; test all ks as a set so that iteration through attrs only happens once - (quad (quad-name q) (filter (λ([qa : QuadAttr]) (not (ormap (λ(k) (equal? (car qa) k)) ks))) (quad-attrs q)) (quad-list q)) + (quad (quad-name q) (apply attr-delete (quad-attrs q) ks) (quad-list q)) q)) diff --git a/quad/wrap-typed.rkt b/quad/wrap-typed.rkt index cff3568c..19c05985 100644 --- a/quad/wrap-typed.rkt +++ b/quad/wrap-typed.rkt @@ -1,11 +1,12 @@ #lang typed/racket/base (require (for-syntax racket/base racket/syntax)) (require/typed sugar/list [slicef-after ((Listof Quad) (Quad . -> . Boolean) . -> . (Listof (Listof Quad)))] - [shift ((Listof Any) (Listof Integer) . -> . (Listof Any))] - [break-at ((Listof Quad) (Listof Nonnegative-Integer) . -> . (Listof (Listof Quad)))]) + ;; shift: need False in type because shift fills with #f + [shift ((Listof Quad) (Listof Integer) . -> . (Listof (Listof (U False Quad))))] + [break-at ((Listof PieceQuad) (Listof Nonnegative-Integer) . -> . (Listof (Listof PieceQuad)))]) (require math/flonum (except-in racket/list flatten) racket/vector math/statistics racket/bool) (require/typed racket/list [flatten (All (A) (Rec as (U Any (Listof as))) -> (Listof Any))]) -(require "ocm-typed.rkt" "quads-typed.rkt" "utils-typed.rkt" "measure-typed.rkt" "world-typed.rkt" "logger-typed.rkt" "core-types.rkt") +(require "ocm-typed.rkt" "quads-typed.rkt" "utils-typed.rkt" "measure-typed.rkt" "world-typed.rkt" "logger-typed.rkt" "core-types.rkt" "utils-typed.rkt") ;; predicate for the soft hyphen (define/typed (soft-hyphen? x) @@ -77,15 +78,15 @@ ;; meaning, a line can wrap at a piece boundary, but not elsewhere. ;; hyphenation produces more, smaller pieces, which means more linebreak opportunities ;; but this also makes wrapping slower. -(define-type Make-Pieces-Type ((Listof Quad) . -> . (Listof Quad))) +(define-type Make-Pieces-Type ((Listof Quad) . -> . (Listof PieceQuad))) (define/typed (make-pieces qs) Make-Pieces-Type (define-values (breakable-items items-to-make-unbreakable) (split-at-right qs (min world:minimum-last-line-chars (length qs)))) (define unbreak-qs (append breakable-items (map make-unbreakable items-to-make-unbreakable))) (define lists-of-quads (slicef-after unbreak-qs (λ([q : Quad]) (and (possible-word-break-quad? q) (not (quad-attr-ref q world:unbreakable-key #f)))))) - (define-values (first-lists-of-quads last-list-of-quads) ((inst split-last (Listof Quad)) lists-of-quads)) + (define-values (first-lists-of-quads last-list-of-quads) (split-last lists-of-quads)) (define/typed (make-first-pieces qs) - ((Listof Quad) . -> . Quad) + ((Listof Quad) . -> . PieceQuad) (let-values ([(first-qs last-q) ((inst split-last Quad) qs)]) (apply piece (list world:word-break-key (convert-to-word-break last-q)) first-qs))) (append (map make-first-pieces first-lists-of-quads) @@ -115,7 +116,7 @@ [(ormap (λ([pred : (Any . -> . Boolean)]) (pred q)) (list char? run? word? word-break?)) (apply measure-text (word-string q) (font-attributes-with-defaults q))] - [(LineGroupQuad? q) (foldl fl+ 0.0 (map quad-width (quad-list q)))] + [(LineQuad? q) (foldl fl+ 0.0 (map quad-width (quad-list q)))] [else 0.0])) ;; get the ascent (distance from top of text to baseline) @@ -140,15 +141,15 @@ ;; and thus give correct behavior to trailing word spaces, soft hyphens, etc. (define/typed (render-piece p [before-break? #f]) - ((Quad) (Boolean) . ->* . Quad) + ((PieceQuad) (Boolean) . ->* . PieceQuad) ;; a piece doesn't necessarily have a word-break item in it. ;; only needs it if the appearance of the piece changes based on location. ;; so words are likely to have a word-break item; boxes not. ;; the word break item contains the different characters needed to finish the piece. - (define the-word-break (assert (quad-attr-ref p world:word-break-key #f) (λ(v) (or (false? v) (Quad? v))))) - (let ([p (quad-attr-remove p world:word-break-key)]) ; so it doesn't propagate into subquads + (define the-word-break (assert (quad-attr-ref p world:word-break-key #f) (λ(v) (or (false? v) (Word-BreakQuad? v))))) + (let ([p (apply piece (attr-delete (quad-attrs p) world:word-break-key) (quad-list p))]) ; so it doesn't propagate into subquads (if the-word-break - (quad (quad-name p) (quad-attrs p) + (apply piece (quad-attrs p) (append (quad-list p) (let ([rendered-wb ((if before-break? word-break->before-break word-break->no-break) the-word-break)]) @@ -160,26 +161,26 @@ ;; shorthand (define/typed (render-piece-before-break p) - (Quad . -> . Quad) + (PieceQuad . -> . PieceQuad) (render-piece p #t)) ;; helper macro to convert quad into word-break. ;; look up the break character and convert the quad based on what is found. (define/typed (render-word-break wb key) - (Quad Symbol . -> . Quad) + (Word-BreakQuad Symbol . -> . Quad) (let ([break-char (quad-attr-ref wb key)]) (quad (if (whitespace? break-char) 'word-break 'word) (quad-attrs (quad-attr-remove* wb world:no-break-key world:before-break-key)) (list (assert (quad-attr-ref wb key) string?))))) ;; uses macro above in no-break mode. (define/typed (word-break->no-break wb) - (Quad . -> . Quad) + (Word-BreakQuad . -> . Quad) (render-word-break wb world:no-break-key)) ;; uses macro above in before-break mode. (define/typed (word-break->before-break wb) - (Quad . -> . Quad) + (Word-BreakQuad . -> . Quad) (render-word-break wb world:before-break-key)) ;; is this the last line? compare current line-idx to total lines @@ -208,11 +209,10 @@ (cond [(not (empty? exploded-line-quads)) ;; after exploding, each quad will have a string with one character. - (define shifted-lists (shift exploded-line-quads '(1 0 -1))) - (define lefts (cast (first shifted-lists) (Listof (U Quad False)))) ;; need False in type because shift fills with #f - (define centers (cast (second shifted-lists) (Listof Quad))) ;; don't need False because shift is 0 (no fill) - (define rights (cast (third shifted-lists) (Listof (U Quad False)))) ;; need False in type because shift fills with #f - (for/list : (Listof Quad) ([(q-left q q-right) (in-parallel lefts centers rights)]) + (define shifted-lists (shift exploded-line-quads '(1 -1))) + (define lefts (first shifted-lists)) + (define rights (second shifted-lists)) + (for/list : (Listof Quad) ([(q-left q q-right) (in-parallel lefts exploded-line-quads rights)]) (if (optical-kern? q) (quad-attr-set q world:width-key (fl+ (overhang-width q-left) (overhang-width q-right))) q))] @@ -223,17 +223,17 @@ ;; spacers are used to soak up extra space left over in a line. ;; depending on where the spacers are inserted, different formatting effects are achieved. ;; e.g., left / right / centered / justified. -(define/typed+provide (insert-spacers-in-line line [alignment-override #f]) - ((Quad) ((Option Symbol)) . ->* . Quad) +(define/typed+provide (insert-spacers-in-line line-in [alignment-override #f]) + ((LineQuad) ((Option Symbol)) . ->* . LineQuad) ;; important principle: avoid peeking into quad-list to get attributes. ;; because non-attributed quads may be added. ;; here, we know that common attributes are hoisted into the line. ;; so rely on line attributes to get horiz alignment. - (define key-to-use (if (and (last-line? line) (quad-has-attr? line world:horiz-alignment-last-line-key)) + (define key-to-use (if (and (last-line? line-in) (quad-has-attr? line-in world:horiz-alignment-last-line-key)) world:horiz-alignment-last-line-key world:horiz-alignment-key)) - (define horiz-alignment (or alignment-override (quad-attr-ref line key-to-use (world:horiz-alignment-default)))) + (define horiz-alignment (or alignment-override (quad-attr-ref line-in key-to-use (world:horiz-alignment-default)))) (define default-spacer (spacer)) (define-values (before middle after) (case horiz-alignment [(left) (values #f #f default-spacer)] @@ -249,18 +249,14 @@ (quad-attrs (apply quad-attr-remove* attr-source keys-to-ignore)))) (quad (quad-name q) (merge-attrs (or filtered-attrs null) q) (quad-list q))) - (quad (quad-name line) - (quad-attrs line) - (cast (flatten (let ([qs (cast (quad-list line) (Listof Quad))]) - ;; (first qs) is a single quad, but wrap it in a list to make it spliceable - `(,@(cast (if before (list (copy-with-attrs before (first qs))) null) (Listof Quad)) - ,@(map (λ([q : Quad]) (if (and middle (takes-justification-space? q)) - (let ([interleaver (copy-with-attrs middle q)]) - (list interleaver q interleaver)) - q)) qs) - ;; (last qs) is a single quad, but wrap it in a list to make it spliceable - ,@(cast (if after (list (copy-with-attrs after (last qs))) null) (Listof Quad)) - ))) QuadList))) + (apply line (quad-attrs line-in) + (flatten-quadtree (let ([qs (quad-list line-in)]) + (list (if before (copy-with-attrs before (first qs)) null) + (map (λ([q : Quad]) (if (and middle (takes-justification-space? q)) + (let ([interleaver (copy-with-attrs middle q)]) + (list interleaver q interleaver)) + (list q))) qs) + (if after (copy-with-attrs after (last qs)) null)))))) ;; installs the width in the quad. @@ -276,9 +272,9 @@ ;; helper function: doesn't need contract because it's already covered by the callers (define/typed (render-pieces ps) - ((Listof Quad) . -> . (Listof Quad)) - (define-values (initial-ps last-p) (split-last ps)) - (snoc ((inst map Quad Quad) render-piece (cast initial-ps (Listof Quad))) (render-piece-before-break (cast last-p Quad)))) + ((Listof PieceQuad) . -> . (Listof PieceQuad)) + (define-values (initial-ps last-p) ((inst split-last PieceQuad) ps)) + (snoc (map render-piece initial-ps) (render-piece-before-break last-p))) (define/typed (calc-looseness total-width measure) @@ -290,7 +286,7 @@ ;; take the contents of the rendered pieces and merge them. ;; compute looseness for line as a whole. ;; also add ascent to each component quad, which can be different depending on font & size. -(define-type Compose-Line-Type ((Listof Quad) (Quad . -> . Float) . -> . Quad)) +(define-type Compose-Line-Type ((Listof PieceQuad) (Quad . -> . Float) . -> . LineQuad)) (define/typed (pieces->line ps measure-quad-proc) Compose-Line-Type @@ -326,13 +322,13 @@ (let* ([new-line-quads (map embed-width merged-quads merged-quad-widths)] [new-line-quads (map record-ascent new-line-quads)] [new-line (quads->line new-line-quads)] - [new-line (quad-attr-set new-line world:line-looseness-key looseness)]) + [new-line (apply line (attr-change (quad-attrs new-line) (list world:line-looseness-key looseness)) (quad-list new-line))]) new-line)) ;; a faster line-measuring function used by the wrapping function to test lines. (define/typed (measure-potential-line ps) - ((Listof Quad) . -> . Float) + ((Listof PieceQuad) . -> . Float) (cast (for*/sum : (U Float Zero) ([rendered-piece (in-list (render-pieces ps))] [piece-quad (in-list (quad-list rendered-piece))]) @@ -363,11 +359,11 @@ qs ((inst map Quad Quad) (λ(q) (quad-attr-set q world:measure-key measure)) qs))]) (log-quad-debug "wrapping on measure = ~a" measure) - (define pieces : (Listof Quad) (make-pieces-proc qs)) + (define pieces : (Listof PieceQuad) (make-pieces-proc qs)) (define bps : (Listof Nonnegative-Integer) (find-breakpoints-proc (list->vector pieces) measure)) - (define broken-pieces : (Listof (Listof Quad)) (break-at pieces bps)) + (define broken-pieces : (Listof (Listof PieceQuad)) (break-at pieces bps)) #; (define-type Compose-Line-Type ((Listof Quad) (Quad . -> . Float) . -> . Quad)) - (map (λ([broken-piece : (Listof Quad)]) (compose-line-proc broken-piece measure-quad-proc)) broken-pieces)))) ; 80% of runtime + (map (λ([broken-piece : (Listof PieceQuad)]) (compose-line-proc broken-piece measure-quad-proc)) broken-pieces)))) ; 80% of runtime (define width? flonum?) (define measure? flonum?) @@ -566,8 +562,9 @@ ;; build quad out to a given width by distributing excess into spacers ;; todo: adjust this to work recursively, so that fill operation cascades down +;; and broaden type from just LineQuad (define/typed+provide (fill starting-quad [target-width? #f]) - ((Quad) ((Option Float)) . ->* . Quad) + ((LineQuad) ((Option Float)) . ->* . LineQuad) (define target-width (fl (or target-width? (cast (quad-attr-ref starting-quad world:measure-key) Float)))) (define subquads (cast (quad-list starting-quad) (Listof Quad))) (define-values (flexible-subquads fixed-subquads) (partition spacer? subquads)) ; only puts fill into spacers. @@ -584,7 +581,7 @@ (quad-attr-set q world:width-key width-per-flexible-quad) q)) subquads)) - (quad (quad-name starting-quad) (quad-attrs (quad-attr-set starting-quad world:width-key target-width)) new-quad-list)])) + (apply line (quad-attrs (quad-attr-set starting-quad world:width-key target-width)) new-quad-list)])) ;; add x positions to a list of fixed-width quads