From 80208a30e54adef4e5d5b31d41d415c2e2068c74 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 4 Mar 2008 20:39:30 +0000 Subject: [PATCH] move incomplete code to the graveyard. svn: r8881 --- collects/htdp/HtDPv0/ping-play-unit.ss | 108 -------- collects/htdp/HtDPv0/pingp-play.ss | 23 -- collects/htdp/HtDPv0/pingp-sig.ss | 69 ------ collects/htdp/HtDPv0/pingp.ss | 284 ---------------------- collects/htdp/HtDPv0/protect-play-unit.ss | 103 -------- collects/htdp/HtDPv0/protect-play.ss | 30 --- collects/htdp/HtDPv0/rectangle.ss | 51 ---- 7 files changed, 668 deletions(-) delete mode 100644 collects/htdp/HtDPv0/ping-play-unit.ss delete mode 100644 collects/htdp/HtDPv0/pingp-play.ss delete mode 100644 collects/htdp/HtDPv0/pingp-sig.ss delete mode 100644 collects/htdp/HtDPv0/pingp.ss delete mode 100644 collects/htdp/HtDPv0/protect-play-unit.ss delete mode 100644 collects/htdp/HtDPv0/protect-play.ss delete mode 100644 collects/htdp/HtDPv0/rectangle.ss diff --git a/collects/htdp/HtDPv0/ping-play-unit.ss b/collects/htdp/HtDPv0/ping-play-unit.ss deleted file mode 100644 index d77c5f4934..0000000000 --- a/collects/htdp/HtDPv0/ping-play-unit.ss +++ /dev/null @@ -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))) - ))) diff --git a/collects/htdp/HtDPv0/pingp-play.ss b/collects/htdp/HtDPv0/pingp-play.ss deleted file mode 100644 index 043b7ed444..0000000000 --- a/collects/htdp/HtDPv0/pingp-play.ss +++ /dev/null @@ -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))))) diff --git a/collects/htdp/HtDPv0/pingp-sig.ss b/collects/htdp/HtDPv0/pingp-sig.ss deleted file mode 100644 index 72640bc12e..0000000000 --- a/collects/htdp/HtDPv0/pingp-sig.ss +++ /dev/null @@ -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)) -) diff --git a/collects/htdp/HtDPv0/pingp.ss b/collects/htdp/HtDPv0/pingp.ss deleted file mode 100644 index bc95d18b2a..0000000000 --- a/collects/htdp/HtDPv0/pingp.ss +++ /dev/null @@ -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)))))) - - ))) diff --git a/collects/htdp/HtDPv0/protect-play-unit.ss b/collects/htdp/HtDPv0/protect-play-unit.ss deleted file mode 100644 index fcfebde022..0000000000 --- a/collects/htdp/HtDPv0/protect-play-unit.ss +++ /dev/null @@ -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) - - ))) diff --git a/collects/htdp/HtDPv0/protect-play.ss b/collects/htdp/HtDPv0/protect-play.ss deleted file mode 100644 index d57f7b1764..0000000000 --- a/collects/htdp/HtDPv0/protect-play.ss +++ /dev/null @@ -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))))) diff --git a/collects/htdp/HtDPv0/rectangle.ss b/collects/htdp/HtDPv0/rectangle.ss deleted file mode 100644 index ff04bee4e1..0000000000 --- a/collects/htdp/HtDPv0/rectangle.ss +++ /dev/null @@ -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))