;;; appends (reverse xrev) to y

(define (reverse-append! xrev y)
  (if (null? xrev)
      y 
      (let ((temp (cdr xrev)))
	(set-cdr! xrev y)
	(reverse-append! temp xrev))))

;;; keeps those elements of the list l that satisfy p

(define (keep p l)
  (let loop ((result '()) (l l))
    (if (null? l)
	(reverse-append! result '())
	(if (p (car l))
	    (loop (cons (car l) result) (cdr l))
	    (loop result (cdr l))))))

;;; some specialized, naive maps for speed.

(define (map1 f l)
  (let loop ((result '())
	     (l l))
    (if (null? l)
	(reverse-append! result '())
	(loop (cons (f (car l)) result)
	      (cdr l)))))

(define (map2 f l1 l2)
  (let loop ((result '())
	     (l1 l1)
	     (l2 l2))
    (if (or (null? l1) (null? l2))
	(reverse-append! result '())
	(loop (cons (f (car l1) (car l2)) result)
	      (cdr l1)
	      (cdr l2)))))

;;; applies f to elements of the list l, each result is a list, 
;;; appends the lists

(define (mappend1 f l)
  ;; is O(N); reduce-from-left would be O(N^2)
  (reduce-from-right append '() (map1 f l)))

;;; assumes you have an associative operation op with identity id; 
;;; applies it to adjacent pairs of the element of the list l

;;; Note: This version of reduce associates to the left,
;;; (reduce-from-left op id (list a b c)) => (op (op (op id a) b) c)

(define (reduce-from-left op id l)
  (let loop ((result id) (l l))
    (if (null? l)
	result
	(loop (op result (car l)) (cdr l)))))

;;; Note: This version of reduce associates to the right,
;;; (reduce-from-right op id (list a b c)) => (op a (op b (op c id)))

(define (reduce-from-right op id l)
  (let loop ((result id) (rev-l (reverse l)))
    (if (null? rev-l)
	result
	(loop (op (car rev-l) result) (cdr rev-l)))))


;;; Single dispatch is faster than multiple dispatch; on the other hand, 
;;; for many two-argument vector functions, we need the two arguments to
;;; have the same class (which is impossible to check anyway in Meroon, e.g., 
;;; (define-method (foo (x bar) (y bar)) ...)
;;; will match if x is a (plain) bar, and y is a subclassed (specialized) bar.)
;;; So we often (but not always) use single dispatch with this
;;; auxiliary function.

(define-generic (check-same-class (x Object) y)
  (and (Object? y)
       (eq? (object->class-number x) (object->class-number y))))

;;; the following comes up enough that we'll abstract it.
;;; the -1 means that it takes only one vector argument

(define (vector-for-each-1 proc v)
  (declare (fixnum))
  (let ((n (vector-length v)))
    (do ((i 0 (+ i 1)))
	((= i n))
      (proc (vector-ref v i)))))

;;; here we put the index as the first argument of proc to allow us to extend
;;; the definition to arbitrary number of vectors v later, if needed

(define (vector-for-each-with-index-1 proc v)
  (declare (fixnum))
  (let ((n (vector-length v)))
    (do ((i 0 (+ i 1)))
	((= i n))
      (proc i (vector-ref v i)))))

(define (vector-map-1 f v)
  (declare (fixnum))
  (let* ((n (vector-length v))
	 (result (make-vector n)))
  (do ((i (- n 1) (- i 1)))
      ((< i 0) result)
    (vector-set! result i (f (vector-ref v i))))))

(define (vector-map-2 f v1 v2)
  (declare (fixnum))
  (let* ((n (vector-length v1))
	 (result (make-vector n)))
  (do ((i (- n 1) (- i 1)))
      ((< i 0) result)
    (vector-set! result i (f (vector-ref v1 i) (vector-ref v2 i))))))