|
|
|
|
@ -54,6 +54,18 @@
|
|
|
|
|
(lambda ()
|
|
|
|
|
(SRV:send-reply (pre-post-order* sxml rules)))))))
|
|
|
|
|
|
|
|
|
|
(define-syntax safe-set!
|
|
|
|
|
(ir-macro-transformer
|
|
|
|
|
(lambda (x i c)
|
|
|
|
|
(let ((mutex-symbol (string->symbol (string-append (car (string-split (symbol->string (caadr x)) "-")) "-mutex"))))
|
|
|
|
|
`(let* ((obj ,(second (second x)))
|
|
|
|
|
(res ,(third x))
|
|
|
|
|
(mutex (,(i mutex-symbol) obj)))
|
|
|
|
|
(dynamic-wind
|
|
|
|
|
(lambda () (mutex-lock! mutex))
|
|
|
|
|
(lambda () (set! (,(first (second x)) obj) res))
|
|
|
|
|
(lambda () (mutex-unlock! mutex))))))))
|
|
|
|
|
|
|
|
|
|
(define-class <player> ()
|
|
|
|
|
((cash initform: 5000 accessor: player-cash)
|
|
|
|
|
(debt initform: 5000 accessor: player-debt)
|
|
|
|
|
@ -78,7 +90,8 @@
|
|
|
|
|
(trade initform: '() accessor: player-trade)
|
|
|
|
|
(last-updated initform: 0 accessor: player-last-updated)
|
|
|
|
|
(last-cash initform: 5000 accessor: player-last-cash)
|
|
|
|
|
(mailbox initform: (make-mailbox) accessor: player-mailbox)))
|
|
|
|
|
(mailbox initform: (make-mailbox) accessor: player-mailbox)
|
|
|
|
|
(mutex initform: (make-mutex 'player) accessor: player-mutex)))
|
|
|
|
|
|
|
|
|
|
(define-class <game> ()
|
|
|
|
|
((id initform: 0 accessor: game-id)
|
|
|
|
|
@ -105,14 +118,16 @@
|
|
|
|
|
(starting-cash . 5000)
|
|
|
|
|
(starting-debt . 5000)
|
|
|
|
|
(trade . #t))
|
|
|
|
|
accessor: game-settings)))
|
|
|
|
|
accessor: game-settings)
|
|
|
|
|
(mutex initform: (make-mutex 'game) accessor: game-mutex)))
|
|
|
|
|
|
|
|
|
|
(define (game-setting setting game)
|
|
|
|
|
(alist-ref setting (game-settings game)))
|
|
|
|
|
|
|
|
|
|
(define-class <app> ()
|
|
|
|
|
((games initform: '() accessor: app-games)
|
|
|
|
|
(last-game-id initform: 0 accessor: last-game-id)))
|
|
|
|
|
(last-game-id initform: 0 accessor: app-last-game-id)
|
|
|
|
|
(mutex initform: (make-mutex 'app) accessor: app-mutex)))
|
|
|
|
|
|
|
|
|
|
(define (player->sexp player)
|
|
|
|
|
`((cash . ,(player-cash player))
|
|
|
|
|
@ -155,8 +170,8 @@
|
|
|
|
|
(define *app* (make <app>))
|
|
|
|
|
|
|
|
|
|
(define (next-game-id app)
|
|
|
|
|
(set! (last-game-id app) (+ (last-game-id app) 1))
|
|
|
|
|
(- (last-game-id app) 1))
|
|
|
|
|
(safe-set! (app-last-game-id app) (+ (app-last-game-id app) 1))
|
|
|
|
|
(- (app-last-game-id app) 1))
|
|
|
|
|
|
|
|
|
|
(define sid (make-parameter #f))
|
|
|
|
|
(define session-cookie-name (make-parameter "awful-cookie"))
|
|
|
|
|
@ -214,7 +229,7 @@
|
|
|
|
|
|
|
|
|
|
(define (next-game-color game)
|
|
|
|
|
(let ((color (car (game-colors game))))
|
|
|
|
|
(set! (game-colors game) (cdr (game-colors game)))
|
|
|
|
|
(safe-set! (game-colors game) (cdr (game-colors game)))
|
|
|
|
|
color))
|
|
|
|
|
|
|
|
|
|
(define (add-player-to-game game color name)
|
|
|
|
|
@ -225,9 +240,9 @@
|
|
|
|
|
'name name
|
|
|
|
|
'state (if (= (length (game-players game)) 0)
|
|
|
|
|
'pre-turn 'turn-ended))))
|
|
|
|
|
(set! (game-players game) (append (game-players game) (list player)))
|
|
|
|
|
(safe-set! (game-players game) (append (game-players game) (list player)))
|
|
|
|
|
(when (= (length (game-players game)) 1)
|
|
|
|
|
(set! (game-current-player game) player))
|
|
|
|
|
(safe-set! (game-current-player game) player))
|
|
|
|
|
player))
|
|
|
|
|
|
|
|
|
|
(define (all-players-finished game)
|
|
|
|
|
@ -248,12 +263,12 @@
|
|
|
|
|
|
|
|
|
|
(define (advance-turn game player)
|
|
|
|
|
(if (all-players-finished game)
|
|
|
|
|
(set! (game-state game) 'finished)
|
|
|
|
|
(safe-set! (game-state game) 'finished)
|
|
|
|
|
(let ((next (next-player game)))
|
|
|
|
|
(set! (player-state player) 'turn-ended)
|
|
|
|
|
(set! (player-state next) 'pre-turn)
|
|
|
|
|
(set! (game-current-player game) next)
|
|
|
|
|
(set! (game-turn game) (+ (game-turn game) 1)))))
|
|
|
|
|
(safe-set! (player-state player) 'turn-ended)
|
|
|
|
|
(safe-set! (player-state next) 'pre-turn)
|
|
|
|
|
(safe-set! (game-current-player game) next)
|
|
|
|
|
(safe-set! (game-turn game) (+ (game-turn game) 1)))))
|
|
|
|
|
|
|
|
|
|
(define (ridge-available? game ridge)
|
|
|
|
|
(let loop ((players (game-players game)))
|
|
|
|
|
@ -268,8 +283,8 @@
|
|
|
|
|
(for-each
|
|
|
|
|
(lambda (x)
|
|
|
|
|
(receive (new-otb remaining-otbs) (split-at (game-otbs game) 1)
|
|
|
|
|
(set! (player-otbs player) (cons (car new-otb) (player-otbs player)))
|
|
|
|
|
(set! (game-otbs game) remaining-otbs)))
|
|
|
|
|
(safe-set! (player-otbs player) (cons (car new-otb) (player-otbs player)))
|
|
|
|
|
(safe-set! (game-otbs game) remaining-otbs)))
|
|
|
|
|
(iota number)))
|
|
|
|
|
|
|
|
|
|
(define (main-page)
|
|
|
|
|
@ -344,17 +359,7 @@
|
|
|
|
|
(trade . ,(game-setting 'trade g))))))))
|
|
|
|
|
|
|
|
|
|
(define (push-message player msg #!key (game (session-ref (sid) 'game)))
|
|
|
|
|
(if player
|
|
|
|
|
(set! (game-messages game) (cons `#(,(player-name player)
|
|
|
|
|
,(game-turn game)
|
|
|
|
|
,msg)
|
|
|
|
|
(game-messages game)))
|
|
|
|
|
;; (set! (game-messages game) (cons (conc (player-name player) ": " msg)
|
|
|
|
|
;; (game-messages game)))
|
|
|
|
|
(set! (game-messages game) (cons `#(#f ,(game-turn game) ,msg)
|
|
|
|
|
(game-messages game)))
|
|
|
|
|
;; (set! (game-messages game) (cons msg (game-messages game)))
|
|
|
|
|
))
|
|
|
|
|
(void))
|
|
|
|
|
|
|
|
|
|
(define (buy-crop crop unnormalized-crop amount cash-value player game)
|
|
|
|
|
(let ((total-cost (* amount (alist-ref unnormalized-crop
|
|
|
|
|
@ -394,14 +399,14 @@
|
|
|
|
|
#f)
|
|
|
|
|
(else
|
|
|
|
|
(let ((assets (player-assets player)))
|
|
|
|
|
(set!
|
|
|
|
|
(safe-set!
|
|
|
|
|
(player-assets player)
|
|
|
|
|
(alist-update crop (+ (alist-ref crop assets) amount) assets))
|
|
|
|
|
(set! (player-cash player) (- (player-cash player) cash-value))
|
|
|
|
|
(set! (player-debt player)
|
|
|
|
|
(safe-set! (player-cash player) (- (player-cash player) cash-value))
|
|
|
|
|
(safe-set! (player-debt player)
|
|
|
|
|
(+ (player-debt player) (- total-cost cash-value)))
|
|
|
|
|
(when (member unnormalized-crop ridges)
|
|
|
|
|
(set! (player-ridges player)
|
|
|
|
|
(safe-set! (player-ridges player)
|
|
|
|
|
(alist-update unnormalized-crop amount (player-ridges player))))
|
|
|
|
|
(push-message player (conc "You bought " amount " " crop "."))
|
|
|
|
|
#t)))))
|
|
|
|
|
@ -412,33 +417,33 @@
|
|
|
|
|
(define (finish-year player #!optional (collect-wages #t))
|
|
|
|
|
(let ((game (session-ref (sid) 'game)))
|
|
|
|
|
(when collect-wages
|
|
|
|
|
(set! (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player)
|
|
|
|
|
(+ (player-cash player) 5000))
|
|
|
|
|
(push-message player
|
|
|
|
|
(conc "You earned $5,000 from your city job!"))
|
|
|
|
|
(set! (game-actions game)
|
|
|
|
|
(safe-set! (game-actions game)
|
|
|
|
|
(cons '((?action . info)
|
|
|
|
|
(?value . "You earned $5,000 from your city job!"))
|
|
|
|
|
(game-actions game))))
|
|
|
|
|
(when (game-called-audit game)
|
|
|
|
|
(set! (game-actions game)
|
|
|
|
|
(safe-set! (game-actions game)
|
|
|
|
|
(append (game-actions game)
|
|
|
|
|
`(((?action . end-game)
|
|
|
|
|
(?value . ,(lambda ()
|
|
|
|
|
(set! (player-finished player) #t))))))))
|
|
|
|
|
(set! (player-year-rules player) (player-next-year-rules player))
|
|
|
|
|
(set! (player-next-year-rules player) '())
|
|
|
|
|
(safe-set! (player-finished player) #t))))))))
|
|
|
|
|
(safe-set! (player-year-rules player) (player-next-year-rules player))
|
|
|
|
|
(safe-set! (player-next-year-rules player) '())
|
|
|
|
|
(when (not (null? (player-farmers-fates player)))
|
|
|
|
|
(set! (game-farmers-fates game)
|
|
|
|
|
(safe-set! (game-farmers-fates game)
|
|
|
|
|
(append (game-farmers-fates game) (player-farmers-fates player)))
|
|
|
|
|
(set! (player-farmers-fates player) '())
|
|
|
|
|
(safe-set! (player-farmers-fates player) '())
|
|
|
|
|
;; this is a really hacky way of getting F.F. calf weaning weights
|
|
|
|
|
;; to work for the second year.
|
|
|
|
|
(when (not (null? (player-year-rules player)))
|
|
|
|
|
(set! (player-farmers-fates player)
|
|
|
|
|
(safe-set! (player-farmers-fates player)
|
|
|
|
|
(list (find (lambda (c) (eq? (alist-ref 'internal-id c) 'cows-15))
|
|
|
|
|
(game-farmers-fates game))))
|
|
|
|
|
(set! (game-farmers-fates game)
|
|
|
|
|
(safe-set! (game-farmers-fates game)
|
|
|
|
|
(filter (lambda (c) (not (eq? (alist-ref 'internal-id c) 'cows-15)))
|
|
|
|
|
(game-farmers-fates game)))
|
|
|
|
|
(push! (make-player-year-rule
|
|
|
|
|
@ -527,12 +532,12 @@
|
|
|
|
|
(cdr x)))
|
|
|
|
|
params)))
|
|
|
|
|
(set! *trade-number* (+ *trade-number* 1))
|
|
|
|
|
(set! (player-trade other-player)
|
|
|
|
|
(safe-set! (player-trade other-player)
|
|
|
|
|
(append `((player . ,(player-name player))
|
|
|
|
|
(originator . ,(player-name player))
|
|
|
|
|
(trade-number . ,*trade-number*))
|
|
|
|
|
to-trade))
|
|
|
|
|
(set! (player-trade player)
|
|
|
|
|
(safe-set! (player-trade player)
|
|
|
|
|
(append `((player . ,(player-name other-player))
|
|
|
|
|
(originator . ,(player-name player))
|
|
|
|
|
(trade-number . ,*trade-number*))
|
|
|
|
|
@ -561,11 +566,11 @@
|
|
|
|
|
(let ((assets (player-assets originator))
|
|
|
|
|
(other-assets (player-assets player))
|
|
|
|
|
(amount (alist-ref crop params)))
|
|
|
|
|
(set!
|
|
|
|
|
(safe-set!
|
|
|
|
|
(player-assets originator)
|
|
|
|
|
(alist-update crop (+ (alist-ref crop assets) amount)
|
|
|
|
|
assets))
|
|
|
|
|
(set!
|
|
|
|
|
(safe-set!
|
|
|
|
|
(player-assets player)
|
|
|
|
|
(alist-update crop (+ (alist-ref crop other-assets) (* amount -1))
|
|
|
|
|
other-assets)))))
|
|
|
|
|
@ -576,52 +581,52 @@
|
|
|
|
|
(when (alist-ref ridge params)
|
|
|
|
|
(if (> (player-ridge player ridge) 0)
|
|
|
|
|
(begin
|
|
|
|
|
(set! (player-ridges originator)
|
|
|
|
|
(safe-set! (player-ridges originator)
|
|
|
|
|
(alist-update ridge
|
|
|
|
|
(alist-ref ridge (player-ridges player))
|
|
|
|
|
(player-ridges originator)))
|
|
|
|
|
(set! (player-ridges player)
|
|
|
|
|
(safe-set! (player-ridges player)
|
|
|
|
|
(alist-update ridge 0 (player-ridges player))))
|
|
|
|
|
(begin
|
|
|
|
|
(set! (player-ridges player)
|
|
|
|
|
(safe-set! (player-ridges player)
|
|
|
|
|
(alist-update ridge
|
|
|
|
|
(alist-ref ridge (player-ridges originator))
|
|
|
|
|
(player-ridges player)))
|
|
|
|
|
(set! (player-ridges originator)
|
|
|
|
|
(safe-set! (player-ridges originator)
|
|
|
|
|
(alist-update ridge 0 (player-ridges originator)))))))
|
|
|
|
|
(loop (cdr ridges))))
|
|
|
|
|
(when (alist-ref 'money params)
|
|
|
|
|
(set! (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player)
|
|
|
|
|
(+ (player-cash player) (* (alist-ref 'money params) -1)))
|
|
|
|
|
(set! (player-cash originator)
|
|
|
|
|
(safe-set! (player-cash originator)
|
|
|
|
|
(+ (player-cash originator) (alist-ref 'money params))))
|
|
|
|
|
(when (alist-ref 'cards params)
|
|
|
|
|
(for-each
|
|
|
|
|
(lambda (id)
|
|
|
|
|
(if (otb-by-id player id)
|
|
|
|
|
(let ((otb (otb-by-id player id)))
|
|
|
|
|
(set! (player-otbs player)
|
|
|
|
|
(safe-set! (player-otbs player)
|
|
|
|
|
(filter (lambda (x) (not (= id (alist-ref 'id x))))
|
|
|
|
|
(player-otbs player)))
|
|
|
|
|
(set! (player-otbs originator)
|
|
|
|
|
(safe-set! (player-otbs originator)
|
|
|
|
|
(cons otb (player-otbs originator))))
|
|
|
|
|
(let ((otb (otb-by-id originator id)))
|
|
|
|
|
(set! (player-otbs originator)
|
|
|
|
|
(safe-set! (player-otbs originator)
|
|
|
|
|
(filter (lambda (x) (not (= id (alist-ref 'id x))))
|
|
|
|
|
(player-otbs originator)))
|
|
|
|
|
(set! (player-otbs player)
|
|
|
|
|
(safe-set! (player-otbs player)
|
|
|
|
|
(cons otb (player-otbs player))))))
|
|
|
|
|
|
|
|
|
|
cards))
|
|
|
|
|
(set! (player-trade originator) '())
|
|
|
|
|
(set! (player-trade player) '()))
|
|
|
|
|
(safe-set! (player-trade originator) '())
|
|
|
|
|
(safe-set! (player-trade player) '()))
|
|
|
|
|
#f)))
|
|
|
|
|
|
|
|
|
|
(define (call-audit game player)
|
|
|
|
|
(if (game-called-audit game)
|
|
|
|
|
(push-message player (conc (player-name (game-called-audit game))
|
|
|
|
|
" already called audit!"))
|
|
|
|
|
(begin (set! (game-called-audit game) player)
|
|
|
|
|
(begin (safe-set! (game-called-audit game) player)
|
|
|
|
|
(push-message player (conc (player-name player) " has called an audit!")))))
|
|
|
|
|
|
|
|
|
|
(define (player-net-worth player)
|
|
|
|
|
@ -693,28 +698,28 @@
|
|
|
|
|
|
|
|
|
|
(define (process-message player game type msg)
|
|
|
|
|
(when game
|
|
|
|
|
(set! (game-messages game) '())
|
|
|
|
|
(set! (player-last-cash player) (player-cash player)))
|
|
|
|
|
(safe-set! (game-messages game) '())
|
|
|
|
|
(safe-set! (player-last-cash player) (player-cash player)))
|
|
|
|
|
(print "message type: " type)
|
|
|
|
|
(cond ((string=? type "roll")
|
|
|
|
|
(let ((num (+ (random 6) 1)))
|
|
|
|
|
(when *next-roll* (set! num *next-roll*))
|
|
|
|
|
(set! (player-previous-space player)
|
|
|
|
|
(safe-set! (player-previous-space player)
|
|
|
|
|
(player-space player))
|
|
|
|
|
(set! (player-space player)
|
|
|
|
|
(safe-set! (player-space player)
|
|
|
|
|
(+ (player-space player) num))
|
|
|
|
|
(set! (player-state player) 'mid-turn)
|
|
|
|
|
(safe-set! (player-state player) 'mid-turn)
|
|
|
|
|
(push-message player (conc "You rolled a " num))
|
|
|
|
|
(when (> (player-space player) 48)
|
|
|
|
|
(set! (player-space player)
|
|
|
|
|
(safe-set! (player-space player)
|
|
|
|
|
(- (player-space player) 49)))
|
|
|
|
|
(when (and (> (player-previous-space player) 40)
|
|
|
|
|
(< (player-space player) 10))
|
|
|
|
|
(finish-year player))
|
|
|
|
|
(set! (player-harvest-mult player) 1)
|
|
|
|
|
(safe-set! (player-harvest-mult player) 1)
|
|
|
|
|
(let ((resp `((from . ,(player-previous-space player))
|
|
|
|
|
(to . ,(player-space player)))))
|
|
|
|
|
(set! (game-actions game)
|
|
|
|
|
(safe-set! (game-actions game)
|
|
|
|
|
(append (game-actions game)
|
|
|
|
|
`(((?action . move) (?value . ,resp)))
|
|
|
|
|
(sort-actions (get-actions player (player-space player)))))
|
|
|
|
|
@ -728,7 +733,7 @@
|
|
|
|
|
(if (or (null? (game-actions game))
|
|
|
|
|
(>= i 15))
|
|
|
|
|
(begin
|
|
|
|
|
(set! (game-actions game) '())
|
|
|
|
|
(safe-set! (game-actions game) '())
|
|
|
|
|
(message-players! game player `((action . #f) (value . #f)))
|
|
|
|
|
(create-ws-response player "action" '((action . #f))))
|
|
|
|
|
(let* ((action (car (game-actions game)))
|
|
|
|
|
@ -737,7 +742,7 @@
|
|
|
|
|
(print action)
|
|
|
|
|
(cond ((eq? value 'otb)
|
|
|
|
|
(let ((otb (do-action action player)))
|
|
|
|
|
(set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(safe-set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(if otb
|
|
|
|
|
(begin
|
|
|
|
|
(message-players! game player
|
|
|
|
|
@ -754,14 +759,14 @@
|
|
|
|
|
`((action . "info")
|
|
|
|
|
(value . ,(conc "Out of " *item-card-short* "'s."))))))))
|
|
|
|
|
((eq? name 'move)
|
|
|
|
|
(set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(safe-set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(message-players! game player
|
|
|
|
|
`((action . "move") (value . ,value)))
|
|
|
|
|
(create-ws-response player "action"
|
|
|
|
|
`((action . "move") (value . ,value))))
|
|
|
|
|
((eq? name 'harvest)
|
|
|
|
|
(let ((res (do-action action player)))
|
|
|
|
|
(set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(safe-set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(if (eq? res 'nothing)
|
|
|
|
|
(loop (+ i 1))
|
|
|
|
|
(begin
|
|
|
|
|
@ -776,7 +781,7 @@
|
|
|
|
|
;; all current player-actions have only a cash effect
|
|
|
|
|
(let ((previous-cash (player-cash player)))
|
|
|
|
|
(do-action action player)
|
|
|
|
|
(set! (game-actions game)
|
|
|
|
|
(safe-set! (game-actions game)
|
|
|
|
|
(cdr (game-actions game)))
|
|
|
|
|
(if (= (- (player-cash player) previous-cash) 0)
|
|
|
|
|
(loop (+ i 1))
|
|
|
|
|
@ -790,19 +795,19 @@
|
|
|
|
|
(if (null? (cdr (game-actions game)))
|
|
|
|
|
(begin
|
|
|
|
|
(value)
|
|
|
|
|
(set! (game-actions game) '()))
|
|
|
|
|
(set! (game-actions game)
|
|
|
|
|
(safe-set! (game-actions game) '()))
|
|
|
|
|
(safe-set! (game-actions game)
|
|
|
|
|
(append (cdr (game-actions game))
|
|
|
|
|
(list (car (game-actions game))))))
|
|
|
|
|
(loop (+ i 1)))
|
|
|
|
|
((or (eq? name 'harvest-mult)
|
|
|
|
|
(eq? name 'player-action-post-harvest))
|
|
|
|
|
(set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(safe-set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(do-action action player)
|
|
|
|
|
(loop (+ i 1)))
|
|
|
|
|
((eq? value 'farmers-fate)
|
|
|
|
|
(let ((ff (do-action action player)))
|
|
|
|
|
(set! (game-actions game)
|
|
|
|
|
(safe-set! (game-actions game)
|
|
|
|
|
(append (alist-ref 'actions ff)
|
|
|
|
|
(cdr (game-actions game))))
|
|
|
|
|
(message-players! game player
|
|
|
|
|
@ -812,7 +817,7 @@
|
|
|
|
|
`((action . "farmers-fate")
|
|
|
|
|
(value . ,(alist-ref 'contents ff))))))
|
|
|
|
|
((eq? name 'ff-money)
|
|
|
|
|
(set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(safe-set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(if (= (alist-ref 'amount value) 0)
|
|
|
|
|
(loop (+ i 1))
|
|
|
|
|
(let ((res `((action . "money")
|
|
|
|
|
@ -821,14 +826,14 @@
|
|
|
|
|
(message-players! game player res)
|
|
|
|
|
(create-ws-response player "action" res))))
|
|
|
|
|
((eq? name 'ff-uncle-bert)
|
|
|
|
|
(set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(safe-set! (game-actions game) (cdr (game-actions 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)))
|
|
|
|
|
(safe-set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(message-players! game player
|
|
|
|
|
`((action . "info") (value . ,value)))
|
|
|
|
|
(create-ws-response player "action"
|
|
|
|
|
@ -836,8 +841,8 @@
|
|
|
|
|
(value . ,value))))
|
|
|
|
|
((eq? name 'goto)
|
|
|
|
|
(do-action action player)
|
|
|
|
|
(set! (player-harvest-mult player) 1)
|
|
|
|
|
(set! (game-actions game)
|
|
|
|
|
(safe-set! (player-harvest-mult player) 1)
|
|
|
|
|
(safe-set! (game-actions game)
|
|
|
|
|
(append (sort-actions (get-actions player (player-space player)))
|
|
|
|
|
(cdr (game-actions game))))
|
|
|
|
|
(let ((resp `((from . ,(player-previous-space player))
|
|
|
|
|
@ -849,7 +854,7 @@
|
|
|
|
|
(value . ,resp)))))
|
|
|
|
|
((eq? name 'add-rule)
|
|
|
|
|
(do-action action player)
|
|
|
|
|
(set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(safe-set! (game-actions game) (cdr (game-actions game)))
|
|
|
|
|
(loop (+ i 1)))
|
|
|
|
|
(else ;; TODO make error
|
|
|
|
|
(create-ws-response player "action" `((action . ,name)))))))))
|
|
|
|
|
@ -871,18 +876,18 @@
|
|
|
|
|
1000)
|
|
|
|
|
player
|
|
|
|
|
game)
|
|
|
|
|
(set! (game-otbs game)
|
|
|
|
|
(safe-set! (game-otbs game)
|
|
|
|
|
(append (game-otbs game)
|
|
|
|
|
(filter (lambda (x) (= id (alist-ref 'id x)))
|
|
|
|
|
(player-otbs player))))
|
|
|
|
|
(set! (player-otbs player)
|
|
|
|
|
(safe-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)
|
|
|
|
|
(safe-set! (player-cash player) (- (player-cash player) 10000))
|
|
|
|
|
(safe-set! (player-assets player)
|
|
|
|
|
(alist-update 'hay (+ (alist-ref 'hay (player-assets player)) 10)
|
|
|
|
|
(player-assets player)))
|
|
|
|
|
(message-players! game player '() type: "update")
|
|
|
|
|
@ -897,8 +902,8 @@
|
|
|
|
|
(farming-round (+ amount (* amount (game-setting 'loan-interest game)))))
|
|
|
|
|
(game-setting 'max-debt game))
|
|
|
|
|
(push-message player "Exceeds max loan.")
|
|
|
|
|
(begin (set! (player-cash player) (+ (player-cash player) amount))
|
|
|
|
|
(set! (player-debt player) (+ (player-debt player)
|
|
|
|
|
(begin (safe-set! (player-cash player) (+ (player-cash player) amount))
|
|
|
|
|
(safe-set! (player-debt player) (+ (player-debt player)
|
|
|
|
|
(farming-round
|
|
|
|
|
(+ amount (* amount (game-setting 'loan-interest game))))))
|
|
|
|
|
(push-message player (conc "Loan of $" amount " taken out."))))
|
|
|
|
|
@ -906,12 +911,12 @@
|
|
|
|
|
(cond ((> (abs amount) (player-cash player))
|
|
|
|
|
(push-message player "Not enough cash to repay loan."))
|
|
|
|
|
(else
|
|
|
|
|
(set! (player-cash player) (+ (player-cash player) amount))
|
|
|
|
|
(set! (player-debt player) (+ (player-debt player) amount))
|
|
|
|
|
(safe-set! (player-cash player) (+ (player-cash player) amount))
|
|
|
|
|
(safe-set! (player-debt player) (+ (player-debt player) amount))
|
|
|
|
|
(when (< (player-debt player) 0)
|
|
|
|
|
(set! (player-cash player) (+ (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player) (+ (player-cash player)
|
|
|
|
|
(abs (player-debt player))))
|
|
|
|
|
(set! (player-debt player) 0))
|
|
|
|
|
(safe-set! (player-debt player) 0))
|
|
|
|
|
(push-message player (conc "Loan of $" (abs amount) " repayed."))))
|
|
|
|
|
))
|
|
|
|
|
(create-ws-response player "loan" '()))
|
|
|
|
|
@ -921,7 +926,7 @@
|
|
|
|
|
(begin
|
|
|
|
|
(message-players! game player '() type: "update")
|
|
|
|
|
(create-ws-response player "trade" '()))
|
|
|
|
|
(begin (set! (player-trade player) `((error . ,res)))
|
|
|
|
|
(begin (safe-set! (player-trade player) `((error . ,res)))
|
|
|
|
|
(create-ws-response player "trade-error" `())))))
|
|
|
|
|
((string=? type "trade-accept")
|
|
|
|
|
(accept-trade game player)
|
|
|
|
|
@ -930,19 +935,19 @@
|
|
|
|
|
((string=? type "trade-deny")
|
|
|
|
|
(push-message player (conc (player-name player) " denied trade with "
|
|
|
|
|
(alist-ref 'originator (player-trade player)) "."))
|
|
|
|
|
(set! (player-trade (find-player-by-name
|
|
|
|
|
(safe-set! (player-trade (find-player-by-name
|
|
|
|
|
game (alist-ref 'originator (player-trade player))))
|
|
|
|
|
'())
|
|
|
|
|
(set! (player-trade player) '())
|
|
|
|
|
(safe-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 "
|
|
|
|
|
(alist-ref 'player (player-trade player)) "."))
|
|
|
|
|
(set! (player-trade (find-player-by-name
|
|
|
|
|
(safe-set! (player-trade (find-player-by-name
|
|
|
|
|
game (alist-ref 'player (player-trade player))))
|
|
|
|
|
'())
|
|
|
|
|
(set! (player-trade player) '())
|
|
|
|
|
(safe-set! (player-trade player) '())
|
|
|
|
|
(message-players! game player '() type: "update")
|
|
|
|
|
(create-ws-response player "trade-cancelled" '()))
|
|
|
|
|
((string=? type "audit")
|
|
|
|
|
@ -1005,7 +1010,7 @@
|
|
|
|
|
(player (add-player-to-game game
|
|
|
|
|
color
|
|
|
|
|
(alist-ref 'playerName msg))))
|
|
|
|
|
(set! (game-colors game) (filter (cut neq? <> color) (game-colors game)))
|
|
|
|
|
(safe-set! (game-colors game) (filter (cut neq? <> color) (game-colors game)))
|
|
|
|
|
(session-set! (sid) 'player player)
|
|
|
|
|
(session-set! (sid) 'game game)
|
|
|
|
|
(set-startup-otbs game player 2)
|
|
|
|
|
@ -1055,8 +1060,8 @@
|
|
|
|
|
(alist-ref 'type msg)
|
|
|
|
|
msg)))
|
|
|
|
|
(when game
|
|
|
|
|
(set! (game-last-updated game) (+ (game-last-updated game) 1))
|
|
|
|
|
(set! (player-last-updated player) (game-last-updated game)))
|
|
|
|
|
(safe-set! (game-last-updated game) (+ (game-last-updated game) 1))
|
|
|
|
|
(safe-set! (player-last-updated player) (game-last-updated game)))
|
|
|
|
|
res)))))
|
|
|
|
|
(loop (read-json (receive-message)))))))
|
|
|
|
|
|
|
|
|
|
@ -1196,34 +1201,34 @@
|
|
|
|
|
(inexact->exact
|
|
|
|
|
(round (/ (exact->inexact amount) num-equipment))))))
|
|
|
|
|
(for-each (lambda (player)
|
|
|
|
|
(set! (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player)
|
|
|
|
|
(+ (player-cash player) amount-per-player)))
|
|
|
|
|
(players-with equipment game)))))
|
|
|
|
|
(push-message player (conc "You paid $" amount "!"))
|
|
|
|
|
(set! (player-cash player) (- (player-cash player) amount))))
|
|
|
|
|
(safe-set! (player-cash player) (- (player-cash player) amount))))
|
|
|
|
|
|
|
|
|
|
(define (make-player-gains amount)
|
|
|
|
|
(lambda (player)
|
|
|
|
|
(push-message player (conc "You gained $" amount "!"))
|
|
|
|
|
(set! (player-cash player) (+ (player-cash player) amount))))
|
|
|
|
|
(safe-set! (player-cash player) (+ (player-cash player) amount))))
|
|
|
|
|
|
|
|
|
|
(define (make-player-pays amount)
|
|
|
|
|
(lambda (player)
|
|
|
|
|
(push-message player (conc "You paid $" amount "!"))
|
|
|
|
|
(set! (player-cash player) (- (player-cash player) amount))))
|
|
|
|
|
(safe-set! (player-cash player) (- (player-cash player) amount))))
|
|
|
|
|
|
|
|
|
|
(define (make-player-pays-per-unit unit amount)
|
|
|
|
|
(lambda (player)
|
|
|
|
|
(let ((to-pay (* (player-asset (normalize-crop unit) player) amount)))
|
|
|
|
|
(push-message player (conc "You paid $" to-pay "!"))
|
|
|
|
|
(set! (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player)
|
|
|
|
|
(- (player-cash player) to-pay)))))
|
|
|
|
|
|
|
|
|
|
(define (make-player-gains-per-unit unit amount)
|
|
|
|
|
(lambda (player)
|
|
|
|
|
(let ((to-pay (* (player-asset (normalize-crop unit) player) amount)))
|
|
|
|
|
(push-message player (conc "You earned $" to-pay "!"))
|
|
|
|
|
(set! (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player)
|
|
|
|
|
(+ (player-cash player) to-pay)))))
|
|
|
|
|
|
|
|
|
|
(define (make-semi-annual-interest-due)
|
|
|
|
|
@ -1231,7 +1236,7 @@
|
|
|
|
|
(let ((to-pay (farming-round-down
|
|
|
|
|
(inexact->exact (round (* (player-debt player) 0.1))))))
|
|
|
|
|
(push-message player (conc "You paid $" to-pay "!"))
|
|
|
|
|
(set! (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player)
|
|
|
|
|
(- (player-cash player) to-pay)))))
|
|
|
|
|
|
|
|
|
|
(define (cows-on-ridges player)
|
|
|
|
|
@ -1243,11 +1248,11 @@
|
|
|
|
|
(define (make-remove-farmers-fate-from-hand id)
|
|
|
|
|
(lambda (player)
|
|
|
|
|
(let ((game (session-ref (sid) 'game)))
|
|
|
|
|
(set! (game-farmers-fates game)
|
|
|
|
|
(safe-set! (game-farmers-fates game)
|
|
|
|
|
(append (game-farmers-fates game)
|
|
|
|
|
(filter (lambda (x) (eq? (alist-ref 'internal-id x) id))
|
|
|
|
|
(player-farmers-fates player)))))
|
|
|
|
|
(set! (player-farmers-fates player)
|
|
|
|
|
(safe-set! (player-farmers-fates player)
|
|
|
|
|
(filter (lambda (x) (not (eq? (alist-ref 'internal-id x) id)))
|
|
|
|
|
(player-farmers-fates player)))))
|
|
|
|
|
|
|
|
|
|
@ -1360,7 +1365,7 @@
|
|
|
|
|
(with-ff-money-action (player game)
|
|
|
|
|
(let ((to-earn (* (player-acres player) 100)))
|
|
|
|
|
(push-message player (conc "You earned $" to-earn "!"))
|
|
|
|
|
(set! (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player)
|
|
|
|
|
(+ (player-cash player) to-earn)))))
|
|
|
|
|
#f)
|
|
|
|
|
(2 ,(lambda (player game)
|
|
|
|
|
@ -1382,9 +1387,9 @@
|
|
|
|
|
(for-each (lambda (from-player)
|
|
|
|
|
(when (not (eq? player from-player))
|
|
|
|
|
(when (not (player-has-asset? 'harvester from-player))
|
|
|
|
|
(set! (player-cash from-player)
|
|
|
|
|
(safe-set! (player-cash from-player)
|
|
|
|
|
(- (player-cash from-player) 2000))
|
|
|
|
|
(set! (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player)
|
|
|
|
|
(+ (player-cash player) 2000)))))
|
|
|
|
|
(game-players (session-ref (sid) 'game))))
|
|
|
|
|
'()))
|
|
|
|
|
@ -1438,7 +1443,7 @@
|
|
|
|
|
(let ((slaughtered-cows (- cows ridge-cows)))
|
|
|
|
|
(push-message player (conc slaughtered-cows
|
|
|
|
|
" cows slaughtered on your farm."))
|
|
|
|
|
(set! (player-assets player)
|
|
|
|
|
(safe-set! (player-assets player)
|
|
|
|
|
(alist-update 'cows (- (alist-ref 'cows (player-assets player)) (- cows ridge-cows))
|
|
|
|
|
(player-assets player)))
|
|
|
|
|
`(((?action . info)
|
|
|
|
|
@ -1487,7 +1492,7 @@
|
|
|
|
|
`((2 ,(lambda (player)
|
|
|
|
|
(let ((to-pay (* (player-acres player) 100)))
|
|
|
|
|
(push-message player (conc "You paid $" to-pay "!"))
|
|
|
|
|
(set! (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player)
|
|
|
|
|
(- (player-cash player) to-pay)))))
|
|
|
|
|
(2 ,(lambda (player)
|
|
|
|
|
(equipment-payout 'harvester player 2000 (session-ref (sid) 'game))))
|
|
|
|
|
@ -1506,7 +1511,7 @@
|
|
|
|
|
(1 ,(lambda (player)
|
|
|
|
|
(when (player-has-asset? 'cows player)
|
|
|
|
|
(push-message player "You paid $500!")
|
|
|
|
|
(set! (player-cash player) (- (player-cash player) 500)))))
|
|
|
|
|
(safe-set! (player-cash player) (- (player-cash player) 500)))))
|
|
|
|
|
(1 ,(make-player-pays 1500))))
|
|
|
|
|
|
|
|
|
|
(define (setup-operating-expenses)
|
|
|
|
|
@ -1521,8 +1526,8 @@
|
|
|
|
|
(let ((card (list-ref (game-operating-expenses game)
|
|
|
|
|
(game-operating-expense-index game))))
|
|
|
|
|
(if (= (+ (game-operating-expense-index game) 1) *total-operating-expenses*)
|
|
|
|
|
(set! (game-operating-expense-index game) 0)
|
|
|
|
|
(set! (game-operating-expense-index game)
|
|
|
|
|
(safe-set! (game-operating-expense-index game) 0)
|
|
|
|
|
(safe-set! (game-operating-expense-index game)
|
|
|
|
|
(+ (game-operating-expense-index game) 1)))
|
|
|
|
|
card))
|
|
|
|
|
|
|
|
|
|
@ -1693,8 +1698,8 @@
|
|
|
|
|
(if (null? (game-otbs game))
|
|
|
|
|
#f
|
|
|
|
|
(receive (new-otb remaining-otbs) (split-at (game-otbs game) 1)
|
|
|
|
|
(set! (player-otbs player) (cons (car new-otb) (player-otbs player)))
|
|
|
|
|
(set! (game-otbs game) remaining-otbs)
|
|
|
|
|
(safe-set! (player-otbs player) (cons (car new-otb) (player-otbs player)))
|
|
|
|
|
(safe-set! (game-otbs game) remaining-otbs)
|
|
|
|
|
(car new-otb))))
|
|
|
|
|
|
|
|
|
|
(define (do-action action player)
|
|
|
|
|
@ -1704,17 +1709,17 @@
|
|
|
|
|
(let ((changed ((alist-ref '?value action) 0)))
|
|
|
|
|
(push-message player (conc "You " (if (>= changed 0) "earned" "paid") " $"
|
|
|
|
|
(abs changed) "!")))
|
|
|
|
|
(set! (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player)
|
|
|
|
|
((alist-ref '?value action) (player-cash player))))
|
|
|
|
|
((eq? a 'add-rule)
|
|
|
|
|
(when (not (member (alist-ref 'id (alist-ref '?value action))
|
|
|
|
|
(map (lambda (x) (alist-ref 'id x))
|
|
|
|
|
(player-year-rules player))))
|
|
|
|
|
(set! (player-year-rules player)
|
|
|
|
|
(safe-set! (player-year-rules player)
|
|
|
|
|
(cons (alist-ref '?value action) (player-year-rules player)))))
|
|
|
|
|
((eq? a 'goto)
|
|
|
|
|
(set! (player-previous-space player) (player-space player))
|
|
|
|
|
(set! (player-space player)
|
|
|
|
|
(safe-set! (player-previous-space player) (player-space player))
|
|
|
|
|
(safe-set! (player-space player)
|
|
|
|
|
(let ((month (alist-ref '?value action)))
|
|
|
|
|
(list-index (lambda (x) (eq? x month)) *months*))))
|
|
|
|
|
((and (eq? a 'draw) (eq? (alist-ref '?value action) 'otb))
|
|
|
|
|
@ -1727,14 +1732,14 @@
|
|
|
|
|
(push-message player (conc "Farmers Fate: " (alist-ref 'text (car new-ff))))
|
|
|
|
|
(if (alist-ref 'hold-card (car new-ff))
|
|
|
|
|
(begin (push! (car new-ff) (player-farmers-fates player))
|
|
|
|
|
(set! (game-farmers-fates game) remaining-ffs))
|
|
|
|
|
(set! (game-farmers-fates game) (append remaining-ffs new-ff)))
|
|
|
|
|
(safe-set! (game-farmers-fates game) remaining-ffs))
|
|
|
|
|
(safe-set! (game-farmers-fates game) (append remaining-ffs new-ff)))
|
|
|
|
|
`((actions . ,((alist-ref 'action (car new-ff)) player game))
|
|
|
|
|
(contents . ,(alist-ref 'contents (car new-ff)))))))
|
|
|
|
|
((or (eq? a 'player-action) (eq? a 'player-action-post-harvest))
|
|
|
|
|
((alist-ref '?value action) player))
|
|
|
|
|
((eq? a 'harvest-mult)
|
|
|
|
|
(set! (player-harvest-mult player)
|
|
|
|
|
(safe-set! (player-harvest-mult player)
|
|
|
|
|
(* (player-harvest-mult player) (alist-ref '?value action))))
|
|
|
|
|
((eq? a 'harvest)
|
|
|
|
|
(let* ((crop (normalize-crop (alist-ref '?value action)))
|
|
|
|
|
@ -1749,9 +1754,9 @@
|
|
|
|
|
(player-harvest-mult player)))))
|
|
|
|
|
(if (not (already-harvested? (alist-ref '?value action) player))
|
|
|
|
|
(begin
|
|
|
|
|
(set! (player-cash player)
|
|
|
|
|
(safe-set! (player-cash player)
|
|
|
|
|
(+ (player-cash player) income))
|
|
|
|
|
(set! (player-harvest-mult player) 1)
|
|
|
|
|
(safe-set! (player-harvest-mult player) 1)
|
|
|
|
|
(let ((operating-expense (draw-operating-expense game))
|
|
|
|
|
(previous-cash (player-cash player))
|
|
|
|
|
(other-previous-cash (map (lambda (p)
|
|
|
|
|
@ -1789,11 +1794,11 @@
|
|
|
|
|
(lambda (x)
|
|
|
|
|
(do-action x player)
|
|
|
|
|
(if (eq? (alist-ref '?action x) 'goto)
|
|
|
|
|
(begin (set! (player-harvest-mult player) 1)
|
|
|
|
|
(begin (safe-set! (player-harvest-mult player) 1)
|
|
|
|
|
(do-all-actions player))))
|
|
|
|
|
(let ((r (sort-actions (get-actions player (player-space player)))))
|
|
|
|
|
(set! *last-actions* r)
|
|
|
|
|
(set! (player-harvest-mult player) 1)
|
|
|
|
|
(safe-set! (player-harvest-mult player) 1)
|
|
|
|
|
r)))
|
|
|
|
|
|
|
|
|
|
(define (sort-actions actions)
|
|
|
|
|
|
