From 32146401367116dd538eaaf23eb0f69d858df99a Mon Sep 17 00:00:00 2001
From: Vivianne Langdon <puttabutta@gmail.com>
Date: Sun, 16 Jul 2023 18:35:12 -0700
Subject: [PATCH] wip

---
 Makefile.am                           |  4 +-
 gib-gab-gob/ui/catbird.scm            | 93 ++++++++++++++++++++++-----
 gib-gab-gob/util/chickadee-vat.scm    | 38 ++++++++---
 gib-gab-gob/util/concurrent-queue.scm | 90 ++++++++++++++++++++++++++
 hall.scm                              | 29 ++++++---
 scripts/make-initiator.in             |  6 +-
 scripts/make-joiner.in                |  2 +-
 7 files changed, 220 insertions(+), 42 deletions(-)
 create mode 100644 gib-gab-gob/util/concurrent-queue.scm

diff --git a/Makefile.am b/Makefile.am
index e0d4b91..1994382 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -36,7 +36,9 @@ SUFFIXES = .scm .go
 SOURCES = gib-gab-gob/rps.scm \
 					gib-gab-gob/game.scm \
 					gib-gab-gob/board.scm \
-					gib-gab-gob/ui/console.scm
+					gib-gab-gob/ui/console.scm \
+				  gib-gab-gob/ui/catbird.scm \
+					gib-gab-gob/util/chickadee-vat.scm
 
 TESTS =
 
diff --git a/gib-gab-gob/ui/catbird.scm b/gib-gab-gob/ui/catbird.scm
index 96e7b68..ebd0188 100644
--- a/gib-gab-gob/ui/catbird.scm
+++ b/gib-gab-gob/ui/catbird.scm
@@ -1,18 +1,30 @@
 (define-module (gib-gab-gob ui catbird)
+  #:use-module (gib-gab-gob board)
+  #:use-module (gib-gab-gob rps)
+  #:use-module (gib-gab-gob util chickadee-vat)
+  #:use-module (gib-gab-gob game)
+  #:use-module (goblins)
+  #:use-module (goblins ocapn captp)
+  #:use-module (goblins ocapn ids)
+  #:use-module (goblins ocapn netlayer onion)
   #:use-module (catbird)
   #:use-module (catbird input-map)
   #:use-module (catbird mode)
   #:use-module (catbird node)
   #:use-module (catbird node-2d)
   #:use-module (catbird region)
+  #:use-module (catbird camera)
   #:use-module ((catbird scene)
                 #:select (<scene> current-scene replace-major-mode))
   #:use-module (chickadee)
   #:use-module (chickadee graphics color)
   #:use-module (chickadee graphics texture)
+  #:use-module (chickadee graphics path)
   #:use-module (chickadee math vector)
   #:use-module (chickadee scripting)
-  #:use-module (oop goops))
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-43)
+  #:export (make-initiator make-joiner))
 
 (define %window-width 1024)
 (define %window-height 768)
@@ -29,7 +41,7 @@
   (board #:getter board #:init-keyword #:board)
   (tiles #:accessor tiles #:init-value #()))
 
-(define-method (on-boot (board-view <board-view>))
+(define-method (initialize (board-view <board-view>) initargs)
   (define tile-container
     (make <node-2d>
       #:name 'tile-container
@@ -39,15 +51,16 @@
       #:name 'background
       #:painter
       (with-style ((fill-color db32-elf-green))
-                  (fill
-                   rectangle (vec2 0.0 0.0)
-                   %window-width
-                   %window-height))))
-  (resize board-view %window-width %window-height)
-  (attach-to board-view tile-container))
+        (fill
+         rectangle (vec2 0.0 0.0)
+         %window-width
+         %window-height))))
+  (next-method)
+  (attach-to board-view tile-container)
+  (rebuild-tiles board-view))
 
-(define-method (tile-ref (garden <garden-view>) x y)
-  (vector-ref (vector-ref (tiles garden) y) x))
+(define-method (tile-ref (board-view <board-view>) x y)
+  (vector-ref (vector-ref (tiles board-view) y) x))
 
 (define-method (rebuild-tiles (board-view <board-view>))
   (let* ((container (& board-view tile-container)))
@@ -55,7 +68,7 @@
      (λ (x y tile)
        (detach tile))
      (tiles board-view))
-    (set! (tiles garden)
+    (set! (tiles board-view)
           (vector-unfold
            (λ (y)
              (vector-unfold
@@ -104,7 +117,7 @@
       row))
    tiles))
 
-(define-method (board-pick (board <board-view>) x y)
+(define-method (board-pick (board-view <board-view>) x y)
   (define (find-tile node)
     (cond
      ((not node)
@@ -114,7 +127,7 @@
      ((parent node)
       (find-tile (parent node)))
      (else #f)))
-  (find-tile (pick board (vec2 x y) (lambda _ #t))))
+  (find-tile (pick board-view (vec2 x y) (lambda _ #t))))
 
 (define-class <board-mode> (<major-mode>))
 
@@ -123,14 +136,14 @@
   (define node (board-pick board x y))
   (cond
    ((is-a? node <tile>)
-    (board-make-move board node))))
+    (format #t "moving ~a ~a\n" board node))))
 
 (bind-input <board-mode> (mouse-press 'left) make-move)
 
 (define* (launch-game node-thunk)
   (run-catbird
    (lambda ()
-     (let ((region (create-full-region #:name 'main))
+     (let ((region (make <full-region> #:name 'main))
            (scene (make <scene> #:name 'board)))
        (replace-scene region scene)
        (replace-major-mode scene (make <board-mode>))
@@ -142,3 +155,53 @@
    #:title "Gib Gab Gob"
    #:width %window-width
    #:height %window-height))
+
+
+(define-class <initiator> (<node>)
+  (vat #:accessor vat))
+
+(define-method (initialize (initiator <initiator>) initargs)
+  (next-method)
+  (run-script initiator
+    (set! (vat initiator) (make-chickadee-vat #:agenda (agenda initiator)))
+    (vat-start! (vat initiator))
+    (let ((board (make-board)))
+      (with-vat (vat initiator)
+                (format #t "inside vat\n")
+                (let* ((my-turn+ (make-channel))
+                       (init (spawn ^game-initiator ^ggg-controller board my-turn+)))
+                  #f))
+      (attach-to initiator (make <board-view> #:vat (vat initiator) #:board board)))))
+
+(define (make-initiator)
+  (launch-game
+   (λ ()
+     (make <initiator> #:name 'root))))
+
+(define-class <joiner> (<node>)
+  (vat #:accessor vat)
+  (addr #:accessor addr #:init-keyword #:addr))
+
+(define-method (initialize (joiner <joiner>) initargs)
+  (next-method)
+  (run-script joiner
+    (let ((board (make-board)))
+      (set! (vat joiner) (make-chickadee-vat #:agenda (agenda joiner)))
+      (vat-start! (vat joiner))
+      (with-vat (vat joiner)
+                (let* ((mycapn (spawn-mycapn (new-onion-netlayer)))
+                       (my-turn+ (make-channel))
+                       (init-sref (string->ocapn-id addr))
+                       (initiator ($ mycapn 'enliven init-sref))
+                       (joiner (spawn ^game-joiner initiator ^ggg-controller board my-turn+))
+                       (sealed ($ joiner 'get-sealed-pick)))
+                  (on (<- initiator 'register-opponent joiner sealed)
+                      (λ (_)
+                        (on ($ joiner 'initialize!)
+                            (λ (status) (format #f "TODO: need to tell it to start here") #f))))))
+      (attach-to joiner (make <board-view> #:vat (vat joiner) #:board board)))))
+
+(define (make-joiner addr)
+  (launch-game
+   (λ ()
+     (make <joiner> #:name 'root #:addr addr))))
diff --git a/gib-gab-gob/util/chickadee-vat.scm b/gib-gab-gob/util/chickadee-vat.scm
index afef6ab..aa791a2 100644
--- a/gib-gab-gob/util/chickadee-vat.scm
+++ b/gib-gab-gob/util/chickadee-vat.scm
@@ -1,38 +1,56 @@
+;; Taken from https://gitlab.com/spritely/community-garden example,
+;; which appears to be licensed Apache 2.0.
+;; Small modifications have been made.
+
 (define-module (gib-gab-gob util chickadee-vat)
+  #:use-module (gib-gab-gob util concurrent-queue)
   #:use-module (chickadee)
   #:use-module (chickadee scripting)
-  #:use-module (community-garden concurrent-queue)
+  #:use-module (chickadee scripting agenda)
   #:use-module (goblins vat)
   #:use-module (ice-9 match)
   #:export (make-chickadee-vat))
 
 (define* (make-chickadee-vat #:key (name 'chickadee)
-                             (agenda (current-agenda)))
+                             (agenda (current-agenda))
+                             (log? #f))
   (define vat-script #f)
   (define message-queue (make-concurrent-queue))
   (define (start churn)
     (define (handle-messages)
+      (format #t "handle messages...")
       (if (concurrent-queue-empty? message-queue)
           (begin
-            (sleep (current-timestep)))
+            (format #t "sleep... ~a\n" (current-timestep))
+            (sleep (current-timestep))
+            (format #t "sleep done."))
           (match (concurrent-dequeue! message-queue)
             ((msg return-channel)
+             (format #t "dequeue w/ return....\n")
              (channel-put return-channel (churn msg)))
             (msg
+             (format #t "dequeue w/o return....\n")
              (churn msg))))
+      (format #t "done.\n")
       (handle-messages))
+    (format #t "churning... ~a\n" churn)
     (with-agenda agenda
+      (format #t "agenda... ~a" agenda)
       (set! vat-script (script (handle-messages)))))
   (define (halt)
     (cancel-script vat-script))
-  (define (send msg return?)
-    (if return?
+  (define (send envelope)
+    (format #t "env send\n")
+    (if (vat-envelope-return? envelope)
         (let ((return-channel (make-channel)))
-          (concurrent-enqueue! message-queue (list msg return-channel))
-          (channel-get return-channel))
-        (begin
-          (concurrent-enqueue! message-queue msg))))
+          (format #t "env enqueue\n")
+          (concurrent-enqueue! message-queue (list envelope return-channel))
+          (format #t "enqueued\n")
+          (channel-get return-channel)
+          (format #t "got return\n"))
+        (concurrent-enqueue! message-queue envelope)))
   (make-vat #:name name
             #:start start
             #:halt halt
-            #:send send))
+            #:send send
+            #:log? log?))
diff --git a/gib-gab-gob/util/concurrent-queue.scm b/gib-gab-gob/util/concurrent-queue.scm
new file mode 100644
index 0000000..a107d66
--- /dev/null
+++ b/gib-gab-gob/util/concurrent-queue.scm
@@ -0,0 +1,90 @@
+;; Taken from https://gitlab.com/spritely/community-garden example,
+;; which appears to be licensed Apache 2.0.
+;; Small modifications have been made.
+
+(define-module (gib-gab-gob util concurrent-queue)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (chickadee data array-list)
+  #:export (make-concurrent-queue
+            concurrent-queue?
+            concurrent-queue-length
+            concurrent-queue-empty?
+            concurrent-enqueue!
+            concurrent-dequeue!
+            concurrent-queue-clear!
+            concurrent-queue-close!))
+
+(define-record-type <concurrent-queue>
+  (%make-concurrent-queue input output mutex condvar)
+  concurrent-queue?
+  (input concurrent-queue-input)
+  (output concurrent-queue-output)
+  (mutex concurrent-queue-mutex)
+  (condvar concurrent-queue-condvar)
+  (closed? concurrent-queue-closed? set-concurrent-queue-closed!))
+
+(define (display-concurrent-queue q port)
+  (format port "#<concurrent-queue length: ~d>" (concurrent-queue-length q)))
+
+(set-record-type-printer! <concurrent-queue> display-concurrent-queue)
+
+(define (make-concurrent-queue)
+  "Return a new, empty queue."
+  (%make-concurrent-queue (make-array-list) (make-array-list)
+                          (make-mutex) (make-condition-variable)))
+
+(define (concurrent-queue-length q)
+  "Return the number of elements in Q."
+  (+ (array-list-size (concurrent-queue-input q))
+     (array-list-size (concurrent-queue-output q))))
+
+(define (concurrent-queue-empty? q)
+  "Return #t if Q is empty."
+  (zero? (concurrent-queue-length q)))
+
+(define (concurrent-enqueue! q item)
+  "Add ITEM to Q."
+  (if (concurrent-queue-closed? q)
+      (error "queue is closed" q)
+      (begin
+        (with-mutex (concurrent-queue-mutex q)
+          (array-list-push! (concurrent-queue-input q) item))
+        (signal-condition-variable (concurrent-queue-condvar q)))))
+
+(define (concurrent-dequeue! q)
+  "Remove the first element of Q."
+  (if (and (concurrent-queue-empty? q)
+           (concurrent-queue-closed? q))
+      #f
+      (with-mutex (concurrent-queue-mutex q)
+        ;; If the queue is empty, block until there's something to
+        ;; dequeue.
+        (when (concurrent-queue-empty? q)
+          (wait-condition-variable (concurrent-queue-condvar q)
+                                   (concurrent-queue-mutex q)))
+        (if (concurrent-queue-empty? q)
+            #f
+            (let ((input (concurrent-queue-input q))
+                  (output (concurrent-queue-output q)))
+              (when (array-list-empty? output)
+                (let loop ()
+                  (unless (array-list-empty? input)
+                    (array-list-push! output (array-list-pop! input))
+                    (loop))))
+              (array-list-pop! output))))))
+
+(define (concurrent-queue-clear! q)
+  "Remove all items from Q."
+  (with-mutex (concurrent-queue-mutex q)
+    (array-list-clear! (concurrent-queue-input q))
+    (array-list-clear! (concurrent-queue-output q))))
+
+(define (concurrent-queue-close! q)
+  "Close Q so that no more items may be enqueued."
+  (with-mutex (concurrent-queue-mutex q)
+    (set-concurrent-queue-closed! q #t)
+    (when (concurrent-queue-empty? q)
+      (signal-condition-variable (concurrent-queue-condvar q)))))
diff --git a/hall.scm b/hall.scm
index e5dfdb3..fd1a822 100644
--- a/hall.scm
+++ b/hall.scm
@@ -12,12 +12,21 @@
   (license gpl3+)
   (dependencies
     `(("guile-goblins" (goblins) ,guile-goblins)
-      ("chickadee" (chickadee) ,chickadee)))
+      ("chickadee" (chickadee) ,chickadee)
+      ("catbird", (catbird) ,catbird)))
   (skip ())
   (files (libraries
            ((directory
               "gib-gab-gob"
-              ((directory "ui" ((scheme-file "console")))
+              ((directory
+                 "ui"
+                 ((compiled-scheme-file "console")
+                  (scheme-file "catbird")
+                  (scheme-file "console")))
+               (directory
+                 "util"
+                 ((scheme-file "chickadee-vat")
+                  (scheme-file "concurrent-queue")))
                (compiled-scheme-file "board")
                (scheme-file "game")
                (scheme-file "board")
@@ -33,17 +42,17 @@
                (text-file "make-initiator")
                (in-file "make-joiner")))))
          (documentation
-           ((text-file "COPYING") (org-file "README")))
+           ((org-file "README") (text-file "COPYING")))
          (infrastructure
-           ((shell-file "bootstrap")
-            (scheme-file "guix")
-            (in-file "pre-inst-env")
+           ((automake-file "Makefile")
+            (autoconf-file "configure")
+            (text-file ".gitignore")
+            (scheme-file "hall")
             (directory
               "build-aux"
               ((scheme-file "test-driver")
                (text-file "missing")
                (text-file "install-sh")))
-            (scheme-file "hall")
-            (text-file ".gitignore")
-            (autoconf-file "configure")
-            (automake-file "Makefile")))))
+            (in-file "pre-inst-env")
+            (scheme-file "guix")
+            (shell-file "bootstrap")))))
diff --git a/scripts/make-initiator.in b/scripts/make-initiator.in
index 09ca512..e20aad4 100644
--- a/scripts/make-initiator.in
+++ b/scripts/make-initiator.in
@@ -3,10 +3,6 @@
 !#
 
 (use-modules
- (gib-gab-gob rps)
- (gib-gab-gob game)
- (gib-gab-gob ui console))
+ (gib-gab-gob ui catbird))
 
 (make-initiator)
-
-(while #t #f) ;; indefinitely
diff --git a/scripts/make-joiner.in b/scripts/make-joiner.in
index c096eba..920a513 100644
--- a/scripts/make-joiner.in
+++ b/scripts/make-joiner.in
@@ -3,7 +3,7 @@
 !#
 
 (use-modules
- (gib-gab-gob ui console)
+ (gib-gab-gob ui catbird)
  (gib-gab-gob game))
 (apply make-joiner (cons ^ggg-controller (cdr (command-line))))