collection.egi

;;;;;
;;;;;
;;;;; Collection
;;;;;
;;;;;

;;;
;;; List
;;;
(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 $ $> [(list a) (list a)]
        {[$tgt (match-all tgt (list a)
                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n))
                                                         rs]])]}]
       [<nioj $ $> [(list a) (list a)]
        {[$tgt (match-all tgt (list a)
                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(foldr (lambda [$i $r] {@r xa_i}) {} (between 1 n))
                                                         rs]])]}]
       [$ [something]
        {[$tgt {tgt}]}]
       })))

(define $ordered-list
  (lambda [$a]
    (matcher
      {[,$val []
        {[$tgt (match [val tgt] [(ordered-list a) (ordered-list a)]
                 {[[<nil> <nil>] {[]}]
                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]
                  [[_ _] {}]})]}]
       [<nil> []
        {[{} {[]}]
         [_ {}]}]
       [<join $ <cons ,$px $>> [(ordered-list a) (ordered-list a)]
        {[{} {}]
         [$tgt (match-all tgt (list a)
                 [(loop $i [1 $n] <cons (& ?(lt? $ px) $xa_i) ...> <cons ,px $rs>) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n))
                                                                                    rs]])]}]
       [<join $ $> [(ordered-list a) (ordered-list a)]
        {[$tgt (match-all tgt (list a)
                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n))
                                                         rs]])]}]
       [<cons ,$px $> [(ordered-list a)]
        {[{$x @$xs} (if (gt? x px)
                      {}
                      {[xs]})]
         [_ {}]}]
       [<cons $ $> [a (ordered-list a)]
        {[{$x @$xs} {[x xs]}]
         [_ {}]}]
       [<nioj $ $> [(ordered-list a) (ordered-list a)]
        {[$tgt (match-all tgt (list a)
                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n))
                                                         rs]])]}]
       [<snoc ,$px $> [a (ordered-list a)]
        {[{@$xs $x} (if (lt? x px)
                      {}
                      {[xs]})]
         [_ {}]}]
       [<snoc $ $> [a (ordered-list a)]
        {[{@$xs $x} {[x xs]}]
         [_ {}]}]
       [$ [something]
        {[$tgt {tgt}]}]
       })))

;;
;; Helper function for List matcher, be careful for recursive calls
;;
(define $between
  (lambda [$s $e]
    (if (eq? s e)
      {s}
      (if (lt? s e)
        {s @(between (+ s 1) e)}
        {}))))

(define $from
  (lambda [$s]
    {s (+ s 1) (+ s 2) (+ s 3) (+ s 4) (+ s 5) (+ s 6) (+ s 7) (+ s 8) (+ s 9) (+ s 10) @(from (+ s 11))}))

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

;;
;; list functions
;;
(define $foldl foldl')

(define $foldl'
  (lambda [$fn $init $ls]
    (match ls (list something)
      {[<nil> init]
       [<cons $x $xs>
        (let {[$z (fn init x)]}
          (seq z (foldl' fn z xs)))]})))

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

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

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

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

(define $filter
  (lambda [$pred $xs]
    (foldr (lambda [$y $ys] (if (pred y) {y @ys} ys))
           {}
           xs)))

(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 $append
  (lambda [$xs $ys]
    {@xs @ys}))

(define $concat
  (lambda [$xss]
    (foldr (lambda [$xs $rs] {@xs @rs})
           {}
           xss)))

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

(define $find-cycle
  (lambda [$fn $init]
    (letrec {[$looper (lambda [$xs $x]
                        (let {[$y (fn x)]}
                          (if (eq? y init)
                            xs
                            (looper {@xs y} y))))]}
      (looper {init} init))))

;;
;; 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)
            (all pred rs)
            #f)]})))

;;
;; Counting
;;
(define $length
  (lambda [$xs]
    (foldl (lambda [$r $x] (+ r 1)) 0 xs)))

(define $count
  (lambda [$x $xs]
    (foldl (match-lambda [something something]
             {[[$r ,x] (+ r 1)]
              [[$r $y] r]})
           0
           xs)))

(define $count/m
  (lambda [$a $x $xs]
    (foldl (match-lambda [a a]
             {[[$r ,x] (+ r 1)]
              [[$r $y] r]})
           0
           xs)))

(define $frequency
  (lambda [$xs]
    (let {[$us (unique xs)]}
      (map (lambda [$u] [u (count u xs)]) us))))

(define $frequency/m
  (lambda [$a $xs]
    (let {[$us (unique/m a xs)]}
      (map (lambda [$u] [u (count/m a u xs)]) us))))

;;
;; Simple accessors
;;
(define $cons
  (lambda [$x $xs] {x @xs}))

(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> {}]
       [<snoc $x $rs>
        {x @(reverse rs)}]})))

(define $intersperse
  (lambda [$in $ws]
    (match ws (list something)
      {[<nil> {}]
       [<cons $w $rs> (foldl (lambda [$s1 $s2] {@s1 in s2}) {w} rs)]})))

(define $intercalate (compose intersperse concat))

(define $split
  (lambda [$in $ls]
    (match ls (list something)
      {[<join $xs <join ,in $rs>> {xs @(split in rs)}]
       [_ {ls}]})))

(define $split/m
  (lambda [$a $in $ls]
    (match ls (list a)
      {[<join $xs <join ,in $rs>> {xs @(split/m $a in rs)}]
       [_ {ls}]})))

;;;
;;; 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 $ $> [a (multiset a)]
        {[$tgt (match-all tgt (list a)
                 [<join $hs <cons $x $ts>> [x {@hs @ts}]])]}]
       [<join ,$pxs $> [(multiset a)]
        {[$tgt (match [pxs tgt] [(list a) (multiset a)]
                 {[[(loop $i [1 $n] <cons $x_i ...> <nil>)
                    (loop $i [1 n] <cons ,x_i ...> $rs)]
                   {rs}]
                  [_ {}]})]}]
       [<join $ $> [(multiset a) (multiset a)]
        {[$tgt (match-all tgt (list a)
                 [(loop $i [1 $n] <join $rs_i <cons $x_i ...>> $ts)
                  [(map (lambda [$i] x_i) (between 1 n))
                   (concat {@(map (lambda [$i] rs_i) (between 1 n)) ts})]])]}]
       [$ [something]
        {[$tgt {tgt}]}]
       })))

;;
;; multiset operation
;;
(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 $ $> [a (set a)]
        {[$tgt (match-all tgt (list a)
                 [<join _ <cons $x _>> [x tgt]])]}]
       [<join ,$pxs $> [(set a)]
        {[$tgt (match [pxs tgt] [(list a) (set a)]
                 {[[(loop $i [1 $n] <cons $x_i ...> <nil>)
                    (loop $i [1 n] <cons ,x_i ...> _)]
                   {tgt}]
                  [_ {}]})]}]
       [<join $ $> [(set a) (set a)]
        {[$tgt (match-all tgt (multiset a)
                 [(loop $i [1 $n] <cons $x_i ...> _)
                  [(map (lambda [$i] x_i) (between 1 n)) 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 {}))))