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

improved the cat slightly (by making it less predictable) and added a help button

Browse Source 
svn: r12326
This commit is contained in:
Robby Findler 2008-11-06 14:55:08 +00:00
parent 1804f76932
commit 7872b59070
2 changed files with 64 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/games/chat-noir/chat-noir-unit.ss
View File

@ -1,6 +1,10 @@
#lang scheme/base
(require scheme/unit
scheme/runtime-path
scheme/gui/base
scheme/class
"../show-scribbling.ss"
string-constants/string-constant
(prefix-in x: lang/htdp-intermediate-lambda)
(prefix-in x: htdp/world))
@ -15,4 +19,18 @@
(parameterize ([current-namespace ns])
(namespace-attach-module orig-namespace '(lib "mred.ss" "mred"))
(namespace-attach-module orig-namespace '(lib "class.ss" "scheme"))
(dynamic-require chat-noir #f)))
(dynamic-require chat-noir #f))
;; a hack.
;; this adds a help button to the world.ss window
(let ([fs (get-top-level-windows)])
(unless (null? fs)
(let ([f (car fs)]
[show-help
(show-scribbling
'(lib "games/scribblings/games.scrbl")
"chat-noir")])
(new button%
[parent f]
[callback (λ (x y) (show-help))]
[label (string-constant help)])))))

103
collects/games/chat-noir/chat-noir.ss
View File

@ -681,12 +681,16 @@ making some of the test cases much easier to manage.
(local [(define cat-position (world-cat world))
(define table (build-table/fast world))
(define neighbors (adjacent cat-position (world-size world)))
(define next-cat-positions
(find-best-positions neighbors
(map (lambda (p) (lookup-in-table table p))
neighbors)))
(define next-cat-position
(find-best-position (first neighbors)
(lookup-in-table table (first neighbors))
(rest neighbors)
(map (lambda (p) (lookup-in-table table p))
(rest neighbors))))]
(cond
[(boolean? next-cat-positions) false]
[else
(list-ref next-cat-positions
(random (length next-cat-positions)))]))]
(make-world (world-board world)
(cond
[(boolean? next-cat-position)
@ -700,6 +704,7 @@ making some of the test cases much easier to manage.
[else 'playing])
(world-size world))))
(check-expect
(move-cat
(make-world (list (make-cell (make-posn 1 0) false)
@ -763,60 +768,42 @@ making some of the test cases much easier to manage.
'playing
5))
;; find-best-position : (nelistof posn) (nelistof number or '∞)
;; -> posn or #f
;; returns #f if there is no non-infinite move, otherwise returns
;; the next step for the cat.
(define (find-best-position best-posn score rest-posns scores)
(cond
[(empty? rest-posns)
(cond
[(equal? score '∞)
false]
[else
best-posn])]
[else (cond
[(<=/f score (first scores))
(find-best-position best-posn
score
(rest rest-posns)
(rest scores))]
[else
(find-best-position (first rest-posns)
(first scores)
(rest rest-posns)
(rest scores))])]))
(check-expect (find-best-position (make-posn 1 1)
1
(list (make-posn 2 2))
(list 2))
(make-posn 1 1))
(check-expect (find-best-position (make-posn 1 1)
'∞
(list)
(list))
;; find-best-positions : (nelistof posn) (nelistof number or '∞) -> (nelistof posn) or false
(define (find-best-positions posns scores)
(local [(define best-score (foldl (lambda (x sofar)
(if (<=/f x sofar)
x
sofar))
(first scores)
(rest scores)))]
(cond
[(symbol? best-score) false]
[else
(map
second
(filter (lambda (x) (equal? (first x) best-score))
(map list scores posns)))])))
(check-expect (find-best-positions (list (make-posn 0 0)) (list 1))
(list (make-posn 0 0)))
(check-expect (find-best-positions (list (make-posn 0 0)) (list '∞))
false)
(check-expect (find-best-positions (list (make-posn 0 0)
(make-posn 1 1))
(list 1 2))
(list (make-posn 0 0)))
(check-expect (find-best-positions (list (make-posn 0 0)
(make-posn 1 1))
(list 1 1))
(list (make-posn 0 0)
(make-posn 1 1)))
(check-expect (find-best-positions (list (make-posn 0 0)
(make-posn 1 1))
(list '∞ 2))
(list (make-posn 1 1)))
(check-expect (find-best-positions (list (make-posn 0 0)
(make-posn 1 1))
(list '∞ '∞))
false)
(check-expect (find-best-position (make-posn 2 2)
2
(list)
(list))
(make-posn 2 2))
(check-expect (find-best-position (make-posn 2 2)
2
(list (make-posn 1 1))
(list 1))
(make-posn 1 1))
(check-expect (find-best-position (make-posn 2 2)
'∞
(list (make-posn 1 1))
(list 1))
(make-posn 1 1))
(check-expect (find-best-position (make-posn 2 2)
2
(list (make-posn 1 1))
(list '∞))
(make-posn 2 2))
;; add-obstacle : board number number -> board
(define (add-obstacle board x y)