;; list processing module based on SRFI1

(module list-utils mzscheme

  ;; (require (lib "1.ss" "srfi")) there are some name clashes between
  ;; mzscheme and the SRFI1 lib. i got the line below from plt/collects/srfi/1.ss

  (require (lib "list.ss" "srfi" "1")
           (lib "match.ss"))

  (provide (all-defined)
           (all-from
            (lib "list.ss" "srfi" "1"))
           ) ;; FIXME: necessary?

  ;; not using 'member' but following the lset api with plugin comparison
  (define (contains same? el lst)
    (any (lambda (e) (same? el e)) lst))
  
  ;; (list->lset = '(3 1 1 2 2 2 3 3 2))
  (define (list->lset same? lst)
    (fold-right
     (lambda (head rest)
       (if (contains same? head rest)
           rest
           (cons head rest)))
     '() lst))

  ;; uses same argument order as assoc
  (define (assoc-ref lst symbol)
    (let ((ref (assoc lst symbol)))
      (and ref (cdr ref))))


  ;; accumulate generator results
  (define (for length gen . args)
    (unfold
     (lambda (n) (= length n))
     (lambda (n) (apply gen args))
     add1
     0))
  

  
  ;; Transform a list like
  ;; ((a . 1) (a . 2) (a . 3) (b . 4) (b . 5)) into
  ;; ((a . (1 2 3)) (b . (4 5)))

  ;; Order is preserved.
  
  ;; On streams, this is more of a 'dispatch' operation..
  
  (define (collect lst)
    (let ((tags (list->lset eq? (map car lst))))
      (map
       (lambda (current-tag)
         (cons current-tag
               (fold-right
                (match-lambda* (((tag . data) collection)
                                (if (eq? tag current-tag)
                                    (cons data collection)
                                    collection)))
                '() lst)))
       tags)))
                    

  ;; FIXME: what's the standard name for this? it's like fold combined
  ;; with unfold.

  

  ;; propagate output feedback function over list (IIR filter)
  ;; perform (x y ...) -> (x (fn z y) ...)
  ;; then do the same for the cdr.

  (define (propagate fn lst)
    (reverse! ;; linear
     (fold
      (lambda (in acc)
        (cons (fn (car acc) in) acc))
      (list (car lst))
      (cdr lst))))


  ;; like fold, but all functions take multiple arguments + tail is always nil..
  (define (list-unfold* terminate? output update . init-state)
    (let next ((l '())
               (s init-state))
      (if (apply terminate? s)
          (reverse! l)
          (next (cons (apply output s) l)
                (apply update s)))))
  

  (define (id x) x)
  (define (dip fn)
    (lambda (lst)
      (cons (car lst)
            (fn (cdr lst)))))
  (define (splash fn)
    (lambda (args)
      (apply fn args)))

  

  ;; MUTATION

  ;; stacks
  (define-syntax push!
  (syntax-rules ()
    ((_ stack value)
     (let ((rest stack))
       (set! stack (cons value rest))))))

  (define-syntax pop!
    (syntax-rules ()
      ((_ stack)
       (if (null? stack)
           (error 'stack-underflow
                  "pop!: no elements on: ~a" 'stack)
           (let ((top (car stack)))
             (set! stack (cdr stack))
             top)))))

  ;; like push!, but add to set
  (define-syntax lset-add!
    (syntax-rules ()
      ((_ same? stack val)
       (let ((v val)) ;; eval once
         (when (null?
                (lset-intersection same?
                                   stack
                                   (list v)))
           (push! stack v))))))

  ;; call a function 'producer' with one argument, which is a function
  ;; taking a single argument, bound to a collector function (add to set)

  ;; the 2nd procedure is called with the return value and collection
  
  (define (call-with-collector producer consumer)
    (call-with-values
        (lambda  ()
          (let* ((store '())
                 (collector
                  (lambda (thing)
                    (lset-add! equal? store thing)))
                 (retval (producer collector)))
      
            (values retval store)))
      consumer))

  
  
  (define-syntax pack
    (syntax-rules ()
      ((_ args ...)
       (apply list args ...))))

  ;; Split a list when predicate becomes true. Head contains atoms
  ;; that tested false.
  
  (define (split-collect lst pred?)
    (let next
        ((head '())
         (tail lst))
      (cond
       ((null? tail)
        (values lst '())) ;; didn't happen
       ((not (pred? (car tail)))
        (values (reverse! head) tail))
       (else
        (next (cons (car tail) head)
              (cdr tail))))))
               
  

  )