a bunch of little fixes to the 2htdp/image library (and related) for sfp submission:

- added in the htdp/image version of the performance test case
- made gui-eval work with things other than slideshow
- extended render-image so that it works on bitmaps and image-snips

original commit: 22bc8f6d87f12efa6b720249a194db5dd555056e
This commit is contained in:
Robby Findler 2010-06-16 11:35:40 -05:00
parent 0a3de1887b
commit 8e14e0dae6

View File

@ -8,21 +8,40 @@
racket/runtime-path
racket/serialize
"private/gui-eval-exn.ss"
racket/system)
racket/system
(for-syntax racket/base))
(define-syntax define-mr
(syntax-rules ()
[(_ mr orig)
(begin
(provide mr)
(define-syntax mr
(syntax-rules ()
(define-syntax (mr stx)
(syntax-case stx ()
[(_ #:eval+opts the-eval get-predicate? get-render get-get-width get-get-height x (... ...))
#'(let ([the-eval-x the-eval])
(parameterize ([scribble-eval-handler (gui-eval-handler the-eval-x
get-predicate?
get-render
get-get-width
get-get-height)])
(orig #:eval the-eval-x x (... ...))))]
[(_ x (... ...))
(parameterize ([scribble-eval-handler gui-eval-handler])
(orig #:eval gui-eval x (... ...)))])))]))
#'(parameterize ([scribble-eval-handler (gui-eval-handler gui-eval
(λ () (gui-eval 'pict?))
(λ () (gui-eval 'draw-pict))
(λ () (gui-eval 'pict-width))
(λ () (gui-eval 'pict-height)))])
(orig #:eval gui-eval x (... ...)))])))]))
(define gui-eval (make-base-eval))
(define mred? (getenv "MREVAL"))
(when mred?
(gui-eval '(require racket/gui/base))
(gui-eval '(require slideshow)))
(define-mr gui-interaction interaction)
(define-mr gui-interaction-eval interaction-eval)
(define-mr gui-interaction-eval-show interaction-eval-show)
@ -34,12 +53,6 @@
(provide (rename-out [gui-racketmod+eval gui-schememod+eval]
[gui-racketblock+eval gui-schemeblock+eval]))
(define mred? (getenv "MREVAL"))
(when mred?
(gui-eval '(require racket/gui/base))
(gui-eval '(require slideshow)))
;; This one needs to be relative, because it ends up in the
;; exprs.dat file:
(define img-dir "images") ; relative to src dir
@ -52,16 +65,20 @@
(if mred?
(let ([eh (scribble-eval-handler)]
[log-file (open-output-file exprs-dat-file #:exists 'truncate/replace)])
(lambda (ev catching-exns? expr)
(write (serialize (if (syntax? expr) (syntax->datum expr) expr)) log-file)
(newline log-file)
(flush-output log-file)
(let ([result
(with-handlers ([exn:fail?
(lambda (exn)
(make-gui-exn (exn-message exn)))])
(eh ev catching-exns? expr))])
(let ([result (fixup-picts result)])
(λ (gui-eval get-predicate? get-render get-get-width get-get-height)
(lambda (ev catching-exns? expr)
(write (serialize (if (syntax? expr) (syntax->datum expr) expr)) log-file)
(newline log-file)
(flush-output log-file)
(let ([result
(with-handlers ([exn:fail?
(lambda (exn)
(make-gui-exn (exn-message exn)))])
;; put the call to fixup-picts in the handlers
;; so that errors in the user-supplied predicates &
;; conversion functions show up in the rendered output
(fixup-picts (get-predicate?) (get-render) (get-get-width) (get-get-height)
(eh ev catching-exns? expr)))])
(write (serialize result) log-file)
(newline log-file)
(flush-output log-file)
@ -74,71 +91,73 @@
(lambda (exn)
(open-input-string ""))])
(open-input-file exprs-dat-file))])
(lambda (ev catching-exns? expr)
(with-handlers ([exn:fail? (lambda (exn)
(if catching-exns?
(raise exn)
(void)))])
(let ([v (read log-file)])
(if (eof-object? v)
(error "expression not in log file")
(let ([v (deserialize v)])
(if (equal? v (if (syntax? expr)
(syntax->datum expr)
expr))
(let ([v (read log-file)])
(if (eof-object? v)
(error "expression result missing in log file")
(let ([v (deserialize v)])
(if (gui-exn? v)
(raise (make-exn:fail
(gui-exn-message v)
(current-continuation-marks)))
v))))
(error 'mreval
"expression does not match log file: ~e versus: ~e"
expr
v))))))))))
(λ (gui-eval get-predicate? get-render get-get-width get-get-height)
(lambda (ev catching-exns? expr)
(with-handlers ([exn:fail? (lambda (exn)
(if catching-exns?
(raise exn)
(void)))])
(let ([v (read log-file)])
(if (eof-object? v)
(error "expression not in log file")
(let ([v (deserialize v)])
(if (equal? v (if (syntax? expr)
(syntax->datum expr)
expr))
(let ([v (read log-file)])
(if (eof-object? v)
(error "expression result missing in log file")
(let ([v (deserialize v)])
(if (gui-exn? v)
(raise (make-exn:fail
(gui-exn-message v)
(current-continuation-marks)))
v))))
(error 'mreval
"expression does not match log file: ~e versus: ~e"
expr
v)))))))))))
(define image-counter 0)
;; This path will be marshaled for use on multiple platforms
(define (build-string-path a b) (string-append a "/" b))
(define (fixup-picts v)
(cond
[((gui-eval 'pict?) v)
(let ([fn (build-string-path img-dir
(format "img~a.png" image-counter))])
(set! image-counter (add1 image-counter))
(let ([dc (let ([pss (make-object (gui-eval 'ps-setup%))])
(send pss set-mode 'file)
(send pss set-file (path-replace-suffix fn #".ps"))
(parameterize ([(gui-eval 'current-ps-setup) pss])
(make-object (gui-eval 'post-script-dc%) #f)))])
(send dc start-doc "Image")
(send dc start-page)
(((gui-eval 'make-pict-drawer) v) dc 0 0)
(send dc end-page)
(send dc end-doc)
(system (format "epstopdf ~a" (path-replace-suffix fn #".ps"))))
(let* ([bm (make-object (gui-eval 'bitmap%)
(inexact->exact (ceiling ((gui-eval 'pict-width) v)))
(inexact->exact (ceiling ((gui-eval 'pict-height) v))))]
[dc (make-object (gui-eval 'bitmap-dc%) bm)])
(send dc set-smoothing 'aligned)
(send dc clear)
(((gui-eval 'make-pict-drawer) v) dc 0 0)
(send bm save-file fn 'png)
(make-image-element
#f
(list "[image]")
;; Be sure to use a string rather than a path, because
;; it gets recorded in "exprs.dat".
(path->string (path-replace-suffix fn #""))
'(".pdf" ".png")
1.0)))]
[(pair? v) (cons (fixup-picts (car v))
(fixup-picts (cdr v)))]
[(serializable? v) v]
[else (make-element #f (list (format "~s" v)))]))
(define (fixup-picts predicate? render get-width get-height v)
(let loop ([v v])
(cond
[(predicate? v)
(let ([fn (build-string-path img-dir
(format "img~a.png" image-counter))])
(set! image-counter (add1 image-counter))
(let ([dc (let ([pss (make-object (gui-eval 'ps-setup%))])
(send pss set-mode 'file)
(send pss set-file (path-replace-suffix fn #".ps"))
(parameterize ([(gui-eval 'current-ps-setup) pss])
(make-object (gui-eval 'post-script-dc%) #f)))])
(send dc start-doc "Image")
(send dc start-page)
(render v dc 0 0)
(send dc end-page)
(send dc end-doc)
(system (format "epstopdf ~a" (path-replace-suffix fn #".ps"))))
(let* ([bm (make-object (gui-eval 'bitmap%)
(inexact->exact (ceiling (get-width v)))
(inexact->exact (ceiling (get-height v))))]
[dc (make-object (gui-eval 'bitmap-dc%) bm)])
(send dc set-smoothing 'aligned)
(send dc clear)
(render v dc 0 0)
(send bm save-file fn 'png)
(make-image-element
#f
(list "[image]")
;; Be sure to use a string rather than a path, because
;; it gets recorded in "exprs.dat".
(path->string (path-replace-suffix fn #""))
'(".pdf" ".png")
1.0)))]
[(pair? v) (cons (loop (car v))
(loop (cdr v)))]
[(serializable? v) v]
[else (make-element #f (list (format "~s" v)))])))