wip

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 =
 

gib-gab-gob/ui/catbird.scm

@@ -0,0 +1,207 @@
+(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 (srfi srfi-43)
+  #:export (make-initiator make-joiner))
+
+(define %window-width 1024)
+(define %window-height 768)
+
+(define %tile-width 64.0)
+(define %tile-height 64.0)
+
+(define-class <tile> (<node-2d>)
+  (tile-x #:getter tile-x #:init-keyword #:tile-x)
+  (tile-y #:getter tile-y #:init-keyword #:tile-y))
+
+(define-class <board-view> (<node-2d>)
+  (vat #:getter vat #:init-keyword #:vat)
+  (board #:getter board #:init-keyword #:board)
+  (tiles #:accessor tiles #:init-value #()))
+
+(define-method (initialize (board-view <board-view>) initargs)
+  (define tile-container
+    (make <node-2d>
+      #:name 'tile-container
+      #:rank 1))
+  (define background
+    (make <canvas>
+      #:name 'background
+      #:painter
+      (with-style ((fill-color db32-elf-green))
+        (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 (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)))
+    (for-each-tile
+     (λ (x y tile)
+       (detach tile))
+     (tiles board-view))
+    (set! (tiles board-view)
+          (vector-unfold
+           (λ (y)
+             (vector-unfold
+              (λ (x)
+                (let* ((painter (with-style
+                                 ((fill-color db32-rope)
+                                  (stroke-color db32-oiled-cedar))
+                                 (fill-and-stroke
+                                  (rectangle (vec2 0.0 0.0)
+                                             %tile-width %tile-height))))
+                       (bg (make <canvas>
+                             #:name 'background
+                             #:painter painter))
+                       (sprite (make <sprite>
+                                 #:name 'sprite
+                                 #:texture null-texture))
+                       (tile (make <tile>
+                               #:tile-x x
+                               #:tile-y y)))
+                  (set! (width tile) %tile-width)
+                  (set! (height tile) %tile-height)
+                  (attach-to tile bg sprite)
+                  (attach-to container tile)
+                  tile))
+              3))
+           3))
+    (for-each-tile
+     (λ (x y tile)
+       (if (= y 0)
+           (set! (position-y tile)
+                 (* %tile-height (- 3 1)))
+           (place-below (tile-ref board-view x (- y 1)) tile))
+       (unless (= x 0)
+         (place-right (tile-ref board-view (- x 1) y) tile)))
+     (tiles board-view))
+    (set! (width container) (* 3 %tile-width))
+    (set! (height container) (* 3 %tile-height))
+    (center-in-parent container)))
+
+(define (for-each-tile proc tiles)
+  (vector-for-each
+   (lambda (y row)
+     (vector-for-each
+      (lambda (x tile)
+        (proc x y tile))
+      row))
+   tiles))
+
+(define-method (board-pick (board-view <board-view>) x y)
+  (define (find-tile node)
+    (cond
+     ((not node)
+      #f)
+     ((is-a? node <tile>)
+      node)
+     ((parent node)
+      (find-tile (parent node)))
+     (else #f)))
+  (find-tile (pick board-view (vec2 x y) (lambda _ #t))))
+
+(define-class <board-mode> (<major-mode>))
+
+(define-method (make-move (mode <board-mode>) x y)
+  (define board (& (current-scene) root board))
+  (define node (board-pick board x y))
+  (cond
+   ((is-a? node <tile>)
+    (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 (make <full-region> #:name 'main))
+           (scene (make <scene> #:name 'board)))
+       (replace-scene region scene)
+       (replace-major-mode scene (make <board-mode>))
+       (set! (camera region)
+             (make <camera-2d>
+               #:width %window-width
+               #:height %window-height))
+       (attach-to scene (node-thunk))))
+   #: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))))

gib-gab-gob/util/chickadee-vat.scm

@@ -0,0 +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 (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))
+                             (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
+            (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 envelope)
+    (format #t "env send\n")
+    (if (vat-envelope-return? envelope)
+        (let ((return-channel (make-channel)))
+          (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
+            #:log? log?))

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)))))

guix.scm

@@ -1,25 +1,161 @@
 (use-modules
+ (srfi srfi-1)
  (guix packages)
  ((guix licenses) #:prefix license:)
-  (guix download)
+ (guix git-download)
  (guix build-system gnu)
  (guix gexp)
+ (guix utils)
  (gnu packages)
+ (gnu packages audio)
  (gnu packages autotools)
+ (gnu packages fontutils)
+ (gnu packages gl)
  (gnu packages guile)
  (gnu packages guile-xyz)
+ (gnu packages image)
+ (gnu packages maths)
+ (gnu packages mp3)
  (gnu packages pkg-config)
+ (gnu packages readline)
+ (gnu packages sdl)
  (gnu packages texinfo)
-	(srfi srfi-1))
+ (gnu packages xiph))
 
 (define (keep-file? file stat)
   (not (any (lambda (my-string)
               (string-contains file my-string))
             (list ".git" ".dir-locals.el" "guix.scm"))))
 
+(define target-guile guile-3.0-latest)
+
+(define guile3.0-opengl
+  (package
+    (inherit guile-opengl)
+    (inputs
+     (modify-inputs (package-inputs guile-opengl)
+       (replace "guile" target-guile)))
+    (native-inputs
+     (modify-inputs (package-native-inputs guile-opengl)
+       (append autoconf automake)))
+    (arguments
+     (substitute-keyword-arguments (package-arguments guile-opengl)
+       ((#:phases phases)
+        `(modify-phases ,phases
+           (delete 'patch-makefile)
+           (add-before 'bootstrap 'patch-configure.ac
+             (lambda _
+               ;; The Guile version check doesn't work for the 3.0
+               ;; pre-release, so just remove it.
+               (substitute* "configure.ac"
+                 (("GUILE_PKG\\(\\[2.2 2.0\\]\\)") ""))
+               (substitute* "Makefile.am"
+                 (("\\$\\(GUILE_EFFECTIVE_VERSION\\)") "3.0")
+                 (("ccache") "site-ccache"))
+               #t))
+           (replace 'bootstrap
+             (lambda _
+               (invoke "autoreconf" "-vfi")))))))))
+
+(define guile-sdl2
+  (let ((commit "e9a7f5e748719ce5b6ccd08ff91861b578034ea6"))
+    (package
+      (name "guile-sdl2")
+      (version (string-append "0.7.0-1." (string-take commit 7)))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                      (url "https://git.dthompson.us/guile-sdl2.git")
+                      (commit commit)))
+                (sha256
+                 (base32
+                  "0ay7mcar8zs0j5rihwlzi0l46vgg9i93piip4v8a3dzwjx3myr7v"))))
+      (build-system gnu-build-system)
+      (arguments
+       '(#:make-flags '("GUILE_AUTO_COMPILE=0")
+         #:phases
+         (modify-phases %standard-phases
+           (add-after 'unpack 'bootstrap
+                      (lambda _
+                        (invoke "sh" "bootstrap"))))))
+      (native-inputs (list autoconf automake pkg-config texinfo))
+      (inputs (list target-guile sdl2))
+      (synopsis "Guile bindings for SDL2")
+      (description "Guile-sdl2 provides pure Guile Scheme bindings to the
+SDL2 C shared library via the foreign function interface.")
+      (home-page "https://git.dthompson.us/guile-sdl2.git")
+      (license license:lgpl3+))))
+
+(define chickadee
+  (let ((commit "1759fa0a056f99a61867c393708c210b37af712f"))
+    (package
+     (name "chickadee")
+     (version (string-append "0.10.0." (string-take commit 7)))
+     (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://git.dthompson.us/chickadee.git")
+                    (commit commit)))
+              (sha256
+               (base32
+                "1vik96bm3qp9hjlhxh4p7cjsdqf1by8i1cd023wvk8dr6anrnfld"))))
+     (build-system gnu-build-system)
+     (arguments
+      '(#:make-flags '("GUILE_AUTO_COMPILE=0")
+        #:phases
+        (modify-phases %standard-phases
+                       (add-after 'unpack 'bootstrap
+                                  (lambda _
+                                    (invoke "sh" "bootstrap"))))))
+     (native-inputs (list autoconf automake pkg-config texinfo))
+     (inputs (list freetype
+                   libjpeg-turbo
+                   libpng
+                   libvorbis
+                   mpg123
+                   openal
+                   readline
+                   target-guile))
+     (propagated-inputs (list guile3.0-opengl guile-sdl2))
+     (synopsis "Game development toolkit for Guile Scheme")
+     (description "Chickadee is a game development toolkit for Guile
+Scheme.  It contains all of the basic components needed to develop
+2D/3D video games.")
+     (home-page "https://dthompson.us/projects/chickadee.html")
+     (license license:gpl3+))))
+
+(define catbird
+  (let ((commit "fa6a85b92f818f1e0139a33ca4110acc97f8d4f2"))
+    (package
+     (name "catbird")
+     (version (string-append "0.1.0-1." (string-take commit 7)))
+     (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://git.dthompson.us/catbird.git")
+                    (commit commit)))
+              (sha256
+               (base32
+                "0jhsf1idrq433x4l10yfzkmd68k5y1ypsfzqpmh1rv6clczxyszf"))))
+     (build-system gnu-build-system)
+     (arguments
+      '(#:make-flags '("GUILE_AUTO_COMPILE=0")
+        #:phases
+        (modify-phases %standard-phases
+                       (add-after 'unpack 'bootstrap
+                                  (lambda _
+                                    (invoke "sh" "bootstrap"))))))
+     (native-inputs (list autoconf automake pkg-config texinfo))
+     (inputs (list target-guile))
+     (propagated-inputs (list chickadee guile-sdl2))
+     (synopsis "Game engine for Scheme programmers")
+     (description "Catbird is a game engine written in Guile Scheme.")
+     (home-page "https://dthompson.us/projects/chickadee.html")
+     (license license:gpl3+))))
+
 (package
   (name "gib-gab-gob")
-  (version "0.1")
+  (version "0.2")
   (source (local-file (dirname (current-filename))
                       #:recursive? #t
                       #:select? keep-file?))
@@ -60,7 +196,7 @@
                                           (string-append
                                             (assoc-ref inputs input)
                                             path))
-                                        ,''("guile-goblins"))))))
+                                        ,''("guile-goblins" "chickadee" "catbird"))))))
                    (out (assoc-ref outputs "out"))
                    (bin (string-append out "/bin/"))
                    (site (uncompiled-dir out "")))
@@ -87,7 +223,9 @@
       ("texinfo" ,texinfo)))
   (inputs `(("guile" ,guile-3.0)))
   (propagated-inputs
-    `(("guile-goblins" ,guile-goblins)))
+    `(("guile-goblins" ,guile-goblins)
+      ("chickadee" ,chickadee)
+      ("catbird" ,catbird)))
   (synopsis
     "Rock Paper Scissors and Tic Tac Toe in Goblins!")
   (description

hall.scm

@@ -1,7 +1,7 @@
 (hall-description
   (name "gib-gab-gob")
   (prefix "")
-  (version "0.1")
+  (version "0.2")
   (author "Vivi Langdon")
   (copyright (2023))
   (synopsis
@@ -11,12 +11,22 @@
   (home-page "https://solarpunk.moe")
   (license gpl3+)
   (dependencies
-    `(("guile-goblins" (goblins) ,guile-goblins)))
+    `(("guile-goblins" (goblins) ,guile-goblins)
+      ("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")
@@ -32,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")
+           ((automake-file "Makefile")
-            (scheme-file "guix")
+            (autoconf-file "configure")
-            (in-file "pre-inst-env")
+            (text-file ".gitignore")
+            (scheme-file "hall")
             (directory
               "build-aux"
               ((scheme-file "test-driver")
                (text-file "missing")
                (text-file "install-sh")))
-            (scheme-file "hall")
+            (in-file "pre-inst-env")
-            (text-file ".gitignore")
+            (scheme-file "guix")
-            (autoconf-file "configure")
+            (shell-file "bootstrap")))))
-            (automake-file "Makefile")))))

scripts/make-initiator.in

@@ -3,10 +3,6 @@
 !#
 
 (use-modules
- (gib-gab-gob rps)
+ (gib-gab-gob ui catbird))
- (gib-gab-gob game)
- (gib-gab-gob ui console))
 
 (make-initiator)
-
-(while #t #f) ;; indefinitely

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))))