put in basic pdf renderer

quad/quad/atomize.rkt

@@ -3,11 +3,10 @@
 (provide (all-defined-out))
 
 (define (atomize x)
-  (define empty-attrs (make-attrs))
   (apply
    vector-immutable
    (flatten
-    (cons
+    (list
      (let loop ([x x][loop-attrs default-attrs])
        (cond
          [($shim? x) x]
@@ -15,21 +14,34 @@
           ;; consolidate consecutive whitespaces into single word space
           ;; todo: hyphenate here? then they are in the quad stream
           (for/list ([c (in-string x)]) 
-                    (cons ($shim empty-attrs #f #f)
-                          ;; todo: is it feasible to box or otherwise object-ize a char
-                          ;; so that all the quads with that char share that object
-                          ;; and thus the measurement can be shared too?
-                          ;; (object would have to be packaged with other typographic specs)
-                          ((casev c
-                                  [(#\space) $space]
-                                  [(#\-) $hyphen]
-                                  [(#\u00AD) $shy]
-                                  [else $black]) loop-attrs #f c)))]
+                    (cons
+                     ;; installing loop attrs allows us to recognize contiguous runs later
+                     ($shim loop-attrs #f #f) 
+                     ;; todo: is it feasible to box or otherwise object-ize a char
+                     ;; so that all the quads with that char share that object
+                     ;; and thus the measurement can be shared too?
+                     ;; (object would have to be packaged with other typographic specs)
+                     ((casev c
+                             [(#\space) $space]
+                             [(#\-) $hyphen]
+                             [(#\u00AD) $shy]
+                             [else $black]) loop-attrs #f c)))]
          [else
           (map (λ(xi) (loop xi ((quad-attrs x) . override-with . loop-attrs))) (quad-val x))]))
-     ($eof empty-attrs #f #f))))) ; add eof so any in-vector loop consumes all the input vals
+     ($eof (make-empty-attrs) #f #f))))) ; add eof so any in-vector loop consumes all the input vals
+
+(define (merge-runs xs)
+  ; combine quads with same attrs into sublists
+  (cond
+    [(empty? xs) empty]
+    [else
+     (define target (car xs))
+     (define-values (matches rest)
+       (splitf-at (cdr xs) (λ(x) (eq? (quad-attrs target) (quad-attrs x)))))
+     (list* (cons target matches) (merge-runs rest))]))
 
 (module+ test
   (require rackunit)
-  (atomize (quad (make-attrs #:size 10 #:font "Eq") "ba" (line-break) "r" (quad (make-attrs #:size 8) "zam") "q\tux"))
-  (atomize (quad #f "snowman")))
+  #;(atomize (quad (make-attrs #:size 10 #:font "Eq") "ba" (line-break) "r" (quad (make-attrs #:size 8) "zam") "q\tux"))
+  (define qs (atomize (quad #f "A" (page-break) "B")))
+  qs)

quad/quad/main.rkt

@@ -1,11 +1,11 @@
 #lang quad/dev
-(require "quads.rkt" "typeset.rkt" "atomize.rkt" "render.rkt" racket/list racket/string)
+(require "quads.rkt" "typeset.rkt" "atomize.rkt" "render.rkt" "render-pdf.rkt" racket/list racket/string)
 (provide (except-out (all-from-out quad/dev "quads.rkt") #%module-begin)
          (rename-out [~module-begin #%module-begin]))
 
 (define-syntax-rule (~module-begin lang-line-config-arg . args)
   (#%module-begin
-   (define main-quad (apply quad #f (add-between (list . args) "\n"))) ; at-reader splits lines, but we want one contiguous run
+   (define main-quad (apply quad #f (list . args))) ; at-reader splits lines, but we want one contiguous run
    ;; branch on config-arg to allow debug / inspection options on #lang line
    (define config-pieces (string-split (string-trim lang-line-config-arg)))
    (and (pair? config-pieces)
@@ -14,6 +14,7 @@
             [("in") (atomize main-quad)]
             [("out") (time (apply fit (atomize main-quad) config-args))]
             [("test") (time (debug-render (apply fit (atomize main-quad) config-args)))]
+            [("pdf") (time (render-pdf (apply fit (atomize main-quad) config-args)))]
             [else (fit (atomize main-quad))])))))
 
 (module reader syntax/module-reader

quad/quad/quadlang-test.rkt

@@ -1,2 +1,2 @@
 #lang quad/text test 300
-Produces a list of three-element lists, where each three-element list represents a set of consecutive code points for which the Unicode standard specifies character properties. Each three-element list contains two integers and a boolean; the first integer is a starting code-point value (inclusive), the second integer is an ending code-point value (inclusive), and the boolean is #t when all characters in the code-point range have identical results for all of the character predicates above. The three-element lists are ordered in the overall result list such that later lists represent larger code-point values, and all three-element lists are separated from every other by at least one code-point value that is not specified by Unicode.
+Artful@(page-break)Belligerence

quad/quad/quads.rkt

@@ -58,6 +58,9 @@ measure (line width)
                     #:font [font #f])
   (hasheq 'size size 'font font))
 
+(define (make-empty-attrs) (make-attrs))
+
+
 
 (define (quad attr . xs)
   ;; squeeze excess whitespace out of quad args

quad/quad/render-pdf.rkt

@@ -0,0 +1,92 @@
+#lang quad/dev
+(require racket/class racket/contract sugar/debug sugar/cache racket/list racket/file racket/draw data/gvector)
+(provide (all-defined-out))
+
+(define (world:paper-width-default) 612)
+(define (world:paper-height-default) 792)
+
+(define renderable-quads '(word box))
+
+(define (render-pdf [qs #f] [path-string "test.pdf"])
+  (send* (current-ps-setup) (set-margin 0 0) (set-scaling 1.0 1.0))
+  (define dc-output-port (open-output-bytes))
+  (define dc (new pdf-dc% [interactive #f][use-paper-bbox #f][as-eps #f]
+                  [output dc-output-port]
+                  [width (world:paper-width-default)][height (world:paper-height-default)]))
+  (send dc start-doc "boing")
+  (send dc set-pen "black" 1 'solid)
+  (send dc set-brush "black" 'transparent) ; no fill by default
+  
+  
+  #;(for ([q (in-vector qs)] #:when (member (quad-name q) renderable-quads))
+         (define p (quad-attr-ref q world:page-key))
+         (gvector-set! page-quad-vector p (cons q (gvector-ref page-quad-vector p null))))
+  
+  #;(for/list ([pq (in-gvector page-quad-vector)])
+              (send dc start-page)
+              (map/send render-element (filter-not whitespace/nbsp? elements))
+              (send dc end-page))
+  
+  (define (print-status)
+    (send dc draw-text (format "foobar ~a" (current-milliseconds)) 0 0))
+  
+  (define f (make-font #:face "Source Code Pro" #:size 10))
+  (send dc set-font f)
+  
+  (send dc start-page)
+  (print-status) 
+  
+  (when qs
+    (for/fold ([page-pos 0]
+               [x-pos 40]
+               [y-pos 40])
+              ([q (in-vector qs)])
+      (cond
+        [(eq? (quad-dim q) 'page-break)
+         (send dc end-page)
+         (send dc start-page)
+         (print-status)
+         (values page-pos 40 40)]
+        [(quad-printable? q)
+         (send dc draw-text (format "~a" (quad-val q)) x-pos y-pos)
+         (values page-pos (+ x-pos (quad-dim q)) y-pos)]
+        [else (values page-pos x-pos y-pos)])))
+  
+  (send dc end-page)
+  (send dc end-doc)
+  
+  (define result-bytes (get-output-bytes dc-output-port))
+  (display-to-file result-bytes path-string #:exists 'replace #:mode 'binary))
+
+
+#;(define (render-element q)
+    (cond 
+      [(word? q) (render-word q)]
+      [else q]))
+
+
+(define/caching (make-font/caching font size style weight)
+  (make-font #:face font #:size size #:style style #:weight weight))
+
+#;(define (render-word w)
+    (define word-font (quad-attr-ref/parameter w world:font-name-key))
+    (define word-size (quad-attr-ref/parameter w world:font-size-key))
+    (define word-style (quad-attr-ref/parameter w world:font-style-key))
+    (define word-weight (quad-attr-ref/parameter w world:font-weight-key))
+    (define word-color (quad-attr-ref/parameter w world:font-color-key))
+    (define word-background (quad-attr-ref/parameter w world:font-background-key))
+    (send dc set-font (make-font/caching word-font word-size word-style word-weight))
+    (send dc set-text-foreground (send the-color-database find-color word-color))
+    (define background-color (send the-color-database find-color word-background))
+    (if background-color ; all invalid color-string values will return #f
+        (send* dc (set-text-mode 'solid) (set-text-background background-color))
+        (send dc set-text-mode 'transparent))
+    
+    (define word-text (quad-car w))
+    (send dc draw-text word-text (quad-attr-ref w world:x-position-key) 
+          ;; we want to align by baseline rather than top of box
+          ;; thus, subtract ascent from y to put baseline at the y coordinate
+          (- (quad-attr-ref w world:y-position-key) (quad-attr-ref w world:ascent-key 0)) #t))
+
+(module+ test
+  (render-pdf))

quad/quad/typeset.rkt

@@ -33,7 +33,7 @@
            [(page-break) page-start-position]
            [else current-posn]))
   
-  (for/fold ([current-posn (handle-break 'page-break)]) ; moves to page start position
+  (for/fold ([current-posn page-start-position]) 
             ([q (in-vector qs)])
     (unless (quad-dim q) (measure! q))
     (cond