From 8e14e0dae686c87af6e156f41bc2878b34d21672 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 16 Jun 2010 11:35:40 -0500 Subject: [PATCH] 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 --- collects/scriblib/gui-eval.rkt | 185 ++++++++++++++++++--------------- 1 file changed, 102 insertions(+), 83 deletions(-) diff --git a/collects/scriblib/gui-eval.rkt b/collects/scriblib/gui-eval.rkt index 49d988c4..e6e93f93 100644 --- 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)))])))