vv
/
gib-gab-gob
1
0
Fork 1
Code Issues Pull Requests Activity

wip

This commit is contained in:
Vivianne 2023-07-16 18:35:12 -07:00
parent fc992f6b9a
commit 3214640136
7 changed files with 220 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile.am
View File

@ -36,7 +36,9 @@ SUFFIXES = .scm .go
SOURCES = gib-gab-gob/rps.scm \ SOURCES = gib-gab-gob/rps.scm \
gib-gab-gob/game.scm \ gib-gab-gob/game.scm \
gib-gab-gob/board.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 = TESTS =

93
gib-gab-gob/ui/catbird.scm
View File

@ -1,18 +1,30 @@
(define-module (gib-gab-gob ui catbird) (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)
#:use-module (catbird input-map) #:use-module (catbird input-map)
#:use-module (catbird mode) #:use-module (catbird mode)
#:use-module (catbird node) #:use-module (catbird node)
#:use-module (catbird node-2d) #:use-module (catbird node-2d)
#:use-module (catbird region) #:use-module (catbird region)
#:use-module (catbird camera)
#:use-module ((catbird scene) #:use-module ((catbird scene)
#:select (<scene> current-scene replace-major-mode)) #:select (<scene> current-scene replace-major-mode))
#:use-module (chickadee) #:use-module (chickadee)
#:use-module (chickadee graphics color) #:use-module (chickadee graphics color)
#:use-module (chickadee graphics texture) #:use-module (chickadee graphics texture)
#:use-module (chickadee graphics path)
#:use-module (chickadee math vector) #:use-module (chickadee math vector)
#:use-module (chickadee scripting) #: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-width 1024)
(define %window-height 768) (define %window-height 768)
@ -29,7 +41,7 @@
(board #:getter board #:init-keyword #:board) (board #:getter board #:init-keyword #:board)
(tiles #:accessor tiles #:init-value #())) (tiles #:accessor tiles #:init-value #()))
(define-method (on-boot (board-view <board-view>)) (define-method (initialize (board-view <board-view>) initargs)
(define tile-container (define tile-container
(make <node-2d> (make <node-2d>
#:name 'tile-container #:name 'tile-container
@ -39,15 +51,16 @@
#:name 'background #:name 'background
#:painter #:painter
(with-style ((fill-color db32-elf-green)) (with-style ((fill-color db32-elf-green))
(fill (fill
rectangle (vec2 0.0 0.0) rectangle (vec2 0.0 0.0)
%window-width %window-width
%window-height)))) %window-height))))
(resize board-view %window-width %window-height) (next-method)
(attach-to board-view tile-container)) (attach-to board-view tile-container)
(rebuild-tiles board-view))
(define-method (tile-ref (garden <garden-view>) x y) (define-method (tile-ref (board-view <board-view>) x y)
(vector-ref (vector-ref (tiles garden) y) x)) (vector-ref (vector-ref (tiles board-view) y) x))
(define-method (rebuild-tiles (board-view <board-view>)) (define-method (rebuild-tiles (board-view <board-view>))
(let* ((container (& board-view tile-container))) (let* ((container (& board-view tile-container)))
@ -55,7 +68,7 @@
(λ (x y tile) (λ (x y tile)
(detach tile)) (detach tile))
(tiles board-view)) (tiles board-view))
(set! (tiles garden) (set! (tiles board-view)
(vector-unfold (vector-unfold
(λ (y) (λ (y)
(vector-unfold (vector-unfold
@ -104,7 +117,7 @@
row)) row))
tiles)) tiles))
(define-method (board-pick (board <board-view>) x y) (define-method (board-pick (board-view <board-view>) x y)
(define (find-tile node) (define (find-tile node)
(cond (cond
((not node) ((not node)
@ -114,7 +127,7 @@
((parent node) ((parent node)
(find-tile (parent node))) (find-tile (parent node)))
(else #f))) (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>)) (define-class <board-mode> (<major-mode>))
@ -123,14 +136,14 @@
(define node (board-pick board x y)) (define node (board-pick board x y))
(cond (cond
((is-a? node <tile>) ((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) (bind-input <board-mode> (mouse-press 'left) make-move)
(define* (launch-game node-thunk) (define* (launch-game node-thunk)
(run-catbird (run-catbird
(lambda () (lambda ()
(let ((region (create-full-region #:name 'main)) (let ((region (make <full-region> #:name 'main))
(scene (make <scene> #:name 'board))) (scene (make <scene> #:name 'board)))
(replace-scene region scene) (replace-scene region scene)
(replace-major-mode scene (make <board-mode>)) (replace-major-mode scene (make <board-mode>))
@ -142,3 +155,53 @@
#:title "Gib Gab Gob" #:title "Gib Gab Gob"
#:width %window-width #:width %window-width
#:height %window-height)) #: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))))

38
gib-gab-gob/util/chickadee-vat.scm
View File

@ -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) (define-module (gib-gab-gob util chickadee-vat)
#:use-module (gib-gab-gob util concurrent-queue)
#:use-module (chickadee) #:use-module (chickadee)
#:use-module (chickadee scripting) #:use-module (chickadee scripting)
#:use-module (community-garden concurrent-queue) #:use-module (chickadee scripting agenda)
#:use-module (goblins vat) #:use-module (goblins vat)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (make-chickadee-vat)) #:export (make-chickadee-vat))
(define* (make-chickadee-vat #:key (name 'chickadee) (define* (make-chickadee-vat #:key (name 'chickadee)
(agenda (current-agenda))) (agenda (current-agenda))
(log? #f))
(define vat-script #f) (define vat-script #f)
(define message-queue (make-concurrent-queue)) (define message-queue (make-concurrent-queue))
(define (start churn) (define (start churn)
(define (handle-messages) (define (handle-messages)
(format #t "handle messages...")
(if (concurrent-queue-empty? message-queue) (if (concurrent-queue-empty? message-queue)
(begin (begin
(sleep (current-timestep))) (format #t "sleep... ~a\n" (current-timestep))
(sleep (current-timestep))
(format #t "sleep done."))
(match (concurrent-dequeue! message-queue) (match (concurrent-dequeue! message-queue)
((msg return-channel) ((msg return-channel)
(format #t "dequeue w/ return....\n")
(channel-put return-channel (churn msg))) (channel-put return-channel (churn msg)))
(msg (msg
(format #t "dequeue w/o return....\n")
(churn msg)))) (churn msg))))
(format #t "done.\n")
(handle-messages)) (handle-messages))
(format #t "churning... ~a\n" churn)
(with-agenda agenda (with-agenda agenda
(format #t "agenda... ~a" agenda)
(set! vat-script (script (handle-messages))))) (set! vat-script (script (handle-messages)))))
(define (halt) (define (halt)
(cancel-script vat-script)) (cancel-script vat-script))
(define (send msg return?) (define (send envelope)
(if return? (format #t "env send\n")
(if (vat-envelope-return? envelope)
(let ((return-channel (make-channel))) (let ((return-channel (make-channel)))
(concurrent-enqueue! message-queue (list msg return-channel)) (format #t "env enqueue\n")
(channel-get return-channel)) (concurrent-enqueue! message-queue (list envelope return-channel))
(begin (format #t "enqueued\n")
(concurrent-enqueue! message-queue msg)))) (channel-get return-channel)
(format #t "got return\n"))
(concurrent-enqueue! message-queue envelope)))
(make-vat #:name name (make-vat #:name name
#:start start #:start start
#:halt halt #:halt halt
#:send send)) #:send send
#:log? log?))

90
gib-gab-gob/util/concurrent-queue.scm Normal file
View File

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

29
hall.scm
View File

@ -12,12 +12,21 @@
(license gpl3+) (license gpl3+)
(dependencies (dependencies
`(("guile-goblins" (goblins) ,guile-goblins) `(("guile-goblins" (goblins) ,guile-goblins)
("chickadee" (chickadee) ,chickadee))) ("chickadee" (chickadee) ,chickadee)
("catbird", (catbird) ,catbird)))
(skip ()) (skip ())
(files (libraries (files (libraries
((directory ((directory
"gib-gab-gob" "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") (compiled-scheme-file "board")
(scheme-file "game") (scheme-file "game")
(scheme-file "board") (scheme-file "board")
@ -33,17 +42,17 @@
(text-file "make-initiator") (text-file "make-initiator")
(in-file "make-joiner"))))) (in-file "make-joiner")))))
(documentation (documentation
((text-file "COPYING") (org-file "README"))) ((org-file "README") (text-file "COPYING")))
(infrastructure (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 (directory
"build-aux" "build-aux"
((scheme-file "test-driver") ((scheme-file "test-driver")
(text-file "missing") (text-file "missing")
(text-file "install-sh"))) (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")))))

6
scripts/make-initiator.in
View File

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

2
scripts/make-joiner.in
View File

@ -3,7 +3,7 @@
!# !#
(use-modules (use-modules
(gib-gab-gob ui console) (gib-gab-gob ui catbird)
(gib-gab-gob game)) (gib-gab-gob game))
(apply make-joiner (cons ^ggg-controller (cdr (command-line)))) (apply make-joiner (cons ^ggg-controller (cdr (command-line))))