typesetting/pitfall/pitfall/images.rkt

#lang racket/base
(require "racket.rkt")

(require "image.rkt")
(provide image-mixin)

(define (image-mixin [% mixin-tester%])
  (class %
    (super-new)
    (field [_imageRegistry #f]
           [_imageCount #f])

    (as-methods
     initImages
     image
     openImage
     )))

    
(define/contract (initImages 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 this))
  
  (hash-ref! (· this page xobjects) (· image label) (· image obj))
  
  (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)

  (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))])])

  (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
      [(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))]))

  ;; 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))

  (· 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/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]))