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

fixing more string/symbol bugs; please propagate

Browse Source 
svn: r15465
This commit is contained in:
Matthias Felleisen 2009-07-16 20:17:34 +00:00
parent 6c6ee2329f
commit 742660ffe7
7 changed files with 142 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/2htdp/private/universe.ss
View File

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

4
collects/2htdp/private/world.ss
View File

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

6
collects/2htdp/uchat/aux.ss Normal file
View File

@ -0,0 +1,6 @@
#lang scheme
(provide spawn)
(define (spawn f name)
(thread (lambda () (f name))))

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

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

3
collects/2htdp/uchat/readme
View File

@ -1,5 +1,6 @@
Twitter Chat
Chit Chat
---------
Design and implement a program that allows people to chat with each
other, using short messages.

95
collects/2htdp/uchat/server.ss
View File

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

6
collects/2htdp/universe.ss
View File

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