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