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

Using dynamic *game* variable and initial AI support.

Browse Source
logins
Thomas Hintz 5 years ago
parent 829bb5feea
commit f485f811ba
1 changed files with 154 additions and 53 deletions
Show Stats Download Patch File Download Diff File

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

@ -54,6 +54,8 @@
(lambda () (lambda ()
(SRV:send-reply (pre-post-order* sxml rules))))))) (SRV:send-reply (pre-post-order* sxml rules)))))))
(define *game* (make-parameter #f))
(define-syntax safe-set! (define-syntax safe-set!
(ir-macro-transformer (ir-macro-transformer
(lambda (x i c) (lambda (x i c)
@ -97,6 +99,9 @@
(hay-doubled initform: #f accessor: player-hay-doubled) (hay-doubled initform: #f accessor: player-hay-doubled)
(corn-doubled initform: #f accessor: player-corn-doubled))) (corn-doubled initform: #f accessor: player-corn-doubled)))
(define-class <ai> (<player>)
((processing-turn initform: #f accessor: ai-processing-turn)))
(define-class <game> () (define-class <game> ()
((id initform: 0 accessor: game-id) ((id initform: 0 accessor: game-id)
(players initform: '() accessor: game-players) (players initform: '() accessor: game-players)
@ -319,6 +324,20 @@
(safe-set! (game-current-player game) player)) (safe-set! (game-current-player game) player))
player)) player))
(define (add-ai-to-game game color name)
(let ((player (make <ai>
'cash 10000
'display-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))))
(safe-set! (game-players game) (append (game-players game) (list player)))
(when (= (length (game-players game)) 1)
(safe-set! (game-current-player game) player))
player))
(define (all-players-finished game) (define (all-players-finished game)
(null? (filter (lambda (p) (null? (filter (lambda (p)
(not (player-finished p))) (not (player-finished p)))
@ -399,7 +418,25 @@
;; (print "</body></html>"))) ;; (print "</body></html>")))
) )
(define (player->list p) (define-method (player->list (p <player>))
`((player . ((assets . ,(player-assets p))
(ridges . ,(player-ridges p))
(cash . ,(player-cash p))
(displayCash . ,(player-display-cash p))
(debt . ,(player-debt p))
(space . ,(player-space p))
(state . ,(symbol->string (player-state p)))
(cards . ,(list->vector (append (player-farmers-fates p)
(player-otbs p))))
(color . ,(symbol->string (player-color p)))
(name . ,(player-name p))
(trade . ,(player-trade p))
(lastCash . ,(player-last-cash p))
(hayDoubled . ,(player-hay-doubled p))
(cornDoubled . ,(player-corn-doubled p))
(ai . #f)))))
(define-method (player->list (p <ai>))
`((player . ((assets . ,(player-assets p)) `((player . ((assets . ,(player-assets p))
(ridges . ,(player-ridges p)) (ridges . ,(player-ridges p))
(cash . ,(player-cash p)) (cash . ,(player-cash p))
@ -414,7 +451,11 @@
(trade . ,(player-trade p)) (trade . ,(player-trade p))
(lastCash . ,(player-last-cash p)) (lastCash . ,(player-last-cash p))
(hayDoubled . ,(player-hay-doubled p)) (hayDoubled . ,(player-hay-doubled p))
(cornDoubled . ,(player-corn-doubled p)))))) (cornDoubled . ,(player-corn-doubled p))
(ai . #t)))))
(define-method (ai-player? (p <ai>)) #t)
(define-method (ai-player? (p <player>)) #f)
(define (game->list g player) (define (game->list g player)
`((game . ((messages . ,(list->vector (reverse (game-messages g)))) `((game . ((messages . ,(list->vector (reverse (game-messages g))))
@ -435,9 +476,6 @@
(auditThreshold . ,(game-setting 'audit-threshold g)) (auditThreshold . ,(game-setting 'audit-threshold g))
(trade . ,(game-setting 'trade g)))))))) (trade . ,(game-setting 'trade g))))))))
(define (push-message player msg #!key (game (session-ref (sid) 'game)))
(void))
(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
'((hay . 2000) (grain . 2000) '((hay . 2000) (grain . 2000)
@ -484,13 +522,11 @@
`((id . ,id) (rule . ,rule))) `((id . ,id) (rule . ,rule)))
(define (finish-year player #!optional (collect-wages #t)) (define (finish-year player #!optional (collect-wages #t))
(let ((game (session-ref (sid) 'game))) (let ((game (*game*)))
(when collect-wages (when collect-wages
(safe-set! (player-cash player) (safe-set! (player-cash player)
(+ (player-cash player) 5000)) (+ (player-cash player) 5000))
(safe-set! (player-display-cash player) (player-cash player)) (safe-set! (player-display-cash player) (player-cash player))
(push-message player
(conc "You earned $5,000 from your city job!"))
(safe-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!"))
@ -733,10 +769,7 @@
(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)) (begin (safe-set! (game-called-audit game) player))))
" already called audit!"))
(begin (safe-set! (game-called-audit game) player)
(push-message player (conc (player-name player) " has called an audit!")))))
(define (player-net-worth player) (define (player-net-worth player)
(+ (* (+ (player-asset 'hay player) (player-asset 'grain player)) 2000) (+ (* (+ (player-asset 'hay player) (player-asset 'grain player)) 2000)
@ -764,7 +797,7 @@
(define (create-ws-response player event misc) (define (create-ws-response player event misc)
(append `((event . ,event) ,@misc) (append `((event . ,event) ,@misc)
(player->list player) (player->list player)
(game->list (session-ref (sid) 'game) player))) (game->list (*game*) player)))
(define (create-start-response event) (define (create-start-response event)
`((event . ,event) `((event . ,event)
@ -824,7 +857,6 @@
(safe-set! (player-space player) (safe-set! (player-space player)
(+ (player-space player) num)) (+ (player-space player) num))
(safe-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) (when (> (player-space player) 48)
(safe-set! (player-space player) (safe-set! (player-space player)
(- (player-space player) 49))) (- (player-space player) 49)))
@ -999,6 +1031,15 @@
(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)))))))))
((and (string=? type "next-action")
(ai-player? (game-current-player game)))
(print "ai next action trigger")
(print (player-name (game-current-player game)))
(message-players! game player '() type: "ai-next-action")
(create-ws-response player "update" `()))
((string=? type "end-ai-turn")
(message-players! game player '() type: "end-ai-turn")
(create-ws-response player "update" `()))
((string=? type "skip") ((string=? type "skip")
(when (and (player-harvesting player) (string=? (alist-ref 'component msg) "harvest|income")) (when (and (player-harvesting player) (string=? (alist-ref 'component msg) "harvest|income"))
;; player-harvesting will contain the operating expense amount ;; player-harvesting will contain the operating expense amount
@ -1061,8 +1102,7 @@
(farming-round (farming-round
(+ amount (* amount (game-setting 'loan-interest game)))))))) (+ amount (* amount (game-setting 'loan-interest game))))))))
;; repaying loan ;; repaying loan
(cond ((> (abs amount) (player-cash player)) (cond ((> (abs amount) (player-cash player)))
(push-message player "Not enough cash to repay loan."))
(else (else
(safe-set! (player-cash player) (+ (player-cash player) amount)) (safe-set! (player-cash player) (+ (player-cash player) amount))
(safe-set! (player-display-cash player) (player-cash player)) (safe-set! (player-display-cash player) (player-cash player))
@ -1071,9 +1111,7 @@
(safe-set! (player-cash player) (+ (player-cash player) (safe-set! (player-cash player) (+ (player-cash player)
(abs (player-debt player)))) (abs (player-debt player))))
(safe-set! (player-display-cash player) (player-cash player)) (safe-set! (player-display-cash player) (player-cash player))
(safe-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" '())) (create-ws-response player "loan" '()))
((string=? type "trade") ((string=? type "trade")
(let ((res (propose-trade game player (alist-ref 'parameters msg)))) (let ((res (propose-trade game player (alist-ref 'parameters msg))))
@ -1088,8 +1126,6 @@
(message-players! game player '() type: "update") (message-players! game player '() type: "update")
(create-ws-response player "trade-accepted" '())) (create-ws-response player "trade-accepted" '()))
((string=? type "trade-deny") ((string=? type "trade-deny")
(push-message player (conc (player-name player) " denied trade with "
(alist-ref 'originator (player-trade player)) "."))
(safe-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))))
'()) '())
@ -1097,8 +1133,6 @@
(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 "
(alist-ref 'player (player-trade player)) "."))
(safe-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))))
'()) '())
@ -1129,8 +1163,7 @@
(do-end-of-game game) (do-end-of-game game)
(message-players! game player '() type: "update")) (message-players! game player '() type: "update"))
(create-ws-response player "update" '())) (create-ws-response player "update" '()))
(begin (push-message player "Cannot end a turn with negative cash!") (begin (create-ws-response player "update" '()))))
(create-ws-response player "update" '()))))
;;;;;;;;;;;;;;;;;;;;; start ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;; start ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
((string=? type "main-init") ((string=? type "main-init")
(create-start-response "start-init")) (create-start-response "start-init"))
@ -1156,11 +1189,15 @@
(trade . ,(or (alist-ref 'trade msg) #t))))) (trade . ,(or (alist-ref 'trade msg) #t)))))
(player (add-player-to-game game (player (add-player-to-game game
color color
(alist-ref 'playerName msg)))) (alist-ref 'playerName msg)))
(ai-player (add-ai-to-game game 'red "AI Player 1")))
(push! game (app-games *app*)) (push! game (app-games *app*))
(session-set! (sid) 'player player) (session-set! (sid) 'player player)
(session-set! (sid) 'game game) (session-set! (sid) 'game game)
(*game* game)
(set-startup-otbs game player 2) (set-startup-otbs game player 2)
(set-startup-otbs game ai-player 2)
(thread-start! (make-ai-push-receiver game ai-player))
(create-start-response "new-game-started"))) (create-start-response "new-game-started")))
((string=? type "join-game") ((string=? type "join-game")
(let* ((name (alist-ref 'gameName msg)) (let* ((name (alist-ref 'gameName msg))
@ -1177,6 +1214,7 @@
(safe-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)
(*game* game)
(set-startup-otbs game player 2) (set-startup-otbs game player 2)
(message-players! game player '() type: "update") (message-players! game player '() type: "update")
(create-start-response "new-game-started"))) (create-start-response "new-game-started")))
@ -1190,9 +1228,63 @@
(game-players game)))) (game-players game))))
(session-set! (sid) 'player player) (session-set! (sid) 'player player)
(session-set! (sid) 'game game) (session-set! (sid) 'game game)
(*game* game)
(create-start-response "new-game-started"))) (create-start-response "new-game-started")))
)) ))
(define (process-ai-push-message player game msg)
(print (player-name player))
(print msg)
(case (string->symbol (alist-ref 'type msg))
((update)
(if (and (eq? (player-state player) 'pre-turn)
(not (ai-processing-turn player)))
(begin (set! (ai-processing-turn player) #t)
(let ((res (process-message player game "roll" '((type . "roll")))))
(print "rolled a " (alist-ref 'value res))
;; (process-message player game "next-action" '((type . "next-action")))
;; (let loop ((msg (process-message player game "next-action" '((type . "next-action")))))
;; (if (alist-ref 'action msg)
;; (loop (process-message player game "next-action" '((type . "next-action"))))
;; (print "done with actions")))
))))
((auto-skip)
(print "ai auto-skip")
;; (when (ai-processing-turn player)
;; (process-message player game "next-action" '((type . "next-action"))))
)
((ai-next-action)
(print "ai-next-action")
(when (ai-processing-turn player)
(let ((res (process-message player game "next-action" '((type . "next-action")))))
(display "res: ")
(write res)
(newline)
;; (print "res1: " (eq? (alist-ref 'event res) 'action))
;; (print "res2: " (not (alist-ref 'action res)))
;; (print "res3: " (and (eq? (alist-ref 'event res) 'action)
;; (not (alist-ref 'action res))))
;; (when (and (string=? (alist-ref 'event res) "action")
;; (not (alist-ref 'action res)))
;; (print "ending turn")
;; (thread-sleep! 0.5)
;; (set! (ai-processing-turn player) #f)
;; (process-message player game "turn-ended" '()))
)))
((end-ai-turn)
(when (ai-processing-turn player)
(print "ending turn")
(thread-sleep! 0.5)
(set! (ai-processing-turn player) #f)
(process-message player game "turn-ended" '())
))))
(define (make-ai-push-receiver game player)
(lambda ()
(let loop ((msg (mailbox-receive! (player-mailbox player))))
(process-ai-push-message player game msg)
(loop (mailbox-receive! (player-mailbox player))))))
(define (websocket-page) (define (websocket-page)
(sid (read-cookie (session-cookie-name))) (sid (read-cookie (session-cookie-name)))
;; TODO some kind of error handling if (sid) #f ;; TODO some kind of error handling if (sid) #f
@ -1236,6 +1328,7 @@
(lambda () (lambda ()
(let ((game (session-ref (sid) 'game)) (let ((game (session-ref (sid) 'game))
(player (session-ref (sid) 'player))) (player (session-ref (sid) 'player)))
(*game* game)
(let loop ((msg (mailbox-receive! (player-mailbox player)))) (let loop ((msg (mailbox-receive! (player-mailbox player))))
(print msg) (print msg)
(when (not game) (when (not game)
@ -1368,17 +1461,14 @@
(safe-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 "!"))
(safe-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 "!"))
(safe-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 "!"))
(safe-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)
@ -1408,7 +1498,7 @@
(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 (*game*)))
(safe-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))
@ -1479,7 +1569,7 @@
(if (odd? roll) (if (odd? roll)
((make-player-pays (* (player-acres p) 100)) p)))) ((make-player-pays (* (player-acres p) 100)) p))))
(filter (lambda (x) (not (eq? x player))) (filter (lambda (x) (not (eq? x player)))
(game-players (session-ref (sid) 'game)))) (game-players (*game*))))
((make-player-gains-per-unit 'hay 500) player))) ((make-player-gains-per-unit 'hay 500) player)))
#f) #f)
(1 ,(lambda (player game) (1 ,(lambda (player game)
@ -1539,7 +1629,7 @@
#f) #f)
(2 ,(lambda (player game) (2 ,(lambda (player game)
(with-ff-money-action (player game) (with-ff-money-action (player game)
(equipment-payout 'tractor player 3000 (session-ref (sid) 'game)))) (equipment-payout 'tractor player 3000 (*game*))))
#f) #f)
(1 ,(lambda (player game) (1 ,(lambda (player game)
(if (player-has-asset? 'harvester player) (if (player-has-asset? 'harvester player)
@ -1551,7 +1641,7 @@
(- (player-cash from-player) 2000)) (- (player-cash from-player) 2000))
(safe-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 (*game*))))
'())) '()))
#f) #f)
(1 ,(lambda (player game) (1 ,(lambda (player game)
@ -1565,7 +1655,7 @@
(1 ,(lambda (player game) (1 ,(lambda (player game)
(with-ff-money-action (player game) (with-ff-money-action (player game)
(equipment-payout 'harvester player 2500 (equipment-payout 'harvester player 2500
(session-ref (sid) 'game)))) (*game*))))
#f) #f)
(1 ,(lambda (player game) (1 ,(lambda (player game)
(push! (make-player-year-rule 6 `((?p cows harvest-mult 1.5) (?p cows))) (push! (make-player-year-rule 6 `((?p cows harvest-mult 1.5) (?p cows)))
@ -1601,8 +1691,6 @@
(ridge-cows (cows-on-ridges player))) (ridge-cows (cows-on-ridges player)))
(if (> cows ridge-cows) (if (> cows ridge-cows)
(let ((slaughtered-cows (- cows ridge-cows))) (let ((slaughtered-cows (- cows ridge-cows)))
(push-message player (conc slaughtered-cows
" cows slaughtered on your farm."))
(safe-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)))
@ -1654,9 +1742,9 @@
(safe-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 (*game*))))
(2 ,(lambda (player) (2 ,(lambda (player)
(equipment-payout 'tractor player 2000 (session-ref (sid) 'game)))) (equipment-payout 'tractor player 2000 (*game*))))
(1 ,(make-player-pays-per-unit 'cows 100)) (1 ,(make-player-pays-per-unit 'cows 100))
(2 ,(make-player-pays 500)) (2 ,(make-player-pays 500))
(1 ,(make-player-pays 1500)) (1 ,(make-player-pays 1500))
@ -1869,11 +1957,8 @@
(define (do-action action player) (define (do-action action player)
(let ((a (alist-ref '?action action)) (let ((a (alist-ref '?action action))
(game (session-ref (sid) 'game))) (game (*game*)))
(cond ((eq? a 'money) (cond ((eq? a 'money)
(let ((changed ((alist-ref '?value action) 0)))
(push-message player (conc "You " (if (>= changed 0) "earned" "paid") " $"
(abs changed) "!")))
(safe-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)
@ -1888,19 +1973,17 @@
(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))
(if (not (null? (game-otbs (session-ref (sid) 'game)))) (if (not (null? (game-otbs game)))
(draw-otb player (session-ref (sid) 'game)) (draw-otb player game)
#f)) #f))
((and (eq? a 'draw) (eq? (alist-ref '?value action) 'farmers-fate)) ((and (eq? a 'draw) (eq? (alist-ref '?value action) 'farmers-fate))
(let ((game (session-ref (sid) 'game)))
(receive (new-ff remaining-ffs) (split-at (game-farmers-fates game) 1) (receive (new-ff remaining-ffs) (split-at (game-farmers-fates game) 1)
(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))
(safe-set! (game-farmers-fates game) remaining-ffs)) (safe-set! (game-farmers-fates game) remaining-ffs))
(safe-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)
@ -2050,3 +2133,21 @@
;; farm.scm:1129: print-call-chain <-- ;; farm.scm:1129: print-call-chain <--
;; Error: (assv) bad argument type: ridge-cows ;; Error: (assv) bad argument type: ridge-cows
;; proposed trade to wrong player
;; accidentally clicking no for uncle bert
;; farmers fate 2nd week of january
;; error:
;; Call history:
;; farm.scm:129: alist-ref
;; farm.scm:1213: k7426
;; farm.scm:1213: g7430
;; farm.scm:1215: with-output-to-string
;; farm.scm:1217: print-call-chain <--
;; Error: (assv) bad argument type: #<coops instance of `<game>'>
;; auto-skip loop wtih harvest
;; when getting trade the name is wrong

Write Preview
Loading…
Cancel
Save