diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt index 35e77487..e89e47b3 100644 --- a/pitfall/pitfall/document.rkt +++ b/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)) diff --git a/pitfall/pitfall/images.rkt b/pitfall/pitfall/images.rkt index 19eb2b35..bd48ec8e 100644 --- a/pitfall/pitfall/images.rkt +++ b/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])) \ No newline at end of file