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

improving chat, no need to propagate

Browse Source 
svn: r15476
This commit is contained in:
Matthias Felleisen 2009-07-17 16:59:40 +00:00
parent 8bdd94dca5
commit 4e40450248
6 changed files with 134 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

156
collects/2htdp/uchat/chatter.ss
View File

@ -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

32
collects/2htdp/uchat/readme
View File

@ -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:

3
collects/2htdp/universe.ss
View File

@ -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)))]))
;

2
collects/2htdp/utest/carl.ss
View File

@ -2,5 +2,5 @@
(require "shared.ss")
(make-player 100 'carl)
(make-player 100 "carl")
)

2
collects/2htdp/utest/player
View File

@ -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))

2
collects/2htdp/utest/sam.ss
View File

@ -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")