From 742660ffe723ecdb575a5c9767478660f0a51753 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 16 Jul 2009 20:17:34 +0000 Subject: [PATCH] fixing more string/symbol bugs; please propagate svn: r15465 --- collects/2htdp/private/universe.ss | 16 +++-- collects/2htdp/private/world.ss | 4 +- collects/2htdp/uchat/aux.ss | 6 ++ collects/2htdp/uchat/chatter.ss | 45 +++++++++++++- collects/2htdp/uchat/readme | 3 +- collects/2htdp/uchat/server.ss | 95 ++++++++++++++++++++++++------ collects/2htdp/universe.ss | 6 +- 7 files changed, 142 insertions(+), 33 deletions(-) create mode 100644 collects/2htdp/uchat/aux.ss diff --git a/collects/2htdp/private/universe.ss b/collects/2htdp/private/universe.ss index 862a8d9b9f..befe3ad146 100644 --- a/collects/2htdp/private/universe.ss +++ b/collects/2htdp/private/universe.ss @@ -38,7 +38,7 @@ on-msg ;; Universe World Message -> Result tick ;; Universe -> Result (on-disconnect ;; Universe World -> Result - (lambda (u w) (list u))) + (lambda (u w) (make-bundle u '() '()))) (to-string #f) ;; Universe -> String (check-with True) ;; Any -> Boolean ) @@ -61,8 +61,9 @@ (define (handler e) (stop! e)) (with-handlers ([exn? handler]) (define ___ (begin 'dummy body ...)) + (define n (if (object-name name) (object-name name) name)) (define-values (u mails bad) - (bundle> 'name (name (send universe get) a ...))) + (bundle> n (name (send universe get) a ...))) (send universe set (format "~a callback" 'name) u) (unless (boolean? to-string) (send gui add (to-string u))) (broadcast mails) @@ -88,7 +89,7 @@ (def/cback private (pnew iworld) on-new (set! iworlds (cons iworld iworlds)) (iworld-send iworld 'okay) ;; <--- this can fail! - (send gui add (format "~a signed up" (iworld-info iworld)))) + (send gui add (format "~a signed up" (iworld-name iworld)))) (def/cback private (pmsg iworld r) on-msg (send gui add (format "~a ->: ~a" (iworld-name iworld) r))) @@ -224,7 +225,7 @@ ;; IPort OPort Sexp -> IWorld (define (create-iworld i o info) - (if (and (pair? info) (symbol? (car info))) + (if (and (pair? info) (string? (car info))) (make-iworld i o (car info) (cdr info)) (make-iworld i o (symbol->string (gensym 'iworld)) info))) @@ -348,10 +349,13 @@ (check-arg tag (iworld? c) msg (format "(elements of) ~a" rank) c)) low)) -;; Any ->* Universe [Listof Mail] [Listof IWorld] +;; Symbol Any ->* Universe [Listof Mail] [Listof IWorld] (define (bundle> tag r) (unless (bundle? r) - (error "bundle expected from ~a, given: " tag)) + (raise + (make-exn + (format "error: bundle expected from ~a, given: ~e" tag r) + (current-continuation-marks)))) (values (bundle-state r) (bundle-mails r) (bundle-bad r))) (define-struct mail (to content) #:transparent) diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss index 9c48a29000..f6499129d7 100644 --- a/collects/2htdp/private/world.ss +++ b/collects/2htdp/private/world.ss @@ -89,7 +89,9 @@ (begin (sleep PAUSE) (do-register (- n 1))))))) (define-values (in out) (tcp-connect register SQPORT)) - (tcp-send out `(REGISTER ,(if name name (gensym 'world)))) + (tcp-send + out + `(REGISTER ,(if name name (symbol->string (gensym 'world))))) (if (eq? (tcp-receive in) 'okay) (values in out) (raise tcp-eof)))) diff --git a/collects/2htdp/uchat/aux.ss b/collects/2htdp/uchat/aux.ss new file mode 100644 index 0000000000..f43ab936db --- /dev/null +++ b/collects/2htdp/uchat/aux.ss @@ -0,0 +1,6 @@ +#lang scheme + +(provide spawn) + +(define (spawn f name) + (thread (lambda () (f name)))) diff --git a/collects/2htdp/uchat/chatter.ss b/collects/2htdp/uchat/chatter.ss index 43dc284d48..39ca318312 100644 --- a/collects/2htdp/uchat/chatter.ss +++ b/collects/2htdp/uchat/chatter.ss @@ -2,6 +2,7 @@ ;; 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) +(require "aux.ss") #| @@ -167,6 +168,42 @@ (define hj (image-height j))) (overlay/xy (put-pinhole i 0 0) (image-width i) (- hi hj) (put-pinhole j 0 0)))) +; +; +; ; +; +; ;; ;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; +; ;; ; ; ; ; ; ; ; ; ; ; ; +; ; ;;;;; ; ;;;;; ; ; ; ;;;;; +; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; +; ;;;;; ;;;; ;;; ;;;; ;;;;; ; ;;;; +; +; +; +; + +;; World Message -> World +;; receive a message, append to end of received messages + +(define w0 (make-world false false '() '())) +(define w1 (make-world false false (list (make-messg "bob*" "hello")) '())) + +(check-expect (receive w0 (list "bob*" "hello")) w1) +(check-expect (receive w1 (list "angie" "world")) + (make-world false false + (list (make-messg "bob*" "hello") + (make-messg "angie" "world")) + '())) + +(define (receive w m) + (make-world (world-todraft w) + (world-mmdraft w) + (append (world-from w) (list (make-messg (first m) (second m)))) + (world-to w))) + + + ; ; ; ;; ; ;; @@ -191,7 +228,6 @@ ;; -- (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) @@ -363,7 +399,10 @@ (render world1) (render world2) -(define (maim name) +(define (main n) (big-bang world0 (on-key react) - (on-draw render))) + (on-draw render) + (on-receive receive) + (name n) + (register LOCALHOST))) diff --git a/collects/2htdp/uchat/readme b/collects/2htdp/uchat/readme index 7e381abd89..5bfa3b0ecf 100644 --- a/collects/2htdp/uchat/readme +++ b/collects/2htdp/uchat/readme @@ -1,5 +1,6 @@ - Twitter Chat + Chit Chat + --------- Design and implement a program that allows people to chat with each other, using short messages. diff --git a/collects/2htdp/uchat/server.ss b/collects/2htdp/uchat/server.ss index 31ff569803..ce34ba1a6f 100644 --- a/collects/2htdp/uchat/server.ss +++ b/collects/2htdp/uchat/server.ss @@ -1,40 +1,97 @@ ;; 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 server) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) - (require 2htdp/universe) -;; UniState = (list String) -;; interp. the name of currently participating chatters +;; UniState = [Listof IWorld] +;; interp. the currently participating iworlds ;; Message = (list String String) +;; intep. +;; incoming message: (list to-address message) +;; outgoing message: (list from-address message) ;; Result = (make-bundle UniState [Listof (make-mail IWorld Message)]) +;; ----------------------------------------------------------------------------- +(define ALL "*") -;; Universe IWorld -> Universe +;; ----------------------------------------------------------------------------- +;; Universe IWorld -> Bundle ;; add the name of the new world to the universe -(check-expect (new-chatter '() iworld1) (list iworld1)) +(check-expect (new-chatter '() iworld1) (make-bundle (list iworld1) '() '())) (define (new-chatter u w) - (cons (iworld-name w) u)) + (make-bundle (cons w u) '() '())) +;; ----------------------------------------------------------------------------- ;; Universe IWorld Message -> Result +;; process the message and forward it to the appropriate addressees (define u0 (list iworld1 iworld2 iworld3)) -(define name1 (symbol->string (iworld-name iworld1))) -(define name2 (symbol->string (iworld-name iworld2))) -(define name3 (symbol->string (iworld-name 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 iworld1 "hello")) '())) +(check-expect + (forward u0 iworld1 (list name2 "hello")) + (make-bundle u0 (list (make-mail iworld2 (list name1 "hello"))) '())) -(check-expect (forward u0 iworld1 (list "*" "hello")) - (make-bundle u0 - (list - (make-mail iworld2 (list (string-append name2 "*") "hello")) - (make-mail iworld2 (list (string-append name3 "*") "hello"))) - '())) +(check-expect + (forward u0 iworld1 (list "*" "hello")) + (make-bundle u0 + (list + (make-mail iworld2 (list (string-append name1 "*") "hello")) + (make-mail iworld3 (list (string-append name1 "*") "hello"))) + '())) -(define (forward u s msg) (make-bundle u '() '())) - +(define (forward u s msg) + (local ((define to (first msg))) + (make-bundle u (transform u (iworld-name s) to (second msg)) '()))) + +;; Universe String Message -> [Listof Message] +;; transform an incoming message into a list of outgoing ones + +(check-expect (transform u0 name1 name2 "hello") + (list (make-mail iworld2 (list name1 "hello")))) + +(check-expect (transform u0 name1 "bob" "hello") '()) + +(check-expect (transform u0 name1 "*" "hello") + (list + (make-mail iworld2 (list (string-append name1 "*") "hello")) + (make-mail iworld3 (list (string-append name1 "*") "hello")))) + +(define (transform univ from to msg) + (if (string=? ALL to) + (local ((define true-msg (list (string-append from "*") msg))) + (map (lambda (to-world) (make-mail to-world true-msg)) + (filter (lambda (to-world) + (not (string=? (iworld-name to-world) from))) + univ))) + (local ((define true-to (lookup to univ))) + (if (boolean? true-to) + '() + (list (make-mail true-to (list from msg))))))) + +;; String Universe -> IWorld or false +;; pick the iworld whose name is n + +(check-expect (lookup name1 u0) iworld1) +(check-expect (lookup name2 u0) iworld2) +(check-expect (lookup name3 u0) iworld3) +(check-expect (lookup "*" u0) false) + +(define (lookup name univ) + (cond + [(empty? univ) false] + [else (if (string=? (iworld-name (first univ)) name) + (first univ) + (lookup name (rest univ)))])) + +;; Any -> Universe +;; run the chat server +(define (run _) + (universe '() + (on-new new-chatter) + (on-msg forward))) \ No newline at end of file diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss index 109fd8a21f..168aca996a 100644 --- a/collects/2htdp/universe.ss +++ b/collects/2htdp/universe.ss @@ -96,9 +96,9 @@ ;; | (stop-when Expr) ;; -- stop-when must specify a boolean-valued function ;; | (register Expr) -;; | (register Expr Expr) ;; -- register must specify the internet address of a host (including LOCALHOST) -;; -- it may specify a world's name +;; | (name Expr) +;; -- the name ;; | (record? Expr) ;; -- should the session be recorded and turned into PNGs and an animated GIF ;; | (on-receive Expr) @@ -124,7 +124,7 @@ [name (lambda (tag) (lambda (p) (syntax-case p () - [(n) #`(symbol> #,tag n)] + [(n) #`(string> #,tag n)] [_ (err tag p "expected a string for the current world")])))] [record? (lambda (tag) (lambda (p)