diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/two-ports.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/two-ports.rkt new file mode 100644 index 0000000000..0be8c44d13 --- /dev/null +++ b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/two-ports.rkt @@ -0,0 +1,35 @@ +#lang racket + +(require 2htdp/universe 2htdp/image) + +;; Run two client-server pairs +(define (run) + (launch-many-worlds + (server 8081) (client 'a 8081 'blue) (client 'b 8081 'blue) + (server 8082) (client 'c 8082 'green) (client 'd 8082 'green))) + +;; Port -> #f +(define (server p) + (define (noop s msg) (make-bundle s (map (λ (s) (make-mail s msg)) s) '())) + (universe '() + (port p) + (on-tick (λ (u) (make-bundle u '() '())) 1 5) + (on-new (λ (u iw) (make-bundle (cons iw u) '() '()))) + (on-msg (λ (u _iw msg) (noop u msg))))) + +;; Symbol Port ColorSymbol -> #f +(define (client name p c) + (define mt (place-image (text (symbol->string name) 22 'blue) 100 100 (empty-scene 400 400))) + (big-bang (list #f 0) + (port p) + (on-tick + (λ (s) (if (first s) + (make-package (list #f (add1 (second s))) (second s)) + (list #t (second s)))) + 1) + (on-receive + (λ (s msg) (displayln msg) (list (first s) (+ (second s) msg)))) + (to-draw + (λ (s) (if (first s) (place-image (circle (second s) 'solid c) 200 200 mt) mt))) + (register LOCALHOST))) +(run) diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/xtest b/pkgs/htdp-pkgs/htdp-test/2htdp/xtest index 56b643ae02..79a6009045 100755 --- a/pkgs/htdp-pkgs/htdp-test/2htdp/xtest +++ b/pkgs/htdp-pkgs/htdp-test/2htdp/xtest @@ -53,3 +53,4 @@ run pad1.rkt run pad1-handler.rkt run pad1-in-bsl.rkt run error-messages.rkt +run two-ports.rkt