101 lines
3.5 KiB
Racket
101 lines
3.5 KiB
Racket
;; 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 #f) (teachpacks ()) (htdp-settings #(#f constructor repeating-decimal #f #t none #f ())))
|
|
(require 2htdp/universe)
|
|
|
|
;; 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 -> Bundle
|
|
;; add the name of the new world to the universe
|
|
|
|
(check-expect (new-chatter '() iworld1) (make-bundle (list iworld1) '() '()))
|
|
|
|
(define (new-chatter u w)
|
|
(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 (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 iworld2 (list name1 "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)
|
|
(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 '()
|
|
(state true)
|
|
(on-new new-chatter)
|
|
(on-msg forward)))
|
|
|
|
(run 0)
|