(load "/Applications/PLT/scheme/simply.scm")

; Kinda sorta nice functions to have--not really necessary
(define (second thing) (first (bf thing)))
(define (third thing) (item 3 thing))
(define (fourth thing) (item 4 thing))
(define (fifth thing) (item 5 thing))
; Some useful definitions relating to poker hands
(define ranks '(A K Q J 10 9 8 7 6 5 4 3 2))
(define suits '(S H D C))
(define (numeric-rank rank)
  (cond ((number? rank) rank)
        ((member? rank 'aA) 14)
        ((member? rank 'kK) 13)
        ((member? rank 'qQ) 12)
        ((member? rank 'jJ) 11)))

; Constructor and selectors for cards
(define (make-card suit rank)  ;; we never use this, but it shows
  (word suit rank))            ;; how a card is constructed
(define (rank card) (bf card))
(define (suit card) (first card))

; Some previous problem solutions that are kind of nice to have
; for solving some of the poker hand problems
(define (count-adjacent-duplicates sent)
  (cond ((< (count sent) 2) 0)
        ((equal? (first sent) (first (bf sent)))
         (+ 1 (count-adjacent-duplicates (bf sent))))
        (else (count-adjacent-duplicates (bf sent)))))

(define (differences sent)
  (cond ((< (count sent) 2) '())
        (else (se (- (first sent) (first (bf sent))) 
                  (differences (bf sent))))))

; Bubble sort program to put the cards in descending order
(define (sort hand)
  ((repeated sort-once (- (count hand) 1)) hand))
(define (sort-once sent)
  (cond ((empty? sent) sent)
        ((= (count sent) 1) sent)
        ((> (numeric-rank (rank (first sent)))
            (numeric-rank (rank (second sent))))
         (se (first sent) (sort-once (bf sent))))
        (else (se (second sent)
                  (sort-once (se (first sent) (bf (bf sent))))))))

; The main program.  NOTE I have not put in the specifics such as
; which suit made a flush or the rank of a pair; I leave that to 
; the reader to complete.
;
; Note also the decision to sort the hand immediately in the poker-value
; function.  I'm cheating a little bit in that this sort permits me to
; avoid sorting in the predicate functions themselves.
(define (poker-value hand)
  (let ((sortedhand (sort hand)))
    (cond ((royal-flush? sortedhand) 'ROYAL)
          ((straight-flush? sortedhand) 'STRAIGHT-FLUSH)
          ((full-house? sortedhand) 'FULL-HOUSE)
          ((quads? sortedhand) 'QUADS)
          ((flush? sortedhand) 'FLUSH)
          ((straight? sortedhand) 'STRAIGHT)
          ((trips? sortedhand) 'TRIPS)
          ((two-pair? sortedhand) 'TWO-PAIR)
          ((one-pair? sortedhand) 'PAIR)
          (else 'GARBAGE))))

(define (straight-flush? hand)  ;; means a straight and a flush at same time
  (and (straight? hand) (flush? hand)))

(define (royal-flush? hand)     ;; very specific straight-flush
  (and (straight-flush? hand) 
       (equal? (rank (last hand)) 10)))

(define (flush? hand)   ;; are all the cards the same suit as the first card
  (let ((sut (suit (first hand))))
    (= 5 (count (keep (lambda (s) (equal? (suit s) sut)) hand)))))

(define (straight? hand)   ;; note the special case--why '(9 1 1 1)?
  (let ((diffs (differences (every numeric-rank (every rank hand)))))
    (cond ((equal? diffs '(9 1 1 1)) #t)  ; 5432A sorts to A5432
          ((and (= (first diffs) 1) 
                (= (count-adjacent-duplicates diffs) 3)) #t)
          (else #f))))

(define (quads? hand)    ;; remember, the hand is sorted by rank
  (or (equal? (rank (first hand)) (rank (fourth hand)))
      (equal? (rank (second hand)) (rank (fifth hand)))))

(define (full-house? hand)  ;; like quads?
  (or (and (equal? (rank (first hand)) (rank (third hand)))
           (equal? (rank (fourth hand)) (rank (fifth hand))))
      (and (equal? (rank (first hand)) (rank (second hand)))
           (equal? (rank (third hand)) (rank (fifth hand))))))

(define (trips? hand)
  (let ((hand (every numeric-rank (every rank hand))))
    (and (= (count-adjacent-duplicates hand) 2)
         (= (count-adjacent-duplicates (differences hand)) 1))))

(define (two-pair? hand)
  (let ((h (every rank hand)))
    (and (= (count-adjacent-duplicates h) 2)
         (not (trips? hand)))))

(define (one-pair? hand)
  (let ((hand (every rank hand)))
    (= (count-adjacent-duplicates hand) 1)))

(define h1 '(d8 dj sq h10 d9))