From 83b7d0b51ab9193a9b11e22c42a9d9b9bacfb7e3 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sat, 22 Dec 2018 09:16:34 -0800
Subject: [PATCH] methodize vector

---
 pitfall/pitfall/document.rkt |   3 +-
 pitfall/pitfall/path.rkt     |   2 +-
 pitfall/pitfall/vector.rkt   | 378 +++++++++++++----------------------
 3 files changed, 144 insertions(+), 239 deletions(-)

diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt
index 209f4421..092e2319 100644
--- a/pitfall/pitfall/document.rkt
+++ b/pitfall/pitfall/document.rkt
@@ -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)
diff --git a/pitfall/pitfall/path.rkt b/pitfall/pitfall/path.rkt
index e325fc51..5a98c5c6 100644
--- a/pitfall/pitfall/path.rkt
+++ b/pitfall/pitfall/path.rkt
@@ -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)]))))
\ No newline at end of file
diff --git a/pitfall/pitfall/vector.rkt b/pitfall/pitfall/vector.rkt
index cdd4546d..ab8d6360 100644
--- a/pitfall/pitfall/vector.rkt
+++ b/pitfall/pitfall/vector.rkt
@@ -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))
-  )
\ No newline at end of file
+                '(1 0 0 1 50 -50.0)))
\ No newline at end of file