refactory

pitfall/pitfall/color.rkt

@@ -1,117 +1,130 @@
 #lang pitfall/racket
 (provide color-mixin)
 
-(define (color-mixin %)
+(define (color-mixin [% mixin-tester%])
   (class %
     (super-new)
-    (field [(@_opacityRegistry _opacityRegistry) #f]
-           [(@_opacityCount _opacityCount) #f]
-           [(@_gradCount _gradCount) #f])
+    (field [_opacityRegistry #f]
+           [_opacityCount #f]
+           [_gradCount #f]
+           [_fillColor #f])
+
+    (as-methods
+     initColor
+     _normalizeColor
+     _setColor
+     _setColorSpace
+     fillColor
+     fillOpacity
+     _doOpacity)))
+
     
-    (define/public (initColor)
-      (set! @_opacityRegistry (mhash))
-      (set! @_opacityCount 0)
-      (set! @_gradCount 0))
+(define/contract (initColor this)
+  (->m void?)
+  (set-field! _opacityRegistry this (mhash))
+  (set-field! _opacityCount this 0)
+  (set-field! _gradCount this 0))
 
-    ;; parses color string into list of values
-    (public [@_normalizeColor _normalizeColor])
-    (define (@_normalizeColor color)
-      (cond
-        #;[(is-a? color PDFGradient) color]  ; todo
-        ;; 3-digit hex becomes 6-digit hex
-        [(and (string? color)
-              (regexp-match #px"^#(?i:[0-9A-F]){3}$" color))
-         (@_normalizeColor
-          (list->string (cdr (apply append
-                                    (for/list ([c (in-string color)])
-                                              (list c c))))))]
-        ;; 6-digit hexish string becomes list of hex numbers and maybe #f vals
-        [(and (string? color) (= 7 (string-length color)) (string-prefix? color "#"))
-         (@_normalizeColor
-          (for/list ([str (in-list (regexp-match* #rx".." (string-trim color "#")))])
-                    (string->number str 16)))]
-        ;; named color
-        [(and (string? color) (hash-ref namedColors color #f)) => @_normalizeColor]
-        ;; array of numbers
-        [(and (list? color) (andmap number? color))
-         (for/list ([i (in-list color)])
-                   (define x (/ i (case (length color)
-                                    [(3) 255.0] ; RGB
-                                    [(4) 100.0] ; CMYK
-                                    [else 1])))
-                   (if (integer? x) (inexact->exact x) x))]
-        [else #f]))
 
-    (public [@_setColor _setColor])
-    (define (@_setColor color stroke)
-      (set! color (@_normalizeColor color))
-      (define op (if stroke "SCN" "scn"))
-      (cond
-        [(not color)]
-        #;[(is-a? color PDFGradient)
-           (@_setColorSpace "Pattern" stroke)
-           (send color apply op)
-           #t] ; todo
-        [else
-         (define space (if (= (length color) 4)
-                           "DeviceCMYK"
-                           "DeviceRGB"))
-         (@_setColorSpace space stroke)
-         (set! color (string-join (map number color) " "))
-         (send this addContent (format "~a ~a" color op))
-         #t]))
+(define/contract (_normalizeColor this color)
+  ((or/c string? (listof number?)) . ->m . (or/c (listof number?) #f))
+  ;; parses color string into list of values
+  (cond
+    #;[(is-a? color PDFGradient) color]  ; todo
+    ;; 3-digit hex becomes 6-digit hex
+    [(and (string? color)
+          (regexp-match #px"^#(?i:[0-9A-F]){3}$" color))
+     (_normalizeColor this
+                      (list->string (cdr (apply append
+                                                (for/list ([c (in-string color)])
+                                                  (list c c))))))] ; change #abc to ##aabbcc then drop the first char
+    ;; 6-digit hexish string becomes list of hex numbers and maybe #f vals
+    [(and (string? color) (= 7 (string-length color)) (string-prefix? color "#"))
+     (_normalizeColor this
+                      (for/list ([str (in-list (regexp-match* #rx".." (string-trim color "#")))])
+                        (string->number str 16)))] ; match two at a time and convert to hex
+    ;; named color
+    [(and (string? color) (hash-ref namedColors color #f)) => (curry _normalizeColor this)]
+    ;; array of numbers
+    [(and (list? color) (andmap number? color))
+     (for/list ([i (in-list color)])
+       (define x (/ i (case (length color)
+                        [(3) 255.0] ; RGB
+                        [(4) 100.0] ; CMYK
+                        [else 1.0])))
+       (if (integer? x) (inexact->exact x) x))]
+    [else #f]))
 
-    
-    (public [@_setColorSpace _setColorSpace])
-    (define (@_setColorSpace space stroke)
-      (define op (if stroke "CS" "cs"))
-      (send this addContent (format "/~a ~a" space op)))
+
+(define/contract (_setColor this color stroke)
+  (color-string? (or/c #f number?) . ->m . boolean?)
+  (let ([color (_normalizeColor this color)]
+        [op (if stroke "SCN" "scn")])
+    (cond
+      [(not color)]
+      #;[(is-a? color PDFGradient)
+         (_setColorSpace this "Pattern" stroke)
+         (send color apply op)
+         #t] ; todo
+      [else
+       (define color-space (cond
+                             [(= (length color) 4) "DeviceCMYK"]
+                             [(= (length color) 3) "DeviceRGB"]
+                             [else (raise-argument-error '_setColor "color of length 3 or 4" color)]))
+       (_setColorSpace this color-space stroke)
+       (send this addContent (format "~a ~a" (string-join (map number color) " ") op))
+       #t])))
 
     
-    (field ([@_fillColor _fillColor] #f))
-    (public [@fillColor fillColor])
-    (define (@fillColor color [opacity 1])
-      (when (@_setColor color #f)
-        (@fillOpacity opacity))
+(define (_setColorSpace this space stroke)
+  ((or/c "DeviceCMYK" "DeviceRGB") (or/c number? #f) . ->m . object?)
+  (define op (if stroke "CS" "cs"))
+  (send this addContent (format "/~a ~a" space op)))
+
+
+(define/contract (fillColor this color [opacity 1])
+  ((color-string?) ((or/c number? #f)) . ->*m . object?)
+  (unless (_normalizeColor this color)
+    (raise-argument-error 'fillColor "valid color string" color))
+  (when (_setColor this color #f) (fillOpacity this opacity))
 
-      ;; save this for text wrapper, which needs to reset
-      ;; the fill color on new pages
-      (set! @_fillColor (list color opacity))
-      this)
+  ;; save this for text wrapper, which needs to reset
+  ;; the fill color on new pages
+  (set-field! _fillColor this (list color opacity))
+  this)
 
 
-    (public [@fillOpacity fillOpacity])
-    (define (@fillOpacity opacity)
-      (@_doOpacity opacity #f)
-      this)
+(define/contract (fillOpacity this opacity)
+  ((or/c number? #f) . ->m . object?)
+  (_doOpacity this opacity #f)
+  this)
 
 
-    (public [@_doOpacity doOpacity])
-    (define (@_doOpacity fillOpacity strokeOpacity)
-      (when (or fillOpacity strokeOpacity)
-        (set! fillOpacity (and fillOpacity (bounded 0 fillOpacity 1)))
-        (set! strokeOpacity (and strokeOpacity (bounded 0 strokeOpacity 1)))
+(define/contract (_doOpacity this fillOpacity strokeOpacity)
+  ((or/c number? #f) (or/c number? #f) . ->m . object?)
+  (when (or fillOpacity strokeOpacity)
+    (set! fillOpacity (and fillOpacity (bounded 0 fillOpacity 1)))
+    (set! strokeOpacity (and strokeOpacity (bounded 0 strokeOpacity 1)))
 
-        (define key (format "~a_~a"
-                            (if fillOpacity (number fillOpacity) "")
-                            (if strokeOpacity (number strokeOpacity) "")))
+    (define key (format "~a_~a"
+                        (if fillOpacity (number fillOpacity) "")
+                        (if strokeOpacity (number strokeOpacity) "")))
         
-        (match-define (list dictionary name)
-          (hash-ref! @_opacityRegistry key
-                     (λ ()
-                       (define dictionary (mhash 'Type "ExtGState"))
-                       (when fillOpacity
-                         (hash-set! dictionary 'ca fillOpacity))
-                       (when strokeOpacity
-                         (hash-set! dictionary 'CA strokeOpacity))
-                       (define dict-ref (send this ref dictionary))
-                       (· dict-ref end)
-                       (list dict-ref (format "Gs~a" (++ @_opacityCount))))))
+    (match-define (list dictionary name)
+      (hash-ref! (get-field _opacityRegistry this) key
+                 (λ ()
+                   (define dictionary (mhash 'Type "ExtGState"))
+                   (when fillOpacity
+                     (hash-set! dictionary 'ca fillOpacity))
+                   (when strokeOpacity
+                     (hash-set! dictionary 'CA strokeOpacity))
+                   (define dict-ref (send this ref dictionary))
+                   (· dict-ref end)
+                   (list dict-ref (format "Gs~a" (increment-field! _opacityCount this))))))
 
-        (hash-set! (· this page ext_gstates) name dictionary)        
-        (send this addContent (format "/~a gs" name))))
+    (hash-set! (· this page ext_gstates) name dictionary)        
+    (send this addContent (format "/~a gs" name))))
 
-    ))
 
 (define namedColors
   (hash "aliceblue" '(240 248 255)
@@ -263,13 +276,13 @@
         "yellowgreen" '(154 205 50)))
 
 
-(define c (new (color-mixin object%)))
 
 (module+ test
   (require rackunit)
-  (check-equal? (send c _normalizeColor "#6699Cc") '(0.4 0.6 0.8))
-  (check-false (send c _normalizeColor "#88aaCCC"))
-  (check-equal? (send c _normalizeColor "#69C") '(0.4 0.6 0.8))
-  (check-equal? (send c _normalizeColor "#69c") '(0.4 0.6 0.8))
-  (check-false (send c _normalizeColor "#8aCC"))
-  (check-equal? (send c _normalizeColor "aqua") '(0 1 1)))
+  (define c (new (color-mixin)))
+  (check-equal? (_normalizeColor c "#6699Cc") '(0.4 0.6 0.8))
+  (check-false (_normalizeColor c "#88aaCCC"))
+  (check-equal? (_normalizeColor c "#69C") '(0.4 0.6 0.8))
+  (check-equal? (_normalizeColor c "#69c") '(0.4 0.6 0.8))
+  (check-false (_normalizeColor c "#8aCC"))
+  (check-equal? (_normalizeColor c "aqua") '(0 1 1)))

pitfall/pitfall/helper.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(require (for-syntax racket/base racket/syntax) racket/class sugar/list racket/list (only-in br/list push! pop!))
+(require (for-syntax racket/base racket/syntax) racket/class sugar/list racket/list (only-in br/list push! pop!) racket/string)
 (provide (all-defined-out) push! pop!)
 
 (define-syntax (· stx)
@@ -61,9 +61,20 @@
 (define-syntax-rule (push-end! id thing) (set! id (append id (list thing))))
 
 (define-syntax-rule (push-field! field o expr) (set-field! field o (cons expr (get-field field o))))
+
+(define-syntax-rule (push-end-field! field o expr)
+  (set-field! field o (append (get-field field o) (list expr))))
+
 (define-syntax-rule (pop-field! field o) (let ([xs (get-field field o)])
                                            (set-field! field o (cdr xs))
                                            (car xs)))
+(define-syntax (increment-field! stx)
+  (syntax-case stx ()
+    [(_ field o)  #'(increment-field! field o 1)]
+    [(_ field o expr)
+     #'(begin (set-field! field o (+ (get-field field o) expr)) (get-field field o))]))
+
+
 
 (module+ test
   (define xs '(1 2 3))
@@ -135,4 +146,7 @@
                   (define (private-id . args) (apply id this args))))]))
 
 (define-syntax-rule (as-methods id ...)
-  (begin (as-method id) ...))
+  (begin (as-method id) ...))
+
+(define (color-string? x)
+  (and (string? x) (or (= (string-length x) 4) (= (string-length x) 7)) (string-prefix? x "#")))

pitfall/pitfall/racket.rkt

@@ -13,10 +13,11 @@
      racket/format
      racket/contract
      racket/list
-     racket/port)
+     racket/port
+     racket/function)
 
 (module reader syntax/module-reader
   #:language "racket.rkt"
-  #:read @-read
-  #:read-syntax @-read-syntax
+  #:read read
+  #:read-syntax read-syntax
   (require (prefix-in @- scribble/reader)))

pitfall/pitfall/reference.rkt

@@ -5,64 +5,72 @@
 (define PDFReference
   (class object%
     (super-new)
-    (init-field [(@document document)] [(@id id)] [(@data data) (mhash)])
-    (field [(@gen gen) 0])
-    (field [(@deflate deflate) #f])
-    (field [(@compress compress) #f #;debug
-                                 #;(and (· @document compress)
-                                        (not (hash-ref @data 'Filter #f)))])
-    (field [(@uncompressedLength uncompressedLength) 0])
-    (field [(@chunks chunks) empty])
+    (init-field document id [data (mhash)])
+    (field [gen 0]
+           [deflate #f]
+           ;; #f is debug value below
+           [compress (and #f
+                          (· document compress)
+                          (not (hash-ref data 'Filter #f)))]
+           [uncompressedLength 0]
+           [chunks empty]
+           [offset #f])
 
-    (public [@initDeflate initDeflate])
-    (define (@initDeflate)
-      (hash-ref! @data 'Filter "FlateDecode")
+    (as-methods
+     initDeflate
+     write
+     _write
+     end
+     finalize
+     toString)))
 
-      (set! @deflate deflate)
-      (report 'initDeflate-unimplemented))
+(define/contract (initDeflate this)
+  (->m void?)
+  (hash-ref! (· this data) 'Filter "FlateDecode"))
 
-    (define/public (write data)
-      (_write data #f void))
-    
-    (define/public (_write chunk-in encoding callback)
-      (define chunk (if (isBuffer? chunk-in)
-                        chunk-in
-                        (newBuffer (string-append chunk-in "\n"))))
-      (+= @uncompressedLength (buffer-length chunk))
-      (hash-ref! @data 'Length 0)
-      (cond
-        [@compress (when (not @deflate) (@initDeflate))
-                   (send @deflate write chunk)]
-        [else (push-end! @chunks chunk)
-              (hash-update! @data 'Length (λ (len) (+ len (buffer-length chunk))))])
-      (callback))
+(define/contract (write this data)
+  (any/c . ->m . void?)
+  (send this _write data #f void))
 
-    (define/public (end [chunk #f])
-      ; (super) ; todo
-      (if @deflate
-          (void) ; todo (deflate-end)
-          (@finalize)))
+(define/contract (_write this chunk-in encoding callback)
+  (any/c (or/c string? #f) procedure? . ->m . any/c)
+  (define chunk (if (isBuffer? chunk-in)
+                    chunk-in
+                    (newBuffer (string-append chunk-in "\n"))))
+  (increment-field! uncompressedLength this (buffer-length chunk))
+  (hash-ref! (· this data) 'Length 0)
+  (cond
+    #;[(· this compress) (when (not (· this deflate)) (initDeflate))
+                         (send deflater write chunk)] ; todo: implement compression
+    [else (push-end-field! chunks this chunk)
+          (hash-update! (· this data) 'Length (λ (len) (+ len (buffer-length chunk))))])
+  (callback))
 
-    (field [(@offset offset) #f])
-    (public [@finalize finalize])
-    (define (@finalize)
-      (set! @offset (· @document _offset))
-      
-      (send @document _write (format "~a ~a obj" @id @gen))
-      (send @document _write (send (new PDFObject) convert @data))
+(define/contract (end this [chunk #f])
+  (() ((or/c any/c #f)) . ->*m . void?)
+  ; (super) ; todo
+  (if (· this deflate)
+      (void) ; todo (deflate-end)
+      (send this finalize)))
 
-      (when (positive? (length @chunks))
-          (send @document _write "stream")
-          (for ([chunk (in-list @chunks)])
-               (send @document _write chunk))
+(define/contract (finalize this)
+  (->m void?)
+  (set-field! offset this (· this document _offset))
+      
+  (send (· this document) _write (format "~a ~a obj" (· this id) (· this gen)))
+  (send (· this document) _write (send (new PDFObject) convert (· this data)))
 
-        (set! @chunks null) ; free up memory
-        (send @document _write "\nendstream"))
+  (when (positive? (length (· this chunks)))
+    (send (· this document) _write "stream")
+    (for ([chunk (in-list (· this chunks))])
+      (send (· this document) _write chunk))
 
-      (send @document _write "endobj")
-      (send @document _refEnd this))
+    (set-field! chunks this null) ; free up memory
+    (send (· this document) _write "\nendstream"))
 
-    (define/public (toString)
-      (format "~a ~a R" @id @gen)) 
+  (send (· this document) _write "endobj")
+  (send (· this document) _refEnd this))
 
-    ))
+(define/contract (toString this)
+  (->m string?)
+  (format "~a ~a R" (· this id) (· this gen)))

pitfall/pitfall/test/test1.rkt

@@ -9,19 +9,18 @@
 ;; Create a new PDFDocument
 (test-mode #t)
 (check-true
- (let ()
-   (define doc (new PDFDocument))
+ (let ([doc (new PDFDocument)])
    (send doc pipe (open-output-file this #:exists 'replace))
-
    ;; Draw a triangle and a circle
-   (send*/fold doc [save]
-               [moveTo 100 150]
-               [lineTo 100 250]
-               [lineTo 200 250]
-               [fill "#FF3300"])
-
-   (send*/fold doc [circle 280 200 50] [fill "#6600FF"])
-
+   (send* doc
+     [save]
+     [moveTo 100 150]
+     [lineTo 100 250]
+     [lineTo 200 250]
+     [fill "#FF3300"])
+   (send* doc
+     [circle 280 200 50]
+     [fill "#6600FF"])
    (send doc end)))
 
 (check-equal? (file->bytes this) (file->bytes control))

pitfall/pitfall/vector.rkt

@@ -89,7 +89,7 @@
   (if (and (string? rule) (regexp-match #rx"^even-?odd$" rule)) "*" ""))
 
 (define/contract (fill this color [rule #f])
-  ((string?) ((or/c string? #f)) . ->*m . object?)
+  ((color-string?) ((or/c string? #f)) . ->*m . object?)
   (when (regexp-match #rx"^(even-?odd)|(non-?zero)$" color)
     (set! rule color)
     (set! color #f))