#lang scheme/gui
(require scheme/class
scheme/local
scheme/bool
mred
htdp/error
htdp/image
(only-in lang/htdp-beginner image?)
mrlib/cache-image-snip
lang/prim
(for-syntax scheme/base))
(require mrlib/gif)
(require mzlib/runtime-path)
(require mrlib/bitmap-label
string-constants)
(provide (all-from-out htdp/image))
(provide
nw:rectangle place-image empty-scene scene+line )
(provide big-bang )
(provide-higher-order-primitive
on-tick-event (tock) )
(provide-higher-order-primitive
on-redraw (world-to-image) )
(provide-higher-order-primitive
on-receive-event (rec) )
(provide
key-event? key=? )
(provide-higher-order-primitive
on-key-event (control) )
(provide-higher-order-primitive
on-mouse-event (clack) )
(provide-higher-order-primitive
stop-when (last-world) )
(provide-higher-order-primitive
run-simulation (_ _ _ create-scene) )
(provide
run-movie )
(define (nw:rectangle width height mode color)
(check-pos 'rectangle width "first")
(check-pos 'rectangle height "second")
(check-mode 'rectangle mode "third")
(check-color 'rectangle color "fourth")
(put-pinhole (rectangle width height mode color) 0 0))
(define (place-image image x y scene)
(check-image 'place-image image "first")
(check-arg 'place-image (number? x) 'integer "second" x)
(check-arg 'place-image (number? y) 'integer "third" y)
(check-scene 'place-image scene "fourth")
(let ([x (number->integer x)]
[y (number->integer y)])
(place-image0 image x y scene)))
(define (empty-scene width height)
(check-pos 'empty-scene width "first")
(check-pos 'empty-scene height "second")
(put-pinhole
(overlay (rectangle width height 'solid 'white)
(rectangle width height 'outline 'black))
0 0))
(define (scene+line img x0 y0 x1 y1 c)
(check-arg 'scene+line (scene? img) "scene" "first" "plain image")
(check-arg 'scene+line (number? x0) "number" "second" x0)
(check-arg 'scene+line (number? y0) "number" "third" y0)
(check-arg 'scene+line (number? x1) "number" "fourth" x1)
(check-arg 'scene+line (number? y1) "number" "fifth" y1)
(let ([x0 (number->integer x0)]
[x1 (number->integer x1)]
[y0 (number->integer y0)]
[y1 (number->integer y1)])
(add-line-to-scene0 img x0 y0 x1 y1 c)))
(define big-bang
(lambda x
(define args (length x))
(if (or (= args 5) (= args 4))
(apply big-bang0 x)
(error 'big-bang msg))))
(define msg
(string-append
"big-bang consumes 4 or 5 arguments:\n"
"-- (big-bang <width> <height> <rate> <world0>)\n"
"-- (big-bang <width> <height> <rate> <world0> <animated-gif>)\n"
"see Help Desk."))
(define *run-sema* (make-semaphore 1))
(define *running?* #f)
(define big-bang0
(case-lambda
[(w h delta world) (big-bang w h delta world #f)]
[(w h delta world animated-gif)
(check-pos 'big-bang w "first")
(check-pos 'big-bang h "second")
(check-arg 'big-bang
(and (number? delta) (<= 0 delta 1000))
"number [of seconds] between 0 and 1000"
"third"
delta)
(check-arg 'big-bang
(boolean? animated-gif)
"boolean expected"
"fifth"
animated-gif)
(let ([w (coerce w)]
[h (coerce h)])
(semaphore-wait *run-sema*)
(when *running?* (error 'big-bang "the world is still running"))
(set! *running?* #t)
(semaphore-post *run-sema*)
(set-stop-when-callback (lambda (w) #f))
(install-world delta world) (set-and-show-frame w h animated-gif) (unless animated-gif (set! add-event void)) (set! *the-delta* delta)
#t)]))
(define (coerce x) (inexact->exact (floor x)))
(define *the-delta* 0.0)
(define (on-tick-event f)
(check-proc 'on-tick-event f 1 "first" "one argument")
(check-world 'on-tick-event)
(set-timer-callback f)
(send the-time start
(let* ([w (ceiling (* 1000 the-delta))])
(if (exact? w) w (inexact->exact w))))
#t)
(define (on-redraw f)
(check-proc 'on-redraw f 1 "first" "one argument")
(check-world 'on-redraw)
(set-redraw-callback f)
(redraw-callback)
#t)
(define (key-event? k)
(or (char? k) (symbol? k)))
(define (key=? k m)
(check-arg 'key=? (key-event? k) 'KeyEvent "first" k)
(check-arg 'key=? (key-event? m) 'KeyEvent "first" m)
(eqv? k m))
(define (on-key-event f)
(check-proc 'on-key-event f 2 "first" "two arguments")
(check-world 'on-key-event)
(set-key-callback f (current-eventspace))
#t)
(define (on-receive-event f)
(check-proc 'on-receive-event f 2 "first" "two arguments")
(check-world 'on-receive-event)
(set-receive-callback f)
#t)
(define (on-mouse-event f)
(check-proc 'on-mouse-event f 4 "first" "four arguments")
(check-world 'on-mouse-event)
(set-mouse-callback f (current-eventspace))
#t)
(define (stop-when f)
(check-proc 'stop-when f 1 "first" "one argument")
(check-world 'stop-when)
(when (f the-world)
(callback-stop!))
(set-stop-when-callback f)
#t)
(define (run-movie movie)
(check-arg 'run-movie (list? movie) "list (of images)" "first" movie)
(for-each (lambda (cand)
(check-image 'run-movie cand "first" "list of images"))
movie)
(let* ([fst (car movie)]
[wdt (image-width fst)]
[hgt (image-height fst)])
(big-bang wdt hgt (/ 1 27) movie)
(let run-movie ([movie movie])
(cond
[(null? movie) #t]
[(pair? movie)
(update-frame (car movie))
(sleep/yield .05)
(run-movie (cdr movie))]))))
(define run-simulation
(lambda x
(define args (length x))
(if (or (= args 5) (= args 4))
(apply run-simulation0 x)
(error 'run-simulation msg-run-simulation))))
(define msg-run-simulation
(string-append
"consumes 4 or 5 arguments:\n"
"-- (run-simulation <width> <height> <rate> <world-to-world-function>)\n"
"-- (run-simulation <width> <height> <rate> <world-to-world-function> <create-animated-gif?>)\n"
"see Help Desk."))
(define run-simulation0
(case-lambda
[(width height rate f record?)
(check-pos 'run-simulation width "first")
(check-pos 'run-simulation height "second")
(check-arg 'run-simulation (number? rate) 'number "third" rate)
(check-proc 'run-simulation f 1 "fourth" "one argument")
(check-arg 'run-simulation (boolean? record?) 'number "fifth [and optional]" record?)
(big-bang width height rate 1 record?)
(on-redraw f)
(on-tick-event add1)]
[(width height rate f)
(run-simulation width height rate f #f)]))
(define (check-pos tag c rank)
(check-arg tag (and (number? c) (> (coerce c) 0))
"positive integer" rank c))
(define (check-image tag i rank . other-message)
(if (and (pair? other-message) (string? (car other-message)))
(check-arg tag (image? i) (car other-message) rank i)
(check-arg tag (image? i) "image" rank i)))
(define (check-scene tag i rank)
(if (image? i)
(unless (scene? i)
(error tag "scene expected, given image whose pinhole is at (~s,~s) instead of (0,0)"
(pinhole-x i) (pinhole-y i)))
(check-arg tag #f "image" rank i)))
(define (scene? i) (and (= 0 (pinhole-x i)) (= 0 (pinhole-y i))))
(define (check-color tag width rank)
(check-arg tag (or (symbol? width) (string? width))
"color symbol or string" rank width))
(define (check-mode tag s rank)
(check-arg tag (or (eq? s 'solid)
(eq? s 'outline)
(string=? "solid" s)
(string=? "outline" s)) "mode (solid or outline)" rank s))
(define (place-image0 image x y scene)
(define sw (image-width scene))
(define sh (image-height scene))
(define ns (overlay/xy scene x y image))
(define nw (image-width ns))
(define nh (image-height ns))
(if (and (= sw nw) (= sh nh)) ns (shrink ns 0 0 sw sh)))
(define (place-image0 image x y scene)
(define sw (image-width scene))
(define sh (image-height scene))
(define ns (overlay/xy scene x y image))
(define nw (image-width ns))
(define nh (image-height ns))
(if (and (= sw nw) (= sh nh)) ns (shrink ns 0 0 (- sw 1) (- sh 1))))
(define (add-line-to-scene0 img x0 y0 x1 y1 c)
(define w (image-width img))
(define h (image-height img))
(cond
[(and (<= 0 x0) (< x0 w) (<= 0 x1) (< x1 w) (<= 0 y0) (< y0 w) (<= 0 y1) (< y1 w))
(add-line img x0 y0 x1 y1 c)]
[(= x0 x1) (if (<= 0 x0 w) (add-line img x0 (app y0 h) x0 (app y1 h) c) img)]
[(= y0 y1) (if (<= 0 y0 h) (add-line img (app x0 w) y0 (app x1 w) y0 c) img)]
[else
(local ((define lin (points->line x0 y0 x1 y1))
(define dir (direction x0 y0 x1 y1))
(define-values (upp low lft rgt) (intersections lin w h))
(define (add x y) (add-line img x0 y0 x y c)))
(cond
[(and (< 0 x0 w) (< 0 y0 h)) (case dir
[(upper-left) (if (number? upp) (add upp 0) (add 0 lft))]
[(lower-left) (if (number? low) (add low h) (add 0 lft))]
[(upper-right) (if (number? upp) (add upp 0) (add h rgt))]
[(lower-right) (if (number? low) (add low h) (add w rgt))]
[else (error 'dir "contract violation: ~e" dir)])]
[(and (< 0 x1 w) (< 0 y1 h)) (add-line-to-scene0 img x1 y1 x0 y0 c)]
[else
(cond
[(and (number? upp) (number? low)) (add-line img upp 0 low h c)]
[(and (number? upp) (number? lft)) (add-line img upp 0 0 lft c)]
[(and (number? upp) (number? rgt)) (add-line img upp 0 w rgt c)]
[(and (number? low) (number? lft)) (add-line img low h 0 lft c)]
[(and (number? low) (number? rgt)) (add-line img low h w rgt c)]
[(and (number? lft) (number? rgt)) (add-line img 0 lft w rgt c)]
[else img])]))]))
(define (app y h)
(cond
[(and (<= 0 y) (< y h)) y]
[(< y 0) 0]
[else (- h 1)]))
(define (direction x0 y0 x1 y1)
(string->symbol
(string-append
(if (<= y0 y1) "lower" "upper") "-" (if (<= x0 x1) "right" "left"))))
(define-struct lyne (slope y0))
(define (points->line x0 y0 x1 y1)
(local ((define slope (/ (- y1 y0) (- x1 x0))))
(make-lyne slope (- y0 (* slope x0)))))
(define (of ln x) (+ (* (lyne-slope ln) x) (lyne-y0 ln)))
(define (intersections l w h)
(values
(opt (X l 0) w) (opt (X l h) w) (opt (lyne-y0 l) h) (opt (of l w) h)))
(define (opt z lft) (if (<= 0 z lft) z false))
(define (X ln h) (/ (- h (lyne-y0 ln)) (lyne-slope ln)))
(define unique-world (cons 1 1))
(define (check-world tag)
(when (eq? unique-world the-world)
(error tag "evaluate (big-bang Number Number Number World) first")))
(define (empty-message? msg)
(null? msg))
(define the-world unique-world)
(define (update-world f)
(define new-world (f the-world))
(if (package? new-world)
(let ([msg (package-message new-world)]
[new-world (package-world new-world)])
(set! the-world new-world)
(when *out*
(if (sexp? msg)
(unless (empty-message? msg)
(tcp-send *out* msg))
(error 'send "Sexp expected; given ~e\n" msg)))
#f)
(let ([result (eq? new-world the-world)])
(set! the-world new-world)
result)))
(define the-world0 unique-world)
(define (install-world delta w)
(reset-event-history)
(set! the-delta delta)
(update-world (lambda (_) w))
(set! the-world0 w)
(vw-setup))
(define the-delta 1000)
(define visible-world #f)
(define (vw-setup)
(set! visible-world (new pasteboard%))
(send visible-world set-cursor (make-object cursor% 'arrow)))
(define (vw-init?) (is-a? visible-world pasteboard%))
(define (update-frame pict)
(send visible-world begin-edit-sequence)
(send visible-world lock #f)
(let ([s (send visible-world find-first-snip)])
(when s
(send visible-world delete s)))
(let ([c (send visible-world get-canvas)])
(let-values ([(px py)
(if (is-a? pict cache-image-snip%)
(send pict get-pinhole)
(values 0 0))]
[(cw ch)
(send c get-client-size)])
(send visible-world insert (send pict copy) (- px) (- py))))
(send visible-world lock #t)
(send visible-world end-edit-sequence))
(define (set-and-show-frame w h animated-gif)
(define the-play-back-custodian (make-custodian))
(define frame (create-frame the-play-back-custodian))
(set! WIDTH w)
(set! HEIGHT h)
(when animated-gif
(add-stop-and-image-buttons frame the-play-back-custodian))
(add-editor-canvas frame visible-world w h)
(send frame show #t))
(define WIDTH 0)
(define HEIGHT 0)
(define (create-frame the-play-back-custodian)
(new (class frame%
(super-new)
(define/augment (on-close)
(callback-stop! 'create-frame)
(custodian-shutdown-all the-play-back-custodian)))
(label "DrScheme")
(stretchable-width #f)
(stretchable-height #f)
(style '(no-resize-border metal))))
(define IMAGES "Images")
(define-runtime-path s:pth '(lib "icons/break.png"))
(define-runtime-path i:pth '(lib "icons/file.gif"))
(define (add-stop-and-image-buttons frame the-play-back-custodian)
(define p (new horizontal-pane% [parent frame][alignment '(center center)]))
(define S ((bitmap-label-maker (string-constant break-button-label) s:pth) '_))
(define I ((bitmap-label-maker IMAGES i:pth) '_))
(define stop-button
(new button% [parent p] [label S] [style '(border)]
[callback (lambda (this-button e)
(callback-stop! 'stop-button)
(send this-button enable #f)
(send image-button enable #t))]))
(define image-button
(new button% [parent p] [enabled #f] [label I] [style '(border)]
[callback (lambda (b e)
(parameterize ([current-custodian the-play-back-custodian])
(define th (thread play-back))
(send b enable #f)))]))
(void))
(define (add-editor-canvas frame visible-world w h)
(define c
(new (class editor-canvas%
(super-new)
(define/override (on-char e) (key-callback (send e get-key-code)))
(define/override (on-event e) (mouse-callback e)))
(parent frame)
(editor visible-world)
(style '(no-hscroll no-vscroll))
(horizontal-inset INSET)
(vertical-inset INSET)))
(send c min-client-width (+ w INSET INSET))
(send c min-client-height (+ h INSET INSET))
(send c focus))
(define INSET 5)
(define TICK 'tick)
(define MOUSE 'mouse)
(define KEY 'key)
(define REC 'rec)
(define event-history '())
(define (reset-event-history)
(set! event-history '()))
(define (add-event type . stuff)
(set! event-history (cons (cons type stuff) event-history)))
(define (zfill a-num a-len)
(let ([n (number->string a-num)])
(string-append (build-string (max (- a-len (string-length n)) 0)
(lambda (i) #\0))
n)))
(define (play-back)
(define (world-transition world fst)
(case (car fst)
[(tick) (timer-callback0 world)]
[(key) (key-callback0 world (cadr fst))]
[(mouse) (mouse-callback0 world (cadr fst) (caddr fst) (cadddr fst))]
[(rec) (receive-callback0 world (cadr fst))]
[else (error 'play-back "bad type of event: ~s" fst)]))
(define total (+ (length event-history) 1))
(define image-count 0)
(define bitmap-list '())
(define (save-image img)
(define-values (w h) (send img get-size))
(define (make-bitmap)
(define bm (make-object bitmap% w h))
(define dc (make-object bitmap-dc% bm))
(send dc clear)
(send img draw dc 0 0 0 0 w h 0 0 #f)
bm)
(define bm (make-bitmap))
(set! bitmap-list (cons bm bitmap-list))
(set! image-count (+ image-count 1))
(send bm save-file (format "i~a.png" (zfill image-count (string-length (number->string total)))) 'png))
(define target:dir
(let* ([cd (current-directory)]
[dd (get-directory "Select directory for images" #f cd)])
(if dd dd cd)))
(parameterize ([current-directory target:dir])
(let replay ([ev (reverse event-history)][world the-world0])
(define img (redraw-callback0 world))
(update-frame (text (format "~a/~a created" image-count total) 18 'red))
(save-image img)
(cond
[(null? ev)
(update-frame (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red))
(create-animated-gif (reverse bitmap-list))
(update-frame img)]
[else
(let ([world1 (world-transition world (car ev))])
(replay (cdr ev) world1))]))))
(define (create-animated-gif bitmap-list)
(define intv (if (> +inf.0 *the-delta* 0) (inexact->exact (floor (* 100 *the-delta*))) 5))
(when (file-exists? ANIMATED-GIF-FILE)
(delete-file ANIMATED-GIF-FILE))
(write-animated-gif bitmap-list intv ANIMATED-GIF-FILE #:one-at-a-time? #t #:loop? #f))
(define ANIMATED-GIF-FILE "i-animated.gif")
(define-syntax (define-callback stx)
(syntax-case stx ()
[(_ n msg (f esp ...) para body ...)
(let* ([n:str (symbol->string (syntax-e (syntax n)))]
[callback (lambda (before after)
(string->symbol
(string-append before n:str "-callback" after)))]
[name (datum->syntax stx (callback "" ""))]
[name0 (datum->syntax stx (callback "" "0"))]
[set-name (datum->syntax stx (callback "set-" ""))])
#`(define-values (#,name #,name0 #,set-name)
(values
void void
(lambda (f esp ...)
(when (callback-set? #,name)
(error (format "the ~a has already been specified") msg))
(set! #,name0 f)
(set! #,name (lambda para body ...))))))]))
(define (callback-stop! . n)
(send the-time stop)
(set! timer-callback void)
(set! mouse-callback void)
(set! key-callback void)
(set! receive-callback void)
(set! stop-when-callback (lambda () #f))
(set! redraw-callback void)
(set! *running?* #f))
(define (callback-set? cb) (not (eq? cb void)))
(define the-time (new timer% [notify-callback (lambda () (timer-callback))]))
(define-callback timer "tick-event hander" (f) ()
(with-handlers ([exn:break? break-handler][exn? exn-handler])
(update-world f) (add-event TICK)
(redraw-callback)))
(define-callback redraw "redraw function" (f) ()
(with-handlers ([exn:break? break-handler][exn? exn-handler])
(define result (f the-world))
(define fname (object-name f))
(define tname (if fname fname 'your-redraw-function))
(if (image? result)
(check-result tname scene? "scene" result
(format "image with pinhole at (~s,~s)"
(pinhole-x result) (pinhole-y result)))
(check-result tname (lambda (x) (image? x)) "scene" result))
(update-frame result)
(when (stop-when-callback)
(callback-stop! 'stop-when-callback))))
(define-callback stop-when "is end of world check" (f) ()
(define result (f the-world))
(define fname (object-name f))
(define tname (if fname fname 'your-redraw-function))
(check-result fname boolean? "boolean" result)
result)
(define-callback key "key-event handler" (f evt-space) (e)
(parameterize ([current-eventspace evt-space])
(queue-callback
(lambda ()
(with-handlers ([exn:break? break-handler][exn? exn-handler])
(unless (update-world (lambda (w) (f w e)))
(add-event KEY e)
(redraw-callback)))))))
(define-callback mouse "mouse event handler" (f evt-space) (e)
(parameterize ([current-eventspace evt-space])
(queue-callback
(lambda ()
(define x (- (send e get-x) INSET))
(define y (- (send e get-y) INSET))
(define m (mouse-event->symbol e))
(when (and (<= 0 x WIDTH) (<= 0 y HEIGHT))
(with-handlers ([exn:break? break-handler][exn? exn-handler])
(unless (update-world (lambda (w) (f w x y m)))
(add-event MOUSE x y m)
(redraw-callback))))))))
(define (mouse-event->symbol e)
(cond [(send e button-down?) 'button-down]
[(send e button-up?) 'button-up]
[(send e dragging?) 'drag]
[(send e moving?) 'move]
[(send e entering?) 'enter]
[(send e leaving?) 'leave]
[else (error 'on-mouse-event
(format
"Unknown event type: ~a"
(send e get-event-type)))]))
(define (exn-handler e)
(callback-stop! 'exn-handler)
(raise e))
(define (break-handler . _)
(printf "animation stopped")
(callback-stop! 'break-handler)
the-world)
(define (number->integer x)
(inexact->exact (floor x)))
(define TRIES 3) (define PAUSE 2)
(provide
register LOCALHOST )
(define (register ip . sexp)
(check-arg 'register (string? ip) "ip address" 'first ip)
(check-arg 'register (or (null? sexp) (sexp? (car sexp))) "sexp"
"second, optional" sexp)
(apply register0 ip sexp))
(define (register0 ip . sexp)
(define host
(if (string=? LOCALHOST ip)
"server on local host"
(format "server at ~a" ip)))
(define (register n)
(define (err b)
(define FMT "unable to register with ~a after ~s tries")
(if b (error 'register FMT host TRIES) (error 'register FMT host TRIES)))
(define (handler x)
(unless (> n 0) (err #t))
(sleep PAUSE)
(register (- n 1)))
(printf "trying to register with ~a ...\n" host)
(with-handlers ((exn:fail:network? handler))
(define-values (in out) (tcp-connect ip SQPORT))
(tcp-send out `(REGISTER ,sexp))
(let ([ackn (tcp-receive in)])
(if (eq? ackn 'okay)
(values in out)
(err #f)))))
(define (RECEIVE)
(sync
(wrap-evt
in
(lambda (in)
(define msg (tcp-receive in))
(unless (sexp? msg)
(error 'rec "can't happen: sexp expected from server, rec'd: ~e" msg))
(receive-callback msg)
(RECEIVE)))))
(define-values (in out) (register TRIES))
(printf "... successful registered and ready to receive\n")
(set-server-out! out (thread RECEIVE))
true)
(define-struct package (world message) #:transparent)
(define (create-package w m)
(check-arg 'make-package (sexp? m) 'sexp "second" m)
(make-package w m))
(provide
(rename-out
(create-package make-package) )
package-world
package-message
package?)
(define *out* #f)
(define *rec* #f)
(define (set-server-out! f th)
(set! *out* f)
(set! *rec* th))
(define-callback receive "receive-event handler" (f) (m)
(queue-callback
(lambda ()
(with-handlers ([exn:break? break-handler][exn? exn-handler])
(update-world (lambda (w) (f w m)))
(add-event REC m)
(redraw-callback)))))
(require htdp/error)
(define LIMIT 2)
(define (make-initial-state-and-messages player1 player2)
(void))
(define (process-message s p m)
(void))
(define (administrator-start players)
(define (loop state)
(define (player-wait-for-msg p)
(wrap-evt (player-in p) (read-and-process-message state p loop)))
(apply sync (map player-wait-for-msg players)))
(define x (apply make-initial-state-and-messages players))
(broadcast (rest x))
(loop (first x)))
(define (read-and-process-message state@t p loop)
(lambda (in)
(define received (tcp-receive in))
(define response (process-message state@t p received))
(define state@t+1 (first response))
(define send-out (rest response))
(show (list (format "received from ~a: ~a" (player-name p) received)))
(broadcast send-out)
(loop state@t+1)))
(define (broadcast lm)
(for-each (lambda (p+m) (player-send (first p+m) (second p+m))) lm)
(show
(map (lambda (p+m)
(format "sent msg to ~a : ~a" (player-name (first p+m)) (second p+m)))
lm)))
(define show void)
(define-struct player (in out name info) #:transparent)
(define (create-player i o info)
(make-player i o (gensym 'player) info))
(define (player-send p sexp)
(tcp-send (player-out p) sexp))
(require scheme/match)
(define gui:ch (make-channel))
(define dr:custodian (current-custodian))
(define the-custodian (make-custodian))
(define (listener enable-stop)
(lambda ()
(define tcp-listener
(with-handlers ((exn:fail:network?
(lambda (x) (custodian-shutdown-all the-custodian))))
(tcp-listen SQPORT 4 #t)))
(define (loop players add-player)
(sync (wrap-evt (tcp-accept-evt tcp-listener) (add-player players))
(wrap-evt gui:ch (interpret-command players))))
(define (add-no-players players)
(lambda (in-out)
(define out (second in-out))
(tcp-send out 'no)
(close-input-port (first in-out))
(close-output-port out)
(loop players add-no-players)))
(define (add-player players)
(lambda (in-out)
(define in (first in-out))
(define out (second in-out))
(define next (tcp-receive in)) (match next
[(cons 'REGISTER info)
(let* ([p (create-player in out info)]
[players (cons p players)])
(players->announcement p)
(player-send p 'okay)
(if (>= player# LIMIT) (go players) (loop players add-player)))]
[else (printf "erroneous connection: ~s\n" next)
(loop players add-player)])))
(define player# 0)
(define (players->announcement p)
(set! player# (+ player# 1))
(show `(,(format "~a signed up as player ~a" (player-name p) player#))))
(define (go players)
(enable-stop)
(thread (lambda () (administrator-start players)))
(loop 'dummy add-no-players))
(define (interpret-command players)
(lambda (c)
(case c
[(START) (go players)]
[(STOP-RESTART)
(parameterize ([current-custodian dr:custodian])
(show '("... done" "----------------------------------"))
(thread
(lambda ()
(custodian-shutdown-all the-custodian)
(run-server))))]
[(STOP) (custodian-shutdown-all the-custodian)]
[else (error 'command "got ~e" c)])))
(loop '() add-player)))
(define (gui)
(define frame
(new (class frame%
(super-new)
(define/augment (on-close)
(send frame show #f)
(channel-put gui:ch 'STOP)))
[label "Server"][width 500][height 200][style '(metal)]))
(define panel (new horizontal-panel%
[parent frame]
[stretchable-height #f]
[alignment '(center center)]))
(define (switch)
(send stop enable #t)
(send s&re enable #t))
(define (stop* stop-l hide? en?)
(new button% [parent panel] [label stop-l] [enabled en?]
[callback (lambda (but evt)
(define msg (if hide? 'STOP 'STOP-RESTART))
(channel-put gui:ch msg)
(when hide? (send frame show #f)))]))
(define stop (stop* "stop" #t #t))
(define s&re (stop* "stop game & relaunch server" #f #f))
(define (show lostr)
(queue-callback
(lambda ()
(send text lock #f)
(for-each (lambda (str) (send text insert (format "~a\n" str))) lostr)
(send text lock #t))))
(define text (new text%))
(new editor-canvas% [parent frame]
[editor text] [style '(no-border combo no-hscroll auto-vscroll)])
(send text lock #t)
(send frame show #t)
(values show switch (lambda () (send frame show #f))))
(define *universe-sema* (make-semaphore 1))
(define *universe-running?* #f)
(define (universe initial* process*)
(semaphore-wait *universe-sema*)
(when *universe-running?*
(semaphore-post *universe-sema*)
(error 'universe "another universe is up and running"))
(set! *universe-running?* #t)
(semaphore-post *universe-sema*)
(check-proc 'universe initial* 2 "first" "two arguments")
(check-proc 'universe process* 3 "second" "two arguments")
(let*-values ([(sh sw cl) (gui)])
(set! show sh)
(set! switch sw)
(set! make-initial-state-and-messages
(check-res cl initial* (name initial* "\"initial\" function")))
(set! process-message
(check-res cl process* (name process* "\"process\" function")))
(run-server)
#t))
(define (check-res close f n)
(define s (format "expected from ~a; given: " n))
(define (stop msg)
(printf "universe: ~a\n" msg)
(printf "shutting down\n")
(close)
(custodian-shutdown-all the-custodian))
(lambda x
(define r (apply f x))
(cond
[(cons? r) (let ([m (cdr r)])
(if (mails? m)
r
(stop (format "list of Mails ~a~e" s m))))]
[else (stop (format "(cons ServerState Mail) ~a~e" s r))])))
(define (name o alt)
(define initial-name (object-name o))
(if initial-name initial-name alt))
(define (mails? m)
(andmap (lambda (x)
(and (cons? x) (cons? (cdr x)) (player? (car x)) (sexp? (cdr x))))
m))
(define switch void)
(define (run-server)
(show '("starting a server ..."))
(set! the-custodian (make-custodian))
(parameterize ([current-custodian the-custodian])
(thread (listener switch))))
(provide sexp?)
(provide
player? universe )
(define (sexp? x)
(cond
[(empty? x) true]
[(string? x) true]
[(symbol? x) true]
[(number? x) true]
[(char? x) true]
[(pair? x) (and (list? x) (andmap sexp? x))]
[else false]))
(define (tcp-send out msg)
(fprintf out "~s\n" msg)
(flush-output out))
(define (tcp-receive in)
(define x (read-line in))
(cond
[(eof-object? x)
(printf "tcp-receive: connection closed prematurely")
(exit)]
[(string=? x "") (error 'tcp-receive "can't happen")]
[else (read (open-input-string x))]))
(define SQPORT 4567)
(define LOCALHOST "127.0.0.1")
![[logo]](/logo.png){kind=logo}