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

world with lang scheme

Browse Source 
svn: r10331
This commit is contained in:
Matthias Felleisen 2008-06-18 02:13:42 +00:00
parent 420263b569
commit 55604117e4
2 changed files with 843 additions and 847 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/htdp/Test/world.ss
View File

@ -2,25 +2,19 @@
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world) (read-case-sensitive #t) (teachpacks ((lib "world.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "world.ss" "teachpack" "htdp")))))
;; testing world
;; World = Nat
(define world0 10)
(define world0 100)
(define (world->image w)
(place-image (circle 3 'solid 'red)
50 w
(empty-scene 100 100)))
(place-image (circle 3 'solid 'red) 50 w (empty-scene 100 100)))
(define (world->next w)
(if (>= (+ w 3) 100)
100
(+ w 1)))
(define (world->next w) (sub1 w))
(define (world->steer w ke)
(cond
[(char? ke) w]
[(symbol=? ke 'left) 10]
[(symbol=? ke 'left) 100]
[(symbol=? ke 'right) 90]
[else w]))
@ -31,4 +25,4 @@
(on-redraw world->image)
(on-tick-event world->next)
(on-key-event world->steer)
(is-end-of-world (lambda (w) (= w 100)))
(stop-when zero?)

44
collects/htdp/world.ss
View File

@ -1,6 +1,6 @@
;; Mon Jun 16 15:38:14 EDT 2008: removed end-of-time and provided is-end-of-time
;; Mon Jun 16 15:38:14 EDT 2008: removed end-of-time and provided stop-when
;; also allow repeated setting of callbacks now
;; If this is changed back, is-end-of-world will fail
;; If this is changed back, stop-when will fail
;; Wed Apr 23 11:42:25 EDT 2008: fixed reverse bug in animation
;; Thu Mar 20 17:15:54 EDT 2008: fixed place-image0, which used shrink off-by-1
@ -45,13 +45,14 @@ Matthew
;; Sat Dec 10 19:39:03 EST 2005: fixed name, changed interface to on-key-event
;; Fri Dec 9 21:39:03 EST 2005: remoevd (update ... produce ...); added on-redraw
;; Thu Dec 1 17:03:03 EST 2005: fixed place-image; all coordinates okay now
(module world mzscheme
#lang scheme
(require mzlib/class
mzlib/kw
mzlib/etc
mred
htdp/error
htdp/image
(only lang/htdp-beginner image?)
(only-in lang/htdp-beginner image?)
mrlib/cache-image-snip
lang/prim)
@ -82,7 +83,7 @@ Matthew
;; image manipulation functions:
;; =============================
(provide (all-from htdp/image))
(provide (all-from-out htdp/image))
(provide
;; Scene is Image with pinhole in origin
@ -128,7 +129,7 @@ Matthew
)
(provide-higher-order-primitive
is-end-of-world (last-world) ;; (World -> Boolean) -> true
stop-when (last-world) ;; (World -> Boolean) -> true
)
(provide-higher-order-primitive
@ -284,10 +285,10 @@ Matthew
(set-mouse-callback f (current-eventspace))
#t)
(define (is-end-of-world f)
(check-proc 'is-end-of-world f 1 "is-end-of-world" "one argument")
(check-world 'is-end-of-world)
(set-is-end-of-world-callback f)
(define (stop-when f)
(check-proc 'stop-when f 1 "stop-when" "one argument")
(check-world 'stop-when)
(set-stop-when-callback f)
#t)
(define (run-movie movie)
@ -734,7 +735,8 @@ Matthew
(update-frame (text (format "~a/~a created" image-count total) 18 'red))
(save-image img)
(cond
[(null? ev) (update-frame (text "creating i-animated.gif" 18 'red))
[(null? ev)
(update-frame (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red))
(create-animated-gif (reverse bitmap-list))
(update-frame img)]
[else
@ -748,7 +750,7 @@ Matthew
(define intv (if (> +inf.0 *the-delta* 0) (inexact->exact (floor (* 100 *the-delta*))) 5))
(when (file-exists? ANIMATED-GIF-FILE)
(delete-file ANIMATED-GIF-FILE))
(write-animated-gif bitmap-list intv ANIMATED-GIF-FILE #:one-at-a-time? #t))
(write-animated-gif bitmap-list intv ANIMATED-GIF-FILE #;one-at-a-time? #t))
(define ANIMATED-GIF-FILE "i-animated.gif")
@ -768,7 +770,7 @@ Matthew
;
;
;; callbacks: timer, mouse, key, redraw, is-end-of-world
;; callbacks: timer, mouse, key, redraw, stop-when
;; Definition = (define-callback Symbol String Symbol Expression ...)
;; effect: (define-callback introduces three names: name, name0, set-name
@ -779,9 +781,9 @@ Matthew
[callback (lambda (before after)
(string->symbol
(string-append before n:str "-callback" after)))]
[name (datum->syntax-object stx (callback "" ""))]
[name0 (datum->syntax-object stx (callback "" "0"))]
[set-name (datum->syntax-object stx (callback "set-" ""))])
[name (datum->syntax stx (callback "" ""))]
[name0 (datum->syntax stx (callback "" "0"))]
[set-name (datum->syntax stx (callback "set-" ""))])
#`(define-values (#,name #,name0 #,set-name)
(values
void void
@ -798,7 +800,7 @@ Matthew
(set! timer-callback void)
(set! mouse-callback void)
(set! key-callback void)
(set! is-end-of-world-callback (lambda (w) #f))
(set! stop-when-callback (lambda (w) #f))
(set! redraw-callback void))
;; Any -> Boolean
@ -828,17 +830,17 @@ Matthew
(check-result tname (lambda (x) (image? x)) "scene" result))
(update-frame result)
;; if this world is the last one, stop the world
(when (is-end-of-world-callback)
(when (stop-when-callback)
(callback-stop!))))
;; f : [World -> Boolean]
(define-callback is-end-of-world "is end of world check" (f) ()
(define-callback stop-when "is end of world check" (f) ()
(define result (f the-world))
(define fname (object-name f))
(define tname (if fname fname 'your-redraw-function))
(check-result fname boolean? "boolean" result)
result)
(set-is-end-of-world-callback (lambda (w) #f))
(set-stop-when-callback (lambda (w) #f))
;; f : [World KeyEvent -> World]
;; esp : EventSpace
@ -894,4 +896,4 @@ Matthew
;; Number -> Integer
(define (number->integer x)
(inexact->exact (floor x)))
)