From 333e0aa07061bc01de05b4dfc432dfdac268e89c Mon Sep 17 00:00:00 2001 From: David Van Horn Date: Fri, 2 May 2014 14:38:15 -0400 Subject: [PATCH] Universe and world take an optional 'port' argument. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Allows universe and world programs to specify which port they want to communicate on. If omitted, universe and world use the default port number. This enables multiple universe instances to run on the same machine. For example: (require 2htdp/universe 2htdp/image) ;; Run two client-server pairs (define (run) (launch-many-worlds (server 8080) (client 8080) (server 8081) (client 8081))) ;; Port -> #f (define (server p) (define noop (make-bundle #f '() '())) (universe #f (port p) (on-new (λ (_u _iw) noop)) (on-msg (λ (_u _iw _msg) noop)))) ;; Port -> #f (define (client p) (big-bang #f (port p) (on-tick values) (to-draw (λ (_) (empty-scene 400 400))) (register LOCALHOST))) --- pkgs/htdp-pkgs/htdp-lib/2htdp/private/clauses-spec-aux.rkt | 6 +++++- pkgs/htdp-pkgs/htdp-lib/2htdp/private/universe.rkt | 3 ++- pkgs/htdp-pkgs/htdp-lib/2htdp/private/world.rkt | 4 ++-- pkgs/htdp-pkgs/htdp-lib/2htdp/universe.rkt | 7 +++++-- 4 files changed, 14 insertions(+), 6 deletions(-) diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/clauses-spec-aux.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/clauses-spec-aux.rkt index 1aaa205d61..c14de56e4b 100644 --- a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/clauses-spec-aux.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/clauses-spec-aux.rkt @@ -3,7 +3,7 @@ ;; --------------------------------------------------------------------------------------------------- ;; provides constants and functions for specifying the shape of clauses in big-bang and universe -(provide nat> nat? proc> bool> num> ip> string> symbol> string-or-symbol> any> K False True) +(provide port> nat> nat? proc> bool> num> ip> string> symbol> string-or-symbol> any> K False True) (require htdp/error "check-aux.rkt") @@ -11,6 +11,10 @@ (define (False w) #f) (define (True w) #t) +;; Symbol X -> X : nat? +(define (port> tag x) + (nat> tag x "port")) + ;; Symbol X -> X : boolean? (define (bool> tag x) (check-arg tag (boolean? x) "boolean" "first" x) diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/universe.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/universe.rkt index f925678a5d..7dfe33a158 100644 --- a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/universe.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/universe.rkt @@ -58,6 +58,7 @@ universe0 ;; the initial state of the universe on-new ;; Universe World -> Result on-msg ;; Universe World Message -> Result + port ;; Number ;; tick ;; Universe -> Result (state #f) ;; Boolean (on-disconnect ;; Universe World -> Result @@ -157,7 +158,7 @@ ;;; WHERE (define tcp-listener (with-handlers ((exn:fail:network? (lambda (x) (stop! x)))) - (tcp-listen SQPORT 4 #t))) + (tcp-listen port 4 #t))) ;; (list IPort OPort) -> Void (define (add-iworld in-out) (define in (first in-out)) diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/world.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/world.rkt index 41e85acb3a..fe9985d536 100644 --- a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/world.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/world.rkt @@ -59,7 +59,7 @@ (class* object% (start-stop<%>) (inspect #f) (init-field world0) - (init-field name state register check-with on-key on-release on-pad on-mouse record?) + (init-field name state register port check-with on-key on-release on-pad on-mouse record?) (init on-receive on-draw stop-when) ;; ----------------------------------------------------------------------- @@ -114,7 +114,7 @@ (if (= n 1) (printf FMTtry register TRIES) (begin (sleep PAUSE) (try (- n 1))))))) - (define-values (in out) (tcp-connect register SQPORT)) + (define-values (in out) (tcp-connect register port)) (tcp-register in out name) (printf "... successful registered and ready to receive\n") (set! *out* out) diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/universe.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/universe.rkt index c6a4d64472..1ad75fcb4e 100644 --- a/pkgs/htdp-pkgs/htdp-lib/2htdp/universe.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/universe.rkt @@ -27,7 +27,7 @@ ;; (only-in "private/launch-many-worlds.rkt" launch-many-worlds launch-many-worlds/proc) (only-in "private/stop.rkt" make-stop-the-world) - (only-in "private/check-aux.rkt" sexp?) + (only-in "private/check-aux.rkt" sexp? SQPORT) (only-in "private/pad.rkt" pad-event? pad=?) htdp/error (rename-in lang/prim (first-order->higher-order f2h))) @@ -74,7 +74,10 @@ [state DEFAULT #'#f (expr-with-check any> "expected a boolean or a string")] ;; Any -> Boolean ;; -- check-with: all states should specify this predicate - [check-with DEFAULT #'True (function-with-arity 1)]) + [check-with DEFAULT #'True (function-with-arity 1)] + ;; Natural + ;; -- port: specify the port to use + [port DEFAULT #'SQPORT (expr-with-check port> "expected a port number")]) ; (create-world world0) (define-keywords WldSpec AllSpec create-world