Adding multiplayer info bar, game settings, cleaning up loans.
This commit is contained in:
@@ -91,11 +91,21 @@
|
||||
(colors initform: '() accessor: game-colors)
|
||||
(last-updated initform: 0 accessor: game-last-updated)
|
||||
(called-audit initform: #f accessor: game-called-audit)
|
||||
(audit-threshold initform: 250000 accessor: game-audit-threshold)
|
||||
(state initform: 'playing accessor: game-state)
|
||||
(name initform: "game" accessor: game-name)
|
||||
(turn initform: 1 accessor: game-turn)
|
||||
(actions initform: '() accessor: game-actions)))
|
||||
(actions initform: '() accessor: game-actions)
|
||||
(settings initform:
|
||||
'((down-payment . 0.2)
|
||||
(loan-interest . 0.2)
|
||||
(max-debt . 50000)
|
||||
(audit-threshold . 250000)
|
||||
(starting-cash . 5000)
|
||||
(starting-debt . 5000))
|
||||
accessor: game-settings)))
|
||||
|
||||
(define (game-setting setting game)
|
||||
(alist-ref setting (game-settings game)))
|
||||
|
||||
(define-class <app> ()
|
||||
((games initform: '() accessor: app-games)
|
||||
@@ -205,10 +215,13 @@
|
||||
color))
|
||||
|
||||
(define (add-player-to-game game color name)
|
||||
(let ((player (make <player> 'cash 5000 'color color
|
||||
'name name
|
||||
'state (if (= (length (game-players game)) 0)
|
||||
'pre-turn 'turn-ended))))
|
||||
(let ((player (make <player>
|
||||
'cash (game-setting 'starting-cash game)
|
||||
'debt (game-setting 'starting-debt game)
|
||||
'color color
|
||||
'name name
|
||||
'state (if (= (length (game-players game)) 0)
|
||||
'pre-turn 'turn-ended))))
|
||||
(set! (game-players game) (append (game-players game) (list player)))
|
||||
player))
|
||||
|
||||
@@ -322,9 +335,12 @@
|
||||
(calledAudit . ,(if (game-called-audit g)
|
||||
(player-name (game-called-audit g))
|
||||
#f))
|
||||
(auditThreshold . ,(game-audit-threshold g))
|
||||
(state . ,(symbol->string (game-state g)))
|
||||
(turn . ,(game-turn g))))))
|
||||
(turn . ,(game-turn g))
|
||||
(settings . ((downPayment . ,(game-setting 'down-payment g))
|
||||
(loanInterest . ,(game-setting 'loan-interest g))
|
||||
(maxDebt . ,(game-setting 'max-debt g))
|
||||
(auditThreshold . ,(game-setting 'audit-threshold g))))))))
|
||||
|
||||
(define (push-message player msg #!key (game (session-ref (sid) 'game)))
|
||||
(if player
|
||||
@@ -361,11 +377,11 @@
|
||||
((> cash-value (player-cash player))
|
||||
(push-message player (conc "Could not buy " unnormalized-crop ". Not enough cash."))
|
||||
#f)
|
||||
((< cash-value (* total-cost 0.2))
|
||||
((< cash-value (* total-cost (game-setting 'down-payment game)))
|
||||
(push-message player
|
||||
(conc "Could not buy " unnormalized-crop ". Not enough down payment."))
|
||||
#f)
|
||||
((> (- total-cost cash-value) (- 50000 (player-debt player)))
|
||||
((> (- total-cost cash-value) (- (game-setting 'max-debt game) (player-debt player)))
|
||||
(push-message player
|
||||
(conc "Could not buy " unnormalized-crop ". Not enough credit."))
|
||||
#f)
|
||||
@@ -611,16 +627,19 @@
|
||||
(* (player-debt player) -1)))
|
||||
|
||||
(define (do-end-of-game game)
|
||||
(push-message #f "Game over!")
|
||||
(for-each (lambda (p i)
|
||||
(push-message #f
|
||||
(conc i ". " (player-name p) " with $"
|
||||
(player-net-worth p))))
|
||||
(sort (game-players game)
|
||||
(lambda (p1 p2)
|
||||
(> (player-net-worth p1)
|
||||
(player-net-worth p2))))
|
||||
(iota (length (game-players game)) 1)))
|
||||
(message-players!
|
||||
game
|
||||
#f
|
||||
`((results
|
||||
. ,(list->vector
|
||||
(map (lambda (p i)
|
||||
(conc i ". " (player-name p) " with $" (player-net-worth p)))
|
||||
(sort (game-players game)
|
||||
(lambda (p1 p2)
|
||||
(> (player-net-worth p1)
|
||||
(player-net-worth p2))))
|
||||
(iota (length (game-players game)) 1)))))
|
||||
type: "end-of-game"))
|
||||
|
||||
(define (create-ws-response player event misc)
|
||||
(append `((event . ,event) ,@misc)
|
||||
@@ -646,6 +665,26 @@
|
||||
|
||||
(define *next-roll* #f)
|
||||
|
||||
(define (->number x default)
|
||||
(if (number? x)
|
||||
x
|
||||
(if (string? x)
|
||||
(or (string->number x)
|
||||
default)
|
||||
default)))
|
||||
|
||||
(define (->pct x default)
|
||||
(let ((n (->number x default)))
|
||||
(if (or (> n 1) (< n 0))
|
||||
default
|
||||
n)))
|
||||
|
||||
(define (->i x default)
|
||||
(let ((n (inexact->exact (floor (->number x default)))))
|
||||
(if (< n 0)
|
||||
default
|
||||
(- n (modulo n 1000)))))
|
||||
|
||||
(define (process-message player game type msg)
|
||||
(when game
|
||||
(set! (game-messages game) '())
|
||||
@@ -842,19 +881,25 @@
|
||||
(let ((amount (* (alist-ref 'amount msg) 1000)))
|
||||
(if (> amount 0)
|
||||
;; taking out loan
|
||||
(if (> (+ (player-debt player) amount) 50000)
|
||||
(if (> (+ (player-debt player)
|
||||
(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) amount))
|
||||
(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."))))
|
||||
;; repaying loan
|
||||
(cond ((> amount (player-cash player))
|
||||
(cond ((> (abs amount) (player-cash player))
|
||||
(push-message player "Not enough cash to repay loan."))
|
||||
((> amount (player-debt player))
|
||||
(push-message player "Repayment exceeds total loan amount."))
|
||||
(else
|
||||
(set! (player-cash player) (+ (player-cash player) amount))
|
||||
(set! (player-debt player) (+ (player-debt player) amount))
|
||||
(when (< (player-debt player) 0)
|
||||
(set! (player-cash player) (+ (player-cash player)
|
||||
(abs (player-debt player))))
|
||||
(set! (player-debt player) 0))
|
||||
(push-message player (conc "Loan of $" (abs amount) " repayed."))))
|
||||
))
|
||||
(create-ws-response player "loan" '()))
|
||||
@@ -908,7 +953,17 @@
|
||||
'id (next-game-id *app*)
|
||||
'otbs (setup-otbs)
|
||||
'operating-expenses (setup-operating-expenses)
|
||||
'farmers-fates (setup-farmers-fates)))
|
||||
'farmers-fates (setup-farmers-fates)
|
||||
'settings
|
||||
`((down-payment . ,(->pct (alist-ref 'downPayment msg) 0.2))
|
||||
(loan-interest . ,(->pct (alist-ref 'loanInterest msg) 0.2))
|
||||
(max-debt . ,(->i (alist-ref 'maxDebt msg) 50000))
|
||||
(audit-threshold . ,(->i (alist-ref 'auditThreshold msg)
|
||||
250000))
|
||||
(starting-cash . ,(->i (alist-ref 'startingCash msg)
|
||||
5000))
|
||||
(starting-debt . ,(->i (alist-ref 'startingDebt msg)
|
||||
5000)))))
|
||||
(player (add-player-to-game game
|
||||
color
|
||||
(alist-ref 'playerName msg))))
|
||||
@@ -930,6 +985,7 @@
|
||||
(session-set! (sid) 'player player)
|
||||
(session-set! (sid) 'game game)
|
||||
(set-startup-otbs game player 2)
|
||||
(message-players! game player '() type: "update")
|
||||
(create-start-response "new-game-started")))
|
||||
((string=? type "join-as-existing")
|
||||
(let* ((name (alist-ref 'gameName msg))
|
||||
@@ -993,29 +1049,29 @@
|
||||
(set! game (session-ref (sid) 'game)))
|
||||
(when (not player)
|
||||
(set! player (session-ref (sid) 'player)))
|
||||
(when (< (player-last-updated player)
|
||||
(game-last-updated game))
|
||||
(handle-exceptions
|
||||
exn
|
||||
(send-message
|
||||
(json->string
|
||||
;; when (< (player-last-updated player)
|
||||
;; (game-last-updated game))
|
||||
(handle-exceptions
|
||||
exn
|
||||
(send-message
|
||||
(json->string
|
||||
`((exn . ,(with-output-to-string
|
||||
(lambda ()
|
||||
(print-call-chain)
|
||||
(print-error-message exn)))))))
|
||||
(send-message
|
||||
(json->string
|
||||
(handle-exceptions
|
||||
exn
|
||||
`((exn . ,(with-output-to-string
|
||||
(lambda ()
|
||||
(print-call-chain)
|
||||
(print-error-message exn)))))))
|
||||
(send-message
|
||||
(json->string
|
||||
(handle-exceptions
|
||||
exn
|
||||
`((exn . ,(with-output-to-string
|
||||
(lambda ()
|
||||
(print-call-chain)
|
||||
(print-error-message exn))))
|
||||
(event . "error"))
|
||||
(create-ws-response player
|
||||
(alist-ref 'type msg)
|
||||
(alist-ref 'value msg))
|
||||
)))))
|
||||
(print-error-message exn))))
|
||||
(event . "error"))
|
||||
(create-ws-response player
|
||||
(alist-ref 'type msg)
|
||||
(alist-ref 'value msg))
|
||||
))))
|
||||
(loop (mailbox-receive! (player-mailbox player))))))))
|
||||
|
||||
(define (otb-spec->otb-cards spec id)
|
||||
|
||||
Reference in New Issue
Block a user