step5

pitfall/pitfall/annotations.rkt

@@ -3,54 +3,49 @@
   "core.rkt"
   "reference.rkt"
   "page.rkt"
+  "color.rkt"
   racket/class
   racket/match
   sugar/unstable/dict)
 
-(provide annotation-mixin)
-
-(define (annotation-mixin [% object%])
-  (class %
-    (super-new)
-    (inherit-field @ctm)
-    (inherit page)
-
-    (define/public (annotate x y w h options)
-      (hash-set*! options
-                  'Type 'Annot
-                  'Rect (convert-rect x y w h)
-                  'Border '(0 0 0))
-      (unless (eq? (hash-ref options 'Subtype #f) 'Link)
-        (hash-ref! options 'C
-                   (λ ()
-                     (send this normalize-color (or (hash-ref options 'color #f) '(0 0 0))))))
-      (hash-remove! options 'color)
-
-      (for ([(k v) (in-hash options)])
-        (hash-set! options (string->symbol (string-titlecase (symbol->string k))) v))
-
-      (define annots-ref (make-ref options))
-      (page-annotations (page) annots-ref)
-      (ref-end annots-ref)
-      this)
-
-    (define/public (link x y w h url [options (mhasheq)])
-      (hash-set*! options
-                  'Subtype 'Link
-                  'A (make-ref (mhash 'S 'URI
-                                      'URI url)))
-      (ref-end (hash-ref options 'A))
-      (annotate x y w h options))
-
-    (define/public (convert-rect x1 y1 w h)
-      ;; flip y1 and y2
-      (let ([y2 y1]
-            [y1 (+ y1 h)]
-            [x2 (+ x1 w)])
-        (match-define (list m0 m1 m2 m3 m4 m5) @ctm)
-        (let* ([x1 (+ (* x1 m0) (* y1 m2) m4)]
-               [y1 (+ (* x1 m1) (* y1 m3) m5)]
-               [x2 (+ (* x2 m0) (* y2 m2) m4)]
-               [y2 (+ (* x2 m1) (* y2 m3) m5)])
-          (list x1 y1 x2 y2))))))
+(provide (all-defined-out))
+
+(define (annotate doc x y w h options)
+  (hash-set*! options
+              'Type 'Annot
+              'Rect (convert-rect doc x y w h)
+              'Border '(0 0 0))
+  (unless (eq? (hash-ref options 'Subtype #f) 'Link)
+    (hash-ref! options 'C
+               (λ ()
+                 (normalize-color (or (hash-ref options 'color #f) '(0 0 0))))))
+  (hash-remove! options 'color)
+
+  (for ([(k v) (in-hash options)])
+    (hash-set! options (string->symbol (string-titlecase (symbol->string k))) v))
+
+  (define annots-ref (make-ref options))
+  (page-annotations (page doc) annots-ref)
+  (ref-end annots-ref)
+  doc)
+
+(define (convert-rect doc x1 y1 w h)
+        ;; flip y1 and y2
+        (let ([y2 y1]
+              [y1 (+ y1 h)]
+              [x2 (+ x1 w)])
+          (match-define (list m0 m1 m2 m3 m4 m5) ($doc-ctm doc))
+          (let* ([x1 (+ (* x1 m0) (* y1 m2) m4)]
+                 [y1 (+ (* x1 m1) (* y1 m3) m5)]
+                 [x2 (+ (* x2 m0) (* y2 m2) m4)]
+                 [y2 (+ (* x2 m1) (* y2 m3) m5)])
+            (list x1 y1 x2 y2))))
+
+(define (link doc x y w h url [options (mhasheq)])
+  (hash-set*! options
+              'Subtype 'Link
+              'A (make-ref (mhash 'S 'URI
+                                  'URI url)))
+  (ref-end (hash-ref options 'A))
+  (annotate doc x y w h options))
 

pitfall/pitfall/check-pdf.rkt

@@ -118,14 +118,6 @@
        (cons idx (parse-pdf-bytes (peek-bytes (- end start) start)))))
    < #:key car))
 
-(define (shorten-val v)
-  (cond
-    [(dict? v) (for/list ([(key val) (in-dict v)])
-                 (cons key (shorten-val val)))]
-    [(and (bytes? v) (> (bytes-length v) 100))
-     (subbytes v 0 100)]
-    [else v]))
-
 (define (dict-compare arg1 arg2)
   (define d1 (if (dict? arg1) arg1 (pdf->dict arg1)))
   (define d2 (if (dict? arg2) arg2 (pdf->dict arg2)))
@@ -136,9 +128,7 @@
          (unless (equal? k1 k2)
            (error (format "keys unequal in ~a and ~a: ~a ≠ ~a" arg1 arg2 k1 k2)))
          (unless (equal? v1 v2)
-           (define val1 (shorten-val v1))
-           (define val2 (shorten-val v2))
-           (error (format "values unequal in ~a and ~a: ~a ≠ ~a" arg1 arg2 val1 val2)))
+           (error (format "values unequal in ~a and ~a: ~e ≠ ~e" arg1 arg2 v1 v2)))
          (when (dict? v1)
            (dict-compare v1 v2))
          #true)))

pitfall/pitfall/color.rkt

@@ -6,8 +6,77 @@
   racket/class
   racket/match
   racket/string)
+(provide (all-defined-out))
 
-(provide color-mixin)
+(define (do-opacity doc [fill-arg #f] [stroke-arg #f])
+  (define fill-opacity (and fill-arg (bounded 0 fill-arg 1)))
+  (define stroke-opacity (and stroke-arg (bounded 0 stroke-arg 1)))
+  (when (or fill-opacity stroke-opacity)
+    (define key (format "~a_~a"
+                        (if fill-opacity (numberizer fill-opacity) "")
+                        (if stroke-opacity (numberizer stroke-opacity) "")))
+    (match-define (list dictionary name)
+      (hash-ref! ($doc-opacity-registry doc) key
+                 (λ ()
+                   (define dictionary (make-hasheq '((Type . ExtGState))))
+                   (when fill-opacity
+                     (hash-set! dictionary 'ca fill-opacity))
+                   (when stroke-opacity
+                     (hash-set! dictionary 'CA stroke-opacity))
+                   (define ref-dict (make-ref dictionary))
+                   (ref-end ref-dict)
+                   (set-$doc-opacity-count! doc (add1 ($doc-opacity-count doc)))
+                   (list ref-dict (string->symbol (format "Gs~a" ($doc-opacity-count doc)))))))
+    (hash-set! (page-ext_gstates (page doc)) name dictionary)        
+    (add-content doc (format "/~a gs" name))))
+
+(define (fill-color doc color [opacity 1])
+  (unless (normalize-color color)
+    (raise-argument-error 'fill-color "valid color string" color))
+  (when (set-color doc color #f) (fill-opacity doc opacity))
+  ;; save this for text wrapper, which needs to reset
+  ;; the fill color on new pages
+  (set-$doc-current-fill-color! doc (list color opacity))
+  doc)
+
+(define (fill-opacity doc opacity)
+  (do-opacity doc opacity #f)
+  doc)
+
+(define (set-color doc color-in stroke)
+  (define color (normalize-color color-in))
+  (define op (if stroke "SCN" "scn"))
+  (cond
+    [(not color)]
+    #;[(is-a? color PDFGradient)
+       (set-color-space "Pattern" stroke)
+       (send color apply op)
+       #true] ; todo
+    [else
+     (define color-space
+       (case (length color)
+         [(3) 'DeviceRGB]
+         [(4) 'DeviceCMYK]
+         [else (raise-argument-error 'set-color "color of length 3 or 4" color)]))
+     (set-color-space doc color-space stroke)
+       
+     ;; 181126 don't round, to be consistent with pdfkit behavior
+     (add-content doc (format "~a ~a" (string-join (map (λ (num) (numberizer num #:round #false)) color) " ") op))
+     #true]))
+
+(define (set-color-space doc space stroke)
+  (define op (if stroke "CS" "cs"))
+  (add-content doc (format "/~a ~a" space op)))
+
+(define (stroke-color doc color [opacity 1])
+  (unless (normalize-color color)
+    (raise-argument-error 'stroke-color "valid color string" color))
+  (when (set-color doc color #t) (stroke-opacity doc opacity))
+  doc)
+
+(define (stroke-opacity doc opacity)
+  (do-opacity doc #f opacity)
+  doc)
 
 (define (normalize-color color)
   ;; parses color string into list of values
@@ -35,83 +104,25 @@
                               (if (integer? x) (inexact->exact x) x))]
     [_ #false]))
 
-(define (color-mixin [% object%])
-  (class %
-    (super-new)
-    (field [@opacity-registry (make-hash)]
-           [@opacity-count 0]
-           [@grad-count 0]
-           [(@current-fill-color current-fill-color) #false])
+#;(define (color-mixin [% object%])
+    (class %
+      (super-new)
+      (field [@opacity-registry (make-hash)]
+             [@opacity-count 0]
+             [@grad-count 0]
+             [(@current-fill-color current-fill-color) #false])
 
-    (define/public (set-color color-in stroke)
-      (define color (normalize-color color-in))
-      (define op (if stroke "SCN" "scn"))
-      (cond
-        [(not color)]
-        #;[(is-a? color PDFGradient)
-           (set-color-space "Pattern" stroke)
-           (send color apply op)
-           #true] ; todo
-        [else
-         (define color-space
-           (case (length color)
-             [(3) 'DeviceRGB]
-             [(4) 'DeviceCMYK]
-             [else (raise-argument-error 'set-color "color of length 3 or 4" color)]))
-         (set-color-space color-space stroke)
-       
-         ;; 181126 don't round, to be consistent with pdfkit behavior
-         (send this add-content (format "~a ~a" (string-join (map (λ (num) (numberizer num #:round #false)) color) " ") op))
-         #true]))
     
-    (define/public (set-color-space space stroke)
-      (define op (if stroke "CS" "cs"))
-      (send this add-content (format "/~a ~a" space op)))
-
-    (define/public (fill-color color [opacity 1])
-      (unless (normalize-color color)
-        (raise-argument-error 'fill-color "valid color string" color))
-      (when (set-color color #f) (fill-opacity opacity))
-      ;; save this for text wrapper, which needs to reset
-      ;; the fill color on new pages
-      (set! @current-fill-color (list color opacity))
-      this)
+    
+      
 
-    (define/public (stroke-color color [opacity 1])
-      (unless (normalize-color color)
-        (raise-argument-error 'stroke-color "valid color string" color))
-      (when (set-color color #t) (stroke-opacity opacity))
-      this)
+      
 
-    (define/public (fill-opacity opacity)
-      (do-opacity opacity #f)
-      this)
+      
 
-    (define/public (stroke-opacity opacity)
-      (do-opacity #f opacity)
-      this)
+      
     
-    (define/public (do-opacity [fill-arg #f] [stroke-arg #f])
-      (define fill-opacity (and fill-arg (bounded 0 fill-arg 1)))
-      (define stroke-opacity (and stroke-arg (bounded 0 stroke-arg 1)))
-      (when (or fill-opacity stroke-opacity)
-        (define key (format "~a_~a"
-                            (if fill-opacity (numberizer fill-opacity) "")
-                            (if stroke-opacity (numberizer stroke-opacity) "")))
-        (match-define (list dictionary name)
-          (hash-ref! (get-field @opacity-registry this) key
-                     (λ ()
-                       (define dictionary (make-hasheq '((Type . ExtGState))))
-                       (when fill-opacity
-                         (hash-set! dictionary 'ca fill-opacity))
-                       (when stroke-opacity
-                         (hash-set! dictionary 'CA stroke-opacity))
-                       (define ref-dict (make-ref dictionary))
-                       (ref-end ref-dict)
-                       (set! @opacity-count (add1 @opacity-count))
-                       (list ref-dict (string->symbol (format "Gs~a" @opacity-count))))))
-        (hash-set! (page-ext_gstates (send this page)) name dictionary)        
-        (send this add-content (format "/~a gs" name))))))
+      ))
 
 (define named-colors
   (hash "aliceblue" '(240 248 255)
@@ -264,7 +275,6 @@
 
 (module+ test
   (require rackunit)
-  (define c (new (color-mixin)))
   (check-equal? (normalize-color "#6699Cc") '(0.4 0.6 0.8))
   (check-false (normalize-color "#88aaCCC"))
   (check-equal? (normalize-color "#69C") '(0.4 0.6 0.8))

pitfall/pitfall/document.rkt

@@ -20,16 +20,6 @@
 (define (store-ref doc ref)
   (set-$doc-refs! doc (cons ref ($doc-refs doc))))
 
-(define (page doc) (first ($doc-pages doc)))
-
-(define (add-content doc data)
-  (page-write (page doc) data))
-
-(define (transform doc scaleX shearY shearX scaleY mdx mdy)
-  (define new-ctm (list scaleX shearY shearX scaleY mdx mdy))
-  (set-$doc-ctm! doc (combine-transforms ($doc-ctm doc) new-ctm))
-  (add-content doc (make-transform-string new-ctm)))
-
 (define (make-$doc [options (make-hasheq)])
 
   ;; initial values
@@ -88,7 +78,7 @@
   (current-compress-streams? (hash-ref options 'compress #t))
   (current-auto-first-page (hash-ref options 'autoFirstPage #t))
   (when (current-auto-first-page) (add-page new-doc))
-  #;(when (current-auto-helvetica) (font "Helvetica"))
+  (when (current-auto-helvetica) (font new-doc "Helvetica"))
   
   new-doc)
 

pitfall/pitfall/fonts.rkt

@@ -1,10 +1,51 @@
 #lang debug racket/base
 (require
+  "core.rkt"
   racket/class
   racket/match
   sugar/unstable/dict
   "font-open.rkt")
-(provide fonts-mixin)
+(provide (all-defined-out))
+
+(define (current-line-height doc [include-gap #f])
+      (send ($doc-current-font doc) line-height ($doc-current-font-size doc) include-gap))
+
+(define (font doc src [size-or-family #f] [maybe-size #f])
+  (match-define (list family size)
+    (match size-or-family
+      [(? number?) (list #f size-or-family)]
+      [_ (list size-or-family maybe-size)]))
+  ;; check registered fonts if src is a string
+  (define cache-key
+    (match src
+      [(? string?) #:when (hash-has-key? ($doc-registered-fonts doc) src)
+                   (define ck src)
+                   (set! src (hash-ref (hash-ref ($doc-registered-fonts doc) ck) 'src))
+                   (set! family (hash-ref (hash-ref ($doc-registered-fonts doc) ck) 'family))
+                   ck]
+      [_ (match (or family src)
+           [(? string? str) str]
+           [_ #false])]))
+      
+  (when size (font-size doc size))
+
+  (match (hash-ref ($doc-font-families doc) cache-key #f) ; check if the font is already in the PDF
+    [(? values val) (set-$doc-current-font! doc val)]
+    [_ ; if not, load the font
+     (set-$doc-font-count! doc (add1 ($doc-font-count doc)))
+     (define id (string->symbol (format "F~a" ($doc-font-count doc))))
+     (set-$doc-current-font! doc (PDFFont-open src family id))
+     ;; check for existing font families with the same name already in the PDF
+     (match (hash-ref ($doc-font-families doc) (get-field name ($doc-current-font doc)) #f)
+       [(? values font) (set-$doc-current-font! doc font)]
+       [_ ;; save the font for reuse later
+        (when cache-key (hash-set! ($doc-font-families doc) cache-key ($doc-current-font doc)))
+        (hash-set! ($doc-font-families doc) (get-field name ($doc-current-font doc)) ($doc-current-font doc))])])
+  doc)
+
+(define (font-size doc size)
+  (set-$doc-current-font-size! doc size)
+  doc)
 
 (define (fonts-mixin [% object%])
   (class %
@@ -52,8 +93,7 @@
       (set! @current-font-size size)
       this)
 
-    (define/public (current-line-height [include-gap #f])
-      (send @current-font line-height @current-font-size include-gap))
+    
 
     (define/public (register-font name src [family #f])
       (hash-set! @registered-fonts name (make-hash (list (cons 'src src)

pitfall/pitfall/images.rkt

@@ -5,9 +5,10 @@
   sugar/unstable/dict
   "core.rkt"
   "page.rkt"
+  "vector.rkt"
   "png.rkt"
   "jpeg.rkt")
-(provide image-mixin)
+(provide (all-defined-out))
 
 (define (open-pdf-image src label)
   (define data (cond
@@ -21,25 +22,17 @@
       [else (raise-argument-error 'open-pdf-image "valid image format" src)]))
   (img-constructor data label))
 
-(define (image-mixin [% object%])
-  (class %
-    (super-new)
-    (field [@image-registry (mhash)]
-           [@image-count 0])
-    (inherit-field [@x x] [@y y])
-    (inherit page)
-
-    (define/public (image src [x-in #f] [y-in #f] [options (mhasheq)])
-      (define x (or x-in (hash-ref options 'x #f) @x))
-      (define y (or y-in (hash-ref options 'y #f) @y))
+    (define (image doc src [x-in #f] [y-in #f] [options (mhasheq)])
+      (define x (or x-in (hash-ref options 'x #f) ($doc-x doc)))
+      (define y (or y-in (hash-ref options 'y #f) ($doc-y doc)))
 
       (define image (cond
-                      [(and (string? src) (hash-ref @image-registry src #f))]
+                      [(and (string? src) (hash-ref ($doc-image-registry doc) src #f))]
                       [(and ($img? src) ($img-width src) ($img-height src)) src]
-                      [else (send this open-image src)]))
+                      [else (open-image doc src)]))
       (unless ($img-ref image) (($img-embed-proc image) image))
   
-      (hash-ref! (page-xobjects (page)) ($img-label image) ($img-ref image))
+      (hash-ref! (page-xobjects (page doc)) ($img-label image) ($img-ref image))
 
       (define image-width ($img-width image))
       (define image-height ($img-height image))
@@ -101,20 +94,20 @@
           [("bottom") (set! y (+ y bh - h))]))
 
       ;; Set the current y position to below the image if it is in the document flow
-      (when (= @y y) (set! y (+ y h)))
-      (send this save)
-      (send this transform w 0 0 (- h) x (+ y h))
-      (send this add-content (format "/~a Do" ($img-label image)))
-      (send this restore)
-      this)
+      (when (= ($doc-y doc) y) (set! y (+ y h)))
+      (save doc)
+      (transform doc w 0 0 (- h) x (+ y h))
+      (add-content doc (format "/~a Do" ($img-label image)))
+      (restore doc)
+      doc)
 
-    (define/public (open-image src)
+    (define (open-image doc src)
       (cond
-        [(and (string? src) (hash-ref @image-registry src #f))]
+        [(and (string? src) (hash-ref ($doc-image-registry doc) src #f))]
         [else
-         (set! @image-count (add1 @image-count))
-         (define image-id (string->symbol (format "I~a" @image-count)))
+         (set-$doc-image-count! doc (add1 ($doc-image-count doc)))
+         (define image-id (string->symbol (format "I~a" ($doc-image-count doc))))
          (define new-image (open-pdf-image src image-id))
-         (when (string? src) (hash-set! @image-registry src new-image))
-         new-image]))))
+         (when (string? src) (hash-set! ($doc-image-registry doc) src new-image))
+         new-image]))
 

pitfall/pitfall/page.rkt

@@ -7,6 +7,11 @@
 
 (provide (all-defined-out))
 
+(define (page doc) (car ($doc-pages doc)))
+
+(define (add-content doc data)
+  (page-write (page doc) data))
+
 (struct $page (page-parent options size layout dimensions width height content resources margins dictionary)
   #:transparent #:mutable)
 

pitfall/pitfall/pdftest.rkt

@@ -11,8 +11,8 @@
 
 (test-mode #t)
 
-(require rackunit pitfall/document racket/runtime-path racket/class)
-(provide (all-from-out  rackunit racket/runtime-path pitfall/document racket/class))
+(require rackunit pitfall/document pitfall/vector pitfall/color pitfall/text pitfall/fonts pitfall/images racket/runtime-path racket/class)
+(provide (all-from-out  rackunit racket/runtime-path pitfall/document pitfall/vector pitfall/text pitfall/fonts  pitfall/images pitfall/color  racket/class))
 
 (define (this->control this) (path-add-extension this #"" #" copy."))
 

pitfall/pitfall/text.rkt

@@ -2,6 +2,10 @@
 (require
   "core.rkt"
   "page.rkt"
+  "annotations.rkt"
+  "fonts.rkt"
+  "vector.rkt"
+  "color.rkt"
   racket/class
   racket/match
   racket/string
@@ -11,158 +15,140 @@
   sugar/list
   racket/promise
   fontland/glyph-position)
-(provide text-mixin)
+(provide (all-defined-out))
 
 #|
 approximates
 https://github.com/mbutterick/pdfkit/blob/master/lib/mixins/text.coffee
 |#
 
-(define (text-mixin [% mixin-tester%])
-  (class %
-    (super-new)
-    (field [@line-gap 0]
-           [@text-options #f]
-           [(@x x) 0]
-           [(@y y) 0])
+(define (text doc str [x #f] [y #f] [options (mhash)])
+  (when x (set-$doc-x! doc x))
+  (when y (set-$doc-y! doc y))
+  (line doc str options)
+  doc)
 
-    (inherit-field [@current-font current-font]
-                   [@current-font-size current-font-size]
-                   [@current-fill-color current-fill-color]
-                   @pages)
-    (inherit [@current-line-height current-line-height])
-    (inherit save line-width move-to line-to stroke stroke-color transform restore) ; from vector
-    (inherit add-content) ; from base
+(define (fragment doc text x y-in options)
+  (define character-spacing (hash-ref options 'characterSpacing 0))
 
-    (define/public (move-down [lines 1] #:factor [factor 1])
-      (set! @y (+ @y (* factor (@current-line-height #t) (+ lines @line-gap))))
-      this)
+  ;; calculate the actual rendered width of the string after word and character spacing
+  (define rendered-width
+    ;; wrap this in delay so it's only calculated if needed
+    (delay
+      (+ (string-width doc text options)
+         (* character-spacing (sub1 (string-length text))))))
 
-    (define/public (move-up  [lines 1])
-      (move-down this #:factor -1))
-
-    (define/public (text str [x #f] [y #f] [options (mhash)])
-      (when x (set! @x x))
-      (when y (set! @y y))
-      (line str options)
-      this)
-
-    (define/public (string-width str [options (mhash)])
-      (+ (send @current-font string-width str @current-font-size (hash-ref options 'features #f))
-         (* (hash-ref options 'characterSpacing 0) (sub1 (string-length str)))))
-
-    (define/public (line str [options (mhasheq)])
-      (fragment str @x @y options)
-      (define line-gap (or (hash-ref options 'line-gap #f) @line-gap 0))
-      ;; 181224 unsuppress size tracking in test mode to preserve test 04
-      ;; otherwise we'll be doing our own line measurement
-      (when (test-mode) (set! @x (+ @x (send this string-width str))))
-      (void))
-
-    (define/public (fragment text x y-in options)
-      (define character-spacing (hash-ref options 'characterSpacing 0))
-
-      ;; calculate the actual rendered width of the string after word and character spacing
-      (define rendered-width
-        ;; wrap this in delay so it's only calculated if needed
-        (delay
-          (+ (string-width text options)
-             (* character-spacing (sub1 (string-length text))))))
-
-      ;; create link annotations if the link option is given
-      (when (hash-ref options 'link #f)
-        (send this link x y-in (force rendered-width) (@current-line-height) (hash-ref options 'link)))
+  ;; create link annotations if the link option is given
+  (when (hash-ref options 'link #f)
+    (link doc x y-in (force rendered-width) (current-line-height doc) (hash-ref options 'link)))
   
-      ;; create underline or strikethrough line
-      (when (or (hash-ref options 'underline #f) (hash-ref options 'strike #f))
-        (save)
-        (unless (hash-ref options 'stroke #f)
-          (define fill-color-args @current-fill-color)
-          (send this stroke-color . fill-color-args))
-        (define new-line-width (if (< @current-font-size 10) 0.5 (floor (/ @current-font-size 10))))
-        (line-width new-line-width)
-        (define d (if (hash-ref options 'underline) 1 2))
-        (define line-y (+ y-in (/ (@current-line-height) d)))
-        (when (hash-ref options 'underline)
-          (set! line-y (+ line-y (- new-line-width))))
-        (move-to x line-y)
-        (line-to (+ x (force rendered-width)) line-y)
-        (stroke)
-        (restore))
+  ;; create underline or strikethrough line
+  (when (or (hash-ref options 'underline #f) (hash-ref options 'strike #f))
+    (save doc)
+    (unless (hash-ref options 'stroke #f)
+      (define fill-color-args ($doc-current-fill-color doc))
+      (apply stroke-color doc fill-color-args))
+    (define new-line-width (if (< ($doc-current-font-size doc) 10) 0.5 (floor (/ ($doc-current-font-size doc) 10))))
+    (line-width new-line-width)
+    (define d (if (hash-ref options 'underline) 1 2))
+    (define line-y (+ y-in (/ (current-line-height) d)))
+    (when (hash-ref options 'underline)
+      (set! line-y (+ line-y (- new-line-width))))
+    (move-to x line-y)
+    (line-to (+ x (force rendered-width)) line-y)
+    (stroke)
+    (restore doc))
 
-      ;; flip coordinate system
-      (save)
-      (define page-height ($page-height (first @pages)))
-      (transform 1 0 0 -1 0 page-height)
-      (define y (- page-height
-                   y-in
-                   (* (/ (get-field ascender @current-font) 1000)
-                      @current-font-size)))
+  ;; flip coordinate system
+  (save doc)
+  (define page-height ($page-height (page doc)))
+  (transform doc 1 0 0 -1 0 page-height)
+  (define y (- page-height
+               y-in
+               (* (/ (get-field ascender ($doc-current-font doc)) 1000)
+                  ($doc-current-font-size doc))))
 
-      ;; add current font to page if necessary
-      (define current-font-id (get-field id @current-font))
-      (hash-ref! (page-fonts (first @pages)) current-font-id  (λ () (send @current-font make-font-ref)))
+  ;; add current font to page if necessary
+  (define current-font-id (get-field id ($doc-current-font doc)))
+  (hash-ref! (page-fonts (page doc)) current-font-id  (λ () (send ($doc-current-font doc) make-font-ref)))
   
-      (add-content "BT") ; begin the text object
-      (add-content (format "1 0 0 1 ~a ~a Tm" (numberizer x) (numberizer y))) ; text position
-      (add-content (format "/~a ~a Tf" current-font-id
-                           (numberizer @current-font-size))) ; font and font size
-      (let ([mode (+ (if (hash-ref options 'fill #f) 1 0) (if (hash-ref options 'stroke #f) 1 0))])
-        (when (and mode (not (zero? mode)))
-          (add-content (format "~a Tr" mode))))
-      (when (not (zero? character-spacing))
-        (add-content (format "~a Tc" character-spacing)))
+  (add-content doc "BT") ; begin the text object
+  (add-content doc (format "1 0 0 1 ~a ~a Tm" (numberizer x) (numberizer y))) ; text position
+  (add-content doc (format "/~a ~a Tf" current-font-id
+                           (numberizer ($doc-current-font-size doc)))) ; font and font size
+  (let ([mode (+ (if (hash-ref options 'fill #f) 1 0) (if (hash-ref options 'stroke #f) 1 0))])
+    (when (and mode (not (zero? mode)))
+      (add-content doc (format "~a Tr" mode))))
+  (when (not (zero? character-spacing))
+    (add-content doc (format "~a Tc" character-spacing)))
 
-      ;; Add the actual text
-      ;; 180321: the first call to this operation is very slow from Quad
-      ;; 181126: because `encode` calls `layout`
-      (match-define (list encoded-char-strs positions)
-        (map list->vector (send @current-font encode text (hash-ref options 'features #f))))
+  ;; Add the actual text
+  ;; 180321: the first call to this operation is very slow from Quad
+  ;; 181126: because `encode` calls `layout`
+  (match-define (list encoded-char-strs positions)
+    (map list->vector (send ($doc-current-font doc) encode text (hash-ref options 'features #f))))
   
-      (define scale (/ @current-font-size 1000.0))
-      (define commands empty)
+  (define scale (/ ($doc-current-font-size doc) 1000.0))
+  (define commands empty)
   
-      ;; Adds a segment of text to the TJ command buffer
-      (define last-segment 0)
-      (define (add-segment cur)
-        (when (< last-segment cur)
-          (define hex (string-append* (for/list ([str (in-vector encoded-char-strs last-segment cur)]) str)))
-          (define posn (vector-ref positions (sub1 cur)))
-          (define advance (- (glyph-position-x-advance posn) (glyph-position-advance-width posn)))
-          (set! commands (cons (format "<~a> ~a" hex (numberizer (- advance))) commands)))
-        (set! last-segment cur))
+  ;; Adds a segment of text to the TJ command buffer
+  (define last-segment 0)
+  (define (add-segment cur)
+    (when (< last-segment cur)
+      (define hex (string-append* (for/list ([str (in-vector encoded-char-strs last-segment cur)]) str)))
+      (define posn (vector-ref positions (sub1 cur)))
+      (define advance (- (glyph-position-x-advance posn) (glyph-position-advance-width posn)))
+      (set! commands (cons (format "<~a> ~a" hex (numberizer (- advance))) commands)))
+    (set! last-segment cur))
 
-      ;; Flushes the current TJ commands to the output stream
-      (define (flush idx)
-        (add-segment idx)
-        (when (positive? (length commands))
-          (add-content (format "[~a] TJ" (string-join (reverse commands) " ")))
-          (set! commands empty)))
+  ;; Flushes the current TJ commands to the output stream
+  (define (flush idx)
+    (add-segment idx)
+    (when (positive? (length commands))
+      (add-content doc (format "[~a] TJ" (string-join (reverse commands) " ")))
+      (set! commands empty)))
   
-      (for/fold ([had-offset #f] [x x])
-                ([(posn idx) (in-indexed positions)])
-        (define having-offset
-          (cond
-            ;; If we have an x or y offset, we have to break out of the current TJ command
-            ;; so we can move the text position.
-            [(or (not (zero? (glyph-position-x-offset posn))) (not (zero? (glyph-position-y-offset posn))))
-             (flush idx)
-             (add-content ; Move the text position and flush just the current character
-              (format "1 0 0 1 ~a ~a Tm"
-                      (numberizer (+ x (* (glyph-position-x-offset posn) scale)))
-                      (numberizer (+ y (* (glyph-position-y-offset posn) scale)))))
-             (flush (add1 idx))
-             #true]
-            [else
-             ;; If the last character had an offset, reset the text position
-             (when had-offset
-               (add-content (format "1 0 0 1 ~a ~a Tm" (numberizer x) (numberizer y))))
-             ;; Group segments that don't have any advance adjustments
-             (unless (zero? (- (glyph-position-x-advance posn) (glyph-position-advance-width posn)))
-               (add-segment (add1 idx)))
-             #false]))
-        (values having-offset (+ x (* (glyph-position-x-advance posn) scale))))
+  (for/fold ([had-offset #f] [x x])
+            ([(posn idx) (in-indexed positions)])
+    (define having-offset
+      (cond
+        ;; If we have an x or y offset, we have to break out of the current TJ command
+        ;; so we can move the text position.
+        [(or (not (zero? (glyph-position-x-offset posn))) (not (zero? (glyph-position-y-offset posn))))
+         (flush idx)
+         (add-content doc ; Move the text position and flush just the current character
+                      (format "1 0 0 1 ~a ~a Tm"
+                              (numberizer (+ x (* (glyph-position-x-offset posn) scale)))
+                              (numberizer (+ y (* (glyph-position-y-offset posn) scale)))))
+         (flush (add1 idx))
+         #true]
+        [else
+         ;; If the last character had an offset, reset the text position
+         (when had-offset
+           (add-content doc (format "1 0 0 1 ~a ~a Tm" (numberizer x) (numberizer y))))
+         ;; Group segments that don't have any advance adjustments
+         (unless (zero? (- (glyph-position-x-advance posn) (glyph-position-advance-width posn)))
+           (add-segment (add1 idx)))
+         #false]))
+    (values having-offset (+ x (* (glyph-position-x-advance posn) scale))))
       
-      (flush (vector-length positions))
-      (add-content "ET") ; end the text object
-      (restore)))) ; restore flipped coordinate system
+  (flush (vector-length positions))
+  (add-content doc "ET") ; end the text object
+  (restore doc)) ; restore flipped coordinate system
+
+(define (line doc str [options (mhasheq)])
+  (fragment doc str ($doc-x doc) ($doc-y doc) options)
+  ;; 181224 unsuppress size tracking in test mode to preserve test 04
+  ;; otherwise we'll be doing our own line measurement
+  (when (test-mode) (set-$doc-x! doc (+ ($doc-x doc) (string-width doc str)))))
+
+(define (move-down doc [lines 1] #:factor [factor 1])
+  (set-$doc-y! (+ ($doc-y doc) (* factor (current-line-height #t) (+ lines ($doc-line-gap doc)))))
+  doc)
+
+(define (move-up doc [lines 1])
+  (move-down doc #:factor -1))
+
+(define (string-width doc str [options (mhash)])
+  (+ (send ($doc-current-font doc) string-width str ($doc-current-font-size doc) (hash-ref options 'features #f))
+     (* (hash-ref options 'characterSpacing 0) (sub1 (string-length str)))))

pitfall/pitfall/vector.rkt

@@ -1,6 +1,8 @@
 #lang racket/base
 (require
   "core.rkt"
+  "page.rkt"
+  "color.rkt"
   racket/class
   racket/match
   racket/string
@@ -9,160 +11,232 @@
   sugar/unstable/js
   sugar/unstable/dict
   "path.rkt")
-(provide vector-mixin default-ctm-value combine-transforms make-transform-string)
+(provide (all-defined-out))
 
 (define default-ctm-value '(1 0 0 1 0 0))
 
+(define (save doc)
+  (set-$doc-ctm-stack! doc (cons ($doc-ctm doc) ($doc-ctm-stack doc)))
+  (add-content doc "q"))
 
-
-(define (vector-mixin [% mixin-tester%])
-  (class %
-    (super-new)
-    (field [@ctm default-ctm-value]
-           [@ctm-stack null])
-    (inherit add-content) ; from base
-    (inherit stroke-color fill-color) ; from color
-
-    (define/public (save)
-      (set! @ctm-stack (cons @ctm @ctm-stack))
-      (add-content "q"))
-
-    (define/public (restore)
-      (set! @ctm (if (pair? @ctm-stack)
+(define (restore doc)
+  (set-$doc-ctm! doc
+                 (if (pair? ($doc-ctm-stack doc))
                      (begin0
-                       (car @ctm-stack)
-                       (set! @ctm-stack (cdr @ctm-stack)))
+                       (car ($doc-ctm-stack doc))
+                       (set-$doc-ctm-stack! doc (cdr ($doc-ctm-stack doc))))
                      default-ctm-value))
-      (add-content "Q"))
-
-    (define/public (close-path)
-      (add-content "h"))
-
-    (define/public (line-cap [c #f])
-      (define cap-styles (hasheq 'butt 0 'round 1 'square 2))
-      (add-content
-       (format "~a J" (if (symbol? c)
-                          (hash-ref cap-styles c)
-                          ""))))
-
-    (define/public (line-join [j #f])
-      (define cap-styles (hasheq 'miter 0 'round 1 'bevel 2))
-      (add-content
-       (format "~a j" (if (symbol? j)
-                          (hash-ref cap-styles j)
-                          ""))))
-
-    (define/public (line-width w)
-      (add-content (format "~a w" (number w))))
-
-    (define/public (dash length [options (mhash)])
-      (cond
-        [(list? length)
-         (add-content
-          (format "[~a] ~a d"
-                  (string-join (map number length) " ")
-                  (hash-ref options 'phase 0)))]
-        [length
-         (define space (hash-ref options 'space length))
-         (define phase (hash-ref options 'phase 0))
-         (add-content (format "[~a ~a] ~a d" (number length) (number space) (number phase)))] 
-        [else this]))
-
-    (define/public (move-to x y)
-      (add-content (format "~a ~a m" x y)))
-
-    (define/public (line-to x y)
-      (add-content (format "~a ~a l" x y)))
-
-    (define/public (bezier-curve-to cp1x cp1y cp2x cp2y x y)
-      (add-content (format "~a c" (string-join (map number (list cp1x cp1y cp2x cp2y x y)) " "))))
-
-    (define/public (quadratic-curve-to cpx cpy x y)
-      (add-content (format "~a v" (string-join (map number (list cpx cpy x y)) " "))))
+  (add-content doc "Q"))
+
+(define (bezier-curve-to doc cp1x cp1y cp2x cp2y x y)
+  (add-content doc (format "~a c" (string-join (map numberizer (list cp1x cp1y cp2x cp2y x y)) " "))))
+
+(define (circle doc x y radius)
+  (ellipse doc x y radius))
+
+(define (close-path doc)
+  (add-content doc "h"))
+
+(define (dash doc length [options (mhash)])
+  (cond
+    [(list? length)
+     (add-content doc
+                  (format "[~a] ~a d"
+                          (string-join (map numberizer length) " ")
+                          (hash-ref options 'phase 0)))]
+    [length
+     (define space (hash-ref options 'space length))
+     (define phase (hash-ref options 'phase 0))
+     (add-content doc (format "[~a ~a] ~a d" (numberizer length) (numberizer space) (numberizer phase)))] 
+    [else doc]))
+
+(define (ellipse doc x y r1 [r2 r1])
+  ;; based on http://stackoverflow.com/questions/2172798/how-to-draw-an-oval-in-html5-canvas/2173084#2173084
+  ;; This constant is used to approximate a symmetrical arc using a cubic Bezier curve.
+  (define kappa (* 4 (/ (- (sqrt 2) 1) 3.0)))
+  (-= x r1)
+  (-= y r2)
+  (define ox (* r1 kappa)) ; control point offset horizontal
+  (define oy (* r2 kappa)) ; control point offset vertical
+  (define xe (+ x (* r1 2))) ; x-end
+  (define ye (+ y (* r2 2))) ; y-end
+  (define xm (+ x r1)) ; x-middle
+  (define ym (+ y r2)) ; y-middle
+  (move-to doc x ym)
+  (bezier-curve-to doc x (- ym oy) (- xm ox) y xm y)
+  (bezier-curve-to doc (+ xm ox) y xe (- ym oy) xe ym)
+  (bezier-curve-to doc xe (+ ym oy) (+ xm ox) ye xm ye)
+  (bezier-curve-to doc (- xm ox) ye x (+ ym oy) x ym)
+  (close-path doc))
+
+(define (fill doc [color #f] #:rule [rule #f])
+  (when color (fill-color doc color)) ;; fill-color method is from color mixin
+  (add-content doc (format "f~a" (winding-rule rule))))
+
+(define (fill-and-stroke doc [fill #f] [stroke fill] #:rule [rule #f])
+  (when fill (fill-color doc fill) (stroke-color doc stroke))
+  (add-content doc (format "B~a" (winding-rule rule))))
+
+(define (line-cap doc [c #f])
+  (define cap-styles (hasheq 'butt 0 'round 1 'square 2))
+  (add-content doc
+               (format "~a J" (if (symbol? c)
+                                  (hash-ref cap-styles c)
+                                  ""))))
+
+(define (line-join doc [j #f])
+  (define cap-styles (hasheq 'miter 0 'round 1 'bevel 2))
+  (add-content doc
+               (format "~a j" (if (symbol? j)
+                                  (hash-ref cap-styles j)
+                                  ""))))
+
+(define (line-to doc x y)
+  (add-content doc (format "~a ~a l" x y)))
+
+(define (line-width doc w)
+  (add-content doc (format "~a w" (numberizer w))))
+
+(define (move-to doc x y)
+  (add-content doc (format "~a ~a m" x y)))
+
+(define (polygon doc . points)
+  (match points
+    [(cons (list x y) other-points)
+     (move-to doc x y)
+     (for ([pt (in-list other-points)])
+       (match pt
+         [(list x y)
+          (line-to doc x y)]))
+     (close-path doc)]
+    [else doc]))
+
+(define (quadratic-curve-to doc cpx cpy x y)
+  (add-content doc (format "~a v" (string-join (map numberizer (list cpx cpy x y)) " "))))
+
+(define (rect doc x y w h)
+  (add-content doc (format "~a re" (string-join (map numberizer (list x y w h)) " "))))
+
+(define (shear doc x y)
+  (transform doc 1 y x 1 0 0))
+
+(define (stroke doc [color #f])
+  (when color (stroke-color doc color))
+  (add-content doc "S"))
+
+(define (transform doc scaleX shearY shearX scaleY mdx mdy)
+  (define new-ctm (list scaleX shearY shearX scaleY mdx mdy))
+  (set-$doc-ctm! doc (combine-transforms ($doc-ctm doc) new-ctm))
+  (add-content doc (make-transform-string new-ctm)))
+
+(define (translate doc x y)
+  (transform doc 1 0 0 1 x y))
+
+(define (winding-rule rule)
+  (if (and (string? rule) (regexp-match #rx"^even-?odd$" rule)) "*" ""))
+
+
+#;(define (vector-mixin [% mixin-tester%])
+    (class %
+      (super-new)
+      (field [@ctm default-ctm-value]
+             [@ctm-stack null])
+      (inherit add-content) ; from base
+      (inherit stroke-color fill-color) ; from color
+
+      (define/public (save)
+        (set! @ctm-stack (cons @ctm @ctm-stack))
+        (add-content "q"))
+
+      (define/public (restore)
+        (set! @ctm (if (pair? @ctm-stack)
+                       (begin0
+                         (car @ctm-stack)
+                         (set! @ctm-stack (cdr @ctm-stack)))
+                       default-ctm-value))
+        (add-content "Q"))
+
+      (define/public (close-path)
+        (add-content "h"))
+
+      
+
+      
+
+      (define/public (move-to x y)
+        (add-content (format "~a ~a m" x y)))
+
+      (define/public (line-to x y)
+        (add-content (format "~a ~a l" x y)))
+
+      (define/public (bezier-curve-to cp1x cp1y cp2x cp2y x y)
+        (add-content (format "~a c" (string-join (map numberizer (list cp1x cp1y cp2x cp2y x y)) " "))))
+
+      (define/public (quadratic-curve-to cpx cpy x y)
+        (add-content (format "~a v" (string-join (map numberizer (list cpx cpy x y)) " "))))
   
-    (define/public (rect x y w h)
-      (add-content (format "~a re" (string-join (map number (list x y w h)) " "))))
-
-    (define/public (ellipse x y r1 [r2 r1])
-      ;; based on http://stackoverflow.com/questions/2172798/how-to-draw-an-oval-in-html5-canvas/2173084#2173084
-      ;; This constant is used to approximate a symmetrical arc using a cubic Bezier curve.
-      (define kappa (* 4 (/ (- (sqrt 2) 1) 3.0)))
-      (-= x r1)
-      (-= y r2)
-      (define ox (* r1 kappa)) ; control point offset horizontal
-      (define oy (* r2 kappa)) ; control point offset vertical
-      (define xe (+ x (* r1 2))) ; x-end
-      (define ye (+ y (* r2 2))) ; y-end
-      (define xm (+ x r1)) ; x-middle
-      (define ym (+ y r2)) ; y-middle
-      (move-to x ym)
-      (bezier-curve-to x (- ym oy) (- xm ox) y xm y)
-      (bezier-curve-to (+ xm ox) y xe (- ym oy) xe ym)
-      (bezier-curve-to xe (+ ym oy) (+ xm ox) ye xm ye)
-      (bezier-curve-to (- xm ox) ye x (+ ym oy) x ym)
-      (close-path))
-
-    (define/public (circle x y radius)
-      (ellipse x y radius))
-
-    (define/public (polygon . points)
-      (match points
-        [(cons (list x y) other-points)
-         (move-to x y)
-         (for ([pt (in-list other-points)])
-           (match pt
-             [(list x y)
-              (line-to x y)]))
-         (close-path)]
-        [else this]))
-
-    (define/public (path path-data)
-      (parse-svg-path this path-data)
-      this)
-
-    (define/public (_windingRule rule)
-      (if (and (string? rule) (regexp-match #rx"^even-?odd$" rule)) "*" ""))
-
-    (define/public (fill [color #f] #:rule [rule #f])
-      (when color (fill-color color)) ;; fill-color method is from color mixin
-      (add-content (format "f~a" (_windingRule rule))))
-
-    (define/public (stroke [color #f])
-      (when color (stroke-color color))
-      (add-content "S"))
-
-    (define/public (fill-and-stroke [fill #f] [stroke fill] #:rule [rule #f])
-      (when fill (fill-color fill) (stroke-color stroke))
-      (add-content (format "B~a" (_windingRule rule))))
-
-    (define tm/c (list/c number? number? number? number? number? number?))
-    (define/public (make-transform-string ctm)
-      (format "~a cm" (string-join (map number ctm) " ")))
-
-    (define/public (clip [rule #f])
-      (add-content (string-append "W" (_windingRule rule) " n")))
-
-    (define/public (transform scaleX shearY shearX scaleY mdx mdy)
-      (define new-ctm (list scaleX shearY shearX scaleY mdx mdy))
-      (set! @ctm (combine-transforms (· this @ctm) new-ctm))
-      (add-content (make-transform-string new-ctm)))
-
-    (define/public (shear x y)
-      (transform 1 y x 1 0 0))
-
-    (define/public (translate x y)
-      (transform 1 0 0 1 x y))
-
-    (define/public scale
-      (match-lambda*
-        [(list (? object? this) (? number? x-factor)) (scale x-factor (mhash))]
-        [(list (? object? this) (? number? xFactor) (? hash? options)) (scale xFactor xFactor options)]
-        [(list (? object? this) (? number? xFactor) (? number? yFactor)) (scale this xFactor yFactor (mhash))]
-        [(list (? object? this) (? number? xFactor) (? number? yFactor) (? hash? options))
-         (match-define (list x y)
-           (match-let ([(list xo yo) (hash-ref options 'origin '(0 0))])
-             (list (* xo (- 1 xFactor)) (* yo (- 1 yFactor)))))
-         (transform xFactor 0 0 yFactor x y)]))))
+      
+
+      (define/public (ellipse x y r1 [r2 r1])
+        ;; based on http://stackoverflow.com/questions/2172798/how-to-draw-an-oval-in-html5-canvas/2173084#2173084
+        ;; This constant is used to approximate a symmetrical arc using a cubic Bezier curve.
+        (define kappa (* 4 (/ (- (sqrt 2) 1) 3.0)))
+        (-= x r1)
+        (-= y r2)
+        (define ox (* r1 kappa)) ; control point offset horizontal
+        (define oy (* r2 kappa)) ; control point offset vertical
+        (define xe (+ x (* r1 2))) ; x-end
+        (define ye (+ y (* r2 2))) ; y-end
+        (define xm (+ x r1)) ; x-middle
+        (define ym (+ y r2)) ; y-middle
+        (move-to x ym)
+        (bezier-curve-to x (- ym oy) (- xm ox) y xm y)
+        (bezier-curve-to (+ xm ox) y xe (- ym oy) xe ym)
+        (bezier-curve-to xe (+ ym oy) (+ xm ox) ye xm ye)
+        (bezier-curve-to (- xm ox) ye x (+ ym oy) x ym)
+        (close-path))
+
+      (define/public (circle x y radius)
+        (ellipse x y radius))
+
+      
+
+      (define/public (path path-data)
+        (parse-svg-path this path-data)
+        this)
+
+      (define/public (_windingRule rule)
+        (if (and (string? rule) (regexp-match #rx"^even-?odd$" rule)) "*" ""))
+
+      (define/public (fill [color #f] #:rule [rule #f])
+        (when color (fill-color color)) ;; fill-color method is from color mixin
+        (add-content (format "f~a" (_windingRule rule))))
+
+      (define/public (stroke [color #f])
+        (when color (stroke-color color))
+        (add-content "S"))
+
+      
+
+      (define tm/c (list/c number? number? number? number? number? number?))
+      (define/public (make-transform-string ctm)
+        (format "~a cm" (string-join (map numberizer ctm) " ")))
+
+      (define/public (clip [rule #f])
+        (add-content (string-append "W" (_windingRule rule) " n")))
+
+      
+
+      (define/public scale
+        (match-lambda*
+          [(list (? object? this) (? number? x-factor)) (scale x-factor (mhash))]
+          [(list (? object? this) (? number? xFactor) (? hash? options)) (scale xFactor xFactor options)]
+          [(list (? object? this) (? number? xFactor) (? number? yFactor)) (scale this xFactor yFactor (mhash))]
+          [(list (? object? this) (? number? xFactor) (? number? yFactor) (? hash? options))
+           (match-define (list x y)
+             (match-let ([(list xo yo) (hash-ref options 'origin '(0 0))])
+               (list (* xo (- 1 xFactor)) (* yo (- 1 yFactor)))))
+           (transform xFactor 0 0 yFactor x y)]))))
 
 (define (combine-transforms m new-ctm)
   (match-define (list m0 m1 m2 m3 m4 m5) m)
@@ -175,7 +249,7 @@
         (+ (* m1 dx) (* m3 dy) m5)))
 
 (define (make-transform-string ctm)
-      (format "~a cm" (string-join (map numberizer ctm) " ")))
+  (format "~a cm" (string-join (map numberizer ctm) " ")))
 
 (module+ test
   (require rackunit)

pitfall/ptest/test1.rkt

@@ -3,16 +3,14 @@
 
 (define (proc doc)
   ;; Draw a triangle and a circle
-  (send* doc
-    [save]
-    [move-to 100 150]
-    [line-to 100 250]
-    [line-to 200 250]
-    [fill "#FF3300"])
+  [save doc]
+  [move-to doc 100 150]
+  [line-to doc 100 250]
+  [line-to doc 200 250]
+  [fill doc "#FF3300"]
 
-  (send* doc
-    [circle 280 200 50]
-    [fill "#6600FF"]))
+  [circle doc 280 200 50]
+  [fill doc "#6600FF"])
 
 (define-runtime-path this "test1rkt.pdf")
 (make-doc this #f proc)

pitfall/ptest/test2.rkt

@@ -4,71 +4,67 @@
 (define (proc doc)
 
   ;; curved path as bezier
-  (send* doc
-    [move-to 0 20]
-    [line-to 100 160]
-    [quadratic-curve-to 130 200 150 120]
-    [bezier-curve-to 190 -40 200 200 300 150]  
-    [line-to 400 90]                         
-    [stroke])
+  [move-to doc 0 20]
+  [line-to doc 100 160]
+  [quadratic-curve-to doc 130 200 150 120]
+  [bezier-curve-to doc 190 -40 200 200 300 150]  
+  [line-to doc 400 90]                         
+  [stroke doc]
 
-  (send* doc [translate 0 200])
+  [translate doc 0 200]
 
   ;; triangle
-  (send* doc
-    [polygon '(100 0) '(50 100) '(150 100)]
-    [stroke])
+  [polygon doc '(100 0) '(50 100) '(150 100)]
+  [stroke doc]
 
   ;; dashed circle
-  (send* doc
-    [save]
-    [translate 200 0]
-    [circle 100 50 50]
-    [dash 5 (hash 'space 10)]
-    [stroke]
-    [restore])
+  [save doc]
+  [translate doc 200 0]
+  [circle doc 100 50 50]
+  [dash doc 5 (hash 'space 10)]
+  [stroke doc]
+  [restore doc]
 
   ;; filled circle
-  (send* doc
-    [save]
-    [translate 400 0]
-    [circle 100 50 50]
-    [line-width 3]
-    [fill-opacity 0.8]
-    [fill-and-stroke "red" "#900"]
-    [restore])
+  [save doc]
+  [translate doc 400 0]
+  [circle doc 100 50 50]
+  [line-width doc 3]
+  [fill-opacity doc 0.8]
+  [fill-and-stroke doc "red" "#900"]
+  [restore doc]
 
-  (send* doc [translate 0 200])
+  [translate doc 0 200]
 
   ;; these examples are easier to see with a large line width
-  (send* doc [line-width 25])
+  [line-width doc 25]
 
   ;; line cap settings
-  (send* doc [line-cap 'butt]
-    [move-to 50 20]
-    [line-to 100 20]
-    [stroke]
-    [line-cap 'round]
-    [move-to 150 20]
-    [line-to 200 20]
-    [stroke])
+  [line-cap doc 'butt]
+  [move-to doc 50 20]
+  [line-to doc 100 20]
+  [stroke doc]
+  [line-cap doc 'round]
+  [move-to doc 150 20]
+  [line-to doc 200 20]
+  [stroke doc]
 
   ;; square line cap shown with a circle instead of a line so you can see it
-  (send* doc [line-cap 'square]
-    [move-to 250 20]
-    [circle 275 30 15]
-    [stroke])
+  [line-cap doc 'square]
+  [move-to doc 250 20]
+  [circle doc 275 30 15]
+  [stroke doc]
 
   ;; line join settings
-  (send* doc [line-join 'miter]
-    [rect 50 100 50 50]
-    [stroke]
-    [line-join 'round]
-    [rect 150 100 50 50]
-    [stroke]
-    [line-join 'bevel]
-    [rect 250 100 50 50]
-    [stroke]))
+  [line-join doc 'miter]
+  [rect doc 50 100 50 50]
+  [stroke doc]
+  [line-join doc 'round]
+  [rect doc 150 100 50 50]
+  [stroke doc]
+  [line-join doc 'bevel]
+  [rect doc 250 100 50 50]
+  [stroke doc])
 
 
 

pitfall/ptest/test3.rkt

@@ -2,7 +2,7 @@
 (require pitfall/pdftest)
 
 (define (proc doc)
-  (send doc text "Hello world"))
+  (text doc "Hello world"))
 
 (define-runtime-path this "test3rkt.pdf")
 (make-doc this #f proc)

pitfall/ptest/test4.rkt

@@ -2,62 +2,61 @@
 (require pitfall/pdftest)
 
 (define (proc doc)
-  (send* doc
-     [font "Courier-Bold"]
-     [font-size 10]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Courier-BoldOblique"]
-     [font-size 11]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Courier-Oblique"]
-     [font-size 12]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Courier"]
-     [font-size 14]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Helvetica-Bold"]
-     [font-size 16]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Helvetica-BoldOblique"]
-     [font-size 18]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Helvetica-Oblique"]
-     [font-size 20]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Helvetica"]
-     [font-size 22]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Symbol"]
-     [font-size 24]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Times-Bold"]
-     [font-size 26]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Times-BoldItalic"]
-     [font-size 28]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Times-Italic"]
-     [font-size 30]
-     [text "Hello"]
-     [translate -30 30]
-     [font "Times-Roman"]
-     [font-size 32]
-     [text "Hello"]
-     [translate -30 30]
-     [font "ZapfDingbats"]
-     [font-size 34]
-     [text "Hello"]))
+  [font doc "Courier-Bold"]
+     [font-size doc 10]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Courier-BoldOblique"]
+     [font-size doc 11]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Courier-Oblique"]
+     [font-size doc 12]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Courier"]
+     [font-size doc 14]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Helvetica-Bold"]
+     [font-size doc 16]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Helvetica-BoldOblique"]
+     [font-size doc 18]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Helvetica-Oblique"]
+     [font-size doc 20]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Helvetica"]
+     [font-size doc 22]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Symbol"]
+     [font-size doc 24]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Times-Bold"]
+     [font-size doc 26]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Times-BoldItalic"]
+     [font-size doc 28]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Times-Italic"]
+     [font-size doc 30]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "Times-Roman"]
+     [font-size doc 32]
+     [text doc "Hello"]
+     [translate doc -30 30]
+     [font doc "ZapfDingbats"]
+     [font-size doc 34]
+     [text doc "Hello"])
 
 (define-runtime-path this "test4rkt.pdf")
 (make-doc this #f proc)

pitfall/ptest/test5.rkt

@@ -4,11 +4,10 @@
 (define-runtime-path death "assets/death.png")
 
 (define (proc doc)
-  (send* doc
-  [font "Times-Italic"]
-  [font-size 25]
-  [text "Some fantastic text!" 100 100 (hash 'lineBreak #f)]
-  [image death 100 160 (hash 'width 412)]))
+  [font doc "Times-Italic"]
+  [font-size doc 25]
+  [text doc "Some fantastic text!" 100 100 (hash 'lineBreak #f)]
+  [image doc death 100 160 (hash 'width 412)])
 
 (define-runtime-path this "test5rkt.pdf")
 (make-doc this #f proc)