; texas hold 'em

(define (take n xs)
  (let loop ((n n) (xs xs) (ys '()))
    (if (or (zero? n) (null? xs))
        (reverse ys)
        (loop (- n 1) (cdr xs)
              (cons (car xs) ys)))))

(define (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
    ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

(define (cons* first . rest)
  (let loop ((curr first) (rest rest))
    (if (null? rest) curr
        (cons curr (loop (car rest) (cdr rest))))))

(define (remove x xs)
  (let loop ((xs xs) (zs '()))
    (cond ((null? xs) (reverse zs))
          ((equal? (car xs) x) (loop (cdr xs) zs))
          (else (loop (cdr xs) (cons (car xs) zs))))))

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define-syntax assert
  (syntax-rules ()
    ((assert expr result)
      (if (not (equal? expr result))
          (for-each display `(
            #\newline "failed assertion:" #\newline
            expr #\newline "expected: " ,result
            #\newline "returned: " ,expr #\newline))))))

(define pips
  (let ((ps (map cons (map char-upcase
          (string->list "23456789TJQKA")) (range 2 15))))
    (lambda (card)
      (cdr (assoc (char-upcase
        (string-ref card 0)) ps)))))

(define (suit card)
  (char-upcase (string-ref card 1)))

(define (flush? hand)
  (apply char=? (map suit hand)))

(define (straight cs)
  (cond ((equal? cs '(14 5 4 3 2)) 5)
        ((apply = 1 (map - (take 4 cs) (cdr cs))) (car cs))
        (else #f)))

(define (same n cards)
  (let ((len (length cards)))
    (let loop ((i 0) (cards cards))
      (cond ((negative? (- len n i)) #f)
            ((apply = (take n cards)) (car cards))
            (else (loop (+ i 1) (cdr cards)))))))

(define (rank hand)
  (let ((cards (sort > (map pips hand))))
    (cond ((straight cards) =>
            (lambda (c)
              (if (flush? hand)
                  (list 9 c)
                  (list 5 c))))
          ((flush? hand) (cons 6 cards))
          ((same 4 cards) =>
            (lambda (c)
              (list 8 c (car (remove c cards)))))
          ((same 3 cards) =>
            (lambda (c)
              (let* ((cs (remove c cards))
                     (k (same 2 cs)))
                (if k (list 7 c k) (cons* 4 c cs)))))
          ((same 2 cards) =>
            (lambda (c)
              (let* ((cs (remove c cards))
                     (k (same 2 cs)))
                (if k (list 3 c k (car (remove k cs)))
                      (cons* 2 c cs)))))
          (else (cons 1 cards)))))

(define (test-rank)
  (assert (rank '("AH" "KH" "QH" "JH" "TH")) '(9 14))
  (assert (rank '("7H" "7C" "3H" "7S" "7D")) '(8 7 3))
  (assert (rank '("TH" "JC" "TS" "JD" "TC")) '(7 10 11))
  (assert (rank '("4H" "7H" "AH" "KH" "9H")) '(6 14 13 9 7 4))
  (assert (rank '("AH" "2C" "3S" "4D" "5H")) '(5 5))
  (assert (rank '("9C" "4S" "KD" "9D" "9H")) '(4 9 13 4))
  (assert (rank '("6D" "6C" "8H" "TD" "8D")) '(3 8 6 10))
  (assert (rank '("9C" "3S" "4D" "7C" "3D")) '(2 3 9 7 4))
  (assert (rank '("4C" "KD" "8S" "6D" "2D")) '(1 13 8 6 4 2))
)

(define (lt? hand1 hand2)
  (let loop ((h1 (rank hand1)) (h2 (rank hand2)))
    (cond ((or (null? h1) (null? h2)) #f)
          ((< (car h1) (car h2)) #t)
          ((< (car h2) (car h1)) #f)
          (else (loop (cdr h1) (cdr h2))))))

(define (combs n xs)
  (cond ((zero? n) '(()))
        ((null? xs) '())
        (else (append (map (lambda (c) (cons (car xs) c))
                           (combs (- n 1) (cdr xs)))
                      (combs n (cdr xs))))))

(define (best-hand cards)
  (let ((hands (combs 5 cards)))
    (let loop ((best (car hands)) (hands (cdr hands)))
      (cond ((null? hands) best)
            ((lt? best (car hands))
              (loop (car hands) (cdr hands)))
            (else (loop best (cdr hands)))))))

(test-rank) ; no news is good news

(display (best-hand '("AH" "JC" "7S" "7H" "AC" "8D" "AD")))

(AH 7S 7H AC AD)