collection.egi

;;
;; Collection.egi
;;

(define $list
  (lambda [$a]
    (matcher
      {[,$val []
        {[$tgt (match [val tgt] [(list a) (list a)]
                 {[[<nil> <nil>] {[]}]
                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]
                  [[_ _] {}]})]}]
       [<nil> []
        {[{} {[]}]
         [_ {}]}]
       [<cons $ $> [a (list a)]
        {[{$x @$xs} {[x xs]}]
         [_ {}]}]
       [<snoc $ $> [a (list a)]
        {[{@$xs $x} {[x xs]}]
         [_ {}]}]
       [<join ,$pxs $> [(list a)]
        {[$tgt (match-all [pxs tgt] [(list a) (list a)]
                 [[(loop $i [1 $n] <cons $xa_i ...> <nil>)
                   (loop $i [1 ,n] <cons ,xa_i ...> $rs)]
                  rs])]}]
       [<join $ $> [(list a) (list a)]
        {[$tgt (match-all tgt (list a)
                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}]
       [<nioj ,$pxs $> [(list a)]
        {[$tgt (match-all [pxs tgt] [(list a) (list a)]
                 [[(loop $i [1 $n] <snoc $xa_i ...> <nil>)
                   (loop $i [1 ,n] <snoc ,xa_i ...> $rs)]
                  rs])]}]
       [<nioj $ $> [(list a) (list a)]
        {[$tgt (match-all tgt (list a)
                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}]
       [$ [something]
        {[$tgt {tgt}]}]
       })))

(define $string (list char))

(define $between
  (lambda [$s $e]
    (if (gt-i? s e)
        {}
        {s @(between (+ s 1) e)})))

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

(define $map-and-concat
  (lambda [$fn $ls]
    (match ls (list something)
      {[<nil> {}]
       [<cons $x $xs> {@(fn x) @(map-and-concat 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 $split
  (lambda [$pred $ls]
    (letrec {[$helper (lambda [$ls $xs $ys]
                        (match ls (list something)
                          {[<nil> [xs ys]]
                           [<cons (& ?pred $l) $rs> (helper rs {l @xs} ys)]
                           [<cons $l $rs> (helper rs xs {l @ys})]}))]}
      (helper ls {} {}))))

(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? a) x xs)
          xs
          {@xs x}))))

(define $union
  (lambda [$a]
    (lambda [$xs $ys]
      (match ys (list something)
        {[<nil> xs]
         [<cons $y $rs> ((union a) ((add a) xs y) rs)]}))))

(define $occurrence
  (lambda [$a]
    (lambda [$xs]
      (letrec {[$remove-and-count
                (lambda [$x $xs]
                  (match xs (list a)
                    {[<nil> [{} 1]]
                     [<cons ,x $ys> (let {[[$r $i] (remove-and-count x ys)]}
                                      [r (+ i 1)])]
                     [<cons $y $ys> (let {[[$r $i] (remove-and-count x ys)]}
                                      [{y @r} i])]}))]}
        (match xs (list something)
          {[<nil> {}]
           [<cons $x $ys> (let {[[$rs $i] (remove-and-count x ys)]}
                            {[x i] @((occurrence a) rs)})]})))))

(define $one-of
  (lambda [$pred $xs]
    (match xs (list something)
      {[<nil> #f]
       [<cons $x $rs>
        (if (pred x)
            #t
            (one-of pred rs))]})))

(define $length
  (lambda [$xs]
    (match xs (list something)
      {[<nil> 0]
       [<cons _ $rs> (+ 1 (length 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 $nth
  (lambda [$i $l]
    (match l (list something)
      {[<cons $x $xs> (if (eq? i 0) x (nth (- i 1) xs))]})))

(define $take
  (lambda [$n $xs]
    (if (eq? n 0)
        {}
        (match xs (list something)
          {[<cons $x $xs> {x @(take (- n 1) xs)}]
           [<nil> {}]}))))

(define $while
  (lambda [$pred $xs]
    (match xs (list something)
      {[<nil> {}]
       [<cons $x $rs>
        (if (pred x)
            {x @(while pred rs)}
            {})]})))

(define $drop
  (lambda [$n $xs]
    (if (eq? n 0)
        xs
        (match xs (list something)
          {[<cons _ $xs> (drop (- n 1) xs)]
           [<nil> {}]}))))

(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 something)
                    {[<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 something)
        {[<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 $empty?
  (match-lambda (list something)
   {[<nil> #t]
    [<cons _ _> #f]}))

(define $multiset
  (lambda [$a]
    (matcher
      {[,$val []
        {[$tgt (match [val tgt] [(list a) (multiset a)]
                 {[[<nil> <nil>] {[]}]
                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]
                  [[_ _] {}]})]}]
       [<nil> []
        {[{} {[]}]
         [_ {}]}]
       [<cons ,$px $> [(multiset a)]
        {[$tgt (match tgt (list a)
                 {[<join $hs <cons ,px $ts>> {{@hs @ts}}]
                  [_ {}]})]}]
       [<cons $ $> [a (multiset a)]
        {[$tgt (match-all tgt (list a)
                 [<join $hs <cons $x $ts>> [x {@hs @ts}]])]}]
       [<join ,$pxs $> [(multiset a)]
        {[$tgt {((remove-collection a) tgt pxs)}]}]
       [$ [something]
        {[$tgt {tgt}]}]
       })))

(define $set
  (lambda [$a]
    (matcher
      {[<nil> []
        {[{} {[]}]
         [_ {}]}]
       [<cons ,$px $> [(set a)]
        {[$tgt (match tgt (list a)
                 {[<join _ <cons ,px _>> {tgt}]
                  [_ {}]})]}]
       [<cons $ $> [a (set a)]
        {[$tgt (match-all tgt (list a)
                 [<join _ <cons $x _>> [x tgt]])]}]
       [$ [something]
        {[$tgt {tgt}]}]
       })))