Adding AI.

src/server/farm.scm

@@ -120,7 +120,7 @@
    (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: #f accessor: player-user-id)
+   (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)
@@ -202,7 +202,8 @@
     (last-cash . ,(player-cash player))
     (hay-doubled . ,(player-hay-doubled player))
     (corn-doubled . ,(player-corn-doubled player))
-    (stats . ,(player-stats player))))
+    (stats . ,(player-stats player))
+    (ai . ,(ai-player? player))))
 
 (define (game->sexp g)
   `((id . ,(game-id g))
@@ -317,7 +318,7 @@
       (set! *app* (sexp->app (read))))))
 
 (define (sexp->player x)
-  (let ((p (apply make <player>
+  (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)
@@ -422,7 +423,7 @@
 
 (define (add-ai-to-game game color name)
   (let ((player (make <ai>
-                  'cash 10000
+                  'cash (game-setting 'starting-cash game)
                   'display-cash (game-setting 'starting-cash game)
                   'debt (game-setting 'starting-debt game)
                   'color color
@@ -555,6 +556,7 @@
                (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))
@@ -1044,6 +1046,10 @@
         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)
@@ -1261,9 +1267,13 @@
         ((and (string=? type "next-action")
               (ai-player? (game-current-player game)))
          (print "ai next action trigger")
-         (print (player-name (game-current-player game)))
          (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" `()))
@@ -1469,6 +1479,21 @@
            (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)))
@@ -1547,6 +1572,79 @@
          (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)
@@ -1555,47 +1653,55 @@
      (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))
-                  ;; (process-message player game "next-action" '((type . "next-action")))
-                  ;; (let loop ((msg (process-message player game "next-action" '((type . "next-action")))))
-                  ;;   (if (alist-ref 'action msg)
-                  ;;       (loop (process-message player game "next-action" '((type . "next-action"))))
-                  ;;       (print "done with actions")))
-                  ))))
+                  (print "rolled a " (alist-ref 'value res))))))
     ((auto-skip)
-     (print "ai auto-skip")
-     ;; (when (ai-processing-turn player)
-     ;;   (process-message player game "next-action" '((type . "next-action"))))
-     )
+     (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")))))
-         (display "res: ")
-         (write res)
-         (newline)
-         ;; (print "res1: " (eq? (alist-ref 'event res) 'action))
-         ;; (print "res2: " (not (alist-ref 'action res)))
-         ;; (print "res3: " (and (eq? (alist-ref 'event res) 'action)
-         ;;                      (not (alist-ref 'action res))))
-         ;; (when (and (string=? (alist-ref 'event res) "action")
-         ;;            (not (alist-ref 'action res)))
-         ;;   (print "ending turn")
-         ;;   (thread-sleep! 0.5)
-         ;;   (set! (ai-processing-turn player) #f)
-         ;;   (process-message player game "turn-ended" '()))
+         res
+         ;; (display "res: ")
+         ;; (write res)
+         ;; (newline)
          )))
-    ((end-ai-turn)
+    ((ai-uncle-bert)
+     (print "ai-uncle-bert")
      (when (ai-processing-turn player)
-       (print "ending turn")
-       (thread-sleep! 0.5)
-       (set! (ai-processing-turn player) #f)
-       (process-message player game "turn-ended" '())
-       ))))
+       (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))))))