egison-2.2.1: lib/poker-hands.egi

(define $Suit
  (type
    {[$var-match (lambda [$tgt] {tgt})]
     [$inductive-match
      (destructor
        {[,$suit []
          {[$tgt (if (= tgt suit)
                     {[]}
                     {})]}]
         [<spade> []
          {[<spade> {[]}]
           [_ {}]}]
         [<heart> []
          {[<heart> {[]}]
           [_ {}]}]
         [<club> []
          {[<club> {[]}]
           [_ {}]}]
         [<diamond> []
          {[<diamond> {[]}]
           [_ {}]}]})]
     [$= eq?]}))

(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
    {[$var-match (lambda [$tgt] {tgt})]
     [$inductive-match
      (destructor
        {[,$card []
            {[$tgt (if (= tgt card)
                       {[]}
                       {})]}]
         [<card _ _> [Suit (Mod 13)]
          {[<card $s $n> {[s n]}]}]})]
     [$= (lambda [$val $tgt]
           (match [val tgt] [Card Card]
             {[[<card $s $n> <card ,s ,n>] #t]
              [[_ _] #f]}))]}))

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