collection-test.egi

(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 $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 $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 $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} (Multiset Number)
        [<cons $x <cons $y <cons $z <nil>>>> [x y z]]))

(test (match-all {{1 2 3} {4 5 1} {6 1 7}} (List (Multiset Number))
        [<cons <cons $x _>
               <cons <cons $y _>
                     <cons <cons $z _>
                           <nil>>>>
         [x y z]]))

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

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

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

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

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

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

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

(test (match {0 1 0 1} (List Number)
        {[(of {<cons ,0 (with $loop (of {<cons ,0 loop> <cons ,1 loop> <nil>}))>
               <cons ,1 (with $loop (of {<cons ,0 loop> <cons ,1 loop> <nil>}))>})
          <ok>]
         [_ <ko>]}))

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

(test (match-all {1 2 3} (List Number)
        [<join $hs $ts> [hs ts]]))

(test (match-all {1 2 3} (Multiset Number)
        [<join $hs $ts> [hs ts]]))

(test (match-all {1 2 3} (Set Number)
        [<join $hs $ts> [hs ts]]))

(test (match-all {1 2 3} (List Number)
        [<join $hs <cons $x $ts>> [hs x ts]]))

(test (match-all {1 2 3} (Multiset Number)
        [<join $hs <cons $x $ts>> [hs x ts]]))

(test (match-all {1 2 3} (Set Number)
        [<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>}))

(test (match {2 7 7 2 7} (Multiset Number)
        {[<cons $m
           <cons ,m
            <cons ,m
             !<cons $n
               !<cons ,n
                 !<nil>>>>>>
          <ok>]
         [ _ <ko>]}))

(test (match {5 2 1 3 4} (Multiset Number)
        {[<cons $n
           <cons ,(- n 1)
            <cons ,(- n 2)
             <cons ,(- n 3)
              <cons ,(- n 4)
               <nil>>>>>>
          <ok>]
         [ _ <ko>]}))

(test (match-all {1 2 3 4 5} (Multiset Number)
        [<cons $n $rest> [n rest]]))

(test (let {[$f (lambda [$x] (+ (g x) 10))]
            [$g (lambda [$x] (+ x 1))]}
        (f 0)))

(define $Stick
  (lambda [$a]
    (type
      {[$var-match (lambda [$tgt] {tgt})]
       [$inductive-match
        (deconstructor
          {[nil []
            {[$tgt (match-all tgt (List a) [<nil> []])]
             }]
           [cons [a (List a)]
            {[$tgt {@(match-all tgt (List a) [<cons $x $xs> [x xs]])
                    @(match-all (reverse tgt) (List a) [<cons $x $xs> [x xs]])}]
             }]
           [join [(List a) (List a)]
            {[$tgt {@(match-all tgt (List a) [<join $xs $ys> [xs ys]])
                    @(match-all (reverse tgt) (List a) [<join $xs $ys> [xs ys]])}]
             }]
           })]
       [$equal? (lambda [$val $tgt]
                  (or ((type-ref (List a) equal?) val tgt)
                      ((type-ref (List a) equal?) val (reverse tgt))))]
       })))

(test (match-all {1 2 3} (Stick Number) [<cons $x $xs> [x xs]]))
(test (match-all {1 2 3} (Stick Number) [<join $xs $ys> [xs ys]]))
(test (match-all {1 2 3 4} (Stick Number) [<join $xs <cons $w $ys>> [xs w ys]]))
(test (match-all {1 2 3} (Stick Number) [,{3 2 1} <ok>]))