(define (identity x) x)

(define (for-each-cdr function list)
  (let loop ((l list))
    (when (pair? l)
          (function l)
          (loop (cdr l)))))

(define (for-each-cdr! function list)
  (let loop ((l list))
    (when (pair? l)
          (let ((next (cdr l)))
            (function l)
            (loop next)))))

(define (for-each function list)
  (for-each-cdr (lambda (x) (function (car x))) list))

(define (map! function list)
  (for-each-cdr (lambda (x) (set-car! x (function (car x)))) list)
  list)

(define ((make-accumulate iterator) function initial-value structure)
  (iterator
    (lambda (x) (set! initial-value (function initial-value x)))
    structure)
  initial-value)

(define (reverse-append a b)
  ((make-accumulate for-each)
   (lambda (x y) (cons y x))
   b
   a))

(define (reverse-append! a b)
  ((make-accumulate for-each-cdr!)
   (lambda (x y) (set-cdr! y x) y)
   b
   a))

(define ((make-collect-cons iterator) function structure)
  (reverse!
    ((make-accumulate iterator)
     (lambda (x y) (cons (function y) x))
     '()
     structure)))

;;;or we can use a clever trick of Risch:

(define (rcons pair value)
  (let ((temp (cons value '())))
    (set-cdr! pair temp)
    temp))

(define ((make-collect-cons iterator) function structure)
  (let ((header '(())))
    (set-cdr! header '())
    ((make-accumulate iterator)
     rcons
     header
     structure)
    (cdr header)))

(define map (make-collect-cons for-each))

(define (list-copy list) (map identity list))

(define ((make-collect-append! iterator) function structure)
  (reverse!
    ((make-accumulate iterator)
     (lambda (x y) (reverse-append! (function y) x))
     '()
     structure)))

(define map-append! (make-collect-append! for-each))

(define (list? x) (or (pair? x) (null? x)))

(define (for-each-integer function n)
  (let loop ((i 0))
    (when (< i n)
          (function i)
          (loop (1+ i)))))

(define generate-list (make-collect-cons for-each-integer))

(define (generate-vector function number)
  (let ((v (make-vector number)))
    (for-each-integer
      (lambda (i) (vector-set! v i (function i)))
      (vector-length v))
    v))

(define (vector-map! function v)
  (for-each-integer
    (lambda (i)
      (vector-set! v i (function (vector-ref v i))))
    (vector-length v))
  v)

(define (string-map! function s)
  (for-each-integer
    (lambda (i)
      (string-set! s i (function (string-ref s i))))
    (string-length s))
  s)

(define (vector-for-each function v)
  (for-each-integer
    (lambda (i) (function (vector-ref v i)))
    (vector-length v)))

(define (string-for-each function s)
  (for-each-integer
    (lambda (i) (function (string-ref s i)))
    (string-length s)))

(define (vector-map function v)
  (generate-vector
    (lambda (i) (function (vector-ref v i)))
    (vector-length v)))

(define (vector-copy v) (vector-map identity v))

(define (iota n) (generate-list identity n))

(define (vector-iota n) (generate-vector identity n))

(define (make-random-function p)
  (if (null? p)
      (lambda (x) (%random))
      (let ((p (car p))) (lambda (x) (random p)))))

(define (random-list n . p)
  (generate-list (make-random-function p) n))

(define (random-vector n . p)
  (generate-vector (make-random-function p) n))

(define (reverse-iota n) (reverse! (iota n)))

(define (random-iota n . p)
  (generate-list
    (let ((p (if (null? p) n (car p))))
      (lambda (x) (+ x (random p))))
    n))

(define (string-downcase! s)
  (string-map! char-downcase s))

(define ((make-reduce non-empty-predicate? non-empty-reduction)
         operation x . identity)
  (cond ((non-empty-predicate? x)
         (non-empty-reduction operation x))
        ((pair? identity) (car identity))
        (else (operation))))

(define reduce
  (make-reduce
    pair?
    (lambda (operation list)
      ((make-accumulate for-each)
       operation
       (car list)
       (cdr list)))))

(define (pairwise-reduce-non-empty-list! operation list)
  (for-each-cdr
    (lambda (x)
      (when (pair? (cdr x))
            (set-car! x (operation (car x) (cadr x)))
            (set-cdr! x (cddr x))))
    list)
  list)

(define pairwise-reduce!
  (make-reduce pair? pairwise-reduce-non-empty-list!))

(define (apply-until predicate? function x)
  (if (predicate? x)
      x
      (apply-until predicate? function (function x))))

(define parallel-reduce!
  (make-reduce
    pair?
    (lambda (operation list)
      (apply-until
        (lambda (x) (null? (cdr x)))
        (lambda (x) (pairwise-reduce-non-empty-list! operation x))
        list)
      (car list))))

(define vector-reduce
  (make-reduce
    (lambda (v) (>= (vector-length v) 0))
    (lambda (operation vector)
      ((make-accumulate
         (lambda (function v)
           (let ((length (vector-length v)))
             (do ((i 1 (1+ i)))
                 ((>= i length))
                 (function (vector-ref v i))))))
       operation
       (vector-ref vector 0)
       vector))))

(define ((make-iterate-until predicate iterator . return-value)
         function structure)
  (call/cc (lambda (exit)
             (iterator (lambda (x)
                         (if (predicate x)
                             (exit x)
                             (function x)))
                       structure)
             (if return-value
                 (car return-value)
                 '()))))

(define ((make-iterate-while predicate iterator . return-value)
         function structure)
  (call/cc (lambda (exit)
             (iterator (lambda (x)
                         (if (predicate x)
                             (function x)
                             (exit x)))
                       structure)
             (if return-value
                 (car return-value)
                 '()))))

(define (member-if predicate? list)
  ((make-iterate-until
     (lambda (x) (predicate? (car x)))
     for-each-cdr)
   identity
   list))

(define (filter predicate list)
  (map-append!
    (lambda (x)
      (if (predicate x)
          (cons x '())
          '()))
    list))

(define (filter! predicate list)
  (let ((first (member-if predicate list)))
    (if first
        (apply-until
          (lambda (x) (null? (cdr x)))
          (lambda (x)
            (cond ((predicate (cadr x))
                   (cdr x))
                  (else
                    (set-cdr! x (cddr x))
                    x)))
          first))
    first))

(define (outer-product function l1 l2)
  (map (lambda (x) (map (lambda (y) (function x y)) l1)) l2))