Adding safe-set!.

logins
Thomas Hintz 5 years ago
parent c8e9ea1842
commit 29171875f4

@ -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)

Loading…
Cancel
Save