collection.egi

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

;;;
;;; List
;;;
(define $list
  (lambda [$a]
    (matcher
      {[<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]])]}]
       [,$val []
        {[$tgt (if (eq? val tgt) {[]} {})]}]
       [$ [something]
        {[$tgt {tgt}]}]
       })))

(define $sorted-list
  (lambda [$a]
    (matcher
      {[<nil> []
        {[{} {[]}]
         [_ {}]}]
       [<join $ <cons ,$px $>> [(sorted-list a) (sorted-list a)]
        {[$tgt (match-all tgt (list a)
                 [(loop $i [1 $n] <cons (& ?(lt? $ px) $xa_i) ...> <cons ,px $rs>)
                  [(map (lambda [$i] (ref xa i)) (between 1 n))
                   rs]])]}]
       [<join $ $> [(sorted-list a) (sorted-list a)]
        {[$tgt (match-all tgt (list a)
                 [(loop $i [1 $n] <cons $xa_i ...> $rs)
                  [(map (lambda [$i] (ref xa i)) (between 1 n))
                   rs]])]}]
       [<cons $ $> [a (sorted-list a)]
        {[{$x @$xs} {[x xs]}]
         [_ {}]}]
       [,$val []
        {[$tgt (if (eq? val tgt) {[]} {})]}]
       [$ [something]
        {[$tgt {tgt}]}]
       })))

;;
;; Accessors
;;
(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 $take-while
  (lambda [$pred $xs]
    (match xs (list something)
      {[<nil> {}]
       [<cons $x $rs>
        (if (pred x)
            {x @(take-while pred rs)}
            {})]})))

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

(define $taile-until
  (lambda [$pred $xs]
    (match xs (list something)
      {[<nil> {}]
       [<cons $x $rs>
        (if (not (pred x))
            {x @(take-until pred rs)}
            {})]})))

(define $take-until-by
  (lambda [$pred $xs]
    (match xs (list something)
      {[<nil> {}]
       [<cons $x $rs>
        (if (not (pred x))
            {x @(take-until-by pred rs)}
            {x})]})))

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

;;
;; cons, car, cdr
;;
(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]})))

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

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

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

(define $map4
  (lambda [$fn $xs $ys $zs $ws]
    (match [xs ys zs ws] [(list something) (list something) (list something) (list something)]
      {[[<nil> _ _ _] {}]
       [[_ <nil> _ _] {}]
       [[_ _ <nil> _] {}]
       [[_ _ _ <nil>] {}]
       [[<cons $x $xs2> <cons $y $ys2> <cons $z $zs2> <cons $w $ws2>]
        {(fn x y z w) @(map4 fn xs2 ys2 zs2 ws2)}]})))

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

(define $partition
  (lambda [$pred $xs]
    [(filter pred xs) (filter 1#(not (pred %1)) xs)]))

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

(define $zip3
  (lambda [$xs $ys $zs]
    (map3 (lambda [$x $y $z] [x y z]) xs ys zs)))

(define $zip4
  (lambda [$xs $ys $zs $ws]
    (map4 (lambda [$x $y $z $w] [x y z w]) xs ys zs ws)))

(define $lookup
  (lambda [$k $ls]
    (match ls (list [something something])
      {[<join _ <cons [,k $x] _>> x]})))

; Note. `foldr` is used in the definition of the list matcher.
(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 {[$z (fn init x)]}
          (seq z (foldl fn z xs)))]})))

(define $reduce
  (lambda [$fn %ls]
    (foldl fn (car ls) (cdr ls))))

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

(define $iterate
  (lambda [$fn %x]
    (let* {[$nx1 (fn x)]
           [$nx2 (fn nx1)]
           [$nx3 (fn nx2)]
           [$nx4 (fn nx3)]
           [$nx5 (fn nx4)]}
      {x nx1 nx2 nx3 nx4 @(iterate fn nx5)})))

(define $repeated-squaring
  (lambda [$fn %x $n]
    (match n integer
      {[,1 x]
       [?even? (let {[$y (repeated-squaring fn x (quotient n 2))]}
                 (fn y y))]
       [?odd? (let {[$y (repeated-squaring fn x (quotient n 2))]}
                (fn (fn y y) x))]})))

(define $append
  (lambda [$xs $ys]
    {@xs @ys}))

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

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

(define $find-cycle
  (lambda [$xs]
    (car (concat (match-all xs (list something)
                   [<join $ys <cons $x _>>
                    (match-all ys (list something)
                      [<join $hs <cons ,x $ms>>
                       [hs {x @ms}]])])))))

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

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

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

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

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

; Note. `between` is used in the definition of the list matcher.
(define $between
  (lambda [$s $e]
    (if (eq? s e)
      {s}
      (if (lt? s e)
        {s @(between (+ s 1) e)}
        {}))))

(define $L./
  (lambda [$xs $ys]
    (if (lt? (length xs) (length ys))
      [{} xs]
      (match [ys xs] [(list math-expr) (list math-expr)]
        {
         [[<cons $y $yrs> <cons $x $xrs>]
          (let {[[$zs $rs] (L./ {@(map2 - (take (length yrs) xrs) (map (* $ (/ x y)) yrs))
                                 @(drop (length yrs) xrs)} ys)]}
            [{(/ x y) @zs} rs])]
         }))))

;;;
;;; Multiset
;;;
(define $multiset
  (lambda [$a]
    (matcher
      {[<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})]])]}]
       [,$val []
        {[$tgt (match [val tgt] [(list a) (multiset a)]
                 {[[<nil> <nil>] {[]}]
                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]
                  [[_ _] {}]})]}]
       [$ [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> {}]
       [<join $hs <cons ,x $ts>> {@hs @(delete x ts)}]
       [_ xs]})))

(define $delete/m
  (lambda [$a $x $xs]
    (match xs (list a)
      {[<nil> {}]
       [<join $hs <cons ,x $ts>> {@hs @(delete/m a x ts)}]
       [_ xs]})))

(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 $include?
  (lambda [$xs $ys]
    (match ys (list something)
      {[<nil> #t]
       [<cons $y $rs>
        (if (member? y xs)
          (include? (delete-first y xs) rs)
          #f)]})))

(define $include?/m
  (lambda [$a $xs $ys]
    (match ys (list a)
      {[<nil> #t]
       [<cons $y $rs>
        (if (member?/m a y xs)
          (include?/m a (delete-first y xs) rs)
          #f)]})))

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

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

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

;;
;; Index
;;
(define $elemIndices
  (lambda [$x $xs]
    (match-all xs (list something)
      [<join $hs <cons ,x _>> (+ 1 (length hs))])))

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

;;
;; set operation
;;
(define $unique
  (lambda [$xs]
    (match-all (sort xs) (list something)
      [<join _ <cons $x !<cons ,x _>>> x])))

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