(chapter-start 'list-manipulation)

;; alias for 'detect
;; true if thing is in things, nil otherwise
(def include? (thing things)
  (detect thing things))

;; sort 'things according to the value
;; returned by 'f for each thing in 'things
(def sort-by (f things)
  (let tmp (hash)
    (each thing things
          (hash-cons tmp
                    (f thing)
                    thing))
    (apply joinlists
           (map λx(hash-get tmp x)
                (sort:hash-keys tmp)))))

;; like 'sort-by, except when 'f returns nil, use 'instead as the sort key instead
(def safe-sort-by (f instead things)
  (sort-by λi(or (f i) instead) things))

;; takes a function f, returns a new function that takes a list and sorts the list by 'f
(def sort-by-f (f) (curry1 sort-by f))

;; takes a function f, returns a new function that takes a list and sorts the list by 'f
(def safe-sort-by-f (f instead) (curry1 safe-sort-by f instead))

;; basically (reduce freduce (map fmap things))
(def mapreduce (fmap freduce things)
  (reduce freduce (map fmap things)))

;; map 'f over 'things and sum the resulting list, excluding nils
(def mapsum (f things)
  (apply + 0 (compact:map f things)))

;; returns a new function f which takes a parameter x
;; for each call to f with any value Z for x
;; f returns true if this f has previously seen Z
;; f returns nil otherwise.
;; Note that each call to 'seen? returns a new function with
;; its own history independent of previous calls to 'seen?
(def seen? ()
  (let seen (hash)
    λx(returning seen.,x (= seen.,x t))))

; return a list containing all the elements of 'things, but with no duplicates
(def uniqify (things) (reject (seen?) things))

;; like 'group-by, but uses and returns the supplied 'h parameter which should be a hash instance
(def group-by-h (f h things)
  (returning h
    (each thing things
          (hash-cons h (f thing) thing))))

;; return a hash of 'things keyed by (f thing) for
;; each thing in 'things
(def group-by (f things)
  (group-by-h f {} things))

(with (m2i λd(+ (* 12 d.year) (- d.month 1))
       i2m λi(date (/ i 12) (+ 1 (mod i 12)) 1))
      (def relative-months (anchor . mm)
        ; 'anchor is a date
        ; 'mm is a list of integers
        ; for each m in 'mm, return the date at the beginning of
        ; the month given by adding m months to 'anchor
        (let mi (m2i anchor)
          (map λm(i2m (+ mi m)) mm))))

;; like 'accum, except 'accfn-name expects 2 args, a key and a value
;; value is hash-consed onto key in an internally-maintained hash
;; the form returns the resulting hash
;; values are in reverse order
(mac accum-hash (accfn-name . body)
  (w/uniq (hsh)
    `(with (,hsh (hash))
           (let ,accfn-name (fn (k a) (hash-cons ,hsh k a))
             ,@body
             ,hsh))))

; return a list containing the range of elements starting with 'start,
; up to but not including 'stop
(def range (start stop)
  (accum acc
         (rfnwith r (n start)
           (if (< n stop)
               (r (+ (acc n) 1))))))

;; return a function that returns 'start on first invocation,
;; and 'start + n * 'incr for each nth invocation
;;
;; see also 'counter which does almost exactly the same thing
(def seqf (start incr)
  (let i (or incr 1)
    (fn () (returning start (++ start i)))))

; like 'map, but assumes each item in 'args is a list
; of parameters for 'f. Effectively, calls (apply f item)
; for each item in 'args
(def mapply (f args) (map λa(apply f a) args))

;; create a function called 'name ; each invocation of the function will
;; return the next value in 'things, cycling around to the start if no things are left
(mac def/cycler (name things)
  `(with (i -1 xs ',things list-len ,(len things))
         (def ,name (j)
           (comment ,(just "each call to ~name returns the next value from ~(inspect things)"))
           (nth (= i (mod (+ 1 (or j i)) list-len))
                xs))))

;; returns a list (list a b c) where
;; 'a is a subset of 'items
;; 'b is the sum of sizes of items in 'a : (apply + (map size-f a))
;; 'c is the subset of 'items not in 'a
;; invariants:
;; b < maximum-size
;; 'a + 'c is equal to 'items
;; arguments:
;; 'items is the list of things of which you have too many
;; 'bucket is either nil, or a list if you have an existing partially-filled bucket
;; 'size-f is a function that can tell the size of each item in 'items
;; 'bucket-size is the size of the existing bucket, or 0 if empty
;; 'maximum-size is the maximum allowed size for the bucket
;; implementation note: this function exploits the behaviour of '> returning its last argument when true
(def bucket/fill (items bucket size-f bucket-size maximum-size)
  (aif (and items
            (> maximum-size (+ (size-f (car items)) bucket-size)))
       (bucket/fill (cdr items)
                    (cons (car items) bucket)
                    size-f
                    it
                    maximum-size)
       (and items (eq? bucket-size 0))
       (bucket/fill (cdr items)
                    (cons (car items) bucket)
                    size-f
                    (size-f (car items))
                    maximum-size)
       (list (rev bucket) bucket-size items)))

;; used by 'fill-buckets
(def bucket/new (buckets)
  (cons { bucket-size 0 } buckets))

;; useful for pagination where each item may have a different size
;; returns a list of hash with keys 'bucket-size and key
;; if buckets is non-nil, assumes it is a list of previously-established buckets
;; will add new items to first bucket if its 'bucket-size permits
(def fill-buckets (items max buckets size-f key)
  (if items
      (if buckets
          (let initial (car buckets)
            (let (these size others)
                 (bucket/fill items nil size-f initial.bucket-size max)
              (hash-set initial key these)
              (= initial.bucket-size size)
              (if others
                  (fill-buckets others max (bucket/new buckets) size-f key)
                  (fill-buckets others max buckets size-f key))))
          (fill-buckets items max (bucket/new buckets) size-f key))
      buckets))

;; return the list except for the last element
(def all-but-last (things)
  (accum acc
         ((afn (xs)
            (when (cdr xs)
              (acc (car xs))
              (self (cdr xs))))
          things)))

;; returns a list containing 'existing items, that has at least 'minimum items, building new items if necessary
;;
;; useful if you want to show, for example, two parent fields, but you don't know in advance whether there
;; are zero, one, two, or more parents already present
;;
;; existing: the existing list
;; buildf: a zero-argument function to build a new item
;; minimum: the minimum number of items in the returned list.
;;
(def list/fill (existing buildf minimum)
  (let missing (- minimum (len existing))
    (if (> missing 0)
        (+ existing (map buildf (range 0 missing)))
        existing)))

;; recursively search the given form for forms matching 'matcher
;; matcher is a function which returns nil for non-match, anything else for match
;; returns the list of non-nil objects returned by 'matcher
;; 'matcher will be called with the entire form, and if the form is a list, with each element of the form, recursively
(def list/grep (matcher form)
  (accum matches
    (let maybe λi(if (matcher i) (matches i))
      (list/traverse maybe maybe form))))

;; recursively seeks forms in 'form whose car is 'symbol
(def list/seek-cars (symbol form)
  (list/grep λf(caris symbol f) form))

;; helper function for 'case macro
(def case/make-conds (test varname conds acc)
  (if conds
      (let (cnd expr) (car conds)
        (if (eq? cnd 'else)
            (acc expr)
            (do (acc `(,test ,varname ,cnd))
                (acc expr)
                (case/make-conds test
                                 varname
                                 (cdr conds)
                                 acc))))))

;; usage: (case eq? person.name
;;              "conan" (greet person)
;;              "egg"   (delete person)
;;              "bach"  (play person)
;;              else    (interrogate person))
(mac case (test what . conditions)
  (w/uniq caseval
    `(let ,caseval ,what
       (if ,@(accum a
                    (case/make-conds test
                                     caseval
                                     (pairs conditions)
                                     a))))))