suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

,

Browse Source 
svn: r620
This commit is contained in:
Robby Findler 2005-08-19 20:31:05 +00:00
parent c3e325f51f
commit fd7790118c
2 changed files with 65 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
collects/lang/htdp-langs.ss
View File

@ -379,44 +379,44 @@ tracing todo:
(inherit get-reader set-printing-parameters) (inherit get-reader set-printing-parameters)
(define/override (front-end/complete-program port settings teachpacks) (define/override (front-end/complete-program port settings teachpacks)
(let ([state 'init] (let ([state 'init]
;; state : 'init => 'require => 'done ;; state : 'init => 'require => 'done
[reader (get-reader)]) [reader (get-reader)])
(lambda () (lambda ()
(case state (case state
[(init) [(init)
(set! state 'require) (set! state 'require)
(let ([body-exps (let ([body-exps
(let loop () (let loop ()
(let ([result (reader (object-name port) port)]) (let ([result (reader (object-name port) port)])
(if (eof-object? result) (if (eof-object? result)
null null
(cons result (loop)))))] (cons result (loop)))))]
[language-module (get-module)] [language-module (get-module)]
[require-specs [require-specs
(drscheme:teachpack:teachpack-cache-require-specs teachpacks)]) (drscheme:teachpack:teachpack-cache-require-specs teachpacks)])
(rewrite-module (rewrite-module
(expand (expand
(datum->syntax-object (datum->syntax-object
#f #f
`(,#'module #%htdp ,language-module `(,#'module #%htdp ,language-module
(,#'require ,@require-specs) (,#'require ,@require-specs)
,@body-exps)))))] ,@body-exps)))))]
[(require) [(require)
(set! state 'done) (set! state 'done)
(syntax (syntax
(let ([done-already? #f]) (let ([done-already? #f])
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
;(dynamic-require '#%htdp #f) ;(dynamic-require '#%htdp #f)
(eval #'(require #%htdp))) ;; work around a bug in dynamic-require (eval #'(require #%htdp))) ;; work around a bug in dynamic-require
(lambda () (lambda ()
(unless done-already? (unless done-already?
(set! done-already? #t) (set! done-already? #t)
(current-namespace (module->namespace '#%htdp)))))))] (current-namespace (module->namespace '#%htdp)))))))]
[(done) eof])))) [(done) eof]))))
(super-new))) (super-new)))

48
collects/lang/private/imageeq.ss
View File

@ -48,30 +48,36 @@
(= (vector-ref v1 (- i 1)) (vector-ref v2 (- i 1))))) (= (vector-ref v1 (- i 1)) (vector-ref v2 (- i 1)))))
(loop (- i 4))))))) (loop (- i 4)))))))
;; coerce-to-cache-image-snip : image -> (is-a?/c cache-image-snip%)
(define image-snip-cache (make-hash-table 'weak))
;; coerce-to-cache-image-snip : image -> (is-a?/c cache-image-snip%)
(define (coerce-to-cache-image-snip snp) (define (coerce-to-cache-image-snip snp)
(cond (cond
[(hash-table-get image-snip-cache snp (λ () #f)) => values]
[(is-a? snp image-snip%) [(is-a? snp image-snip%)
(let ([bmp (send snp get-bitmap)]) (let* ([bmp (send snp get-bitmap)]
(if bmp [cis
(let ([bmp-mask (or (send bmp get-loaded-mask) (if bmp
(send snp get-bitmap-mask) (let ([bmp-mask (or (send bmp get-loaded-mask)
(bitmap->mask bmp))]) (send snp get-bitmap-mask)
(bitmaps->cache-image-snip (copy-bitmap bmp) (bitmap->mask bmp))])
(copy-bitmap bmp-mask) (bitmaps->cache-image-snip (copy-bitmap bmp)
(floor (/ (send bmp get-width) 2)) (copy-bitmap bmp-mask)
(floor (/ (send bmp get-height) 2)))) (floor (/ (send bmp get-width) 2))
(let-values ([(w h) (snip-size snp)]) (floor (/ (send bmp get-height) 2))))
(let* ([bmp (make-object bitmap% (let-values ([(w h) (snip-size snp)])
(inexact->exact (floor w)) (let* ([bmp (make-object bitmap%
(inexact->exact (floor h)))] (inexact->exact (floor w))
[bdc (make-object bitmap-dc% bmp)]) (inexact->exact (floor h)))]
(send snp draw bdc 0 0 0 0 w h 0 0 'no-caret) [bdc (make-object bitmap-dc% bmp)])
(send bdc set-bitmap #f) (send snp draw bdc 0 0 0 0 w h 0 0 'no-caret)
(bitmaps->cache-image-snip bmp (send bdc set-bitmap #f)
(bitmap->mask bmp) (bitmaps->cache-image-snip bmp
(floor (/ w 2)) (bitmap->mask bmp)
(floor (/ h 2)))))))] (floor (/ w 2))
(floor (/ h 2))))))])
(hash-table-put! image-snip-cache snp cis)
cis)]
[else snp])) [else snp]))
;; copy-bitmap : bitmap -> bitmap ;; copy-bitmap : bitmap -> bitmap