partial typing

quad/main-typed-tests.rkt

@@ -23,7 +23,3 @@
 
 
 (check-equal? (log-debug-lines (list (line (list world:line-looseness-key 42.0) (word #f "bar")))) '("0/1: \"bar\" 42.0"))
-
-
-;; todo next: debug this line
-(block->lines (block #f (word '(measure 50.0) "Meg is an ally.")))

quad/main-typed.rkt

@@ -10,8 +10,7 @@
   (All (A B) ((Listof A) (Listof B) -> (Pairof (Listof A) (Listof B))))
   ((inst cons (Listof A) (Listof B)) ((inst reverse A) xs) ys))
 
-(provide input->nested-blocks)
-(define/typed (input->nested-blocks i)
+(define/typed+provide (input->nested-blocks i)
   (Quad . -> . (Listof Multipage-Type))
   (define-values (mps mcs bs b)
     (for/fold ([multipages : (Listof Multipage-Type) empty]
@@ -26,20 +25,17 @@
         [else (values multipages multicolumns blocks (cons q block-acc))])))
   (reverse (cons-reverse (cons-reverse ((inst cons-reverse Quad Block-Type) b bs) mcs) mps)))
 
-(provide merge-adjacent-within)
-(define/typed (merge-adjacent-within q)
+(define/typed+provide (merge-adjacent-within q)
   (Quad . -> . Quad)
   (quad (quad-name q) (quad-attrs q) (join-quads (cast (quad-list q) (Listof Quad)))))
 
-(provide hyphenate-quad-except-last-word)
-(define/typed (hyphenate-quad-except-last-word q)
+(define/typed+provide (hyphenate-quad-except-last-word q)
   (Quad . -> . Quad)
   (log-quad-debug "last word will not be hyphenated")
   (define-values (first-quads last-quad) ((inst split-last QuadListItem) (quad-list q)))
   (quad (quad-name q) (quad-attrs q) (snoc ((inst map QuadListItem QuadListItem) hyphenate-quad first-quads) last-quad)))
 
-(provide average-looseness)
-(define/typed (average-looseness lines)
+(define/typed+provide (average-looseness lines)
   ((Listof Quad) . -> . Flonum)
   (if (<= (length lines) 1)
       0.0
@@ -47,8 +43,7 @@
         (round-float (/ (foldl fl+ 0.0 ((inst map Flonum Quad) (λ(line) (cast (quad-attr-ref line world:line-looseness-key 0.0) Flonum)) lines-to-measure)) (- (fl (length lines)) 1.0))))))
 
 
-(provide log-debug-lines)
-(define/typed (log-debug-lines lines)
+(define/typed+provide (log-debug-lines lines)
   ((Listof Quad) . -> . (Listof String)) 
   (log-quad-debug "line report:")
   (for/list : (Listof String) ([(line idx) (in-indexed lines)])
@@ -58,8 +53,7 @@
             (quad-attr-ref line world:line-looseness-key))))
 
 
-(provide block->lines)
-(define/typed (block->lines b)
+(define/typed+provide (block->lines b)
   (Quad . -> . (Listof Quad)) ;; todo: introduce a Quad subtype where quad-list is guaranteed to be all Quads (no strings)
   (define quality (cast (quad-attr-ref/parameter b world:quality-key) Real))
   (define/typed (wrap-quads qs)
@@ -93,3 +87,93 @@
   (map insert-spacers-in-line
        (for/list : (Listof Quad) ([line-idx (in-naturals)][line (in-list wrapped-lines)])
          (quad-attr-set* line 'line-idx line-idx 'lines (length wrapped-lines)))))
+
+
+(define/typed+provide (number-pages ps)
+  ((Listof Quad) . -> . (Listof Quad))
+  (for/list ([i (in-naturals)][p (in-list ps)])
+    (quad (quad-name p) (merge-attrs (quad-attrs p) `(page ,i)) (quad-list p))))
+
+(define/typed+provide (pages->doc ps)
+  ((Listof Quad) . -> . Quad)  
+  ;; todo: resolve xrefs and other last-minute tasks
+  ;; todo: generalize computation of widths and heights, recursively
+  (define (columns-mapper page)
+    (quad-map (compose1 add-vert-positions (λ(xs) (quad-map (λ(x) (compute-line-height (add-horiz-positions (fill (cast x Quad))))) (cast xs Quad)))) (cast page Quad)))
+  (define mapped-pages (map columns-mapper (number-pages ps)))
+  (define doc (quads->doc mapped-pages))
+  doc)
+
+(require racket/class)
+(require/typed csp
+               [problem%  (Class (init-field) 
+                                   (get-solution (-> HashTableTop)))])
+(define/typed+provide (lines->columns lines)
+  ((Listof Quad) . -> . (Listof Quad)) ; (lines? . -> . columns?)
+  (define prob (new problem%))
+  #;(define max-column-lines world:default-lines-per-column)
+  (define-values (columns ignored-return-value)
+    (for/fold ([columns : (Listof Quad) empty][lines-remaining : (Listof Quad) lines])
+              ([col-idx : Nonnegative-Integer (stop-before (in-naturals) (λ(x) (empty? lines-remaining)))])
+      #;(log-quad-info "making column ~a" (add1 col-idx))
+      ;; domain constraint is best way to simplify csp, because it limits the search space.
+      ;; search from largest possible value to smallest.
+      ;; largest possible is the minimum of the max column lines, or 
+      ;; the number of lines left (modulo minimum page lines) ...
+      #;(define viable-column-range
+        (range (min max-column-lines (max 
+                                      (length lines-remaining)
+                                      (- (length lines-remaining) world:minimum-lines-per-column)))
+               ;; ... and the smallest possible is 1, or the current minimum lines.
+               ;; (sub1 insures that range is inclusive of last value.)
+               (sub1 (min 1 world:minimum-lines-per-column)) -1))
+      
+      #;(log-quad-debug "viable number of lines for this column to start =\n~a" viable-column-range)
+      #;(send prob add-variable "column-lines" viable-column-range)
+      
+      
+      ;; greediness constraint: leave enough lines for next page, or take all
+      #;(define (greediness-constraint pl)
+        (define leftover (- (length lines-remaining) pl))
+        (or (= leftover 0) (>= leftover world:minimum-lines-per-column)))
+      #;(send prob add-constraint greediness-constraint '("column-lines"))
+      
+      #;(log-quad-debug "viable number of lines after greediness constraint =\n~a" (map (λ(x) (hash-ref x "column-lines")) (send prob get-solutions)))
+      
+      ;; last lines constraint: don't take page that will end with too few lines of last paragraph.
+      #;(define (last-lines-constraint pl) 
+        (define last-line-of-page (list-ref lines-remaining (sub1 pl)))
+        (define lines-in-this-paragraph (quad-attr-ref last-line-of-page world:total-lines-key))
+        (define line-index-of-last-line (quad-attr-ref last-line-of-page world:line-index-key))
+        (define (paragraph-too-short-to-meet-constraint?)
+          (< lines-in-this-paragraph world:min-last-lines))
+        (or (paragraph-too-short-to-meet-constraint?)
+            (>= (add1 line-index-of-last-line) world:min-last-lines)))
+      #;(send prob add-constraint last-lines-constraint '("column-lines"))
+      
+      #;(log-quad-debug "viable number of lines after last-lines constraint =\n~a" (map (λ(x) (hash-ref x "column-lines")) (send prob get-solutions)))
+      
+      ;; first lines constraint: don't take page that will leave too few lines at top of next page
+      #;(define (first-lines-constraint pl lines-remaining)
+        (define last-line-of-page (list-ref lines-remaining (sub1 pl)))
+        (define lines-in-this-paragraph (quad-attr-ref last-line-of-page world:total-lines-key))
+        (define line-index-of-last-line (quad-attr-ref last-line-of-page world:line-index-key))
+        (define lines-that-will-remain (- lines-in-this-paragraph (add1 line-index-of-last-line)))
+        (define (paragraph-too-short-to-meet-constraint?)
+          (< lines-in-this-paragraph world:min-first-lines))
+        (or (paragraph-too-short-to-meet-constraint?)
+            (= 0 lines-that-will-remain) ; ok to use all lines ...
+            (>= lines-that-will-remain world:min-first-lines))) ; but if any remain, must be minimum number.
+      #;(send prob add-constraint (λ(x) (first-lines-constraint x lines-remaining)) '("column-lines"))
+      
+      #;(log-quad-debug "viable number of lines after first-lines constraint =\n~a" (map (λ(x) (hash-ref x "column-lines")) (send prob get-solutions)))
+      
+      
+      (define s (send prob get-solution))
+      (define how-many-lines-to-take (cast (hash-ref s "column-lines") Positive-Index))
+      (define-values (lines-to-take lines-to-leave) (split-at lines-remaining how-many-lines-to-take))
+      #;(log-quad-debug "taking ~a lines for column ~a:" how-many-lines-to-take (add1 col-idx))
+      #;(map (λ(idx line) (log-quad-debug "~a:~a ~v" (add1 col-idx) (add1 idx) (quad->string line))) (range how-many-lines-to-take) lines-to-take)
+      #;(send prob reset)
+      (values (cons (quad-attr-set (quads->column lines-to-take) world:column-index-key col-idx) columns) lines-to-leave)))
+  (reverse columns))

quad/main.rkt

@@ -80,9 +80,7 @@
     (quad (quad-name p) (merge-attrs (quad-attrs p) `(page ,i)) (quad-list p))))
 
 (define+provide/contract (pages->doc ps)
-  (pages? . -> . doc?)
-  (map quad-attrs (quad-list (first ps)))
-  
+  (pages? . -> . doc?)  
   ;; todo: resolve xrefs and other last-minute tasks
   ;; todo: generalize computation of widths and heights, recursively
   (define (columns-mapper page)

quad/quads-typed.rkt

@@ -21,6 +21,20 @@
          (: proc-name type-expr)
          (define proc-name body ...))]))
 
+(define-syntax (define/typed+provide stx)
+  (syntax-case stx ()
+    [(_ (proc-name arg ... . rest-arg) type-expr body ...)
+     #'(begin
+         (provide proc-name)
+         (define/typed proc-name type-expr
+           (λ(arg ... . rest-arg) body ...)))]
+    [(_ proc-name type-expr body ...)
+     #'(begin
+         (provide proc-name)
+         (begin
+         (: proc-name type-expr)
+         (define proc-name body ...)))]))
+
 
 (define-syntax-rule (even-members xs)
   (for/list : (Listof Any) ([(x i) (in-indexed xs)] #:when (even? i))
@@ -98,9 +112,8 @@
       [(string? x) x]
       [else ""])))
 
-(provide gather-common-attrs)
-(: gather-common-attrs ((Listof Quad) . -> . (U False HashableList)))
-(define (gather-common-attrs qs)
+(define/typed+provide (gather-common-attrs qs)
+  ((Listof Quad) . -> . (U False HashableList))
   (: check-cap (QuadAttrPair . -> . Boolean))
   (define (check-cap cap)
     (equal? (quad-attr-ref (car qs) (car cap) attr-missing) (cdr cap)))

quad/utils-typed.rkt

@@ -5,8 +5,7 @@
 (require (for-syntax racket/syntax racket/base) racket/string (except-in racket/list flatten) sugar/debug racket/bool racket/function math/flonum)
 (require "quads-typed.rkt" "world-typed.rkt" "measure-typed.rkt")
 
-(provide quad-map)
-(define/typed (quad-map proc q)
+(define/typed+provide (quad-map proc q)
   ((QuadListItem . -> . QuadListItem) Quad . -> . Quad)
   (quad (quad-name q) (quad-attrs q) (map proc (quad-list q))))
 
@@ -22,9 +21,8 @@
 
 ;; push together multiple attr sources into one list of pairs.
 ;; mostly a helper function for the two attr functions below.
-(provide join-attrs)
-(: join-attrs ((Listof (U Quad QuadAttrs HashableList)) . -> . (Listof QuadAttrPair)))
-(define (join-attrs quads-or-attrs-or-lists)
+(define/typed+provide (join-attrs quads-or-attrs-or-lists)
+  ((Listof (U Quad QuadAttrs HashableList)) . -> . (Listof QuadAttrPair))
   ((inst append-map QuadAttrPair QuadAttrs) (inst hash->list QuadAttrKey QuadAttrValue) (map (λ(x)
                                                                                                (cond
                                                                                                  [(quad? x) (quad-attrs x)]
@@ -36,9 +34,8 @@
 
 ;; flatten merges attributes, but applies special logic suitable to flattening
 ;; for instance, resolving x and y coordinates.
-(provide flatten-attrs)
-(: flatten-attrs ((U Quad QuadAttrs) * . -> . QuadAttrs))
-(define (flatten-attrs . quads-or-attrs-or-falses)
+(define/typed+provide (flatten-attrs . quads-or-attrs-or-falses)
+  ((U Quad QuadAttrs) * . -> . QuadAttrs)
   (define all-attrs (join-attrs quads-or-attrs-or-falses))
   (define-values (x-attrs y-attrs other-attrs-reversed)
     (for/fold ([xas : (Listof QuadAttrPair) null]
@@ -61,9 +58,8 @@
 
 ;; merge concatenates attributes, with later ones overriding earlier.
 ;; most of the work is done by join-attrs.
-(provide merge-attrs)
-(: merge-attrs ((U Quad QuadAttrs HashableList) * . -> . QuadAttrs))
-(define (merge-attrs . quads-or-attrs-or-lists)
+(define/typed+provide (merge-attrs . quads-or-attrs-or-lists)
+  ((U Quad QuadAttrs HashableList) * . -> . QuadAttrs)
   (for/hash : QuadAttrs ([kv-pair (in-list (join-attrs quads-or-attrs-or-lists))])
     (values (car kv-pair) (cdr kv-pair))))
 
@@ -71,9 +67,8 @@
 
 ;; pushes attributes down from parent quads to children, 
 ;; resulting in a flat list of quads.
-(provide flatten-quad)
-(: flatten-quad (Quad . -> . (Listof Quad)))
-(define (flatten-quad q)
+(define/typed+provide (flatten-quad q)
+  (Quad . -> . (Listof Quad))
   (cast (flatten 
          (let loop : (Treeof Quad)
            ([x : QuadListItem q][parent : Quad (box)])
@@ -93,9 +88,8 @@
 ;; flatten quad as above, 
 ;; then dissolve it into individual character quads while copying attributes
 ;; input is often large, so macro allows us to avoid allocation
-(provide split-quad)
-(: split-quad (Quad . -> . (Listof Quad)))
-(define (split-quad q)
+(define/typed+provide (split-quad q)
+  (Quad . -> . (Listof Quad))
   (: do-explode ((QuadListItem) (Quad) . ->* . (Treeof Quad)))
   (define (do-explode x [parent (box)])
     (cond
@@ -112,8 +106,7 @@
 ;; if two quads are mergeable types, and have the same attributes,
 ;; they get merged.
 ;; input is often large, so macro allows us to avoid allocation
-(provide join-quads)
-(define/typed (join-quads qs-in)
+(define/typed+provide (join-quads qs-in)
   ((Listof Quad) . -> . (Listof Quad))
   
   (let ([make-matcher (λ ([base-q : Quad])
@@ -148,9 +141,8 @@
 
 ;; propagate x and y adjustments throughout the tree,
 ;; using parent x and y to adjust children, and so on.
-(provide compute-absolute-positions)
-(: compute-absolute-positions (Quad . -> . Quad))
-(define (compute-absolute-positions qli)
+(define/typed+provide (compute-absolute-positions qli)
+  (Quad . -> . Quad)
   (define result 
     (let loop : QuadListItem ([qli : QuadListItem qli][parent-x : Flonum 0.0][parent-y : Flonum 0.0])
     (cond
@@ -166,39 +158,34 @@
 
 
 ;; functionally update a quad attr. Similar to hash-set
-(provide quad-attr-set)
-(: quad-attr-set (Quad QuadAttrKey QuadAttrValue . -> . Quad)) 
-(define (quad-attr-set q k v)
+(define/typed+provide (quad-attr-set q k v)
+  (Quad QuadAttrKey QuadAttrValue . -> . Quad)
   (quad (quad-name q) (merge-attrs (quad-attrs q) (list k v)) (quad-list q)))
 
 
 ;; functionally update multiple quad attrs. Similar to hash-set*
-(provide quad-attr-set*)
-(: quad-attr-set* (Quad (U QuadAttrKey QuadAttrValue) * . -> . Quad))
-(define (quad-attr-set* q . kvs)
+(define/typed+provide (quad-attr-set* q . kvs)
+  (Quad (U QuadAttrKey QuadAttrValue) * . -> . Quad)
   (for/fold ([current-q q])([kv-list (in-list (slice-at kvs 2))])
     (apply quad-attr-set current-q kv-list)))
 
 ;; functionally remove a quad attr. Similar to hash-remove
-(provide quad-attr-remove)
-(: quad-attr-remove (Quad QuadAttrKey . -> . Quad))
-(define (quad-attr-remove q k)
+(define/typed+provide (quad-attr-remove q k)
+  (Quad QuadAttrKey . -> . Quad)
   (if (quad-attrs q)
       (quad (quad-name q) (hash-remove (quad-attrs q) k) (quad-list q))
       q))
 
 ;; functionally remove multiple quad attrs. Similar to hash-remove*
-(provide quad-attr-remove*)
-(: quad-attr-remove* (Quad QuadAttrKey * . -> . Quad))
-(define (quad-attr-remove* q . ks)
+(define/typed+provide (quad-attr-remove* q . ks)
+  (Quad QuadAttrKey * . -> . Quad)
   (for/fold ([current-q q])([k (in-list ks)])
     (quad-attr-remove current-q k)))
 
 
 ;; the last char of a quad
-(provide quad-last-char)
-(: quad-last-char (Quad . -> . (Option String)))
-(define (quad-last-char q)
+(define/typed+provide (quad-last-char q)
+  (Quad . -> . (Option String))
   (define split-qs (split-quad q)) ; split makes it simple, but is it too expensive?
   (if (or (empty? split-qs) (empty? (quad-list (last split-qs))))
       #f
@@ -208,9 +195,8 @@
             result))))
 
 ;; the first char of a quad
-(provide quad-first-char)
-(: quad-first-char (Quad . -> . (Option String)))
-(define (quad-first-char q)
+(define/typed+provide (quad-first-char q)
+  (Quad . -> . (Option String))
   (define split-qs (split-quad q)) ; explosion makes it simple, but is it too expensive?
   (if (or (empty? split-qs) (empty? (quad-list (first split-qs))))
       #f
@@ -220,9 +206,30 @@
             result))))
 
 
+;; todo: how to guarantee line has leading key?
+(define/typed+provide (compute-line-height line)
+  (Quad . -> . Quad)
+  (quad-attr-set line world:height-key (quad-attr-ref/parameter line world:leading-key)))
+
+(define/typed (fixed-height? q)
+  (Quad . -> . Boolean)
+  (quad-has-attr? q world:height-key))
+
+(define/typed+provide (quad-height q)
+  (Quad . -> . Flonum)
+  (cast (quad-attr-ref q world:height-key 0.0) Flonum))
+
+;; use heights to compute vertical positions
+(define/typed+provide (add-vert-positions starting-quad)
+  (Quad . -> . Quad)
+  (define-values (new-quads final-height)
+    (for/fold ([new-quads : (Listof Quad) empty][height-so-far : Flonum 0.0])([q (in-list (cast (quad-list starting-quad) (Listof Quad)))])
+      (values (cons (quad-attr-set q world:y-position-key height-so-far) new-quads) 
+              (round-float (+ height-so-far (quad-height q))))))
+  (quad (quad-name starting-quad) (quad-attrs starting-quad) (reverse new-quads)))
+
 ;; recursively hyphenate strings in a quad
-(provide hyphenate-quad)
-(define/typed (hyphenate-quad x)
+(define/typed+provide (hyphenate-quad x)
   (QuadListItem . -> . QuadListItem)
   (cond
     [(quad? x) (quad-map hyphenate-quad x)]
@@ -233,8 +240,7 @@
     [else x]))
 
 ;; just because it comes up a lot
-(provide split-last)
-(define/typed (split-last xs)
+(define/typed+provide (split-last xs)
   (All (A) ((Listof A) -> (values (Listof A) A)))
   (let-values ([(first-list last-list) ((inst split-at-right A) xs 1)])
     (values first-list (car last-list))))

quad/wrap-typed.rkt

@@ -222,8 +222,7 @@
 ;; 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.
-(provide insert-spacers-in-line)
-(define/typed (insert-spacers-in-line line [alignment-override #f])
+(define/typed+provide (insert-spacers-in-line line [alignment-override #f])
   ((Quad) ((Option Symbol)) . ->* . Quad)
   ;; important principle: avoid peeking into quad-list to get attributes.
   ;; because non-attributed quads may be added.
@@ -252,12 +251,14 @@
   (quad (quad-name line) 
         (quad-attrs line) 
         (cast (flatten (let ([qs (cast (quad-list line) (Listof Quad))])
-                         `(,@(cast (if before (copy-with-attrs before (first qs)) null) (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) 
-                           ,@(cast (if after (copy-with-attrs after (last qs)) null) (Listof Quad))
+                         ;; (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)))
 
 
@@ -524,23 +525,25 @@
 
 
 ;; wrap proc based on greedy proc
-(provide wrap-first) 
-(define wrap-first (make-wrap-proc  
+(define-syntax-rule (define+provide name expr ...)
+  (begin 
+    (provide name)
+    (define name expr ...)))
+
+(define+provide wrap-first (make-wrap-proc  
                     make-pieces 
                     quad-width 
                     pieces->line 
                     (λ(x y) (adaptive-fit-proc (cast x (Vectorof Quad)) (cast y Flonum) #t #f))))
 
 ;; wrap proc based on penalty function
-(provide wrap-best)
-(define wrap-best (make-wrap-proc
+(define+provide wrap-best (make-wrap-proc
                    make-pieces
                    quad-width
                    pieces->line
-                   (λ(x y) (adaptive-fit-proc (cast x (Vectorof Quad)) (cast y Flonum) #f #t))))
+                   (λ(x y) (adaptive-fit-proc (cast x (Vectorof Quad)) (cast y Flonum) #f #t)))) ; note difference in boolean args
 
-(provide wrap-adaptive)
-(define wrap-adaptive (make-wrap-proc 
+(define+provide wrap-adaptive (make-wrap-proc 
                        make-pieces
                        quad-width
                        pieces->line
@@ -554,8 +557,8 @@
 
 ;; build quad out to a given width by distributing excess into spacers
 ;; todo: adjust this to work recursively, so that fill operation cascades down
-(define/typed (fill starting-quad [target-width? #f])
-  ((Quad) ((U False Flonum)) . ->* . Quad)
+(define/typed+provide (fill starting-quad [target-width? #f])
+  ((Quad) ((Option Flonum)) . ->* . Quad)
   (define target-width (fl (or target-width? (cast (quad-attr-ref starting-quad world:measure-key) Flonum)))) 
   (define subquads (cast (quad-list starting-quad) (Listof Quad)))
   (define-values (flexible-subquads fixed-subquads) (partition spacer? subquads)) ; only puts fill into spacers.
@@ -577,7 +580,7 @@
 
 ;; add x positions to a list of fixed-width quads
 ;; todo: adjust this to work recursively, so that positioning operation cascades down
-(define/typed (add-horiz-positions starting-quad)
+(define/typed+provide (add-horiz-positions starting-quad)
   (Quad . -> . Quad)
   (define-values (new-quads final-width)
     (for/fold ([new-quads : (Listof Quad) empty][width-so-far : Flonum 0.0])([qi (in-list (quad-list starting-quad))])