From 415723eb7c5db74bdbc54a0a76f0fb966b9b265b Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 26 Dec 2018 13:45:36 -0800 Subject: [PATCH] step5 --- pitfall/pitfall/annotations.rkt | 87 ++++---- pitfall/pitfall/check-pdf.rkt | 12 +- pitfall/pitfall/color.rkt | 156 +++++++------- pitfall/pitfall/document.rkt | 12 +- pitfall/pitfall/fonts.rkt | 46 +++- pitfall/pitfall/images.rkt | 47 ++-- pitfall/pitfall/page.rkt | 5 + pitfall/pitfall/pdftest.rkt | 4 +- pitfall/pitfall/text.rkt | 258 +++++++++++----------- pitfall/pitfall/vector.rkt | 370 +++++++++++++++++++------------- pitfall/ptest/test1.rkt | 16 +- pitfall/ptest/test2.rkt | 94 ++++---- pitfall/ptest/test3.rkt | 2 +- pitfall/ptest/test4.rkt | 111 +++++----- pitfall/ptest/test5.rkt | 9 +- 15 files changed, 652 insertions(+), 577 deletions(-) diff --git a/pitfall/pitfall/annotations.rkt b/pitfall/pitfall/annotations.rkt index 516a9444..99ab2ec2 100644 --- a/pitfall/pitfall/annotations.rkt +++ b/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)) diff --git a/pitfall/pitfall/check-pdf.rkt b/pitfall/pitfall/check-pdf.rkt index d1c7e501..ec02238e 100644 --- a/pitfall/pitfall/check-pdf.rkt +++ b/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))) diff --git a/pitfall/pitfall/color.rkt b/pitfall/pitfall/color.rkt index ece7cdb1..169fa01c 100644 --- a/pitfall/pitfall/color.rkt +++ b/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)) diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt index 0b2ccfcd..b65c9fdb 100644 --- a/pitfall/pitfall/document.rkt +++ b/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) diff --git a/pitfall/pitfall/fonts.rkt b/pitfall/pitfall/fonts.rkt index ba2872bd..b41f1636 100644 --- a/pitfall/pitfall/fonts.rkt +++ b/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) diff --git a/pitfall/pitfall/images.rkt b/pitfall/pitfall/images.rkt index 63e27069..b89a6e43 100644 --- a/pitfall/pitfall/images.rkt +++ b/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])) diff --git a/pitfall/pitfall/page.rkt b/pitfall/pitfall/page.rkt index 73739779..53d2df78 100644 --- a/pitfall/pitfall/page.rkt +++ b/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) diff --git a/pitfall/pitfall/pdftest.rkt b/pitfall/pitfall/pdftest.rkt index 2b9d0cde..f0ead9da 100644 --- a/pitfall/pitfall/pdftest.rkt +++ b/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.")) diff --git a/pitfall/pitfall/text.rkt b/pitfall/pitfall/text.rkt index 0474b458..2e3183b7 100644 --- a/pitfall/pitfall/text.rkt +++ b/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))))) diff --git a/pitfall/pitfall/vector.rkt b/pitfall/pitfall/vector.rkt index c3329bd3..9852c983 100644 --- a/pitfall/pitfall/vector.rkt +++ b/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) diff --git a/pitfall/ptest/test1.rkt b/pitfall/ptest/test1.rkt index b59dd70a..21475650 100644 --- a/pitfall/ptest/test1.rkt +++ b/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) diff --git a/pitfall/ptest/test2.rkt b/pitfall/ptest/test2.rkt index b6217ce5..fd1aeae7 100644 --- a/pitfall/ptest/test2.rkt +++ b/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]) diff --git a/pitfall/ptest/test3.rkt b/pitfall/ptest/test3.rkt index 4b55d82d..90882020 100644 --- a/pitfall/ptest/test3.rkt +++ b/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) diff --git a/pitfall/ptest/test4.rkt b/pitfall/ptest/test4.rkt index fad4aab4..d9809311 100644 --- a/pitfall/ptest/test4.rkt +++ b/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) diff --git a/pitfall/ptest/test5.rkt b/pitfall/ptest/test5.rkt index 13764781..cd4e8e2e 100644 --- a/pitfall/ptest/test5.rkt +++ b/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)