;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
(newline)
(display "Playing card and poker hand support functions: Version 1.1\n")
(display "Copyright (c) 2000 Wesley H. Huang.  All rights reserved.\n")
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; I suggest you keep *error-checking* set to #t if you are writing
; functions that call these routines.  Some routines can accept
; invalid inputs but not give any error message.  With
; *error-checking* set #t, inputs to "public" functions are checked
; for validity.  This variable is used in conjunction with the "check"
; function to print an error message and signal an error for invalid
; arguments.
; 
(define *error-checking* #t)

;
; preliminary stuff for cards
;
(define card-values ' (ace king queen jack 10 9 8 7 6 5 4 3 2))
(define card-suits '(spades diamonds clubs hearts))

(define (card-value:> a b)
  (member b (cdr (member a card-values))))
(define (card-value:< a b)
  (card-value:> b a))

(define card-value car)
(define card-suit cadr)

; creates a string that is an abbreviated version of the card
; useful for printing a hand of cards!
; 
(define (card-string c)
  (string-append  (case (car c)
			((2 3 4 5 6 7 8 9 10) (number->string (car c)))
			((jack) "J")
			((queen) "Q")
			((king) "K")
			((ace) "A"))
		  (case (cadr c)
		    ((spades) "-S")
		    ((clubs) "-C")
		    ((diamonds) "-D")
		    ((hearts) "-H"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; (shuffled-deck)
; 
; returns a shuffled deck of cards (a random permutation of all 52 cards)
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (shuffled-deck)
  (shuffle (ordered-deck)))

; create a random permutation of the given list
(define (shuffle original-lst)
  (define (helper lst n)
    (if (= n (length original-lst))
	lst
	(helper (swap lst n (random (1+ n)))
		(1+ n))))
  (helper original-lst 1))

; this creates a deck of cards in order by suit and then value
(define (ordered-deck)
  (apply append (map (lambda (suit)
		       (map (lambda (value)
			      (list value suit))
			    card-values))
		     card-suits)))

; the swap function from Assignment 2!
(define (swap l x y)
  (let ((y-el (list-ref l y))
        (x-el (list-ref l x)))
    (define (swap-helper lst n)
      (cond
       ((null? lst) '())
       ((= n x) (cons y-el (swap-helper (cdr lst) (+ n 1))))
       ((= n y) (cons x-el (swap-helper (cdr lst) (+ n 1))))
       (else (cons (car lst) (swap-helper (cdr lst) (+ n 1))))))

    (swap-helper l 0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; (evaluate-cards cards)
;
; Given a list of five cards, it determines what hand you have.  It
; does this by sorting the card values, and looking for certain
; features of the hand: pairs, triples, quads (4 of the same value),
; straight, and flush.  It then uses these features to classify the
; hand.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (evaluate-cards cards)
  (check "evaluate-cards" valid-cards? cards)
  (let* ((values-list (sort (map card-value cards) card-value:>))
	 (pairs   (count-matches 2 values-list))
	 (triples (count-matches 3 values-list))
	 (quads   (count-matches 4 values-list))
	 (is-straight (straight? values-list))
	 (is-flush  (flush? (map card-suit cards))))
    ; The ace low straight (flush) needs to be handled as a special case here
    (if (equal? values-list '(Ace 5 4 3 2))
	(begin
	  (set! is-straight #t)
	  (set! values-list '(5))))
    (cond
     ((and is-flush is-straight) 
      (list 'straight-flush (car values-list)))	; need only the highest value
     ((not (null? quads))
      (cons 'four-ofakind quads))	; need only the (single) value
     ((and (not (null? triples))
	   (not (null? pairs)))
      (cons 'full-house triples))	; need only the (single) value
     (is-flush
      (cons 'flush values-list))	; need all the values for a flush
     (is-straight
      (list 'straight (car values-list))) ; need only the highest value
     ((not (null? triples))
      (cons 'three-ofakind triples))	; need only the (single) value
     ((= (length pairs) 2)
      ; need the value of the pairs in decreasing order
      ; then the values of the remaining card
      (cons 'two-pairs (append (sort pairs card-value:>)
			       (list-transform-positive values-list
				 (lambda (v)
				   (not (member v pairs)))))))
     ((= (length pairs) 1)
      ; need the value of the pair followed by the values of the
      ; remaining cards 
      (cons 'one-pair (append pairs
			      (list-transform-positive values-list
				(lambda (v)
				  (not (member v pairs)))))))
     (else
      ; need all the card values
      (cons 'high-card values-list)))))

; (count-matches N lst)
;		    
; looks for values which are repeated exactly N times in the given
; list.  It returns a list of all such values.  The given list must be
; sorted so that identical values will appear consecutively.
; 
(define (count-matches N lst)
  (define (so-far remaining-lst last-value num-matches results)
    (if (null? remaining-lst)
	; end of the list, but check the last value
	(if (= num-matches N)
	    (cons last-value results)
	    results)
	; otherwise, see if the next element matches the last-value
	(if (equal? (car remaining-lst) last-value)
	    ; if so, recurse (until we find something different or we
	    ; reach the end of the list)
	    (so-far (cdr remaining-lst) last-value (1+ num-matches) results)
	    ; this value doesn't match the previous one.  see if we
	    ; found exactly N occurences of the previous value and if
	    ; so, add it to the results list.
	    (so-far (cdr remaining-lst) (car remaining-lst) 1
		    (if (= num-matches N)
			(cons last-value results)
			results)))))
  (so-far (cdr lst) (car lst) 1 '()))

; (straight? value-list)
;
; return #t if the list of card values (which must be given in
; descending order) are consecutive.
;
; The Ace low straight is handled as a special case in evaluate-cards
;
(define (straight? value-list)
  (define (check-sequence remaining-values sequence)
    (cond
     ((null? remaining-values) #t)
     ((null? sequence) #f) ; without this 5 4 3 2 2 produces an error
     ((not (equal? (car remaining-values) (car sequence))) #f)
     (else (check-sequence (cdr remaining-values)
			   (cdr sequence)))))

  (check-sequence (cdr value-list) 
		  (cdr (member (car value-list) card-values))))

; (flush? suit-list)
; 
; return #t of all the suits in the given list are the same.  (just
; checks whether all the elements of this list are the same as the
; first element.)
;
(define (flush? suit-list)
  (define (compare-suits remaining)
    (if (null? remaining)
	#t
	(if (equal? (car suit-list) (car remaining))
	    (compare-suits (cdr remaining))
	    #f)))
  (compare-suits (cdr suit-list)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; preliminary stuff for hands
;


(define hand-ordering
  '(straight-flush four-ofakind full-house flush straight three-ofakind
		   two-pairs one-pair high-card))

; some definitions to make specifying generic hands easier (with no quoting)
(define high-card '(high-card))
(define one-pair '(one-pair))
(define two-pairs '(two-pairs))
(define three-ofakind '(three-ofakind))
(define straight '(straight))
(define flush '(flush))
(define full-house '(full-house))
(define four-ofakind '(four-ofakind))
(define straight-flush '(straight-flush))

; returns #t if hand1 is of a higher category than hand 2
(define (hand:higher? hand1 hand2)
 (not (member (car hand1) (member (car hand2) hand-ordering))))

; returns #t if hand1 is of a lower category than hand2
(define (hand:lower? hand1 hand2)
  (hand:higher? hand2 hand1))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; comparison operators for poker hands
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (poker:>= hand1 hand2)
  (check "poker:>=" valid-hand? hand1 valid-hand? hand2)
  (cond
   ((hand:higher? hand1 hand2) #t)
   ((hand:lower? hand1 hand2) #f)
   (else (compare-values:>= (cdr hand1) (cdr hand2)))))

(define (poker:> hand1 hand2)
  (check "poker:>" valid-hand? hand1 valid-hand? hand2)
  (cond
   ((hand:higher? hand1 hand2) #t)
   ((hand:lower? hand1 hand2) #f)
   (else (compare-values:> (cdr hand1) (cdr hand2)))))

(define (poker:<= hand1 hand2)
  (check "poker:<=" valid-hand? hand1 valid-hand? hand2)
  (poker:>= hand2 hand1))

(define (poker:< hand1 hand2)
  (check "poker:<" valid-hand? hand1 valid-hand? hand2)
  (poker:> hand2 hand1))

; this just compares to make sure that all elements of the two hands
; are the same.  If one is a generic hand (i.e. no card values
; specified) then we return #t because they are in the same category.
;
(define (poker:= hand1 hand2)
  (check "poker:=" valid-hand? hand1 valid-hand? hand2)
  (define (compare-values h1 h2)
    (if (or (null? h1) (null? h2))
	#t
	(if (equal? (car h1) (car h2))
	    (compare-values (cdr h1) (cdr h2))
	    #f)))
  (compare-values hand1 hand2))

; (compare-values:>= values1 values2)
; (compare-values:>  values1 values2)
; (compare-values:<= values1 values2)
; (compare-values:<  values1 values2)
;
; functions for comparing the lists of values for two hands of the
; same category.
;
(define (compare-values:>= values1 values2)
  (cond
   ; base case: if we've compared all the values or if one of the
   ; hands is generic (i.e. no values specified) then return #t
   ((or (null? values1) (null? values2)) #t)
   ((card-value:> (car values1) (car values2)) #t)
   ((card-value:< (car values1) (car values2)) #f)
   (else (compare-values:>= (cdr values1) (cdr values2)))))

(define (compare-values:<= values1 values2)
  (compare-values:>= values2 values1))

(define (compare-values:> values1 values2)
  (cond
   ; base case: if we've compared all the values or if one of the
   ; hands is generic (i.e. no values specified) then return #f
   ((or (null? values1) (null? values2)) #f)
   ((card-value:> (car values1) (car values2)) #t)
   ((card-value:< (car values1) (car values2)) #f)
   (else (compare-values:> (cdr values1) (cdr values2)))))

(define (compare-values:< values1 values2)
  (compare-values:> values2 values1))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; (hi/lo-hand public-hand excluded-cards)
;
; Given a list of cards to exclude from consideration, return the
; highest and lowest possible hand a player could have given its
; public cards.  (The cards in the public-cards must be included in the
; excluded-cards list.)
;
; This function first removes any excluded card from a full deck to
; get the list of cards which it must consider.  It computes the hand
; formed by taking the first of these cards; this is both the
; highest and lowest hand so far.  Then it cycles through the rest of
; the cards under consideration, updating the hi-hand and lo-hand
; parameters as required.
; 
; Returns a list where the first element is the hi-hand and the second
; element is the lo-hand.
;
; This function is used in the play-hand function to precompute all
; the hi and lo hands for all players, both from a "public"
; perspective (for the my/hi-hand and my/lo-hand variables) and from
; individual players perspectives (for the hi-hand and lo-hand
; functions).  The difference is that individual players know their
; own hole card, whereas the "public" does not know anyone's hole
; card).
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (hi/lo-hand public-cards excluded-cards)
  (check "hi/lo-hand" valid-public-cards? public-cards
	 checkcards excluded-cards)
  (let* ((possible-cards (list-transform-negative (ordered-deck)
			   (lambda (c)
			     (member c excluded-cards))))
	 (first-hand (evaluate-cards (cons (car possible-cards)
					   public-cards))))
    (define (consider-cards card-list hi-hand lo-hand)
      (if (null? card-list)
	  (list hi-hand lo-hand)
	  (let ((h (evaluate-cards (cons (car card-list)
					 public-cards))))
	    (consider-cards (cdr card-list)
			    (if (poker:> h hi-hand)
				h
				hi-hand)
			    (if (poker:< h lo-hand)
				h
				lo-hand)))))
    (consider-cards (cdr possible-cards) first-hand first-hand)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;  functions for error checking
;
; the function name should be a string so it can appear in the mesage
; the "tests" should be a function and then an argument (in order)
; for example: (check "myfunc" integer? a checkcards b)
; 
(define (check funcname . tests)
  (define (ch t n)
    (if (null? t)
	#t
	(if (apply (car t) (list (cadr t)))
	    (ch (list-tail t 2) (1+ n))
	    (begin
	      (print "\n;Invalid argument given as argument " n " of function "
		     funcname "\n")
	      (error "Offending argument is:" (cadr t))))))
  (if *error-checking*
      (ch tests 1)))


; valid public-cards is a list of four valid cards
(define (valid-public-cards? c)
  (if (= (length c) 4)
      (checkcards c)
      #f))

; valid "cards" means a list of five valid cards
(define (valid-cards? c)
  (if (= (length c) 5)
      (checkcards c)
      #f))

; (checkcards lst)
;
; checks to see that all elements of the list are valid cards.
; doesn't check for duplicate cards or anything like that
(define (checkcards lst)
  (if (null? lst)
      #t
      (if (and (list? (car lst))
	       (= (length (car lst)) 2)
	       (member (caar lst) card-values)
	       (member (cadar lst) card-suits))
	  (checkcards (cdr lst))
	  #f)))
; (valid-hand? h)
; 
; make sure the hand category is correct, it is a generic hand (with
; no additional information) or has the proper numbers of valid values
; for the hand category.
; 
(define (valid-hand? h)
  (case (car h)
    ((straight-flush) (or (null? (cdr h)) (valid-value-list? (cdr h) 1)))
    ((four-ofakind) (or (null? (cdr h)) (valid-value-list? (cdr h) 1)))
    ((full-house) (or (null? (cdr h)) (valid-value-list? (cdr h) 1)))
    ((flush) (or (null? (cdr h)) (valid-value-list? (cdr h) 5)))
    ((straight) (or (null? (cdr h)) (valid-value-list? (cdr h) 1)))
    ((three-ofakind) (or (null? (cdr h)) (valid-value-list? (cdr h) 1)))
    ((two-pairs) (or (null? (cdr h)) (valid-value-list? (cdr h) 3)))
    ((one-pair) (or (null? (cdr h)) (valid-value-list? (cdr h) 4)))
    ((high-card) (or (null? (cdr h)) (valid-value-list? (cdr h) 5)))
    (else #f)))

; returns #t if there are exactly N valid card values given in lst
(define (valid-value-list? lst N)
  (cond
   ((null? lst) (= N 0))
   ((= N 0) #f)
   ((member (car lst) card-values) (valid-value-list? (cdr lst) (-1+ N)))
   (else #f)))