improved drschemes display of planet requires
svn: r13534
This commit is contained in:
Robby Findler
parent
0be1c093b3
commit
d3ed20934a
|
|
@ -1,47 +1,55 @@
|
|||
(module drscheme mzscheme
|
||||
(require "private/key.ss")
|
||||
|
||||
(define debugging? (getenv "PLTDRDEBUG"))
|
||||
|
||||
(define install-cm? (and (not debugging?)
|
||||
(getenv "PLTDRCM")))
|
||||
|
||||
(define cm-trace? (or (equal? (getenv "PLTDRCM") "trace")
|
||||
(equal? (getenv "PLTDRDEBUG") "trace")))
|
||||
|
||||
(when debugging?
|
||||
(printf "PLTDRDEBUG: installing CM to load/create errortrace zos\n")
|
||||
(let-values ([(zo-compile
|
||||
make-compilation-manager-load/use-compiled-handler
|
||||
manager-trace-handler)
|
||||
(parameterize ([current-namespace (make-namespace)]
|
||||
[use-compiled-file-paths '()])
|
||||
(values
|
||||
(dynamic-require 'errortrace/zo-compile 'zo-compile)
|
||||
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
|
||||
(dynamic-require 'compiler/cm 'manager-trace-handler)))])
|
||||
(current-compile zo-compile)
|
||||
(use-compiled-file-paths (list (build-path "compiled" "errortrace")))
|
||||
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
|
||||
(error-display-handler (dynamic-require 'errortrace/errortrace-lib
|
||||
'errortrace-error-display-handler))
|
||||
(when cm-trace?
|
||||
(printf "PLTDRDEBUG: enabling CM tracing\n")
|
||||
(manager-trace-handler
|
||||
(λ (x) (display "1: ") (display x) (newline))))))
|
||||
|
||||
(when install-cm?
|
||||
(printf "PLTDRCM: installing compilation manager\n")
|
||||
(let-values ([(make-compilation-manager-load/use-compiled-handler
|
||||
manager-trace-handler)
|
||||
(parameterize ([current-namespace (make-namespace)])
|
||||
(values
|
||||
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
|
||||
(dynamic-require 'compiler/cm 'manager-trace-handler)))])
|
||||
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
|
||||
(when cm-trace?
|
||||
(printf "PLTDRCM: enabling CM tracing\n")
|
||||
(manager-trace-handler
|
||||
(λ (x) (display "1: ") (display x) (newline))))))
|
||||
#lang scheme/base
|
||||
|
||||
(dynamic-require 'drscheme/private/drscheme-normal #f))
|
||||
(require "private/key.ss")
|
||||
|
||||
(define debugging? (getenv "PLTDRDEBUG"))
|
||||
|
||||
(define install-cm? (and (not debugging?)
|
||||
(getenv "PLTDRCM")))
|
||||
|
||||
(define cm-trace? (or (equal? (getenv "PLTDRCM") "trace")
|
||||
(equal? (getenv "PLTDRDEBUG") "trace")))
|
||||
|
||||
|
||||
;; the flush is only here to ensure that the output is
|
||||
;; appears when running in cygwin under windows.
|
||||
(define (flprintf fmt . args)
|
||||
(apply printf fmt args)
|
||||
(flush-output))
|
||||
|
||||
(when debugging?
|
||||
(flprintf "PLTDRDEBUG: installing CM to load/create errortrace zos\n")
|
||||
(let-values ([(zo-compile
|
||||
make-compilation-manager-load/use-compiled-handler
|
||||
manager-trace-handler)
|
||||
(parameterize ([current-namespace (make-base-empty-namespace)]
|
||||
[use-compiled-file-paths '()])
|
||||
(values
|
||||
(dynamic-require 'errortrace/zo-compile 'zo-compile)
|
||||
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
|
||||
(dynamic-require 'compiler/cm 'manager-trace-handler)))])
|
||||
(current-compile zo-compile)
|
||||
(use-compiled-file-paths (list (build-path "compiled" "errortrace")))
|
||||
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
|
||||
(error-display-handler (dynamic-require 'errortrace/errortrace-lib
|
||||
'errortrace-error-display-handler))
|
||||
(when cm-trace?
|
||||
(flprintf "PLTDRDEBUG: enabling CM tracing\n")
|
||||
(manager-trace-handler
|
||||
(λ (x) (display "1: ") (display x) (newline) (flush-output))))))
|
||||
|
||||
(when install-cm?
|
||||
(flprintf "PLTDRCM: installing compilation manager\n")
|
||||
(let-values ([(make-compilation-manager-load/use-compiled-handler
|
||||
manager-trace-handler)
|
||||
(parameterize ([current-namespace (make-base-empty-namespace)])
|
||||
(values
|
||||
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
|
||||
(dynamic-require 'compiler/cm 'manager-trace-handler)))])
|
||||
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
|
||||
(when cm-trace?
|
||||
(flprintf "PLTDRCM: enabling CM tracing\n")
|
||||
(manager-trace-handler
|
||||
(λ (x) (display "1: ") (display x) (newline) (flush-output))))))
|
||||
|
||||
(dynamic-require 'drscheme/private/drscheme-normal #f)
|
||||
|
|
|
|||
|
|
@ -1,274 +1,274 @@
|
|||
#lang mzscheme
|
||||
#lang scheme/base
|
||||
|
||||
(require mred
|
||||
mzlib/class
|
||||
mzlib/cmdline
|
||||
scheme/list
|
||||
framework/private/bday)
|
||||
(require mred
|
||||
scheme/class
|
||||
mzlib/cmdline
|
||||
scheme/list
|
||||
framework/private/bday)
|
||||
|
||||
; (current-load text-editor-load-handler)
|
||||
|
||||
(define files-to-open
|
||||
(command-line
|
||||
(case (system-type)
|
||||
[(windows) "DrScheme.exe"]
|
||||
[(macosx) "drscheme" #;"DrScheme"]
|
||||
[else "drscheme"])
|
||||
(current-command-line-arguments)
|
||||
(args filenames filenames)))
|
||||
|
||||
(define icons-bitmap
|
||||
(let ([icons (collection-path "icons")])
|
||||
(lambda (name)
|
||||
(make-object bitmap% (build-path icons name)))))
|
||||
|
||||
;; updates the command-line-arguments with only the files
|
||||
;; to open. See also main.ss.
|
||||
(current-command-line-arguments (apply vector files-to-open))
|
||||
|
||||
(define-values (texas-independence-day? halloween?)
|
||||
(let* ([date (seconds->date (current-seconds))]
|
||||
[month (date-month date)]
|
||||
[day (date-day date)])
|
||||
(values (and (= 3 month) (= 2 day))
|
||||
(and (= 10 month) (= 31 day)))))
|
||||
|
||||
(define high-color? ((get-display-depth) . > . 8))
|
||||
(define special-state #f)
|
||||
(define normal-bitmap #f) ; set by load-magic-images
|
||||
|
||||
(define-struct magic-image (chars filename bitmap))
|
||||
|
||||
(define (magic-img str img)
|
||||
(make-magic-image (reverse (string->list str)) img #f))
|
||||
|
||||
;; magic strings and their associated images. There should not be a string
|
||||
;; in this list that is a prefix of another.
|
||||
(define magic-images
|
||||
(list (magic-img "larval" "PLT-206-larval.png")
|
||||
(magic-img "mars" "PLT-206-mars.jpg")))
|
||||
|
||||
(define (load-magic-images)
|
||||
(set! load-magic-images void) ; run only once
|
||||
(unless normal-bitmap (set! normal-bitmap (icons-bitmap "PLT-206.png")))
|
||||
(for-each (λ (magic-image)
|
||||
(unless (magic-image-bitmap magic-image)
|
||||
(set-magic-image-bitmap!
|
||||
magic-image
|
||||
(icons-bitmap (magic-image-filename magic-image)))))
|
||||
magic-images))
|
||||
|
||||
(define longest-magic-string
|
||||
(apply max (map (λ (s) (length (magic-image-chars s))) magic-images)))
|
||||
|
||||
(define key-codes null)
|
||||
|
||||
(define (find-magic-image)
|
||||
(define (prefix? l1 l2)
|
||||
(or (null? l1)
|
||||
(and (pair? l2)
|
||||
(eq? (car l1) (car l2))
|
||||
(prefix? (cdr l1) (cdr l2)))))
|
||||
(ormap (λ (i) (and (prefix? (magic-image-chars i) key-codes) i))
|
||||
magic-images))
|
||||
|
||||
(define (add-key-code new-code)
|
||||
(set! key-codes (cons new-code key-codes))
|
||||
(when ((length key-codes) . > . longest-magic-string)
|
||||
(set! key-codes (take key-codes longest-magic-string))))
|
||||
|
||||
(let ([set-splash-bitmap
|
||||
(dynamic-require 'framework/splash 'set-splash-bitmap)])
|
||||
((dynamic-require 'framework/splash 'set-splash-char-observer)
|
||||
(λ (evt)
|
||||
(let ([ch (send evt get-key-code)])
|
||||
(when (char? ch)
|
||||
;; as soon as something is typed, load the bitmaps
|
||||
(load-magic-images)
|
||||
(add-key-code ch)
|
||||
(let ([match (find-magic-image)])
|
||||
(when match
|
||||
(set! key-codes null)
|
||||
(set-splash-bitmap
|
||||
(if (eq? special-state match)
|
||||
(begin (set! special-state #f) normal-bitmap)
|
||||
(begin (set! special-state match)
|
||||
(magic-image-bitmap match)))))))))))
|
||||
|
||||
(when (eb-bday?)
|
||||
(let ()
|
||||
(define main-size 260)
|
||||
(define pi (atan 0 -1))
|
||||
|
||||
(define eli (icons-bitmap "eli-purple.jpg"))
|
||||
(define bitmap (make-object bitmap% main-size main-size))
|
||||
(define bdc (make-object bitmap-dc% bitmap))
|
||||
|
||||
(define outer-color (send the-color-database find-color "darkorange"))
|
||||
(define inner-color (send the-color-database find-color "green"))
|
||||
(define omega-str "(λ (x) (x x)) (λ (x) (x x)) ")
|
||||
(define hebrew-str " ףוס ןיא ףוס ןיא")
|
||||
|
||||
(define (draw-letter dc cx cy angle radius letter color)
|
||||
(let ([x (+ cx (* (cos angle) radius))]
|
||||
[y (- cy (* (sin angle) radius))])
|
||||
(send bdc set-text-foreground color)
|
||||
(send dc draw-text letter x y #f 0 (- angle (/ pi 2)))))
|
||||
|
||||
(define (draw-single-loop str dc offset cx cy radius font-size color)
|
||||
(send dc set-font (send the-font-list find-or-create-font font-size 'modern))
|
||||
(let loop ([i (string-length str)])
|
||||
(unless (zero? i)
|
||||
(draw-letter dc
|
||||
cx
|
||||
cy
|
||||
(normalize-angle
|
||||
(+ (- (* 2 pi) (* (* 2 pi) (/ (- i 1) (string-length str))))
|
||||
(/ pi 2)
|
||||
offset))
|
||||
radius
|
||||
(string (string-ref str (- i 1)))
|
||||
color)
|
||||
(loop (- i 1)))))
|
||||
|
||||
(define (normalize-angle angle)
|
||||
(cond
|
||||
[(<= 0 angle (* 2 pi)) angle]
|
||||
[(< angle 0) (normalize-angle (+ angle (* 2 pi)))]
|
||||
[else (normalize-angle (- angle (* 2 pi)))]))
|
||||
|
||||
(define splash-canvas ((dynamic-require 'framework/splash 'get-splash-canvas)))
|
||||
(define (draw-single-step dc offset)
|
||||
(send bdc draw-bitmap eli 0 0)
|
||||
(draw-single-loop omega-str bdc offset (/ main-size 2) (/ main-size 2) 120 32 outer-color)
|
||||
(draw-single-loop hebrew-str bdc (+ (- (* 2 pi) offset) (* 2 pi)) (/ main-size 2) (/ main-size 2) 70 20 inner-color)
|
||||
(send splash-canvas on-paint))
|
||||
|
||||
(define gc-b
|
||||
(with-handlers ([exn:fail? (lambda (x)
|
||||
(printf "~s\n" (exn-message x))
|
||||
#f)])
|
||||
(let ([b (icons-bitmap "recycle.gif")])
|
||||
(cond
|
||||
[(send b ok?)
|
||||
(let ([gbdc (make-object bitmap-dc% b)]
|
||||
[ebdc (make-object bitmap-dc% eli)]
|
||||
[color1 (make-object color%)]
|
||||
[color2 (make-object color%)]
|
||||
[avg (lambda (x y) (floor (* (/ x 255) y)))]
|
||||
[ox (floor (- (/ main-size 2) (/ (send b get-width) 2)))]
|
||||
[oy (floor (- (/ main-size 2) (/ (send b get-height) 2)))])
|
||||
(let loop ([i (send b get-width)])
|
||||
(unless (zero? i)
|
||||
(let loop ([j (send b get-height)])
|
||||
(unless (zero? j)
|
||||
(let ([x (- i 1)]
|
||||
[y (- j 1)])
|
||||
(send gbdc get-pixel x y color1)
|
||||
(send ebdc get-pixel (+ x ox) (+ y oy) color2)
|
||||
(send color1 set
|
||||
(avg (send color1 red) (send color2 red))
|
||||
(avg (send color1 green) (send color2 green))
|
||||
(avg (send color1 blue) (send color2 blue)))
|
||||
(send gbdc set-pixel x y color1)
|
||||
(loop (- j 1)))))
|
||||
(loop (- i 1))))
|
||||
(send gbdc set-bitmap #f)
|
||||
(send ebdc set-bitmap #f)
|
||||
b)]
|
||||
[else #f]))))
|
||||
|
||||
|
||||
(define (eli-paint dc)
|
||||
(send dc draw-bitmap bitmap 0 0))
|
||||
(define (eli-event evt)
|
||||
(cond
|
||||
[(send evt leaving?)
|
||||
((dynamic-require 'framework/splash 'set-splash-paint-callback) orig-paint)
|
||||
(when gc-b
|
||||
(unregister-collecting-blit splash-canvas))
|
||||
(send splash-canvas refresh)
|
||||
(when draw-thread
|
||||
(kill-thread draw-thread)
|
||||
(set! draw-thread #f))]
|
||||
[(send evt entering?)
|
||||
((dynamic-require 'framework/splash 'set-splash-paint-callback) eli-paint)
|
||||
(when gc-b
|
||||
(register-collecting-blit splash-canvas
|
||||
(floor (- (/ main-size 2)
|
||||
(/ (send gc-b get-width) 2)))
|
||||
(floor (- (/ main-size 2)
|
||||
(/ (send gc-b get-height) 2)))
|
||||
(send gc-b get-width)
|
||||
(send gc-b get-height)
|
||||
gc-b gc-b))
|
||||
(send splash-canvas refresh)
|
||||
(unless draw-thread
|
||||
(start-thread))]))
|
||||
|
||||
(define splash-eventspace ((dynamic-require 'framework/splash 'get-splash-eventspace)))
|
||||
(define draw-next-state
|
||||
(let ([o 0])
|
||||
(lambda ()
|
||||
(let ([s (make-semaphore 0)])
|
||||
(parameterize ([current-eventspace splash-eventspace])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(draw-single-step bdc o)
|
||||
(semaphore-post s))))
|
||||
(semaphore-wait s))
|
||||
(let ([next (+ o (/ pi 60))])
|
||||
(set! o (if (< next (* 2 pi))
|
||||
next
|
||||
(- next (* 2 pi))))))))
|
||||
|
||||
(define draw-thread #f)
|
||||
(define (start-thread)
|
||||
(set! draw-thread
|
||||
(thread
|
||||
(λ ()
|
||||
(let loop ()
|
||||
(draw-next-state)
|
||||
(sleep .01)
|
||||
(loop))))))
|
||||
(define orig-paint ((dynamic-require 'framework/splash 'get-splash-paint-callback)))
|
||||
|
||||
(draw-next-state)
|
||||
((dynamic-require 'framework/splash 'set-splash-event-callback) eli-event)
|
||||
(send splash-canvas refresh)))
|
||||
|
||||
((dynamic-require 'framework/splash 'start-splash)
|
||||
(build-path (collection-path "icons")
|
||||
(cond
|
||||
[texas-independence-day?
|
||||
"texas-plt-bw.gif"]
|
||||
[(and halloween? high-color?)
|
||||
"PLT-pumpkin.png"]
|
||||
[high-color? "PLT-206.png"]
|
||||
[(= (get-display-depth) 1)
|
||||
"pltbw.gif"]
|
||||
[else
|
||||
"plt-flat.gif"]))
|
||||
"DrScheme"
|
||||
99)
|
||||
|
||||
(when (getenv "PLTDRBREAK")
|
||||
(printf "PLTDRBREAK: creating break frame\n")
|
||||
(let ([to-break (eventspace-handler-thread (current-eventspace))])
|
||||
(parameterize ([current-eventspace (make-eventspace)])
|
||||
(let* ([f (new frame% (label "Break DrScheme"))]
|
||||
[b (new button%
|
||||
(label "Break Main Thread")
|
||||
(callback
|
||||
(λ (x y)
|
||||
(break-thread to-break)))
|
||||
(parent f))]
|
||||
[b (new button%
|
||||
(label "Break All Threads")
|
||||
(callback
|
||||
(λ (x y)
|
||||
((dynamic-require 'drscheme/private/key 'break-threads))))
|
||||
(parent f))])
|
||||
(send f show #t)))))
|
||||
; (current-load text-editor-load-handler)
|
||||
|
||||
(dynamic-require 'drscheme/tool-lib #f)
|
||||
(define files-to-open
|
||||
(command-line
|
||||
(case (system-type)
|
||||
[(windows) "DrScheme.exe"]
|
||||
[(macosx) "drscheme" #;"DrScheme"]
|
||||
[else "drscheme"])
|
||||
(current-command-line-arguments)
|
||||
(args filenames filenames)))
|
||||
|
||||
(define icons-bitmap
|
||||
(let ([icons (collection-path "icons")])
|
||||
(lambda (name)
|
||||
(make-object bitmap% (build-path icons name)))))
|
||||
|
||||
;; updates the command-line-arguments with only the files
|
||||
;; to open. See also main.ss.
|
||||
(current-command-line-arguments (apply vector files-to-open))
|
||||
|
||||
(define-values (texas-independence-day? halloween?)
|
||||
(let* ([date (seconds->date (current-seconds))]
|
||||
[month (date-month date)]
|
||||
[day (date-day date)])
|
||||
(values (and (= 3 month) (= 2 day))
|
||||
(and (= 10 month) (= 31 day)))))
|
||||
|
||||
(define high-color? ((get-display-depth) . > . 8))
|
||||
(define special-state #f)
|
||||
(define normal-bitmap #f) ; set by load-magic-images
|
||||
|
||||
(define-struct magic-image (chars filename [bitmap #:mutable]))
|
||||
|
||||
(define (magic-img str img)
|
||||
(make-magic-image (reverse (string->list str)) img #f))
|
||||
|
||||
;; magic strings and their associated images. There should not be a string
|
||||
;; in this list that is a prefix of another.
|
||||
(define magic-images
|
||||
(list (magic-img "larval" "PLT-206-larval.png")
|
||||
(magic-img "mars" "PLT-206-mars.jpg")))
|
||||
|
||||
(define (load-magic-images)
|
||||
(set! load-magic-images void) ; run only once
|
||||
(unless normal-bitmap (set! normal-bitmap (icons-bitmap "PLT-206.png")))
|
||||
(for-each (λ (magic-image)
|
||||
(unless (magic-image-bitmap magic-image)
|
||||
(set-magic-image-bitmap!
|
||||
magic-image
|
||||
(icons-bitmap (magic-image-filename magic-image)))))
|
||||
magic-images))
|
||||
|
||||
(define longest-magic-string
|
||||
(apply max (map (λ (s) (length (magic-image-chars s))) magic-images)))
|
||||
|
||||
(define key-codes null)
|
||||
|
||||
(define (find-magic-image)
|
||||
(define (prefix? l1 l2)
|
||||
(or (null? l1)
|
||||
(and (pair? l2)
|
||||
(eq? (car l1) (car l2))
|
||||
(prefix? (cdr l1) (cdr l2)))))
|
||||
(ormap (λ (i) (and (prefix? (magic-image-chars i) key-codes) i))
|
||||
magic-images))
|
||||
|
||||
(define (add-key-code new-code)
|
||||
(set! key-codes (cons new-code key-codes))
|
||||
(when ((length key-codes) . > . longest-magic-string)
|
||||
(set! key-codes (take key-codes longest-magic-string))))
|
||||
|
||||
(let ([set-splash-bitmap
|
||||
(dynamic-require 'framework/splash 'set-splash-bitmap)])
|
||||
((dynamic-require 'framework/splash 'set-splash-char-observer)
|
||||
(λ (evt)
|
||||
(let ([ch (send evt get-key-code)])
|
||||
(when (char? ch)
|
||||
;; as soon as something is typed, load the bitmaps
|
||||
(load-magic-images)
|
||||
(add-key-code ch)
|
||||
(let ([match (find-magic-image)])
|
||||
(when match
|
||||
(set! key-codes null)
|
||||
(set-splash-bitmap
|
||||
(if (eq? special-state match)
|
||||
(begin (set! special-state #f) normal-bitmap)
|
||||
(begin (set! special-state match)
|
||||
(magic-image-bitmap match)))))))))))
|
||||
|
||||
(when (eb-bday?)
|
||||
(let ()
|
||||
(define main-size 260)
|
||||
(define pi (atan 0 -1))
|
||||
|
||||
(define eli (icons-bitmap "eli-purple.jpg"))
|
||||
(define bitmap (make-object bitmap% main-size main-size))
|
||||
(define bdc (make-object bitmap-dc% bitmap))
|
||||
|
||||
(define outer-color (send the-color-database find-color "darkorange"))
|
||||
(define inner-color (send the-color-database find-color "green"))
|
||||
(define omega-str "(λ (x) (x x)) (λ (x) (x x)) ")
|
||||
(define hebrew-str " ףוס ןיא ףוס ןיא")
|
||||
|
||||
(define (draw-letter dc cx cy angle radius letter color)
|
||||
(let ([x (+ cx (* (cos angle) radius))]
|
||||
[y (- cy (* (sin angle) radius))])
|
||||
(send bdc set-text-foreground color)
|
||||
(send dc draw-text letter x y #f 0 (- angle (/ pi 2)))))
|
||||
|
||||
(define (draw-single-loop str dc offset cx cy radius font-size color)
|
||||
(send dc set-font (send the-font-list find-or-create-font font-size 'modern))
|
||||
(let loop ([i (string-length str)])
|
||||
(unless (zero? i)
|
||||
(draw-letter dc
|
||||
cx
|
||||
cy
|
||||
(normalize-angle
|
||||
(+ (- (* 2 pi) (* (* 2 pi) (/ (- i 1) (string-length str))))
|
||||
(/ pi 2)
|
||||
offset))
|
||||
radius
|
||||
(string (string-ref str (- i 1)))
|
||||
color)
|
||||
(loop (- i 1)))))
|
||||
|
||||
(define (normalize-angle angle)
|
||||
(cond
|
||||
[(<= 0 angle (* 2 pi)) angle]
|
||||
[(< angle 0) (normalize-angle (+ angle (* 2 pi)))]
|
||||
[else (normalize-angle (- angle (* 2 pi)))]))
|
||||
|
||||
(define splash-canvas ((dynamic-require 'framework/splash 'get-splash-canvas)))
|
||||
(define (draw-single-step dc offset)
|
||||
(send bdc draw-bitmap eli 0 0)
|
||||
(draw-single-loop omega-str bdc offset (/ main-size 2) (/ main-size 2) 120 32 outer-color)
|
||||
(draw-single-loop hebrew-str bdc (+ (- (* 2 pi) offset) (* 2 pi)) (/ main-size 2) (/ main-size 2) 70 20 inner-color)
|
||||
(send splash-canvas on-paint))
|
||||
|
||||
(define gc-b
|
||||
(with-handlers ([exn:fail? (lambda (x)
|
||||
(printf "~s\n" (exn-message x))
|
||||
#f)])
|
||||
(let ([b (icons-bitmap "recycle.gif")])
|
||||
(cond
|
||||
[(send b ok?)
|
||||
(let ([gbdc (make-object bitmap-dc% b)]
|
||||
[ebdc (make-object bitmap-dc% eli)]
|
||||
[color1 (make-object color%)]
|
||||
[color2 (make-object color%)]
|
||||
[avg (lambda (x y) (floor (* (/ x 255) y)))]
|
||||
[ox (floor (- (/ main-size 2) (/ (send b get-width) 2)))]
|
||||
[oy (floor (- (/ main-size 2) (/ (send b get-height) 2)))])
|
||||
(let loop ([i (send b get-width)])
|
||||
(unless (zero? i)
|
||||
(let loop ([j (send b get-height)])
|
||||
(unless (zero? j)
|
||||
(let ([x (- i 1)]
|
||||
[y (- j 1)])
|
||||
(send gbdc get-pixel x y color1)
|
||||
(send ebdc get-pixel (+ x ox) (+ y oy) color2)
|
||||
(send color1 set
|
||||
(avg (send color1 red) (send color2 red))
|
||||
(avg (send color1 green) (send color2 green))
|
||||
(avg (send color1 blue) (send color2 blue)))
|
||||
(send gbdc set-pixel x y color1)
|
||||
(loop (- j 1)))))
|
||||
(loop (- i 1))))
|
||||
(send gbdc set-bitmap #f)
|
||||
(send ebdc set-bitmap #f)
|
||||
b)]
|
||||
[else #f]))))
|
||||
|
||||
|
||||
(define (eli-paint dc)
|
||||
(send dc draw-bitmap bitmap 0 0))
|
||||
(define (eli-event evt)
|
||||
(cond
|
||||
[(send evt leaving?)
|
||||
((dynamic-require 'framework/splash 'set-splash-paint-callback) orig-paint)
|
||||
(when gc-b
|
||||
(unregister-collecting-blit splash-canvas))
|
||||
(send splash-canvas refresh)
|
||||
(when draw-thread
|
||||
(kill-thread draw-thread)
|
||||
(set! draw-thread #f))]
|
||||
[(send evt entering?)
|
||||
((dynamic-require 'framework/splash 'set-splash-paint-callback) eli-paint)
|
||||
(when gc-b
|
||||
(register-collecting-blit splash-canvas
|
||||
(floor (- (/ main-size 2)
|
||||
(/ (send gc-b get-width) 2)))
|
||||
(floor (- (/ main-size 2)
|
||||
(/ (send gc-b get-height) 2)))
|
||||
(send gc-b get-width)
|
||||
(send gc-b get-height)
|
||||
gc-b gc-b))
|
||||
(send splash-canvas refresh)
|
||||
(unless draw-thread
|
||||
(start-thread))]))
|
||||
|
||||
(define splash-eventspace ((dynamic-require 'framework/splash 'get-splash-eventspace)))
|
||||
(define draw-next-state
|
||||
(let ([o 0])
|
||||
(lambda ()
|
||||
(let ([s (make-semaphore 0)])
|
||||
(parameterize ([current-eventspace splash-eventspace])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(draw-single-step bdc o)
|
||||
(semaphore-post s))))
|
||||
(semaphore-wait s))
|
||||
(let ([next (+ o (/ pi 60))])
|
||||
(set! o (if (< next (* 2 pi))
|
||||
next
|
||||
(- next (* 2 pi))))))))
|
||||
|
||||
(define draw-thread #f)
|
||||
(define (start-thread)
|
||||
(set! draw-thread
|
||||
(thread
|
||||
(λ ()
|
||||
(let loop ()
|
||||
(draw-next-state)
|
||||
(sleep .01)
|
||||
(loop))))))
|
||||
(define orig-paint ((dynamic-require 'framework/splash 'get-splash-paint-callback)))
|
||||
|
||||
(draw-next-state)
|
||||
((dynamic-require 'framework/splash 'set-splash-event-callback) eli-event)
|
||||
(send splash-canvas refresh)))
|
||||
|
||||
((dynamic-require 'framework/splash 'start-splash)
|
||||
(build-path (collection-path "icons")
|
||||
(cond
|
||||
[texas-independence-day?
|
||||
"texas-plt-bw.gif"]
|
||||
[(and halloween? high-color?)
|
||||
"PLT-pumpkin.png"]
|
||||
[high-color? "PLT-206.png"]
|
||||
[(= (get-display-depth) 1)
|
||||
"pltbw.gif"]
|
||||
[else
|
||||
"plt-flat.gif"]))
|
||||
"DrScheme"
|
||||
99)
|
||||
|
||||
(when (getenv "PLTDRBREAK")
|
||||
(printf "PLTDRBREAK: creating break frame\n") (flush-output)
|
||||
(let ([to-break (eventspace-handler-thread (current-eventspace))])
|
||||
(parameterize ([current-eventspace (make-eventspace)])
|
||||
(let* ([f (new frame% (label "Break DrScheme"))]
|
||||
[b (new button%
|
||||
(label "Break Main Thread")
|
||||
(callback
|
||||
(λ (x y)
|
||||
(break-thread to-break)))
|
||||
(parent f))]
|
||||
[b (new button%
|
||||
(label "Break All Threads")
|
||||
(callback
|
||||
(λ (x y)
|
||||
((dynamic-require 'drscheme/private/key 'break-threads))))
|
||||
(parent f))])
|
||||
(send f show #t)))))
|
||||
|
||||
(dynamic-require 'drscheme/tool-lib #f)
|
||||
|
|
|
|||
|
|
@ -1297,11 +1297,11 @@ TODO
|
|||
;; register drscheme with the planet-terse-register for the user's namespace
|
||||
;; must be called after 'initialize-parameters' is called (since it initializes
|
||||
;; the user's namespace)
|
||||
(planet-terse-set-key (gensym))
|
||||
(planet-terse-register
|
||||
(lambda (tag package)
|
||||
(parameterize ([current-eventspace drscheme:init:system-eventspace])
|
||||
(queue-callback (λ () (new-planet-info tag package)))))
|
||||
(get-user-namespace))
|
||||
(queue-callback (λ () (new-planet-info tag package))))))
|
||||
|
||||
;; disable breaks until an evaluation actually occurs
|
||||
(send context set-breakables #f #f)
|
||||
|
|
@ -1438,33 +1438,35 @@ TODO
|
|||
(define logger-messages '())
|
||||
(define/public (get-logger-messages) logger-messages)
|
||||
(define/private (new-log-message vec)
|
||||
(let ([level (vector-ref vec 0)]
|
||||
[str (cond
|
||||
[(<= (string-length (vector-ref vec 1)) log-entry-max-size)
|
||||
(vector-ref vec 1)]
|
||||
[else
|
||||
(substring (vector-ref vec 1) 0 log-entry-max-size)])])
|
||||
(let* ([level (vector-ref vec 0)]
|
||||
[str (cond
|
||||
[(<= (string-length (vector-ref vec 1)) log-entry-max-size)
|
||||
(vector-ref vec 1)]
|
||||
[else
|
||||
(substring (vector-ref vec 1) 0 log-entry-max-size)])]
|
||||
[msg (vector level str)])
|
||||
(cond
|
||||
[(< (length logger-messages) log-max-size)
|
||||
(set! logger-messages (cons (vector level str) logger-messages))]
|
||||
(set! logger-messages (cons msg logger-messages))
|
||||
(update-logger-gui (cons 'add-line msg))]
|
||||
[else
|
||||
(set! logger-messages
|
||||
(cons
|
||||
(vector level str)
|
||||
msg
|
||||
(let loop ([msgs logger-messages])
|
||||
(cond
|
||||
[(null? (cdr msgs)) null]
|
||||
[else (cons (car msgs) (loop (cdr msgs)))]))))])
|
||||
(update-logger-gui)))
|
||||
[else (cons (car msgs) (loop (cdr msgs)))]))))
|
||||
(update-logger-gui (cons 'clear-last-line-and-add-line msg))])))
|
||||
|
||||
(define/private (reset-logger-messages)
|
||||
(set! logger-messages '())
|
||||
(update-logger-gui))
|
||||
(update-logger-gui #f))
|
||||
|
||||
(define/private (update-logger-gui)
|
||||
(define/private (update-logger-gui command)
|
||||
(let ([frame (get-frame)])
|
||||
(when frame
|
||||
(send frame update-logger-window))))
|
||||
(send frame update-logger-window command))))
|
||||
|
||||
(define/private (new-planet-info tag package)
|
||||
(let ([frame (get-frame)])
|
||||
|
|
|
|||
|
|
@ -117,7 +117,7 @@
|
|||
(define candidate-tool?
|
||||
(cond
|
||||
[(getenv "PLTNOTOOLS")
|
||||
(printf "PLTNOTOOLS: skipping tools\n")
|
||||
(printf "PLTNOTOOLS: skipping tools\n") (flush-output)
|
||||
(lambda (it) #f)]
|
||||
[(getenv "PLTONLYTOOL") =>
|
||||
(lambda (onlys)
|
||||
|
|
@ -130,7 +130,7 @@
|
|||
(let-values ([(base name dir) (split-path x)])
|
||||
(memq (string->symbol (path->string name))
|
||||
allowed)))])
|
||||
(printf "PLTONLYTOOL: only loading ~s\n" allowed)
|
||||
(printf "PLTONLYTOOL: only loading ~s\n" allowed) (flush-output)
|
||||
(lambda (it)
|
||||
(directory-ok?
|
||||
(directory-record-path
|
||||
|
|
|
|||
|
|
@ -1433,11 +1433,11 @@ module browser threading seems wrong.
|
|||
(not (member logger-panel l))))
|
||||
;; if things are already up to date, only update the logger text
|
||||
(when show?
|
||||
(update-logger-window))
|
||||
(update-logger-window #f))
|
||||
l]
|
||||
[show?
|
||||
(new-logger-text)
|
||||
(update-logger-window)
|
||||
(update-logger-window #f)
|
||||
(send logger-menu-item set-label (string-constant hide-log))
|
||||
(append (remq logger-panel l) (list logger-panel))]
|
||||
[else
|
||||
|
|
@ -1453,11 +1453,11 @@ module browser threading seems wrong.
|
|||
[parent logger-panel]
|
||||
[callback
|
||||
(λ (tp evt)
|
||||
(update-logger-window))]))
|
||||
(update-logger-window #f))]))
|
||||
(new-logger-text)
|
||||
(new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text])
|
||||
(send logger-menu-item set-label (string-constant hide-log))
|
||||
(update-logger-window)
|
||||
(update-logger-window #f)
|
||||
(send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))])
|
||||
(with-handlers ([exn:fail? void])
|
||||
(send logger-parent-panel set-percentages (list p (- 1 p))))
|
||||
|
|
@ -1472,27 +1472,66 @@ module browser threading seems wrong.
|
|||
(set! logger-gui-text (new (text:hide-caret/selection-mixin text:basic%)))
|
||||
(send logger-gui-text lock #t))
|
||||
|
||||
(define/public (update-logger-window)
|
||||
(define/public (update-logger-window command)
|
||||
(when logger-gui-text
|
||||
(send logger-gui-text begin-edit-sequence)
|
||||
(send logger-gui-text lock #f)
|
||||
(send logger-gui-text erase)
|
||||
(let ([level (case (send logger-gui-tab-panel get-selection)
|
||||
[(0) #f]
|
||||
[(1) 'fatal]
|
||||
[(2) 'error]
|
||||
[(3) 'warning]
|
||||
[(4) 'info]
|
||||
[(5) 'debug])])
|
||||
(for-each
|
||||
(λ (x)
|
||||
(when (or (not level)
|
||||
(eq? level (vector-ref x 0)))
|
||||
(send logger-gui-text insert "\n" 0 0)
|
||||
(send logger-gui-text insert (vector-ref x 1) 0 0)))
|
||||
(send interactions-text get-logger-messages)))
|
||||
(send logger-gui-text lock #t)
|
||||
(send logger-gui-text end-edit-sequence)))
|
||||
(let ([admin (send logger-gui-text get-admin)]
|
||||
[canvas (send logger-gui-text get-canvas)])
|
||||
(when (and canvas admin)
|
||||
(let ([logger-messages (send interactions-text get-logger-messages)]
|
||||
[level (case (send logger-gui-tab-panel get-selection)
|
||||
[(0) #f]
|
||||
[(1) 'fatal]
|
||||
[(2) 'error]
|
||||
[(3) 'warning]
|
||||
[(4) 'info]
|
||||
[(5) 'debug])])
|
||||
(cond
|
||||
[(and (pair? command)
|
||||
(pair? logger-messages)
|
||||
;; just flush and redraw everything if there is one (or zero) logger messages
|
||||
(pair? (cdr logger-messages)))
|
||||
(let ([msg (cdr command)])
|
||||
(when (or (not level)
|
||||
(eq? (vector-ref msg 0) level))
|
||||
(send logger-gui-text begin-edit-sequence)
|
||||
(send logger-gui-text lock #f)
|
||||
(case (car command)
|
||||
[(add-line) (void)]
|
||||
[(clear-last-and-add-line)
|
||||
(send logger-gui-text delete
|
||||
0
|
||||
(send logger-gui-text paragraph-start-position 1))])
|
||||
(send logger-gui-text insert
|
||||
"\n"
|
||||
(send logger-gui-text last-position)
|
||||
(send logger-gui-text last-position))
|
||||
(send logger-gui-text insert
|
||||
(vector-ref msg 1)
|
||||
(send logger-gui-text last-position)
|
||||
(send logger-gui-text last-position))
|
||||
(send logger-gui-text end-edit-sequence)
|
||||
(send logger-gui-text lock #t)))]
|
||||
[else
|
||||
(send logger-gui-text begin-edit-sequence)
|
||||
(send logger-gui-text lock #f)
|
||||
(send logger-gui-text erase)
|
||||
|
||||
(let ([insert-one
|
||||
(λ (x newline?)
|
||||
(when (or (not level)
|
||||
(eq? level (vector-ref x 0)))
|
||||
(when newline? (send logger-gui-text insert "\n" 0 0))
|
||||
(send logger-gui-text insert (vector-ref x 1) 0 0)))])
|
||||
|
||||
(unless (null? logger-messages)
|
||||
;; skip the last newline in the buffer
|
||||
(insert-one (car logger-messages) #f)
|
||||
(for-each
|
||||
(λ (x) (insert-one x #t))
|
||||
(cdr (send interactions-text get-logger-messages)))))
|
||||
|
||||
(send logger-gui-text lock #t)
|
||||
(send logger-gui-text end-edit-sequence)]))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
@ -1527,7 +1566,6 @@ module browser threading seems wrong.
|
|||
[label (string-constant show-log)]
|
||||
[callback (λ (a b) (send current-tab toggle-log))]))
|
||||
(update-logger-button-label)
|
||||
;; needs to become that little x thingy that is in the search/replace bar
|
||||
(new close-icon%
|
||||
[parent planet-status-panel]
|
||||
[callback (λ ()
|
||||
|
|
|
|||
|
|
@ -4,50 +4,56 @@
|
|||
|
||||
This file is shared between the original
|
||||
namespace that drscheme first starts with
|
||||
and other namespaces that it loads,
|
||||
any other namespaces that it loads,
|
||||
so it keeps the requirements low (it could
|
||||
be in the '#%kernel language, but
|
||||
drscheme already shares mred/mred, so there
|
||||
seems little point to that.
|
||||
seems little point to that).
|
||||
|
||||
|#
|
||||
|
||||
(provide planet-terse-register planet-terse-log)
|
||||
(provide planet-terse-register
|
||||
planet-terse-log
|
||||
planet-terse-set-key)
|
||||
|
||||
(define-values (terse-log-message-chan) (make-channel))
|
||||
(define-values (terse-log-proc-chan) (make-channel))
|
||||
(define terse-log-message-chan (make-channel))
|
||||
(define terse-log-proc-chan (make-channel))
|
||||
(define terse-log-key-param (make-parameter (gensym)))
|
||||
|
||||
(define thd
|
||||
(thread
|
||||
(lambda ()
|
||||
(let ([procs (make-weak-hash)])
|
||||
(let ([procs (make-weak-hasheq)])
|
||||
(let loop ()
|
||||
(sync
|
||||
(handle-evt
|
||||
terse-log-message-chan
|
||||
(lambda (msg)
|
||||
(let ([namespace (list-ref msg 0)]
|
||||
(let ([registry (list-ref msg 0)]
|
||||
[id (list-ref msg 1)]
|
||||
[str (list-ref msg 2)])
|
||||
(for-each (lambda (eph)
|
||||
(let ([proc (ephemeron-value eph)])
|
||||
(when proc
|
||||
(proc id str))))
|
||||
(hash-ref procs namespace '())))
|
||||
(hash-ref procs registry '())))
|
||||
(loop)))
|
||||
(handle-evt
|
||||
terse-log-proc-chan
|
||||
(lambda (pn)
|
||||
(let ([proc (list-ref pn 0)]
|
||||
[namespace (list-ref pn 1)])
|
||||
(lambda (rp)
|
||||
(let ([registry (list-ref rp 0)]
|
||||
[proc (list-ref rp 1)])
|
||||
(hash-update! procs
|
||||
namespace
|
||||
(lambda (x) (cons (make-ephemeron namespace proc) x))
|
||||
registry
|
||||
(lambda (x) (cons (make-ephemeron registry proc) x))
|
||||
'())
|
||||
(loop))))))))))
|
||||
|
||||
(define (planet-terse-log id str [key (terse-log-key-param)])
|
||||
(sync (channel-put-evt terse-log-message-chan (list key id str))))
|
||||
|
||||
(define (planet-terse-log id str [namespace (current-namespace)])
|
||||
(sync (channel-put-evt terse-log-message-chan (list namespace id str))))
|
||||
|
||||
(define (planet-terse-register proc [namespace (current-namespace)])
|
||||
(sync (channel-put-evt terse-log-proc-chan (list proc namespace))))
|
||||
(define (planet-terse-register proc [key (terse-log-key-param)])
|
||||
(sync (channel-put-evt terse-log-proc-chan (list key proc))))
|
||||
|
||||
(define (planet-terse-set-key new-key)
|
||||
(terse-log-key-param new-key))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user