tjhintz
/
farm
1
0
Fork 0
Code Issues 7 Pull Requests Packages Projects Releases Wiki Activity

Adding safe-set!.

Browse Source
logins
Thomas Hintz 5 years ago
parent c8e9ea1842
commit 29171875f4
1 changed files with 133 additions and 128 deletions
Show Stats Download Patch File Download Diff File

261
src/server/farm.scm
Unescape Escape View File

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

Write Preview
Loading…
Cancel
Save