commit 8e14e0dae686c87af6e156f41bc2878b34d21672
parent 0a3de1887bd13c31df5efeb80d6e8e4095179e1d
Author: Robby Findler <robby@racket-lang.org>
Date: Wed, 16 Jun 2010 11:35:40 -0500
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
Diffstat:
1 file changed, 102 insertions(+), 83 deletions(-)
diff --git a/collects/scriblib/gui-eval.rkt b/collects/scriblib/gui-eval.rkt
@@ -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)))])))
