Changing from coops to define-record.

src/server/farm.scm

@@ -18,7 +18,7 @@
 ;;; <https://www.gnu.org/licenses/>.
 
 (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 <player> ()
-  ((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-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-class <ai> (<player>)
-  ((processing-turn initform: #f accessor: ai-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-class <game> ()
-  ((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 (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 <app> ()
-  ((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 <game>
+    (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 <app>
+  (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 <game>))
+  (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 <player>))
+              (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) <player>)
+  (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) <player>)
+  (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) <ai> <player>)
+  (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 <app>))
+(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 <player>
+  (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 <ai>
+  (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 <player>))
+(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 <ai>))
-  `((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 <ai>)) #t)
-(define-method (ai-player? (p <player>)) #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 <game> '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