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

Changing from coops to define-record.

Browse Source
master
Thomas Hintz 5 years ago
parent fbc8706893
commit 48b178327b
1 changed files with 169 additions and 132 deletions
Show Stats Download Patch File Download Diff File

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

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

Write Preview
Loading…
Cancel
Save