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

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

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