tjhintz
/
farm
1
0
Fork 0
Code Issues 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/>.
(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)
(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))
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)
(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))
accessor: player-stats)))
(define-class <ai> (<player>)
((processing-turn initform: #f accessor: ai-processing-turn)))
(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)
(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))
accessor: game-settings)
(mutex initform: (make-mutex 'game) accessor: game-mutex)))
(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,27 +592,7 @@
(safe-set! (game-current-player game) first-player)
(message-players! game #f '() type: "update"))
(define-method (player->list (p <player>))
`((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>))
(define (player->list p)
`((player . ((assets . ,(player-assets p))
(ridges . ,(player-ridges p))
(cash . ,(player-cash p))
@ -567,10 +610,7 @@
(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,7 +1464,8 @@
((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)
(game (make-game*
'colors (filter (cut neq? <> color)
'(green red blue yellow black))
'name (alist-ref 'gameName msg)
'id (next-game-id *app*)
@ -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

Write Preview
Loading…
Cancel
Save