Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

144 lines (112 sloc) 4.789 kb
#lang scheme/base
(require scheme/class
scheme/gui/base
scheme/list
scheme/port
mrlib/cache-image-snip
scheme/contract
"utils.ss"
"resource.ss"
"collects/moby/runtime/stx.ss")
(define-struct named-bitmap (name bitmap))
;; Image lifting
(provide/contract [struct named-bitmap [(name string?)
(bitmap (is-a?/c bitmap%))]]
[named-bitmap->resource (named-bitmap? . -> . (is-a?/c resource<%>))]
[named-bitmap-save (named-bitmap? path-string? . -> . any)]
[lift-images! ((is-a?/c text%)
. -> . (listof named-bitmap?))]
[lift-images/stx (stx? . -> . (values stx? (listof named-bitmap?)))]
[lift-images/stxs ((listof stx?) . -> . (values (listof stx?) (listof named-bitmap?)))])
(define named-bitmap-resource%
(class* object% (resource<%>)
(init-field named-bitmap)
(super-new)
(define/public (save! a-path)
(named-bitmap-save named-bitmap a-path))
(define/public (get-name)
(named-bitmap-name named-bitmap))
(define/public (get-bytes)
(with-temporary-directory
(lambda (a-dir)
(save! a-dir)
(call-with-input-file (build-path a-dir (get-name))
(lambda (ip)
(port->bytes ip))))))))
;; Turns a named bitmap into a resource.
(define (named-bitmap->resource a-named-bitmap)
(new named-bitmap-resource% [named-bitmap a-named-bitmap]))
;; lift-images!: text -> (listof named-bitmap)
;; Lifts up the image snips in the text.
;; The snips in the text will be replaced with the expression (open-image-url <path>)
;; where path refers to the file name of the named bitmap.
;; Mutates the text, and produces a list of bitmap objects that should be saved.
(define (lift-images! a-text)
(let loop ([a-snip (send a-text find-first-snip)])
(cond
[(not a-snip)
empty]
[(image-snip? a-snip)
(let* ([file-name (make-image-name)]
[bitmap (send a-snip get-bitmap)]
[replacement-snip (make-object string-snip%
(format "(open-image-url ~s)"
file-name))])
(send a-text set-position
(send a-text get-snip-position a-snip)
(+ (send a-text get-snip-position a-snip)
(send a-snip get-count)))
(send a-text insert replacement-snip)
(cons (make-named-bitmap file-name bitmap)
(loop (send replacement-snip next))))]
[else
(loop (send a-snip next))])))
;; lift-images/stx: stx -> (values stx (listof named-bitmap))
;; Lift out the image snips in an stx.
(define (lift-images/stx a-stx)
(cond
[(stx:list? a-stx)
(let-values ([(lifted-elts named-bitmaps)
(lift-images/stxs (stx-e a-stx))])
(values (datum->stx #f lifted-elts (stx-loc a-stx))
named-bitmaps))]
[(stx:atom? a-stx)
(cond [(image-snip? (stx-e a-stx))
(let* ([filename (make-image-name)]
[bitmap (send (stx-e a-stx) get-bitmap)]
[replacement-stx (datum->stx #f `(open-image-url ,filename)
(stx-loc a-stx))])
(values replacement-stx (list (make-named-bitmap filename bitmap))))]
[else
(values a-stx empty)])]))
;; lift-images/stxs: (listof stx) -> (values (listof stx) (listof named-bitmap))
(define (lift-images/stxs stxs)
(cond
[(empty? stxs)
(values empty empty)]
[else
(let-values ([(lifted-stx named-bitmaps)
(lift-images/stx (first stxs))]
[(rest-lifted-stxs rest-named-bitmaps)
(lift-images/stxs (rest stxs))])
(values (cons lifted-stx rest-lifted-stxs)
(append named-bitmaps rest-named-bitmaps)))]))
;; named-bitmap-save: named-bitmap path-string -> void
;; Saves the named bitmap under the given directory.
(define (named-bitmap-save a-named-bitmap a-dir)
(let ([a-path
(build-path a-dir (named-bitmap-name a-named-bitmap))])
(send (named-bitmap-bitmap a-named-bitmap) save-file (path->string a-path)
'png)))
;; make-image-name: -> string
;; Makes a new image name.
(define make-image-name
(let ([i 0])
(lambda ()
(begin0 (string-append "image-" (number->string i) ".png")
(set! i (add1 i))))))
;; image-snip?: snip -> boolean
;; Returns true if this looks like an image snip.
(define (image-snip? a-snip)
(or (is-a? a-snip image-snip%)
(is-a? a-snip cache-image-snip%)))
Jump to Line
Something went wrong with that request. Please try again.