collection.egi

;;
;; Collection.egi
;;

(define $List
  (lambda [$a]
    (type
      {[$var-match (lambda [$tgt] {tgt})]
       [$inductive-match
        (destructor
          {[,$val []
            {[$tgt (if (= tgt val)
                       {[]}
                       {})]}]
           [<nil> []
            {[{} {[]}]
             [_ {}]}]
           [<cons _ _> [a (List a)]
            {[{$x .$xs} {[x xs]}]
             [_ {}]}]
           [<snoc _ _> [a (List a)]
            {[{.$xs $x} {[x xs]}]
             [_ {}]}]
           [<join ,$pxs _> [(List a)]
            {[$tgt (letrec {[$helper (lambda [$pxs $tgt]
                                       (match [pxs tgt] [(List a) (List a)]
                                         {[[<nil> _] {tgt}]
                                          [[<cons $x $xs> <cons ,x $ys>] (helper xs ys)]
                                          [[_ _] {}]}))]}
                     (helper pxs tgt))]}]
           [<join _ _> [(List a) (List a)]
            {[$tgt (letrec {[$loop-fn
                             (lambda [$ts]
                               (match ts (List a)
                                 {[<nil> {[{} {}]}]
                                  [<cons $x $xs>
                                   {[{} ts]
                                    @(map (lambda [$as $bs] [{x @as} bs])
                                          (loop-fn xs))}]}))]}
                     (loop-fn tgt))]}]
           [<nioj _ _> [(List a) (List a)]
            {[$tgt (letrec {[$loop-fn
                             (lambda [$ts]
                               (match ts (List a)
                                 {[<nil> {[{} {}]}]
                                  [<snoc $x $xs>
                                   {[{} ts]
                                    @(map (lambda [$as $bs] [{@as x} bs])
                                          (loop-fn xs))}]}))]}
                     (loop-fn tgt))]}]})]
       [$= (lambda [$val $tgt]
             (match [val tgt] [(List a) (List a)]
               {[[<nil> <nil>] #t]
                [[<cons $x $xs> <cons ,x ,xs>] #t]
                [[_ _] #f]}))]})))

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

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

(define $foldl
  (lambda [$fn $init $ls]
    (match ls (List Something)
      {[<nil> init]
       [<cons $x $xs> (let {[$y (fn init x)]}
                        (foldl fn y xs))]})))

(define $filter
  (lambda [$pred $ls]
    (match ls (List Something)
      {[<nil> {}]
       [<cons $x $xs>
        (if (pred x)
            {x @(filter pred xs)}
            (filter pred 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 $add
  (lambda [$a]
    (lambda [$xs $x]
      (if ((member? Integer) x xs)
          xs
          {@xs x}))))

(define $union
  (lambda [$a]
    (lambda [$xs $ys]
      (match ys (List a)
        {[<nil> xs]
         [<cons $y $rs> ((union a) ((add 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 $size
  (lambda [$xs]
    (match xs (List Something)
      {[<nil> 0]
       [<cons _ $rs> (+ 1 (size rs))]})))

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

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

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

(define $rdc
  (lambda [$xs]
    (match xs (List Something)
      {[<snoc _ $ys> ys]})))

(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> #f]
         [<cons ,x $ys> #t]
         [<cons $y $ys> ((member? a) x ys)]}))))

(define $unique
  (lambda [$a]
    (lambda [$xs]
      (letrec {[$loop-fn (lambda [$xs $ys]
                           (match xs (List a)
                             {[<nil> ys]
                              [<cons $x $rs>
                               (if ((member? a) x ys)
                                   (loop-fn rs ys)
                                   (loop-fn rs {@ys x}))]}))]}
        (loop-fn xs {})))))

(define $subcollection?
  (lambda [$a]
    (lambda [$xs $ys]
      (match xs (List a)
        {[<nil> #t]
         [<cons $x $rest>
          (if ((member? a) x ys)
              ((subcollection? a) rest ys)
              #f)]}))))
             

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

(define $Multiset
  (lambda [$a]
    (type
      {[$var-match (lambda [$tgt] {tgt})]
       [$inductive-match
        (destructor
          {[,$val []
            {[$tgt (if (= tgt val)
                       {[]}
                       {})]}]
           [<nil> []
            {[{} {[]}]
             [_ {}]}]
           [<cons ,$px _> [(Multiset a)]
            {[$tgt {((remove a) tgt px)}]}]
           [<cons _ _> [a (Multiset a)]
            {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])
                        ((unique a) tgt))]}]
           [<join ,$pxs _> [(Multiset a)]
            {[$tgt {((remove-collection a) tgt pxs)}]}]
           [<join _ _> [(Multiset a) (Multiset a)]
            {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])
                        (subcollections tgt))]}]})]
       [$= (lambda [$val $tgt]
             (match [val tgt] [(Multiset a) (Multiset a)]
               {[[<nil> <nil>] #t]
                [[<cons $x $xs> <cons ,x ,xs>] #t]
                [[_ _] #f]}))]})))

(define $Set
  (lambda [$a]
    (type
      {[$var-match (lambda [$tgt] {tgt})]
       [$inductive-match
        (destructor
          {[,$val []
            {[$tgt (if (= tgt val)
                       {[]}
                       {})]}]
           [<nil> []
            {[{} {[]}]
             [_ {}]}]
           [<cons _ _> [a (Set a)]
            {[$tgt (let {[$tgt2 ((unique a) tgt)]}
                     {@(match-all tgt2 (Multiset a) [<cons $x $xs> [x xs]])
                      @(match-all tgt2 (Multiset a) [<cons $x $xs> [x {@xs x}]])})]}]
           [<join _ _> [(Set a) (Set a)]
            {[$tgt (let {[$tgt2 ((unique a) tgt)]}
                     (concat (map (lambda [$xs $ys] (map (lambda [$sxs] [xs {@ys @sxs}])
                                                         (subcollections xs)))
                                  (match-all tgt2 (Multiset a) [<join $xs $ys> [xs ys]]))))]}]})]
       [$= (lambda [$val $tgt]
             (and ((subcollection? a) val tgt) ((subcollection? a) tgt val)))]})))