#lang scheme
;; blackjack.ss
;; Code to support a simplified game of blackjack, as discussed in class.
;; Lee Spector, lspector@hampshire.edu, 20091124
;; Update 20091125: fixed bug that treated wrong card of opponents' hands
;; as the down card (first card in hand is down card, but
;; prev version consed new cards onto front)
;; Update 20091201: fixed bug that allowed busted agents to keep getting cards
;; Update 20091202: fixed bug that allowed agents to have only one card
;; Simplifications (from class):
;; - 4 decks, fresh and reshuffled for each game
;; - no suits
;; - no dealer
;; - values 1-10 -- 1 can count as 11, all face cards equivalent (10)
;; - run many games and accumulate winnings
;; - ties broken by "less cards better" or randomly if same number
;; Each player must supply a "hit function" procedure which takes a list
;; of the player's cards and a list of other-player-visible-cards lists.
;; The hit function should return #t if the player wants another card
;; or #f otherwise.
;; The top-level procedure is tournament, which takes a number of games
;; to play and a list of (name hit-function) pairs.
;; At the bottom of this file are two not-very-bright example hit functions
;; and a call to tournament that plays them against each other.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; generating the decks of cards
(define one-suit
(lambda ()
;; Return numbers corresponding to one suit.
;; Suit is not actually represented.
;; J, Q, and K are all 10
(list 1 2 3 4 5 6 7 8 9 10 10 10 10)))
;;(one-suit)
(define one-deck
(lambda ()
;; Return numbers corresponding to one full deck.
(append (one-suit) (one-suit) (one-suit) (one-suit))))
;; (one-deck)
(define four-decks
(lambda ()
;; Return numbers corresponding to four full deck.
(append (one-deck) (one-deck) (one-deck) (one-deck))))
;; (/ (length (four-decks)) 4)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; general utilities that will come in handy
(define shuffle ; Returns a randomly re-ordered copy of list.
(lambda (list)
(if (< (length list) 2)
list
(let ((item (list-ref list (random (length list)))))
(cons item (shuffle (remove item list)))))))
;; (shuffle (one-deck))
(define list-change
(lambda (lst pos new-item)
;; Returns a copy of lst with new-item replacing whatever was at position pos.
(append (take lst pos)
(list new-item)
(drop lst (+ pos 1)))))
;; (list-change '(a b c d e) 2 'z)
;; (list-change '(a b c d e) 0 'z)
;; (list-change '(a b c d e) 4 'z)
(define list-without
(lambda (lst pos)
;; Returns a copy of lst without the item at position pos.
(append (take lst pos)
(drop lst (+ pos 1)))))
;; (list-without '(a b c d e) 2)
;; (list-without '(a b c d e) 0)
;; (list-without '(a b c d e) 4)
(define increment
(lambda (name name-number-list)
;; Returns a (name number) list in which the number paired with the given
;; name has been incremented by 1.
(cond ((null? name-number-list) '())
((equal? name (first (first name-number-list)))
(cons (list name (+ 1 (second (first name-number-list))))
(cdr name-number-list)))
(else (cons (car name-number-list)
(increment name (cdr name-number-list)))))))
;; (increment 'foo '((bar 2) (foo 4) (baz 0)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; blackjack-specific procedures
(define best-total
(lambda (cards)
;; Returns the best total of the cards, using 1 or 11 for each 1
(let ((raw-score
(if (member 1 cards)
(let* ((without1 (remove 1 cards))
(score1 (+ 1 (apply + without1)))
(score11 (+ 11 (apply + without1))))
(if (< score11 22)
score11
score1))
(apply + cards))))
(if (< raw-score 22)
raw-score
0))))
;; (best-total '(2 4 1 5))
;; (best-total '(10 1))
;; (best-total '(9 1 1))
;; (best-total '(9 9 9))
;; (best-total '(9 9 9 1))
(define winner
(lambda (hands names)
;; Returns the name of the winner, assuming the hands and names
;; are in corresponding order.
(let ((named-hands (shuffle (map list names hands)))) ;; shuffled to randomize ties
(car (car (sort named-hands
(lambda (h1 h2)
(if (= (best-total h1) (best-total h2))
(< (length h1) (length h2))
(> (best-total h1) (best-total h2))))
#:key second))))))
;; (winner '((2 4 1 5) (10 1) (10 1) (9 1 1) (9 9 9) (9 9 9 1)) '(a b c d e f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the top-level procedure
(define tournament
(lambda (games players)
;; Returns a sorted list of (name wins) lists.
;; Games is the number of games to play.
;; Players is a list of (name hit-function).
;; A hit-function takes a list of the player's cards and a list
;; of other-player-visible-cards lists.
(let ((scores (map (lambda (p) (list (car p) 0)) players)))
(for ((game (in-range 0 games)))
(printf "\nGame #~A" game)
(let* ((cards (shuffle (four-decks)))
(names (shuffle (map car players))) ;; shuffle player order
(hands (map (lambda (x) ;; deal initial cards
(let ((my-cards (list (car cards)
(cadr cards))))
(set! cards (cddr cards))
my-cards))
names))
(game-over #f)
(someone-hit #f))
(printf "\nInitial hands: ~A" (map list names hands))
(do ((turn 0 (+ turn 1)))
(game-over (let ((w (winner hands names)))
(set! scores (increment w scores))
(printf "\nGame won by ~A\n" w)))
(printf "\nTurn #~A" turn)
(set! someone-hit #f)
(do ((player-number 0 (+ player-number 1))) ;; ask each player if wants card
((>= player-number (length players)))
(when (and (> (best-total (list-ref hands player-number)) 0) ;; can only hit if still alive
((cadr (assoc (list-ref names player-number) players))
(list-ref hands player-number)
(map cdr (list-without hands player-number))))
(set! hands (list-change hands
player-number
(append (list-ref hands player-number)
(list (car cards)))))
(printf "\n~A hit, now has ~A" (list-ref names player-number)
(list-ref hands player-number))
(set! cards (cdr cards))
(set! someone-hit #t)))
(unless someone-hit (set! game-over #t))
(unless (> (apply max (map best-total hands)) 0) (set! game-over #t)))))
(sort scores > #:key second))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; example
(define mr15-hitfn
(lambda (mine others)
(< (apply + mine) 15)))
(define mr18-hitfn
(lambda (mine others)
(< (apply + mine) 18)))
(tournament 100 (list (list 'mr15 mr15-hitfn)
(list 'mr18 mr18-hitfn)))