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

methodize vector

Browse Source
main
Matthew Butterick 5 years ago
parent 30693ca0b9
commit 83b7d0b51a
3 changed files with 144 additions and 239 deletions
Show Stats Download Patch File Download Diff File

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

@ -37,8 +37,7 @@
'CreationDate (seconds->date (if (test-mode) 0 (current-seconds)) #f))])
;; initialize mixins
(send this initVector)
(inherit-field @ctm)
(inherit-field @ctm) ; from vector
(send this initFonts)
(inherit-field @font-families)
(send this initText)

2
pitfall/pitfall/path.rkt
Unescape Escape View File

@ -81,6 +81,6 @@
(list (- cx (- px cx) (- cy (- py cy))))))
(send doc quadratic-curve-to . cmd-args)]
;; todo other path ops
[(z) (send doc closePath . cmd-args)
[(z) (send doc close-path . cmd-args)
(values sx sy px py sx sy)]
[else (raise-argument-error 'apply-commands "valid command name" cmd-name)]))))

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

@ -18,199 +18,149 @@
(super-new)
(field [@ctm default-ctm-value]
[@ctm-stack null])
(as-methods
initVector
save
restore
closePath
line-cap
line-join
line-width
dash
move-to
line-to
bezier-curve-to
quadratic-curve-to
rect
ellipse
circle
polygon
path
_windingRule
fill
stroke
fill-and-stroke
clip
shear
transform
translate
scale)))
(define/contract (initVector this)
(->m void?)
(set-field! @ctm this default-ctm-value)
(set-field! @ctm-stack this null))
(define/contract (save this)
(->m object?)
(push-field! @ctm-stack this (· this @ctm))
(send this addContent "q"))
(define/contract (restore this)
(->m object?)
(set-field! @ctm this (if (pair? (· this @ctm-stack))
(pop-field! @ctm-stack this)
default-ctm-value))
(send this addContent "Q"))
(define/contract (closePath this)
(->m object?)
(send this addContent "h"))
(define/contract (line-cap this [c #f])
((or/c 'butt 'round 'square #f) . ->m . object?)
(define cap-styles (hasheq 'butt 0 'round 1 'square 2))
(send this addContent
(format "~a J" (if (symbol? c)
(hash-ref cap-styles c)
""))))
(define/contract (line-join this [j #f])
((or/c 'miter 'round 'bevel #f) . ->m . object?)
(define cap-styles (hasheq 'miter 0 'round 1 'bevel 2))
(send this addContent
(format "~a j" (if (symbol? j)
(hash-ref cap-styles j)
""))))
(define/contract (line-width this w)
(number? . ->m . object?)
(send this addContent (format "~a w" (number w))))
(define/contract (dash this length [options (mhash)])
(((or/c number? (listof number?) #f)) (hash?) . ->*m . object?)
(cond
[length
(cond
[(list? length)
(send this addContent
(format "[~a] ~a d"
(string-join (map number length) " ")
(hash-ref options 'phase 0)))]
[else
(define space (hash-ref options 'space length))
(define phase (hash-ref options 'phase 0))
(send this addContent (format "[~a ~a] ~a d" (number length) (number space) (number phase)))])]
[else this]))
(define/contract (move-to this x y)
(number? number? . ->m . object?)
(send this addContent (format "~a ~a m" x y)))
(define/contract (line-to this x y)
(number? number? . ->m . object?)
(send this addContent (format "~a ~a l" x y)))
(define/contract (bezier-curve-to this cp1x cp1y cp2x cp2y x y)
(number? number? number? number? number? number? . ->m . object?)
(send this addContent (format "~a c" (string-join (map number (list cp1x cp1y cp2x cp2y x y)) " "))))
(define/contract (quadratic-curve-to this cpx cpy x y)
(number? number? number? number . ->m . object?)
(send this addContent (format "~a v" (string-join (map number (list cpx cpy x y)) " "))))
(define/public (save)
(set! @ctm-stack (cons @ctm @ctm-stack))
(send this addContent "q"))
(define/public (restore)
(set! @ctm (if (pair? @ctm-stack)
(begin0
(car @ctm-stack)
(set! @ctm-stack (cdr @ctm-stack)))
default-ctm-value))
(send this addContent "Q"))
(define/public (close-path)
(send this addContent "h"))
(define/public (line-cap [c #f])
(define cap-styles (hasheq 'butt 0 'round 1 'square 2))
(send this addContent
(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))
(send this addContent
(format "~a j" (if (symbol? j)
(hash-ref cap-styles j)
""))))
(define/public (line-width w)
(send this addContent (format "~a w" (number w))))
(define/public (dash length [options (mhash)])
(cond
[(list? length)
(send this addContent
(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))
(send this addContent (format "[~a ~a] ~a d" (number length) (number space) (number phase)))]
[else this]))
(define/public (move-to x y)
(send this addContent (format "~a ~a m" x y)))
(define/public (line-to x y)
(send this addContent (format "~a ~a l" x y)))
(define/public (bezier-curve-to cp1x cp1y cp2x cp2y x y)
(send this addContent (format "~a c" (string-join (map number (list cp1x cp1y cp2x cp2y x y)) " "))))
(define/public (quadratic-curve-to cpx cpy x y)
(send this addContent (format "~a v" (string-join (map number (list cpx cpy x y)) " "))))
(define/contract (rect this x y w h)
(number? number? number? number? . ->m . object?)
(send this addContent (format "~a re" (string-join (map number (list x y w h)) " "))))
(define/contract (ellipse this x y r1 [r2 r1])
((number? number? number?) (number?) . ->*m . object?)
;; 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 this x ym)
(bezier-curve-to this x (- ym oy) (- xm ox) y xm y)
(bezier-curve-to this (+ xm ox) y xe (- ym oy) xe ym)
(bezier-curve-to this xe (+ ym oy) (+ xm ox) ye xm ye)
(bezier-curve-to this (- xm ox) ye x (+ ym oy) x ym)
(closePath this))
(define/contract (circle this x y radius)
(number? number? number? . ->m . object?)
(ellipse this x y radius))
(define/contract (polygon this . points)
(() () #:rest (listof (list/c number? number?)) . ->*m . object?)
(cond
[(pair? points)
(apply move-to this (car points))
(for ([pt (in-list (cdr points))])
(apply line-to this pt))
(closePath this)]
[else this]))
(define/contract (path this path-data)
(string? . ->m . object?)
(parse-svg-path this path-data)
this)
(define/contract (_windingRule rule)
((or/c string? #f) . -> . string?)
(if (and (string? rule) (regexp-match #rx"^even-?odd$" rule)) "*" ""))
(define/contract (fill this [color #f] #:rule [rule #f])
(() ((or/c color-string? #f) #:rule (or/c string? #f)) . ->*m . object?)
(when color (send this fill-color color)) ;; fill-color method is from color mixin
(send this addContent (format "f~a" (_windingRule rule))))
(define/contract (stroke this [color #f])
(() ((or/c color-string? #f)) . ->*m . object?)
(when color (send this stroke-color color))
(send this addContent "S"))
(define/contract (fill-and-stroke this [fill #f] [stroke fill] #:rule [rule #f])
(() ((or/c color-string? #f) (or/c color-string? #f) #:rule (or/c string? #f)) . ->*m . object?)
(when fill (send* this [fill-color fill] [stroke-color stroke]))
(send this addContent (format "B~a" (_windingRule rule))))
(define tm/c (list/c number? number? number? number? number? number?))
(define/contract (make-transform-string ctm)
(tm/c . -> . string?)
(format "~a cm" (string-join (map number ctm) " ")))
(define/contract (combine-transforms m new-ctm)
(tm/c tm/c . -> . tm/c)
(define/public (rect x y w h)
(send this addContent (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 (send this fill-color color)) ;; fill-color method is from color mixin
(send this addContent (format "f~a" (_windingRule rule))))
(define/public (stroke [color #f])
(when color (send this stroke-color color))
(send this addContent "S"))
(define/public (fill-and-stroke [fill #f] [stroke fill] #:rule [rule #f])
(when fill (send* this [fill-color fill] [stroke-color stroke]))
(send this addContent (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])
(send this addContent (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))
(send this addContent (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)
(match-define (list m0 m1 m2 m3 m4 m5) m)
(match-define (list m11 m12 m21 m22 dx dy) new-ctm)
(list (+ (* m0 m11) (* m2 m12))
@ -220,47 +170,6 @@
(+ (* m0 dx) (* m2 dy) m4)
(+ (* m1 dx) (* m3 dy) m5)))
(define/contract (clip this [rule #f])
(() ((or/c string? #f)) . ->*m . object?)
(send this addContent (string-append "W" (_windingRule rule) " n")))
(define/contract (transform this scaleX shearY shearX scaleY mdx mdy)
(number? number? number? number? number? number? . ->m . object?)
(define new-ctm (list scaleX shearY shearX scaleY mdx mdy))
(set-field! @ctm this (combine-transforms (· this @ctm) new-ctm))
(send this addContent (make-transform-string new-ctm)))
(define/contract (shear this x y)
(number? number? . ->m . object?)
(transform this 1 y x 1 0 0))
(define/contract (translate this x y)
(number? number? . ->m . object?)
(transform this 1 0 0 1 x y))
(define/contract scale
(case->m
(number? . -> . object?)
(number? hash? . -> . object?)
(number? number? . -> . object?)
(number? number? hash? . -> . object?))
(match-lambda*
[(list (? object? this) (? number? xFactor)) (scale xFactor (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 this xFactor 0 0 yFactor x y)]))
(module+ test
(require rackunit)
(define ctm default-ctm-value)
@ -271,10 +180,7 @@
(check-equal? ctm '(7 10 15 22 28 40))
(set! ctm (combine-transforms ctm ctm2))
(check-equal? ctm '(37 54 81 118 153 222))
(check-equal? (combine-transforms '(1 0 0 -1 0 792.0) '(1 0 0 1 50 50))
'(1 0 0 -1 50 742.0))
(check-equal? (combine-transforms '(1 0 0 -1 50 742.0) '(1 0 0 -1 0 792))
'(1 0 0 1 50 -50.0))
)
'(1 0 0 1 50 -50.0)))
Write Preview
Loading…
Cancel
Save