collection-test.egi

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

(define $Order
  (type
    {[$var-match (lambda [$tgt] {tgt})]
     [$inductive-match
      (deconstructor
        {[less []
          {[<equal> {[]}]
           [_ {}]}]
         [equal []
          {[<equal> {[]}]
           [_ {}]}]
         [greater []
          {[<greater> {[]}]
           [_ {}]}]
         })]
     [$equal?
      (lambda [$val $tgt]
        (match [val tgt] [Order Order]
          {[[<less> <less>] <true>]
           [[<equal> <equal>] <true>]
           [[<greater> <greater>] <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>]}))]
     }))

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

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

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

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

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

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

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

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

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

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

(define $min
  (lambda [$Ns]
    (match Ns (List Int)
      {[<cons $n <nil>> n]
       [<cons $n $Rs>
        (let {[$r (min Rs)]}
          (match ((type-ref Int compare) n r) Order
            {[<less> n]
             [_ r]}))]})))       

(define $gcd
  (lambda [$ns]
    (let {[$ns2 ((remove-all Int) ns 0)]}
      (match ns2 (Set Int)
        {[<cons $n <nil>> n]
         [<cons ,(min ns2)
                $Rs>
          (gcd {n @(map (lambda [$r] (mod r n))
                        Rs)})]}))))

(define $gcd
  (lambda [$Ns]
    (let {[$Ns2 (remove-all Ns 0)]}
      (match Ns2 (Set Int)
        {[<cons $n <nil>> n]
         [<cons ,(min Ns2)
                $Rs>
          (gcd {n @(map (lambda [$r] (mod r n))
                        Rs)})]}))))

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

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

(define $member?
  (lambda [$a]
    (lambda [$x $ys]
      (match ys (List a)
        {[<nil> <false>]
         [<cons ,x $ys> <true>]
         [<cons $y $ys> ((member? a) x ys)]
         }))))

(define $unique
  (lambda [$a]
    (lambda [$xs]
      (let {[$loop (lambda [$xs $ys]
                     (match xs (List a)
                       {[<nil> ys]
                        [<cons $x $rs>
                         (match ((member? a) x ys) Bool
                           {[<true> (loop rs ys)]
                            [<false> (loop rs {@ys x})]
                            [_ {}]
                            })]}))]}
        (loop xs {})))))

(define $Set
  (lambda [$a]
    (let
      {[$Loop
        (type
          {[$var-match
            (lambda [$ts1 $ts2]
              (map (lambda [$sts2] {@ts1 @sts2})
                   (subcollections ts2)))]
           [$inductive-match
            (deconstructor
              {[nil []
                {[[{} _] {[]}]
                 [[_ _] {}]
                 }]
               [cons [a Loop]
                {[[$ts1 $ts2]  (map (lambda [$t] [t [((remove a) ts1 t)
                                                     {@ts2 t}]])
                                    {@ts1 @ts2})]
                 }]
               [join [(Set a) Loop]
                {[[$ts1 $ts2] (map (lambda [$ts] [ts [((remove-collection a) ts1 ts)
                                                      {@ts2 ts}]])
                                   (subcollections {@ts1 @ts2}))]
                 }]
               })]
           [$equal? <undefined>]
           })]}
      (type
        {[$var-match (lambda [$tgt] {$tgt})]
         [$inductive-match
          (lambda [$tgt]
            (let {[$tgt2 ((unique a) tgt)]}
              ((type-ref Loop inductive-match) [tgt2 {}])))]
         [$equal? <undefined>]}))))

(define $not
  (lambda [$b]
    (match b Bool
      {[<true> <false>]
       [<false> <true>]})))

(define $ham1
  (lambda [$xs $ys]
    (match [xs ys] [(List Bool) (List Bool)]
      {[[<join $hs <cons $x $ts>>
         <join (on [$hs] ,hs) <cons (on [$x] ,(not x)) (on [$ts] ,ts)>>]
        <true>]
       [[_ _] <false>]})))

(define $ham1
  (lambda [$xs $ys]
    (match [xs ys] [(List Bool) (List Bool)]
      {[[<join $hs <cons $x $ts>>
         <join (on [$hs] ,{}) <cons (on [$x] ,(not x)) (on [$ts] ,{})>>]
        <true>]
       [[_ _] <false>]})))

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

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

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

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

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

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

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