Lots of boxes

bot/Makefile

@@ -0,0 +1,12 @@
+# See https://gitlab.com/preserves/preserves/-/issues/39
+WORKAROUND_PRESERVES_ISSUE_39=--base `realpath ../protocols/schemas`/
+
+schemas:
+	preserves-schema-rkt \
+		--output schemas \
+		$(WORKAROUND_PRESERVES_ISSUE_39) \
+		--module noise=:syndicate/schemas/noise \
+		../protocols/schemas/**.prs
+
+clean:
+	rm -rf schemas/

bot/bot.rkt

@@ -0,0 +1,43 @@
+#lang syndicate
+
+(module+ main
+  (require syndicate/distributed/tcp)
+  (require syndicate/drivers/timer)
+  (require syndicate/gensym)
+  (require racket/math)
+
+  (require "schemas/scene.rkt")
+  (require "schemas/shapes.rkt")
+
+  (assertion-struct SceneHandle (ds))
+
+  (standard-actor-system (ds)
+    (define (on-connected remote-ds)
+      (at remote-ds
+        (during (SceneHandle $scene-e)
+          (define scene (embedded-value scene-e))
+
+          (define (bouncy-box)
+            (define me (symbol->string (strong-gensym 'user)))
+            (define start-time (current-inexact-milliseconds))
+            (define-field deadline start-time)
+            (define-field x (* (- (random) 0.5) 100))
+            (define y0 (+ 1.0 (* (random) 10)))
+            (define-field y y0)
+            (define-field z (* (- (random) 0.5) 100))
+            (at ds
+              (on (asserted (LaterThan (deadline)))
+                (deadline (+ (deadline) (/ 1000 10)))
+                (y (+ y0 (cos (/ (- (deadline) start-time) 1000.0 (/ 1 2 pi)))))))
+            (define r (random))
+            (define g (random))
+            (define b (random))
+            (at scene
+              (assert (Sprite me (Move (Vector3 (x) (y) (z))
+                                       (Color-opaque r g b (Box)))))
+              ))
+
+          (for [(i 100)] (bouncy-box)))))
+
+    (run-tcp-client-relay ds #:hostname "vr.demo.leastfixedpoint.com" #:port 9001
+                          #:import (lambda (v) (on-connected (embedded-value v))))))

bot/schemas/scene.rkt

@@ -0,0 +1,148 @@
+(module scene racket/base
+  (provide (except-out (all-defined-out) :decode-embedded :encode-embedded)
+           (rename-out
+            (:decode-embedded decode-embedded:scene)
+            (:encode-embedded encode-embedded:scene)))
+  (require preserves)
+  (require preserves-schema/methods)
+  (require preserves-schema/support)
+  (require racket/match)
+  (require racket/set)
+  (require racket/dict)
+  (require (only-in racket/generic define/generic))
+  (require (prefix-in noise: syndicate/schemas/noise))
+  (require (prefix-in shapes: "shapes.rkt"))
+  (define :decode-embedded values)
+  (define :encode-embedded values)
+  (struct
+   AmbientSound
+   (name spec)
+   #:transparent
+   #:methods
+   gen:preservable
+   ((define/generic *->preserve ->preserve)
+    (define (->preserve preservable)
+      (match
+       preservable
+       ((AmbientSound ?name ?spec)
+        (record
+         'ambient-sound
+         (list (*->preserve ?name) (*->preserve ?spec))))))))
+  (define (parse-AmbientSound input)
+    (match
+     input
+     ((and dest
+           (record
+            'ambient-sound
+            (list
+             (and ?name (? string?))
+             (app shapes:parse-SoundSpec (and ?spec (not (== eof)))))))
+      (AmbientSound ?name ?spec))
+     (_ eof)))
+  (define parse-AmbientSound!
+    (parse-success-or-error 'parse-AmbientSound parse-AmbientSound))
+  (struct
+   Gravity
+   (direction)
+   #:transparent
+   #:methods
+   gen:preservable
+   ((define/generic *->preserve ->preserve)
+    (define (->preserve preservable)
+      (match
+       preservable
+       ((Gravity ?direction)
+        (record 'gravity (list (*->preserve ?direction))))))))
+  (define (parse-Gravity input)
+    (match
+     input
+     ((and dest
+           (record
+            'gravity
+            (list (app shapes:parse-Vector3 (and ?direction (not (== eof)))))))
+      (Gravity ?direction))
+     (_ eof)))
+  (define parse-Gravity! (parse-success-or-error 'parse-Gravity parse-Gravity))
+  (struct
+   Portal
+   (name destination position)
+   #:transparent
+   #:methods
+   gen:preservable
+   ((define/generic *->preserve ->preserve)
+    (define (->preserve preservable)
+      (match
+       preservable
+       ((Portal ?name ?destination ?position)
+        (record
+         'portal
+         (list
+          (*->preserve ?name)
+          (*->preserve ?destination)
+          (*->preserve ?position))))))))
+  (define (parse-Portal input)
+    (match
+     input
+     ((and dest
+           (record
+            'portal
+            (list
+             (and ?name (? string?))
+             (app parse-PortalDestination (and ?destination (not (== eof))))
+             (app shapes:parse-Vector3 (and ?position (not (== eof)))))))
+      (Portal ?name ?destination ?position))
+     (_ eof)))
+  (define parse-Portal! (parse-success-or-error 'parse-Portal parse-Portal))
+  (define (PortalDestination? p)
+    (or (PortalDestination-local? p) (PortalDestination-remote? p)))
+  (struct
+   PortalDestination-local
+   (value)
+   #:transparent
+   #:methods
+   gen:preservable
+   ((define/generic *->preserve ->preserve)
+    (define (->preserve preservable)
+      (match preservable ((PortalDestination-local src) (embedded src))))))
+  (struct
+   PortalDestination-remote
+   (value)
+   #:transparent
+   #:methods
+   gen:preservable
+   ((define/generic *->preserve ->preserve)
+    (define (->preserve preservable)
+      (match preservable ((PortalDestination-remote src) (*->preserve src))))))
+  (define (parse-PortalDestination input)
+    (match
+     input
+     ((embedded dest) (PortalDestination-local dest))
+     ((app noise:parse-Route (and dest (not (== eof))))
+      (PortalDestination-remote dest))
+     (_ eof)))
+  (define parse-PortalDestination!
+    (parse-success-or-error 'parse-PortalDestination parse-PortalDestination))
+  (struct
+   Touch
+   (subject object)
+   #:transparent
+   #:methods
+   gen:preservable
+   ((define/generic *->preserve ->preserve)
+    (define (->preserve preservable)
+      (match
+       preservable
+       ((Touch ?subject ?object)
+        (record
+         'touch
+         (list (*->preserve ?subject) (*->preserve ?object))))))))
+  (define (parse-Touch input)
+    (match
+     input
+     ((and dest
+           (record
+            'touch
+            (list (and ?subject (? string?)) (and ?object (? string?)))))
+      (Touch ?subject ?object))
+     (_ eof)))
+  (define parse-Touch! (parse-success-or-error 'parse-Touch parse-Touch)))