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 '5e8be6e416'
${ noResults }
farm/src/server/farm.scm

1688 lines
73 KiB
Scheme
Raw Normal View History Unescape Escape

Initial public release.
5 years ago
;;; 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 uri-common
srfi-18 medea numbers spiffy spiffy-cookies
intarweb pll sxml-transforms websockets miscmacros)
Cleaning up Scheme code integration with different dev/prod modes.
5 years ago
(cond-expand
(geiser
(include "../../assets/game/acf/game"))
(else
(include "game")))
Initial public release.
5 years ago
(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-class <player> ()
((cash initform: 5000 accessor: player-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)
(assets initform:
'((hay . 10) (grain . 10) (fruit . 0) (cows . 0)
(harvester . 0) (tractor . 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)
(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)
(trade initform: '() accessor: player-trade)
(last-updated initform: 0 accessor: player-last-updated)
(last-cash initform: 5000 accessor: player-last-cash)
(last-ui-action initform: #f accessor: player-last-ui-action)))
(define-class <game> ()
((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)
(audit-threshold initform: 250000 accessor: game-audit-threshold)
(state initform: 'playing accessor: game-state)
(name initform: "game" accessor: game-name)
(turn initform: 1 accessor: game-turn)
(actions initform: '() accessor: game-actions)
(last-ui-action initform: #f accessor: game-last-ui-action)))
(define-class <app> ()
((games initform: '() accessor: app-games)))
(define (player->sexp player)
`((cash . ,(player-cash player))
(debt . ,(player-debt player))
(space . ,(player-space player))
(previous-space . ,(player-previous-space player))
(state . ,(player-state player))
(assets . ,(player-assets player))
(ridges . ,(player-ridges player))
(harvest-mult . ,(player-harvest-mult player))
(player-otbs . ,(player-otbs player))
(farmers-fates . ,(map (cut alist-ref 'id <>) (player-farmers-fates player)))
(year-rules . ,(player-year-rules player))
(next-year-rules . ,(player-next-year-rules player))
(color . ,(player-color player))
(name . ,(player-name player))
(trade . ())
(last-updated . 0)
(last-cash . ,(player-cash player))))
(define (sexp->player x)
(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*)))
(fold (lambda (k r) (cons k (cons (alist-ref k x) r)))
'()
'(cash debt space previous-space state assets ridges
harvest-mult otbs
year-rules next-year-rules
color name trade last-updated last-cash))))
(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 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))
(define update-condition-variable (make-condition-variable))
(define update-mutex (make-mutex))
(access-log (current-output-port))
(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))))
(set! (game-colors game) (cdr (game-colors game)))
color))
(define (add-player-to-game game color name)
(let ((player (make <player> 'cash 5000 'color color
'name name
'state (if (= (length (game-players game)) 0)
'pre-turn 'turn-ended))))
(set! (game-players game) (append (game-players game) (list player)))
player))
(define (all-players-finished game)
(null? (filter (lambda (p)
(not (eq? (player-state p) 'finished-game)))
(game-players game))))
(define (next-player game player)
(let ((tail (cdr (filter (lambda (p)
(not (eq? (player-state p) 'finished-game)))
(find-tail (cut eq? <> player) (game-players game))))))
(if (null? tail)
(car (game-players game))
(car tail))))
(define (advance-turn game player)
(if (all-players-finished game)
(set! (game-state game) 'finished)
(begin (set! (player-state player) 'turn-ended)
(set! (player-state (next-player game player)) 'pre-turn)
(set! (game-turn game) (+ (game-turn game) 1)))))
(define (current-players-turn game)
(let loop ((players (game-players game)))
(cond ((null? players) ;; game finished use player 0 as a dummy player
(car (game-players game)))
((or (eq? (player-state (car players)) 'turn-ended)
(eq? (player-state (car players)) 'finished-game))
(loop (cdr players)))
(else
(car players)))))
(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)
(set! (player-otbs player) (cons (car new-otb) (player-otbs player)))
(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 (player->list p)
`((player . ((assets . ,(player-assets p))
(ridges . ,(player-ridges p))
(cash . ,(player-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))))
(color . ,(symbol->string (player-color p)))
(name . ,(player-name p))
(trade . ,(player-trade p))
(lastCash . ,(player-last-cash p))))))
(define (game->list g player)
`((game . ((messages . ,(list->vector (reverse (game-messages g))))
(currentPlayer . ,(player-name (current-players-turn 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))
(auditThreshold . ,(game-audit-threshold g))
(state . ,(symbol->string (game-state g)))
(turn . ,(game-turn g))))))
(define (push-message player msg #!key (game (session-ref (sid) 'game)))
(if player
(set! (game-messages game) (cons `#(,(player-name player)
,(game-turn game)
,msg)
(game-messages game)))
;; (set! (game-messages game) (cons (conc (player-name player) ": " msg)
;; (game-messages game)))
(set! (game-messages game) (cons `#(#f ,(game-turn game) ,msg)
(game-messages game)))
;; (set! (game-messages game) (cons msg (game-messages game)))
))
(define (buy-crop crop unnormalized-crop amount cash-value player game)
;; TODO bug when buying ridge, the full amount isn't accounted for
;; because 'crop' is 'cows' not 'ridge-cows' or the ridge
(let ((total-cost (* amount (alist-ref 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)))
(push-message player (conc "Ridge already leased."))
#f)
((> (player-space player) 14)
(push-message player (conc "Crops may only be bought in winter."))
#f)
((> cash-value (player-cash player))
(push-message player (conc "Could not buy " unnormalized-crop ". Not enough cash."))
#f)
((< cash-value (* total-cost 0.2))
(push-message player
(conc "Could not buy " unnormalized-crop ". Not enough down payment."))
#f)
((> (- total-cost cash-value) (- 50000 (player-debt player)))
(push-message player
(conc "Could not buy " unnormalized-crop ". Not enough credit."))
#f)
(else
(let ((assets (player-assets player)))
(set!
(player-assets player)
(alist-update crop (+ (alist-ref crop assets) amount) assets))
(set! (player-cash player) (- (player-cash player) cash-value))
(set! (player-debt player)
(+ (player-debt player) (- total-cost cash-value)))
(when (member unnormalized-crop ridges)
(set! (player-ridges player)
(alist-update unnormalized-crop amount (player-ridges player))))
(push-message player (conc "You bought " amount " " crop "."))
#t)))))
(define (finish-year player #!optional (collect-wages #t))
(let ((game (session-ref (sid) 'game)))
(when collect-wages
(set! (player-cash player)
(+ (player-cash player) 5000))
(push-message player
(conc "You earned $5,000 from your city job!"))
(set! (game-actions game)
(cons '((?action . info)
(?value . "You earned $5,000 from your city job!"))
(game-actions game))))
(when (game-called-audit game)
(set! (player-state player) 'finished-game)
(advance-turn game player)
;; advance turn resets state back to turn ended
(set! (player-state player) 'finished-game))
(set! (player-year-rules player) (player-next-year-rules player))
(set! (player-next-year-rules player) '())
(when (not (null? (player-farmers-fates player)))
(set! (game-farmers-fates game)
(append (game-farmers-fates game) (player-farmers-fates player)))
(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)))
(set! (player-farmers-fates player)
(list (find (lambda (c) (eq? (alist-ref 'internal-id c) 'cows-15))
(game-farmers-fates game))))
(set! (game-farmers-fates game)
(filter (lambda (c) (not (eq? (alist-ref 'internal-id c) 'cows-15)))
(game-farmers-fates game)))
(push! `((?p cows player-action-post-harvest
,(make-remove-farmers-fate-from-hand 'cows-15))
(?p cows))
(player-year-rules player))
(push! `((?d player-action ?p
,(make-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))
(player-otbs player))
(find (lambda (card)
(= (alist-ref 'id card eqv? -1) id))
(player-otbs other-player)))
r
(cons id r)))
'()
cards)))
(cond (basics
(push-message player (conc "You don't have enough " basics " to trade!"))
#f)
(other-basics
(push-message player (conc (player-name other-player)
" doesn't have enough " other-basics " to trade!"))
#f)
(ridges
(push-message player (conc ridges " ridge not available to trade!"))
#f)
((< (+ (player-cash player) (alist-ref 'money params eqv? 0)) 0)
(push-message player "You don't have enough cash to trade!")
#f)
((< (+ (player-cash other-player) (* (alist-ref 'money params eqv? 0) -1)) 0)
(push-message player (conc (player-name other-player)
" doesn't have enough cash to trade!"))
#f)
((not (null? missing-cards))
(push-message player (conc "Nobody has cards: "
(string-intersperse
(map number->string missing-cards)
", ") "."))
#f)
(else
other-player))))
(define (propose-trade game player params)
(let ((other-player (validate-trade game player params)))
(if other-player
(let ((to-trade (filter (lambda (x) (and (not (equal? (cdr x) 0))
(not (equal? (cdr x) ""))
(cdr x)))
params)))
(push-message player
(conc "Trade proposed to " (player-name other-player) "!"))
(set! (player-trade other-player)
(append `((player . ,(player-name player))
(originator . ,(player-name player)))
to-trade))
(set! (player-trade player)
(append `((player . ,(player-name other-player))
(originator . ,(player-name player)))
to-trade))
#t)
#f)))
(define (otb-by-id player id)
(find (lambda (card)
(= (alist-ref 'id card eqv? -1) id))
(player-otbs player)))
(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)))
(set!
(player-assets originator)
(alist-update crop (+ (alist-ref crop assets) amount)
assets))
(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
(set! (player-ridges originator)
(alist-update ridge
(alist-ref ridge (player-ridges player))
(player-ridges originator)))
(set! (player-ridges player)
(alist-update ridge 0 (player-ridges player))))
(begin
(set! (player-ridges player)
(alist-update ridge
(alist-ref ridge (player-ridges originator))
(player-ridges player)))
(set! (player-ridges originator)
(alist-update ridge 0 (player-ridges originator)))))))
(loop (cdr ridges))))
(when (alist-ref 'money params)
(set! (player-cash player)
(+ (player-cash player) (* (alist-ref 'money params) -1)))
(set! (player-cash originator)
(+ (player-cash originator) (alist-ref 'money params))))
(when (alist-ref 'cards params)
(for-each
(lambda (id)
(if (otb-by-id player id)
(let ((otb (otb-by-id player id)))
(set! (player-otbs player)
(filter (lambda (x) (not (= id (alist-ref 'id x))))
(player-otbs player)))
(set! (player-otbs originator)
(cons otb (player-otbs originator))))
(let ((otb (otb-by-id originator id)))
(set! (player-otbs originator)
(filter (lambda (x) (not (= id (alist-ref 'id x))))
(player-otbs originator)))
(set! (player-otbs player)
(cons otb (player-otbs player))))))
cards))
(set! (player-trade originator) '())
(set! (player-trade player) '()))
#f)))
(define (call-audit game player)
(if (game-called-audit game)
(push-message player (conc (player-name (game-called-audit game))
" already called audit!"))
(begin (set! (game-called-audit game) player)
(push-message player (conc (player-name player) " has called an audit!")))))
(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)
(push-message #f "Game over!")
(for-each (lambda (p i)
(push-message #f
(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)))
(define (create-ws-response player event misc)
(append `((event . ,event) ,@misc)
(player->list player)
(game->list (session-ref (sid) 'game) player)))
(define (create-start-response event)
`((event . ,event)
(games . ((games . ,(list->vector
(map (lambda (game)
`((name . ,(game-name game))
(colors . ,(list->vector
(map symbol->string (game-colors game))))
(players . ,(list->vector
(map player-name (game-players game))))))
(app-games *app*))))))))
(define (set-ui-action! action game)
(set! (game-last-ui-action game) action))
(define (ui-action game)
(game-last-ui-action game))
(define (new-ui-action? player action)
(not (eq? (player-last-ui-action player) action)))
(define *next-roll* #f)
(define (process-message player game type msg)
(when game
(set! (game-messages game) '())
(set! (player-last-cash player) (player-cash player)))
(cond ((string=? type "roll")
(let ((num (+ (random 6) 1)))
(when *next-roll* (set! num *next-roll*))
(set! (player-previous-space player)
(player-space player))
(set! (player-space player)
(+ (player-space player) num))
(set! (player-state player) 'mid-turn)
(push-message player (conc "You rolled a " num))
(when (> (player-space player) 48)
(set! (player-space player)
(- (player-space player) 49)))
(when (and (> (player-previous-space player) 40)
(< (player-space player) 10))
(finish-year player))
(when (eq? (game-state game) 'finished)
(do-end-of-game game)) ;; TODO check
(set! (player-harvest-mult player) 1)
(let ((resp `((from . ,(player-previous-space player))
(to . ,(player-space player)))))
(set! (game-actions game)
(append (game-actions game)
`(((?action . move) (?value . ,resp)))
(sort-actions (get-actions player (player-space player)))))
(set-ui-action! `((action . "roll")
(value . ,resp))
game)
(create-ws-response player "action" `((action . "roll") (value . ,resp))))))
((and (string=? type "next-action")
(not (eq? (player-state player) 'turn-ended)))
(let loop ()
(if (null? (game-actions game))
(begin
(set-ui-action! `((action . #f) (value . #f)) game)
(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)
(let ((otb (do-action action player)))
(if otb
(begin
(set! (game-actions game) (cdr (game-actions game)))
(set-ui-action! `((action . "otb")
(value . ,(alist-ref 'contents otb)))
game)
(create-ws-response player "action"
`((action . "otb")
(value . ,(alist-ref 'contents otb)))))
(loop))))
((eq? name 'move)
(set! (game-actions game) (cdr (game-actions game)))
(set-ui-action! `((action . "move") (value . ,value)) game)
(create-ws-response player "action"
`((action . "move") (value . ,value))))
((eq? name 'harvest)
(let ((res (do-action action player)))
(set! (game-actions game) (cdr (game-actions game)))
(if (eq? res 'nothing)
(loop)
(begin
(set-ui-action!
`((action . "harvest") (value . ,res)) game)
(create-ws-response player
"action"
`((action . "harvest")
(value . ,res)))))))
((or (eq? name 'money) (eq? name 'player-action))
;; all current player-actions have only a cash effect
(let ((previous-cash (player-cash player)))
(do-action action player)
(set! (game-actions game)
(cdr (game-actions game)))
(set-ui-action! `((action . "money")
(value . ,(- (player-cash player)
previous-cash)))
game)
(create-ws-response player "action"
`((action . "money")
(value . ,(- (player-cash player)
previous-cash))))))
((or (eq? name 'harvest-mult)
(eq? name 'player-action-post-harvest))
(set! (game-actions game) (cdr (game-actions game)))
(do-action action player)
(loop))
((eq? value 'farmers-fate)
(let ((ff (do-action action player)))
(set! (game-actions game)
(append (alist-ref 'actions ff)
(cdr (game-actions game))))
(set-ui-action! `((action . "farmers-fate")
(value . ,(alist-ref 'contents ff)))
game)
(create-ws-response player "action"
`((action . "farmers-fate")
(value . ,(alist-ref 'contents ff))))))
((eq? name 'ff-money)
(set! (game-actions game) (cdr (game-actions game)))
(set-ui-action! `((action . "money") (value . ,value))
game)
(create-ws-response player "action"
`((action . "money")
(value . ,value))))
((eq? name 'ff-uncle-bert)
(set! (game-actions game) (cdr (game-actions game)))
(set-ui-action! `((action . "ff-uncle-bert") (value . #f))
game)
(create-ws-response player "action"
`((action . "ff-uncle-bert")
(value . #f))))
((eq? name 'info)
(set! (game-actions game) (cdr (game-actions game)))
(set-ui-action! `((action . "info") (value . ,value)) game)
(create-ws-response player "action"
`((action . "info")
(value . ,value))))
((eq? name 'goto)
(do-action action player)
(set! (player-harvest-mult player) 1)
(set! (game-actions game)
(append (sort-actions (get-actions player (player-space player)))
(cdr (game-actions game))))
(let ((resp `((from . ,(player-previous-space player))
(to . ,(player-space player)))))
(set-ui-action! `((action . "goto")
(value . ,resp))
game)
(create-ws-response player "action"
`((action . "goto")
(value . ,resp)))))
((eq? name 'add-rule)
(do-action action player)
(set! (game-actions game) (cdr (game-actions game)))
(loop))
(else ;; TODO make error
(create-ws-response player "action" `((action . ,name)))))))))
((string=? type "buy")
(let* ((id (alist-ref 'id msg))
(otb (find (lambda (x) (= id (alist-ref 'id x)))
(player-otbs player))))
(if
(buy-crop (normalize-crop
(string->symbol (alist-ref 'crop otb)))
(string->symbol (alist-ref 'crop otb))
(alist-ref 'amount otb)
(* (alist-ref 'cash msg) 1000)
player
game)
(set! (player-otbs player)
(filter (lambda (x) (not (= id (alist-ref 'id x))))
(player-otbs player)))))
(create-ws-response player "buy" '()))
((string=? type "buy-uncle-bert")
(set! (player-cash player) (- (player-cash player) 10000))
(set! (player-assets player)
(alist-update 'hay (+ (alist-ref 'hay (player-assets player)) 10)
(player-assets player)))
(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) amount) 50000)
(push-message player "Exceeds max loan.")
(begin (set! (player-cash player) (+ (player-cash player) amount))
(set! (player-debt player) (+ (player-debt player) amount))
(push-message player (conc "Loan of $" amount " taken out."))))
;; repaying loan
(cond ((> amount (player-cash player))
(push-message player "Not enough cash to repay loan."))
((> amount (player-debt player))
(push-message player "Repayment exceeds total loan amount."))
(else
(set! (player-cash player) (+ (player-cash player) amount))
(set! (player-debt player) (+ (player-debt player) amount))
(push-message player (conc "Loan of $" (abs amount) " repayed."))))
))
(create-ws-response player "loan" '()))
((string=? type "trade")
(propose-trade game player (alist-ref 'parameters msg))
(create-ws-response player "trade" '()))
((string=? type "trade-accept")
(accept-trade game player)
(create-ws-response player "trade-accepted" '()))
((string=? type "trade-deny")
(push-message player (conc (player-name player) " denied trade with "
(alist-ref 'originator (player-trade player)) "."))
(set! (player-trade (find-player-by-name
game (alist-ref 'originator (player-trade player))))
'())
(set! (player-trade player) '())
(create-ws-response player "trade-denied" '()))
((string=? type "trade-cancel")
(push-message player (conc (player-name player) " cancelled trade with "
(alist-ref 'player (player-trade player)) "."))
(set! (player-trade (find-player-by-name
game (alist-ref 'player (player-trade player))))
'())
(set! (player-trade player) '())
(create-ws-response player "trade-cancelled" '()))
((string=? type "audit")
(call-audit game player)
(create-ws-response player "called-audit" '()))
((string=? type "init")
(create-ws-response player "init" '()))
((string=? type "turn-ended")
(if (>= (player-cash player) 0)
(begin (advance-turn game player)
(create-ws-response player "turn-ended" '()))
(begin (push-message player "Cannot end a turn with negative cash!")
(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)))
(game (make <game> 'colors (filter (cut neq? <> color)
'(green red blue yellow black))
'name (alist-ref 'gameName msg)
'otbs (setup-otbs)
'operating-expenses (setup-operating-expenses)
'farmers-fates (setup-farmers-fates)))
(player (add-player-to-game game
color
(alist-ref 'playerName msg))))
(push! game (app-games *app*))
(session-set! (sid) 'player player)
(session-set! (sid) 'game game)
(set-startup-otbs game player 2)
(create-start-response "new-game-started")))
((string=? type "join-game")
(let* ((color (string->symbol (alist-ref 'checkedColor msg)))
(name (alist-ref 'gameName msg))
(game (find (lambda (g) (string=? (game-name g) name))
(app-games *app*)))
(player (add-player-to-game game
color
(alist-ref 'playerName msg))))
(set! (game-colors game) (filter (cut neq? <> color) (game-colors game)))
(session-set! (sid) 'player player)
(session-set! (sid) 'game game)
(set-startup-otbs game player 2)
(create-start-response "new-game-started")))
((string=? type "join-as-existing")
(let* ((name (alist-ref 'gameName msg))
(pname (alist-ref 'playerName msg))
(game (find (lambda (g) (string=? (game-name g) name))
(app-games *app*)))
(player (find (lambda (p) (string=? (player-name p) pname))
(game-players game))))
(session-set! (sid) 'player player)
(session-set! (sid) 'game game)
(create-start-response "new-game-started")))
))
(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 . ,(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn))))
(event . "error"))))
(send-message
(json->string
(handle-exceptions
exn
`((exn . ,(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn))))
(event . "error"))
(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
(set! (game-last-updated game) (+ (game-last-updated game) 1))
(set! (player-last-updated player) (game-last-updated game))
(condition-variable-broadcast! update-condition-variable))
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 ()
(let ((game (session-ref (sid) 'game))
(player (session-ref (sid) 'player)))
(let loop ((updated (mutex-unlock! update-mutex update-condition-variable)))
(when (not game)
(set! game (session-ref (sid) 'game)))
(when (not player)
(set! player (session-ref (sid) 'player)))
(when (< (player-last-updated player)
(game-last-updated game))
(handle-exceptions
exn
(send-message
(json->string
`((exn . ,(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn)))))))
(send-message
(json->string
(handle-exceptions
exn
`((exn . ,(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn))))
(event . "error"))
(if (and (new-ui-action? player (ui-action game))
(or (eq? (player-state player) 'turn-ended)
(eq? (player-state player) 'finished-game)))
(begin
(set! (player-last-ui-action player) (ui-action game))
(create-ws-response player
"action"
(ui-action game)))
(create-ws-response player "update" '())))))))
(loop (mutex-unlock! update-mutex update-condition-variable)))))))
(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 emacs interactive development
(set! *awful-thread*
(make-thread
(lambda ()
(start-server)
;; (awful-start (lambda () (void)) port: 8080)
)))
(thread-start! *awful-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? 'harvester player))
(game-players game)))
(define (player-asset-binary-count asset game)
(apply + (map (lambda (player)
(if (player-has-asset? 'harvester 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)
(set! (player-cash player)
(+ (player-cash player) amount-per-player)))
(players-with equipment game)))))
(push-message player (conc "You paid $" amount "!"))
(set! (player-cash player) (- (player-cash player) amount))))
(define (make-player-gains amount)
(lambda (player)
(push-message player (conc "You gained $" amount "!"))
(set! (player-cash player) (+ (player-cash player) amount))))
(define (make-player-pays amount)
(lambda (player)
(push-message player (conc "You paid $" amount "!"))
(set! (player-cash player) (- (player-cash player) amount))))
(define (make-player-pays-per-unit unit amount)
(lambda (player)
(let ((to-pay (* (player-asset (normalize-crop unit) player) amount)))
(push-message player (conc "You paid $" to-pay "!"))
(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)))
(push-message player (conc "You earned $" to-pay "!"))
(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))))))
(push-message player (conc "You paid $" to-pay "!"))
(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 (make-remove-farmers-fate-from-hand id)
(lambda (player)
(let ((game (session-ref (sid) 'game)))
(set! (game-farmers-fates game)
(append (game-farmers-fates game)
(filter (lambda (x) (eq? (alist-ref 'internal-id x) id))
(player-farmers-fates player)))))
(set! (player-farmers-fates player)
(filter (lambda (x) (not (eq? (alist-ref 'internal-id x) id)))
(player-farmers-fates player)))))
(define (make-remove-farmers-fate-after id space)
(lambda (p)
(when (>= (player-space p) space)
((make-remove-farmers-fate-from-hand id) p))))
(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-syntax with-ff-money-action
(syntax-rules (?action ff-money ?value)
((_ (player) body ...)
(let ((previous-cash (player-cash player)))
body ...
`(((?action . ff-money)
(?value . ,(- (player-cash player) previous-cash))))))))
(define *farmers-fates-specs*
;; xxx multiplayer interaction
`((1 ,(lambda (player)
(for-each (lambda (p)
(let ((roll (+ (random 6) 1)))
(if (odd? roll)
(push-message p (conc "You rolled a " roll " and escaped!"))
(begin (push-message p (conc "You rolled a " roll " and were hit!"))
((make-player-pays (* (player-acres p) 100)) p)))))
(filter (lambda (x) (not (eq? x player)))
(game-players (session-ref (sid) 'game))))
(with-ff-money-action (player)
((make-player-gains-per-unit 'hay 500) player)))
#f)
(1 ,(lambda (player)
(with-ff-money-action (player)
((make-player-gains-per-unit 'grain 100) player)))
#f)
(1 ,(lambda (player)
(push! '((?p wheat harvest-mult 0.5) (?p grain)) (player-year-rules player))
(push! `((?p wheat player-action-post-harvest
,(make-remove-farmers-fate-from-hand 'windy-spring))
(?p grain))
(player-year-rules player))
(push! `((?d player-action ?p
,(make-remove-farmers-fate-after 'windy-spring 34)))
(player-year-rules player))
'())
#t
windy-spring)
(1 ,(lambda (player)
(if (player-has-asset? 'cows player)
(with-ff-money-action (player) ((make-player-gains 2000) player))
'()))
#f)
(1 ,(lambda (player)
(with-ff-money-action (player)
((make-player-gains-per-unit 'hay 100) player)))
#f)
(1 ,(lambda (player)
(with-ff-money-action (player) ((make-player-gains 1000) player)))
#f)
(1 ,(lambda (player)
(with-ff-money-action (player) ((make-player-pays 7000) player)))
#f)
(1 ,(lambda (player)
(with-ff-money-action (player)
((make-player-pays-per-unit 'fruit 500) player)))
#f)
(1 ,(lambda (player)
(with-ff-money-action (player)
(let ((to-earn (* (player-acres player) 100)))
(push-message player (conc "You earned $" to-earn "!"))
(set! (player-cash player)
(+ (player-cash player) to-earn)))))
#f)
(2 ,(lambda (player)
`(((?action . player-action)
(?value . ,(lambda (player) (finish-year player #f))))
((?action . goto) (?value . jan2))))
#f)
(1 ,(lambda (player)
(with-ff-money-action (player)
((make-player-pays-per-unit 'fruit 300) player)))
#f)
;; xxx multiplayer interaction
(2 ,(lambda (player)
(with-ff-money-action (player)
(equipment-payout 'tractor player 3000 (session-ref (sid) 'game))))
#f)
;; xxx multiplayer interaction
(1 ,(lambda (player)
(if (player-has-asset? 'harvester player)
(with-ff-money-action (player)
(for-each (lambda (from-player)
(when (not (eq? player from-player))
(when (not (player-has-asset? 'harvester from-player))
(set! (player-cash from-player)
(- (player-cash from-player) 2000))
(set! (player-cash player)
(+ (player-cash player) 2000)))))
(game-players (session-ref (sid) 'game))))
'()))
#f)
(1 ,(lambda (player)
(push! '((?p ?any harvest-mult 0) (?p ?crop)) (player-year-rules player))
'())
#t)
(1 ,(lambda (player)
`(((?action . ff-uncle-bert) (?value . #f))))
#f)
;; xxx multiplayer interaction
(1 ,(lambda (player)
(with-ff-money-action (player)
(equipment-payout 'harvester player 2500
(session-ref (sid) 'game))))
#f)
(1 ,(lambda (player)
(push! `((?p cows harvest-mult 1.5) (?p cows)) (player-year-rules player))
(push! `((?p cows harvest-mult 1.5) (?p cows)) (player-next-year-rules player))
'())
#t
cows-15)
(1 ,(lambda (player)
(with-ff-money-action (player) ((make-player-gains 2000) player)))
#f)
(1 ,(lambda (player)
(when (< (player-space player) 26)
(push! '((?p cherries harvest-mult 0.5) (?p fruit)) (player-year-rules player))
(push! `((?p cherries player-action-post-harvest
,(make-remove-farmers-fate-from-hand 'cherries-05))
(?p fruit))
(player-year-rules player)))
(push! `((?d player-action ?p
,(make-remove-farmers-fate-after 'cherries-05 26)))
(player-year-rules player))
'())
#t
cherries-05)
(1 ,(lambda (player)
(let ((cows (player-asset 'cows player))
(ridge-cows (cows-on-ridges player)))
(if (> cows ridge-cows)
(let ((slaughtered-cows (- cows ridge-cows)))
(push-message player (conc slaughtered-cows
" cows slaughtered on your farm."))
(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)
(with-ff-money-action (player)
((make-player-pays-per-unit 'fruit 1000) player)))
#f)
(1 ,(lambda (player)
(with-ff-money-action (player) ((make-semi-annual-interest-due) player)))
#f)))
(define (setup-farmers-fates)
(shuffle (farmers-fate-spec-list->farmers-fate-cards *farmers-fates-specs* *ff-text*)))
(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)))
(push-message player (conc "You paid $" to-pay "!"))
(set! (player-cash player)
(- (player-cash player) to-pay)))))
(2 ,(lambda (player)
(equipment-payout 'harvester player 2000 (session-ref (sid) 'game))))
(2 ,(lambda (player)
(equipment-payout 'tractor player 2000 (session-ref (sid) '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)
(push-message player "You paid $500!")
(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 *total-operating-expenses*
(length (operating-expenses-spec-list->operating-expenses-cards
*operating-expenses-specs* *oe-text*)))
(define (draw-operating-expense)
(let* ((game (session-ref (sid) 'game))
(card (list-ref (game-operating-expenses game)
(game-operating-expense-index game))))
(if (= (+ (game-operating-expense-index game) 1) *total-operating-expenses*)
(set! (game-operating-expense-index game) 0)
(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)) 0) `(((tom ,crop))) '()))
(define (aug4-action player)
(when (not (already-harvested? 'wheat player))
((make-player-pays-per-unit 'grain 50) player)))
(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 ((?p hay harvest-mult 2) (?p hay))))
((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))
((mar4 money ?p ,(pays 2000)) (?p fruit))
((apr1 draw ?p otb))
((apr2 add-rule ?p ((?p corn harvest-mult 2) (?p grain))))
((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-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)))
,@(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))
`((,(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)
(let ((game (session-ref (sid) 'game)))
(if (null? (game-otbs game))
(begin (push-message player "No O.T.B.s left to draw!")
#f)
(receive (new-otb remaining-otbs) (split-at (game-otbs game) 1)
(set! (player-otbs player) (cons (car new-otb) (player-otbs player)))
(set! (game-otbs game) remaining-otbs)
(car new-otb)))))
(define (do-action action player)
(let ((a (alist-ref '?action action)))
(cond ((eq? a 'money)
(let ((changed ((alist-ref '?value action) 0)))
(push-message player (conc "You " (if (>= changed 0) "earned" "paid") " $"
(abs changed) "!")))
(set! (player-cash player)
((alist-ref '?value action) (player-cash player))))
((eq? a 'add-rule)
(set! (player-year-rules player)
(cons (alist-ref '?value action) (player-year-rules player)))
;; TODO handle being added multiple times
)
((eq? a 'goto)
(set! (player-previous-space player) (player-space player))
(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))
(when (not (null? (game-otbs (session-ref (sid) 'game))))
(push-message player "You drew an O.T.B.!")
(draw-otb player)))
((and (eq? a 'draw) (eq? (alist-ref '?value action) 'farmers-fate))
(let ((game (session-ref (sid) 'game)))
(receive (new-ff remaining-ffs) (split-at (game-farmers-fates game) 1)
(push-message player (conc "Farmers Fate: " (alist-ref 'text (car new-ff))))
(if (alist-ref 'hold-card (car new-ff))
(begin (push! (car new-ff) (player-farmers-fates player))
(set! (game-farmers-fates game) remaining-ffs))
(set! (game-farmers-fates game) (append remaining-ffs new-ff)))
`((actions . ,((alist-ref 'action (car new-ff)) player))
(contents . ,(alist-ref 'contents (car new-ff)))))))
((or (eq? a 'player-action) (eq? a 'player-action-post-harvest))
((alist-ref '?value action) player))
((eq? a 'harvest-mult)
(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))
(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
(push-message player (conc crop " Harvest! You rolled a " rolled
" and earned $" income "!"))
(when (not (= (player-harvest-mult player) 1))
(push-message player (conc "Harvest multiplied by " (player-harvest-mult player) "!")))
(set! (player-cash player)
(+ (player-cash player) income))
(set! (player-harvest-mult player) 1)
(let ((operating-expense (draw-operating-expense))
(previous-cash (player-cash player)))
((alist-ref 'action operating-expense) player)
(push-message player (alist-ref 'summary operating-expense))
`((rolled . ,rolled)
(income . ,income)
(operatingExpense . ,(alist-ref 'contents operating-expense))
(operatingExpenseValue . ,(- (player-cash player)
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 (set! (player-harvest-mult player) 1)
(do-all-actions player))))
(let ((r (sort-actions (get-actions player (player-space player)))))
(set! *last-actions* r)
(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))))))
Cleaning up Scheme code integration with different dev/prod modes.
5 years ago
(cond-expand
(geiser
'())
(csi
(run-awful)
(repl))
(compiling ;; production
(run-awful)
(thread-join! *server-thread*)))
Initial public release.
5 years ago
;; TODO
;; audit was called but didn't cause anything on year end
;; make sure two players can't have the same name
;; bug: harvest action multiplayer doesn't flow right for other players
;; info actions should look better
;; bug: notify when need to raise money because less than 0
;; bug: loans is buggy when negative cash
;; bug: dice shows no value when landing on christmas vacation
;; hide Join Game when no games to join
;; livestock bonus card causes "you gained $0" to show every turn