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.
121 lines
4.1 KiB
Racket
121 lines
4.1 KiB
Racket
#lang racket/base
|
|
(require
|
|
racket/match
|
|
sugar/unstable/dict
|
|
"core.rkt"
|
|
"page.rkt"
|
|
"vector.rkt"
|
|
"png.rkt"
|
|
"jpeg.rkt")
|
|
(provide (all-defined-out))
|
|
|
|
(define (open-pdf-image src label)
|
|
(define data (cond
|
|
[(bytes? src) (open-input-bytes src)]
|
|
[(regexp-match #rx"^data:.+;base64,(.*)$" src) (void)] ;; base64 ; todo
|
|
[else (open-input-file src)]))
|
|
(define img-constructor
|
|
(cond
|
|
[(equal? (peek-bytes 2 0 data) (bytes #xff #xd8)) make-jpeg]
|
|
[(equal? (peek-bytes 4 0 data) (apply bytes (map char->integer '(#\u0089 #\P #\N #\G)))) make-png]
|
|
[else (raise-argument-error 'open-pdf-image "valid image format" src)]))
|
|
(img-constructor data label))
|
|
|
|
(define (image doc src [x-arg #f] [y-arg #f]
|
|
#:x [x-kwarg #f]
|
|
#:y [y-kwarg #f]
|
|
#:width [width #f]
|
|
#:height [height #f]
|
|
#:scale [scale #f]
|
|
#:fit [fit #f]
|
|
#:cover [cover #f]
|
|
#:align [align #f]
|
|
#:valign [valign #f]
|
|
)
|
|
(define x (or x-arg x-kwarg (pdf-x doc)))
|
|
(define y (or y-arg y-kwarg (pdf-y doc)))
|
|
|
|
(define image (cond
|
|
[(and (string? src) (hash-ref (pdf-image-registry doc) src #f))]
|
|
[(and ($img? src) ($img-width src) ($img-height src)) src]
|
|
[else (open-image doc src)]))
|
|
(unless ($img-ref image) (($img-embed-proc image) image))
|
|
|
|
(hash-ref! (page-xobjects (current-page doc)) ($img-label image) ($img-ref image))
|
|
|
|
(define image-width ($img-width image))
|
|
(define image-height ($img-height image))
|
|
(define w (or width image-width))
|
|
(define h (or height image-height))
|
|
(define wp #f)
|
|
(define hp #f)
|
|
(define bp #f)
|
|
(define ip #f)
|
|
(define bw #f)
|
|
(define bh #f)
|
|
|
|
(cond
|
|
[(and width (not height))
|
|
(set! wp (/ w image-width))
|
|
(set! w (* image-width wp))
|
|
(set! h (* image-height wp))]
|
|
[(and height (not width))
|
|
(set! hp (/ h image-width))
|
|
(set! w (* image-width hp))
|
|
(set! h (* image-height hp))]
|
|
[scale
|
|
=> (λ (scale-val)
|
|
(set! w (* image-width scale-val))
|
|
(set! h (* image-height scale-val)))]
|
|
[fit
|
|
=> (λ (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)]))]
|
|
[cover
|
|
=> (λ (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))]))])
|
|
|
|
(when (or fit cover)
|
|
(case align
|
|
[("center") (set! x (+ x (/ bw 2) (- (/ w 2))))]
|
|
[("right") (set! x (+ x bw - w))])
|
|
(case valign
|
|
[("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 (= (pdf-y doc) y) (set! y (+ y h)))
|
|
(save doc)
|
|
(transform doc w 0 0 (- h) x (+ y h))
|
|
(add-content doc (format "/~a Do" ($img-label image)))
|
|
(restore doc)
|
|
doc)
|
|
|
|
(define (open-image doc src)
|
|
(cond
|
|
[(and (string? src) (hash-ref (pdf-image-registry doc) src #f))]
|
|
[else
|
|
(define image-idx (add1 (length (hash-keys (pdf-image-registry doc)))))
|
|
(define image-id (string->symbol (format "I~a" image-idx)))
|
|
(define new-image (open-pdf-image src image-id))
|
|
(when (string? src) (hash-set! (pdf-image-registry doc) src new-image))
|
|
new-image]))
|
|
|