collection.egi

;;;;;
;;;;; Collection.egi
;;;;;

;;;
;;; List
;;;
(define $list
  (lambda [$a]
    (matcher-bfs
      {[,$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 $flist
  (lambda [$a]
    (matcher-dfs
      {[,$val []
        {[$tgt (match [val tgt] [(flist a) (flist a)]
                 {[[<nil> <nil>] {[]}]
                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]
                  [[_ _] {}]})]}]
       [<nil> []
        {[{} {[]}]
         [_ {}]}]
       [<cons $ $> [a (flist a)]
        {[{$x @$xs} {[x xs]}]
         [_ {}]}]
       [<snoc $ $> [a (flist a)]
        {[{@$xs $x} {[x xs]}]
         [_ {}]}]
       [<join ,$pxs $> [(flist a)]
        {[$tgt (match-all [pxs tgt] [(flist a) (flist a)]
                 [[(loop $i [1 $n] <cons $xa_i ...> <nil>)
                   (loop $i [1 ,n] <cons ,xa_i ...> $rs)]
                  rs])]}]
       [<join $ $> [(flist a) (flist a)]
        {[$tgt (match-all tgt (flist a)
                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}]
       [<nioj ,$pxs $> [(flist a)]
        {[$tgt (match-all [pxs tgt] [(flist a) (flist a)]
                 [[(loop $i [1 $n] <snoc $xa_i ...> <nil>)
                   (loop $i [1 ,n] <snoc ,xa_i ...> $rs)]
                  rs])]}]
       [<nioj $ $> [(flist a) (flist a)]
        {[$tgt (match-all tgt (flist 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))

;;
;; Helper function for List matcher, be careful for recursive calls
;;
(define $map
  (lambda [$fn $xs]
    (match xs (list something)
      {[<nil> {}]
       [<cons $x $rs> {(fn x) @(map fn rs)}]})))

(define $between
  (lambda [$s $e]
    (if (gt? (+ s 10) e)
      (if (gt? s e)
        {}
        {s @(between (+ s 1) e)})
      {s (+ s 1) (+ s 2) (+ s 3) (+ s 4) (+ s 5) (+ s 6) (+ s 7) (+ s 8) (+ s 9) (+ s 10) @(between (+ s 11) e)})
    ))

;;
;; list functions
;;
(define $repeat1
  (lambda [$x]
    {x @(repeat1 x)}))

(define $repeat
  (lambda [$xs]
    {@xs @(repeat xs)}))

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

(define $separate
  (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 $concat
  (lambda [$xss]
    (match xss (list something)
      {[<nil> {}]
       [<cons $xs $rss> {@xs @(concat rss)}]})))

(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 $map2
  (lambda [$fn $xs $ys]
    (match [xs ys] [(list something) (list something)]
      {[[<nil> <nil>] {}]
       [[<cons $x $xs2> <cons $y $ys2>]
        {(fn x y) @(map2 fn xs2 ys2)}]})))

(define $zip
  (lambda [$xs $ys]
    (map2 (lambda [$x $y] [x y]) xs ys)))

;;
;; Simple predicate
;;
(define $member?
  (lambda [$x $ys]
    (match ys (list something)
      {[<join _ <cons ,x _>> #t]
       [_ #f]})))

(define $member?/m
  (lambda [$a $x $ys]
    (match ys (list a)
      {[<join _ <cons ,x _>> #t]
       [_ #f]})))

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

(define $include?/m
  (lambda [$a $xs $ys]
    (match xs (list something)
      {[<nil> #t]
       [<cons $x $rest>
        (if (member?/m a x ys)
          (include?/m a rest ys)
          #f)]})))

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

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

;;
;; Counting
;;
(define $length
  (lambda [$xs]
    (match xs (list something)
      {[<nil> 0]
       [<cons _ $rs> (+ 1 (length rs))]})))

(define $count
  (lambda [$x $xs]
    (length (match-all xs (list something)
              [<join _ <cons ,x _>> x]))))

(define $count/m
  (lambda [$a $x $xs]
    (length (match-all xs (list a)
              [<join _ <cons ,x _>> x]))))

;;
;; Simple accessors
;;
(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 [$n $xs]
    (match xs (list something)
      {[(loop $i [1 ,(- n 1)]
          <cons _ ...>
          <cons $x _>)
        x]})))

(define $take-and-drop
  (lambda [$n $xs]
    (match xs (list something)
      {[(loop $i [1 ,n] <cons $a_i ...> $rs)
        [(map (lambda [$i] a_i) (between 1 n)) rs]]})))

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

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

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

;;
;; Others
;;
(define $reverse
  (lambda [$xs]
    (match xs (list something)
      {[<nil> {}]
       [<cons $x $rs>
        {@(reverse rs) x}]})))

;;;
;;; Multiset
;;;
(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 {(difference/m a tgt pxs)}]}]
       [$ [something]
        {[$tgt {tgt}]}]
       })))

;;
;; multiset operation (Don't use multiset matcher)
;;
(define $add
  (lambda [$x $xs]
    (if (member? x xs)
      xs
      {@xs x})))

(define $add/m
  (lambda [$a $x $xs]
    (if (member?/m a x xs)
      xs
      {@xs x})))

(define $delete-first
  (lambda [$x $xs]
    (match xs (list something)
      {[<nil> {}]
       [<cons ,x $rs> rs]
       [<cons $y $rs> {y @(delete-first x rs)}]})))

(define $delete-first/m
  (lambda [$a $x $xs]
    (match xs (list a)
      {[<nil> {}]
       [<cons ,x $rs> rs]
       [<cons $y $rs> {y @(delete-first/m a x rs)}]})))

(define $delete
  (lambda [$x $xs]
    (match xs (list something)
      {[<nil> {}]
       [<cons ,x $rs> (delete x rs)]
       [<cons $y $rs> {y @(delete x rs)}]})))

(define $delete/m
  (lambda [$a $x $xs]
    (match xs (list a)
      {[<nil> {}]
       [<cons ,x $rs> (delete/m a x rs)]
       [<cons $y $rs> {y @(delete/m a x rs)}]})))

(define $difference
  (lambda [$xs $ys]
    (match ys (list something)
      {[<nil> xs]
       [<cons $y $rs> (difference (delete-first y xs) rs)]})))

(define $difference/m
  (lambda [$a $xs $ys]
    (match ys (list a)
      {[<nil> xs]
       [<cons $y $rs> (difference/m a (delete-first/m a y xs) rs)]})))

(define $union
  (lambda [$xs $ys]
    {xs
     @(match-all [ys xs] [(multiset something) (multiset something)]
        [[<cons $y _> ^<cons ,y _>] y])
     }))

(define $union/m
  (lambda [$a $xs $ys]
    {xs
     @(match-all [ys xs] [(multiset a) (multiset a)]
        [[<cons $y _> ^<cons ,y _>] y])
     }))

(define $intersect
  (lambda [$xs $ys]
    (match-all [xs ys] [(multiset something) (multiset something)]
      [[<cons $x _> <cons ,x _>] x])))

(define $intersect/m
  (lambda [$a $xs $ys]
    (match-all [xs ys] [(multiset a) (multiset a)]
      [[<cons $x _> <cons ,x _>] x])))

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

;;
;; set operation
;;
(define $unique
  (lambda [$xs]
    (letrec {[$loop-fn
              (lambda [$xs $ys]
                (match xs (list something)
                  {[<nil> ys]
                   [<cons $x $rs>
                    (if (member? x ys)
                      (loop-fn rs ys)
                      (loop-fn rs {@ys x}))]}))]}
      (loop-fn xs {}))))

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