From 4e40450248a312a31f5cd9c440e5bfb40c061871 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 17 Jul 2009 16:59:40 +0000 Subject: [PATCH] improving chat, no need to propagate svn: r15476 --- collects/2htdp/uchat/chatter.ss | 156 ++++++++++++++++++++++---------- collects/2htdp/uchat/readme | 32 +++++-- collects/2htdp/universe.ss | 3 +- collects/2htdp/utest/carl.ss | 2 +- collects/2htdp/utest/player | 2 +- collects/2htdp/utest/sam.ss | 2 +- 6 files changed, 134 insertions(+), 63 deletions(-) diff --git a/collects/2htdp/uchat/chatter.ss b/collects/2htdp/uchat/chatter.ss index 39e251ba07..598d2fcb59 100644 --- a/collects/2htdp/uchat/chatter.ss +++ b/collects/2htdp/uchat/chatter.ss @@ -20,9 +20,9 @@ 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? + -- the editing of too-tall send messages is a bit off screen. |# @@ -49,18 +49,25 @@ ;; Line = (make-messg String String) ;; WorldPackage = (make-package World (list String String)) -(define WIDTH 400) -(define HEIGHT 300) -(define MID (/ HEIGHT 2)) +;; NOTE: the from and to fields never contain lists that would +;; create images taller than MID-2. We enforce this via send +;; and receive. ;; visual constants +(define WIDTH 400) +(define HEIGHT 300) ;; at least 200 +(define MID (/ HEIGHT 2)) + +(define FTSZ 11) +(define FTCL "black") + (define SP " ") -(define MT (scene+line (empty-scene WIDTH HEIGHT) 0 MID WIDTH MID "black")) -(define BLANK (rectangle WIDTH 11 "outline" "white")) +(define MT (scene+line (empty-scene WIDTH HEIGHT) 0 MID WIDTH MID FTCL)) +(define BLANK (rectangle WIDTH FTSZ "outline" "white")) -(define CURSOR (rectangle 3 11 "solid" "red")) +(define CURSOR (rectangle 3 FTSZ "solid" "red")) ; ; @@ -82,7 +89,8 @@ (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 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)))) @@ -101,22 +109,22 @@ ;; String String -> Image ;; render a single display line -(define result0 (text (string-append SP "ada: hello") 11 "black")) +(define result0 (text (string-append SP "ada: hello") FTSZ FTCL)) (check-expect (line-render "ada" "hello") result0) (define (line-render addr msg) - (text (string-append SP addr ": " msg) 11 "black")) + (text (string-append SP addr ": " msg) FTSZ FTCL)) ;; ----------------------------------------------------------------------------- ;; StrFl StrFl -> Image ;; render a single display line, with a cursor at current 'editing' position (check-expect (line-render-cursor false false) - (image-append (text SP 11 "black") CURSOR)) + (image-append (text SP FTSZ FTCL) CURSOR)) (check-expect (line-render-cursor "ada" false) - (image-append (text (string-append SP "ada") 11 "black") CURSOR)) + (image-append (text (string-append SP "ada") FTSZ FTCL) CURSOR)) (check-expect (line-render-cursor "ada" "hello") (image-append result0 CURSOR)) @@ -124,11 +132,11 @@ (define (line-render-cursor addr msg) (cond [(and (boolean? addr) (boolean? msg)) - (image-append (text SP 11 "black") CURSOR)] + (image-append (text SP FTSZ FTCL) CURSOR)] [(and (string? addr) (boolean? msg)) - (image-append (text (string-append SP addr) 11 "black") CURSOR)] + (image-append (text (string-append SP addr) FTSZ FTCL) CURSOR)] [else - (image-append (text (string-append SP addr ": " msg) 11 "black") CURSOR)])) + (image-append (text (string-append SP addr ": " msg) FTSZ FTCL) CURSOR)])) ; ; @@ -204,9 +212,29 @@ (define (receive w m) (make-world (world-todraft w) (world-mmdraft w) - (append (world-from w) (list (make-messg (first m) (second m)))) + (enqueue (world-from w) (first m) (second m)) (world-to w))) +;; [Listof Line] String String -> [Listof Line] +;; generative: add the line at end of list; if small enough, okay. + +;; this tests adding one too many items to the list +(check-expect + (enqueue (build-list 11 (lambda (i) (make-messg "a*" (number->string i)))) + "ada" "hello world") + (build-list 11 (lambda (i) + (if (<= i 9) + (make-messg "a*" (number->string (+ i 1))) + (make-messg "ada" "hello world"))))) + + +(define (enqueue from* from msg) + (local ((define candidate (append from* (list (make-messg from msg)))) + (define rendered (line*-render candidate))) + (cond + [(<= (image-height rendered) (- MID 2)) candidate] + [else (enqueue (rest from*) from msg)]))) + ; @@ -262,43 +290,72 @@ (check-expect (react (make-world WIDE-STRING false '() '()) "x") (send WIDE-STRING "" '() '())) +;; ------------------------------- +;; editing keys, not required + +(check-expect (react (make-world "abc" false '() '()) "\b") + (make-world "ab" false '() '())) +(check-expect (react (make-world false false '() '()) "\b") + (make-world false false '() '())) +(check-expect (react (make-world "abc" "def" '() '()) "\b") + (make-world "abc" "de" '() '())) + (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))) + (local ((define to (world-todraft w)) + (define mm (world-mmdraft 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*))] + ;; ------------------------------- + ;; editing keys; not required + [(key=? "\b" key) + (cond + [(boolean? to) w] + [(string? mm) (world-mmdraft! w (shorten mm))] + ;; (boolean? mm) ^ (not (boolean? to)) => (string? mm) + [else (world-todraft! w (shorten 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 ":"))])] + [(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)]))])]))) + (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 -> String +;; take off last character +(check-expect (shorten "") "") +(check-expect (shorten "abc") "ab") +(define (shorten to) + (if (= (string-length to) 0) + to + (substring to 0 (- (string-length to) 1)))) ;; ----------------------------------------------------------------------------- ;; String -> Boolean @@ -331,9 +388,8 @@ (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)))) + (make-package (make-world false false from* (enqueue to* addr msg)) + (list addr msg))) ;; ----------------------------------------------------------------------------- ;; World String -> World diff --git a/collects/2htdp/uchat/readme b/collects/2htdp/uchat/readme index 5bfa3b0ecf..1ab168baa9 100644 --- a/collects/2htdp/uchat/readme +++ b/collects/2htdp/uchat/readme @@ -1,9 +1,8 @@ + Chit Chat + --------- - Chit Chat - --------- - -Design and implement a program that allows people to chat with each - other, using short messages. +Design and implement a universe 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 @@ -11,11 +10,12 @@ A participant uses a chat space, which is a window divided into two spaces: 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 + recent message received/sent at the bottom. When 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: +Each message is at most one line of text, which is the width of the + window. Use 400 pixels for the width of a window, and use 11 point text + fonts to render lines. A line consists of two pieces: -- an address -- a message @@ -25,14 +25,28 @@ Each message is at most one line of text, i.e., the width of the of the message. The message is sent when the user hits "\r" (return) or when the line is too wide for the screen. +Editing is just entering keys. Ignore all those key strokes that aren't + one-character strings and of the remaining strings ignore backspace and + delete. (Of course, if you are ambitious you may wish to assign meaning to + some of those keys so that chatters can edit a bit.) + 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. + the valid name of a current participant; all other messages disappear in + the big empty void. 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 "*". +As you work on this project, you will encounter questions for which this +problem statement doesn't provide enough information to make decisions. You +must make the decisions on your own, following this procedure: + -- do not opt for answers that render the project trivial + -- document all non-trivial answers and the answer you chose + -- provide a reason for your choice +Be concise. + ;; ----------------------------------------------------------------------------- protocol: diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss index 168aca996a..edb34e0080 100644 --- a/collects/2htdp/universe.ss +++ b/collects/2htdp/universe.ss @@ -162,7 +162,8 @@ kwds Spec))) (list (syntax-e (car co)) ((cadr co) (cdr x)))) spec)]) - #`(send (new (if #,rec? aworld% world%) [world0 w] #,@args) last))])) + #`(let ([o (new (if #,rec? aworld% world%) [world0 w] #,@args)]) + (send o last)))])) ; diff --git a/collects/2htdp/utest/carl.ss b/collects/2htdp/utest/carl.ss index b28823f28b..240287d9ed 100644 --- a/collects/2htdp/utest/carl.ss +++ b/collects/2htdp/utest/carl.ss @@ -2,5 +2,5 @@ (require "shared.ss") -(make-player 100 'carl) +(make-player 100 "carl") ) diff --git a/collects/2htdp/utest/player b/collects/2htdp/utest/player index fa05de9b38..38d9e9e9e9 100755 --- a/collects/2htdp/utest/player +++ b/collects/2htdp/utest/player @@ -12,4 +12,4 @@ exec mred -qu "$0" ${1+"$@"} (unless (= (vector-length argv) 1) (error 'player "name of one player expected: $ ./player name")) -(make-player 200 (string->symbol (vector-ref argv 0))) +(make-player 200 (vector-ref argv 0)) diff --git a/collects/2htdp/utest/sam.ss b/collects/2htdp/utest/sam.ss index 250a085ce7..8752aa71da 100644 --- a/collects/2htdp/utest/sam.ss +++ b/collects/2htdp/utest/sam.ss @@ -3,4 +3,4 @@ #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname sam) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) (require "shared.ss") -(make-player 200 'sam) +(make-player 200 "sam")