mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

step5

Browse Source
main
Matthew Butterick 5 years ago
parent 7287495bca
commit 415723eb7c
15 changed files with 652 additions and 577 deletions
Show Stats Download Patch File Download Diff File

87
pitfall/pitfall/annotations.rkt
Unescape Escape View File

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

12
pitfall/pitfall/check-pdf.rkt
Unescape Escape View File

@ -118,14 +118,6 @@
(cons idx (parse-pdf-bytes (peek-bytes (- end start) start))))) (cons idx (parse-pdf-bytes (peek-bytes (- end start) start)))))
< #:key car)) < #: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 (dict-compare arg1 arg2)
(define d1 (if (dict? arg1) arg1 (pdf->dict arg1))) (define d1 (if (dict? arg1) arg1 (pdf->dict arg1)))
(define d2 (if (dict? arg2) arg2 (pdf->dict arg2))) (define d2 (if (dict? arg2) arg2 (pdf->dict arg2)))
@ -136,9 +128,7 @@
(unless (equal? k1 k2) (unless (equal? k1 k2)
(error (format "keys unequal in ~a and ~a: ~a ≠ ~a" arg1 arg2 k1 k2))) (error (format "keys unequal in ~a and ~a: ~a ≠ ~a" arg1 arg2 k1 k2)))
(unless (equal? v1 v2) (unless (equal? v1 v2)
(define val1 (shorten-val v1)) (error (format "values unequal in ~a and ~a: ~e ≠ ~e" arg1 arg2 v1 v2)))
(define val2 (shorten-val v2))
(error (format "values unequal in ~a and ~a: ~a ≠ ~a" arg1 arg2 val1 val2)))
(when (dict? v1) (when (dict? v1)
(dict-compare v1 v2)) (dict-compare v1 v2))
#true))) #true)))

156
pitfall/pitfall/color.rkt
Unescape Escape View File

@ -6,8 +6,77 @@
racket/class racket/class
racket/match racket/match
racket/string) 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) (define (normalize-color color)
;; parses color string into list of values ;; parses color string into list of values
@ -35,83 +104,25 @@
(if (integer? x) (inexact->exact x) x))] (if (integer? x) (inexact->exact x) x))]
[_ #false])) [_ #false]))
(define (color-mixin [% object%]) #;(define (color-mixin [% object%])
(class % (class %
(super-new) (super-new)
(field [@opacity-registry (make-hash)] (field [@opacity-registry (make-hash)]
[@opacity-count 0] [@opacity-count 0]
[@grad-count 0] [@grad-count 0]
[(@current-fill-color current-fill-color) #false]) [(@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 (define named-colors
(hash "aliceblue" '(240 248 255) (hash "aliceblue" '(240 248 255)
@ -264,7 +275,6 @@
(module+ test (module+ test
(require rackunit) (require rackunit)
(define c (new (color-mixin)))
(check-equal? (normalize-color "#6699Cc") '(0.4 0.6 0.8)) (check-equal? (normalize-color "#6699Cc") '(0.4 0.6 0.8))
(check-false (normalize-color "#88aaCCC")) (check-false (normalize-color "#88aaCCC"))
(check-equal? (normalize-color "#69C") '(0.4 0.6 0.8)) (check-equal? (normalize-color "#69C") '(0.4 0.6 0.8))

12
pitfall/pitfall/document.rkt
Unescape Escape View File

@ -20,16 +20,6 @@
(define (store-ref doc ref) (define (store-ref doc ref)
(set-$doc-refs! doc (cons ref ($doc-refs doc)))) (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)]) (define (make-$doc [options (make-hasheq)])
;; initial values ;; initial values
@ -88,7 +78,7 @@
(current-compress-streams? (hash-ref options 'compress #t)) (current-compress-streams? (hash-ref options 'compress #t))
(current-auto-first-page (hash-ref options 'autoFirstPage #t)) (current-auto-first-page (hash-ref options 'autoFirstPage #t))
(when (current-auto-first-page) (add-page new-doc)) (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) new-doc)

46
pitfall/pitfall/fonts.rkt
Unescape Escape View File

@ -1,10 +1,51 @@
#lang debug racket/base #lang debug racket/base
(require (require
"core.rkt"
racket/class racket/class
racket/match racket/match
sugar/unstable/dict sugar/unstable/dict
"font-open.rkt") "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%]) (define (fonts-mixin [% object%])
(class % (class %
@ -52,8 +93,7 @@
(set! @current-font-size size) (set! @current-font-size size)
this) 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]) (define/public (register-font name src [family #f])
(hash-set! @registered-fonts name (make-hash (list (cons 'src src) (hash-set! @registered-fonts name (make-hash (list (cons 'src src)

47
pitfall/pitfall/images.rkt
Unescape Escape View File

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

5
pitfall/pitfall/page.rkt
Unescape Escape View File

@ -7,6 +7,11 @@
(provide (all-defined-out)) (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) (struct $page (page-parent options size layout dimensions width height content resources margins dictionary)
#:transparent #:mutable) #:transparent #:mutable)

4
pitfall/pitfall/pdftest.rkt
Unescape Escape View File

@ -11,8 +11,8 @@
(test-mode #t) (test-mode #t)
(require rackunit pitfall/document racket/runtime-path 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 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.")) (define (this->control this) (path-add-extension this #"" #" copy."))

258
pitfall/pitfall/text.rkt
Unescape Escape View File

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

370
pitfall/pitfall/vector.rkt
Unescape Escape View File

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

16
pitfall/ptest/test1.rkt
Unescape Escape View File

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

94
pitfall/ptest/test2.rkt
Unescape Escape View File

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

2
pitfall/ptest/test3.rkt
Unescape Escape View File

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

111
pitfall/ptest/test4.rkt
Unescape Escape View File

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

9
pitfall/ptest/test5.rkt
Unescape Escape View File

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

Write Preview
Loading…
Cancel
Save