(chapter-start 'list-manipulation)

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

(def sort-by (f things)
  ; sort 'things according to the value
  ; returned by 'f for each thing in '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))

(def mapreduce (fmap freduce things)
  ; same as (reduce freduce (map fmap things))
  ; returns the resulting list
  (if (pair? things)
      (freduce (fmap (car things))
               (mapreduce fmap freduce (cdr things)))
      things
      (freduce (map fmap things))
      (freduce)))

; map 'f over 'things and sum the resulting list
(def mapsum (f things) (mapreduce f + things))

(def seen? ()
  ; 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?
  (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))

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

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

;; each call to the name 'accfn-name with an arg will append the arg to the end of a list.
;; This form returns the resulting list.
;; Example (collect first names from a list of people)
;;
;;   (accum a (each person people (a person.firstname)))
;;
;; will return (Alice Bob Carol Declan Eliza Fionn)
;;
(mac accum (accfn-name . body)
  (w/uniq (things last-cons)
    `(with (,last-cons (cons) ,things nil)
       (= ,things ,last-cons)
       (let ,accfn-name (fn (a) (= ,last-cons (cdr-set ,last-cons (cons a))) a)
         ,@body
         (cdr ,things)))))

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

(mac def/cycler (name things)
  ; 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
  `(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))))

(def bucket/fill (items bucket size-f bucket-size maximum-size)
  ; 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
  (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)))

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

(def fill-buckets (items max buckets size-f key)
  ; 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
  (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))))))