refaction

quad/quad/base.rkt

@@ -0,0 +1,12 @@
+#lang racket/base
+
+(require
+  "quad.rkt"
+  "position.rkt"
+  "param.rkt"
+  "util.rkt")
+
+(provide (all-from-out "quad.rkt"
+                       "position.rkt"
+                       "param.rkt"
+                       "util.rkt"))

quad/quad/quad.rkt

@@ -201,6 +201,16 @@
   
 (define q make-quad)
 
+(define only-prints-in-middle (λ (q sig) (not (memq sig '(start end)))))
+
+(define/match (from-parent qs [where #f])
+  ;; doesn't change any positioning. doesn't depend on state. can happen anytime.
+  ;; can be repeated without damage.
+  [((? null?) _) null]
+  [((cons q rest) where)
+   (quad-update! q [from-parent (or where (quad-from q))])
+   (cons q rest)])
+
 (module+ test
   (require racket/port)
   (define q1 (q #f #\H #\e #\l #\o))

quad/quadwriter/block.rkt

@@ -4,10 +4,7 @@
          "log.rkt"
          "debug.rkt"
          "struct.rkt"
-         "line.rkt"
+         quad/base
-         quad/quad
-         quad/util
-         quad/position
          pitfall)
 (provide (all-defined-out))
 

quad/quadwriter/column.rkt

@@ -1,15 +1,11 @@
 #lang debug racket
 (require "attrs.rkt"
          "struct.rkt"
-         "line.rkt"
          "block.rkt"
-         quad/quad
+         quad/base
-         quad/wrap
+         quad/wrap)
-         quad/position)
 (provide (all-defined-out))
 
-
-
 (define q:column (make-quad
                   #:type column-quad
                   #:id 'col
@@ -47,7 +43,31 @@
 constraint wrapping example
 https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d9656046b/pdf/directory-require.rkt#L51
 |#
-;; 
+;;
+
+
+(define (footnote-start? fnq) (quad-ref fnq :fn-text-start))
+
+(define (handle-leftover-footnote ymax leftover-qs fn-qs)
+  (let loop ([ymax ymax][leftover-qs leftover-qs][fn-qs fn-qs])
+    (define ydist (and (pair? fn-qs) (pt-y (size (car fn-qs)))))
+    ;; take all fn lines that are not footnote-start?
+    ;; and that fit within ymax remaining
+    (if (and ydist (not (footnote-start? (car fn-qs))) (<= ydist ymax))
+        (loop (- ymax ydist) (cons (car fn-qs) leftover-qs) (cdr fn-qs))
+        (values ymax leftover-qs fn-qs))))
+
+(define (handle-new-footnote ymax leftover-qs fn-qs fn-ref-q)
+  (define ydist-fn (and (pair? fn-qs)
+                        (footnote-start? (car fn-qs))
+                        (pt-y (size (car fn-qs)))))
+  (define ydist-ref (pt-y (size fn-ref-q)))
+  ;; only accept the footnote if both the first line of footnote
+  ;; and the line containing the ref will fit.
+  (if (and ydist-fn (<= (+ ydist-fn ydist-ref) ymax))
+      (values (- ymax ydist-fn) (cons (car fn-qs) leftover-qs) (cdr fn-qs))
+      (raise 'boom)))
+
 (define (column-wrap lines fn-lines vertical-height column-gap [col-quad-proto q:column])
   (unless (positive? vertical-height)
     (raise-argument-error 'column-wrap "positive number" vertical-height))
@@ -57,7 +77,6 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96
   ;; could do it after, but it would require going back inside each col quad
   ;; which seems overly interdependent, because `insert-blocks` is used to determine break locations.
   ;; `col-wrap` should emit quads that are complete.
-  (define (footnote-start? fnq) (quad-ref fnq :fn-text-start))
   (define cols (wrap lines vertical-height
                      #:soft-break #true
                      #:hard-break column-break-quad?
@@ -67,24 +86,8 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96
                                   (sum-y (insert-blocks (reverse wrap-qs))))                     
                      #:finish-wrap (column-wrap-finish col-quad-proto)
                      #:footnote-qs fn-lines
-                     #:footnote-leftover-proc (λ (ymax leftover-qs fn-qs)
+                     #:footnote-leftover-proc handle-leftover-footnote
-                                                (let loop ([ymax ymax][leftover-qs leftover-qs][fn-qs fn-qs])
+                     #:footnote-new-proc handle-new-footnote))
-                                                  (define ydist (and (pair? fn-qs) (pt-y (size (car fn-qs)))))
-                                                  ;; take all fn lines that are not footnote-start?
-                                                  ;; and that fit within ymax remaining
-                                                  (if (and ydist (not (footnote-start? (car fn-qs))) (<= ydist ymax))
-                                                      (loop (- ymax ydist) (cons (car fn-qs) leftover-qs) (cdr fn-qs))
-                                                      (values ymax leftover-qs fn-qs))))
-                     #:footnote-new-proc (λ (ymax leftover-qs fn-qs fn-ref-q)
-                                           (define ydist-fn (and (pair? fn-qs)
-                                                                 (footnote-start? (car fn-qs))
-                                                                 (pt-y (size (car fn-qs)))))
-                                           (define ydist-ref (pt-y (size fn-ref-q)))
-                                           ;; only accept the footnote if both the first line of footnote
-                                           ;; and the line containing the ref will fit.
-                                           (if (and ydist-fn (<= (+ ydist-fn ydist-ref) ymax))
-                                               (values (- ymax ydist-fn) (cons (car fn-qs) leftover-qs) (cdr fn-qs))
-                                               (raise 'boom)))))
   (define reversed-fn-lines
     (from-parent (for/list ([fn-line (in-list (reverse fn-lines))])
                            ;; position bottom to top, in reverse

quad/quadwriter/debug.rkt

@@ -1,10 +1,46 @@
 #lang debug racket
-(require "param.rkt"
+(require pitfall
-         pitfall
          quad/position
          quad/quad)
 (provide (all-defined-out))
 
+(define-for-syntax debug-mode #false)
+
+(define-syntax (go stx)
+  (datum->syntax stx
+                 (cond
+                   [debug-mode
+                    '(begin
+                       (define draw-debug? (make-parameter #true))
+                       (define draw-debug-line? (make-parameter #true))
+                       (define draw-debug-block? (make-parameter #false))
+                       (define draw-debug-string? (make-parameter #true))
+                       (define draw-debug-image? (make-parameter #false))
+
+                       (define debug-page-width (make-parameter 400))
+                       (define debug-page-height (make-parameter 400))
+                       (define debug-x-margin (make-parameter 50))
+                       (define debug-y-margin (make-parameter 50))
+                       (define debug-column-count (make-parameter 1))
+                       (define debug-column-gap (make-parameter 36)))]
+                   [else
+                    '(begin
+                       (define draw-debug? (make-parameter #false))
+                       (define draw-debug-line? (make-parameter #true))
+                       (define draw-debug-block? (make-parameter #true))
+                       (define draw-debug-string? (make-parameter #true))
+                       (define draw-debug-image? (make-parameter #true))
+
+                       (define debug-page-width (make-parameter #f))
+                       (define debug-page-height (make-parameter #f))
+                       (define debug-x-margin (make-parameter #f))
+                       (define debug-y-margin (make-parameter #f))
+                       (define debug-column-count (make-parameter #f))
+                       (define debug-column-gap (make-parameter #f)))])))
+
+
+(go)
+
 
 (define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"] . _)
   (define stroke-width 0.5)
@@ -22,4 +58,4 @@
     (restore doc)
     (apply rect doc (append (pt+ (quad-origin q)) (map (λ (x) (- x stroke-width)) (size q))))
     (stroke doc stroke-color)
-    (restore doc)))
+    (restore doc)))

quad/quadwriter/line.rkt

@@ -6,8 +6,7 @@
          "font.rkt"
          "string.rkt"
          "attrs.rkt"
-         quad/position
+         quad/base
-         quad/quad
          quad/wrap
          sugar/list
          pitfall
@@ -57,7 +56,6 @@
 
 (define (space-quad? q) (equal? (quad-elems q) (list " ")))
 
-
 (define (hang-punctuation nonspacess)
   (match nonspacess
     [(list sublists ... (list prev-qs ... last-q))
@@ -160,16 +158,6 @@
                ;; ok to put back absolute quads at end, because it doesn't affect their layout
                (append other-qs absolute-qs))])]))
 
-(define/match (from-parent qs [where #f])
-  ;; doesn't change any positioning. doesn't depend on state. can happen anytime.
-  ;; can be repeated without damage.
-  [((? null?) _) null]
-  [((cons q rest) where)
-   (quad-update! q [from-parent (or where (quad-from q))])
-   (cons q rest)])
-
-
-(define only-prints-in-middle (λ (q sig) (not (memq sig '(start end)))))
 (define (make-paragraph-spacer maybe-first-line-q key default-val)
   (define arbitrary-width 20)
   (make-quad #:type line-spacer-quad

quad/quadwriter/param.rkt

@@ -1,58 +1,12 @@
 #lang debug racket
-(define-for-syntax debug-mode #false)
+(provide (all-defined-out))
-
+(define current-doc (make-parameter #false))
-(define-syntax (go stx)
+(define current-pdf (make-parameter #false))
-  (syntax-case stx ()
+(define current-line-wrap (make-parameter #f)) ; because kp is slow and maybe we want to disable for "draft" mode
-    [_
+(define section-pages-used (make-parameter 0))
-     debug-mode
+(define current-named-quads (make-parameter #false))
-     #'(begin
-         (provide (all-defined-out))
-         (define current-doc (make-parameter #false))
-         (define current-pdf (make-parameter #false))
-         (define current-line-wrap (make-parameter #f)) ; because kp is slow and maybe we want to disable for "draft" mode
-         (define section-pages-used (make-parameter 0))
-         (define current-named-quads (make-parameter #false))
-         
-         (define quadwriter-test-mode (make-parameter #f)) ; used during rackunit to suppress nondeterministic elements, like timestamp in header
-
-         (define draw-debug? (make-parameter #true))
-         (define draw-debug-line? (make-parameter #true))
-         (define draw-debug-block? (make-parameter #false))
-         (define draw-debug-string? (make-parameter #true))
-         (define draw-debug-image? (make-parameter #false))
-
-         (define debug-page-width (make-parameter 400))
-         (define debug-page-height (make-parameter 400))
-         (define debug-x-margin (make-parameter 50))
-         (define debug-y-margin (make-parameter 50))
-         (define debug-column-count (make-parameter 1))
-         (define debug-column-gap (make-parameter 36))
-         (define zoom-factor (make-parameter 1))
-         (define log-clipping? (make-parameter 'warn)))]
-    [_
-     #'(begin
-         (provide (all-defined-out))
-         (define current-doc (make-parameter #false))
-         (define current-pdf (make-parameter #false))
-         (define current-line-wrap (make-parameter #f))
-         (define section-pages-used (make-parameter 0))
-         (define current-named-quads (make-parameter #false))
          
-         (define quadwriter-test-mode (make-parameter #f))
+(define quadwriter-test-mode (make-parameter #f)) ; used during rackunit to suppress nondeterministic elements, like timestamp in header
-
-         (define draw-debug? (make-parameter #false))
-         (define draw-debug-line? (make-parameter #true))
-         (define draw-debug-block? (make-parameter #true))
-         (define draw-debug-string? (make-parameter #true))
-         (define draw-debug-image? (make-parameter #true))
-
-         (define debug-page-width (make-parameter #f))
-         (define debug-page-height (make-parameter #f))
-         (define debug-x-margin (make-parameter #f))
-         (define debug-y-margin (make-parameter #f))
-         (define debug-column-count (make-parameter #f))
-         (define debug-column-gap (make-parameter #f))
-         (define zoom-factor (make-parameter 1))
-         (define log-clipping? (make-parameter 'warn)))]))
 
-(go)
+(define zoom-factor (make-parameter 1))
+(define log-clipping? (make-parameter 'warn))

quad/quadwriter/render.rkt

@@ -27,7 +27,8 @@
          "section.rkt"
          "doc.rkt"
          "column.rkt"
-         "keep.rkt")
+         "keep.rkt"
+         "debug.rkt")
 (provide (all-defined-out))