From f485f811ba327fa80448a4cc371b4d44b7416bb0 Mon Sep 17 00:00:00 2001 From: Thomas Hintz Date: Mon, 6 Apr 2020 08:18:45 -0700 Subject: [PATCH] Using dynamic *game* variable and initial AI support. --- src/server/farm.scm | 207 ++++++++++++++++++++++++++++++++------------ 1 file changed, 154 insertions(+), 53 deletions(-) diff --git a/src/server/farm.scm b/src/server/farm.scm index b60a99d..a321f78 100644 --- a/src/server/farm.scm +++ b/src/server/farm.scm @@ -54,6 +54,8 @@ (lambda () (SRV:send-reply (pre-post-order* sxml rules))))))) +(define *game* (make-parameter #f)) + (define-syntax safe-set! (ir-macro-transformer (lambda (x i c) @@ -97,6 +99,9 @@ (hay-doubled initform: #f accessor: player-hay-doubled) (corn-doubled initform: #f accessor: player-corn-doubled))) +(define-class () + ((processing-turn initform: #f accessor: ai-processing-turn))) + (define-class () ((id initform: 0 accessor: game-id) (players initform: '() accessor: game-players) @@ -319,6 +324,20 @@ (safe-set! (game-current-player game) player)) player)) +(define (add-ai-to-game game color name) + (let ((player (make + '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) (null? (filter (lambda (p) (not (player-finished p))) @@ -399,7 +418,7 @@ ;; (print ""))) ) -(define (player->list p) +(define-method (player->list (p )) `((player . ((assets . ,(player-assets p)) (ridges . ,(player-ridges p)) (cash . ,(player-cash p)) @@ -414,7 +433,29 @@ (trade . ,(player-trade p)) (lastCash . ,(player-last-cash p)) (hayDoubled . ,(player-hay-doubled p)) - (cornDoubled . ,(player-corn-doubled p)))))) + (cornDoubled . ,(player-corn-doubled p)) + (ai . #f))))) + +(define-method (player->list (p )) + `((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 . #t))))) + +(define-method (ai-player? (p )) #t) +(define-method (ai-player? (p )) #f) (define (game->list g player) `((game . ((messages . ,(list->vector (reverse (game-messages g)))) @@ -435,9 +476,6 @@ (auditThreshold . ,(game-setting 'audit-threshold 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) (let ((total-cost (* amount (alist-ref unnormalized-crop '((hay . 2000) (grain . 2000) @@ -484,13 +522,11 @@ `((id . ,id) (rule . ,rule))) (define (finish-year player #!optional (collect-wages #t)) - (let ((game (session-ref (sid) 'game))) + (let ((game (*game*))) (when collect-wages (safe-set! (player-cash player) (+ (player-cash player) 5000)) (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) (cons '((?action . info) (?value . "You earned $5,000 from your city job!")) @@ -733,10 +769,7 @@ (define (call-audit game player) (if (game-called-audit game) - (push-message player (conc (player-name (game-called-audit game)) - " already called audit!")) - (begin (safe-set! (game-called-audit game) player) - (push-message player (conc (player-name player) " has called an audit!"))))) + (begin (safe-set! (game-called-audit game) player)))) (define (player-net-worth player) (+ (* (+ (player-asset 'hay player) (player-asset 'grain player)) 2000) @@ -764,7 +797,7 @@ (define (create-ws-response player event misc) (append `((event . ,event) ,@misc) (player->list player) - (game->list (session-ref (sid) 'game) player))) + (game->list (*game*) player))) (define (create-start-response event) `((event . ,event) @@ -824,7 +857,6 @@ (safe-set! (player-space player) (+ (player-space player) num)) (safe-set! (player-state player) 'mid-turn) - (push-message player (conc "You rolled a " num)) (when (> (player-space player) 48) (safe-set! (player-space player) (- (player-space player) 49))) @@ -999,6 +1031,15 @@ (loop (+ i 1))) (else ;; TODO make error (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") (when (and (player-harvesting player) (string=? (alist-ref 'component msg) "harvest|income")) ;; player-harvesting will contain the operating expense amount @@ -1061,8 +1102,7 @@ (farming-round (+ amount (* amount (game-setting 'loan-interest game)))))))) ;; repaying loan - (cond ((> (abs amount) (player-cash player)) - (push-message player "Not enough cash to repay loan.")) + (cond ((> (abs amount) (player-cash player))) (else (safe-set! (player-cash player) (+ (player-cash player) amount)) (safe-set! (player-display-cash player) (player-cash player)) @@ -1071,9 +1111,7 @@ (safe-set! (player-cash player) (+ (player-cash player) (abs (player-debt player)))) (safe-set! (player-display-cash player) (player-cash player)) - (safe-set! (player-debt player) 0)) - (push-message player (conc "Loan of $" (abs amount) " repayed.")))) - )) + (safe-set! (player-debt player) 0)))))) (create-ws-response player "loan" '())) ((string=? type "trade") (let ((res (propose-trade game player (alist-ref 'parameters msg)))) @@ -1088,8 +1126,6 @@ (message-players! game player '() type: "update") (create-ws-response player "trade-accepted" '())) ((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 game (alist-ref 'originator (player-trade player)))) '()) @@ -1097,8 +1133,6 @@ (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)) ".")) (safe-set! (player-trade (find-player-by-name game (alist-ref 'player (player-trade player)))) '()) @@ -1129,8 +1163,7 @@ (do-end-of-game game) (message-players! game player '() type: "update")) (create-ws-response player "update" '())) - (begin (push-message player "Cannot end a turn with negative cash!") - (create-ws-response player "update" '())))) + (begin (create-ws-response player "update" '())))) ;;;;;;;;;;;;;;;;;;;;; start ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ((string=? type "main-init") (create-start-response "start-init")) @@ -1156,11 +1189,15 @@ (trade . ,(or (alist-ref 'trade msg) #t))))) (player (add-player-to-game game 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*)) (session-set! (sid) 'player player) (session-set! (sid) 'game game) + (*game* game) (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"))) ((string=? type "join-game") (let* ((name (alist-ref 'gameName msg)) @@ -1177,6 +1214,7 @@ (safe-set! (game-colors game) (filter (cut neq? <> color) (game-colors game))) (session-set! (sid) 'player player) (session-set! (sid) 'game game) + (*game* game) (set-startup-otbs game player 2) (message-players! game player '() type: "update") (create-start-response "new-game-started"))) @@ -1190,9 +1228,63 @@ (game-players game)))) (session-set! (sid) 'player player) (session-set! (sid) 'game game) + (*game* game) (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) (sid (read-cookie (session-cookie-name))) ;; TODO some kind of error handling if (sid) #f @@ -1236,6 +1328,7 @@ (lambda () (let ((game (session-ref (sid) 'game)) (player (session-ref (sid) 'player))) + (*game* game) (let loop ((msg (mailbox-receive! (player-mailbox player)))) (print msg) (when (not game) @@ -1368,17 +1461,14 @@ (safe-set! (player-cash player) (+ (player-cash player) amount-per-player))) (players-with equipment game))))) - (push-message player (conc "You paid $" amount "!")) (safe-set! (player-cash player) (- (player-cash player) amount)))) (define (make-player-gains amount) (lambda (player) - (push-message player (conc "You gained $" amount "!")) (safe-set! (player-cash player) (+ (player-cash player) amount)))) (define (make-player-pays amount) (lambda (player) - (push-message player (conc "You paid $" amount "!")) (safe-set! (player-cash player) (- (player-cash player) amount)))) (define (make-player-pays-per-unit unit amount) @@ -1408,7 +1498,7 @@ (define (make-remove-farmers-fate-from-hand id) (lambda (player) - (let ((game (session-ref (sid) 'game))) + (let ((game (*game*))) (safe-set! (game-farmers-fates game) (append (game-farmers-fates game) (filter (lambda (x) (eq? (alist-ref 'internal-id x) id)) @@ -1479,7 +1569,7 @@ (if (odd? roll) ((make-player-pays (* (player-acres p) 100)) p)))) (filter (lambda (x) (not (eq? x player))) - (game-players (session-ref (sid) 'game)))) + (game-players (*game*)))) ((make-player-gains-per-unit 'hay 500) player))) #f) (1 ,(lambda (player game) @@ -1539,7 +1629,7 @@ #f) (2 ,(lambda (player game) (with-ff-money-action (player game) - (equipment-payout 'tractor player 3000 (session-ref (sid) 'game)))) + (equipment-payout 'tractor player 3000 (*game*)))) #f) (1 ,(lambda (player game) (if (player-has-asset? 'harvester player) @@ -1551,7 +1641,7 @@ (- (player-cash from-player) 2000)) (safe-set! (player-cash player) (+ (player-cash player) 2000))))) - (game-players (session-ref (sid) 'game)))) + (game-players (*game*)))) '())) #f) (1 ,(lambda (player game) @@ -1565,7 +1655,7 @@ (1 ,(lambda (player game) (with-ff-money-action (player game) (equipment-payout 'harvester player 2500 - (session-ref (sid) 'game)))) + (*game*)))) #f) (1 ,(lambda (player game) (push! (make-player-year-rule 6 `((?p cows harvest-mult 1.5) (?p cows))) @@ -1601,8 +1691,6 @@ (ridge-cows (cows-on-ridges player))) (if (> 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) (alist-update 'cows (- (alist-ref 'cows (player-assets player)) (- cows ridge-cows)) (player-assets player))) @@ -1654,9 +1742,9 @@ (safe-set! (player-cash player) (- (player-cash player) to-pay))))) (2 ,(lambda (player) - (equipment-payout 'harvester player 2000 (session-ref (sid) 'game)))) + (equipment-payout 'harvester player 2000 (*game*)))) (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)) (2 ,(make-player-pays 500)) (1 ,(make-player-pays 1500)) @@ -1869,11 +1957,8 @@ (define (do-action action player) (let ((a (alist-ref '?action action)) - (game (session-ref (sid) 'game))) + (game (*game*))) (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) ((alist-ref '?value action) (player-cash player)))) ((eq? a 'add-rule) @@ -1888,19 +1973,17 @@ (let ((month (alist-ref '?value action))) (list-index (lambda (x) (eq? x month)) *months*)))) ((and (eq? a 'draw) (eq? (alist-ref '?value action) 'otb)) - (if (not (null? (game-otbs (session-ref (sid) 'game)))) - (draw-otb player (session-ref (sid) 'game)) + (if (not (null? (game-otbs game))) + (draw-otb player game) #f)) ((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) - (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)) - (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))))))) + (receive (new-ff remaining-ffs) (split-at (game-farmers-fates game) 1) + (if (alist-ref 'hold-card (car new-ff)) + (begin (push! (car new-ff) (player-farmers-fates player)) + (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) @@ -2050,3 +2133,21 @@ ;; farm.scm:1129: print-call-chain <-- ;; 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: #'> + +;; auto-skip loop wtih harvest + +;; when getting trade the name is wrong