;; ===================================
;;              John Paxton
;;                CS 436
;;           November 11, 2005
;; ===================================
;; The driver for the cribbage tournament.
;; ===================================

(defvar *player-one* 0)    ;; player one
(defvar *player-two* 1)    ;; player two

(defvar *names* (make-array 2))       ;; names
(setf (aref *names* 0) "Player 1")
(setf (aref *names* 1) "Player 2")

;; -----------------------------------
;; driver
;; -----------------------------------
;; file: the file where the pre-dealt hands reside
;; -----------------------------------
;; Oversee one complete game of cribbage.
;; This will take no more than 121 deals!
;; -----------------------------------


(defun driver ( file )
  (let
    (
     (scores (make-array 2 :initial-element 0))  ;; score of each player
     (dealer *player-one*)                       ;; dealer
    ) 

    (with-open-file (input-stream file :direction :input)
      (dotimes (i 121)                           
        (play-one-hand input-stream dealer scores)
	(setf dealer (other-player dealer))
      )
    )
  )
)

;; -----------------------------------
;; play-one-hand
;; -----------------------------------
;; input-stream: file to read cards from
;; dealer: who dealt this hand
;; scores: score of each player
;; -----------------------------------
;; Simulates one cribbage hand
;; -----------------------------------

(defun play-one-hand ( input-stream dealer scores)
  (let
    (
     (hand-1 nil)      ;; player 1's hand
     (hand-2 nil)      ;; player 2's hand
     temp-hand         ;; hand for swapping
     (crib nil)        ;; cards in the crib
     flip              ;; card turned over
     hand-1-discards   ;; player 1's discards
     hand-2-discards   ;; player 2's discards
    )

    (dotimes (i 6)     ;; form 2 hands of 6 cards
      (setf hand-1 (cons (convert-card (read input-stream)) hand-1))
      (setf hand-2 (cons (convert-card (read input-stream)) hand-2))
    )

    (setf flip (convert-card (read input-stream)))

    (setf hand-1-discards (player-one-get-discards (copy-hand hand-1) 
       (aref scores *player-one*) (aref scores *player-two*) dealer))
    (setf hand-1 (update-hand hand-1 hand-1-discards *player-one* 2))

    (setf hand-2-discards (player-two-get-discards (copy-hand hand-2) 
       (aref scores *player-two*) (aref scores *player-one*) dealer))
    (setf hand-2 (update-hand hand-2 hand-2-discards *player-two* 2))

    (setf crib (append hand-1-discards hand-2-discards))

    (format t "~%------------------~2%")
    (format t "Flip: ~a~%" (printing-version flip))
    (if (equal (rank flip) 'jack)
      (update-score scores dealer "flipping a jack" 2)
    ) 

    (thirty-one hand-1 hand-2 dealer scores)  ;; play 31

    (when (equal dealer *player-two*)  ;; swap hands for scoring if necessary
      (setf temp-hand hand-1)          ;; code added 12/4
      (setf hand-1 hand-2)
      (setf hand-2 temp-hand)
    )

    ;; score non-dealer's hand
    (format t "~a hand: ~a~%" (aref *names* (other-player dealer)) 
	  (mapcar #'printing-version hand-2))
    (update-score scores (other-player dealer) "the hand" 
          (score-hand hand-2 flip))

    ;; score dealer's hand
    (format t "~a hand: ~a~%" (aref *names* dealer) 
          (mapcar #'printing-version hand-1))
    (update-score scores dealer "the hand" (score-hand hand-1 flip))

    ;; score dealer's crib
    (format t "~a hand: ~a~%" (aref *names* dealer) 
          (mapcar #'printing-version crib))
    (update-score scores dealer "the crib" (score-hand crib flip))
  )
)

;; -----------------------------------
;; thirty-one
;; -----------------------------------
;; hand-1: player 1's hand
;; hand-2: player 2's hand
;; whose-turn: whose turn to play
;; scores: each player's current score
;; -----------------------------------
;; Play the 31 portion of cribbage.
;; -----------------------------------

(defun thirty-one ( hand-1 hand-2 whose-turn scores )

  (setf whose-turn (other-player whose-turn))

  (do
    (
     card-to-play            ;; next card to play (or pass)
     (score 0)               ;; current score of 31
     (number-of-passes 0)    ;; consecutive passes
     (cards-played nil)      ;; all cards played since score was last 0
     (all-cards-played nil)  ;; all cards played since this round of 31 began
    )

    ((and (null hand-1) (null hand-2)) )

      (if (= whose-turn *player-one*)            ;; get card to play
        (setf card-to-play (player-one-get-play 
	      (copy-hand hand-1) (copy-hand cards-played) score 
	      (aref scores *player-one*) (aref scores *player-two*)
	      (copy-hand all-cards-played)))
	(setf card-to-play (player-two-get-play 
	      (copy-hand hand-2) (copy-hand cards-played) score 
	      (aref scores *player-two*) (aref scores *player-one*)
	      (copy-hand all-cards-played)))
      )

      (cond
        ((equal card-to-play 'pass)              ;; player passed
	  (if (= whose-turn *player-one*) 
	    (check-pass (aref *names* *player-one*) score hand-1)
	    (check-pass (aref *names* *player-two*) score hand-2)
	  )
	  (format t "~a passes, score = ~a~%" (aref *names* whose-turn) score)
          (setf number-of-passes (+ 1 number-of-passes))
          (when (= number-of-passes 2)
	    (update-score scores whose-turn "playing the last card" 1)
            (setf number-of-passes 0)
	    (setf score 0)
	    (setf cards-played nil)
          )
        )
	(t                                       ;; player played a card
	  (setf number-of-passes 0)
	  (setf score (+ score (score-value card-to-play)))
	  (if (= whose-turn *player-one*)
	    (setf hand-1 (process hand-1 card-to-play 
	                 (aref *names* *player-one*) score))
	    (setf hand-2 (process hand-2 card-to-play 
	                 (aref *names* *player-two*) score))
	  )
	  (setf cards-played (cons card-to-play cards-played))
	  (setf all-cards-played (cons card-to-play all-cards-played))
	  (score-in-play score scores whose-turn cards-played)
	) ;t
      ) ;cond
      (setf whose-turn (other-player whose-turn))
  )
  (update-score scores (other-player whose-turn) "playing the last card" 1)
)

;; -----------------------------------
;; score-in-play
;; -----------------------------------
;; score: the current score for 31
;; scores: the score for each player
;; whose-turn: whose turn it is
;; cards-played: all the cards played in 31 since the score was last 0
;; -----------------------------------
;; Determine whether "whose-turn" should earn
;; any points for the 31 portion of play
;; -----------------------------------

(defun score-in-play ( score scores whose-turn cards-played )

  (cond
    ((= score 15) 
      (update-score scores whose-turn "making the score 15" 2)
    )
    ((= score 31)
      (update-score scores whose-turn "making the score 31" 1)
    ) 
  )

  (cond                                            ;; check pairs
    ((and (>= (length cards-played) 4)
          (= (sort-value (first cards-played))
	  (sort-value (second cards-played))
	  (sort-value (third cards-played))
	  (sort-value (fourth cards-played))))
	    (update-score scores whose-turn "making 4 of a kind" 12)
    ) 
    ((and (>= (length cards-played) 3)
          (= (sort-value (first cards-played))
	  (sort-value (second cards-played))
	  (sort-value (third cards-played))))
            (update-score scores whose-turn "making 3 of a kind" 6)
    )
    ((and (>= (length cards-played) 2)
      (= (sort-value (first cards-played))
         (sort-value (second cards-played))))
	    (update-score scores whose-turn "making 2 of a kind" 2)
    )
  ) ;cond

  (check-runs scores whose-turn (reverse cards-played))
)

;; -----------------------------------
;; check-runs
;; -----------------------------------
;; scores: each player's current score
;; whose-turn: the player who just played a card
;; cards-played: all cards played in 31 since score was last 0
;; -----------------------------------
;; Check to see if the last card played in 31 makes a run
;; -----------------------------------

(defun check-runs ( scores whose-turn cards-played )
  (cond
    ((< (length cards-played) 3) nil)
    ((run-present-p scores whose-turn cards-played ) nil)
    (t (check-runs scores whose-turn (rest cards-played)))
  )
)

;; -----------------------------------
;; run-present-p
;; -----------------------------------
;; scores: each player's current score
;; whose-turn: the player who just played a card
;; cards-played: all cards played in 31 since score was last 0
;; -----------------------------------
;; Check to see if all of the cards passed in form a run
;; -----------------------------------

(defun run-present-p ( scores whose-turn cards-played )
  (let
    (
     (count (fill-array cards-played))  ;; how many of each card rank there is
     (current-run 0)                    ;; length of current run
     (longest-run 0)                    ;; length of longest run
    )

    (dotimes (i (array-dimension count 0))
      (cond
        ((= (aref count i) 1)
	  (setf current-run (+ 1 current-run))
	  (if (> current-run longest-run)
	    (setf longest-run current-run)
	  )
	)
	(t
	  (setf current-run 0)
	)
      )
    )

    (if (= longest-run (length cards-played))
      (update-score scores whose-turn "making a run" longest-run) 
    )

    (= longest-run (length cards-played))
  )
)

;; -----------------------------------
;; update-score
;; -----------------------------------
;; scores: each player's current score
;; who: who gets to add to his score
;; what: what happened to cause the scoring
;; how-much: the value of "what"
;; -----------------------------------
;; Updates the score of the cribbage game.
;; If someone won, stop the game.
;; -----------------------------------

(defun update-score ( scores who what how-much )

  (setf (aref scores who) (+ how-much (aref scores who)))

  (format t "~a " (aref *names* who))

  (format t "scores ~a for ~a, ~a to ~a~%" 
      how-much what (aref scores 0) (aref scores 1))
      
  (cond
    ((>= (aref scores *player-one*) 121)   ;; player 1 won
      (format t "Player 1 wins.  121 to ~a~%" (aref scores *player-two*))
      (error "GAME WON")
    )
    ((>= (aref scores *player-two*) 121)   ;; player 2 won
      (format t "Player 2 wins.  121 to ~a~%" (aref scores *player-one*))
      (error "GAME WON")
    )
  )
)

;; -----------------------------------
;; check-pass
;; -----------------------------------
;; player: the player who passed
;; score: the current score of 31
;; hand: the cards left in the player's hand
;; -----------------------------------
;; Check to see whether pass is a legal
;; option for "player".  If it isn't, end
;; the game with an appropriate message.
;; -----------------------------------

(defun check-pass ( player score hand )
  (let
    (
     (low-card 32)        ;; a value guaranteed to exceed 31
    )

    (dolist (card hand)   ;; find the lowest card left
      (if (< (score-value card) low-card)
        (setf low-card (score-value card))
      )
    )

    (when (<= (+ score low-card) 31)     ;; was there a legal play?
      (format t "Player ~a may not pass.~%" player)
      (error "ILLEGAL PASS")
    )
  )
)

;; -----------------------------------
;; process
;; -----------------------------------
;; hand: the player's hand
;; card: the card to play
;; player: the player making the play
;; score: the current score for the 31 game
;; -----------------------------------
;; Play the desired card unless it is
;; illegal to do so.  In this case, end the game.
;; -----------------------------------

(defun process (hand card player score)
  (setf hand (update-hand hand (list card) player 1))
  (format t "~a plays ~a, score = ~a~%"
     player (printing-version card) score)
  (when (> score 31)
    (format t "~a has played a card that is too large.~%" player)
    (error "ILLEGAL PLAY")
  )
  hand
)

;; -----------------------------------
;; update-hand
;; -----------------------------------
;; hand: a player's hand of cards
;; hand-discards: the cards the player wants to discard
;; player: the player to discard
;; how-many-discards: the desired number of discards
;; -----------------------------------
;; Discard the "hand-discards" from the hand.
;; In the event that the discards are illegal,
;; end the game with an appropriate message.
;; -----------------------------------

(defun update-hand (hand hand-discards player how-many-discards)

  (when (not (= (length hand-discards) how-many-discards))
    (format t "~a has not discarded ~a card(s).~%" player how-many-discards)
    (error "ILLEGAL NUMBER OF DISCARDS")
  ) 

  (dolist (discard hand-discards hand)
    (when (not (find-if 
                   #'(lambda (x) (and (equal (rank x) (rank discard))
                                      (equal (suit x) (suit discard))))
           hand))
      (format t "~a has discarded an illegal card.~%" player)
      (error "ILLEGAL DISCARD")
    )
    (setf hand (remove-if
                   #'(lambda (x) (and (equal (rank x) (rank discard))
		                      (equal (suit x) (suit discard))))
	        hand)) 
  )
)

;; -----------------------------------
;; copy-hand
;; -----------------------------------
;; hand: the current hand of "card"s 
;; -----------------------------------
;; Make a copy of the current hand
;; -----------------------------------

(defun copy-hand ( hand )
  (mapcar #'convert-card 
      (mapcar #'(lambda (x) (list (rank x) (suit x))) hand)
  )
)

;; -----------------------------------
;; other-player
;; -----------------------------------
;; current-player: the current player
;; -----------------------------------
;; Determine who the other player is
;; -----------------------------------

(defun other-player ( current-player )
  (if (= current-player *player-one*)
    *player-two*
    *player-one*
  )
)

;; ******************************************************************
;; The code below is a slightly modified version
;; of the Program 1 solution written on September 2, 2005.
;; ******************************************************************


;; -----------------------------------
;; CARD
;; -----------------------------------
;; This is the class used to represent
;; all of the important information about
;; an individual card
;; -----------------------------------
;; SCORE-VALUE: how much a card is worth
;; SORT-VALUE:  used to distinguish jacks, queens, kings
;; RANK:        the rank of a card, e.g. 'two
;; SUIT:        the suit of a card, e.g. 'hearts 
;; -----------------------------------

(defclass card ()
  (
    (score-value :accessor score-value)
    (sort-value :accessor sort-value)
    (rank :accessor rank)
    (suit :accessor suit)
  )
)

;; -----------------------------------
;; score-hand
;; -----------------------------------
;; hand: the hand to score
;; flip: the card flipped over
;; -----------------------------------
;; Determine how much the hand is worth
;; -----------------------------------

(defun score-hand (hand flip)
  (let
    (
     full-hand            ;; a list of all 5 "card"s to score
    )

    (setf full-hand (append hand (list flip)))

    (sort full-hand #'(lambda (card1 card2) 
        (< (sort-value card1) (sort-value card2))))

    (+ 
       (score-pairs full-hand)
       (score-runs full-hand)
       (score-flush hand flip)
       (score-nobs hand flip)
       (score-fifteens full-hand)
    )
  )
)

;; -----------------------------------
;; SCORE-FIFTEENS
;; -----------------------------------
;; Score the fifteens for the show.
;; -----------------------------------
;; CARDS-LEFT: The cards not yet considered
;; SCORE: The score for the fifteens so far
;; -----------------------------------

(defun score-fifteens ( cards-left &optional (score 0) )
  (cond
    ((= score 15) 2)         ;; 15!
    ((> score 15) 0)         ;; no fifteen
    ((null cards-left) 0)    ;; no fifteen
    (t
      (+ 
         (score-fifteens (rest cards-left) score)  ;; don't include next card
         (score-fifteens (rest cards-left)         ;; include next card 
	    (+ score (score-value (first cards-left))))
      )
    )
  )
)

;; -----------------------------------
;; SCORE-FLUSH
;; -----------------------------------
;; Score the flushes for the show.
;; -----------------------------------
;; HAND: The four cards dealt to the player.
;; FLIP: The card turned over.
;; -----------------------------------

(defun score-flush ( hand flip )

  (if (= (count-if #'(lambda (x) (equal (suit x) (suit (first hand)))) hand)
         (length hand))
    (if (equal (suit flip) (suit (first hand)))
      (+ 1 (length hand))
      (length hand) 
    )
    0
  )
)

;; -----------------------------------
;; SCORE-NOBS
;; -----------------------------------
;; Does the player's four cards include nobs?
;; -----------------------------------
;; HAND: A list of the player's four cards.
;; FLIP: The card turned over
;; -----------------------------------

(defun score-nobs ( hand flip )
  (count-if 
    #'(lambda (x) 
        (and (equal (rank x) 'jack) (equal (suit x) (suit flip))))
    hand
  )
)

;; -----------------------------------
;; SCORE-RUNS
;; -----------------------------------
;; Scores the runs in the hand
;; -----------------------------------
;; HAND: All five cards in the show.
;; -----------------------------------

(defun score-runs ( hand )
  (let
    (
     (counts (fill-array hand))  ;; how many of each rank is there?
     (result 0)                  ;; the score so far
     (current-length 0)          ;; length of the current run
     (current-multiplier 1)      ;; multiplier of the current run
    )

    (dotimes (slot (array-dimension counts 0) result)
      (cond 
        ((> (aref counts slot) 0)
	  (setf current-length (+ 1 current-length))
	  (setf current-multiplier (* current-multiplier (aref counts slot)))
	)
	(t
	  (if (>= current-length 3)
	      (setf result (+ result (* current-length current-multiplier)))
	  )
	  (setf current-length 0)
	  (setf current-multiplier 1)
	)
      )
    )
  )
)

;; -----------------------------------
;; SCORE-PAIRS
;; -----------------------------------
;; Scores all of the pairs.
;; -----------------------------------
;; HAND: The five cards in the show.
;; -----------------------------------

(defun score-pairs ( hand )
  (let
    (
     (how-many (fill-array hand))  ;; how many of each rank is there? 
     (result 0)                    ;; the score so far
    )

    (dotimes (slot (array-dimension how-many 0) result)
      (case (aref how-many slot)
        (2 (setf result (+ result 2)))
	(3 (setf result (+ result 6)))
	(4 (setf result (+ result 12)))
      )
    )
  )
)

;; -----------------------------------
;; CONVERT-CARD
;; -----------------------------------
;; Converts the card into an instance
;; of the "card" class.
;;
;; Note: All cards are assumed to be legal.
;; -----------------------------------
;; CARD: A list containing the rank and
;;       suit of the card.
;; -----------------------------------

(defun convert-card ( card )
  (let
    (
     (new-card (make-instance 'card))    ;; the converted card
    )

    (setf (rank new-card) (first card))
    (setf (suit new-card) (second card))

    (case (rank new-card)                 
      (ace (setf (score-value new-card) 1))
      (two (setf (score-value new-card) 2))
      (three (setf (score-value new-card) 3))
      (four (setf (score-value new-card) 4))
      (five (setf (score-value new-card) 5))
      (six (setf (score-value new-card) 6))
      (seven (setf (score-value new-card) 7))
      (eight (setf (score-value new-card) 8))
      (nine (setf (score-value new-card) 9))
      (ten (setf (score-value new-card) 10))
      (jack (setf (score-value new-card) 10))
      (queen (setf (score-value new-card) 10))
      (king (setf (score-value new-card) 10))
    )

    ;; it is convenient to have the sort-values 0 based.
    (setf (sort-value new-card) (- (score-value new-card) 1))
    
    (case (rank new-card)
      (jack (setf (sort-value new-card) 10))
      (queen (setf (sort-value new-card) 11))
      (king (setf (sort-value new-card) 12))
    )

    new-card
  )
)

;; -----------------------------------
;; FILL-ARRAY
;; -----------------------------------
;; Fills an array with the number of times each
;; rank appears in the hand.
;; -----------------------------------
;; HAND: A list of "card" instances.
;; -----------------------------------

(defun fill-array ( hand )
  (let
   ( 
    (count (make-array 14 :initial-element 0))  ;; score runs easily
   )

   (dolist (card hand count)
     (setf (aref count (sort-value card)) (+ 1 (aref count (sort-value card))))
   )

  )
)

;; -----------------------------------
;; PRINTING-VERSION
;; -----------------------------------
;; Return a list of '(rank suit)
;; -----------------------------------
;; CARD: An instance of the card class
;; -----------------------------------

(defun printing-version( card )
  (list (rank card) (suit card))
)