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

world modified

Browse Source 
svn: r5140
This commit is contained in:
Matthias Felleisen 2006-12-19 19:47:05 +00:00
parent cbfdfd91b4
commit 586b47c0dd
1 changed files with 163 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

309
collects/htdp/world.ss
View File

@ -7,49 +7,62 @@
;; Thu Dec 1 17:03:03 EST 2005: fixed place-image; all coordinates okay now ;; Thu Dec 1 17:03:03 EST 2005: fixed place-image; all coordinates okay now
(module world mzscheme (module world mzscheme
(require (require
(lib "class.ss") (lib "class.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "list.ss") (lib "list.ss")
(lib "process.ss") (lib "process.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "error.ss" "htdp") (lib "error.ss" "htdp")
(lib "image.ss" "htdp") (lib "image.ss" "htdp")
(prefix beg: (lib "htdp-beginner.ss" "lang")) (prefix beg: (lib "htdp-beginner.ss" "lang"))
(lib "prim.ss" "lang")) (lib "prim.ss" "lang"))
;; --- provide --------------------------------------------------------------- ;; --- provide ---------------------------------------------------------------
(provide (all-from-except (lib "image.ss" "htdp") add-line)) (provide (all-from-except (lib "image.ss" "htdp") add-line))
(provide ;; forall(World): (provide ;; forall(World):
big-bang ;; Number Number Number World -> true big-bang ;; Number Number Number World -> true
begin-recording ;; String -> true begin-recording ;; String -> true
end-of-time ;; String u Symbol -> World end-of-time ;; String u Symbol -> World
nw:rectangle ;; Number Number Mode Color -> Image nw:rectangle ;; Number Number Mode Color -> Image
place-image ;; Image Number Number Scence -> Scene place-image ;; Image Number Number Scence -> Scene
empty-scene ;; Number Number -> Scene empty-scene ;; Number Number -> Scene
run-movie ;; (Listof Image) -> true run-movie ;; (Listof Image) -> true
(rename add-line-to-scene add-line) (rename add-line-to-scene add-line)
;; Scene Number Number Number Number Color -> Scene ;; Scene Number Number Number Number Color -> Scene
;; cut all pieces that are outside the given rectangle ;; cut all pieces that are outside the given rectangle
) )
(provide-higher-order-primitive (provide-higher-order-primitive
on-tick-event (tock) ;; (World -> World) -> true run-simulation (_ _ _ create-scene) ;; (Nat Nat Number (Nat -> Image) -> true)
) )
(define (run-simulation width height rate f)
(check-pos 'run-simulation width "first")
(check-pos 'run-simulation height "second")
(check-arg 'run-simulation (number? rate) 'number "third" rate)
(check-proc 'run-simulation f 1 "fourth" "one argument")
(big-bang width height rate 1)
(on-redraw f)
(on-tick-event add1))
(provide-higher-order-primitive (provide-higher-order-primitive
on-redraw (world-image) ;; (World -> Image) -> true on-tick-event (tock) ;; (World -> World) -> true
) )
(provide-higher-order-primitive
on-redraw (world-image) ;; (World -> Image) -> true
)
;; KeyEvent is one of: ;; KeyEvent is one of:
;; -- Char ;; -- Char
;; -- Symbol ;; -- Symbol
(provide-higher-order-primitive ;; (World KeyEvent -> World) -> true (provide-higher-order-primitive ;; (World KeyEvent -> World) -> true
on-key-event on-key-event
(draw) (draw)
) )
;; A MouseEventType is one of: ;; A MouseEventType is one of:
;; - 'button-down ;; - 'button-down
@ -60,9 +73,9 @@
;; - 'leave ;; - 'leave
(provide-higher-order-primitive ;; (World Number Number MouseEvent -> World) -> true (provide-higher-order-primitive ;; (World Number Number MouseEvent -> World) -> true
on-mouse-event on-mouse-event
(clack) (clack)
) )
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
@ -95,10 +108,11 @@
(define (place-image image x y scene) (define (place-image image x y scene)
(check-image 'place-image image "first") (check-image 'place-image image "first")
(check-arg 'place-image (and (number? x) (integer? x)) 'integer "second" x) (check-arg 'place-image (number? x) 'integer "second" x)
(check-arg 'place-image (and (number? y) (integer? x)) 'integer "third" y) (check-arg 'place-image (number? y) 'integer "third" y)
(check-image 'place-image scene "fourth" "scene") (check-image 'place-image scene "fourth" "scene")
(let () (let ([x (number->integer x)]
[y (number->integer y)])
(define sw (image-width scene)) (define sw (image-width scene))
(define sh (image-height scene)) (define sh (image-height scene))
(define ns (overlay/xy scene x y image)) (define ns (overlay/xy scene x y image))
@ -108,6 +122,8 @@
ns ns
(shrink ns 0 0 sw sh)))) (shrink ns 0 0 sw sh))))
(define (number->integer x) (inexact->exact (floor x)))
(define (add-line-to-scene img x0 y0 x1 y1 c) (define (add-line-to-scene img x0 y0 x1 y1 c)
#| #|
(check-image 'add-line image "first") (check-image 'add-line image "first")
@ -127,29 +143,29 @@
[(= y0 y1) ;; horizontal [(= y0 y1) ;; horizontal
(if (<= 0 y0 h) (add-line img (app x0 w) y0 (app x1 w) y0 c) img)] (if (<= 0 y0 h) (add-line img (app x0 w) y0 (app x1 w) y0 c) img)]
[else [else
(local ((define lin (points->line x0 y0 x1 y1)) (local ((define lin (points->line x0 y0 x1 y1))
(define dir (direction x0 y0 x1 y1)) (define dir (direction x0 y0 x1 y1))
(define-values (upp low lft rgt) (intersections lin w h)) (define-values (upp low lft rgt) (intersections lin w h))
(define (add x y) (add-line img x0 y0 x y c))) (define (add x y) (add-line img x0 y0 x y c)))
(cond (cond
[(and (< 0 x0 w) (< 0 y0 h)) ;; (x0,y0) is in the interior [(and (< 0 x0 w) (< 0 y0 h)) ;; (x0,y0) is in the interior
(case dir (case dir
[(upper-left) (if (number? upp) (add upp 0) (add 0 lft))] [(upper-left) (if (number? upp) (add upp 0) (add 0 lft))]
[(lower-left) (if (number? low) (add low h) (add 0 lft))] [(lower-left) (if (number? low) (add low h) (add 0 lft))]
[(upper-right) (if (number? upp) (add upp 0) (add h rgt))] [(upper-right) (if (number? upp) (add upp 0) (add h rgt))]
[(lower-right) (if (number? low) (add low h) (add w rgt))] [(lower-right) (if (number? low) (add low h) (add w rgt))]
[else (error 'dir "contract violation: ~e" dir)])] [else (error 'dir "contract violation: ~e" dir)])]
[(and (< 0 x1 w) (< 0 y1 h)) ;; (x1,y1) in interior; symmetry! [(and (< 0 x1 w) (< 0 y1 h)) ;; (x1,y1) in interior; symmetry!
(add-line-to-scene img x1 y1 x0 y0 c)] (add-line-to-scene img x1 y1 x0 y0 c)]
[else [else
(cond (cond
[(and (number? upp) (number? low)) (add-line img upp 0 low h c)] [(and (number? upp) (number? low)) (add-line img upp 0 low h c)]
[(and (number? upp) (number? lft)) (add-line img upp 0 0 lft c)] [(and (number? upp) (number? lft)) (add-line img upp 0 0 lft c)]
[(and (number? upp) (number? rgt)) (add-line img upp 0 w rgt c)] [(and (number? upp) (number? rgt)) (add-line img upp 0 w rgt c)]
[(and (number? low) (number? lft)) (add-line img low h 0 lft c)] [(and (number? low) (number? lft)) (add-line img low h 0 lft c)]
[(and (number? low) (number? rgt)) (add-line img low h w rgt c)] [(and (number? low) (number? rgt)) (add-line img low h w rgt c)]
[(and (number? lft) (number? rgt)) (add-line img 0 lft w rgt c)] [(and (number? lft) (number? rgt)) (add-line img 0 lft w rgt c)]
[else img])]))]))) [else img])]))])))
;; Nat Nat -> Nat ;; Nat Nat -> Nat
;; y if in [0,h], otherwise the closest boundary ;; y if in [0,h], otherwise the closest boundary
@ -163,8 +179,8 @@
;; how to get to (x1,y1) from (x0,y0) ;; how to get to (x1,y1) from (x0,y0)
(define (direction x0 y0 x1 y1) (define (direction x0 y0 x1 y1)
(string->symbol (string->symbol
(string-append (string-append
(if (<= y0 y1) "lower" "upper") "-" (if (<= x0 x1) "right" "left")))) (if (<= y0 y1) "lower" "upper") "-" (if (<= x0 x1) "right" "left"))))
'direction 'direction
(equal? (direction 10 10 0 0) 'upper-left) (equal? (direction 10 10 0 0) 'upper-left)
@ -196,7 +212,7 @@
;; when a field is false, the line doesn't interesect with that side ;; when a field is false, the line doesn't interesect with that side
(define (intersections l w h) (define (intersections l w h)
(values (values
(opt (X l 0) w) (opt (X l h) w) (opt (lyne-y0 l) h) (opt (of l w) h))) (opt (X l 0) w) (opt (X l h) w) (opt (lyne-y0 l) h) (opt (of l w) h)))
;; Number Number -> [Opt Number] ;; Number Number -> [Opt Number]
(define (opt z lft) (if (<= 0 z lft) z false)) (define (opt z lft) (if (<= 0 z lft) z false))
@ -217,13 +233,13 @@
(= (X (make-lyne 1 0) 100) 100) (= (X (make-lyne 1 0) 100) 100)
(equal? (call-with-values (equal? (call-with-values
(lambda () (intersections (points->line -10 -10 110 110) 100 100)) (lambda () (intersections (points->line -10 -10 110 110) 100 100))
list) list)
(list 0 100 0 100)) (list 0 100 0 100))
(equal? (call-with-values (equal? (call-with-values
(lambda () (intersections (points->line 0 10 100 80) 100 100)) (lambda () (intersections (points->line 0 10 100 80) 100 100))
list) list)
(list false false 10 80)) (list false false 10 80))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
@ -231,20 +247,20 @@
(check-pos 'empty-scene width "first") (check-pos 'empty-scene width "first")
(check-pos 'empty-scene height "second") (check-pos 'empty-scene height "second")
(move-pinhole (move-pinhole
(rectangle width height 'outline 'black) (rectangle width height 'outline 'black)
(/ width -2) (/ height -2))) (/ width -2) (/ height -2)))
;; display all images in list in the canvas ;; display all images in list in the canvas
(define (run-movie movie) (define (run-movie movie)
(check-arg 'run-movie (list? movie) "list (of images)" "first" movie) (check-arg 'run-movie (list? movie) "list (of images)" "first" movie)
(for-each (lambda (cand) (check-image 'run-movie cand "first" "list of images")) (for-each (lambda (cand) (check-image 'run-movie cand "first" "list of images"))
movie) movie)
(let run-movie ([movie movie]) (let run-movie ([movie movie])
(cond [(null? movie) #t] (cond [(null? movie) #t]
[(pair? movie) [(pair? movie)
(update-frame (car movie)) (update-frame (car movie))
(sleep/yield .05) (sleep/yield .05)
(run-movie (cdr movie))]))) (run-movie (cdr movie))])))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
@ -271,35 +287,35 @@
(check-pos 'big-bang w "first") (check-pos 'big-bang w "first")
(check-pos 'big-bang h "second") (check-pos 'big-bang h "second")
(check-arg 'big-bang (check-arg 'big-bang
(and (number? delta) (<= 0 delta 1000)) (and (number? delta) (<= 0 delta 1000))
"number [of seconds] between 0 and 1000" "number [of seconds] between 0 and 1000"
"first" "first"
delta) delta)
(when the-frame (error 'big-bang "big-bang already called once")) (when the-frame (error 'big-bang "big-bang already called once"))
(set! the-delta delta) (set! the-delta delta)
(set! the-world world) (set! the-world world)
(set! the-frame (set! the-frame
(new (class frame% (new (class frame%
(super-new) (super-new)
(define/augment (on-close) (define/augment (on-close)
;; shut down the timer when the window is destroyed ;; shut down the timer when the window is destroyed
(send the-time stop) (send the-time stop)
(inner (void) on-close))) (inner (void) on-close)))
(label "DrScheme") (label "DrScheme")
(stretchable-width #f) (stretchable-width #f)
(stretchable-height #f) (stretchable-height #f)
(style '(no-resize-border metal)))) (style '(no-resize-border metal))))
(let ([c (new (class editor-canvas% (let ([c (new (class editor-canvas%
(super-new) (super-new)
(define/override (on-char e) (define/override (on-char e)
(on-char-proc (send e get-key-code))) (on-char-proc (send e get-key-code)))
(define/override (on-event e) (define/override (on-event e)
(on-mouse-proc e))) (on-mouse-proc e)))
(parent the-frame) (parent the-frame)
(editor txt) (editor txt)
(style '(no-hscroll no-vscroll)) (style '(no-hscroll no-vscroll))
(horizontal-inset INSET) (horizontal-inset INSET)
(vertical-inset INSET))]) (vertical-inset INSET))])
(send c min-client-width (+ w INSET INSET)) (send c min-client-width (+ w INSET INSET))
(send c min-client-height (+ h INSET INSET)) (send c min-client-height (+ h INSET INSET))
(send c focus)) (send c focus))
@ -319,15 +335,15 @@
(check-world 'on-tick-event) (check-world 'on-tick-event)
(if (eq? timer-callback void) (if (eq? timer-callback void)
(set! timer-callback (set! timer-callback
(lambda () (lambda ()
(with-handlers ([exn:break? break-handler] (with-handlers ([exn:break? break-handler]
[exn? exn-handler]) [exn? exn-handler])
(set! the-world (f the-world)) (set! the-world (f the-world))
(on-redraw-proc)))) (on-redraw-proc))))
(error 'on-tick "the timing action has been set already")) (error 'on-tick "the timing action has been set already"))
(send the-time start (send the-time start
(let* ([w (ceiling (* 1000 the-delta))]) (let* ([w (ceiling (* 1000 the-delta))])
(if (exact? w) w (inexact->exact w)))) (if (exact? w) w (inexact->exact w))))
#t] #t]
;; --- key and mouse events ;; --- key and mouse events
@ -342,15 +358,15 @@
(if (eq? on-char-proc void) (if (eq? on-char-proc void)
(begin (begin
(set! on-char-proc (set! on-char-proc
(lambda (e) (lambda (e)
(parameterize ([current-eventspace esp]) (parameterize ([current-eventspace esp])
(queue-callback (queue-callback
(lambda () (lambda ()
(with-handlers ([exn:break? break-handler] (with-handlers ([exn:break? break-handler]
[exn? exn-handler]) [exn? exn-handler])
(set! the-world (f the-world e)) (set! the-world (f the-world e))
(on-redraw-proc)))) (on-redraw-proc))))
#t))) #t)))
#t) #t)
(error 'on-event "the event action has been set already")))] (error 'on-event "the event action has been set already")))]
@ -369,29 +385,29 @@
(if (eq? on-mouse-proc void) (if (eq? on-mouse-proc void)
(begin (begin
(set! on-mouse-proc (set! on-mouse-proc
(lambda (e) (lambda (e)
(parameterize ([current-eventspace esp]) (parameterize ([current-eventspace esp])
(queue-callback (queue-callback
(lambda () (lambda ()
(with-handlers ([exn:break? break-handler] (with-handlers ([exn:break? break-handler]
[exn? exn-handler]) [exn? exn-handler])
(set! the-world (f the-world (set! the-world (f the-world
(- (send e get-x) INSET) (- (send e get-x) INSET)
(- (send e get-y) INSET) (- (send e get-y) INSET)
(cond [(send e button-down?) 'button-down] (cond [(send e button-down?) 'button-down]
[(send e button-up?) 'button-up] [(send e button-up?) 'button-up]
[(send e dragging?) 'drag] [(send e dragging?) 'drag]
[(send e moving?) 'move] [(send e moving?) 'move]
[(send e entering?) 'enter] [(send e entering?) 'enter]
[(send e leaving?) 'leave] [(send e leaving?) 'leave]
[else ; (send e get-event-type) [else ; (send e get-event-type)
(error 'on-mouse-event (error 'on-mouse-event
(format (format
"Unknown event type: ~a" "Unknown event type: ~a"
(send e get-event-type)))] (send e get-event-type)))]
))) )))
(on-redraw-proc)))) (on-redraw-proc))))
#t))) #t)))
#t) #t)
(error 'on-mouse-event "the mouse event action has been set already")))) (error 'on-mouse-event "the mouse event action has been set already"))))
#| #|
@ -434,14 +450,14 @@
(if (eq? on-redraw-proc void) (if (eq? on-redraw-proc void)
(begin (begin
(set! on-redraw-proc (set! on-redraw-proc
(lambda () (lambda ()
(with-handlers ([exn:break? break-handler] (with-handlers ([exn:break? break-handler]
[exn? exn-handler]) [exn? exn-handler])
(define img (f the-world)) (define img (f the-world))
(check-result 'on-redraw (lambda (x) (beg:image? x)) "image" img) (check-result 'on-redraw (lambda (x) (beg:image? x)) "image" img)
(when recording? (save-image img)) (when recording? (save-image img))
(update-frame img) (update-frame img)
#t))) #t)))
(on-redraw-proc)) (on-redraw-proc))
(error 'on-redraw "the redraw function has already been specified"))) (error 'on-redraw "the redraw function has already been specified")))
@ -470,15 +486,16 @@
(let () (let ()
(define files (define files
(sort (sort
(filter (lambda (x) (regexp-match #rx"i[0-9]*.png" x)) (filter (lambda (x) (regexp-match #rx"i[0-9]*.png" x))
(map path->string (directory-list))) (map path->string (directory-list)))
(lambda (x y) (lambda (x y)
(<= (string->number (car (regexp-match #rx"[0-9]+" x))) (<= (string->number (car (regexp-match #rx"[0-9]+" x)))
(string->number (car (regexp-match #rx"[0-9]+" y))))))) (string->number (car (regexp-match #rx"[0-9]+" y)))))))
#;
(define cmdline (format "convert -delay 5 ~a ~a.gif" (define cmdline (format "convert -delay 5 ~a ~a.gif"
(apply string-append (map (lambda (x) (format " ~a" x)) files)) (apply string-append (map (lambda (x) (format " ~a" x)) files))
d)) d))
#;
(system cmdline) (system cmdline)
#t)) #t))