Compare commits
No commits in common. "main" and "main" have entirely different histories.
|
|
@ -35,8 +35,7 @@ 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/board.scm
|
||||
|
||||
TESTS =
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +0,0 @@
|
|||
#!/bin/sh
|
||||
|
||||
autoreconf -vif
|
||||
|
|
@ -2,15 +2,10 @@
|
|||
#:use-module (srfi srfi-1)
|
||||
#:export (make-board
|
||||
board-ref
|
||||
board-assert-vacant
|
||||
board-choose!
|
||||
board-display
|
||||
board-winner?))
|
||||
|
||||
;; TODO: This board is no longer time-travel friendly!
|
||||
;; Have to decide if we go back to the old board with one actor per cell,
|
||||
;; or make a new version. Board could becom a new board containing the new mark.
|
||||
|
||||
(define ggg-size 3) ;; tic tac toe with more than 3x3 grid?
|
||||
|
||||
(define (make-board)
|
||||
|
|
@ -19,13 +14,11 @@
|
|||
(define (board-ref board x y)
|
||||
(array-ref board y x))
|
||||
|
||||
(define (board-assert-vacant board x y)
|
||||
(define ref (board-ref board x y))
|
||||
(if ref (error "That space is already occupied with:" ref) ref))
|
||||
|
||||
(define (board-choose! board val x y)
|
||||
(board-assert-vacant board x y)
|
||||
(array-set! board val y x))
|
||||
(define ref (board-ref board x y))
|
||||
(if ref
|
||||
(error "That space is already occupied with:" ref)
|
||||
(array-set! board val y x)))
|
||||
|
||||
(define (board-display board)
|
||||
(array-slice-for-each-in-order
|
||||
|
|
|
|||
|
|
@ -1,59 +1,42 @@
|
|||
(define-module (gib-gab-gob game)
|
||||
#:use-module (fibers)
|
||||
#:use-module (fibers channels)
|
||||
#:use-module (goblins)
|
||||
#:use-module (goblins vat)
|
||||
#:use-module (goblins actor-lib cell)
|
||||
#:use-module (goblins actor-lib methods)
|
||||
#:use-module (goblins actor-lib sealers)
|
||||
#:use-module (gib-gab-gob board)
|
||||
#:export (^ggg-controller))
|
||||
|
||||
;; Actual Tic Tac Toe game
|
||||
(define (^ggg-controller bcom board state+ first? peer)
|
||||
(define mark (if first? 'x 'o))
|
||||
(define peer-mark (if first? 'o 'x))
|
||||
(define %my-turn? (spawn ^cell first?))
|
||||
(define (%state)
|
||||
(cond
|
||||
((board-winner? board mark) 'won)
|
||||
((board-winner? board peer-mark) 'lost)
|
||||
(else 'play)))
|
||||
(define (signal-turn)
|
||||
(syscaller-free-fiber (λ () (put-message state+ (%state))))
|
||||
#f)
|
||||
(define (switch-turn!)
|
||||
(let ((new-turn (not ($ %my-turn?))))
|
||||
($ %my-turn? new-turn)
|
||||
(when new-turn (signal-turn))
|
||||
#f))
|
||||
(when first? (signal-turn))
|
||||
(define (^ggg-controller bcom won? peer)
|
||||
(define mark (if won? 'x 'o))
|
||||
(define peer-mark (if won? 'o 'x))
|
||||
(define board (make-board))
|
||||
(define my-turn? won?)
|
||||
(define (i-won?) (board-winner? board mark))
|
||||
(define (peer-won?) (board-winner? board peer-mark))
|
||||
(define (display)
|
||||
(board-display board)
|
||||
(format #t "-> It is ~a turn!\n" (if my-turn? "my" "peer's"))
|
||||
(when (i-won?) (format #t "*** I won! ***\n"))
|
||||
(when (peer-won?) (format #t "*** I lost! ***\n")))
|
||||
(display)
|
||||
(methods
|
||||
;; The peer is telling us about the turn it took.
|
||||
[(peer-turn! x y)
|
||||
(if (not ($ %my-turn?))
|
||||
(if (not my-turn?)
|
||||
(begin
|
||||
(board-choose! board peer-mark x y)
|
||||
(switch-turn!))
|
||||
(set! my-turn? (not my-turn?))
|
||||
(display))
|
||||
(error "It's my turn!"))]
|
||||
;; TODO: These need to go somewhere else so the peer can't move or init for us!
|
||||
[(try-transition) 'playing]
|
||||
[(my-turn?) ($ %my-turn?)]
|
||||
[(my-mark) mark]
|
||||
[(state) (%state)]
|
||||
[(initialize!)
|
||||
(on (<- peer 'try-transition)
|
||||
(λ (status)
|
||||
(format #t "Peer's status: ~a\n" status)
|
||||
status) #:promise? #t)]
|
||||
(on (<- peer 'try-transition) (lambda (status) (format #t "Peer's status: ~a\n" status)) #:promise? #t)]
|
||||
[(my-turn! x y)
|
||||
(if ($ %my-turn?)
|
||||
(if my-turn?
|
||||
(begin
|
||||
(board-assert-vacant board x y)
|
||||
(on (<- peer 'peer-turn! x y)
|
||||
(λ (_)
|
||||
(board-choose! board mark x y)
|
||||
(switch-turn!)
|
||||
(%state))
|
||||
#:promise? #t))
|
||||
(board-choose! board mark x y)
|
||||
(set! my-turn? (not my-turn?))
|
||||
(display)
|
||||
(<- peer 'peer-turn! x y))
|
||||
(error "It's not my turn."))]))
|
||||
|
|
|
|||
|
|
@ -6,41 +6,48 @@
|
|||
#:use-module (goblins ocapn captp)
|
||||
#:use-module (goblins ocapn ids)
|
||||
#:use-module (goblins ocapn netlayer onion)
|
||||
#:use-module (gib-gab-gob board)
|
||||
#:use-module (fibers conditions)
|
||||
#:export (initiator/connect ^game-initiator ^game-joiner))
|
||||
#:export (make-initiator make-joiner ^game-initiator ^game-joiner))
|
||||
|
||||
;;
|
||||
;; Initiator logic
|
||||
;;
|
||||
;; use this one
|
||||
(define (initiator/connect initiator)
|
||||
(define mycapn (spawn-mycapn (new-onion-netlayer)))
|
||||
(define init-sref ($ mycapn 'register initiator 'onion))
|
||||
(format #t "Connect to: ~a\n" (ocapn-id->string init-sref)))
|
||||
(define (make-initiator ^game-controller)
|
||||
(with-vat (spawn-vat)
|
||||
(define initiator (spawn ^game-initiator ^game-controller))
|
||||
(define mycapn (spawn-mycapn (new-onion-netlayer)))
|
||||
(define init-sref ($ mycapn 'register initiator 'testuds))
|
||||
(format #t "Connect to: ~a\n" (ocapn-id->string init-sref))))
|
||||
|
||||
(define (^game-initiator bcom ^game-controller board state+)
|
||||
(define (^game-initiator bcom ^game-controller)
|
||||
(define pick (pick-rps))
|
||||
(define won? #nil)
|
||||
(define peer #nil)
|
||||
(methods
|
||||
[(register-opponent p sealed-pick)
|
||||
[(register-opponent name p sealed-pick)
|
||||
(set! peer p)
|
||||
(format #t "Hey there! You sent me your pick of rock-paper-scissors; now I will send mine.\n")
|
||||
(format #t "Hey there, ~a! You sent me your pick of rock-paper-scissors; now I will send mine.\n" name)
|
||||
(on (<- (<- peer 'pick->unsealer pick) sealed-pick)
|
||||
(λ (peer-pick)
|
||||
(set! won? (rps-winner pick peer-pick))
|
||||
(format #t "Opponent has picked ~a (do I win? ~a). Ready to be a controller.\n" peer-pick won?)))]
|
||||
(format #t "Opponent ~a has picked ~a (do I win? ~a). Ready to be a controller.\n" name peer-pick won?)))]
|
||||
[(try-transition)
|
||||
(if (eq? won? #nil)
|
||||
'connecting
|
||||
(bcom (^game-controller bcom board state+ won? peer) 'ready-to-play))]))
|
||||
(bcom (^game-controller bcom won? peer) 'ready-to-play))]))
|
||||
|
||||
;;
|
||||
;; Joiner logic
|
||||
;;
|
||||
(define (make-joiner ^game-controller user-name addr)
|
||||
(with-vat (spawn-vat)
|
||||
(define mycapn (spawn-mycapn (new-onion-netlayer)))
|
||||
(define init-sref (string->ocapn-id addr))
|
||||
(define initiator ($ mycapn 'enliven init-sref))
|
||||
(define joiner (spawn ^game-joiner initiator ^game-controller))
|
||||
(on (<- initiator 'register-opponent user-name joiner ($ joiner 'get-sealed-pick))
|
||||
(λ (_) (format #t "~a finished the game.\n" user-name)))))
|
||||
|
||||
(define (^game-joiner bcom initiator ^game-controller board state+)
|
||||
(define (^game-joiner bcom initiator ^game-controller)
|
||||
(define-values (seal-pick unseal-pick my-pick?)
|
||||
(spawn-sealer-triplet))
|
||||
(define pick (pick-rps))
|
||||
|
|
@ -52,7 +59,7 @@
|
|||
;; We make the assumption that initiator is to become a controller.
|
||||
;; Note second arg to bcom which will return the value (this is confusing to me)
|
||||
;; see https://spritely.institute/files/docs/guile-goblins/0.11.0/Object-construction.html
|
||||
(bcom (^game-controller bcom board state+ won? initiator) unseal-pick)]))
|
||||
(bcom (^game-controller bcom won? initiator) unseal-pick)]))
|
||||
|
||||
;;
|
||||
;; Standard rock paper scissors logic follows!
|
||||
|
|
|
|||
|
|
@ -1,98 +0,0 @@
|
|||
(define-module (gib-gab-gob ui console)
|
||||
#:use-module (gib-gab-gob rps)
|
||||
#:use-module (gib-gab-gob game)
|
||||
#:use-module (gib-gab-gob board)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 exceptions)
|
||||
#:use-module (ice-9 suspendable-ports)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (fibers)
|
||||
#:use-module (fibers channels)
|
||||
#:use-module (goblins)
|
||||
#:use-module (goblins vat)
|
||||
#:use-module (goblins ocapn captp)
|
||||
#:use-module (goblins ocapn ids)
|
||||
#:use-module (goblins ocapn netlayer onion)
|
||||
#:export (make-initiator make-joiner))
|
||||
|
||||
;; https://www.gnu.org/software/guile/manual/guile.html#Non_002dBlocking-I_002fO
|
||||
(let* ((input (current-input-port))
|
||||
(flags (fcntl input F_GETFL)))
|
||||
(fcntl input F_SETFL (logior O_NONBLOCK flags)))
|
||||
(install-suspendable-ports!)
|
||||
|
||||
(random-state-from-platform)
|
||||
|
||||
;; Module for simple console-based UI (no curses)
|
||||
|
||||
;; A single run of the loop for a bespoke REPL for playing the game
|
||||
(define (%loop vat b controller state+)
|
||||
(define state (get-message state+))
|
||||
(%print b state)
|
||||
(if (eq? state 'play)
|
||||
(let ((coords (%read)))
|
||||
(with-vat
|
||||
vat
|
||||
(if coords (%eval vat b controller coords) #f)))
|
||||
#f))
|
||||
|
||||
(define (%read)
|
||||
(%prompt)
|
||||
(let ((line (read-line (current-input-port))))
|
||||
(if (string-prefix? ",q" line) #f
|
||||
(let ((coords (map string->number (string-tokenize line char-set:digit))))
|
||||
(if (not (= (length coords) 2))
|
||||
(begin (format #t "Must be two numbers, x y; or ,quit to quit. Try again.\n")
|
||||
(%prompt) (%read))
|
||||
coords)))))
|
||||
|
||||
(define (%eval vat b controller coordinates)
|
||||
;; weird?
|
||||
(let ((x (first coordinates))
|
||||
(y (second coordinates)))
|
||||
(on (<- controller 'my-turn! x y)
|
||||
(λ (state) (%display b state)))))
|
||||
|
||||
(define (%print b state)
|
||||
(%display b state))
|
||||
|
||||
(define (%prompt) (format #t "Enter your move: "))
|
||||
|
||||
(define (%display b state)
|
||||
(board-display b)
|
||||
(cond
|
||||
((eq? state 'won) (format #t "*** I won! ***\n"))
|
||||
((eq? state 'lost) (format #t "*** I lost! ***\n"))))
|
||||
|
||||
(define (begin-game-loop board controller state+)
|
||||
(define vat (spawn-vat #:name "UI"))
|
||||
(syscaller-free-fiber
|
||||
(λ ()
|
||||
(while (%loop vat board controller state+))
|
||||
(format #t "bye-bye!\n")
|
||||
#f)))
|
||||
|
||||
(define (make-initiator)
|
||||
(with-vat
|
||||
(spawn-vat #:name "Initiator Game")
|
||||
(define state+ (make-channel))
|
||||
(define board (make-board))
|
||||
(define initiator (spawn ^game-initiator ^ggg-controller board state+))
|
||||
(initiator/connect initiator)
|
||||
(begin-game-loop board initiator state+)))
|
||||
|
||||
(define (make-joiner ^game-controller addr)
|
||||
(with-vat
|
||||
(spawn-vat #:name "Joiner Game")
|
||||
(define mycapn (spawn-mycapn (new-onion-netlayer)))
|
||||
(define state+ (make-channel))
|
||||
(define board (make-board))
|
||||
(let* ((init-sref (string->ocapn-id addr))
|
||||
(initiator ($ mycapn 'enliven init-sref))
|
||||
(joiner (spawn ^game-joiner initiator ^game-controller board state+))
|
||||
(sealed ($ joiner 'get-sealed-pick)))
|
||||
(on (<- initiator 'register-opponent joiner sealed)
|
||||
(λ (_)
|
||||
(on ($ joiner 'initialize!)
|
||||
(λ (status) (begin-game-loop board joiner state+) #f)))))))
|
||||
13
guix.scm
13
guix.scm
|
|
@ -3,26 +3,17 @@
|
|||
((guix licenses) #:prefix license:)
|
||||
(guix download)
|
||||
(guix build-system gnu)
|
||||
(guix gexp)
|
||||
(gnu packages)
|
||||
(gnu packages autotools)
|
||||
(gnu packages guile)
|
||||
(gnu packages guile-xyz)
|
||||
(gnu packages pkg-config)
|
||||
(gnu packages texinfo)
|
||||
(srfi srfi-1))
|
||||
|
||||
(define (keep-file? file stat)
|
||||
(not (any (lambda (my-string)
|
||||
(string-contains file my-string))
|
||||
(list ".git" ".dir-locals.el" "guix.scm"))))
|
||||
(gnu packages texinfo))
|
||||
|
||||
(package
|
||||
(name "gib-gab-gob")
|
||||
(version "0.1")
|
||||
(source (local-file (dirname (current-filename))
|
||||
#:recursive? #t
|
||||
#:select? keep-file?))
|
||||
(source "./gib-gab-gob-0.1.tar.gz")
|
||||
(build-system gnu-build-system)
|
||||
(arguments
|
||||
`(#:modules
|
||||
|
|
|
|||
30
hall.scm
30
hall.scm
|
|
@ -16,32 +16,30 @@
|
|||
(files (libraries
|
||||
((directory
|
||||
"gib-gab-gob"
|
||||
((directory "ui" ((scheme-file "console")))
|
||||
(compiled-scheme-file "board")
|
||||
(scheme-file "game")
|
||||
(scheme-file "board")
|
||||
((compiled-scheme-file "game")
|
||||
(scheme-file "rps")
|
||||
(compiled-scheme-file "game")
|
||||
(scheme-file "game")
|
||||
(compiled-scheme-file "board")
|
||||
(scheme-file "board")
|
||||
(compiled-scheme-file "rps")))))
|
||||
(tests ())
|
||||
(tests ((directory "tests" ())))
|
||||
(programs
|
||||
((directory
|
||||
"scripts"
|
||||
((in-file "make-initiator")
|
||||
(text-file "make-joiner")
|
||||
((in-file "make-joiner")
|
||||
(in-file "make-initiator")
|
||||
(text-file "make-initiator")
|
||||
(in-file "make-joiner")))))
|
||||
(documentation
|
||||
((text-file "COPYING") (org-file "README")))
|
||||
(text-file "make-joiner")))))
|
||||
(documentation ((org-file "README")))
|
||||
(infrastructure
|
||||
((shell-file "bootstrap")
|
||||
(scheme-file "guix")
|
||||
(in-file "pre-inst-env")
|
||||
((in-file "pre-inst-env")
|
||||
(directory
|
||||
"build-aux"
|
||||
((scheme-file "test-driver")
|
||||
((tex-file "texinfo")
|
||||
(scheme-file "test-driver")
|
||||
(text-file "missing")
|
||||
(text-file "install-sh")))
|
||||
(text-file "install-sh")
|
||||
(text-file "mdate-sh")))
|
||||
(scheme-file "hall")
|
||||
(text-file ".gitignore")
|
||||
(autoconf-file "configure")
|
||||
|
|
|
|||
|
|
@ -4,9 +4,7 @@
|
|||
|
||||
(use-modules
|
||||
(gib-gab-gob rps)
|
||||
(gib-gab-gob game)
|
||||
(gib-gab-gob ui console))
|
||||
|
||||
(make-initiator)
|
||||
(gib-gab-gob game))
|
||||
(make-initiator ^ggg-controller)
|
||||
|
||||
(while #t #f) ;; indefinitely
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
!#
|
||||
|
||||
(use-modules
|
||||
(gib-gab-gob ui console)
|
||||
(gib-gab-gob rps)
|
||||
(gib-gab-gob game))
|
||||
(apply make-joiner (cons ^ggg-controller (cdr (command-line))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue