methodize images

pitfall/pitfall/document.rkt

@@ -38,7 +38,6 @@
     (inherit-field @ctm) ; from vector mixin
     (inherit-field @font-families) (inherit font) ; from font mixin
     (inherit-field [@x x] [@y y])
-    (send this init-images)
 
     ;; initialize params
     (current-compress-streams? (hash-ref @options 'compress #t))

pitfall/pitfall/images.rkt

@@ -2,119 +2,102 @@
 (require
   racket/class
   racket/match
-  racket/contract
-  sugar/unstable/class
-  sugar/unstable/js
   sugar/unstable/dict
   "image.rkt")
 (provide image-mixin)
 
-(define (image-mixin [% mixin-tester%])
+(define (image-mixin [% object%])
   (class %
     (super-new)
-    (field [_imageRegistry #f]
-           [_imageCount #f])
+    (field [@image-registry (mhash)]
+           [@image-count 0])
+    (inherit-field [@x x] [@y y])
 
-    (as-methods
-     init-images
-     image
-     openImage
-     )))
+    (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/contract (init-images this)
-  (->m void?)
-  (set-field! _imageRegistry this (mhash))
-  (set-field! _imageCount this 0))
-
-
-(define/contract (image this src [x #f] [y #f] [options mhash])
-  ((any/c) ((or/c number? #f) (or/c number? #f) hash?) . ->*m . object?)
-  (set! x (or x (· options x) (· this x)))
-  (set! y (or y (· options y) (· this y)))
-
-  (define image (cond
-                  [(and (string? src) (hash-ref (· this _imageRegistry) src #f))]
-                  [(and (object? src) (· src width) (· src height)) src]
-                  [else (send this openImage src)]))
-
-  (unless (· image obj) (send image embed))
-  
-  (hash-ref! (· this page xobjects) (· image label) (· image obj))
+      (define image (cond
+                      [(and (string? src) (hash-ref @image-registry src #f))]
+                      [(and (object? src) (get-field width src) (get-field height src)) src]
+                      [else (send this open-image src)]))
+      (unless (get-field obj image) (send image embed))
   
-  (define w (or (hash-ref options 'width #f) (· image width)))
-  (define h (or (hash-ref options 'height #f) (· image height)))
-  (define wp #f)
-  (define hp #f)
-  (define bp #f)
-  (define ip #f)
-  (define bw #f)
-  (define bh #f)
+      (hash-ref! (send (send this page) xobjects) (get-field label image) (get-field obj image))
 
-  (cond
-    [(and (hash-ref options 'width #f) (not (hash-ref options 'height #f)))
-     (set! wp (/ w (· image width)))
-     (set! w (* (· image width) wp))
-     (set! h (* (· image height) wp))]
-    [(and (hash-ref options 'height #f) (not (hash-ref options 'width #f)))
-     (set! hp (/ h (· image width)))
-     (set! w (* (· image width) hp))
-     (set! h (* (· image height) hp))]
-    [(hash-ref options 'scale #f)
-     (set! w (* (· image width) (· options scale)))
-     (set! h (* (· image height) (· options scale)))]
-    [(hash-ref options 'fit #f)
-     (match-define (list bw bh) (· options fit))
-     (set! bp (/ bw bh))
-     (set! ip (/ (· image width) (· image height)))
-     (cond
-       [(> ip bp)
-        (set! w bw)
-        (set! h (/ bw ip))]
-       [else
-        (set! h bh)
-        (set! w (* bh ip))])]
-    [(hash-ref options 'cover #f)
-     (match-define (list bw bh) (· options cover))
-     (set! bp (/ bw bh))
-     (set! ip (/ (· image width) (· image height)))
-     (cond
-       [(> ip bp)
-        (set! h bh)
-        (set! w (* bh ip))]
-       [else
-        (set! w bw)
-        (set! h (/ bw ip))])])
+      (define image-width (get-field width image))
+      (define image-height (get-field height image))
+      (define options-width (hash-ref options 'width #f))
+      (define options-height (hash-ref options 'height #f))
+      (define w (or options-width image-width))
+      (define h (or options-height image-height))
+      (define wp #f)
+      (define hp #f)
+      (define bp #f)
+      (define ip #f)
+      (define bw #f)
+      (define bh #f)
 
-  (when (or (hash-ref options 'fit #f) (hash-ref options 'cover #f))
-    (cond
-      [(equal? (hash-ref options 'align #f) "center")
-       (set! x (+ x (/ bw 2) (- (/ w 2))))]
-      [(equal? (hash-ref options 'align #f) "right")
-       (set! x (+ x bw - w))])
+      (cond
+        [(and options-width (not options-height))
+         (set! wp (/ w image-width))
+         (set! w (* image-width wp))
+         (set! h (* image-height wp))]
+        [(and options-height (not options-width))
+         (set! hp (/ h image-width))
+         (set! w (* image-width hp))
+         (set! h (* image-height hp))]
+        [(hash-ref options 'scale #f)
+         => (λ (scale-val)
+              (set! w (* image-width scale-val))
+              (set! h (* image-height scale-val)))]
+        [(hash-ref options 'fit #f)
+         => (λ (fit-val)
+              (match-define (list bw bh) fit-val)
+              (set! bp (/ bw bh))
+              (set! ip (/ image-width image-height))
+              (cond
+                [(> ip bp)
+                 (set! w bw)
+                 (set! h (/ bw ip))]
+                [else
+                 (set! w (* bh ip))
+                 (set! h bh)]))]
+        [(hash-ref options 'cover #f)
+         => (λ (cover-val)
+              (match-define (list bw bh) cover-val)
+              (set! bp (/ bw bh))
+              (set! ip (/ image-width image-height))
+              (cond
+                [(> ip bp)
+                 (set! w (* bh ip))
+                 (set! h bh)]
+                [else
+                 (set! w bw)
+                 (set! h (/ bw ip))]))])
 
-    (cond
-      [(equal? (hash-ref options 'valign #f) "center")
-       (set! y (+ y (/ bh 2) (- (/ h 2))))]
-      [(equal? (hash-ref options 'valign #f) "bottom")
-       (set! y (+ y bh - h))]))
+      (when (or (hash-ref options 'fit #f) (hash-ref options 'cover #f))
+        (case (hash-ref options 'align #f)
+          [("center") (set! x (+ x (/ bw 2) (- (/ w 2))))]
+          [("right") (set! x (+ x bw - w))])
+        (case (hash-ref options 'valign #f)
+          [("center") (set! y (+ y (/ bh 2) (- (/ h 2))))]
+          [("bottom") (set! y (+ y bh - h))]))
 
-  ;; Set the current y position to below the image if it is in the document flow
-  (when (equal? (· this y) y) (increment-field! y this h))
+      ;; Set the current y position to below the image if it is in the document flow
+      (when (= @y y) (set! y (+ y h)))
+      (send this save)
+      (send this transform w 0 0 (- h) x (+ y h))
+      (send this addContent (format "/~a Do" (get-field label image)))
+      (send this restore)
+      this)
 
-  (· this save)
-  (send this transform w 0 0 (- h) x (+ y h))
-  (send this addContent (format "/~a Do" (· image label)))
-  (· this restore)
-  this
-  #;(error 'stop-in-images:image))
+    (define/public (open-image src)
+      (cond
+        [(and (string? src) (hash-ref @image-registry src #f))]
+        [else
+         (define new-image
+           (PDFImage-open src (format "I~a" (let () (set! @image-count (add1 @image-count)) @image-count))))
+         (when (string? src) (hash-set! @image-registry src new-image))
+         new-image]))))
 
-(define/contract (openImage this src)
-  (any/c . ->m . object?)
-  (cond
-    [(and (string? src) (hash-ref (· this _imageRegistry) src #f))]
-    [else
-     (define new-image
-       (PDFImage-open src (format "I~a" (increment-field! _imageCount this))))
-     (when (string? src) (hash-set! (· this _imageRegistry) src new-image))
-     new-image]))