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 $or
  (lambda [$b1 $b2]
    (match b1 Bool
      {[<true> <true>]
       [<false> b2]})))

(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 ,s ,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 ,x ,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 ,x ,xs>]
                      <true>]
                     [[_ _] <false>]}))]
       })))

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

(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 ,hs <cons ,(not x) ,ts>>]
        <true>]
       [[_ _] <false>]})))


(test (match-all {{1 2 3} {4 5 1} {6 1 7}} (List (Multiset Int))
        [<cons <cons $n _>
               <cons <cons ,n _>
                     <cons <cons ,n _>
                           <nil>>>>
         n]))

(test (match (with $loop {1 @loop}) (List Int)
        {[<cons $m <cons $n _>> [m n]]
         [_ <not-ok>]}))

(test (let {[$pat <cons ,1 <nil>>]}
        (match {1} (Multiset Int)
          {[pat <ok>]
           [_ <not-ok>]})))

(test (match {1} (Multiset Int)
        {[(of {<nil> <cons ,1 <nil>>}) <ok>]
         [_ <not-ok>]}))

(test (let {[$loop <cons ,1 (of {<nil> loop})>]}
        (match {1 1 1 1} (Multiset Int)
          {[loop <ok>]
           [_ <not-ok>]})))

(test (match {1 1 1 1} (Multiset Int)
        {[(with $loop <cons ,1 (of {<nil> loop})>) <ok>]
         [_ <not-ok>]}))

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

(test (match-all {<x> <y> <z> <w>} (List Something)
        [<join $hs <cons $x $ts>> [hs x 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>}))