htdp/peer-universe examples

examples/bouncing-ball-client.rkt

@@ -0,0 +1,85 @@
+#lang racketscript/base
+(require racketscript/htdp/peer-universe
+         racketscript/htdp/image)
+
+;; Implementation of bouncing ball example from
+;; 2htdp/universe docs
+;; ( https://docs.racket-lang.org/teachpack/2htdpuniverse.html )
+;; (ctrl + F search for "Designing the Ball World")
+
+(define SPEED 5)
+(define RADIUS 10)
+(define WORLD0 'RESTING)
+
+(define WIDTH 600)
+(define HEIGHT 400)
+(define MT (empty-scene WIDTH HEIGHT))
+(define BALL (circle RADIUS 'solid 'blue))
+
+(define (move ws)
+  (define is-active (number? ws))
+  (if is-active
+    (if (<= ws 0)
+        (make-package 'RESTING #js"done")
+        (- ws SPEED))
+    ws))
+
+(define (draw ws)
+  (cond
+    [(number? ws) (underlay/xy MT 50 ws BALL)]
+    [else (underlay/xy MT 50 50 (text "Resting" 24 'blue))]))
+
+;; The only message that the server send is the your-turn one,
+;; so this will always return HEIGHT as the next world state
+(define (receive ws msg)
+  (if (number? ws)
+      ws
+      HEIGHT))
+
+;; Stops world when ws == "stop"
+(define (stop? ws) (equal? ws "stop"))
+
+(define (handle-key ws key)
+  (if (equal? key " ")
+      "stop" ws))
+
+(define (start-world client-name server-id)
+    (big-bang WORLD0 
+              [on-tick move]
+              [to-draw draw]
+              [on-receive receive]
+              [register server-id]
+              [name client-name]
+              [on-key handle-key]
+              [stop-when stop?]))
+
+;; 
+;; User login UI
+;; 
+
+(define join-form         (#js*.document.createElement #js"form"))
+(define server-id-label   (#js*.document.createElement #js"label"))
+(define br-1              (#js*.document.createElement #js"br"))
+(define server-id-input   (#js*.document.createElement #js"input"))
+(define br-2              (#js*.document.createElement #js"br"))
+(define form-submit       (#js*.document.createElement #js"input"))
+
+($/:= #js.server-id-label.innerHTML   #js"Server's Peer ID")
+($/:= #js.server-id-input.placeholder #js"42adwadwa#$021")
+($/:= #js.form-submit.type            #js"submit")
+($/:= #js.form-submit.value           #js"Join!")
+
+(for-each (λ (el)
+            (#js.join-form.appendChild el)
+            0)
+          (list server-id-label br-1 server-id-input
+                br-2
+                form-submit))
+
+($/:= #js.join-form.onsubmit
+      (λ ()
+        (start-world "user"
+                     (js-string->string #js.server-id-input.value))
+        (#js.join-form.remove)))
+
+(#js*.document.body.appendChild join-form)

examples/bouncing-ball-server.rkt

@@ -0,0 +1,130 @@
+#lang racketscript/base
+
+(require racketscript/htdp/peer-universe
+         racketscript/htdp/image
+         racket/list)
+
+
+;; 
+;; Funny words courtesy of ChatGPT
+;; 
+
+(define funny-adjectives (list "bumbling"
+                               "quizzical"
+                               "wacky"
+                               "zany"
+                               "fluffy"
+                               "bizarre"
+                               "hilarious"
+                               "whimsical"
+                               "absurd"
+                               "goofy"
+                               "ridiculous"
+                               "loopy"
+                               "nutty"
+                               "eccentric"
+                               "silly"
+                               "quirky"
+                               "jovial"
+                               "giggly"
+                               "mirthful"
+                               "haphazard"
+                               "chucklesome"
+                               "fanciful"
+                               "droll"
+                               "boisterous"
+                               "offbeat"
+                               "hysterical"
+                               "peculiar"
+                               "lighthearted"
+                               "playful"
+                               "amusing"))
+
+(define funny-nouns (list "goober"
+                          "banana"
+                          "sock-puppet"
+                          "llama"
+                          "rubber-chicken"
+                          "pajamas"
+                          "gobbledygook"
+                          "poodle"
+                          "bubble-wrap"
+                          "tater-tot"
+                          "cheeseburger"
+                          "wiggle"
+                          "snorkel"
+                          "ticklemonster"
+                          "jello"
+                          "balloon-animal"
+                          "slinky"
+                          "spaghetti"
+                          "bumblebee"
+                          "dingleberry"
+                          "flapdoodle"
+                          "doohickey"
+                          "noodle"
+                          "gobbledygook"
+                          "whatchamacallit"
+                          "snickerdoodle"
+                          "popsicle"
+                          "gigglesnort"
+                          "wobble"
+                          "hootenanny"
+                          "noodle"))
+
+(define (generate-id)
+  (define adjective (list-ref funny-adjectives 
+                              (random (length funny-adjectives))))
+  (define noun (list-ref funny-nouns
+                         (random (length funny-nouns))))
+  (format "~a-~a" adjective noun))
+
+
+;; 
+;; Helper functions
+;; 
+
+(define (make-curr-mail ws)
+  (define curr-iw (first ws))
+  (list (make-mail curr-iw #js"it-is-your-turn")))
+
+
+;; 
+;; Event handlers
+;; 
+
+(define (handle-new ws iw)
+  (define ws* (append ws (list iw)))
+  (define mails (make-curr-mail ws*))
+  (define to-remove '())
+  (make-bundle ws* mails to-remove))
+
+(define (handle-msg ws iw msg)
+  (define ws* (append (rest ws) (list (first ws))))
+  (define mails (make-curr-mail ws*))
+  (define to-remove '())
+  (make-bundle ws* mails to-remove))
+
+(define (handle-disconnect ws iw)
+  (define ws* (remove iw ws))
+  (define mails (make-curr-mail ws*))
+  (define to-remove '())
+  (make-bundle ws* mails to-remove))
+
+(define (handle-tick ws)
+  (make-bundle ws '() '()))
+
+
+;; 
+;; Starting server on window load
+;; 
+
+(define (start-universe)
+  (universe '()
+    [server-id     (generate-id)]
+    [on-new        handle-new]
+    [on-msg        handle-msg]
+    [on-tick       handle-tick]
+    [on-disconnect handle-disconnect]))
+
+($/:= #js*.window.onload start-universe)