From 48b178327b5914e3a475a4c57319ff514f527827 Mon Sep 17 00:00:00 2001 From: Thomas Hintz Date: Mon, 27 Apr 2020 21:06:43 -0700 Subject: [PATCH] Changing from coops to define-record. --- src/server/farm.scm | 301 +++++++++++++++++++++++++------------------- 1 file changed, 169 insertions(+), 132 deletions(-) diff --git a/src/server/farm.scm b/src/server/farm.scm index f89e32d..0ba7961 100644 --- a/src/server/farm.scm +++ b/src/server/farm.scm @@ -18,7 +18,7 @@ ;;; . (import chicken scheme srfi-1 data-structures) -(use http-session srfi-69 coops coops-utils uri-common +(use http-session srfi-69 uri-common srfi-18 medea numbers spiffy spiffy-cookies intarweb pll sxml-transforms websockets miscmacros mailbox) @@ -96,88 +96,149 @@ (lambda () (set! (,(first (second x)) obj) res)) (lambda () (mutex-unlock! mutex)))))))) -(define-class () - ((cash initform: 5000 accessor: player-cash) - (display-cash initform: 5000 accessor: player-display-cash) - (debt initform: 5000 accessor: player-debt) - (space initform: 0 accessor: player-space) - (previous-space initform: 0 accessor: player-previous-space) - (state initform: 'turn-ended accessor: player-state) - (finished initform: #f accessor: player-finished) - (assets initform: - '((hay . 10) (grain . 10) (fruit . 0) (cows . 0) - (harvester . 0) (tractor . 0) - (birthday . 0)) - accessor: player-assets) - (ridges initform: - '((ridge1 . 0) (ridge2 . 0) (ridge3 . 0) (ridge4 . 0)) - accessor: player-ridges) - (harvest-mult initform: 1 accessor: player-harvest-mult) - (otbs initform: '() accessor: player-otbs) - (farmers-fates initform: '() accessor: player-farmers-fates) - (revealed-cards initform: '() accessor: player-revealed-cards) - (year-rules initform: '() accessor: player-year-rules) - (next-year-rules initform: '() accessor: player-next-year-rules) - (color initform: #f accessor: player-color) - (name initform: "PLAYER X" accessor: player-name) - (user-id initform: -1 accessor: player-user-id) - (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) - (mutex initform: (make-mutex 'player) accessor: player-mutex) - (harvesting initform: #f accessor: player-harvesting) - (hay-doubled initform: #f accessor: player-hay-doubled) - (corn-doubled initform: #f accessor: player-corn-doubled) - (ready-to-start initform: #f accessor: player-ready-to-start) - (stats initform: - '((pro . 0) - (back . 0) - (tax-person . 0) - (emergency . 0) - (num-harvests . 0) - (harvest-rolls . 0)) - accessor: player-stats))) - -(define-class () - ((processing-turn initform: #f accessor: ai-processing-turn))) - -(define-class () - ((id initform: 0 accessor: game-id) - (players initform: '() accessor: game-players) - (messages initform: '() accessor: game-messages) - (otbs initform: '() accessor: game-otbs) - (used-otbs initform: '() accessor: game-used-otbs) - (farmers-fates initform: '() accessor: game-farmers-fates) - (operating-expenses initform: '() accessor: game-operating-expenses) - (operating-expense-index initform: 0 accessor: game-operating-expense-index) - (colors initform: '() accessor: game-colors) - (last-updated initform: 0 accessor: game-last-updated) - (called-audit initform: #f accessor: game-called-audit) - (state initform: 'pre-game accessor: game-state) - (name initform: "game" accessor: game-name) - (turn initform: 1 accessor: game-turn) - (current-player initform: #f accessor: game-current-player) - (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) - (trade . #t) - (starting-otbs . 2)) - accessor: game-settings) - (mutex initform: (make-mutex 'game) accessor: game-mutex))) +(define-record player + (setter cash) + (setter display-cash) + (setter debt) + (setter space) + (setter previous-space) + (setter state) + (setter finished) + (setter assets) + (setter ridges) + (setter harvest-mult) + (setter otbs) + (setter farmers-fates) + (setter revealed-cards) + (setter year-rules) + (setter next-year-rules) + (setter color) + (setter name) + (setter user-id) + (setter trade) + (setter last-updated) + (setter last-cash) + (setter mailbox) + (setter mutex) + (setter harvesting) + (setter hay-doubled) + (setter corn-doubled) + (setter ready-to-start) + (setter stats) + (setter ai?) + (setter processing-turn)) + +(define (build-arg-list args) + (letrec ((build-alist (lambda (args out) + (if (null? args) + out + (build-alist (cddr args) (cons (cons (car args) (cadr args)) out)))))) + (build-alist args '()))) + +(define (make-player* #!rest args) + (let ((args (build-arg-list args))) + (make-player + (alist-ref 'cash args eqv? 5000) + (alist-ref 'display-cash args eqv? 5000) + (alist-ref 'debt args eqv? 5000) + (alist-ref 'space args eqv? 0) + (alist-ref 'previous-space args eqv? 0) + (alist-ref 'state args eqv? 'turn-ended) + (alist-ref 'finished args eqv? #f) + (alist-ref 'assets args eqv? '((hay . 10) (grain . 10) (fruit . 0) (cows . 0) + (harvester . 0) (tractor . 0) + (birthday . 0))) + (alist-ref 'ridges args eqv? '((ridge1 . 0) (ridge2 . 0) (ridge3 . 0) (ridge4 . 0))) + (alist-ref 'harvest-mult args eqv? 1) + (alist-ref 'otbs args eqv? '()) + (alist-ref 'farmers-fates args eqv? '()) + (alist-ref 'revealed-cards args eqv? '()) + (alist-ref 'year-rules args eqv? '()) + (alist-ref 'next-year-rules args eqv? '()) + (alist-ref 'color args eqv? #f) + (alist-ref 'name args eqv? "PLAYER X") + (alist-ref 'user-id args eqv? -1) + (alist-ref 'trade args eqv? '()) + (alist-ref 'last-updated args eqv? 0) + (alist-ref 'last-cash args eqv? 5000) + (alist-ref 'mailbox args eqv? (make-mailbox)) + (alist-ref 'mutex args eqv? (make-mutex 'player)) + (alist-ref 'harvesting args eqv? #f) + (alist-ref 'hay-doubled args eqv? #f) + (alist-ref 'corn-doubled args eqv? #f) + (alist-ref 'ready-to-start args eqv? #f) + (alist-ref 'stats args eqv? '((pro . 0) + (back . 0) + (tax-person . 0) + (emergency . 0) + (num-harvests . 0) + (harvest-rolls . 0))) + (alist-ref 'ai? args eqv? #f) + (alist-ref 'processing-turn args eqv? #f)))) + +(define-record game + (setter id) + (setter players) + (setter messages) + (setter otbs) + (setter used-otbs) + (setter farmers-fates) + (setter operating-expenses) + (setter operating-expense-index) + (setter colors) + (setter last-updated) + (setter called-audit) + (setter state) + (setter name) + (setter turn) + (setter current-player) + (setter actions) + (setter settings) + (setter mutex)) + +(define (make-game* #!rest args) + (let ((args (build-arg-list args))) + (make-game + (alist-ref 'id args eqv? 0) + (alist-ref 'players args eqv? '()) + (alist-ref 'messages args eqv? '()) + (alist-ref 'otbs args eqv? '()) + (alist-ref 'used-otbs args eqv? '()) + (alist-ref 'farmers-fates args eqv? '()) + (alist-ref 'operating-expenses args eqv? '()) + (alist-ref 'operating-expense-index args eqv? 0) + (alist-ref 'colors args eqv? '()) + (alist-ref 'last-updated args eqv? 0) + (alist-ref 'called-audit args eqv? #f) + (alist-ref 'state args eqv? 'pre-game) + (alist-ref 'name args eqv? "game") + (alist-ref 'turn args eqv? 1) + (alist-ref 'current-player args eqv? #f) + (alist-ref 'actions args eqv? '()) + (alist-ref 'settings args eqv? '((down-payment . 0.2) + (loan-interest . 0.2) + (max-debt . 50000) + (audit-threshold . 250000) + (starting-cash . 5000) + (starting-debt . 5000) + (trade . #t) + (starting-otbs . 2))) + (alist-ref 'mutex args eqv? (make-mutex 'game))))) (define (game-setting setting game) (alist-ref setting (game-settings game))) -(define-class () - ((games initform: '() accessor: app-games) - (last-game-id initform: 0 accessor: app-last-game-id) - (mutex initform: (make-mutex 'app) accessor: app-mutex))) +(define-record app + (setter games) + (setter last-game-id) + (setter mutex)) + +(define (make-app* #!rest args) + (let ((args (build-arg-list args))) + (make-app + (alist-ref 'games args eqv? '()) + (alist-ref 'last-game-id args eqv? 0) + (alist-ref 'mutex args eqv? (make-mutex 'app))))) (define (player->sexp player) `((cash . ,(inexact->exact (round (player-cash player)))) @@ -203,7 +264,7 @@ (hay-doubled . ,(player-hay-doubled player)) (corn-doubled . ,(player-corn-doubled player)) (stats . ,(player-stats player)) - (ai . ,(ai-player? player)))) + (ai . ,(player-ai? player)))) (define (game->sexp g) `((id . ,(game-id g)) @@ -227,7 +288,7 @@ (define (sexp->game x) (let ((players (map sexp->player (alist-ref 'players x)))) - (apply make + (apply make-game* 'players players 'farmers-fates (let ((ffs (alist-ref 'farmers-fates x))) (list-copy @@ -257,19 +318,19 @@ (last-game-id . ,(app-last-game-id a)))) (define (sexp->app x) - (make + (make-app* 'games (map sexp->game (alist-ref 'games x)) 'last-game-id (alist-ref 'last-game-id x))) (define (validate-game g) - (assert (instance-of? g )) + (assert (game? g)) (assert (number? (game-id g))) (assert (list? (game-players g))) (for-each (lambda (p) (when (not (= (player-cash p) (player-display-cash p))) (print "display cash out-of-sync") (safe-set! (player-display-cash p) (player-cash p))) - (assert (instance-of? p )) + (assert (player? p)) (assert (number? (player-cash p))) (assert (number? (player-display-cash p))) (assert (= (player-cash p) (player-display-cash p))) @@ -301,12 +362,12 @@ (assert (list? (game-operating-expenses g))) (assert (number? (game-operating-expense-index g))) (assert (list? (game-colors g))) - (assert (or (instance-of? (game-called-audit g) ) + (assert (or (player? (game-called-audit g)) (boolean? (game-called-audit g)))) (assert (symbol? (game-state g))) ;; TODO test all symbols (assert (string? (game-name g))) (assert (number? (game-turn g))) - (assert (or (instance-of? (game-current-player g) ) + (assert (or (player? (game-current-player g)) (boolean? (game-current-player g)))) (assert (list? (game-settings g)))) @@ -321,12 +382,13 @@ (set! *app* (sexp->app (read)))))) (define (sexp->player x) - (let ((p (apply make (if (alist-ref 'ai x) ) + (let ((p (apply make-player* 'farmers-fates (let ((ffs (alist-ref 'farmers-fates x))) (list-copy (filter (lambda (card) (member (alist-ref 'id card) ffs)) *farmers-fates-cards*))) + 'ai? (alist-ref 'ai x) (fold (lambda (k r) (cons k (cons (alist-ref k x) r))) '() '(cash debt space previous-space state assets ridges @@ -342,7 +404,7 @@ (sort (map (lambda (x) (cons (random 100) x)) l) (lambda (x y) (< (car x) (car y)))))) -(define *app* (make )) +(define *app* (make-app*)) (define (next-game-id app) (safe-set! (app-last-game-id app) (+ (app-last-game-id app) 1)) @@ -410,7 +472,7 @@ color)) (define (add-player-to-game game color name user-id) - (let ((player (make + (let ((player (make-player* 'cash (game-setting 'starting-cash game) 'display-cash (game-setting 'starting-cash game) 'debt (game-setting 'starting-debt game) @@ -425,7 +487,8 @@ player)) (define (add-ai-to-game game color name) - (let ((player (make + (let ((player (make-player* + 'ai? #t 'cash (game-setting 'starting-cash game) 'display-cash (game-setting 'starting-cash game) 'debt (game-setting 'starting-debt game) @@ -529,7 +592,7 @@ (safe-set! (game-current-player game) first-player) (message-players! game #f '() type: "update")) -(define-method (player->list (p )) +(define (player->list p) `((player . ((assets . ,(player-assets p)) (ridges . ,(player-ridges p)) (cash . ,(player-cash p)) @@ -547,30 +610,7 @@ (lastCash . ,(player-last-cash p)) (hayDoubled . ,(player-hay-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)))) - (revealedCards . ,(list->vector (player-revealed-cards p))) - (color . ,(symbol->string (player-color p))) - (name . ,(player-name p)) - (user-id . ,(player-user-id 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) + (ai . ,(player-ai? p)))))) (define (game->list g player) `((game . ((messages . ,(list->vector (reverse (game-messages g)))) @@ -1050,7 +1090,7 @@ (let ((db-game (sexp->game (db-fetch-game id)))) (push! db-game (app-games *app*)) (for-each (lambda (p) - (when (ai-player? p) + (when (player-ai? p) (thread-start! (make-ai-push-receiver db-game p)))) (game-players db-game)) db-game)))) @@ -1268,12 +1308,12 @@ (else ;; TODO make error (create-ws-response player "action" `((action . ,name))))))))) ((and (string=? type "next-action") - (ai-player? (game-current-player game))) + (player-ai? (game-current-player game))) (print "ai next action trigger") (message-players! game player '() type: "ai-next-action") (create-ws-response player "update" `())) ((and (string=? type "buy-uncle-bert") - (ai-player? (game-current-player game))) + (player-ai? (game-current-player game))) (print "ai uncle bert trigger") (message-players! game player '() type: "ai-uncle-bert") (create-ws-response player "update" `())) @@ -1424,8 +1464,9 @@ ((string=? type "new-game") (let* ((color (string->symbol (alist-ref 'checkedColor msg))) (user (fetch-user-by-id (session-ref (sid) 'user-id))) - (game (make 'colors (filter (cut neq? <> color) - '(green red blue yellow black)) + (game (make-game* + 'colors (filter (cut neq? <> color) + '(green red blue yellow black)) 'name (alist-ref 'gameName msg) 'id (next-game-id *app*) 'otbs (setup-otbs) @@ -1449,9 +1490,7 @@ (player (add-player-to-game game color (alist-ref 'username user) - (alist-ref 'id user))) - ;; (ai-player (add-ai-to-game game 'red "AI Player 1")) - ) + (alist-ref 'id user)))) (push! game (app-games *app*)) (let ((gid (db-add-game "pre-game" (game->sexp game)))) (safe-set! (game-id game) gid) @@ -1461,8 +1500,6 @@ (*game* game) (*player* player) (set-startup-otbs game player (alist-ref 'starting-otbs (game-settings game))) - ;; (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* ((user (fetch-user-by-id (session-ref (sid) 'user-id))) @@ -1488,7 +1525,7 @@ ((string=? type "add-ai-player") (let* ((user (fetch-user-by-id (session-ref (sid) 'user-id))) (name (conc "AI Player " - (+ 1 (length (filter ai-player? (game-players game)))))) + (+ 1 (length (filter player-ai? (game-players game)))))) (game (*game*)) (color (car (game-colors game))) (player (add-ai-to-game game @@ -1657,8 +1694,8 @@ (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) + (not (player-processing-turn player))) + (begin (set! (player-processing-turn player) #t) ;; time to buy (when (and (>= (player-space player) 9) (<= (player-space player) 14)) (let loop ((cont (ai-buy player game))) @@ -1669,7 +1706,7 @@ (print "ai auto-skip")) ((ai-next-action) (print "ai-next-action") - (when (ai-processing-turn player) + (when (player-processing-turn player) (let ((res (process-message player game "next-action" '((type . "next-action"))))) res ;; (display "res: ") @@ -1678,7 +1715,7 @@ ))) ((ai-uncle-bert) (print "ai-uncle-bert") - (when (ai-processing-turn player) + (when (player-processing-turn player) (safe-set! (player-debt player) (+ (player-debt player) 10000)) (safe-set! (player-assets player) (alist-update 'hay (+ (alist-ref 'hay (player-assets player)) 10) @@ -1686,7 +1723,7 @@ ((end-ai-turn) (if (eq? (player-state player) 'pre-turn) (process-ai-push-message player game '((type . "update"))) ;; restarting at AI player's turn - (if (ai-processing-turn player) + (if (player-processing-turn player) (begin (when (< (player-cash player) 0) (print "taking out loan") @@ -1701,7 +1738,7 @@ -1))))) (print "ending turn") ;; (thread-sleep! 0.5) - (set! (ai-processing-turn player) #f) + (set! (player-processing-turn player) #f) (process-message player game "turn-ended" '())) ;; this could happen if we restart the game in the middle of a turn ;; so lets just force the next turn