Syncing multi-player actions.
This commit is contained in:
@@ -20,7 +20,8 @@
|
||||
(import chicken scheme srfi-1 data-structures)
|
||||
(use http-session srfi-69 coops uri-common
|
||||
srfi-18 medea numbers spiffy spiffy-cookies
|
||||
intarweb pll sxml-transforms websockets miscmacros)
|
||||
intarweb pll sxml-transforms websockets miscmacros
|
||||
mailbox)
|
||||
|
||||
(cond-expand
|
||||
(geiser
|
||||
@@ -76,7 +77,7 @@
|
||||
(trade initform: '() accessor: player-trade)
|
||||
(last-updated initform: 0 accessor: player-last-updated)
|
||||
(last-cash initform: 5000 accessor: player-last-cash)
|
||||
(last-ui-action initform: #f accessor: player-last-ui-action)))
|
||||
(mailbox initform: (make-mailbox) accessor: player-mailbox)))
|
||||
|
||||
(define-class <game> ()
|
||||
((id initform: 0 accessor: game-id)
|
||||
@@ -94,8 +95,7 @@
|
||||
(state initform: 'playing accessor: game-state)
|
||||
(name initform: "game" accessor: game-name)
|
||||
(turn initform: 1 accessor: game-turn)
|
||||
(actions initform: '() accessor: game-actions)
|
||||
(last-ui-action initform: #f accessor: game-last-ui-action)))
|
||||
(actions initform: '() accessor: game-actions)))
|
||||
|
||||
(define-class <app> ()
|
||||
((games initform: '() accessor: app-games)
|
||||
@@ -152,9 +152,6 @@
|
||||
(set-cookie! (session-cookie-name) sid))))
|
||||
(session-lifetime (* 60 60 24 7 4))
|
||||
|
||||
(define update-condition-variable (make-condition-variable))
|
||||
(define update-mutex (make-mutex))
|
||||
|
||||
(access-log (current-output-port))
|
||||
|
||||
(handle-not-found
|
||||
@@ -641,15 +638,11 @@
|
||||
(players . ,(list->vector
|
||||
(map player-name (game-players game))))))
|
||||
(app-games *app*))))))))
|
||||
|
||||
(define (set-ui-action! action game)
|
||||
(set! (game-last-ui-action game) action))
|
||||
|
||||
(define (ui-action game)
|
||||
(game-last-ui-action game))
|
||||
|
||||
(define (new-ui-action? player action)
|
||||
(not (eq? (player-last-ui-action player) action)))
|
||||
(define (message-players! game player message #!key (type "action"))
|
||||
(for-each (lambda (p)
|
||||
(when (not (eq? p player))
|
||||
(mailbox-send! (player-mailbox p) `((type . ,type) (value . ,message)))))
|
||||
(game-players game)))
|
||||
|
||||
(define *next-roll* #f)
|
||||
|
||||
@@ -681,16 +674,16 @@
|
||||
(append (game-actions game)
|
||||
`(((?action . move) (?value . ,resp)))
|
||||
(sort-actions (get-actions player (player-space player)))))
|
||||
(set-ui-action! `((action . "roll")
|
||||
(value . ,resp))
|
||||
game)
|
||||
(message-players! game player
|
||||
`((action . "roll")
|
||||
(value . ,resp)))
|
||||
(create-ws-response player "action" `((action . "roll") (value . ,resp))))))
|
||||
((and (string=? type "next-action")
|
||||
(not (eq? (player-state player) 'turn-ended)))
|
||||
(let loop ()
|
||||
(if (null? (game-actions game))
|
||||
(begin
|
||||
(set-ui-action! `((action . #f) (value . #f)) game)
|
||||
(message-players! game player `((action . #f) (value . #f)))
|
||||
(create-ws-response player "action" '((action . #f))))
|
||||
(let* ((action (car (game-actions game)))
|
||||
(name (alist-ref '?action action))
|
||||
@@ -701,22 +694,23 @@
|
||||
(set! (game-actions game) (cdr (game-actions game)))
|
||||
(if otb
|
||||
(begin
|
||||
(set-ui-action! `((action . "otb")
|
||||
(value . ,(alist-ref 'contents otb)))
|
||||
game)
|
||||
(message-players! game player
|
||||
`((action . "otb")
|
||||
(value . ,(alist-ref 'contents otb))))
|
||||
(create-ws-response player "action"
|
||||
`((action . "otb")
|
||||
(value . ,(alist-ref 'contents otb)))))
|
||||
(begin
|
||||
(set-ui-action! `((action . "info")
|
||||
(value . ,(conc "Out of " *item-card-short* "'s.")))
|
||||
game)
|
||||
(message-players! game player
|
||||
`((action . "info")
|
||||
(value . ,(conc "Out of " *item-card-short* "'s."))))
|
||||
(create-ws-response player "action"
|
||||
`((action . "info")
|
||||
(value . ,(conc "Out of " *item-card-short* "'s."))))))))
|
||||
((eq? name 'move)
|
||||
(set! (game-actions game) (cdr (game-actions game)))
|
||||
(set-ui-action! `((action . "move") (value . ,value)) game)
|
||||
(message-players! game player
|
||||
`((action . "move") (value . ,value)))
|
||||
(create-ws-response player "action"
|
||||
`((action . "move") (value . ,value))))
|
||||
((eq? name 'harvest)
|
||||
@@ -725,8 +719,9 @@
|
||||
(if (eq? res 'nothing)
|
||||
(loop)
|
||||
(begin
|
||||
(set-ui-action!
|
||||
`((action . "harvest") (value . ,res)) game)
|
||||
(message-players!
|
||||
game player
|
||||
`((action . "harvest") (value . ,res)))
|
||||
(create-ws-response player
|
||||
"action"
|
||||
`((action . "harvest")
|
||||
@@ -740,10 +735,10 @@
|
||||
(if (= (- (player-cash player) previous-cash) 0)
|
||||
(loop)
|
||||
(begin
|
||||
(set-ui-action! `((action . "money")
|
||||
(value . ,(- (player-cash player)
|
||||
previous-cash)))
|
||||
game)
|
||||
(message-players! game player
|
||||
`((action . "money")
|
||||
(value . ,(- (player-cash player)
|
||||
previous-cash))))
|
||||
(create-ws-response player "action"
|
||||
`((action . "money")
|
||||
(value . ,(- (player-cash player)
|
||||
@@ -758,9 +753,9 @@
|
||||
(set! (game-actions game)
|
||||
(append (alist-ref 'actions ff)
|
||||
(cdr (game-actions game))))
|
||||
(set-ui-action! `((action . "farmers-fate")
|
||||
(value . ,(alist-ref 'contents ff)))
|
||||
game)
|
||||
(message-players! game player
|
||||
`((action . "farmers-fate")
|
||||
(value . ,(alist-ref 'contents ff))))
|
||||
(create-ws-response player "action"
|
||||
`((action . "farmers-fate")
|
||||
(value . ,(alist-ref 'contents ff))))))
|
||||
@@ -769,21 +764,22 @@
|
||||
(if (= value 0)
|
||||
(loop)
|
||||
(begin
|
||||
(set-ui-action! `((action . "money") (value . ,value))
|
||||
game)
|
||||
(message-players! game player
|
||||
`((action . "money") (value . ,value)))
|
||||
(create-ws-response player "action"
|
||||
`((action . "money")
|
||||
(value . ,value))))))
|
||||
((eq? name 'ff-uncle-bert)
|
||||
(set! (game-actions game) (cdr (game-actions game)))
|
||||
(set-ui-action! `((action . "ff-uncle-bert") (value . #f))
|
||||
game)
|
||||
(message-players! game player
|
||||
`((action . "ff-uncle-bert") (value . #f)))
|
||||
(create-ws-response player "action"
|
||||
`((action . "ff-uncle-bert")
|
||||
(value . #f))))
|
||||
((eq? name 'info)
|
||||
(set! (game-actions game) (cdr (game-actions game)))
|
||||
(set-ui-action! `((action . "info") (value . ,value)) game)
|
||||
(message-players! game player
|
||||
`((action . "info") (value . ,value)))
|
||||
(create-ws-response player "action"
|
||||
`((action . "info")
|
||||
(value . ,value))))
|
||||
@@ -795,9 +791,8 @@
|
||||
(cdr (game-actions game))))
|
||||
(let ((resp `((from . ,(player-previous-space player))
|
||||
(to . ,(player-space player)))))
|
||||
(set-ui-action! `((action . "goto")
|
||||
(value . ,resp))
|
||||
game)
|
||||
(message-players! game player `((action . "goto")
|
||||
(value . ,resp)))
|
||||
(create-ws-response player "action"
|
||||
`((action . "goto")
|
||||
(value . ,resp)))))
|
||||
@@ -807,6 +802,10 @@
|
||||
(loop))
|
||||
(else ;; TODO make error
|
||||
(create-ws-response player "action" `((action . ,name)))))))))
|
||||
((string=? type "skip")
|
||||
(message-players! game player `((component . ,(alist-ref 'component msg)))
|
||||
type: "auto-skip")
|
||||
(create-ws-response player "update" '()))
|
||||
((string=? type "buy")
|
||||
(let* ((id (alist-ref 'id msg))
|
||||
(otb (find (lambda (x) (= id (alist-ref 'id x)))
|
||||
@@ -828,12 +827,14 @@
|
||||
(set! (player-otbs player)
|
||||
(filter (lambda (x) (not (= id (alist-ref 'id x))))
|
||||
(player-otbs player)))))
|
||||
(message-players! game player '() type: "update")
|
||||
(create-ws-response player "buy" '()))
|
||||
((string=? type "buy-uncle-bert")
|
||||
(set! (player-cash player) (- (player-cash player) 10000))
|
||||
(set! (player-assets player)
|
||||
(alist-update 'hay (+ (alist-ref 'hay (player-assets player)) 10)
|
||||
(player-assets player)))
|
||||
(message-players! game player '() type: "update")
|
||||
(create-ws-response player "buy" '()))
|
||||
((string=? type "actions-finished")
|
||||
(create-ws-response player "update" '()))
|
||||
@@ -859,9 +860,11 @@
|
||||
(create-ws-response player "loan" '()))
|
||||
((string=? type "trade")
|
||||
(propose-trade game player (alist-ref 'parameters msg))
|
||||
(message-players! game player '() type: "update")
|
||||
(create-ws-response player "trade" '()))
|
||||
((string=? type "trade-accept")
|
||||
(accept-trade game player)
|
||||
(message-players! game player '() type: "update")
|
||||
(create-ws-response player "trade-accepted" '()))
|
||||
((string=? type "trade-deny")
|
||||
(push-message player (conc (player-name player) " denied trade with "
|
||||
@@ -870,6 +873,7 @@
|
||||
game (alist-ref 'originator (player-trade player))))
|
||||
'())
|
||||
(set! (player-trade player) '())
|
||||
(message-players! game player '() type: "update")
|
||||
(create-ws-response player "trade-denied" '()))
|
||||
((string=? type "trade-cancel")
|
||||
(push-message player (conc (player-name player) " cancelled trade with "
|
||||
@@ -878,16 +882,19 @@
|
||||
game (alist-ref 'player (player-trade player))))
|
||||
'())
|
||||
(set! (player-trade player) '())
|
||||
(message-players! game player '() type: "update")
|
||||
(create-ws-response player "trade-cancelled" '()))
|
||||
((string=? type "audit")
|
||||
(call-audit game player)
|
||||
(message-players! game player '() type: "update")
|
||||
(create-ws-response player "called-audit" '()))
|
||||
((string=? type "init")
|
||||
(create-ws-response player "init" '()))
|
||||
((string=? type "turn-ended")
|
||||
(if (>= (player-cash player) 0)
|
||||
(begin (advance-turn game player)
|
||||
(create-ws-response player "turn-ended" '()))
|
||||
(message-players! game player '() type: "update")
|
||||
(create-ws-response player "update" '()))
|
||||
(begin (push-message player "Cannot end a turn with negative cash!")
|
||||
(create-ws-response player "update" '()))))
|
||||
;;;;;;;;;;;;;;;;;;;;; start ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@@ -969,8 +976,7 @@
|
||||
msg)))
|
||||
(when game
|
||||
(set! (game-last-updated game) (+ (game-last-updated game) 1))
|
||||
(set! (player-last-updated player) (game-last-updated game))
|
||||
(condition-variable-broadcast! update-condition-variable))
|
||||
(set! (player-last-updated player) (game-last-updated game)))
|
||||
res)))))
|
||||
(loop (read-json (receive-message)))))))
|
||||
|
||||
@@ -981,7 +987,8 @@
|
||||
(lambda ()
|
||||
(let ((game (session-ref (sid) 'game))
|
||||
(player (session-ref (sid) 'player)))
|
||||
(let loop ((updated (mutex-unlock! update-mutex update-condition-variable)))
|
||||
(let loop ((msg (mailbox-receive! (player-mailbox player))))
|
||||
(print msg)
|
||||
(when (not game)
|
||||
(set! game (session-ref (sid) 'game)))
|
||||
(when (not player)
|
||||
@@ -1005,16 +1012,11 @@
|
||||
(print-call-chain)
|
||||
(print-error-message exn))))
|
||||
(event . "error"))
|
||||
(if (and (new-ui-action? player (ui-action game))
|
||||
(or (eq? (player-state player) 'turn-ended)
|
||||
(eq? (player-state player) 'finished-game)))
|
||||
(begin
|
||||
(set! (player-last-ui-action player) (ui-action game))
|
||||
(create-ws-response player
|
||||
"action"
|
||||
(ui-action game)))
|
||||
(create-ws-response player "update" '())))))))
|
||||
(loop (mutex-unlock! update-mutex update-condition-variable)))))))
|
||||
(create-ws-response player
|
||||
(alist-ref 'type msg)
|
||||
(alist-ref 'value msg))
|
||||
)))))
|
||||
(loop (mailbox-receive! (player-mailbox player))))))))
|
||||
|
||||
(define (otb-spec->otb-cards spec id)
|
||||
`((contents . ,(sxml->html* (list-ref spec 5)))
|
||||
@@ -1709,7 +1711,6 @@
|
||||
;; TODO
|
||||
;; make game finished display results.
|
||||
;; make sure two players can't have the same name
|
||||
;; bug: harvest action multiplayer doesn't flow right for other players
|
||||
;; info actions should look better
|
||||
;; you can get $50 from harvest
|
||||
;; bug: new websocket messages should not reset IFS card selection
|
||||
|
||||
Reference in New Issue
Block a user