1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
#lang racket/base
(require scribble/eval
scribble/core
scribble/scheme
racket/class
racket/file
racket/runtime-path
racket/serialize
"private/gui-eval-exn.rkt"
racket/system
racket/sandbox
(for-syntax racket/base))
(define-syntax define-mr
(syntax-rules ()
[(_ mr orig)
(begin
(provide mr)
(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 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 #:pretty-print? #f))
(define mred? (getenv "MREVAL"))
(define-namespace-anchor anchor)
(when mred?
(call-in-sandbox-context gui-eval
(lambda ()
(namespace-attach-module (namespace-anchor->namespace anchor)
'racket/class)))
(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)
(define-mr gui-def+int def+int)
(define-mr gui-defs+int defs+int)
(define-mr gui-racketmod+eval racketmod+eval)
(define-mr gui-racketblock+eval racketblock+eval)
(provide (rename-out [gui-racketmod+eval gui-schememod+eval]
[gui-racketblock+eval gui-schemeblock+eval]))
;; This one needs to be relative, because it ends up in the
;; exprs.dat file:
(define img-dir "images") ; relative to src dir
;; This one can be absolute:
(define exprs-dat-file (build-path "images"
"exprs.dat"))
(define gui-eval-handler
(if mred?
(let ([eh (scribble-eval-handler)]
[log-file (open-output-file exprs-dat-file #:exists 'truncate/replace)])
(λ (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)
(if (gui-exn? result)
(raise (make-exn:fail
(gui-exn-message result)
(current-continuation-marks)))
result)))))
(let ([log-file (with-handlers ([exn:fail:filesystem?
(lambda (exn)
(open-input-string ""))])
(open-input-file exprs-dat-file))])
(λ (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 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 #".pdf"))
(parameterize ([(gui-eval 'current-ps-setup) pss])
(let ([xb (box 0)]
[yb (box 0)])
(send pss get-scaling xb yb)
(new (gui-eval 'pdf-dc%)
[interactive #f]
[width (* (unbox xb) (get-width v))]
[height (* (unbox yb) (get-height v))]))))])
(send dc start-doc "Image")
(send dc start-page)
(render v dc 0 0)
(send dc end-page)
(send dc end-doc))
(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)))])))
|
