tjhintz
/
farm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
master
leave-game2
leave-game
logins
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'db47e5e6e9'
${ noResults }
farm/src/server/farm.scm

2588 lines
119 KiB
Scheme
Raw Blame History

;;; Copyright 2020 Thomas Hintz
;;;
;;; This file is part of the Alpha Centauri Farming project.
;;;
;;; The Alpha Centauri Farming project is free software: you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; The Alpha Centauri Farming project is distributed in the hope that
;;; it will be useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;; PURPOSE. See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with the Alpha Centauri Farming project. If not, see
;;; <https://www.gnu.org/licenses/>.
(import chicken scheme srfi-1 data-structures)
(use http-session srfi-69 coops coops-utils uri-common
srfi-18 medea numbers spiffy spiffy-cookies
intarweb pll sxml-transforms websockets miscmacros
mailbox)
(cond-expand
(geiser
(include "../../assets/game/acf/game"))
(else
(include "game")))
(include "db.scm")
(session-storage-initialize
(lambda ()
'no-op))
(session-storage-set!
(lambda (sid session-item)
(db-session-set! sid (session-item-bindings session-item))))
(define (expiration)
(+ (current-milliseconds)
(inexact->exact (floor (* (session-lifetime) 1000)))))
(session-storage-ref
(lambda (sid)
(let ((data (db-session-ref sid)))
(if data
(make-session-item (expiration) (remote-address) data #f)
(error "session not found")))
;; (make-session-item (+ (current-milliseconds) 100000000) (remote-address) `((user-id . ,(db-session-ref sid))) #f)
))
(session-storage-delete!
(lambda (sid)
(error "session storage delete not handled")))
(root-path "./")
(define (neq? a b) (not (eq? a b)))
;; by default medea puts an a procedure at the end of the list that
;; signals an error if no unparsers matched. we don't ever want an
;; error instead we will just print out as a string the unparseable
;; object.
(json-unparsers (drop-right (json-unparsers) 1))
(json-unparsers (append (json-unparsers)
(list (cons (constantly #t)
(lambda datum
(display #\")
(display datum)
(display #\"))))))
(define sxml->html*
(let ((rules `((literal *preorder* . ,(lambda (t b) b))
. ,universal-conversion-rules*)))
(lambda (sxml)
(with-output-to-string
(lambda ()
(SRV:send-reply (pre-post-order* sxml rules)))))))
(define *game* (make-parameter #f))
(define *player* (make-parameter #f))
(define-syntax safe-set!
(ir-macro-transformer
(lambda (x i c)
(let ((mutex-symbol (string->symbol (string-append (car (string-split (symbol->string (caadr x)) "-")) "-mutex"))))
`(let* ((obj ,(second (second x)))
(res ,(third x))
(mutex (,(i mutex-symbol) obj)))
(dynamic-wind
(lambda () (mutex-lock! mutex))
(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-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)
(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 (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 (player->sexp player)
`((cash . ,(inexact->exact (round (player-cash player))))
(debt . ,(inexact->exact (round (player-debt player))))
(space . ,(player-space player))
(previous-space . ,(player-previous-space player))
(state . ,(player-state player))
(finished . ,(player-finished player))
(assets . ,(player-assets player))
(ridges . ,(player-ridges player))
(harvest-mult . ,(player-harvest-mult player))
(otbs . ,(player-otbs player))
(farmers-fates . ,(map (cut alist-ref 'id <>) (player-farmers-fates player)))
(revealed-cards . ,(player-revealed-cards player))
(year-rules . ,(player-year-rules player))
(next-year-rules . ,(player-next-year-rules player))
(color . ,(player-color player))
(name . ,(player-name player))
(user-id . ,(player-user-id player))
(trade . ())
(last-updated . 0)
(last-cash . ,(player-cash player))
(hay-doubled . ,(player-hay-doubled player))
(corn-doubled . ,(player-corn-doubled player))
(stats . ,(player-stats player))
(ai . ,(ai-player? player))))
(define (game->sexp g)
`((id . ,(game-id g))
(players . ,(map player->sexp (game-players g)))
(otbs . ,(game-otbs g))
(used-otbs . ,(game-used-otbs g))
(farmers-fates . ,(map (cut alist-ref 'id <>) (game-farmers-fates g)))
(operating-expenses . ,(map (cut alist-ref 'id <>) (game-operating-expenses g)))
(operating-expense-index . ,(game-operating-expense-index g))
(colors . ,(game-colors g))
(last-updated . ,(game-last-updated g))
(called-audit . ,(if (game-called-audit g)
(player-name (game-called-audit g))
#f)) ;; reify player
(state . ,(game-state g))
(name . ,(game-name g))
(turn . ,(game-turn g))
(current-player . ,(player-name (game-current-player g))) ;; reify player
(settings . ,(game-settings g))))
(define (sexp->game x)
(let ((players (map sexp->player
(alist-ref 'players x))))
(apply make <game>
'players players
'farmers-fates (let ((ffs (alist-ref 'farmers-fates x)))
(list-copy
(filter (lambda (card)
(member (alist-ref 'id card) ffs))
*farmers-fates-cards*)))
'operating-expenses (let ((oes (alist-ref 'operating-expenses x)))
(list-copy
(filter (lambda (card)
(member (alist-ref 'id card) oes))
*operating-expense-cards*)))
'called-audit (if (alist-ref 'called-audit x)
(find (lambda (p)
(equal? (player-name p) (alist-ref 'called-audit x)))
players)
#f)
'current-player (find (lambda (p)
(equal? (player-name p) (alist-ref 'current-player x)))
players)
(fold (lambda (k r) (cons k (cons (alist-ref k x) r)))
'()
'(id otbs used-otbs operating-expense-index colors
last-updated state name turn settings)))))
(define (app->sexp a)
`((games . ,(map game->sexp (app-games a)))
(last-game-id . ,(app-last-game-id a))))
(define (sexp->app x)
(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 (number? (game-id g)))
(assert (list? (game-players g)))
(for-each (lambda (p)
(assert (instance-of? p <player>))
(assert (number? (player-cash p)))
(assert (number? (player-display-cash p)))
(assert (= (player-cash p) (player-display-cash p)))
(assert (number? (player-debt p)))
(assert (number? (player-space p)))
(assert (number? (player-previous-space p)))
(assert (symbol? (player-state p)))
(assert (member (player-state p) '(turn-ended pre-turn mid-turn)))
(assert (boolean? (player-finished p)))
(assert (list? (player-assets p))) ;; TODO test assets
(assert (list? (player-ridges p)))
(assert (number? (player-harvest-mult p)))
(assert (list? (player-otbs p)))
(assert (list? (player-farmers-fates p)))
(assert (list? (player-year-rules p)))
(assert (list? (player-next-year-rules p)))
(assert (symbol? (player-color p)))
(assert (string? (player-name p)))
(assert (number? (player-user-id p)))
(assert (list? (player-trade p)))
(assert (number? (player-last-cash p)))
(assert (boolean? (player-harvesting p)))
(assert (boolean? (player-hay-doubled p)))
(assert (boolean? (player-corn-doubled p))))
(game-players g))
(assert (list? (game-otbs g)))
(assert (list? (game-used-otbs g)))
(assert (list? (game-farmers-fates g)))
(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>)
(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>)
(boolean? (game-current-player g))))
(assert (list? (game-settings g))))
(define (save-game game)
(validate-game game)
(db-update-game (game-id game) (symbol->string (game-state game))
(game->sexp game)))
(define (load-app)
(with-input-from-file "/home/tjhintz/app.scm"
(lambda ()
(set! *app* (sexp->app (read))))))
(define (sexp->player x)
(let ((p (apply make (if (alist-ref 'ai x) <ai> <player>)
'farmers-fates (let ((ffs (alist-ref 'farmers-fates x)))
(list-copy
(filter (lambda (card)
(member (alist-ref 'id card) ffs))
*farmers-fates-cards*)))
(fold (lambda (k r) (cons k (cons (alist-ref k x) r)))
'()
'(cash debt space previous-space state assets ridges
harvest-mult otbs user-id revealed-cards
year-rules next-year-rules hay-doubled corn-doubled
color name trade last-updated last-cash stats)))))
(when (not (player-revealed-cards p))
(safe-set! (player-revealed-cards p) '()))
p))
(define (shuffle l)
(map cdr
(sort (map (lambda (x) (cons (random 100) x)) l)
(lambda (x y) (< (car x) (car y))))))
(define *app* (make <app>))
(define (next-game-id app)
(safe-set! (app-last-game-id app) (+ (app-last-game-id app) 1))
(- (app-last-game-id app) 1))
(define sid (make-parameter #f))
(define session-cookie-name (make-parameter "awful-cookie"))
(define session-cookie-setter (make-parameter
(lambda (sid)
(set-cookie! (session-cookie-name) sid))))
(session-lifetime (* 60 60 24 7 4))
;; (access-log (current-output-port))
(access-log "access.log")
(error-log "error.log")
(handle-not-found
(let ((old-handler (handle-not-found)))
(lambda (path)
(let ((path (uri->string (make-uri
path: (uri-path (request-uri (current-request)))))))
(cond ((string= path "/websocket/web-socket")
(websocket-page))
((string= path "/websocket/push-web-socket")
(push-websocket-page))
((string= path "/")
(main-page))
(else
(old-handler path)))))))
(handle-directory (handle-not-found))
;; (handle-file
;; (let ((old-handler (handle-file)))
;; (lambda (path)
;; (if (or (string= path "/index.html") (string= path "/")
;; (string= path ""))
;; (main-page)
;; (old-handler path)))))
;; (define (defpage path thunk) XXX
;; (define-page path
;; (lambda ()
;; (thunk))
;; headers: (with-output-to-string
;; (lambda () (waffle-sxml->html*
;; `((stylesheet (@ (path "normalize.css")))
;; (stylesheet (@ (path "foundation.min.css")))
;; (stylesheet (@ (path "stork.css")))
;; (meta (@ (http-equiv "Content-Type") (content "text/html")
;; (charset "utf-8")))))))
;; no-session: #t))
;; (widget
;; 'example
;; ``(div (@ (id "example")))
;; '())
;; (define *player* (make <player> 'cash 20000))
;; (define *game* (make <game> 'colors (shuffle '(green red blue yellow black))))
(define (next-game-color game)
(let ((color (car (game-colors game))))
(safe-set! (game-colors game) (cdr (game-colors game)))
color))
(define (add-player-to-game game color name user-id)
(let ((player (make <player>
'cash (game-setting 'starting-cash game)
'display-cash (game-setting 'starting-cash game)
'debt (game-setting 'starting-debt game)
'color color
'name name
'user-id user-id
'state (if (= (length (game-players game)) 0)
'pre-turn 'turn-ended))))
(safe-set! (game-players game) (append (game-players game) (list player)))
(when (= (length (game-players game)) 1)
(safe-set! (game-current-player game) player))
player))
(define (add-ai-to-game game color name)
(let ((player (make <ai>
'cash (game-setting 'starting-cash game)
'display-cash (game-setting 'starting-cash game)
'debt (game-setting 'starting-debt game)
'color color
'name name
'state (if (= (length (game-players game)) 0)
'pre-turn 'turn-ended))))
(safe-set! (game-players game) (append (game-players game) (list player)))
(when (= (length (game-players game)) 1)
(safe-set! (game-current-player game) player))
player))
(define (all-players-finished game)
(null? (filter (lambda (p)
(not (player-finished p)))
(game-players game))))
(define (next-player game)
(let ((tail (filter (lambda (p)
(not (player-finished p)))
(find-tail (cut eq? <> (game-current-player game))
(game-players game)))))
(if (or (null? tail) (null? (cdr tail)))
(car (filter (lambda (p)
(not (player-finished p)))
(game-players game)))
(car (cdr tail)))))
(define (advance-turn game player)
(if (all-players-finished game)
(safe-set! (game-state game) 'finished)
(let ((next (next-player game)))
(safe-set! (player-state player) 'turn-ended)
(safe-set! (player-state next) 'pre-turn)
(safe-set! (game-current-player game) next)
(safe-set! (game-turn game) (+ (game-turn game) 1)))))
(define (ridge-available? game ridge)
(let loop ((players (game-players game)))
(if (null? players)
#t
(if (> (alist-ref ridge (player-ridges (car players))) 0)
#f
(loop (cdr players))))))
(define (set-startup-otbs game player number)
;; pretty hacky...
(for-each
(lambda (x)
(receive (new-otb remaining-otbs) (split-at (game-otbs game) 1)
(safe-set! (player-otbs player) (cons (car new-otb) (player-otbs player)))
(safe-set! (game-otbs game) remaining-otbs)))
(iota number)))
(define (main-page)
(sid (read-cookie (session-cookie-name)))
(when (not (session-valid? (sid)))
(sid (session-create))
((session-cookie-setter) (sid))
;; (session-set! (sid) 'player (add-player-to-game *game*))
;; (session-set! (sid) 'game *game*)
;; (set-startup-otbs (session-ref (sid) 'player) 2)
)
(send-static-file "main.html")
;; (with-headers `((connection close)
;; (content-type text/html))
;; (lambda ()
;; (write-logged-response)))
;; (finish-response-body (current-response))
)
(define (start-game)
(send-static-file "start.html")
""
;; (with-output-to-string
;; (lambda ()
;; (print "<html><head>")
;; ;; (waffle-sxml->html*
;; ;; `((stylesheet (@ (path "normalize.css")))
;; ;; (stylesheet (@ (path "foundation.min.css")))
;; ;; (stylesheet (@ (path "stork.css")))
;; ;; (meta (@ (http-equiv "Content-Type") (content "text/html")
;; ;; (charset "utf-8")))))
;; (print "</head><body>")
;; ;; (waffle-sxml->html*
;; ;; `("start game"
;; ;; ;; (script (@ (language "javascript") (type "text/javascript")
;; ;; ;; (src "/res/js/all.js")))
;; ;; ))
;; (print "</body></html>")))
)
(define (restart-game game first-player)
(safe-set! (game-called-audit game) #f)
(safe-set! (game-state game) 'playing)
(for-each (lambda (p)
(safe-set! (player-finished p) #f)
(safe-set! (player-state p) 'turn-ended))
(game-players game))
(safe-set! (player-state first-player) 'pre-turn)
(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>))
`((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)
(define (game->list g player)
`((game . ((messages . ,(list->vector (reverse (game-messages g))))
(currentPlayer . ,(player-name (game-current-player g)))
(otherPlayers
. ,(list->vector
(map
player->list
(filter (lambda (x) (not (eq? x player))) (game-players g)))))
(calledAudit . ,(if (game-called-audit g)
(player-name (game-called-audit g))
#f))
(state . ,(symbol->string (game-state g)))
(turn . ,(game-turn g))
(name . ,(game-name g))
(settings . ((downPayment . ,(game-setting 'down-payment g))
(loanInterest . ,(game-setting 'loan-interest g))
(maxDebt . ,(game-setting 'max-debt g))
(auditThreshold . ,(game-setting 'audit-threshold g))
(startingOtbs . ,(game-setting 'starting-otbs g))
(startingCash . ,(game-setting 'starting-cash g))
(startingDebt . ,(game-setting 'starting-debt g))
(trade . ,(game-setting 'trade g))))
(readyToStart . ,(fold (lambda (p r)
(and (player-ready-to-start p) r))
#t
(game-players g)))
(host . ,(player-name (car (game-players g))))))))
(define (buy-crop crop unnormalized-crop amount cash-value player game)
(let ((total-cost (* amount (alist-ref unnormalized-crop
'((hay . 2000) (grain . 2000)
(fruit . 5000) (cows . 500)
(ridge-cows . 1000)
(tractor . 10000)
(harvester . 10000)
(ridge4 . 1000)
(ridge3 . 1000)
(ridge2 . 1000)
(ridge1 . 1000)))))
(ridges '(ridge1 ridge2 ridge3 ridge4)))
(cond ((and (member unnormalized-crop ridges)
(not (ridge-available? game unnormalized-crop)))
"Ridge already leased.")
((> (player-space player) 14)
"Crops may only be bought in winter.")
((> cash-value (player-cash player))
(conc "Could not buy " unnormalized-crop ". Not enough cash."))
((< cash-value (* total-cost (game-setting 'down-payment game)))
(conc "Could not buy " unnormalized-crop ". Not enough down payment."))
((> (- total-cost cash-value) (max 0 (- (game-setting 'max-debt game) (player-debt player))))
(conc "Could not buy " unnormalized-crop ". Not enough credit."))
((and (eq? unnormalized-crop 'cows)
(= (- (player-asset 'cows player)
(fold + 0 (map cdr (player-ridges player))))
20))
(conc "Could not buy " unnormalized-crop " because it would exceed maximum allowed on farm."))
(else
(let ((assets (player-assets player)))
(safe-set!
(player-assets player)
(alist-update crop (+ (alist-ref crop assets) amount) assets))
(safe-set! (player-cash player) (- (player-cash player) cash-value))
(safe-set! (player-display-cash player) (player-cash player))
(safe-set! (player-debt player)
(+ (player-debt player) (- total-cost cash-value)))
(when (member unnormalized-crop ridges)
(safe-set! (player-ridges player)
(alist-update unnormalized-crop amount (player-ridges player))))
#t)))))
(define (make-player-year-rule id rule)
`((id . ,id) (rule . ,rule)))
(define (finish-year player #!optional (collect-wages #t))
(let ((game (*game*)))
(when collect-wages
(let* ((richest (car (sort (game-players game)
(lambda (p1 p2)
(> (player-net-worth p1)
(player-net-worth p2))))))
;; (bonus (max (farming-round
;; (inexact->exact
;; (round
;; (* (- (player-net-worth richest)
;; (+ (player-net-worth player)
;; ;; don't give a bonus for emergency debt
;; (max 0 (- (player-debt player) (game-setting 'max-debt game)))))
;; 0.2))))
;; 2500))
(bonus 5000)
)
(safe-set! (player-cash player)
(+ (player-cash player) 5000)
;; (+ (player-cash player) bonus)
)
(safe-set! (player-display-cash player) (player-cash player))
(safe-set! (game-actions game)
(cons `((?action . info)
(?value . ,(conc "You earned $" bonus " from your city job!")))
(game-actions game)))))
(when (game-called-audit game)
(safe-set! (game-actions game)
(append (game-actions game)
`(((?action . end-game)
(?value . ,(lambda ()
(safe-set! (player-finished player) #t))))))))
(safe-set! (player-year-rules player) (player-next-year-rules player))
(safe-set! (player-next-year-rules player) '())
(safe-set! (player-hay-doubled player) #f)
(safe-set! (player-corn-doubled player) #f)
(when (not (null? (player-farmers-fates player)))
(safe-set! (game-farmers-fates game)
(append (game-farmers-fates game) (player-farmers-fates player)))
(safe-set! (player-farmers-fates player) '())
;; this is a really hacky way of getting F.F. calf weaning weights
;; to work for the second year.
(when (not (null? (player-year-rules player)))
(safe-set! (player-farmers-fates player)
(list (find (lambda (c) (eq? (alist-ref 'internal-id c) 'cows-15))
(game-farmers-fates game))))
(safe-set! (game-farmers-fates game)
(filter (lambda (c) (not (eq? (alist-ref 'internal-id c) 'cows-15)))
(game-farmers-fates game)))
(push! (make-player-year-rule
0
'((?p cows player-action-post-harvest
(remove-farmers-fate-from-hand cows-15))
(?p cows)))
(player-year-rules player))
(push! (make-player-year-rule
1
`((?d player-action ?p
(remove-farmers-fate-after cows-15 40))))
(player-year-rules player))))))
(define (find-player-by-name game name)
(find (lambda (p) (equal? (player-name p) name)) (game-players game)))
(define (validate-trade game player params)
(let* ((other-player (find-player-by-name game (alist-ref 'player params)))
(basics (fold (lambda (x r)
(or r
(if (< (+ (player-asset x player)
(alist-ref x params eqv? 0))
0)
x
#f)))
#f
'(hay grain fruit cows harvester tractor)))
(other-basics (fold (lambda (x r)
(or r
(if (< (+ (player-asset x other-player)
(* (alist-ref x params eqv? 0) -1)) 0)
x
#f)))
#f
'(hay grain fruit cows harvester tractor)))
(ridges (fold (lambda (x r)
(or r
(if (alist-ref x params)
(if (and (= (player-ridge player x) 0)
(= (player-ridge other-player x) 0))
x
#f)
#f)))
#f
'(ridge1 ridge2 ridge3 ridge4)))
(cards (map string->number (string-split (alist-ref 'cards params eqv? ""))))
(missing-cards (fold (lambda (id r)
(if (or (find (lambda (card)
(= (alist-ref 'id card eqv? -1) id))
(append (player-otbs player) (player-farmers-fates player)))
(find (lambda (card)
(= (alist-ref 'id card eqv? -1) id))
(append (player-otbs other-player) (player-farmers-fates other-player))))
r
(cons id r)))
'()
cards)))
(cond (basics
(conc "You don't have enough " basics " to trade!"))
(other-basics
(conc (player-name other-player)
" doesn't have enough " other-basics " to trade!"))
(ridges
(conc ridges " ridge not available to trade!"))
((< (+ (player-cash player) (alist-ref 'money params eqv? 0)) 0)
"You don't have enough cash to trade!")
((< (+ (player-cash other-player) (* (alist-ref 'money params eqv? 0) -1)) 0)
(conc (player-name other-player)
" doesn't have enough cash to trade!"))
((not (null? missing-cards))
(conc "Nobody has cards: "
(string-intersperse
(map number->string missing-cards)
", ") "."))
(else
other-player))))
(define *trade-number* 0)
(define (propose-trade game player params)
(let ((other-player (validate-trade game player params)))
(if (not (string? other-player))
(let ((to-trade (filter (lambda (x) (and (not (equal? (cdr x) 0))
(not (equal? (cdr x) ""))
(cdr x)))
params)))
(set! *trade-number* (+ *trade-number* 1))
(safe-set! (player-trade other-player)
(append `((player . ,(player-name player))
(originator . ,(player-name player))
(trade-number . ,*trade-number*))
to-trade))
(safe-set! (player-trade player)
(append `((player . ,(player-name other-player))
(originator . ,(player-name player))
(trade-number . ,*trade-number*))
to-trade))
#t)
other-player)))
(define (card-by-id player cards id)
(find (lambda (card)
(= (alist-ref 'id card eqv? -1) id))
cards))
(define (accept-trade game player)
(let* ((originator (find-player-by-name
game (alist-ref 'originator (player-trade player))))
;; player and originator will be the same for the accepting player
;; so we update player to be the other player
(params (alist-update 'player (player-name player) (player-trade player)))
(cards (map string->number (string-split (alist-ref 'cards params eqv? "")))))
(if (validate-trade game originator params)
(begin
(let loop ((crops '(hay grain fruit cows harvester tractor)))
(when (not (null? crops))
(let ((crop (car crops)))
(when (alist-ref crop params)
(let ((assets (player-assets originator))
(other-assets (player-assets player))
(amount (alist-ref crop params)))
(safe-set!
(player-assets originator)
(alist-update crop (+ (alist-ref crop assets) amount)
assets))
(safe-set!
(player-assets player)
(alist-update crop (+ (alist-ref crop other-assets) (* amount -1))
other-assets)))))
(loop (cdr crops))))
(let loop ((ridges '(ridge1 ridge2 ridge3 ridge4)))
(when (not (null? ridges))
(let ((ridge (car ridges)))
(when (alist-ref ridge params)
(if (> (player-ridge player ridge) 0)
(begin
(safe-set!
(player-assets originator)
(alist-update 'cows (+ (alist-ref 'cows (player-assets originator))
(alist-ref ridge (player-ridges player)))
(player-assets originator)))
(safe-set!
(player-assets player)
(alist-update 'cows (- (alist-ref 'cows (player-assets player))
(alist-ref ridge (player-ridges player)))
(player-assets player)))
(safe-set! (player-ridges originator)
(alist-update ridge
(alist-ref ridge (player-ridges player))
(player-ridges originator)))
(safe-set! (player-ridges player)
(alist-update ridge 0 (player-ridges player))))
(begin
(safe-set!
(player-assets originator)
(alist-update 'cows (- (alist-ref 'cows (player-assets originator))
(alist-ref ridge (player-ridges originator)))
(player-assets originator)))
(safe-set!
(player-assets player)
(alist-update 'cows (+ (alist-ref 'cows (player-assets player))
(alist-ref ridge (player-ridges originator)))
(player-assets player)))
(safe-set! (player-ridges player)
(alist-update ridge
(alist-ref ridge (player-ridges originator))
(player-ridges player)))
(safe-set! (player-ridges originator)
(alist-update ridge 0 (player-ridges originator)))))))
(loop (cdr ridges))))
(when (alist-ref 'money params)
(safe-set! (player-cash player)
(+ (player-cash player) (* (alist-ref 'money params) -1)))
(safe-set! (player-display-cash player) (player-cash player))
(safe-set! (player-cash originator)
(+ (player-cash originator) (alist-ref 'money params)))
(safe-set! (player-display-cash originator) (player-cash originator)))
(when (alist-ref 'cards params)
(for-each
(lambda (id)
(cond ((card-by-id player (player-otbs player) id)
(let ((otb (card-by-id player (player-otbs player) id)))
(safe-set! (player-otbs player)
(filter (lambda (x) (not (= id (alist-ref 'id x))))
(player-otbs player)))
(safe-set! (player-otbs originator)
(cons otb (player-otbs originator)))))
((card-by-id originator (player-otbs originator) id)
(let ((otb (card-by-id originator (player-otbs originator) id)))
(safe-set! (player-otbs originator)
(filter (lambda (x) (not (= id (alist-ref 'id x))))
(player-otbs originator)))
(safe-set! (player-otbs player)
(cons otb (player-otbs player)))))
((card-by-id player (player-farmers-fates player) id)
(let ((ff (card-by-id player (player-farmers-fates player) id)))
(safe-set! (player-farmers-fates player)
(filter (lambda (x) (not (= id (alist-ref 'id x))))
(player-farmers-fates player)))
(safe-set! (player-farmers-fates originator)
(cons ff (player-farmers-fates originator)))))
((card-by-id originator (player-farmers-fates originator) id)
(let ((ff (card-by-id originator (player-farmers-fates originator) id)))
(safe-set! (player-farmers-fates originator)
(filter (lambda (x) (not (= id (alist-ref 'id x))))
(player-farmers-fates originator)))
(safe-set! (player-farmers-fates player)
(cons ff (player-farmers-fates player)))))))
cards))
(safe-set! (player-trade originator) '())
(safe-set! (player-trade player) '()))
#f)))
(define (call-audit game player)
(if (not (game-called-audit game))
(safe-set! (game-called-audit game) player)))
(define (player-net-worth player)
(+ (* (+ (player-asset 'hay player) (player-asset 'grain player)) 2000)
(* (player-asset 'fruit player) 5000)
(* (player-asset 'cows player) 500)
(* (+ (player-asset 'harvester player) (player-asset 'tractor player)) 10000)
(player-cash player)
(* (player-debt player) -1)))
(define (do-end-of-game game)
(let ((rollers (sort (game-players game)
(lambda (p1 p2)
(> (/ (alist-ref 'harvest-rolls (player-stats p1))
(max (alist-ref 'num-harvests (player-stats p1)) 1))
(/ (alist-ref 'harvest-rolls (player-stats p2))
(max (alist-ref 'num-harvests (player-stats p2)) 1)))))))
(message-players!
game
#f
`((results
. ,(list->vector
(map (lambda (p i)
(conc i ". " (player-name p) " with $" (player-net-worth p)))
(sort (game-players game)
(lambda (p1 p2)
(> (player-net-worth p1)
(player-net-worth p2))))
(iota (length (game-players game)) 1))))
(stats . ((pro . ,(let ((p (car (sort (game-players game)
(lambda (p1 p2)
(> (alist-ref 'pro (player-stats p1))
(alist-ref 'pro (player-stats p2))))))))
(conc "Most suns aligned: " (player-name p) " (" (alist-ref 'pro (player-stats p)) ")")))
(back . ,(let ((p (car (sort (game-players game)
(lambda (p1 p2)
(> (alist-ref 'back (player-stats p1))
(alist-ref 'back (player-stats p2))))))))
(conc "Most licences expired: " (player-name p) " (" (alist-ref 'back (player-stats p)) ")")))
(taxPerson . ,(let ((p (car (sort (game-players game)
(lambda (p1 p2)
(> (alist-ref 'tax-person (player-stats p1))
(alist-ref 'tax-person (player-stats p2))))))))
(conc "Needs a tax person: " (player-name p) " (" (alist-ref 'tax-person (player-stats p)) ")")))
(emergency . ,(let ((p (car (sort (game-players game)
(lambda (p1 p2)
(> (alist-ref 'emergency (player-stats p1))
(alist-ref 'emergency (player-stats p2))))))))
(conc "Living on the edge: " (player-name p) " ($" (alist-ref 'emergency (player-stats p)) ")")))
(highRoller . ,(let ((p (car rollers)))
(conc "High Roller: " (player-name p) " (" (exact->inexact
(/ (round
(* (/ (alist-ref 'harvest-rolls (player-stats p))
(max (alist-ref 'num-harvests (player-stats p)) 1))
10))
10)) ")")))
(lowRoller . ,(let ((p (last rollers)))
(conc "Low Roller: " (player-name p) " (" (exact->inexact
(/ (round
(* (/ (alist-ref 'harvest-rolls (player-stats p))
(max (alist-ref 'num-harvests (player-stats p)) 1))
10))
10)) ")"))))))
type: "end-of-game")))
(define (create-ws-response player event misc)
(append `((event . ,event) ,@misc)
(player->list player)
(game->list (*game*) player)))
(define (create-start-response event #!key (errors '()))
`((event . ,event)
(games . ((games . ,(list->vector
(map (lambda (game)
`((name . ,(game-name game))
(id . ,(game-id game))
(colors . ,(list->vector
(map symbol->string (game-colors game))))
(players . ,(list->vector
(map player-name (game-players game))))))
(map (lambda (gid)
(sexp->game (db-fetch-game gid)))
(db-fetch-user-games (session-ref (sid) 'user-id -1))))))))
(openGames . ((games . ,(list->vector
(map (lambda (game)
`((name . ,(game-name game))
(id . ,(game-id game))
(colors . ,(list->vector
(map symbol->string (game-colors game))))
(players . ,(list->vector
(map player-name (game-players game))))))
(map sexp->game (db-fetch-open-games)))))))
(user . ,(let ((id (session-ref (sid) 'user-id #f)))
(if (and id (not (equal? id -1)))
id
#f)))
(errors . ,(list->vector errors))))
(define (message-players! game player message #!key (type "action"))
(for-each (lambda (p)
(when (not (eq? p player))
(mailbox-send! (player-mailbox p) `((type . ,type) (value . ,message)))))
(game-players game)))
(define *next-roll* #f)
(define (->number x default)
(if (number? x)
x
(if (string? x)
(or (string->number x)
default)
default)))
(define (->pct x default)
(let ((n (->number x default)))
(if (or (> n 1) (< n 0))
default
n)))
(define (->i x default)
(let ((n (inexact->exact (floor (->number x default)))))
(if (< n 0)
default
(- n (modulo n 1000)))))
(define (reconcile-display-cash player game)
(unless (player-harvesting player)
(for-each (lambda (player)
(safe-set! (player-display-cash player) (player-cash player)))
(game-players game))))
(define (find-game id)
(let ((game-in-memory (find (lambda (g) (= (game-id g) id))
(app-games *app*))))
(if game-in-memory
game-in-memory
(let ((db-game (sexp->game (db-fetch-game id))))
(push! db-game (app-games *app*))
(for-each (lambda (p)
(when (ai-player? p)
(thread-start! (make-ai-push-receiver db-game p))))
(game-players db-game))
db-game))))
(define (next-roll last-roll)
(let ((roll (+ (random 6) 1)))
(if (= roll last-roll)
(next-roll last-roll)
roll)))
(define (make-rolls n)
(define (_make-rolls n i rolls)
(if (<= i n)
(_make-rolls n (+ i 1) (cons (next-roll (car rolls)) rolls))
rolls))
(_make-rolls n 1 (list (next-roll -1))))
(define (log-error exn)
(with-output-to-file (error-log)
(lambda ()
(print-call-chain)
(print exn)
(print-error-message exn))
append:))
(define (log-msg msg)
(log-to (error-log) "~A" msg))
(define (process-message player game type msg)
(when player
(safe-set! (player-last-cash player) (player-cash player)))
(print "message type: " type)
(cond ((string=? type "roll")
(let ((num (+ (random 6) 1))
(rolls (make-rolls 22)))
(when *next-roll* (set! num *next-roll*))
(safe-set! (player-previous-space player)
(player-space player))
(safe-set! (player-space player)
(+ (player-space player) num))
(safe-set! (player-state player) 'mid-turn)
(when (> (player-space player) 48)
(safe-set! (player-space player)
(- (player-space player) 49)))
(when (and (> (player-previous-space player) 40)
(< (player-space player) 10))
(finish-year player))
(safe-set! (player-harvest-mult player) 1)
(let ((resp `((from . ,(player-previous-space player))
(to . ,(player-space player))
(rolls . ,(list->vector rolls)))))
(safe-set! (game-actions game)
(append (game-actions game)
`(((?action . move) (?value . ,resp))
((?action . resolve-move)
(?value . ((to . ,(player-space player))
(color . ,(symbol->string (player-color player)))))))
(sort-actions (get-actions player (player-space player)))))
(message-players! game player
`((action . "roll")
(value . ,resp)))
(create-ws-response player "action" `((action . "roll") (value . ,resp))))))
((and (string=? type "next-action")
(not (eq? (player-state player) 'turn-ended)))
(let loop ((i 0))
(if (or (null? (game-actions game))
(>= i 15))
(begin
(reconcile-display-cash player game)
(safe-set! (game-actions game) '())
(message-players! game player `((action . #f) (value . #f)))
(create-ws-response player "action" '((action . #f))))
(let* ((action (car (game-actions game)))
(name (alist-ref '?action action))
(value (alist-ref '?value action)))
(print action)
(cond ((eq? value 'otb)
(reconcile-display-cash player game)
(let ((otb (do-action action player)))
(safe-set! (game-actions game) (cdr (game-actions game)))
(if otb
(begin
(message-players! game player
`((action . "otb")
(value . ,(alist-ref 'contents otb))))
(create-ws-response player "action"
`((action . "otb")
(value . ,(alist-ref 'contents otb)))))
(begin
(message-players! game player
`((action . "info")
(value . ,(conc "Out of " *item-card-short* "'s."))))
(create-ws-response player "action"
`((action . "info")
(value . ,(conc "Out of " *item-card-short* "'s."))))))))
((eq? name 'move)
(reconcile-display-cash player game)
(safe-set! (game-actions game) (cdr (game-actions game)))
(message-players! game player
`((action . "move") (value . ,value)))
(create-ws-response player "action"
`((action . "move") (value . ,value))))
((eq? name 'resolve-move)
(safe-set! (game-actions game) (cdr (game-actions game)))
(message-players! game player
`((action . "resolve-move") (value . ,value)))
(create-ws-response player "action"
`((action . "resolve-move") (value . ,value))))
((eq? name 'harvest)
(reconcile-display-cash player game)
(let ((res (do-action action player)))
(safe-set! (game-actions game) (cdr (game-actions game)))
(if (eq? res 'nothing)
(loop (+ i 1))
(begin
(safe-set! (player-harvesting player) (alist-ref (string->symbol (player-name player))
(alist-ref 'operatingExpenseValue res)))
(message-players!
game player
`((action . "harvest") (value . ,res)))
(create-ws-response player
"action"
`((action . "harvest")
(value . ,res)))))))
((or (eq? name 'money) (eq? name 'player-action))
(reconcile-display-cash player game)
;; all current player-actions have only a cash effect
(let ((previous-cash (player-cash player)))
(do-action action player)
(safe-set! (game-actions game)
(cdr (game-actions game)))
(if (= (- (player-cash player) previous-cash) 0)
(loop (+ i 1))
(let ((res `((action . "money")
(value . ((amount . ,(- (player-cash player)
previous-cash))
(player . ,(player-name player)))))))
(message-players! game player res)
(create-ws-response player "action" res)))))
((eq? name 'end-game)
(reconcile-display-cash player game)
(if (null? (cdr (game-actions game)))
(begin
(value)
(safe-set! (game-actions game) '()))
(safe-set! (game-actions game)
(append (cdr (game-actions game))
(list (car (game-actions game))))))
(loop (+ i 1)))
((or (eq? name 'harvest-mult)
(eq? name 'player-action-post-harvest))
(safe-set! (game-actions game) (cdr (game-actions game)))
(do-action action player)
(loop (+ i 1)))
((eq? value 'farmers-fate)
(reconcile-display-cash player game)
(let ((ff (do-action action player)))
(safe-set! (game-actions game)
(append (alist-ref 'actions ff)
(cdr (game-actions game))))
(message-players! game player
`((action . "farmers-fate")
(value . ,(alist-ref 'contents ff))))
(create-ws-response player "action"
`((action . "farmers-fate")
(value . ,(alist-ref 'contents ff))))))
((eq? name 'ff-money)
(reconcile-display-cash player game)
(safe-set! (game-actions game) (cdr (game-actions game)))
(if (= (alist-ref 'amount value) 0)
(loop (+ i 1))
(let ((res `((action . "money")
(value . ((amount . ,(alist-ref 'amount value))
(player . ,(alist-ref 'name value)))))))
(message-players! game player res)
(create-ws-response player "action" res))))
((eq? name 'ff-uncle-bert)
(reconcile-display-cash player game)
(safe-set! (game-actions game) (cdr (game-actions game)))
(message-players! game player
`((action . "ff-uncle-bert") (value . #f)))
(create-ws-response player "action"
`((action . "ff-uncle-bert")
(value . #f))))
((eq? name 'info)
(reconcile-display-cash player game)
(safe-set! (game-actions game) (cdr (game-actions game)))
(message-players! game player
`((action . "info") (value . ,value)))
(create-ws-response player "action"
`((action . "info")
(value . ,value))))
((eq? name 'goto)
(reconcile-display-cash player game)
(do-action action player)
(safe-set! (player-harvest-mult player) 1)
(safe-set! (game-actions game)
(append `(((?action . resolve-move)
(?value . ((to . ,(player-space player))
(color . ,(symbol->string (player-color player)))))))
(sort-actions (get-actions player (player-space player)))
(cdr (game-actions game))))
(let ((resp `((from . ,(player-previous-space player))
(to . ,(player-space player)))))
(message-players! game player `((action . "goto")
(value . ,resp)))
(create-ws-response player "action"
`((action . "goto")
(value . ,resp)))))
((eq? name 'add-rule)
(reconcile-display-cash player game)
(do-action action player)
(safe-set! (game-actions game) (cdr (game-actions game)))
(loop (+ i 1)))
(else ;; TODO make error
(create-ws-response player "action" `((action . ,name)))))))))
((and (string=? type "next-action")
(ai-player? (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)))
(print "ai uncle bert trigger")
(message-players! game player '() type: "ai-uncle-bert")
(create-ws-response player "update" `()))
((string=? type "end-ai-turn")
(message-players! game player '() type: "end-ai-turn")
(create-ws-response player "update" `()))
((string=? type "skip")
(when (and (player-harvesting player) (string=? (alist-ref 'component msg) "harvest|income"))
;; player-harvesting will contain the operating expense amount
(safe-set! (player-display-cash player) (- (player-cash player) (player-harvesting player))))
(when (string=? (alist-ref 'component msg) "harvest|operating-expense")
(safe-set! (player-harvesting player) #f)
(reconcile-display-cash player game))
(message-players! game player `((component . ,(alist-ref 'component msg)))
type: "auto-skip")
(create-ws-response player "update" '()))
((string=? type "buy")
(let* ((id (alist-ref 'id msg))
(otb (find (lambda (x) (= id (alist-ref 'id x)))
(player-otbs player)))
(bought-crop (buy-crop (normalize-crop
(string->symbol (alist-ref 'crop otb)))
(string->symbol (alist-ref 'crop otb))
(alist-ref 'amount otb)
(* (or (and (number? (alist-ref 'cash msg))
(alist-ref 'cash msg))
0)
1000)
player
game)))
(if (eq? bought-crop #t)
(begin
(safe-set! (game-otbs game)
(append (game-otbs game)
(filter (lambda (x) (= id (alist-ref 'id x)))
(player-otbs player))))
(safe-set! (player-otbs player)
(filter (lambda (x) (not (= id (alist-ref 'id x))))
(player-otbs player)))
(message-players! game player '() type: "update")
(create-ws-response player "buy" '()))
(create-ws-response player "buy" `((error . ,bought-crop))))))
((string=? type "buy-uncle-bert")
(safe-set! (player-cash player) (- (player-cash player) 10000))
(safe-set! (player-display-cash player) (player-cash player))
(safe-set! (player-assets player)
(alist-update 'hay (+ (alist-ref 'hay (player-assets player)) 10)
(player-assets player)))
(message-players! game player '() type: "update")
(create-ws-response player "buy" '()))
((string=? type "actions-finished")
(create-ws-response player "update" '()))
((string=? type "loan")
(let ((amount (* (alist-ref 'amount msg) 1000)))
(if (> amount 0)
;; taking out loan
(if (> (+ (player-debt player)
(farming-round (+ amount (* amount (game-setting 'loan-interest game)))))
(game-setting 'max-debt game))
;; emergency loan
(begin ((make-player-stat 'emergency (* amount 2)) player)
(safe-set! (player-cash player) (+ (player-cash player) amount))
(safe-set! (player-display-cash player) (player-cash player))
(safe-set! (player-debt player) (+ (player-debt player) (* amount 2))))
;; regular loan
(begin (safe-set! (player-cash player) (+ (player-cash player) amount))
(safe-set! (player-display-cash player) (player-cash player))
(safe-set! (player-debt player) (+ (player-debt player)
(farming-round
(+ amount (* amount (game-setting 'loan-interest game))))))))
;; repaying loan
(cond ((> (abs amount) (player-cash player)))
(else
(safe-set! (player-cash player) (+ (player-cash player) amount))
(safe-set! (player-display-cash player) (player-cash player))
(safe-set! (player-debt player) (+ (player-debt player) amount))
(when (< (player-debt player) 0)
(safe-set! (player-cash player) (+ (player-cash player)
(abs (player-debt player))))
(safe-set! (player-display-cash player) (player-cash player))
(safe-set! (player-debt player) 0))))))
(create-ws-response player "loan" '()))
((string=? type "trade")
(let ((res (propose-trade game player (alist-ref 'parameters msg))))
(if (eq? res #t)
(begin
(message-players! game player '() type: "update")
(create-ws-response player "trade" '()))
(begin (safe-set! (player-trade player) `((error . ,res)))
(create-ws-response player "trade-error" `())))))
((string=? type "trade-accept")
(accept-trade game player)
(message-players! game player '() type: "update")
(create-ws-response player "trade-accepted" '()))
((string=? type "trade-deny")
(safe-set! (player-trade (find-player-by-name
game (alist-ref 'originator (player-trade player))))
'())
(safe-set! (player-trade player) '())
(message-players! game player '() type: "update")
(create-ws-response player "trade-denied" '()))
((string=? type "trade-cancel")
(safe-set! (player-trade (find-player-by-name
game (alist-ref 'player (player-trade player))))
'())
(safe-set! (player-trade player) '())
(message-players! game player '() type: "update")
(create-ws-response player "trade-cancelled" '()))
((string=? type "audit")
(call-audit game player)
(message-players! game player '() type: "update")
(create-ws-response player "called-audit" '()))
((string=? type "init")
(create-ws-response player "init" `((harvestTable . ,(map (lambda (row)
`(,(car row) . ,(list->vector (cdr row))))
*harvest-table*)))))
((string=? type "turn-ended")
(reconcile-display-cash player game)
(safe-set! (player-harvesting player) #f)
(if (>= (player-cash player) 0)
(begin (advance-turn game player)
(handle-exceptions
exn
(begin (log-error exn)
(log-msg "error saving app"))
(save-game game))
(if (eq? (game-state game) 'finished)
(do-end-of-game game)
(message-players! game player '() type: "update"))
(create-ws-response player "update" '()))
(begin (create-ws-response player "update" '()))))
((string=? type "toggle-reveal-for-trading")
(let ((id (alist-ref 'id msg)))
(if (member id (player-revealed-cards player))
(safe-set! (player-revealed-cards player)
(filter (lambda (cid) (not (eqv? cid id)))
(player-revealed-cards player)))
(safe-set! (player-revealed-cards player)
(cons id (player-revealed-cards player)))))
(message-players! game player '() type: "update")
(create-ws-response player "update" '()))
;;;;;;;;;;;;;;;;;;;;; start ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
((string=? type "main-init")
(create-start-response "start-init"))
((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))
'name (alist-ref 'gameName msg)
'id (next-game-id *app*)
'otbs (setup-otbs)
'operating-expenses (setup-operating-expenses)
'farmers-fates (setup-farmers-fates #t)
'settings
`((down-payment . ,(->pct (alist-ref 'downPayment msg) 0))
(loan-interest . ,(->pct (alist-ref 'loanInterest msg) 0))
(max-debt . ,(->i (alist-ref 'maxDebt msg) 50000))
(audit-threshold . ,(->i (alist-ref 'auditThreshold msg)
250000))
(starting-cash . ,(->i (alist-ref 'startingCash msg)
0))
(starting-debt . ,(->i (alist-ref 'startingDebt msg)
0))
(starting-otbs . ,(min (max (->number (alist-ref 'startingOtbs msg)
2)
0)
8))
(trade . ,(or (alist-ref 'trade msg) #t)))))
(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"))
)
(push! game (app-games *app*))
(let ((gid (db-add-game "pre-game" (game->sexp game))))
(safe-set! (game-id game) gid)
(db-update-game gid "pre-game" (game->sexp game))
(db-add-user-game (alist-ref 'id user) (game-id game))
(session-set! (sid) 'game-id (game-id game)))
(*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)))
(name (alist-ref 'username user))
(id (alist-ref 'gameId msg))
(game (find-game id))
(color-raw (string->symbol (alist-ref 'checkedColor msg)))
(color (if (not (member color-raw (game-colors game)))
(car (game-colors game))
color-raw))
(player (add-player-to-game game
color
(alist-ref 'username user)
(alist-ref 'id user))))
(safe-set! (game-colors game) (filter (cut neq? <> color) (game-colors game)))
(session-set! (sid) 'game-id (game-id game))
(db-add-user-game (alist-ref 'id user) (game-id game))
(*game* game)
(*player* player)
(set-startup-otbs game player (alist-ref 'starting-otbs (game-settings game)))
(message-players! game player '() type: "update")
(create-start-response "new-game-started")))
((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))))))
(game (*game*))
(color (car (game-colors game)))
(player (add-ai-to-game game
color
name)))
(safe-set! (game-colors game) (filter (cut neq? <> color) (game-colors game)))
(set-startup-otbs game player (alist-ref 'starting-otbs (game-settings game)))
(safe-set! (player-ready-to-start player) #t)
(thread-start! (make-ai-push-receiver game player))
(message-players! game player '() type: "update")
(create-ws-response (*player*) "update" '())))
((string=? type "join-as-existing")
(let* ((id (or (alist-ref 'gameId msg)
(session-ref (sid) 'game-id)))
(user-id (session-ref (sid) 'user-id))
(game (find-game id))
(player (find (lambda (p) (equal? (player-user-id p) user-id))
(game-players game))))
(*game* game)
(*player* player)
(create-start-response "new-game-started")))
((string=? type "create-account")
(let ((username (alist-ref 'username msg))
(email (alist-ref 'email msg))
(password (alist-ref 'password msg))
(confirm-password (alist-ref 'confirmPassword msg)))
(if (string=? password confirm-password)
(if (null? (fetch-user username))
(let ((id (add-user username email password)))
(session-set! (sid) 'user-id id)
(create-start-response "start-init"))
(create-start-response "start-init" errors: '("Account already exists")))
(create-start-response "start-init" errors: '("Passwords don't match")))))
((string=? type "login")
(let ((username (alist-ref 'username msg))
(password (alist-ref 'password msg)))
(if (valid-password? username password)
(begin (session-set! (sid) 'user-id (alist-ref 'id (fetch-user username)))
(create-start-response "start-init"))
(create-start-response "start-init" errors: '("Invalid password or account doesn't exist")))))
((string=? type "logout")
(session-set! (sid) 'game-id #f)
(session-set! (sid) 'user-id #f)
(create-start-response "start-init"))
((string=? type "ready-to-start")
(safe-set! (player-ready-to-start (*player*)) (not (player-ready-to-start (*player*))))
(message-players! (*game*) (*player*) '() type: "update")
(create-ws-response (*player*) "update" '()))
((string=? type "kick-player")
(let ((kicked-player (find (lambda (p)
(equal? (player-name p) (alist-ref 'name msg)))
(game-players (*game*)))))
(safe-set! (game-colors (*game*))
(cons (player-color kicked-player) (game-colors (*game*))))
(safe-set! (game-otbs (*game*))
(append (game-otbs (*game*))
(player-otbs kicked-player)))
(safe-set! (game-players (*game*))
(filter (lambda (p)
(not (eq? p kicked-player)))
(game-players (*game*))))
(db-remove-user-game (player-user-id kicked-player) (game-id (*game*)))
(mailbox-send! (player-mailbox kicked-player) '((type . "left-game") (value . ())))
(message-players! (*game*) (*player*) `((color . ,(symbol->string (player-color kicked-player))))
type: "player-left-game")
(create-ws-response (*player*) "player-left-game" `((color . ,(symbol->string (player-color kicked-player)))))))
((string=? type "leave-game")
(safe-set! (game-colors (*game*))
(cons (player-color (*player*)) (game-colors (*game*))))
(safe-set! (game-otbs (*game*))
(append (game-otbs (*game*))
(player-otbs (*player*))))
(safe-set! (game-players (*game*))
(filter (lambda (p)
(not (eq? p (*player*))))
(game-players (*game*))))
(when (not (null? (game-players (*game*))))
(safe-set! (game-current-player (*game*)) (car (game-players (*game*)))))
(db-remove-user-game (player-user-id (*player*)) (game-id (*game*)))
(message-players! (*game*) (*player*) `((color . ,(symbol->string (player-color (*player*)))))
type: "player-left-game")
(create-ws-response (*player*) "left-game" '()))
((string=? type "start-game")
(safe-set! (game-state (*game*)) 'pre-turn)
(db-update-game (game-id (*game*)) (symbol->string (game-state (*game*)))
(game->sexp (*game*)))
(message-players! (*game*) (*player*) '() type: "update")
(create-ws-response (*player*) "update" '()))))
(define (round-down-1000 val)
(- val (remainder val 1000)))
(define (ai-buy player game)
(print "ai attempting to buy")
(let ((room (+ (- (game-setting 'max-debt game) (player-debt player)) (round-down-1000 (player-cash player))))
(crops (map (lambda (card)
(string->symbol (alist-ref 'crop card)))
(player-otbs player))))
(print (conc "room: " room))
(print (conc "crops: " crops))
(let ((to-buy
(cond ((and (member 'cows crops) (>= room 5000))
'(cows 10 5000))
((and (member 'fruit crops) (>= room 25000))
'(fruit 5 25000))
((and (member 'grain crops) (>= room 20000))
'(grain 10 20000))
((and (member 'hay crops) (>= room 20000))
'(hay 10 20000))
((and (member 'harvester crops) (>= room 10000)
(= (player-asset 'harvester player) 0))
'(harvester 1 10000))
((and (member 'tractor crops) (>= room 10000)
(= (player-asset 'tractor player) 0))
'(tractor 1 10000))
((and (member 'ridge4 crops) (>= room 50000)
(not (find (lambda (p)
(> (player-asset 'ridge4 p) 0))
(game-players game))))
'(ridge4 50 50000))
((and (member 'ridge3 crops) (>= room 40000)
(not (find (lambda (p)
(> (player-asset 'ridge3 p) 0))
(game-players game))))
'(ridge3 40 40000))
((and (member 'ridge2 crops) (>= room 30000)
(not (find (lambda (p)
(> (player-asset 'ridge2 p) 0))
(game-players game))))
'(ridge2 30 30000))
((and (member 'ridge1 crops) (>= room 20000)
(not (find (lambda (p)
(> (player-asset 'ridge1 p) 0))
(game-players game))))
'(ridge1 20 20000))
(else #f))))
(print "to buy: " to-buy)
(if to-buy
(begin
(print (conc "buying crop: " (first to-buy)))
(if (eq? (buy-crop (normalize-crop (first to-buy))
(first to-buy)
(second to-buy)
(min (third to-buy) (round-down-1000 (player-cash player)))
player
game)
#t)
(let ((id (alist-ref 'id
(find (lambda (c) (equal? (alist-ref 'crop c) (symbol->string (first to-buy))))
(player-otbs player)))))
(safe-set! (game-otbs game)
(append (game-otbs game)
(filter (lambda (x) (= id (alist-ref 'id x)))
(player-otbs player))))
(safe-set! (player-otbs player)
(filter (lambda (x) (not (= id (alist-ref 'id x))))
(player-otbs player)))
#t)
#f))
#f)))
)
(define (process-ai-push-message player game msg)
(print (player-name player))
(print msg)
(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)
;; time to buy
(when (and (>= (player-space player) 9) (<= (player-space player) 14))
(let loop ((cont (ai-buy player game)))
(when cont (loop (ai-buy player game)))))
(let ((res (process-message player game "roll" '((type . "roll")))))
(print "rolled a " (alist-ref 'value res))))))
((auto-skip)
(print "ai auto-skip"))
((ai-next-action)
(print "ai-next-action")
(when (ai-processing-turn player)
(let ((res (process-message player game "next-action" '((type . "next-action")))))
res
;; (display "res: ")
;; (write res)
;; (newline)
)))
((ai-uncle-bert)
(print "ai-uncle-bert")
(when (ai-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)
(player-assets player)))))
((end-ai-turn)
(if (eq? (player-state player) 'pre-turn)
(process-ai-push-message player game '((type . "update"))) ;; restarting at AI player's turn
(when (ai-processing-turn player)
(when (< (player-cash player) 0)
(print "taking out loan")
(process-message player game "loan" `((amount . ,(/ (+ (abs (player-cash player))
(remainder (abs (player-cash player)) 1000))
1000)))))
(when (>= (player-cash player) 1000)
(print "repaying loan")
(process-message player game "loan" `((amount . ,(* (/ (- (player-cash player)
(remainder (player-cash player) 1000))
1000)
-1)))))
(print "ending turn")
;; (thread-sleep! 0.5)
(set! (ai-processing-turn player) #f)
(process-message player game "turn-ended" '())
)))))
(define (make-ai-push-receiver game player)
(lambda ()
(*game* game)
(*player* player)
(let loop ((msg (mailbox-receive! (player-mailbox player))))
(process-ai-push-message player game msg)
(loop (mailbox-receive! (player-mailbox player))))))
(define (session-game)
(let ((user-id (session-ref (sid) 'user-id)))
(if (and (not (*game*)) (session-ref (sid) 'game-id #f))
(let ((possible-game (find-game (session-ref (sid) 'game-id))))
(when possible-game
(*game* possible-game)
(*player* (find (lambda (p)
(equal? (player-user-id p) user-id))
(game-players (*game*))))
(*game*)))
(and (*game*)))))
(define (websocket-page)
(sid (read-cookie (session-cookie-name)))
;; TODO some kind of error handling if (sid) #f
(with-concurrent-websocket
(lambda ()
(let loop ((msg (read-json (receive-message))))
(handle-exceptions
exn
(send-message
(json->string
`((exn . ,(begin (log-error exn)
(conc "Server error: " (with-output-to-string
(lambda ()
(print-error-message exn))))))
(event . "error"))))
(send-message
(json->string
(handle-exceptions
exn
`((exn . ,(begin (log-error exn)
(conc "Server error: " (with-output-to-string
(lambda ()
(print-error-message exn))))))
(event . "error"))
(session-game)
(let* ((game (*game*))
(res (process-message (*player*)
game
(alist-ref 'type msg)
msg)))
(when game
(safe-set! (game-last-updated game) (+ (game-last-updated game) 1))
(when (*player*)
(safe-set! (player-last-updated (*player*)) (game-last-updated game))))
res)
;; (let* ((game (session-ref (sid) 'game #f))
;; (player (session-ref (sid) 'player #f))
;; (res (process-message player
;; game
;; (alist-ref 'type msg)
;; msg)))
;; (when game
;; (safe-set! (game-last-updated game) (+ (game-last-updated game) 1))
;; (safe-set! (player-last-updated player) (game-last-updated game)))
;; res)
))))
(loop (read-json (receive-message)))))))
(define (push-websocket-page)
(sid (read-cookie (session-cookie-name)))
;; TODO some kind of error handling if (sid) #f
(with-concurrent-websocket
(lambda ()
(session-game)
(let loop ((msg (mailbox-receive! (player-mailbox (*player*)))))
(session-game)
;; when (< (player-last-updated player)
;; (game-last-updated game))
(handle-exceptions
exn
(send-message
(json->string
`((exn . ,(begin (log-error exn)
(conc "Server error: " (with-output-to-string
(lambda ()
(print-error-message exn)))))))))
(send-message
(json->string
(handle-exceptions
exn
`((exn . ,(begin (log-error exn)
(conc "Server error: " (with-output-to-string
(lambda ()
(print-error-message exn))))))
(event . "error"))
(create-ws-response (*player*)
(alist-ref 'type msg)
(alist-ref 'value msg))
))))
(loop (mailbox-receive! (player-mailbox (*player*))))))))
(define (otb-spec->otb-cards spec id)
`((contents . ,(sxml->html* (list-ref spec 5)))
(total . ,(list-ref spec 4))
(amount . ,(list-ref spec 3))
(type . "otb")
(crop . ,(symbol->string (list-ref spec 0)))
(summary . ,(conc *item-card-short* ": " (list-ref spec 6)))
(id . ,id)
(title . ,(conc *item-card* ":"))))
(define (otb-spec-list->otb-cards otbs)
(let ((id 10))
(append-map (lambda (otb-type)
(map (lambda (x)
(set! id (+ id 1))
(otb-spec->otb-cards otb-type id))
(iota (list-ref otb-type 1))))
otbs)))
(define (otb-text key text)
(alist-ref key text))
(define *otb-specs*
(map
(lambda (spec)
(append spec (otb-text (car spec) *otb-text*)))
'((fruit 6 crop 5 25000)
(hay 5 crop 10 20000)
(grain 5 crop 10 20000)
(cows 6 crop 10 5000)
(harvester 3 equipment 1 10000)
(tractor 3 equipment 1 10000)
(ridge4 3 ridge 50 50000)
(ridge3 3 ridge 40 40000)
(ridge2 3 ridge 30 30000)
(ridge1 3 ridge 20 20000))))
(define (setup-otbs) (shuffle (otb-spec-list->otb-cards (list-copy *otb-specs*))))
;; (define *otbs* (setup-otbs))
(define *awful-thread* #f)
(define (run-awful) ; for interactive development
(set! *server-thread*
(make-thread
(lambda ()
(start-server)
;; (awful-start (lambda () (void)) port: 8080)
)))
(thread-start! *server-thread*))
(define (strip-tags sxml #!key (para-space #f))
(apply
conc
(flatten
(pre-post-order*
sxml
`((p . ,(lambda (tag body)
(if para-space
(append body '(" "))
body)))
(em . ,(lambda (tag body) body))
(b . ,(lambda (tag body) body))
(*text* . ,(lambda (tag str) str))
(*default* . ,(lambda (tag str) str))
(*TOP* . ,(lambda (tag str) str)))))))
(define (player-acres player)
(apply + (map cdr (filter (lambda (a) (member (car a) '(grain hay fruit)))
(player-assets player)))))
(define (player-asset asset player)
(or (alist-ref asset (player-assets player))
0))
(define (player-ridge player ridge)
(alist-ref ridge (player-ridges player)))
(define (player-has-asset? asset player)
(not (equal? (player-asset asset player) 0)))
(define (players-with asset game)
(filter (lambda (player)
(player-has-asset? asset player))
(game-players game)))
(define (player-asset-binary-count asset game)
(apply + (map (lambda (player)
(if (player-has-asset? asset player) 1 0))
(game-players game))))
(define (equipment-payout equipment player amount game)
(when (not (player-has-asset? equipment player))
(let ((num-equipment (player-asset-binary-count equipment game)))
(when (> num-equipment 0)
(let ((amount-per-player (farming-round-down
(inexact->exact
(round (/ (exact->inexact amount) num-equipment))))))
(for-each (lambda (player)
(safe-set! (player-cash player)
(+ (player-cash player) amount-per-player)))
(players-with equipment game)))))
(safe-set! (player-cash player) (- (player-cash player) amount))))
(define (make-player-gains amount)
(lambda (player)
(safe-set! (player-cash player) (+ (player-cash player) amount))))
(define (make-player-pays amount)
(lambda (player)
(safe-set! (player-cash player) (- (player-cash player) amount))))
(define (make-player-pays-per-unit unit amount)
(lambda (player)
(let ((to-pay (farming-round-down
(inexact->exact
(round (* (player-asset (normalize-crop unit) player) amount))))))
(safe-set! (player-cash player)
(- (player-cash player) to-pay)))))
(define (make-player-gains-per-unit unit amount)
(lambda (player)
(let ((to-pay (* (player-asset (normalize-crop unit) player) amount)))
(safe-set! (player-cash player)
(+ (player-cash player) to-pay)))))
(define (make-semi-annual-interest-due)
(lambda (player)
(let ((to-pay (farming-round-down
(inexact->exact (round (* (player-debt player) 0.1))))))
(safe-set! (player-cash player)
(- (player-cash player) to-pay)))))
(define (cows-on-ridges player)
(fold (lambda (ridge r)
(+ r (player-ridge player ridge)))
0
'(ridge1 ridge2 ridge3 ridge4)))
(define (remove-farmers-fate-from-hand player id)
(let ((game (*game*)))
(safe-set! (game-farmers-fates game)
(append (game-farmers-fates game)
(filter (lambda (x) (eq? (alist-ref 'internal-id x) id))
(player-farmers-fates player)))))
(safe-set! (player-farmers-fates player)
(filter (lambda (x) (not (eq? (alist-ref 'internal-id x) id)))
(player-farmers-fates player))))
(define (remove-farmers-fate-after p id space)
(when (>= (player-space p) space)
(remove-farmers-fate-from-hand p id)))
(define *action-map*
`((remove-farmers-fate-from-hand . ,remove-farmers-fate-from-hand)
(remove-farmers-fate-after . ,remove-farmers-fate-after)))
(define (farmers-fate-spec->farmers-fate-card spec id)
`((contents . ,(sxml->html* (list-ref spec 0)))
(text . ,(strip-tags (list-ref spec 0) para-space: #t))
(total . #f)
(type . "farmers-fate")
(crop . #f)
(summary . ,(conc *fate-card-short* ": "
(string-take (strip-tags (list-ref spec 0)) 20)))
(id . ,id)
(title . ,(conc *fate-card* ":"))
(hold-card . ,(list-ref spec 3))
(action . ,(list-ref spec 2))
(internal-id . ,(if (> (length spec) 4) (list-ref spec 4) #f))))
(define (farmers-fate-spec-list->farmers-fate-cards farmers-fates ff-texts)
(let ((id 1000))
(append-map (lambda (spec text)
(map (lambda (x)
(set! id (+ id 1))
(farmers-fate-spec->farmers-fate-card
(cons text spec) id))
(iota (list-ref spec 0))))
farmers-fates ff-texts)))
(define (ff-money-response amount player-name)
`((?action . ff-money)
(?value . ((amount . ,amount)
(name . ,player-name)))))
(define-syntax with-ff-money-action
(syntax-rules ()
((_ (player game) body ...)
(let ((previous-cash (map (lambda (p)
(cons p (player-cash p))) (game-players game))))
body ...
`(,(ff-money-response (- (player-cash player)
(cdr (find (lambda (x) (eq? (car x) player)) previous-cash)))
(player-name player))
,@(map (lambda (x)
(ff-money-response (- (player-cash (car x)) (cdr x))
(player-name (car x))))
(filter (lambda (x)
(and (not (eq? (car x) player))
(not (= (- (player-cash (car x))
(cdr x))
0))))
previous-cash))
)))))
(define *farmers-fates-specs*
`((1 ,(lambda (player game)
(with-ff-money-action (player game)
(for-each (lambda (p)
(let ((roll (+ (random 6) 1)))
(if (odd? roll)
((make-player-pays (* (player-acres p) 100)) p))))
(filter (lambda (x) (not (eq? x player)))
(game-players (*game*))))
((make-player-gains-per-unit 'hay 500) player)))
#f)
(1 ,(lambda (player game)
(with-ff-money-action (player game)
((make-player-gains-per-unit 'grain 100) player)))
#f)
(1 ,(lambda (player game)
(push! (make-player-year-rule 2 '((?p wheat harvest-mult 0.5) (?p grain)))
(player-year-rules player))
(push! (make-player-year-rule
3
`((?p wheat player-action-post-harvest
(remove-farmers-fate-from-hand windy-spring))
(?p grain)))
(player-year-rules player))
(push! (make-player-year-rule
4
`((?d player-action ?p
(remove-farmers-fate-after windy-spring 34))))
(player-year-rules player))
'())
#t
windy-spring)
(1 ,(lambda (player game)
(if (player-has-asset? 'cows player)
(with-ff-money-action (player game) ((make-player-gains 2000) player))
'()))
#f)
(1 ,(lambda (player game)
(with-ff-money-action (player game)
((make-player-gains-per-unit 'hay 100) player)))
#f)
(1 ,(lambda (player game)
(with-ff-money-action (player game) ((make-player-gains 1000) player)))
#f)
(1 ,(lambda (player game)
(with-ff-money-action (player game) ((make-player-pays 7000) player)))
#f)
(1 ,(lambda (player game)
(with-ff-money-action (player game)
((make-player-pays-per-unit 'fruit 500) player)))
#f)
(1 ,(lambda (player game)
(with-ff-money-action (player game)
(let ((to-earn (* (player-acres player) 100)))
(safe-set! (player-cash player)
(+ (player-cash player) to-earn)))))
#f)
(2 ,(lambda (player game)
`(((?action . player-action)
(?value . ,(lambda (player) (finish-year player #f))))
((?action . goto) (?value . jan2))))
#f)
(1 ,(lambda (player game)
(with-ff-money-action (player game)
((make-player-pays-per-unit 'fruit 300) player)))
#f)
(2 ,(lambda (player game)
(with-ff-money-action (player game)
(equipment-payout 'tractor player 3000 (*game*))))
#f)
(1 ,(lambda (player game)
(if (player-has-asset? 'harvester player)
(with-ff-money-action (player game)
(for-each (lambda (from-player)
(when (not (eq? player from-player))
(when (not (player-has-asset? 'harvester from-player))
(safe-set! (player-cash from-player)
(- (player-cash from-player) 2000))
(safe-set! (player-cash player)
(+ (player-cash player) 2000)))))
(game-players (*game*))))
'()))
#f)
(1 ,(lambda (player game)
((make-player-stat 'tax-person 1) player)
(push! (make-player-year-rule 5 '((?p ?any harvest-mult 0) (?p ?crop)))
(player-year-rules player))
'())
#t)
(1 ,(lambda (player game)
`(((?action . ff-uncle-bert) (?value . #f))))
#f)
(1 ,(lambda (player game)
(with-ff-money-action (player game)
(equipment-payout 'harvester player 2500
(*game*))))
#f)
(1 ,(lambda (player game)
(push! (make-player-year-rule 6 `((?p cows harvest-mult 1.5) (?p cows)))
(player-year-rules player))
(push! (make-player-year-rule 7 `((?p cows harvest-mult 1.5) (?p cows)))
(player-next-year-rules player))
'())
#t
cows-15)
(1 ,(lambda (player game)
(with-ff-money-action (player game) ((make-player-gains 2000) player)))
#f)
(1 ,(lambda (player game)
(when (< (player-space player) 26)
(push! (make-player-year-rule 7 '((?p cherries harvest-mult 0.5) (?p fruit)))
(player-year-rules player))
(push! (make-player-year-rule
8
`((?p cherries player-action-post-harvest
(remove-farmers-fate-from-hand cherries-05))
(?p fruit)))
(player-year-rules player)))
(push! (make-player-year-rule
8
`((?d player-action ?p
(make-remove-farmers-fate-after cherries-05 26))))
(player-year-rules player))
'())
#t
cherries-05)
(1 ,(lambda (player game)
(let ((cows (player-asset 'cows player))
(ridge-cows (cows-on-ridges player)))
(if (> cows ridge-cows)
(let ((slaughtered-cows (- cows ridge-cows)))
(safe-set! (player-assets player)
(alist-update 'cows (- (alist-ref 'cows (player-assets player)) (- cows ridge-cows))
(player-assets player)))
`(((?action . info)
(?value . ,(conc slaughtered-cows
" cows slaughtered on your farm.")))))
'())))
#f)
(1 ,(lambda (player game)
(with-ff-money-action (player game)
((make-player-pays-per-unit 'fruit 1000) player)))
#f)
(1 ,(lambda (player game)
(with-ff-money-action (player game) ((make-semi-annual-interest-due) player)))
#f)))
(define (setup-farmers-fates shuffle?)
(let ((cards (farmers-fate-spec-list->farmers-fate-cards *farmers-fates-specs* *ff-text*)))
(if shuffle?
(shuffle cards)
cards)))
(define *farmers-fates-cards*
(farmers-fate-spec-list->farmers-fate-cards *farmers-fates-specs* *ff-text*))
;; (define *farmers-fates* (setup-farmers-fates))
(define (operating-expenses-spec->operating-expenses-card spec id)
`((contents . ,(sxml->html* (list-ref spec 0)))
(total . #f)
(type . "operating-expense")
(crop . #f)
(summary . ,(conc "Operating Expense: " (strip-tags (list-ref spec 0))))
(id . ,id)
(title . "Operating Expense:")
(action . ,(list-ref spec 2))))
(define (operating-expenses-spec-list->operating-expenses-cards operating-expenses oe-text)
(let ((id 2000))
(append-map (lambda (spec text)
(map (lambda (x)
(set! id (+ id 1))
(operating-expenses-spec->operating-expenses-card
(cons text spec) id))
(iota (list-ref spec 0))))
operating-expenses oe-text)))
(define *operating-expenses-specs*
`((2 ,(lambda (player)
(let ((to-pay (* (player-acres player) 100)))
(safe-set! (player-cash player)
(- (player-cash player) to-pay)))))
(2 ,(lambda (player)
(equipment-payout 'harvester player 2000 (*game*))))
(2 ,(lambda (player)
(equipment-payout 'tractor player 2000 (*game*))))
(1 ,(make-player-pays-per-unit 'cows 100))
(2 ,(make-player-pays 500))
(1 ,(make-player-pays 1500))
(2 ,(make-player-pays 1000))
(2 ,(make-semi-annual-interest-due))
(2 ,(make-player-pays 1000))
(1 ,(make-player-pays 500))
(1 ,(make-player-pays-per-unit 'grain 100))
(2 ,(make-player-pays 3000))
(2 ,(make-player-pays 500))
(1 ,(lambda (player)
(when (player-has-asset? 'cows player)
(safe-set! (player-cash player) (- (player-cash player) 500)))))
(1 ,(make-player-pays 1500))))
(define (setup-operating-expenses)
(shuffle (operating-expenses-spec-list->operating-expenses-cards
*operating-expenses-specs* *oe-text*)))
(define *operating-expense-cards*
(operating-expenses-spec-list->operating-expenses-cards
*operating-expenses-specs* *oe-text*))
(define *total-operating-expenses*
(length (operating-expenses-spec-list->operating-expenses-cards
*operating-expenses-specs* *oe-text*)))
(define (draw-operating-expense game)
(let ((card (list-ref (game-operating-expenses game)
(game-operating-expense-index game))))
(if (= (+ (game-operating-expense-index game) 1) *total-operating-expenses*)
(safe-set! (game-operating-expense-index game) 0)
(safe-set! (game-operating-expense-index game)
(+ (game-operating-expense-index game) 1)))
card))
(define *months*
'(dec4 jan1 jan2 jan3 jan4 feb1 feb2 feb3 feb4 mar1 mar2 mar3 mar4 apr1 apr2 apr3 apr4 may1 may2 may3 may4 jun1 jun2 jun3 jun4 jul1 jul2 jul3 jul4 jul5 aug1 aug2 aug3 aug4 sep1 sep2 sep3 sep4 sep5 oct1 oct2 oct3 oct4 nov1 nov2 nov3 nov4 dec1 dec2 dec3))
(define (pays amount) (lambda (n) (- n amount)))
(define (gains amount) (lambda (n) (+ n amount)))
(define (player-crop-rule player crop)
(if (> (alist-ref crop (player-assets player) eqv? 0) 0) `(((tom ,crop))) '()))
(define (aug4-action player)
(when (not (already-harvested? 'wheat player))
((make-player-pays-per-unit 'grain 50) player)))
(define (make-player-stat stat amount)
(lambda (p)
(safe-set! (player-stats p)
(alist-update stat (+ (alist-ref stat (player-stats p)) amount)
(player-stats p)))))
(define (get-actions player space)
(let ((res '()))
(let loop ((a
(prolog+meta
`(((dec4 money ?p ,(gains 1000)))
((jan1 player-action ?p ,(make-semi-annual-interest-due)))
((jan2 draw ?p otb))
((jan3 money ?p ,(pays 500)) (?p cows))
((jan4 add-rule ?p ,(make-player-year-rule 9 '((?p hay harvest-mult 2) (?p hay)))))
((jan4 player-action ?p ,(lambda (p) (safe-set! (player-hay-doubled p) #t))))
((feb1 money ?p ,(gains 1000)))
((feb2 draw ?p farmers-fate))
((feb3 goto ?p apr2))
((feb4 draw ?p otb))
((mar1 money ?p ,(pays 2000)))
((mar2 money ?p ,(pays 500)))
((mar3 goto ?p jan2))
((mar3 player-action ?p ,(make-player-stat 'back 1)))
((mar4 money ?p ,(pays 2000)) (?p fruit))
((apr1 draw ?p otb))
((apr2 add-rule ?p ,(make-player-year-rule
10 '((?p corn harvest-mult 2) (?p grain)))))
((apr2 player-action ?p ,(lambda (p) (safe-set! (player-corn-doubled p) #t))))
((apr2 money ?p ,(gains 5000)) (?p birthday))
((apr3 money ?p ,(pays 500)))
((apr4 money ?p ,(pays 1000)))
((may1 money ?p ,(gains 500)))
((may2 money ?p ,(pays 500)))
((may3 money ?p ,(gains 1000)))
((may3 harvest ?p hay) (?p hay))
((may4 draw ?p otb))
((may4 harvest ?p hay) (?p hay))
((jun1 harvest ?p hay) (?p hay))
((jun1 harvest-mult ?p 0.5) (?p hay))
((jun2 money ?p ,(gains 500)))
((jun2 harvest ?p hay) (?p hay))
((jun3 harvest ?p cherries) (?p fruit))
((jun3 harvest-mult ?p 0.5) (?p fruit))
((jun4 harvest ?p cherries) (?p fruit))
((jun4 draw ?p farmers-fate))
((jul1 harvest ?p cherries) (?p fruit))
((jul2 harvest ?p hay) (?p hay))
((jul2 harvest-mult ?p 2) (?p hay))
((jul3 harvest ?p hay) (?p hay))
((jul3 draw ?p otb))
((jul4 harvest ?p hay) (?p hay))
((jul4 goto ?p sep4))
((jul5 player-action ?p ,(make-player-gains-per-unit 'grain 50)))
((jul5 harvest ?p wheat) (?p grain))
((aug1 harvest ?p wheat) (?p grain))
((aug1 goto ?p feb4))
((aug1 player-action ?p ,(make-player-stat 'pro 1)))
((aug1 player-action-post-harvest ?p ,finish-year))
((aug2 harvest ?p wheat) (?p grain))
((aug2 money ?p ,(gains 1000)) (?p harvester))
((aug3 money ?p ,(gains 500)))
((aug3 harvest ?p wheat) (?p grain))
((aug4 harvest ?p wheat) (?p grain))
((aug4 player-action ?p ,aug4-action))
((sep1 harvest ?p hay) (?p hay))
((sep1 goto ?p nov3) (?p tractor))
((sep2 harvest ?p hay) (?p hay))
((sep2 draw ?p otb))
((sep3 harvest ?p cows) (?p cows))
((sep3 harvest-mult ?p 0.5) (?p cows))
((sep4 harvest ?p cows) (?p cows))
((sep4 money ?p ,(gains 500)))
((sep5 harvest ?p cows) (?p cows))
((sep5 money ?p ,(pays 2000)) (?p fruit))
((oct1 money ?p ,(gains 500)))
((oct1 harvest ?p cows) (?p cows))
((oct2 draw ?p farmers-fate))
((oct2 harvest ?p hay) (?p hay))
((oct3 draw ?p otb))
((oct3 harvest ?p hay) (?p hay))
((oct4 draw ?p farmers-fate))
((oct4 harvest ?p fruit) (?p fruit))
((nov1 draw ?p otb))
((nov1 harvest ?p fruit) (?p fruit))
((nov2 money ?p ,(gains 500)))
((nov2 harvest ?p fruit) (?p fruit))
((nov3 money ?p ,(gains 1000)))
((nov3 harvest ?p fruit) (?p fruit))
((nov4 money ?p ,(pays 1000)) (?p fruit))
((nov4 harvest ?p corn) (?p grain))
((dec1 money ?p ,(gains 500)))
((dec1 harvest ?p corn) (?p grain))
((dec2 draw ?p farmers-fate))
((dec2 harvest ?p corn) (?p grain))
((dec3 money ?p ,(gains 1000)))
,@(map (lambda (x) (alist-ref 'rule x)) (player-year-rules player))
((?date harvest-mult ?p ?val) (?date harvest ?p ?crop) (?p ?crop harvest-mult ?val))
((?date player-action-post-harvest ?p ?val) (?date harvest ?p ?crop) (?p ?crop player-action-post-harvest ?val))
,@(player-crop-rule player 'cows)
,@(player-crop-rule player 'fruit)
,@(player-crop-rule player 'hay)
,@(player-crop-rule player 'grain)
,@(player-crop-rule player 'tractor)
,@(player-crop-rule player 'harvester)
,@(player-crop-rule player 'birthday))
`((,(list-ref *months* space) ?action tom ?value)))))
(if a
(begin (set! res (cons a res)) (loop (amb+)))
res))))
(define (normalize-crop crop)
(cond ((or (eq? crop 'wheat) (eq? crop 'corn))
'grain)
((eq? crop 'cherries)
'fruit)
((member crop '(ridge1 ridge2 ridge3 ridge4))
'cows)
(else crop)))
;; First number is the divisor, the rest are the harvest values
(define *harvest-table*
`((hay . (10 400 600 1000 1500 2200 3000))
(fruit . (5 2000 3500 6000 9000 13000 17500))
(grain . (10 750 1500 2500 3750 5250 7000))
(cows . (10 1400 2000 2800 3800 5000 7500))))
(define (get-harvest-amounts crop)
(let ((amounts (alist-ref crop *harvest-table*)))
(if (null? amounts)
(error (conc "amounts null? for " crop))
amounts)))
(define (farming-round n)
(inexact->exact (+ n (modulo n 100))))
(define (farming-round-down n)
(inexact->exact (- n (modulo n 100))))
(define (harvest-actions actions)
(filter (lambda (action) (eq? (alist-ref '?action action) 'harvest))
actions))
(define (harvest-action-of-type? crop action)
(eq? (alist-ref '?value action) crop))
(define (already-harvested? crop player)
;; if previous space was within 3 spaces (or 4 for wheat)
;; then check if it is the same crop
;; if it is then don't harvest again
;; this is a hack based on the layout of the board
(if (<= (- (player-space player) (player-previous-space player))
(if (eq? crop 'wheat) 4 3))
(let ((actions (harvest-actions (get-actions player (player-previous-space player)))))
(if (null? actions)
#f
(harvest-action-of-type? crop (car actions))))
#f))
(define (draw-otb player game)
(if (null? (game-otbs game))
#f
(receive (new-otb remaining-otbs) (split-at (game-otbs game) 1)
(safe-set! (player-otbs player) (cons (car new-otb) (player-otbs player)))
(safe-set! (game-otbs game) remaining-otbs)
(car new-otb))))
(define (do-action action player)
(let ((a (alist-ref '?action action))
(game (*game*)))
(cond ((eq? a 'money)
(safe-set! (player-cash player)
((alist-ref '?value action) (player-cash player))))
((eq? a 'add-rule)
(when (not (member (alist-ref 'id (alist-ref '?value action))
(map (lambda (x) (alist-ref 'id x))
(player-year-rules player))))
(safe-set! (player-year-rules player)
(cons (alist-ref '?value action) (player-year-rules player)))))
((eq? a 'goto)
(safe-set! (player-previous-space player) (player-space player))
(safe-set! (player-space player)
(let ((month (alist-ref '?value action)))
(list-index (lambda (x) (eq? x month)) *months*))))
((and (eq? a 'draw) (eq? (alist-ref '?value action) 'otb))
(if (not (null? (game-otbs game)))
(draw-otb player game)
#f))
((and (eq? a 'draw) (eq? (alist-ref '?value action) 'farmers-fate))
(receive (new-ff remaining-ffs) (split-at (game-farmers-fates game) 1)
(if (alist-ref 'hold-card (car new-ff))
(begin (push! (car new-ff) (player-farmers-fates player))
(safe-set! (game-farmers-fates game) remaining-ffs))
(safe-set! (game-farmers-fates game) (append remaining-ffs new-ff)))
`((actions . ,((alist-ref 'action (car new-ff)) player game))
(contents . ,(alist-ref 'contents (car new-ff))))))
((or (eq? a 'player-action) (eq? a 'player-action-post-harvest))
(let ((value (alist-ref '?value action)))
(if (procedure? value)
(value player)
(let ((action-proc (alist-ref (car value) *action-map*)))
(if (procedure? action-proc)
(apply action-proc player (cdr value))
(print (conc "unknown action value: " value)))))))
((eq? a 'harvest-mult)
(safe-set! (player-harvest-mult player)
(* (player-harvest-mult player) (alist-ref '?value action))))
((eq? a 'harvest)
(let* ((crop (normalize-crop (alist-ref '?value action)))
(acres (alist-ref crop (player-assets player)))
(harvest-amounts (get-harvest-amounts crop))
(rolled (+ (random 6) 1))
(harvest-mult (player-harvest-mult player))
(income
(farming-round
;; add one to skip the divisor
(* (list-ref harvest-amounts rolled)
(/ acres (car harvest-amounts))
(player-harvest-mult player)))))
(if (not (already-harvested? (alist-ref '?value action) player))
(begin
((make-player-stat 'num-harvests 1) player)
((make-player-stat 'harvest-rolls rolled) player)
(safe-set! (player-cash player)
(+ (player-cash player) income))
(safe-set! (player-harvest-mult player) 1)
(let ((operating-expense (draw-operating-expense game))
(previous-cash (player-cash player))
(other-previous-cash (map (lambda (p)
(cons p (player-cash p)))
(filter
(lambda (p)
(not (string=? (player-name p)
(player-name player))))
(game-players game)))))
((alist-ref 'action operating-expense) player)
`((rolled . ,rolled)
(rolls . ,(list->vector (make-rolls 22)))
(income . ,income)
(harvestMult . ,harvest-mult)
(operatingExpense . ,(alist-ref 'contents operating-expense))
(operatingExpenseValue . ((,(string->symbol (player-name player))
. ,(- (player-cash player)
previous-cash))
,@(map (lambda (p/c)
(let ((p (car p/c)))
`(,(string->symbol (player-name p))
. ,(- (player-cash p)
(cdr p/c)))))
(filter
(lambda (p/c)
(not (= 0
(- (player-cash (car p/c))
(cdr p/c)))))
other-previous-cash))))
(crop . ,(symbol->string (alist-ref '?value action)))
(acres . ,acres))))
'nothing))))))
(define *last-actions* '())
(define (do-all-actions player)
(for-each
(lambda (x)
(do-action x player)
(if (eq? (alist-ref '?action x) 'goto)
(begin (safe-set! (player-harvest-mult player) 1)
(do-all-actions player))))
(let ((r (sort-actions (get-actions player (player-space player)))))
(set! *last-actions* r)
(safe-set! (player-harvest-mult player) 1)
r)))
(define (sort-actions actions)
(sort actions
(lambda (x y)
(let ((a (alist-ref '?action x)) (b (alist-ref '?action y))
(av (alist-ref '?value x)) (bv (alist-ref '?value y)))
(cond ((eq? av 'otb) #t)
((eq? bv 'otb) #f)
((eq? a 'money) #t)
((eq? b 'money) #f)
((eq? a 'player-action) #t)
((eq? b 'player-action) #f)
((eq? a 'harvest-mult) #t)
((eq? b 'harvest-mult) #f)
((eq? a 'harvest) #t)
((eq? b 'harvest) #f)
((eq? a 'player-action-post-harvest) #t)
((eq? b 'player-action-post-harvest) #f)
((eq? av 'farmers-fate) #t)
((eq? bv 'farmers-fate) #f)
((eq? a 'add-rule) #t)
((eq? b 'add-rule) #f)
((eq? a 'goto) #t)
((eq? b 'goto) #f)
(else #f))))))
(define (first-game)
(car (app-games *app*)))
(define (gp i)
(list-ref (game-players (first-game)) i))
(define (gn name)
(find (lambda (p) (equal? (player-name p) name))
(game-players (first-game))))
(define (gnb name)
(let ((player (gn name)))
(safe-set! (player-assets player)
(alist-update 'birthday 1 (player-assets player)))))
(cond-expand
(geiser
'())
(csi
(run-awful)
(repl))
(compiling ;; production
(run-awful)
(repl)
;; (thread-join! *server-thread*)
))
;; TODO
;; make sure two players can't have the same name
;; "your turn to roll" showing up on mobile when on action screen
;; bug on display for uncle berts farm
;; Error: (mailbox-send!) bad argument type - not a mailbox: "redhead91
;; Uncaught TypeError: Cannot read property 'toFixed' of undefined
;; at St (app.0f8d4f4543faaee5dff1.js:1377)
;; at app.0f8d4f4543faaee5dff1.js:1457
;; at Object.y [as dispatch] (vendors.bef6ac3591b4d9cb3c76.js:8936)
;; at app.0f8d4f4543faaee5dff1.js:1226
;; at eu (vendors.bef6ac3591b4d9cb3c76.js:12601)
;; at WebSocket.pt (app.0f8d4f4543faaee5dff1.js:1127)
;; Uncaught TypeError: Cannot read property 'krispy kreme' of undefined
;; at app.0f8d4f4543faaee5dff1.js:1461
;; at Object.y [as dispatch] (vendors.bef6ac3591b4d9cb3c76.js:8936)
;; at app.0f8d4f4543faaee5dff1.js:1226
;; at eu (vendors.bef6ac3591b4d9cb3c76.js:12601)
;; at WebSocket.pt (app.0f8d4f4543faaee5dff1.js:1127)
Reference in New Issue View Git Blame Copy Permalink