Exploring more HLL-style examples

doc/big-bang.rkt.txt

@@ -0,0 +1,51 @@
+#lang racket ;; -*- racket -*-
+
+(require "../main.rkt")
+(require "../big-bang.rkt")
+
+(define (button #:background [background "grey"]
+                #:foreground [foreground "white"]
+                #:font-size [font-size 22]
+                name x y label callback)
+  (define label-image (text label font-size foreground))
+  (actor (forever
+          (on (message (at-meta (mouse-event ? ? name "button-down"))) (callback))
+          (assert (window name x y 0
+                          (seal
+                           (overlay label-image
+                                    (rectangle (+ (image-width label-image) 20)
+                                               (+ (image-height label-image) 20)
+                                               "solid"
+                                               background))))))))
+
+(define (draggable-shape name orig-x orig-y image)
+  (define (move-to x y) (assert (update-window name x y image #:z 10)))
+  (define (idle ticks x y)
+    (state [#:collect [(ticks ticks) (x x) (y y)]
+            (move-to x y)
+            (on (message (at-meta (tick-event)))
+                (define new-ticks (+ ticks 1))
+                (define displacement (* (cos (* new-ticks 10 1/180 pi)) 4))
+                (values new-ticks x (+ y displacement)))]
+      [(message (at-meta (mouse-event mx my name "button-down")))
+       (dragging mx my (- mx x) (- my y))]))
+  (define (dragging mx my dx dy)
+    (state [#:collect [(mx mx) (my my)]
+            (move-to (- mx dx) (- my dy))
+            (on (message (at-meta (mouse-event mx my ? "drag"))) (values mx my))]
+      [(message (at-meta (mouse-event mx my ? (or "leave" "button-up"))))
+       (idle 0 (- mx dx) (- my dy))]))
+  (actor (idle 0 orig-x orig-y)))
+
+(big-bang-world #:width 640
+                #:height 480
+                (actor (forever
+                        (on (asserted (active-window $id) #:meta-level 1)
+                            (update-window 'active-window-label 300 0
+                                           (text (format "~v" id) 22 "black")))))
+                (button #:background "red" 'stop-button 0 0 "Exit"
+                        (lambda () (assert! 'stop #:meta-level 1)))
+                (draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))
+                (draggable-shape 's1 100 100 (star 40 "solid" "firebrick")))
+
+(exit 0)

doc/chat-client.rkt.txt

@@ -0,0 +1,22 @@
+#lang prospect ;; -*- racket -*-
+
+(require (only-in racket/port read-bytes-line-evt))
+(require "../drivers/tcp.rkt")
+
+(define local-handle (tcp-handle 'chat))
+(define remote-handle (tcp-address "localhost" 5999))
+
+(spawn-tcp-driver)
+(actor (define e (read-bytes-line-evt (current-input-port) 'any))
+       (until quit?
+              #:collect [quit? #f]
+              (assert (advertise (tcp-channel local-handle remote-handle ?)))
+              (on (retracted (advertise (tcp-channel remote-handle local-handle ?))) #t)
+              (on (message (at-meta (external-event e (list $value))))
+                  (match value
+                    [(? eof-object?) #t]
+                    [(? bytes?) (send! (tcp-channel local-handle remote-handle value)) #f]))
+              (on (message (tcp-channel remote-handle local-handle $bs))
+                  (write-bytes bs)
+                  (flush-output)
+                  #f)))

doc/chat.rkt.txt

@@ -0,0 +1,31 @@
+#lang prospect ;; -*- racket -*-
+
+(require (only-in racket/string string-trim))
+(require "../drivers/tcp.rkt")
+(require "../demand-matcher.rkt")
+
+(define (spawn-session them us)
+  (define user (gensym 'user))
+  (define (send-to-remote fmt . vs)
+    (send! (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
+  (define (say who fmt . vs)
+    (unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
+  (actor (send-to-remote "Welcome, ~a.\n" user)
+         (until (retracted (advertise (tcp-channel them us ?)) #:meta-level 1)
+           (assert (advertise (tcp-channel us them ?) #:meta-level 1))
+           (assert (advertise `(,user says ,?)))
+           (on (asserted (advertise `(,$who says ,?))) (say who "arrived."))
+           (on (retracted (advertise `(,$who says ,?))) (say who "departed."))
+           (on `(,$who says ,$what) (say who "says: ~a" what))
+           (on (message (at-meta (tcp-channel them us $bs)))
+               (define input-string (string-trim (bytes->string/utf-8 bs)))
+               (if (equal? input-string "quit-world")
+                   (assert! 'quit-world)
+                   (send! `(,user says ,input-string)))))
+         (send-to-remote "Goodbye!\n")))
+
+(spawn-tcp-driver)
+(let ((us (tcp-listener 5999)))
+  (group (until (asserted 'quit-world)
+           (on (asserted (advertise (tcp-channel $them us ?)) #:meta-level 1)
+               (spawn-session them us)))))

doc/echo.rkt.txt

@@ -0,0 +1,16 @@
+#lang prospect ;; -*- racket -*-
+
+(require "../drivers/tcp.rkt")
+(require "../demand-matcher.rkt")
+
+(define server-id (tcp-listener 5999))
+
+(spawn-tcp-driver)
+(actor (forever
+        (on (asserted (advertise (tcp-channel $c server-id ?)))
+            (printf "Accepted connection from ~v\n" c)
+            (actor (until (retracted (advertise (tcp-channel c server-id ?)))
+                     (advertise (tcp-channel server-id c ?))
+                     (on (tcp-channel c server-id bs)
+                         (send! (tcp-channel server-id c bs))))
+                   (printf "Closed connection ~v\n" c)))))