; 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 card)
  (let ((r (rank card)))
    (cond ((equal? r 'a) 14)
          ((equal? r 'k) 13)
          ((equal? r 'q) 12)
          ((equal? r 'j) 11)
          (else r))))

; 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 (differences sent)
  (cond ((< (count sent) 2) '())
        (else (se (- (item 2 sent) (item 1 sent))
                  (differences (bf sent))))))

(define (consec datum sent)
  (consec-helper datum sent 0 0))
(define (consec-helper datum sent current maximum)
  (cond ((empty? sent) maximum)
        ((equal? (first sent) datum)
         (consec-helper datum (bf sent) (+ current 1) (max (+ current 1) maximum)))
        (else (consec-helper datum (bf sent) 0 maximum))))

; 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 (first sent))
            (numeric-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))))

; NOTE THAT ALL OF THE BELOW FUNCTIONS ASSUME THE HAND HAS BEEN
; SORTED BEFORE THE FUNCTION CALL
(define (straight-flush? sortedhand)  ;; means a straight and a flush at same time
  (and (straight? sortedhand) (flush? sortedhand)))

(define (royal-flush? sortedhand)     ;; very specific straight-flush
  (and (straight-flush? sortedhand) 
       (equal? (rank (last sortedhand)) 10)))  ; smallest card is a 10 --> AKQJ10

(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)))))

; Patterns are differences in hand ranks
;
; straight pattern: All -1s or '(-9 -1 -1 -1) for 5432A which
;   gets sorted as '(A 5 4 3 2)
(define (straight? sortedhand)
  (let ((diffs (differences (every numeric-rank sortedhand))))
    (or (equal? diffs '(-1 -1 -1 -1)) (equal? diffs '(-9 -1 -1 -1)))))

; x (and other variables for later functions) means some non-zero number
; quads pattern: '(0 0 0 x) or '(x 0 0 0)
(define (quads? sortedhand)    ;; remember, the hand is sorted by rank
  (let ((diffs (differences (every numeric-rank sortedhand))))
    (= (consec 0 diffs) 3)))  ; this suffices

; full-house pattern: '(0 0 x 0) or '(0 x 0 0)
(define (full-house? sortedhand)  ;; like quads?
  (let ((diffs (differences (every numeric-rank sortedhand))))
    (and (= (appearances 0 diffs) 3)
         (= (consec 0 diffs) 2))))

; trips pattern: '(0 0 x y), '(x 0 0 y), or '(x y 0 0)
(define (trips? sortedhand)
  (let ((diffs (differences (every numeric-rank sortedhand))))
    (and (= (appearances 0 diffs) 2)
         (= (consec 0 diffs) 2))))

; two-pair pattern: '(0 x 0 y), '(x 0 y 0), or '(0 x y 0)
(define (two-pair? sortedhand)
  (let ((diffs (differences (every numeric-rank sortedhand))))
    (and (= (appearances 0 diffs) 2)
         (= (consec 0 diffs) 1))))

; one-pair pattern: '(0 x y z), '(x 0 y z), '(x y 0 z), or '(x y z 0)
(define (one-pair? sortedhand)
  (let ((diffs (differences (every numeric-rank sortedhand))))
    (= (appearances 0 diffs) 1)))  ; this suffices


; Some hands for testing
;
; Use: (function (sort hand)) where hand is one of the below
(define roy '(s10 sk sq sa sj))  ; royal flush
(define stf '(s10 s8 s9 sj sq))  ; straight flush
(define qua '(s5 h10 h5 c5 d5))  ; quads (four of a kind)
(define fho '(s10 d7 h7 c10 s7)) ; full house (three of one kind, two of another)
(define flu '(sa s10 s7 sk s2))  ; flush
(define str '(d8 dj sq h10 d9))  ; straight
(define tri '(d5 s8 sa s5 c5))   ; trips
(define 2pr '(d7 s9 c7 sa h9))   ; two pair
(define 1pr '(d7 s9 c10 sa h9))  ; one pair
(define gbg '(d10 s9 c2 sa h5))  ; garbage