;;;
;;;
;;; Poker-hands demonstration
;;;
;;;

;;
;; Matcher definitions
;;
(define $suit
  (algebraic-data-matcher
    {<spade> <heart> <club> <diamond>}))

(define $card
  (algebraic-data-matcher
    {<card suit (mod 13)>}))

;;
;; A function that determines poker-hands
;;
(define $poker-hands
  (lambda [$cs]
    (match cs (multiset card)
      {[<cons <card $s $n>
         <cons <card ,s ,(- n 1)>
          <cons <card ,s ,(- n 2)>
           <cons <card ,s ,(- n 3)>
            <cons <card ,s ,(- n 4)>
             <nil>>>>>>
        "Straight flush"]
       [<cons <card _ $n>
         <cons <card _ ,n>
          <cons <card _ ,n>
            <cons <card _ ,n>
              <cons _
                <nil>>>>>>
        "Four of a kind"]
       [<cons <card _ $m>
         <cons <card _ ,m>
          <cons <card _ ,m>
           <cons <card _ $n>
            <cons <card _ ,n>
              <nil>>>>>>
        "Full house"]
       [<cons <card $s _>
         <cons <card ,s _>
           <cons <card ,s _>
             <cons <card ,s _>
               <cons <card ,s _>
                 <nil>>>>>>
        "Flush"]
       [<cons <card _ $n>
         <cons <card _ ,(- n 1)>
          <cons <card _ ,(- n 2)>
           <cons <card _ ,(- n 3)>
            <cons <card _ ,(- n 4)>
             <nil>>>>>>
        "Straight"]
       [<cons <card _ $n>
         <cons <card _ ,n>
          <cons <card _ ,n>
           <cons _
            <cons _
             <nil>>>>>>
        "Three of a kind"]
       [<cons <card _ $m>
         <cons <card _ ,m>
          <cons <card _ $n>
            <cons <card _ ,n>
             <cons _
               <nil>>>>>>
        "Two pair"]
       [<cons <card _ $n>
         <cons <card _ ,n>
          <cons _
           <cons _
            <cons _
             <nil>>>>>>
        "One pair"]
       [<cons _
         <cons _
          <cons _
           <cons _
            <cons _
             <nil>>>>>>
        "Nothing"]})))

;;
;; Demonstration code
;;
(assert-equal "poker hands 1"
  (poker-hands {<Card <Club> 12>
                <Card <Club> 10>
                <Card <Club> 13>
                <Card <Club> 1>
                <Card <Club> 11>})
  "Straight flush")

(assert-equal "poker hands 2"
  (poker-hands {<Card <Diamond> 1>
                <Card <Club> 2>
                <Card <Club> 1>
                <Card <Heart> 1>
                <Card <Diamond> 2>})
  "Full house")

(assert-equal "poker hands 3"
  (poker-hands {<Card <Diamond> 4>
                <Card <Club> 2>
                <Card <Club> 5>
                <Card <Heart> 1>
                <Card <Diamond> 3>})
  "Straight")

(assert-equal "poker hands 4"
  (poker-hands {<Card <Diamond> 4>
                <Card <Club> 10>
                <Card <Club> 5>
                <Card <Heart> 1>
                <Card <Diamond> 3>})
  "Nothing")