You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/pitfall/pitfall/images.rkt

113 lines
3.4 KiB
Racket

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

#lang pitfall/racket
(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]))