diff --git a/collects/2htdp/uchat/chatter.ss b/collects/2htdp/uchat/chatter.ss new file mode 100644 index 0000000000..43dc284d48 --- /dev/null +++ b/collects/2htdp/uchat/chatter.ss @@ -0,0 +1,369 @@ +;; The first three lines of this file were inserted by DrScheme. They record metadata +;; 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 chatter) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +(require 2htdp/universe) + +#| + + +------------------------------------------------------------------+ + | from: text text text text text text | + | from*: text text text text text text | + | ... | + | ... | + +------------------------------------------------------------------+ + | to: text text text text text text | + | *: text text text text text text | + | to2: text blah text[] | + | ... | + +------------------------------------------------------------------+ + + Convention: the names of participants may not contain ":". + The first typed ":" separates the addressess from the message. + + TODO: + -- delete key during editing. should it work? + +|# + +; +; +; ;; ;; ;;; +; ; ; ; ; +; ;; ; ;;; ;;;;; ;;; ;; ; ;;; ;;;;; +; ; ;; ; ; ; ; ; ; ;; ; ; ; +; ; ; ;;;; ; ;;;; ; ; ;;;;; ; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;;;; ;;;;; ;;; ;;;;; ;;;;; ;;;; ;;;;; +; +; +; +; + +(define-struct world (todraft mmdraft from to)) +(define-struct messg (addr text)) + +;; World = (make-world StrFl StrFl (Listof Line) (Listof Line)) +;; StrFl = String or false +;; Line = (make-messg String String) +;; WorldPackage = (make-package World (list String String)) + +(define WIDTH 400) +(define HEIGHT 300) +(define MID (/ HEIGHT 2)) + +;; visual constants + +(define SP " ") + +(define MT (scene+line (empty-scene WIDTH HEIGHT) 0 MID WIDTH MID "black")) +(define BLANK (rectangle WIDTH 11 "outline" "white")) + +(define CURSOR (rectangle 3 11 "solid" "red")) + +; +; +; ;; +; ; +; ;; ;; ;;; ;; ;; ;; ; ;;; ;; ;; +; ;; ; ; ;; ; ; ;; ; ; ;; +; ; ;;;;; ; ; ; ; ;;;;; ; +; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; +; ;;;;; ;;;; ;;; ;;; ;;;;; ;;;; ;;;;; +; +; +; +; + +;; World -> Scene +;; render the world as a scene +(define (render w) + (local ((define fr (line*-render (world-from w))) + (define t1 (line*-render (world-to w))) + (define last-to-line (line-render-cursor (world-todraft w) (world-mmdraft w))) + (define tt (image-stack t1 last-to-line))) + (place-image fr 1 1 (place-image tt 1 MID MT)))) + +;; ----------------------------------------------------------------------------- +;; [Listof Line] -> Image +;; render this list of lines +(define (line*-render lines) + (cond + [(empty? lines) (circle 0 "solid" "red")] + [else + (local ((define fst (first lines))) + (image-stack (line-render (messg-addr fst) (messg-text fst)) + (line*-render (rest lines))))])) + +;; ----------------------------------------------------------------------------- +;; Line -> Image +;; render a single display line + +(define result0 (text (string-append SP "ada: hello") 11 "black")) +(check-expect (line-render "ada" "hello") result0) + +(check-expect (line-render false "hello") + (text (string-append SP ": hello") 11 "black")) + +(check-expect (line-render "ada" false) + (text (string-append SP "ada: ") 11 "black")) + +(define (line-render addr msg) + (local ((define addr* (if (boolean? addr) "" addr)) + (define msg* (if (boolean? msg) "" msg))) + (text (string-append SP addr* ": " msg*) 11 "black"))) + +;; ----------------------------------------------------------------------------- +;; Line -> Image +;; render a single display line + +(check-expect (line-render-cursor "ada" "hello") (image-append result0 CURSOR)) + +(define (line-render-cursor addr msg) + (local ((define r (line-render addr msg))) + (image-append r CURSOR))) + +; +; +; ; +; +; ;; ;;;; ;; ;;; ;;; ;; ;; ;; ;; +; ; ;; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ;;;; ; ; ;; +; ; ; ; ; ; ; ; ; ; ;; +; ; ; ; ;; ; ; ; ; ;; ; ; +; ;;;; ;; ;; ;;;;; ;;;;; ;; ;;;; ;; +; ; +; ;;; +; +; + +;; Image Image -> Image +;; stack two images along left vertical + +(check-expect (image-stack (rectangle 10 20 "solid" "red") + (rectangle 10 20 "solid" "red")) + (put-pinhole (rectangle 10 40 "solid" "red") 0 0)) + +(define (image-stack i j) + (overlay/xy (put-pinhole i 0 0) 0 (image-height i) (put-pinhole j 0 0))) + +;; Image Image -> Image +;; append two images along bottom line + +(check-expect (image-append (rectangle 10 20 "solid" "red") + (rectangle 10 20 "solid" "red")) + (put-pinhole (rectangle 20 20 "solid" "red") 0 0)) + +(check-expect (image-append (rectangle 10 20 "solid" "red") + (rectangle 10 10 "solid" "red")) + (overlay/xy (put-pinhole (rectangle 10 20 "solid" "red") 0 0) + 10 10 + (put-pinhole (rectangle 10 10 "solid" "red") 0 0))) + +(define (image-append i j) + (local ((define hi (image-height i)) + (define hj (image-height j))) + (overlay/xy (put-pinhole i 0 0) (image-width i) (- hi hj) (put-pinhole j 0 0)))) + +; +; +; ;; ; ;; +; ; ; ; +; ;;; ;; ; ;;; ;;;;; ;; ;;;; ;;; ;; ;; ;; ; +; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; +; ;;;;; ; ; ; ; ; ;;; ;;;;; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;;; ;;;;; ;;;;; ;;; ;; ; ;;;; ;;;; ;;; ;;; ;;;;; +; +; +; +; + +;; World String -> World u WorldPackage +;; add char to address (unless ":"); otherwise to message draft +;; if line is too wide to display, send off the message + +;; edit a text: one char at a time until +;; -- (1) ":" which is the name or +;; -- (2) "\r"/rendering a line is wider than the window +;; WHAT HAPPENS IF THE LINE BECOMES WIDER THAN THE BUFFER BEFORE ":" ? + +(define w0 (make-world false false '() '())) +(define WIDE-STRING (replicate WIDTH "m")) + +(check-expect (react w0 ":") w0) +(check-expect (react w0 " ") w0) +(check-expect (react w0 "a") (make-world "a" false '() '())) +(check-expect (react (make-world "a" false '() '()) "d") + (make-world "ad" false '() '())) +(check-expect (react (make-world "ada" false '() '()) ":") + (make-world "ada" "" '() '())) +(check-expect (react (make-world "ada" false '() '()) "left") + (make-world "ada" false '() '())) +(check-expect (react (make-world "ada" "" '() '()) " ") + (make-world "ada" " " '() '())) +(check-expect (react (make-world "ada" "" '() '()) "left") + (make-world "ada" "" '() '())) +(check-expect (react (make-world "ada" "" '() '()) "h") + (make-world "ada" "h" '() '())) +(check-expect (react (make-world "ada" "h" '() '()) ":") + (make-world "ada" "h:" '() '())) +(check-expect (react w0 "\r") w0) +(check-expect (react (make-world "ada" "x" '() '()) "\r") + (send "ada" "x" '() '())) +(check-expect (react (make-world "ada" false '() '()) "\r") + (send "ada" "" '() '())) +(check-expect (react (make-world "ada" WIDE-STRING '() '()) "x") + (send "ada" WIDE-STRING '() '())) +(check-expect (react (make-world WIDE-STRING false '() '()) "x") + (send WIDE-STRING "" '() '())) + +(define (react w key) + (local ((define mm (world-mmdraft w)) + (define to (world-todraft w)) + (define from* (world-from w)) + (define to* (world-to w))) + (cond + [(key=? "\r" key) + (if (boolean? to) w (send to (if (boolean? mm) "" mm) from* to*))] + [(key=? ":" key) + (cond + [(boolean? to) w] + [(boolean? mm) (world-mmdraft! w "")] + ;; (and (string? to) (string? mm)) + ;; so this string belongs to the end of mm + [else (world-mmdraft! w (string-append mm ":"))])] + [else + (cond + [(and (boolean? to) (boolean? mm)) + ;; the key belongs into the address; it can't possibly be too wide + (cond + [(bad-name-key? key) w] + [else (world-todraft! w key)])] + [(and (string? to) (boolean? mm)) + ;; the key also belongs into address + (local ((define to-new (string-append to key))) + (cond + [(bad-name-key? key) w] + [(too-wide? to-new mm) (send to "" from* to*)] + [else (world-todraft! w to-new)]))] + ; [(and (boolean? to) (string? mm)) (error 'react "can't happen")] + [else ; (and (string? to) (string? mm)) + ;; the key belongs into the message text + (local ((define new-mm (string-append mm key))) + (cond + [(bad-msg-key? key) w] + [(too-wide? to new-mm) (send to mm from* to*)] + [else (world-mmdraft! w new-mm)]))])]))) + +;; ----------------------------------------------------------------------------- +;; String -> Boolean +;; is this key bad for text messages? + +(check-expect (bad-msg-key? " ") false) +(check-expect (bad-msg-key? "right") true) + +(define (bad-msg-key? key) + (or (string=? "\b" key) (>= (string-length key) 2))) + +;; ----------------------------------------------------------------------------- +;; String -> Boolean +;; is the key bad (special key, or space or ":") for names + +(check-expect (bad-name-key? "x") false) +(check-expect (bad-name-key? ":") true) +(check-expect (bad-name-key? "false") true) + +(define (bad-name-key? key) + (or (string=? " " key) (string=? ":" key) (>= (string-length key) 2))) + +;; ----------------------------------------------------------------------------- +;; String String [Listof Line] [Listof Line] -> WorldPackage +;; add (make-messg addr msg) to from list, send (list addr msg) + +(check-expect (send "ada" "hello" '() '()) + (make-package + (make-world false false '() (list (make-messg "ada" "hello"))) + (list "ada" "hello"))) + +(define (send addr msg from* to*) + (local ((define to*-appended (append to* (list (make-messg addr msg))))) + (make-package (make-world false false from* to*-appended) + (list addr msg)))) + +;; ----------------------------------------------------------------------------- +;; World String -> World +;; create world from old fiels, use str for mmdraft + +(check-expect (world-mmdraft! (make-world false "" '() '()) ":") + (make-world false ":" '() '())) + +(define from0 (list (make-messg "ada" "hello world"))) +(check-expect (world-mmdraft! (make-world false "" '() from0) ":") + (make-world false ":" '() from0)) + +(define (world-mmdraft! w str) + (make-world (world-todraft w) str (world-from w) (world-to w))) + +;; ----------------------------------------------------------------------------- +;; World String -> World +;; create world from old fiels, use str for todraft + +(check-expect (world-todraft! (make-world false false '() '()) "x") + (make-world "x" false '() '())) + +(check-expect (world-todraft! (make-world "xy" false '() from0) "xyz") + (make-world "xyz" false '() from0)) + +(define (world-todraft! w str) + (make-world str (world-mmdraft w) (world-from w) (world-to w))) + +;; ----------------------------------------------------------------------------- +;; String String -> Boolean + +(check-expect (too-wide? "" (replicate WIDTH "m")) true) +(check-expect (too-wide? "ada" "hello") false) ; must succeed + +(define (too-wide? addr msg) + (>= (image-width (line-render-cursor addr msg)) (- WIDTH 2))) + +; +; +; +; ; ; +; ;;;;; ;;; ;;;; ;;;;; ;;;; +; ; ; ; ; ; ; ; ; +; ; ;;;;; ;;; ; ;;; +; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; +; ;;; ;;;; ;;;; ;;; ;;;; +; +; +; +; + +(define world0 (make-world false false '() '())) +(define world1 (make-world + false false + (list (make-messg "ada*" "hello")) + (list (make-messg "ada" "world")))) +(define world2 (make-world + false false + (list (make-messg "ada*" "hello") + (make-messg "bob" "secret code") + (make-messg "cynthia" "more secrets") + (make-messg "doug" "it's all the same to me")) + (list (make-messg "ada" "world") + (make-messg "*" "world!!!")))) + +(render world0) +(render world1) +(render world2) + +(define (maim name) + (big-bang world0 + (on-key react) + (on-draw render))) diff --git a/collects/2htdp/uchat/readme b/collects/2htdp/uchat/readme new file mode 100644 index 0000000000..c0c1cae300 --- /dev/null +++ b/collects/2htdp/uchat/readme @@ -0,0 +1,88 @@ + + Twitter Chat + +Design and implement a program that allows people to chat with each + other, using short messages. + +A participant uses a chat space, which is a window divided into two spaces: + the top half for listing the messages received and the bottom half for + listing the messages sent plus the one message the participant is currently + entering. + +The two halves display the messages in historical order, with the most + recent message received/sent at the bottom. When the either half is full of + messages, drop the least recent lines. + +Each message is at most one line of text, i.e., the width of the + window, which is 400 pixels. A line consists of two pieces: + + -- an address + -- a message + + where the address is separated from the message with a ":". The user sends + a message by typing the name of a participant, followed by ":" and the text + of the message. The message is sent when the user hits "\r" (return) or + when the line is too wide for the screen. + +A message whose recipient is "*" is broadcast to every current participant. + Otherwise a message is sent to the designated recipient, if the string is + the valid name of a current participant. + +Each received message is displayed like those that are sent, with an sender + followed by ":" and the text of the message. If the message went to all + participants, the sender's name is followed by an asterisk "*". + +;; ----------------------------------------------------------------------------- +protocol: + +Sending and receiving message occur without any synchronization. + +Clients send messages of the form (list String String) to the server. The + first string designates the recipient of the message, the second string + represents the message text. + +The Chat Server swaps the name of the recipient of a message with that of + the sender; if the message is to be broadcast, it adds an asterisk "*". + The server sends sends the resulting messages to the designated recipient. + If the recipient name of a message is "*", then the server sends it all + current participants. + + + SERVER CLIENT (name1) CLIENT (name2) + | | | + | name1 | % name by which client is known | + | <-------------------- | | + | | | + | (list name2 txt) | | + | <-------------------- | | + | | | + | | (list name1 txt) | + | --------------------------------------------------------> | + | | | + | | | + +;; Client2ServerMsg = (list String String) +;; interp. recipient followed by message text + +;; Server2ClientMsg = (list String String) +;; interp. sender followed by message text. + +;; ----------------------------------------------------------------------------- + +chat server: receive message, swap recipient for sender & send message(s) + +;; ----------------------------------------------------------------------------- + +chat world: + + +------------------------------------------------------------------+ + | from: text text text text text text | + | from*: text text text text text text | + | ... | + +------------------------------------------------------------------+ + | to: text text text text text text | + | *: text text text text text text | + | ... | + +------------------------------------------------------------------+ + + diff --git a/collects/2htdp/uchat/server.ss b/collects/2htdp/uchat/server.ss new file mode 100644 index 0000000000..7dd92eb2fb --- /dev/null +++ b/collects/2htdp/uchat/server.ss @@ -0,0 +1,34 @@ + + +;; UniState = (list String) +;; interp. the name of currently participating chatters + +;; Message = (list String String) + +;; Result = (make-bundle UniState [Listof (make-mail IWorld Message)]) + +;; Universe IWorld -> Universe +;; add the name of the new world to the universe + +(check-expect (new-chatter '() iworld1) (list iworld1)) + +(define (new-chatter u w) + (cons (iworld-name w) u)) + +;; Universe IWorld Message -> Result + +(define u0 (list iworld1 iworld2 iworld3)) +(define name1 (iworld-name iworld1)) +(define name2 (iworld-name iworld2)) +(define name3 (iworld-name iworld3)) + +(check-expect (forward u0 iworld1 (list name2 "hello")) + (make-bundle u0 (list (make-mail name1 "hello")) '())) + +(check-expect (forward u0 iworld1 (list "*" "hello")) + (make-bundle u0 (list + (make-mail (string-append name2 "*") "hello") + (make-mail (string-append name3 "*") "hello")))) + +(define (forward u s msg) (make-bundle u '() '())) + diff --git a/collects/2htdp/utest/balls.ss b/collects/2htdp/utest/balls.ss index b05a7e0601..4811ee370a 100644 --- a/collects/2htdp/utest/balls.ss +++ b/collects/2htdp/utest/balls.ss @@ -6,7 +6,7 @@ ;; ----------------------------------------------------------------------------- ;; Universe = [Listof IWorld] -;; BallMail = (make-mail World 'go) +;; BallMail = (make-mail IWorld 'go) ;; Result = (make-bundle [Listof IWorld] [Listof BallMail] '()) (define Result0 (make-bundle '() '() '())) @@ -18,7 +18,7 @@ (make-bundle lw (list (make-mail (first lw) 'go)) '())) ;; ----------------------------------------------------------------------------- -;; Universe World -> Result +;; Universe IWorld -> Result ;; add w to the list of worlds; get the first one to play (check-expect (add-world '() iworld1) (mail2 (list iworld1))) @@ -27,7 +27,7 @@ (mail2 (append univ (list wrld)))) ;; ----------------------------------------------------------------------------- -;; Universe World Sexp -> Result +;; Universe IWorld Sexp -> Result ;; w sent message m in universe u (check-expect @@ -48,7 +48,7 @@ [else (error 'switch "wrong world sent message")]))) ;; ----------------------------------------------------------------------------- -;; [Listof World] Universe World -> Result +;; [Listof IWorld] Universe IWorld -> Result ;; w disconnected from the universe (check-expect (disconnect (list iworld1 iworld2 iworld3) iworld2) @@ -59,7 +59,7 @@ (local ((define nxt (remq w u))) (if (empty? nxt) Result0 (mail2 nxt)))) -;; World [Listof World] -> [Listof World] +;; IWorld [Listof IWorld] -> [Listof IWorld] ;; remove w from low (check-expect (remq 'a '(a b c)) '(b c))