Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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.