move incomplete code to the graveyard.
svn: r8881
This commit is contained in:
Eli Barzilay
parent
944770a4d1
commit
80208a30e5
|
|
@ -1,108 +0,0 @@
|
||||||
#cs(module ping-play-unit mzscheme
|
|
||||||
(require "pingp-sig.ss"
|
|
||||||
(lib "posn.ss" "lang")
|
|
||||||
mzlib/unitsig)
|
|
||||||
(provide ping-play-U)
|
|
||||||
|
|
||||||
(define ping-play-U
|
|
||||||
(unit/sig ppu-S
|
|
||||||
(import pingpS)
|
|
||||||
|
|
||||||
;; ---------------------------------------------------------------------------
|
|
||||||
;; To test: set library to pingp-lib.ss and uncomment the last line.
|
|
||||||
;; The file tests the function play from pingp-lib.ss.
|
|
||||||
;; The file is used to build pinpgp-play-lib.ss.
|
|
||||||
|
|
||||||
;; Speed and its relationship to positions
|
|
||||||
;; ---------------------------------------
|
|
||||||
(define-struct speed (x y))
|
|
||||||
|
|
||||||
;; posn+ : posn vec -> vec
|
|
||||||
(define (posn+ p v)
|
|
||||||
(make-posn (+ (posn-x p) (speed-x v)) (+ (posn-y p) (speed-y v))))
|
|
||||||
|
|
||||||
;; posn*s : number vec -> posn
|
|
||||||
(define (posn*s f p)
|
|
||||||
(make-speed (* f (speed-x p)) (* f (speed-y p))))
|
|
||||||
|
|
||||||
;; vec* : vec vec -> vec
|
|
||||||
(define (vec* v1 v2)
|
|
||||||
(make-speed (* (speed-x v1) (speed-x v2)) (* (speed-y v1) (speed-y v2))))
|
|
||||||
|
|
||||||
;; The ball representation and some basic primitives:
|
|
||||||
;; ---------------------------------------------------
|
|
||||||
(define-struct ball (posn speed))
|
|
||||||
|
|
||||||
;; make-direction : (speed -> num) X Y -> (ball -> (union X Y))
|
|
||||||
(define (make-direction access dir1 dir2)
|
|
||||||
(lambda (ball)
|
|
||||||
(cond
|
|
||||||
((< (access (ball-speed ball)) 0) dir1)
|
|
||||||
((> (access (ball-speed ball)) 0) dir2)
|
|
||||||
(else (error 'make-direction "can't happen")))))
|
|
||||||
|
|
||||||
;; ns-direction : ball -> {'NORTH, 'SOUTH}
|
|
||||||
(define ns-direction (make-direction speed-y 'NORTH 'SOUTH))
|
|
||||||
|
|
||||||
;; ew-direction : ball -> {'EAST, 'WEST}
|
|
||||||
(define ew-direction (make-direction speed-x 'WEST 'EAST))
|
|
||||||
|
|
||||||
;; make-distance : (posn -> num) (ball -> sym) sym num num -> (ball -> num)
|
|
||||||
(define (make-distance direction access dir bound1 bound2)
|
|
||||||
(lambda (ball)
|
|
||||||
(if (eq? (direction ball) dir)
|
|
||||||
(- (access (ball-posn ball)) bound1)
|
|
||||||
(- bound2 (access (ball-posn ball))))))
|
|
||||||
|
|
||||||
;; make-time : (ball -> num) (speed -> num) -> (ball -> number)
|
|
||||||
(define (make-time distance access)
|
|
||||||
(lambda (ball)
|
|
||||||
(/ (distance ball) (abs (access (ball-speed ball))))))
|
|
||||||
|
|
||||||
;; ns-time-to-wall : ball -> number (time before ns wall is hit)
|
|
||||||
(define ns-time-to-wall
|
|
||||||
(make-time (make-distance ns-direction posn-y 'NORTH NORTH SOUTH) speed-y))
|
|
||||||
|
|
||||||
;; ew-time-to-wall : ball -> number (time before ew wall is hit)
|
|
||||||
(define ew-time-to-wall
|
|
||||||
(make-time (make-distance ew-direction posn-x 'WEST WEST EAST) speed-x))
|
|
||||||
|
|
||||||
;; Moving a Ball
|
|
||||||
;; -------------
|
|
||||||
;; move-in-box : ball number -> ball
|
|
||||||
(define (move-in-box ball t)
|
|
||||||
(case (bounces-from ball t)
|
|
||||||
((NORTH SOUTH) (bouncing-move ns-bounce (ns-time-to-wall ball) t ball))
|
|
||||||
((EAST WEST) (bouncing-move ew-bounce (ew-time-to-wall ball) t ball))
|
|
||||||
(else (move-ball ball t))))
|
|
||||||
|
|
||||||
;; bouncing-move : (ball -> ball) num num ball -> ball
|
|
||||||
(define (bouncing-move bounce t-bounce t ball)
|
|
||||||
(move-in-box (bounce (move-ball ball t-bounce)) (- t t-bounce)))
|
|
||||||
|
|
||||||
;; bounces-from : ball number -> {'NORTH, 'SOUTH, 'EAST, 'WEST, 'none}
|
|
||||||
(define (bounces-from ball t)
|
|
||||||
(cond
|
|
||||||
((<= (ns-time-to-wall ball) (min t (ew-time-to-wall ball))) (ns-direction ball))
|
|
||||||
((<= (ew-time-to-wall ball) (min t (ns-time-to-wall ball)))
|
|
||||||
(cond
|
|
||||||
((landed-on-paddle? (ball-posn (move-ball ball (ew-time-to-wall ball))))
|
|
||||||
(ew-direction ball))
|
|
||||||
(else 'none)))
|
|
||||||
(else 'none)))
|
|
||||||
|
|
||||||
;; move : ball number -> ball
|
|
||||||
(define (move-ball ball t)
|
|
||||||
(make-ball (posn+ (ball-posn ball) (posn*s t (ball-speed ball))) (ball-speed ball)))
|
|
||||||
|
|
||||||
;; make-bounce : speed -> (ball -> ball)
|
|
||||||
(define (make-bounce bounceV)
|
|
||||||
(lambda (ball)
|
|
||||||
(make-ball (ball-posn ball) (vec* (ball-speed ball) bounceV))))
|
|
||||||
|
|
||||||
;; ns-bounce : ball -> ball
|
|
||||||
(define ns-bounce (make-bounce (make-speed 1 -1)))
|
|
||||||
|
|
||||||
;; ew-bounce-west : ball -> ball
|
|
||||||
(define ew-bounce (make-bounce (make-speed -1 1)))
|
|
||||||
)))
|
|
||||||
|
|
@ -1,23 +0,0 @@
|
||||||
#cs(module pingp-play mzscheme
|
|
||||||
|
|
||||||
(require "pingp-sig.ss"
|
|
||||||
"pingp.ss"
|
|
||||||
mzlib/unitsig
|
|
||||||
"ping-play-unit.ss")
|
|
||||||
|
|
||||||
(provide pingp-play@)
|
|
||||||
(define pingp-play@
|
|
||||||
(compound-unit/sig
|
|
||||||
(import)
|
|
||||||
(link
|
|
||||||
[PINGP : pingpS (pingpU)]
|
|
||||||
[BALL : ballS (ping-play-U PINGP)]
|
|
||||||
(GO : goS ((unit/sig goS (import ballS pingpS)
|
|
||||||
(define (go s)
|
|
||||||
(printf "Have fun playing, ~a~n" s)
|
|
||||||
(play make-ball make-speed ball-posn move-in-box)))
|
|
||||||
BALL
|
|
||||||
(PINGP : pingpS))))
|
|
||||||
(export (var (PINGP change-speed))
|
|
||||||
(var (PINGP change-wind))
|
|
||||||
(open GO)))))
|
|
||||||
|
|
@ -1,69 +0,0 @@
|
||||||
#cs(module pingp-sig mzscheme
|
|
||||||
(require htdp/draw-sig
|
|
||||||
mzlib/unitsig)
|
|
||||||
(provide pingpS
|
|
||||||
ping-protS-core
|
|
||||||
ping-protS-extr
|
|
||||||
ballS
|
|
||||||
ping-protS
|
|
||||||
ppu-S
|
|
||||||
protectS
|
|
||||||
goS
|
|
||||||
pingp-play^
|
|
||||||
protect-play^)
|
|
||||||
|
|
||||||
;; to be provided to student
|
|
||||||
(define-signature pingpS
|
|
||||||
( play
|
|
||||||
; ((posn posn -> ball) (ball -> posn) (ball -> posn) (ball -> ball) -> void)
|
|
||||||
; make-ball ball-posn ball-speed move/move-in-box
|
|
||||||
landed-on-paddle?
|
|
||||||
protect
|
|
||||||
; ((balls: (listof ball)
|
|
||||||
; (move-balls : (listof ball) -> (listof posn))
|
|
||||||
; (balls-posns :(listof ball) -> (listof ball))
|
|
||||||
; (balls-destroyed : (listof ball) -> (listof ball))) -> void)
|
|
||||||
trace
|
|
||||||
trace-ball
|
|
||||||
;change-width
|
|
||||||
;change-height
|
|
||||||
change-speed
|
|
||||||
change-wind
|
|
||||||
NORTH SOUTH EAST WEST FAR-WEST
|
|
||||||
PADDLE-X
|
|
||||||
PADDLE-Y
|
|
||||||
))
|
|
||||||
|
|
||||||
;; needed from ping-play-unit for playing ping-pong
|
|
||||||
(define-signature ping-protS-core
|
|
||||||
(make-ball make-speed ball-posn))
|
|
||||||
(define-signature ping-protS-extr
|
|
||||||
(ns-bounce ns-time-to-wall ew-time-to-wall move-ball))
|
|
||||||
(define-signature ballS
|
|
||||||
((open ping-protS-core) move-in-box))
|
|
||||||
|
|
||||||
;; needed from ping-play-unit for playing protect-the-wall
|
|
||||||
(define-signature ping-protS
|
|
||||||
((open ping-protS-core) (open ping-protS-extr)))
|
|
||||||
|
|
||||||
;; provided by ping-play-unit
|
|
||||||
(define-signature ppu-S
|
|
||||||
((open ping-protS-core) (open ping-protS-extr) move-in-box))
|
|
||||||
|
|
||||||
;; provided by protect-play-unit
|
|
||||||
(define-signature protectS
|
|
||||||
(mk-balls move-balls remove-balls-hit-paddle remove-outside-balls balls-posn))
|
|
||||||
|
|
||||||
;; provided by the glue units
|
|
||||||
(define-signature goS
|
|
||||||
(go))
|
|
||||||
|
|
||||||
(define-signature pingp-play^
|
|
||||||
((open goS)
|
|
||||||
change-speed
|
|
||||||
change-wind))
|
|
||||||
(define-signature protect-play^
|
|
||||||
((open goS)
|
|
||||||
change-speed
|
|
||||||
change-wind))
|
|
||||||
)
|
|
||||||
|
|
@ -1,284 +0,0 @@
|
||||||
#cs(module pingp mzscheme
|
|
||||||
(require "error.ss"
|
|
||||||
"pingp-sig.ss"
|
|
||||||
"big-draw.ss"
|
|
||||||
mzlib/unitsig
|
|
||||||
(lib "posn.ss" "lang"))
|
|
||||||
|
|
||||||
(provide pingpU)
|
|
||||||
|
|
||||||
(define pingpU
|
|
||||||
(unit/sig pingpS
|
|
||||||
(import)
|
|
||||||
|
|
||||||
;; Exported Functions
|
|
||||||
;; ------------------
|
|
||||||
|
|
||||||
;; trace : posn S (posn S num -> posn) num -> #t
|
|
||||||
(define (trace pos speed f e)
|
|
||||||
; --- error checking: redo
|
|
||||||
(check-arg 'trace (posn? pos) 'posn '1st pos)
|
|
||||||
; the second arg is polymorphic
|
|
||||||
(check-proc 'trace f 3 '3rd "3 arguments")
|
|
||||||
(check-arg 'trace (and (number? e) (> e 0)) "positive number" '4th e)
|
|
||||||
; ---
|
|
||||||
(TT (make-bb pos speed)
|
|
||||||
bb-p
|
|
||||||
(lambda (b t) (let ((s (bb-s b))) (make-bb (f (bb-p b) s t) s)))
|
|
||||||
e))
|
|
||||||
|
|
||||||
(define-struct bb (p s))
|
|
||||||
|
|
||||||
;; trace-ball : X (X -> posn) (X num -> X) number -> #t
|
|
||||||
(define (trace-ball ball ball-posn f e)
|
|
||||||
; --- error checking
|
|
||||||
; the first arg is polymorphic
|
|
||||||
(check-proc 'trace-ball ball-posn 1 '2nd "1 argument")
|
|
||||||
(check-proc 'trace-ball f 2 '3rd "2 arguments")
|
|
||||||
(check-arg 'trace-ball (and (number? e) (> e 0)) "positive number" '4th e)
|
|
||||||
; ---
|
|
||||||
(TT ball ball-posn f e))
|
|
||||||
|
|
||||||
;; play : (posn X -> B) (num num -> S) (B -> posn) (B num -> B) -> #t
|
|
||||||
(define (play make-ball make-speed ball-posn move)
|
|
||||||
(check-proc 'play make-ball 2 '1st "2 arguments")
|
|
||||||
(check-proc 'play make-speed 2 '2nd "2 arguments")
|
|
||||||
(check-proc 'play ball-posn 1 '3rd "1 argument")
|
|
||||||
(check-proc 'play move 2 '4th "2 arguments")
|
|
||||||
(set-pad)
|
|
||||||
(unset-trace)
|
|
||||||
(play2 make-ball make-speed ball-posn move))
|
|
||||||
|
|
||||||
;; landed-on-paddle? : posn -> bool
|
|
||||||
(define (%landed-on-paddle? x)
|
|
||||||
(error 'landed-on-paddle? "can't happen"))
|
|
||||||
(define (landed-on-paddle? aposn)
|
|
||||||
(%landed-on-paddle? aposn))
|
|
||||||
|
|
||||||
;; change-speed : int[> 0] -> void
|
|
||||||
(define (change-speed s)
|
|
||||||
(check-arg 'change-speed (and (integer? s) (> s 0)) "positive integer" '1st s)
|
|
||||||
(set! SLEEP (/ 10 s)))
|
|
||||||
|
|
||||||
;; change-wind : int[> 0] -> void
|
|
||||||
(define (change-wind s)
|
|
||||||
(check-arg 'change-wind (and (integer? s) (> s 0)) "positive integer" '1st s)
|
|
||||||
(set! SWITCH s))
|
|
||||||
|
|
||||||
; ;; change-width : int[> 200] -> void
|
|
||||||
; (define (change-width s)
|
|
||||||
; (check-arg 'change-width (and (integer? s) (> s 200)) "integer [> 200]" '1st s)
|
|
||||||
; (set! EAST s))
|
|
||||||
;
|
|
||||||
; ;; change-height : int[> 200] -> void
|
|
||||||
; (define (change-height s)
|
|
||||||
; (check-arg 'change-height (and (integer? s) (> s 200)) "integer [> 200]" '1st s)
|
|
||||||
; (set! SOUTH s))
|
|
||||||
|
|
||||||
(define NORTH 0)
|
|
||||||
(define SOUTH 400)
|
|
||||||
(define WEST 0)
|
|
||||||
(define EAST 400)
|
|
||||||
(define FAR-WEST (* -1 EAST))
|
|
||||||
|
|
||||||
;; protect : (listof ball)
|
|
||||||
;; ((listof ball) -> (listof ball))
|
|
||||||
;; ((listof ball) -> (listof ball))
|
|
||||||
;; ((listof ball) -> (listof ball))
|
|
||||||
;; ((listof ball) -> (listof posn))
|
|
||||||
;; -> void
|
|
||||||
(define (protect objs move-objs remove-objs-hit-paddle remove-outside-objs objs-posn)
|
|
||||||
; --- error checking
|
|
||||||
(check-arg 'protect (list? objs) 'list '1st objs)
|
|
||||||
(check-proc 'protect move-objs 1 '2nd "1 argument")
|
|
||||||
(check-proc 'protect remove-objs-hit-paddle 1 '3rd "1 argument")
|
|
||||||
(check-proc 'protect remove-outside-objs 1 '4th "1 argument")
|
|
||||||
(check-proc 'protect objs-posn 1 '5th "1 argument")
|
|
||||||
; ---
|
|
||||||
(ready-to-go?)
|
|
||||||
(let* ((objs# (length objs))
|
|
||||||
(PAD_Y0 (- (quotient SOUTH 2) (quotient PAD_LENGTH 2)))
|
|
||||||
(west (box (make-posn 0 0)));; fake: to reuse move-paddle and make-landed
|
|
||||||
(east (box (make-posn (- EAST (+ PAD_WIDTH PAD_DIST_WALL)) PAD_Y0))))
|
|
||||||
(set! %landed-on-paddle? (make-landed-on-paddle east west))
|
|
||||||
(draw-paddle (unbox east))
|
|
||||||
;; --- the loop
|
|
||||||
(let PLAY ((ball0 objs) (p0 (objs-posn objs)) (hits 0))
|
|
||||||
(if (null? ball0)
|
|
||||||
(cond
|
|
||||||
[(= hits 0) (printf "You didn't catch any balls.")]
|
|
||||||
[(= hits 1) (printf "You caught one ball. All others hit the wall.")]
|
|
||||||
[else
|
|
||||||
(printf "You caught ~s balls, ~s hit the wall." hits (- objs# hits))])
|
|
||||||
(begin
|
|
||||||
(for-each draw-ball p0)
|
|
||||||
(sleep SLEEP)
|
|
||||||
(for-each clear-ball p0)
|
|
||||||
(let* ((ball1 (move-objs ball0))
|
|
||||||
(ball2 (remove-objs-hit-paddle ball1))
|
|
||||||
(ball3 (remove-outside-objs ball2))
|
|
||||||
(p1 (objs-posn ball3)))
|
|
||||||
(move-paddle east west (ready-mouse-click (get-@VP)))
|
|
||||||
(PLAY ball3 p1 (+ hits (- (length ball1) (length ball2))))))))
|
|
||||||
;; --- clean up
|
|
||||||
(stop)))
|
|
||||||
|
|
||||||
;; Hidden Definitions
|
|
||||||
;; ==================
|
|
||||||
|
|
||||||
;; Hidden Functions: Tracing and Playing
|
|
||||||
;; -------------------------------------
|
|
||||||
|
|
||||||
;; TT : X (X -> posn) (X -> X) num[n] -> #t
|
|
||||||
;; effect: trace X's movement for n steps on canvas
|
|
||||||
(define (TT ball ball-posn f e)
|
|
||||||
(start2 EAST SOUTH)
|
|
||||||
(let dl ((ball0 ball) (s 1))
|
|
||||||
(if (> s e) #t
|
|
||||||
(let ((ball1 (f ball0 1)))
|
|
||||||
(and
|
|
||||||
(draw-solid-disk (ball-posn ball1) 3 'red)
|
|
||||||
(draw-solid-line (ball-posn ball0) (ball-posn ball1))
|
|
||||||
(dl ball1 (+ s 1)))))))
|
|
||||||
|
|
||||||
; (define (check s make-ball ball-posn move)
|
|
||||||
; (check-proc s make-ball 2 '1st "2 arguments")
|
|
||||||
; (check-proc s ball-posn 1 '2nd "1 argument")
|
|
||||||
; (check-proc s move 2 '3rd "2 arguments"))
|
|
||||||
|
|
||||||
(define (play2 make-ball make-speed ball-posn move)
|
|
||||||
(ready-to-go?)
|
|
||||||
(let* ((rn-10-10 (lambda ()
|
|
||||||
(let ((n (random 20)))
|
|
||||||
(if (< n 10) (- n 10) (- n 9)))))
|
|
||||||
(posn0 (make-posn (quotient EAST 2) (quotient SOUTH 2)))
|
|
||||||
(PAD_Y0 (- (quotient SOUTH 2) (quotient PAD_LENGTH 2)))
|
|
||||||
(west (box (make-posn PAD_DIST_WALL PAD_Y0)))
|
|
||||||
(east (box (make-posn (- EAST (+ PAD_WIDTH PAD_DIST_WALL)) PAD_Y0)))
|
|
||||||
(start-time (current-seconds)))
|
|
||||||
(set! %landed-on-paddle? (make-landed-on-paddle east west))
|
|
||||||
(draw-paddle (unbox west))
|
|
||||||
(draw-paddle (unbox east))
|
|
||||||
;; --- the loop
|
|
||||||
(let play ((ball0 (make-ball posn0 (make-speed (rn-10-10) (rn-10-10)))) (p0 posn0) (i 1))
|
|
||||||
(unless (or (< (posn-x p0) 0) (< EAST (posn-x p0)))
|
|
||||||
(draw-ball p0) (sleep SLEEP) (clear-ball p0)
|
|
||||||
(let* ((ball1 (move ball0 1)) (p1 (ball-posn ball1)))
|
|
||||||
(draw-solid-line p0 p1 TRACE-COLOR)
|
|
||||||
(move-paddle east west (ready-mouse-click (get-@VP)))
|
|
||||||
(if (zero? (modulo i SWITCH))
|
|
||||||
(play (make-ball p1 (make-speed (rn-10-10) (rn-10-10))) p1 1)
|
|
||||||
(play ball1 p1 (add1 i))))))
|
|
||||||
;; --- clean up
|
|
||||||
(printf "You kept the ball in play for ~s seconds.\n" (- (current-seconds) start-time))
|
|
||||||
(stop)))
|
|
||||||
|
|
||||||
;; move-paddle : (box posn) (box posn) (union #f mouse-click) -> void
|
|
||||||
;; effect: modify the appropriate box, if mouse was clicked
|
|
||||||
(define (move-paddle east west mc)
|
|
||||||
(let ((new-posn (and mc (center-paddle (mouse-click-posn mc)))))
|
|
||||||
(cond
|
|
||||||
((not new-posn) (void))
|
|
||||||
((in-west-zone? new-posn) (move-one-paddle west new-posn))
|
|
||||||
((in-east-zone? new-posn) (move-one-paddle east new-posn)))))
|
|
||||||
|
|
||||||
;; move-one-paddle : (box posn) -> void
|
|
||||||
;; effect: modify the boxe, re-draw at appropriate place
|
|
||||||
(define (move-one-paddle a-paddle a-posn)
|
|
||||||
(clear-paddle (unbox a-paddle))
|
|
||||||
(set-box! a-paddle (new-paddle (unbox a-paddle) (posn-y a-posn)))
|
|
||||||
(draw-paddle (unbox a-paddle)))
|
|
||||||
|
|
||||||
;; ready-to-go? : -> void
|
|
||||||
;; effect: set up window, make announcement, wait for user to start the game
|
|
||||||
(define (ready-to-go?)
|
|
||||||
(start2 EAST SOUTH)
|
|
||||||
(draw-solid-rect (make-posn (- (quotient EAST 2) 100) 10) 200 20 BG-COLOR)
|
|
||||||
((draw-string (get-@VP)) (make-posn (- (quotient EAST 2) 65) 20)
|
|
||||||
"Click anywhere when ready!")
|
|
||||||
(let loop () (unless (ready-mouse-click (get-@VP)) (loop)))
|
|
||||||
(draw-solid-rect (make-posn (- (quotient EAST 2) 100) 10) 200 20 BG-COLOR))
|
|
||||||
|
|
||||||
(define (start2 x y)
|
|
||||||
(start x y)
|
|
||||||
(draw-solid-rect (make-posn 0 0) EAST SOUTH BG-COLOR))
|
|
||||||
|
|
||||||
;; The Graphical Ball Representation
|
|
||||||
;; ---------------------------------
|
|
||||||
(define BALL-RADIUS 5)
|
|
||||||
(define (draw-ball p) (draw-solid-disk p BALL-RADIUS 'red))
|
|
||||||
(define (clear-ball p) (draw-solid-disk p BALL-RADIUS 'white))
|
|
||||||
|
|
||||||
;(define (draw-ball p)
|
|
||||||
; (set! draw-ball ((draw-pixmap-posn "Gifs/redball.gif") (get-@VP)))
|
|
||||||
; (draw-ball p))
|
|
||||||
;(define (clear-ball p)
|
|
||||||
; (set! clear-ball ((clear-pixmap-posn "Gifs/redball.gif") (get-@VP)))
|
|
||||||
; (clear-ball p))
|
|
||||||
|
|
||||||
|
|
||||||
;; Global Properties (initialized by set-up!)
|
|
||||||
;; ------------------------------------------
|
|
||||||
|
|
||||||
(define BG-COLOR 'green)
|
|
||||||
(define BALL-COLOR 'red)
|
|
||||||
(define PAD-COLOR 'blue)
|
|
||||||
(define (set-pad) (set! PAD-COLOR 'blue))
|
|
||||||
(define (unset-pad) (set! PAD-COLOR 'white))
|
|
||||||
(define TRACE-COLOR 'white)
|
|
||||||
(define (set-trace) (set! TRACE-COLOR 'green))
|
|
||||||
(define (unset-trace) (set! TRACE-COLOR 'white))
|
|
||||||
|
|
||||||
(define SLEEP .15)
|
|
||||||
(define SWITCH 10000)
|
|
||||||
(define CENTER (quotient EAST 2))
|
|
||||||
(define PADDLE-X EAST)
|
|
||||||
(define PADDLE-Y (quotient SOUTH 2))
|
|
||||||
|
|
||||||
;; The Graphical Paddle Representation
|
|
||||||
;; ------------------------------------
|
|
||||||
(define PAD_WIDTH 3)
|
|
||||||
(define PAD_LENGTH 50)
|
|
||||||
(define PAD_DIST_WALL 0)
|
|
||||||
|
|
||||||
(define (draw-paddle paddle)
|
|
||||||
(draw-solid-rect paddle PAD_WIDTH PAD_LENGTH PAD-COLOR))
|
|
||||||
(define (clear-paddle paddle)
|
|
||||||
(draw-solid-rect paddle PAD_WIDTH PAD_LENGTH BG-COLOR))
|
|
||||||
|
|
||||||
;; center-paddle : posn -> posn
|
|
||||||
(define (center-paddle p)
|
|
||||||
(make-posn (posn-x p) (- (posn-y p) (quotient PAD_LENGTH 2))))
|
|
||||||
|
|
||||||
(define (new-paddle paddle new-y)
|
|
||||||
(make-posn (posn-x paddle) new-y))
|
|
||||||
|
|
||||||
(define (in-west-zone? p) (<= 0 (posn-x p) CENTER))
|
|
||||||
(define (in-east-zone? p) (<= CENTER (posn-x p) EAST))
|
|
||||||
|
|
||||||
;; make-landed-on-paddle :
|
|
||||||
;; (box posn) (box posn) -> ( ball -> boolean )
|
|
||||||
;; to set up landed on paddle
|
|
||||||
(define (make-landed-on-paddle east west)
|
|
||||||
(lambda (pball)
|
|
||||||
(let ((y-pad (posn-y
|
|
||||||
(unbox
|
|
||||||
(cond
|
|
||||||
((= EAST (posn-x pball)) east)
|
|
||||||
((= WEST (posn-x pball)) west)
|
|
||||||
(else (error 'landed-on-paddle
|
|
||||||
"this ball has not reached a wall: ~s" pball)))))))
|
|
||||||
(<= y-pad (posn-y pball) (+ y-pad PAD_LENGTH)))))
|
|
||||||
|
|
||||||
;; landed-on-paddle : the paddles are initially in the middle of the
|
|
||||||
;; two walls
|
|
||||||
(set! %landed-on-paddle?
|
|
||||||
(make-landed-on-paddle
|
|
||||||
(box (make-posn
|
|
||||||
(- PAD_DIST_WALL WEST)
|
|
||||||
(- (quotient SOUTH 2) (quotient PAD_LENGTH 2))))
|
|
||||||
(box (make-posn
|
|
||||||
(- EAST (+ PAD_WIDTH PAD_DIST_WALL))
|
|
||||||
(- (quotient SOUTH 2) (quotient PAD_LENGTH 2))))))
|
|
||||||
|
|
||||||
)))
|
|
||||||
|
|
@ -1,103 +0,0 @@
|
||||||
#cs(module protect-play-unit mzscheme
|
|
||||||
(provide protect-play-U)
|
|
||||||
(require mzlib/unitsig
|
|
||||||
"pingp-sig.ss"
|
|
||||||
mzlib/list
|
|
||||||
(lib "posn.ss" "lang"))
|
|
||||||
|
|
||||||
(define protect-play-U
|
|
||||||
(unit/sig protectS
|
|
||||||
(import ping-protS pingpS)
|
|
||||||
|
|
||||||
;; Adapting the relevant functions from the pingp game
|
|
||||||
;; ---------------------------------------------------
|
|
||||||
|
|
||||||
;; move-in-box : ball number -> ball or #f (if the ball gets destroyed)
|
|
||||||
(define (move-in-box ball t)
|
|
||||||
(case (bounces-off ball t)
|
|
||||||
((NORTH-SOUTH)
|
|
||||||
(move-in-box
|
|
||||||
(ns-bounce
|
|
||||||
(move-ball ball (ns-time-to-wall ball)))
|
|
||||||
(- t (ns-time-to-wall ball))))
|
|
||||||
((PADDLE) #f)
|
|
||||||
(else (move-ball ball t))))
|
|
||||||
|
|
||||||
;; bounces-off : ball number -> {'NORTH-SOUTH,'PADDLE,'none}
|
|
||||||
(define (bounces-off ball t)
|
|
||||||
(cond
|
|
||||||
((<= (ns-time-to-wall ball) (min (ew-time-to-wall ball) t)) 'NORTH-SOUTH)
|
|
||||||
((<= (ew-time-to-wall ball) (min (ns-time-to-wall ball) t))
|
|
||||||
(cond
|
|
||||||
[(landed-on-paddle? (ball-posn (move-ball ball (ew-time-to-wall ball))))
|
|
||||||
'PADDLE]
|
|
||||||
[else 'none]))
|
|
||||||
(else 'none)))
|
|
||||||
|
|
||||||
|
|
||||||
;; Dealing with collections of balls
|
|
||||||
;; ---------------------------------
|
|
||||||
|
|
||||||
;; mk-balls : natnum -> list-of-balls
|
|
||||||
(define (mk-balls a-nn)
|
|
||||||
(cond
|
|
||||||
((zero? a-nn) null)
|
|
||||||
(else
|
|
||||||
(cons
|
|
||||||
(make-ball (make-posn (random-between FAR_WEST EAST) (random SOUTH))
|
|
||||||
(make-speed (random-between MIN-X-SPEED MAX-X-SPEED)
|
|
||||||
(random-between MIN-Y-SPEED MAX-Y-SPEED)))
|
|
||||||
(mk-balls (- a-nn 1))))))
|
|
||||||
|
|
||||||
;; random-between : int int -> int (randomly in betweeen he two inputs)
|
|
||||||
(define (random-between low high)
|
|
||||||
(+ low (random (+ (abs low) (abs high)))))
|
|
||||||
|
|
||||||
;; move-balls : list-of-balls -> list-of-balls
|
|
||||||
(define (move-balls loballs)
|
|
||||||
(cond
|
|
||||||
((null? loballs) null)
|
|
||||||
(else (cons (move-in-box (first loballs) 1) (move-balls (rest loballs))))))
|
|
||||||
|
|
||||||
;; remove-balls-hit-paddle : list-of-balls/#f -> list-of-balls
|
|
||||||
;; (those that hit paddle during a move or are outside after a move)
|
|
||||||
(define (remove-balls-hit-paddle loballs)
|
|
||||||
(cond
|
|
||||||
((null? loballs) null)
|
|
||||||
(else (cond
|
|
||||||
((boolean? (first loballs))
|
|
||||||
(remove-balls-hit-paddle (rest loballs)))
|
|
||||||
(else
|
|
||||||
(cons (first loballs) (remove-balls-hit-paddle (rest loballs))))))))
|
|
||||||
|
|
||||||
;; remove-outside-balls : list-of-balls -> list-of-balls
|
|
||||||
;; (those that hit paddle during a move or are outside after a move)
|
|
||||||
(define (remove-outside-balls loballs)
|
|
||||||
(cond
|
|
||||||
((null? loballs) null)
|
|
||||||
(else (cond
|
|
||||||
((inside? (first loballs))
|
|
||||||
(cons (first loballs) (remove-outside-balls (rest loballs))))
|
|
||||||
(else
|
|
||||||
(remove-outside-balls (rest loballs)))))))
|
|
||||||
|
|
||||||
;; inside? : ball -> boolean (is the ball inside the user-defined space)
|
|
||||||
(define (inside? aball)
|
|
||||||
(and (<= FAR_WEST (posn-x (ball-posn aball)) EAST)
|
|
||||||
(<= NORTH (posn-y (ball-posn aball)) SOUTH)))
|
|
||||||
|
|
||||||
;; balls-posn : list-of-balls -> list-of-posn (a projection)
|
|
||||||
(define (balls-posn l)
|
|
||||||
(cond
|
|
||||||
((null? l) null)
|
|
||||||
(else (cons (ball-posn (first l)) (balls-posn (rest l))))))
|
|
||||||
|
|
||||||
;; the true extent of the space
|
|
||||||
(define FAR_WEST (* -1 EAST))
|
|
||||||
|
|
||||||
(define MIN-X-SPEED 05)
|
|
||||||
(define MAX-X-SPEED 15)
|
|
||||||
(define MIN-Y-SPEED 1)
|
|
||||||
(define MAX-Y-SPEED 4)
|
|
||||||
|
|
||||||
)))
|
|
||||||
|
|
@ -1,30 +0,0 @@
|
||||||
#cs(module protect-play mzscheme
|
|
||||||
(require "pingp-sig.ss"
|
|
||||||
"protect-play-unit.ss"
|
|
||||||
"ping-play-unit.ss"
|
|
||||||
"pingp.ss"
|
|
||||||
mzlib/unitsig)
|
|
||||||
|
|
||||||
(provide protect-play@)
|
|
||||||
(define protect-play@
|
|
||||||
(compound-unit/sig
|
|
||||||
(import)
|
|
||||||
(link
|
|
||||||
[PINGP : pingpS (pingpU)]
|
|
||||||
[BALL : ping-protS (ping-play-U PINGP)]
|
|
||||||
[PROT : protectS (protect-play-U BALL PINGP)]
|
|
||||||
(GO : goS ((unit/sig goS (import protectS pingpS)
|
|
||||||
(define n (+ 10 (random 10)))
|
|
||||||
(define (go s)
|
|
||||||
(set! n (+ 10 (random 10)))
|
|
||||||
(printf "You're facing ~a balls. Have fun playing, ~a~n" n s)
|
|
||||||
(protect (mk-balls n)
|
|
||||||
move-balls
|
|
||||||
remove-balls-hit-paddle
|
|
||||||
remove-outside-balls
|
|
||||||
balls-posn)))
|
|
||||||
PROT
|
|
||||||
(PINGP : pingpS))))
|
|
||||||
(export (var (PINGP change-speed))
|
|
||||||
(var (PINGP change-wind))
|
|
||||||
(open GO)))))
|
|
||||||
|
|
@ -1,51 +0,0 @@
|
||||||
(module rectangle mzscheme
|
|
||||||
(require htdp/error
|
|
||||||
htdp/draw-sig
|
|
||||||
htdp/big-draw
|
|
||||||
mzlib/unitsig
|
|
||||||
mzlib/list
|
|
||||||
(lib "posn.ss" "lang"))
|
|
||||||
|
|
||||||
(provide show)
|
|
||||||
|
|
||||||
(define-primitive show show/proc)
|
|
||||||
|
|
||||||
;; do we really need this? Can't they load draw as well instead?
|
|
||||||
(provide-signature-elements draw^)
|
|
||||||
|
|
||||||
;; show : rectangle -> #t
|
|
||||||
(define (show/proc rect)
|
|
||||||
(check-arg 'show
|
|
||||||
(and (list? rect) (andmap (lambda (l) (and (list? l) (andmap rgb? l))) rect))
|
|
||||||
"rectangle (list of list of colors)" "" rect)
|
|
||||||
|
|
||||||
(clear-all)
|
|
||||||
|
|
||||||
(let ((x 0) (y 0))
|
|
||||||
(for-each (lambda (line)
|
|
||||||
(for-each (lambda (color)
|
|
||||||
(draw-square x y color)
|
|
||||||
(set! x (+ x LENGTH-SQUARE)))
|
|
||||||
line)
|
|
||||||
(set! x 0)
|
|
||||||
(set! y (+ y LENGTH-SQUARE)))
|
|
||||||
rect)
|
|
||||||
#t))
|
|
||||||
|
|
||||||
;; could be done by students -- after they learn about accumulators
|
|
||||||
(define (show2 rect)
|
|
||||||
(let OL ((rect rect) (y 0))
|
|
||||||
(cond
|
|
||||||
((null? rect) #t)
|
|
||||||
(else (let IL ((line (first rect)) (x 0))
|
|
||||||
(cond
|
|
||||||
((null? line) (void))
|
|
||||||
(else (and (draw-square x y (first line))
|
|
||||||
(IL (rest line) (+ x LENGTH-SQUARE))))))
|
|
||||||
(OL (rest rect) (+ y LENGTH-SQUARE))))))
|
|
||||||
|
|
||||||
;; draw-square : number number symbol -> #t
|
|
||||||
(define (draw-square y x c)
|
|
||||||
(draw-solid-rect (make-posn y x) LENGTH-SQUARE LENGTH-SQUARE c))
|
|
||||||
|
|
||||||
(define LENGTH-SQUARE 10))
|
|
||||||
Loading…
Reference in New Issue
Block a user