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

Lobby improvements; leave game.

Browse Source
This commit is contained in:
Thomas Hintz
2020-04-22 18:57:15 -07:00
parent 7ba6f19133
commit 2a6a0b038e
9 changed files with 217 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
src/server/db.scm
View File

@@ -127,6 +127,11 @@
(exec (sql db "insert into user_games(user_id, game_id) values (?, ?);")
user-id game-id)))
(define (db-remove-user-game user-id game-id)
(with-db (db)
(exec (sql db "delete from user_games where user_id=? and game_id=?;")
user-id game-id)))
(define (db-fetch-user-games user-id)
(with-db (db)
(query fetch-column

49
src/server/farm.scm
View File

@@ -127,7 +127,8 @@
(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)))
(corn-doubled initform: #f accessor: player-corn-doubled)
(ready-to-start initform: #f accessor: player-ready-to-start)))
(define-class <ai> (<player>)
((processing-turn initform: #f accessor: ai-processing-turn)))
@@ -564,11 +565,19 @@
#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))
(trade . ,(game-setting 'trade 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)))))))
(define (buy-crop crop unnormalized-crop amount cash-value player game)
(let ((total-cost (* amount (alist-ref unnormalized-crop
@@ -1424,6 +1433,42 @@
(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)
(eq? p kicked-player))
(game-players (*game*))))
(db-remove-user-game (player-user-id kicked-player) (game-id (*game*))))
(message-players! (*game*) (*player*) '() type: "update")
(create-ws-response (*player*) "update" '()))
((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*)))