egison-2.3.0: lib/poker-hands.egi

(define $Suit
  (type
    {[,$suit []
      {[$tgt (if (eq? tgt suit)
                 {[]}
                 {})]}]
     [<spade> []
      {[<spade> {[]}]
       [_ {}]}]
     [<heart> []
      {[<heart> {[]}]
       [_ {}]}]
     [<club> []
      {[<club> {[]}]
       [_ {}]}]
     [<diamond> []
      {[<diamond> {[]}]
       [_ {}]}]
     [_ [Something]
      {[$tgt {tgt}]}]
     }))

(define $Mod
  (lambda [$m]
    (type
      {[$var-match (lambda [$tgt] {(mod tgt m)})]
       [$inductive-match
        (destructor
          {[,$n []
            {[$tgt (if (= tgt n)
                       {[]}
                       {})]}]})]
       [$= (lambda [$val $tgt] (eq-n? (mod val m) (mod tgt m)))]})))

(define $Card
  (type
    {[,$card []
      {[$tgt (match [val tgt] [Card Card]
               {[[<card $s $n> <card ,s ,n>] {[]}]
                [[_ _] {}]})]}]
     [<card _ _> [Suit (Mod 13)]
      {[<card $s $n> {[s n]}]}]
     [_ [Something]
      {[$tgt {tgt}]}]
     }))

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