list-test.egi

(define $Bool
  (type
    {[$var-match (lambda [$tgt] {tgt})]
     [$inductive-match
      (deconstructor
        {[true []
          {[<true> {[]}]
           [_ {}]}]
         [false []
          {[<falset> {[]}]
           [_ {}]}]
         })]
     [$equal?
      (lambda [$val $tgt]
        (match [val tgt] [Suit Suit]
          {[[<true> <true>] <true>]
           [[<false> <false>] <true>]
           [[_ _] <false>]}))]
     }))

(define $Something
  (type
    {[$var-match (lambda [$tgt] {tgt})]
     }))

(define $Suit
  (type
    {[$var-match (lambda [$tgt] {tgt})]
     [$inductive-match
      (deconstructor
        {[spade []
          {[<spade> {[]}]
           [_ {}]}]
         [heart []
          {[<heart> {[]}]
           [_ {}]}]
         [club []
          {[<club> {[]}]
           [_ {}]}]
         [diamond []
          {[<diamond> {[]}]
           [_ {}]}]
         })]
     [$equal?
      (lambda [$val $tgt]
        (match [val tgt] [Suit Suit]
          {[[<spade> <spade>] <true>]
           [[<heart> <heart>] <true>]
           [[<club> <club>] <true>]
           [[<diamond> <diamond>] <true>]
           [[_ _] <false>]}))]
     }))

(test ((type-ref Suit equal?) <spade> <spade>))

(define $Nat
  (type
    {[$var-match (lambda [$tgt] {tgt})]
     [$equal? (lambda [$val $tgt]
                (= val tgt))]}))

(define $Mod
  (lambda [$m]
    (type
      {[$var-match (lambda [$tgt] {(mod tgt m)})]
       [$equal? (lambda [$val $tgt]
                  (= (mod val m) (mod tgt m)))]})))

(test (match 10 Nat
        {[,(- 12 2) <ok>]
         [_ <not-ok>]}))

(test (match 10 (Mod 13)
        {[,(- 12 2) <ok>]
         [_ <not-ok>]}))

(define $Card
  (type
    {[$var-match (lambda [$tgt] {tgt})]
     [$inductive-match
      (deconstructor
        {[card [Suit (Mod 13)]
          {[<card $s $n> {[s n]}]}]})]
     [$equal? (lambda [$val $tgt]
                (match [val tgt] [Card Card]
                  {[[<card $s $n>
                     <card (on [$s] ,s) (on [$n] ,n)>]
                    <true>]
                   [[_ _] <false>]}))]}))

(test (match <card <diamond> 12> Card
        {[<card <club> ,12> <not-ok>]
         [<card <diamond> ,10> <not-ok>]
         [,<card <diamond> 12> <ok2>]
         [<card _ ,12> <ok>]
         [_ <not-ok>]}))

(define $List
  (lambda [$a]
    (type
      {[$var-match (lambda [$tgt] {tgt})]
       [$inductive-match
        (deconstructor
          {[nil []
            {[{} {[]}]
             [_ {}]
             }]
           [cons [a (List a)]
            {[{$x .$xs} {[x xs]}]
             [_ {}]
             }]
           [snoc [a (List a)]
            {[{.$xs $x} {[x xs]}]
             [_ {}]
             }]
           [join [(List a) (List a)]
            {[$tgt (let {[$loop
                       (lambda [$ts]
                         (match ts (List a)
                           {[<nil> {[{} {}]}]
                            [<cons $x $xs>
                             {[{} ts]
                              @(map (lambda [$as $bs]
                                      [{x @as} bs])
                                    (loop xs))}]}))]}
                   (loop tgt))]
             }]
           [nioj [(List a) (List a)]
            {[$tgt (let {[$loop
                       (lambda [$ts]
                         (match ts (List a)
                           {[<nil> {[{} {}]}]
                            [<snoc $x $xs>
                             {[{} ts]
                              @(map (lambda [$as $bs]
                                      [{@as x} bs])
                                    (loop xs))}]}))]}
                   (loop tgt))]
             }]
           })]
       [$equal? (lambda [$val $tgt]
             (match [val tgt] [(List a) (List a)]
               {[[<nil> <nil>] <true>]
                [[<cons $x $xs>
                  <cons (on [$x] ,x) (on [$xs] ,xs)>]
                 <true>]
                [[_ _] <false>]}))]
       })))

(test (match-map {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]]))

(define $map
  (lambda [$fn $ls]
    (match ls (List Something)
      {[<nil> {}]
       [<cons $x $xs> {(fn x) @(map fn xs)}]})))

(test (match-map {<x> <y> <z> <w>} (List Something)
        [<join $hs <cons $x $ts>> [hs x ts]]))

(define $remove
  (lambda [$a]
    (lambda [$xs $x]
      (match xs (List a)
        {[<nil> {}]
         [<cons ,x $rs> rs]
         [<cons $y $rs> {y @((remove a) rs x)}]}))))

(test ((remove Suit) {<club> <diamond>} <diamond>))

(test ((remove Nat) {1 2} 1))

(define $remove-collection
  (lambda [$a]
    (lambda [$xs $ys]
      (match ys (List a)
        {[<nil> xs]
         [<cons $y $rs> ((remove-collection a) ((remove a) xs y) rs)]}))))

(test ((remove-collection Suit) {<club> <heart> <diamond>} {<club> <diamond>}))

(define $subcollection
  (lambda [$xs]
    (match xs (List Something)
      {[<nil> {{}}]
       [<cons $x $rs>
        (let {[$subs (subcollection rs)]}
          {@subs @(map (lambda [$sub] {x @sub})
                       subs)})]
       })))

(test (subcollection {<x> <y> <z>}))

(define $Multiset
  (lambda [$a]
    (type
      {[$var-match (lambda [$tgt] {tgt})]
       [$inductive-match
        (deconstructor
          {[nil []
            {[{} {[]}]
             [_ {}]
             }]
           [cons [a (Multiset a)]
            {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])
                        tgt)]
             }]
           [join [(Multiset a) (Multiset a)]
            {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])
                        (subcollections tgt))]
             }]
           })]
       [$equal? (lambda [$val $tgt]
                  (match [val tgt] [(Multiset a) (Multiset a)]
                    {[[<nil> <nil>] <true>]
                     [[<cons $x $xs>
                       <cons (on [$x] ,x) (on [$xs] ,xs)>]
                      <true>]
                     [[_ _] <false>]}))]
       })))


(define $one-pair
  (lambda [$ns]
    (match ns (Multiset Suit)
      {[<cons $n <cons (on [$n] ,n) _>> <ok>]
       [_ <nothing>]})))
                 
(test (one-pair {<club> <spade> <club>}))

(define $list-nat
  (lambda [$ns]
    (match ns (List Nat)
      {[<cons $n <cons (on [$n] ,n) _>> n]
       [_ <not-ok>]})))

(test (list-nat {1 1 3}))

(define $multiset-nat
  (lambda [$ns]
    (match ns (Multiset Nat)
      {[<cons $n <cons (on [$n] ,n) _>> n]
       [_ <not-ok>]})))

(test (multiset-nat {1 1 3}))

(define $full-house
  (lambda [$ns]
    (match ns (Multiset Nat)
      {[<cons $m
         <cons (on [$m] ,m)
          <cons (on [$m] ,m)
           !<cons $n
             !<cons (on [$n] ,n)
               !<nil>
               >>>>>
        <full-house>]
       [_ <nothing>]
       })))

(test (full-house {1 1 0 0 1}))

(define $poker-hands
  (lambda [$Cs]
    (match Cs (Multiset Card)
      {[<cons <card $S $n>
         <cons <card (on [$S] ,S) (on [$n] ,(- n 1))>
          <cons <card (on [$S] ,S) (on [$n] ,(- n 2))>
           <cons <card (on [$S] ,S) (on [$n] ,(- n 3))>
            <cons <card (on [$S] ,S) (on [$n] ,(- n 4))>
             !<nil>
             >>>>>
        <straight-flush>]
       [<cons <card _ $n>
         <cons <card _ (on [$n] ,n)>
          !<cons <card _ (on [$n] ,n)>
            !<cons <card _ (on [$n] ,n)>
              !<cons _
                !<nil>
                >>>>>
        <four-of-kind>]
       [<cons <card _ $m>
         <cons <card _ (on [$m] ,m)>
          <cons <card _ (on [$m] ,m)>
           !<cons <card _ $n>
             !<cons <card _ (on [$n] ,n)>
               !<nil>
               >>>>>
        <full-house>]
       [<cons <card $S _>
         !<cons <card (on [$S] ,S) _>
           !<cons <card (on [$S] ,S) _>
             !<cons <card (on [$S] ,S) _>
               !<cons <card (on [$S] ,S) _>
                 !<nil>
                 >>>>>
        <flush>]
       [<cons <card _ $n>
         <cons <card _ (on [$n] ,(- n 1))>
          <cons <card _ (on [$n] ,(- n 2))>
           <cons <card _ (on [$n] ,(- n 3))>
            <cons <card _ (on [$n] ,(- n 4))>
             !<nil>
             >>>>>
        <straight>]
       [<cons <card _ $n>
         <cons <card _ (on [$n] ,n)>
          <cons <card _ (on [$n] ,n)>
           !<cons _
             !<cons _
               !<nil>
               >>>>>
        <three-of-kind>]
       [<cons <card _ $m>
         <cons <card _ (on [$m] ,m)>
          !<cons <card _ $n>
            <cons <card _ (on [$n] ,n)>
             !<cons _
               !<nil>
               >>>>>
        <two-pair>]
       [<cons <card _ $n>
         <cons <card _ (on [$n] ,n)>
          !<cons _
            !<cons _
              !<cons _
                !<nil>
                >>>>>
        <one-pair>]
       [<cons _
         !<cons _
           !<cons _
             !<cons _
               !<cons _
                 !<nil>
                 >>>>>
        <nothing>]})))

(test (poker-hands {<card <club> 4>
                    <card <club> 2>
                    <card <club> 5>
                    <card <club> 1>
                    <card <club> 3>}))

(test (poker-hands {<card <diamond> 1>
                    <card <club> 2>
                    <card <club> 1>
                    <card <heart> 1>
                    <card <diamond> 2>}))

(test (poker-hands {<card <diamond> 4>
                    <card <club> 2>
                    <card <club> 5>
                    <card <heart> 1>
                    <card <diamond> 3>}))

(test (poker-hands {<card <diamond> 4>
                    <card <club> 10>
                    <card <club> 5>
                    <card <heart> 1>
                    <card <diamond> 3>}))

(define $car
  (lambda [$as]
    (match as (List Something)
      {[<cons $a _> a]})))

(define $reverse
  (lambda [$as]
    (match as (List Something)
      {[<nil> {}]
       [<cons $a $rs>
        {@(reverse rs) a}]})))