Added randomness and more cleanups
This commit is contained in:
parent
afd422039f
commit
b2bcaa8086
4 changed files with 28 additions and 9 deletions
7
gib-gab-gob.scm
Normal file
7
gib-gab-gob.scm
Normal file
|
@ -0,0 +1,7 @@
|
||||||
|
(define-module (gib-gab-gob)
|
||||||
|
#:use-module (gib-gab-gob rps)
|
||||||
|
#:use-module (gib-gab-gob actors)
|
||||||
|
#:re-export (do-rps
|
||||||
|
join-rps))
|
||||||
|
|
||||||
|
(set! *random-state* (random-state-from-platform))
|
|
@ -7,7 +7,7 @@
|
||||||
#:export (^rps ^client-picker))
|
#:export (^rps ^client-picker))
|
||||||
|
|
||||||
(define* (^rps bcom)
|
(define* (^rps bcom)
|
||||||
(define pick 'scissors)
|
(define pick (pick-rps))
|
||||||
(methods
|
(methods
|
||||||
((register-opponent name client sealed-pick)
|
((register-opponent name client sealed-pick)
|
||||||
(format #t "Hey there, ~a! You sent me your pick of rock-paper-scissors; now I will send mine.\n" name)
|
(format #t "Hey there, ~a! You sent me your pick of rock-paper-scissors; now I will send mine.\n" name)
|
||||||
|
@ -19,7 +19,7 @@
|
||||||
(define (^client-picker bcom)
|
(define (^client-picker bcom)
|
||||||
(define-values (seal-pick unseal-pick my-pick?)
|
(define-values (seal-pick unseal-pick my-pick?)
|
||||||
(spawn-sealer-triplet))
|
(spawn-sealer-triplet))
|
||||||
(define pick 'rock)
|
(define pick (pick-rps))
|
||||||
(methods
|
(methods
|
||||||
;; client always picks rock, it's the real good strat
|
;; client always picks rock, it's the real good strat
|
||||||
((get-sealed-pick) ($ seal-pick pick))
|
((get-sealed-pick) ($ seal-pick pick))
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
#:use-module (goblins ocapn ids)
|
#:use-module (goblins ocapn ids)
|
||||||
#:use-module (goblins ocapn netlayer testuds)
|
#:use-module (goblins ocapn netlayer testuds)
|
||||||
#:use-module (oop goops)
|
#:use-module (oop goops)
|
||||||
#:export (do-rps join-rps rps-winner rock-paper-scissors))
|
#:export (do-rps join-rps pick-rps rps-winner rock-paper-scissors))
|
||||||
|
|
||||||
(define-class <rps-host> ()
|
(define-class <rps-host> ()
|
||||||
(vat #:accessor vat)
|
(vat #:accessor vat)
|
||||||
|
@ -27,7 +27,9 @@
|
||||||
|
|
||||||
|
|
||||||
(define (new-testuds-netlayer)
|
(define (new-testuds-netlayer)
|
||||||
(spawn ^testuds-netlayer "/tmp/netlayers"))
|
(define tmp "/tmp/netlayers")
|
||||||
|
(unless (access? tmp X_OK) (mkdir tmp))
|
||||||
|
(spawn ^testuds-netlayer tmp))
|
||||||
|
|
||||||
(define (do-rps user-name)
|
(define (do-rps user-name)
|
||||||
(init (make <rps-host> #:user-name user-name)))
|
(init (make <rps-host> #:user-name user-name)))
|
||||||
|
@ -43,14 +45,12 @@
|
||||||
(define uds-netlayer (new-testuds-netlayer))
|
(define uds-netlayer (new-testuds-netlayer))
|
||||||
(define mycapn (spawn-mycapn uds-netlayer))
|
(define mycapn (spawn-mycapn uds-netlayer))
|
||||||
(set! (rps client)
|
(set! (rps client)
|
||||||
(<- mycapn 'enliven rps-sref))
|
(<- mycapn 'enliven rps-sref)))
|
||||||
(on (rps client) pk))
|
|
||||||
|
|
||||||
(define (join-rps user-name rps-addr)
|
(define (join-rps user-name rps-addr)
|
||||||
(define client (make <rps-client> #:user-name user-name #:rps-addr rps-addr))
|
(define client (make <rps-client> #:user-name user-name #:rps-addr rps-addr))
|
||||||
(with-vat (vat client)
|
(with-vat (vat client)
|
||||||
(init client)
|
(init client)
|
||||||
(format #t "Tor will take a bit...\n")
|
|
||||||
(let ((client-picker (spawn ^client-picker))
|
(let ((client-picker (spawn ^client-picker))
|
||||||
(rps (rps client)))
|
(rps (rps client)))
|
||||||
(on (<- rps 'register-opponent user-name client-picker ($ client-picker 'get-sealed-pick))
|
(on (<- rps 'register-opponent user-name client-picker ($ client-picker 'get-sealed-pick))
|
||||||
|
@ -60,6 +60,9 @@
|
||||||
|
|
||||||
(define rock-paper-scissors (list 'rock 'paper 'scissors))
|
(define rock-paper-scissors (list 'rock 'paper 'scissors))
|
||||||
|
|
||||||
|
(define (pick-rps)
|
||||||
|
(list-ref rock-paper-scissors (random (length rock-paper-scissors))))
|
||||||
|
|
||||||
(define (rps-winner a b)
|
(define (rps-winner a b)
|
||||||
(if (and (memq a rock-paper-scissors) (memq b rock-paper-scissors))
|
(if (and (memq a rock-paper-scissors) (memq b rock-paper-scissors))
|
||||||
(match (list a b)
|
(match (list a b)
|
||||||
|
|
13
hall.scm
13
hall.scm
|
@ -16,14 +16,23 @@
|
||||||
(files (libraries
|
(files (libraries
|
||||||
((directory
|
((directory
|
||||||
"gib-gab-gob"
|
"gib-gab-gob"
|
||||||
((scheme-file "rps") (scheme-file "actors")))))
|
((compiled-scheme-file "actors")
|
||||||
|
(scheme-file "rps")
|
||||||
|
(scheme-file "actors")
|
||||||
|
(compiled-scheme-file "rps")))))
|
||||||
(tests ((directory "tests" ())))
|
(tests ((directory "tests" ())))
|
||||||
(programs ((directory "scripts" ())))
|
(programs ((directory "scripts" ())))
|
||||||
(documentation
|
(documentation
|
||||||
((text-file "ChangeLog")
|
((text-file "ChangeLog")
|
||||||
(text-file "AUTHORS")
|
(text-file "AUTHORS")
|
||||||
(text-file "NEWS")
|
(text-file "NEWS")
|
||||||
(directory "doc" ((texi-file "gib-gab-gob")))
|
(directory
|
||||||
|
"doc"
|
||||||
|
((texi-file "version")
|
||||||
|
(text-file ".dirstamp")
|
||||||
|
(text-file "stamp-vti")
|
||||||
|
(info-file "gib-gab-gob")
|
||||||
|
(texi-file "gib-gab-gob")))
|
||||||
(text-file "COPYING")
|
(text-file "COPYING")
|
||||||
(text-file "HACKING")
|
(text-file "HACKING")
|
||||||
(text-file "README")))
|
(text-file "README")))
|
||||||
|
|
Loading…
Reference in a new issue