page & page-sizes

quad2/attr.rkt

@@ -20,12 +20,13 @@
   ;; recursively descend from top to bottom.
   ;; but also track which attrs are visited and skip any already visited.
   (define attrs-seen (mutable-seteq))
+  (define wants-parent-attrs? (= (procedure-arity proc) 2))
   (let loop ([xs xs][parent-attrs #false])
     (for ([x (in-list xs)]
           #:when (quad? x))
          (define attrs (quad-attrs x))
          (unless (set-member? attrs-seen attrs)
-           (proc attrs parent-attrs)
+           (if wants-parent-attrs? (proc attrs parent-attrs) (proc attrs))
            (set-add! attrs-seen attrs))
          (loop (quad-elems x) attrs))))
 

quad2/constants.rkt

@@ -7,6 +7,8 @@
 (define default-font-family "text")
 (define default-font-size 12)
 (define default-no-features (seteq))
+(define default-page-size "letter")
+(define default-page-orientation "tall")
 
 (struct no-value ())
 (define no-value-signal (no-value))
@@ -32,4 +34,10 @@
   [:font-size (make-attr-dimension-string-key 'font-size #true default-font-size)]
   [:font-features (make-attr-set-key 'font-features #true default-no-features)]
   [:font-features-add (make-attr-set-key 'font-features-add #false default-no-features)]
-  [:font-features-subtract (make-attr-set-key 'font-features-subtract #false default-no-features)])
+  [:font-features-subtract (make-attr-set-key 'font-features-subtract #false default-no-features)]
+
+  [:page-size (make-attr-uncased-string-key 'page-size #true default-page-size)]
+  [:page-orientation (make-attr-uncased-string-key 'page-orientation #true default-page-orientation)]
+  [:page-width (make-attr-dimension-string-key 'page-width)]
+  [:page-height (make-attr-dimension-string-key 'page-height)]
+  )

quad2/draw.rkt

@@ -19,7 +19,7 @@
            (for/list ([q (in-list qs)])
                      (append
                       (match (quad-ref q :font-path)
-                        [(== current-font) (list)]
+                        [(== current-font) null]
                         [font-path
                          (set! current-font font-path)
                          (list ($font font-path))])
@@ -27,7 +27,7 @@
                         [(quad? q)
                          (if (pair? (quad-elems q))
                              (list ($move (quad-posn q)) ($text (char->integer (car (string->list (car (quad-elems q)))))))
-                             (list))]
+                             null)]
                         [else (error 'render-unknown-thing)]))))
          ($page 'end) ($doc 'end))))
 

quad2/layout.rkt

@@ -25,26 +25,40 @@
 
 (define/contract (rect-contains-point? rect pt)
   ($rect? $point? . -> . boolean?)
-  (and (<= (min-x rect) ($point-x pt) (max-x rect))
-       (<= (min-y rect) ($point-y pt) (max-y rect))))
+  ;; https://developer.apple.com/documentation/foundation/1391317-nspointinrect/
+  ;; "Point-in-rectangle functions generally assume that the “upper” and “left” edges of a rectangle are inside the rectangle boundaries, while the “lower” and “right” edges are outside the boundaries. This method treats the “upper” and “left” edges of the rectangle as the ones containing the origin of the rectangle."
+  (and
+   ;; IOW the point (min-x, min-y) is inside rect,
+   (<= (min-x rect) ($point-x pt))
+   (<= (min-y rect) ($point-y pt))
+   ;; and the point (max-x, max-y) is not
+   (< ($point-x pt) (max-x rect))
+   (< ($point-y pt) (max-y rect))))
 
-(define/contract (rect-contains-rect? outer inner)
+(define/contract (rect-contains-rect? outer-aRect inner-bRect)
   ($rect? $rect? . -> . boolean?)
-  (and (rect-contains-point? outer ($rect-origin inner))
-       (rect-contains-point? outer ($point (max-x inner) (max-y inner)))))
+  ;; https://developer.apple.com/documentation/foundation/1391177-nscontainsrect
+  ;; "true if aRect completely encloses bRect. For this condition to be true, bRect cannot be empty, and must not extend beyond aRect in any direction."
+  ;; thus a rect always contains itself.
+  ;; TODO: why can't bRect be empty?
+  (and (<= (min-x outer-aRect) (min-x inner-bRect)) (<= (max-x inner-bRect) (max-x outer-aRect))
+       (<= (min-y outer-aRect) (min-y inner-bRect)) (<= (max-y inner-bRect) (max-y outer-aRect))))
 
 (define-pass (layout qs)
   #:pre (list-of has-no-position?)
   #:post (list-of has-position?)
   (define frame ($rect ($point 0 0) ($size (current-wrap-width) 30)))
   (define (quad-fits? q posn)
-    (define q-size (size q))
-    (define quad-rect ($rect posn q-size))
-    (and (rect-contains-rect? frame quad-rect) posn))
-  (for/fold ([posn ($point 0 0)]
+    (rect-contains-rect? frame ($rect posn (size q))))
+  (for/fold ([posn0 ($point 0 0)]
              #:result qs)
             ([q (in-list qs)])
-    (define first-posn-on-next-line ($point 0 (add1 ($point-y posn))))
-    (define winning-posn (or (ormap (λ (posn) (quad-fits? q posn)) (list posn first-posn-on-next-line)) (error 'no-posn-that-fits)))
-    (set-quad-posn! q winning-posn)
-    (posn-add winning-posn (advance q))))
+    (define first-posn-on-next-line ($point 0 (add1 ($point-y posn0))))
+    (define other-possible-posns (list first-posn-on-next-line))
+    (define posn1 (for/first ([posn (in-list (cons posn0 other-possible-posns))]
+                              #:when (quad-fits? q posn))
+                             posn))
+    (unless posn1
+      (error 'no-posn-that-fits))
+    (set-quad-posn! q posn1)
+    (posn-add posn1 (advance q))))

quad2/main.rkt

@@ -9,6 +9,7 @@
          "font.rkt"
          "constants.rkt"
          "param.rkt"
+         "page.rkt"
          racket/list
          racket/match
          racket/file)
@@ -36,6 +37,7 @@
                   parse-dimension-strings
                   resolve-font-sizes
                   resolve-font-features
+                  parse-page-sizes
 
                   ;; linearization =============
                   ;; we postpone this step until we're certain any
@@ -63,7 +65,9 @@
 (module+ main
   (require "render.rkt")
   (define (test-compile x)
-    (parameterize ([current-wrap-width 13]
+    (define characters-in-line 13)
+    (define monospaced-em-width 0.6)
+    (parameterize ([current-wrap-width (* characters-in-line monospaced-em-width default-font-size)]
                    [current-attr-keys all-attr-keys]
                    [current-strict-attrs? #t]
                    [current-show-timing? #f]
@@ -71,8 +75,9 @@
                    [current-use-postconditions? #t])
       (quad-compile (bootstrap-input x))))
 
-  (match (test-compile "Hello this is the earth")
+  (match (test-compile "X")
     [(? string? insts)
+     (displayln insts)
      (render insts #:using text-renderer)
      (render insts #:using drr-renderer)
      (render insts #:using (html-renderer (build-path (find-system-path 'desk-dir) "test.html")))

quad2/page-sizes.rkt

@@ -0,0 +1,72 @@
+#lang debug at-exp racket/base
+(require racket/string
+         racket/match)
+(provide page-sizes-ref)
+
+(define page-size-strs
+  @list{
+ 4A0 4767.87 6740.79
+ 2A0 3370.39 4767.87
+ A0 2383.94 3370.39
+ A1 1683.78 2383.94
+ A2 1190.55 1683.78
+ A3 841.89 1190.55
+ A4 595.28 841.89
+ A5 419.53 595.28
+ A6 297.64 419.53
+ A7 209.76 297.64
+ A8 147.40 209.76
+ A9 104.88 147.40
+ A10 73.70 104.88
+ B0 2834.65 4008.19
+ B1 2004.09 2834.65
+ B2 1417.32 2004.09
+ B3 1000.63 1417.32
+ B4 708.66 1000.63
+ B5 498.90 708.66
+ B6 354.33 498.90
+ B7 249.45 354.33
+ B8 175.75 249.45
+ B9 124.72 175.75
+ B10 87.87 124.72
+ C0 2599.37 3676.54
+ C1 1836.85 2599.37
+ C2 1298.27 1836.85
+ C3 918.43 1298.27
+ C4 649.13 918.43
+ C5 459.21 649.13
+ C6 323.15 459.21
+ C7 229.61 323.15
+ C8 161.57 229.61
+ C9 113.39 161.57
+ C10 79.37 113.39
+ RA0 2437.80 3458.27
+ RA1 1729.13 2437.80
+ RA2 1218.90 1729.13
+ RA3 864.57 1218.90
+ RA4 609.45 864.57
+ SRA0 2551.18 3628.35
+ SRA1 1814.17 2551.18
+ SRA2 1275.59 1814.17
+ SRA3 907.09 1275.59
+ SRA4 637.80 907.09
+ EXECUTIVE 521.86 756.00
+ FOLIO 612.00 936.00
+ LEGAL 612.00 1008.00
+ LETTER 612.00 792.00
+ TABLOID 792.00 1224.00
+ })
+
+(define page-sizes
+  (make-hasheq
+   (for*/list ([line (in-list page-size-strs)]
+               [toks (in-value (for/list ([tok (in-port read (open-input-string line))])
+                                         tok))]
+               #:unless (null? toks))
+              toks)))
+
+(define (page-sizes-ref name [other-name #false])
+  (define name-key (string->symbol (string-upcase name)))
+  (if other-name
+      (hash-ref page-sizes name-key (λ () (page-sizes-ref other-name)))
+      (hash-ref page-sizes name-key)))

quad2/page.rkt

@@ -0,0 +1,63 @@
+#lang debug racket/base
+(require "quad.rkt"
+         "attr.rkt"
+         "pipeline.rkt"
+         "constants.rkt"
+         "param.rkt"
+         "page-sizes.rkt"
+         racket/match)
+(provide (all-defined-out))
+
+(define (quad-with-page-size? x)
+  (and (quad? x)
+       (number? (quad-ref x :page-width #false))
+       (number? (quad-ref x :page-height #false))
+       ;; at this point :page-size and :page-orientation
+       ;; have been parsed into width & height
+       (not (quad-has-key? x :page-size))
+       (not (quad-has-key? x :page-orientation))))
+
+(define (parse-page-size attrs)
+  ;; if set, debug-page-width and debug-page-height override the requested width & height
+  (define width (or (debug-page-width) (hash-ref attrs :page-width #false)))
+  (define height (or (debug-page-height) (hash-ref attrs :page-height #false)))
+  (define size (hash-ref attrs :page-size default-page-size))
+  (define orientation (hash-ref attrs :page-orientation default-page-orientation))
+
+  ;; parsed-width and parsed-height are derived from named size & orientation
+  (match-define (list parsed-width parsed-height)
+    (sort
+     (page-sizes-ref size default-page-size)
+     ;; for portrait, shorter edge is width
+     (if (member orientation '("portrait" "tall")) < >)))
+  
+  (hash-set! attrs :page-width (or width parsed-width))
+  (hash-set! attrs :page-height (or height parsed-height))
+  (hash-remove! attrs :page-size)
+  (hash-remove! attrs :page-orientation)
+  attrs)
+
+
+(module+ test
+  (require rackunit racket/sequence)
+  (define (attrs . args)
+    (make-hash (for/list ([duo (in-slice 2 args)])
+                         (apply cons duo))))
+  (define (width-height attrs)
+    (cons (hash-ref attrs :page-width) (hash-ref attrs :page-height)))
+  ;; TODO: test other weird combinations of attr keys
+  (check-equal? (width-height (parse-page-size (attrs :page-width 240))) (cons 240 792.0))
+  (check-equal? (width-height (parse-page-size (attrs :page-height 240))) (cons 612.0 240))
+  (check-equal? (width-height (parse-page-size (attrs :page-size "legal"))) (cons 612.0 1008.0))
+  (check-equal? (width-height (parse-page-size (attrs :page-orientation "wide"))) (cons 792.0 612.0)))
+  
+
+(define-pass (parse-page-sizes qs)
+  ;; put the default values for mandatory keys at the top level
+  ;; so that when we linearize, they will percolate downward
+  #:pre (list-of quad?)
+  #:post (list-of quad-with-page-size?)  
+  (for-each-attrs qs (λ (q)
+                       (unless (quad-with-page-size? q)
+                         (parse-page-size q)))))
+                         

quad2/param.rkt

@@ -19,3 +19,10 @@
   [current-strict-attrs? boolean? #false]
   [current-use-preconditions? boolean? #true]
   [current-use-postconditions? boolean? #true])
+
+
+(define (number-or-false? x) (or (eq? #false x) (number? x)))
+
+(define-guarded-parameters
+  [debug-page-width number-or-false? #false]
+  [debug-page-height number-or-false? #false])