Compare commits
7 Commits
77625ede95
...
3e9d075cda
Author | SHA1 | Date |
---|---|---|
Vivianne | 3e9d075cda | |
Vivianne | ad2d33e994 | |
Vivianne | 78226e84e6 | |
Vivianne | 748bbfdb3f | |
Vivianne | b2444ace11 | |
Vivianne | 7708870b45 | |
Vivianne | 559f9832f5 |
|
@ -35,7 +35,8 @@ 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
|
||||||
|
|
||||||
TESTS =
|
TESTS =
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,6 @@
|
||||||
(define-module (gib-gab-gob game)
|
(define-module (gib-gab-gob game)
|
||||||
|
#:use-module (fibers)
|
||||||
|
#:use-module (fibers channels)
|
||||||
#:use-module (goblins)
|
#:use-module (goblins)
|
||||||
#:use-module (goblins actor-lib methods)
|
#:use-module (goblins actor-lib methods)
|
||||||
#:use-module (goblins actor-lib sealers)
|
#:use-module (goblins actor-lib sealers)
|
||||||
|
@ -6,39 +8,50 @@
|
||||||
#:export (^ggg-controller))
|
#:export (^ggg-controller))
|
||||||
|
|
||||||
;; Actual Tic Tac Toe game
|
;; Actual Tic Tac Toe game
|
||||||
(define (^ggg-controller bcom won? peer)
|
(define (^ggg-controller bcom board my-turn+ first? peer)
|
||||||
(define mark (if won? 'x 'o))
|
(define mark (if first? 'x 'o))
|
||||||
(define peer-mark (if won? 'o 'x))
|
(define peer-mark (if first? 'o 'x))
|
||||||
(define board (make-board))
|
(define %my-turn? first?)
|
||||||
(define my-turn? won?)
|
(define (%state)
|
||||||
(define (i-won?) (board-winner? board mark))
|
(cond
|
||||||
(define (peer-won?) (board-winner? board peer-mark))
|
((board-winner? board mark) => 'won)
|
||||||
(define (display)
|
((board-winner? board peer-mark) => 'lost)
|
||||||
(board-display board)
|
(else 'play)))
|
||||||
(format #t "-> It is ~a turn!\n" (if my-turn? "my" "peer's"))
|
(define (signal-turn)
|
||||||
(when (i-won?) (format #t "*** I won! ***\n"))
|
;; any better way to do this?
|
||||||
(when (peer-won?) (format #t "*** I lost! ***\n")))
|
(spawn-fiber (λ () (put-message my-turn+ #t)))
|
||||||
(display)
|
#f)
|
||||||
|
(define (switch-turn!)
|
||||||
|
(set! %my-turn? (not %my-turn?))
|
||||||
|
(when %my-turn? (signal-turn))
|
||||||
|
#f)
|
||||||
|
(when first? (signal-turn))
|
||||||
(methods
|
(methods
|
||||||
;; The peer is telling us about the turn it took.
|
;; The peer is telling us about the turn it took.
|
||||||
[(peer-turn! x y)
|
[(peer-turn! x y)
|
||||||
(if (not my-turn?)
|
(if (not %my-turn?)
|
||||||
(begin
|
(begin
|
||||||
(board-choose! board peer-mark x y)
|
(board-choose! board peer-mark x y)
|
||||||
(set! my-turn? (not my-turn?))
|
(switch-turn!))
|
||||||
(display))
|
|
||||||
(error "It's my turn!"))]
|
(error "It's my turn!"))]
|
||||||
;; TODO: These need to go somewhere else so the peer can't move or init for us!
|
;; TODO: These need to go somewhere else so the peer can't move or init for us!
|
||||||
[(try-transition) 'playing]
|
[(try-transition) 'playing]
|
||||||
|
[(my-turn?) %my-turn?]
|
||||||
|
[(my-mark) mark]
|
||||||
|
[(state) (%state)]
|
||||||
[(initialize!)
|
[(initialize!)
|
||||||
(on (<- peer 'try-transition) (λ (status) (format #t "Peer's status: ~a\n" status)) #:promise? #t)]
|
(on (<- peer 'try-transition)
|
||||||
|
(λ (status)
|
||||||
|
(format #t "Peer's status: ~a\n" status)
|
||||||
|
status) #:promise? #t)]
|
||||||
[(my-turn! x y)
|
[(my-turn! x y)
|
||||||
(if my-turn?
|
(if %my-turn?
|
||||||
(begin
|
(begin
|
||||||
(board-assert-vacant board x y)
|
(board-assert-vacant board x y)
|
||||||
(on (<- peer 'peer-turn! x y)
|
(on (<- peer 'peer-turn! x y)
|
||||||
(λ (_)
|
(λ (_)
|
||||||
(board-choose! board mark x y)
|
(board-choose! board mark x y)
|
||||||
(set! my-turn? (not my-turn?))
|
(switch-turn!)
|
||||||
(display))))
|
(%state))
|
||||||
|
#:promise? #t))
|
||||||
(error "It's not my turn."))]))
|
(error "It's not my turn."))]))
|
||||||
|
|
|
@ -6,26 +6,20 @@
|
||||||
#:use-module (goblins ocapn captp)
|
#:use-module (goblins ocapn captp)
|
||||||
#:use-module (goblins ocapn ids)
|
#:use-module (goblins ocapn ids)
|
||||||
#:use-module (goblins ocapn netlayer onion)
|
#:use-module (goblins ocapn netlayer onion)
|
||||||
#:export (make-initiator make-joiner initiator/connect resolve-initiator ^game-initiator ^game-joiner))
|
#:use-module (gib-gab-gob board)
|
||||||
|
#:use-module (fibers conditions)
|
||||||
|
#:export (initiator/connect ^game-initiator ^game-joiner))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Initiator logic
|
;; Initiator logic
|
||||||
;;
|
;;
|
||||||
;; todo: refactor?
|
|
||||||
(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))))
|
|
||||||
|
|
||||||
;; use this one
|
;; use this one
|
||||||
(define (initiator/connect initiator)
|
(define (initiator/connect initiator)
|
||||||
(define mycapn (spawn-mycapn (new-onion-netlayer)))
|
(define mycapn (spawn-mycapn (new-onion-netlayer)))
|
||||||
(define init-sref ($ mycapn 'register initiator 'onion))
|
(define init-sref ($ mycapn 'register initiator 'onion))
|
||||||
(format #t "Connect to: ~a\n" (ocapn-id->string init-sref)))
|
(format #t "Connect to: ~a\n" (ocapn-id->string init-sref)))
|
||||||
|
|
||||||
(define (^game-initiator bcom ^game-controller)
|
(define (^game-initiator bcom ^game-controller board my-turn+)
|
||||||
(define pick (pick-rps))
|
(define pick (pick-rps))
|
||||||
(define won? #nil)
|
(define won? #nil)
|
||||||
(define peer #nil)
|
(define peer #nil)
|
||||||
|
@ -40,21 +34,13 @@
|
||||||
[(try-transition)
|
[(try-transition)
|
||||||
(if (eq? won? #nil)
|
(if (eq? won? #nil)
|
||||||
'connecting
|
'connecting
|
||||||
(bcom (^game-controller bcom won? peer) 'ready-to-play))]))
|
(bcom (^game-controller bcom board my-turn+ won? peer) 'ready-to-play))]))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Joiner logic
|
;; Joiner logic
|
||||||
;;
|
;;
|
||||||
(define (make-joiner ^game-controller addr)
|
|
||||||
(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 joiner ($ joiner 'get-sealed-pick))
|
|
||||||
(lambda (_) (<- initiator 'try-transition)))
|
|
||||||
joiner)
|
|
||||||
|
|
||||||
(define (^game-joiner bcom initiator ^game-controller)
|
(define (^game-joiner bcom initiator ^game-controller board my-turn+)
|
||||||
(define-values (seal-pick unseal-pick my-pick?)
|
(define-values (seal-pick unseal-pick my-pick?)
|
||||||
(spawn-sealer-triplet))
|
(spawn-sealer-triplet))
|
||||||
(define pick (pick-rps))
|
(define pick (pick-rps))
|
||||||
|
@ -66,7 +52,7 @@
|
||||||
;; We make the assumption that initiator is to become a controller.
|
;; 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)
|
;; 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
|
;; see https://spritely.institute/files/docs/guile-goblins/0.11.0/Object-construction.html
|
||||||
(bcom (^game-controller bcom won? initiator) unseal-pick)]))
|
(bcom (^game-controller bcom board my-turn+ won? initiator) unseal-pick)]))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Standard rock paper scissors logic follows!
|
;; Standard rock paper scissors logic follows!
|
||||||
|
|
|
@ -0,0 +1,90 @@
|
||||||
|
(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 (srfi srfi-9)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (fibers)
|
||||||
|
#:use-module (fibers channels)
|
||||||
|
#:use-module (goblins)
|
||||||
|
#:use-module (goblins ocapn captp)
|
||||||
|
#:use-module (goblins ocapn ids)
|
||||||
|
#:use-module (goblins ocapn netlayer onion)
|
||||||
|
#:export (make-initiator make-joiner))
|
||||||
|
|
||||||
|
;; 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 my-turn+)
|
||||||
|
(get-message my-turn+)
|
||||||
|
(with-vat vat
|
||||||
|
(on (<- controller 'state)
|
||||||
|
(λ (state)
|
||||||
|
(%print b state)
|
||||||
|
(if (eq? state 'play)
|
||||||
|
(let ((coords (%read)))
|
||||||
|
(if coords (%eval vat b controller coords) #f))
|
||||||
|
#f)))))
|
||||||
|
|
||||||
|
(define (%read)
|
||||||
|
(define 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)
|
||||||
|
(format #t "Moving ~a\n" 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)
|
||||||
|
(%prompt))
|
||||||
|
|
||||||
|
(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 my-turn+)
|
||||||
|
(define vat (spawn-vat #:name "UI"))
|
||||||
|
(spawn-fiber
|
||||||
|
(λ ()
|
||||||
|
(while (%loop vat board controller my-turn+))
|
||||||
|
(format #t "bye-bye!\n")
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(define (make-initiator)
|
||||||
|
(with-vat
|
||||||
|
(spawn-vat #:name "Initiator Game")
|
||||||
|
(define my-turn+ (make-channel))
|
||||||
|
(define board (make-board))
|
||||||
|
(define initiator (spawn ^game-initiator ^ggg-controller board my-turn+))
|
||||||
|
(initiator/connect initiator)
|
||||||
|
(begin-game-loop board initiator my-turn+)))
|
||||||
|
|
||||||
|
(define (make-joiner ^game-controller addr)
|
||||||
|
(with-vat
|
||||||
|
(spawn-vat #:name "Joiner Game")
|
||||||
|
(define mycapn (spawn-mycapn (new-onion-netlayer)))
|
||||||
|
(define my-turn+ (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 my-turn+))
|
||||||
|
(sealed ($ joiner 'get-sealed-pick)))
|
||||||
|
(on (<- initiator 'register-opponent joiner sealed)
|
||||||
|
(λ (_)
|
||||||
|
(on ($ joiner 'initialize!)
|
||||||
|
(λ (status) (begin-game-loop board joiner my-turn+) #f)))))))
|
27
hall.scm
27
hall.scm
|
@ -16,32 +16,33 @@
|
||||||
(files (libraries
|
(files (libraries
|
||||||
((directory
|
((directory
|
||||||
"gib-gab-gob"
|
"gib-gab-gob"
|
||||||
((compiled-scheme-file "board")
|
((directory "ui" ((scheme-file "console")))
|
||||||
(compiled-scheme-file "game")
|
(compiled-scheme-file "board")
|
||||||
(scheme-file "game")
|
(scheme-file "game")
|
||||||
(scheme-file "board")
|
(scheme-file "board")
|
||||||
(scheme-file "rps")
|
(scheme-file "rps")
|
||||||
|
(compiled-scheme-file "game")
|
||||||
(compiled-scheme-file "rps")))))
|
(compiled-scheme-file "rps")))))
|
||||||
(tests ())
|
(tests ())
|
||||||
(programs
|
(programs
|
||||||
((directory
|
((directory
|
||||||
"scripts"
|
"scripts"
|
||||||
((in-file "make-joiner")
|
((in-file "make-initiator")
|
||||||
(in-file "make-initiator")
|
|
||||||
(text-file "make-joiner")
|
(text-file "make-joiner")
|
||||||
(text-file "make-initiator")))))
|
(text-file "make-initiator")
|
||||||
|
(in-file "make-joiner")))))
|
||||||
(documentation
|
(documentation
|
||||||
((org-file "README") (text-file "COPYING")))
|
((text-file "COPYING") (org-file "README")))
|
||||||
(infrastructure
|
(infrastructure
|
||||||
((automake-file "Makefile")
|
((shell-file "bootstrap")
|
||||||
(autoconf-file "configure")
|
(scheme-file "guix")
|
||||||
(text-file ".gitignore")
|
(in-file "pre-inst-env")
|
||||||
(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")))
|
||||||
(in-file "pre-inst-env")
|
(scheme-file "hall")
|
||||||
(scheme-file "guix")
|
(text-file ".gitignore")
|
||||||
(shell-file "bootstrap")))))
|
(autoconf-file "configure")
|
||||||
|
(automake-file "Makefile")))))
|
||||||
|
|
|
@ -4,7 +4,9 @@
|
||||||
|
|
||||||
(use-modules
|
(use-modules
|
||||||
(gib-gab-gob rps)
|
(gib-gab-gob rps)
|
||||||
(gib-gab-gob game))
|
(gib-gab-gob game)
|
||||||
(make-initiator ^ggg-controller)
|
(gib-gab-gob ui console))
|
||||||
|
|
||||||
|
(make-initiator)
|
||||||
|
|
||||||
(while #t #f) ;; indefinitely
|
(while #t #f) ;; indefinitely
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
!#
|
!#
|
||||||
|
|
||||||
(use-modules
|
(use-modules
|
||||||
(gib-gab-gob rps)
|
(gib-gab-gob ui console)
|
||||||
(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))))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue