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

;;; 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 '() (map 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.

(define (vector-for-each f v1 #!optional (v2 c#absent-object)  #!rest vs)

  (define (vector-for-each-1 f v)
    (let* ((n (vector-length v)))
      (do ((i (fx- n 1) (fx- i 1)))
	  ((fx< i 0))
	(f (vector-ref v i)))))
  
  (define (vector-for-each-2 f v1 v2)
    (let* ((n (vector-length v1)))
      (do ((i (fx- n 1) (fx- i 1)))
	  ((fx< i 0))
	(f (vector-ref v1 i) (vector-ref v2 i)))))

  (define (vector-for-each-n f vectors)
    (let* ((n (vector-length (car vectors))))
      (do ((i (fx- n 1) (fx- i 1)))
	  ((fx< i 0))
	(apply f (map (lambda (v) (vector-ref v i)) vectors)))))

  (cond ((eq? v2 c#absent-object)
	 (vector-for-each-1 f v1))
	((null? vs)
	 (vector-for-each-2 f v1 v2))
	(else
	 (vector-for-each-n f (cons v1 (cons v2 vs))))))

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

(define (vector-for-each-with-index f v1 #!optional (v2 c#absent-object)  #!rest vs)

  (define (vector-for-each-with-index-1 f v)
    (let* ((n (vector-length v)))
      (do ((i (fx- n 1) (fx- i 1)))
	  ((fx< i 0))
	(f i (vector-ref v i)))))
  
  (define (vector-for-each-with-index-2 f v1 v2)
    (let* ((n (vector-length v1)))
      (do ((i (fx- n 1) (fx- i 1)))
	  ((fx< i 0))
	(f i (vector-ref v1 i) (vector-ref v2 i)))))

  (define (vector-for-each-with-index-n f vectors)
    (let* ((n (vector-length (car vectors))))
      (do ((i (fx- n 1) (fx- i 1)))
	  ((fx< i 0))
	(apply f i (map (lambda (v) (vector-ref v i)) vectors)))))

  (cond ((eq? v2 c#absent-object)
	 (vector-for-each-with-index-1 f v1))
	((null? vs)
	 (vector-for-each-with-index-2 f v1 v2))
	(else
	 (vector-for-each-with-index-n f (cons v1 (cons v2 vs))))))

(define c#absent-object
  (string->symbol "#<absent>")) ; (##type-cast -6 2)

(define (vector-map f v1 #!optional (v2 c#absent-object)  #!rest vs)

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

  (define (vector-map-n f vectors)
    (let* ((n (vector-length (car vectors)))
	   (result (make-vector n)))
      (do ((i (fx- n 1) (fx- i 1)))
	  ((fx< i 0) result)
	(vector-set! result i (apply f (map (lambda (v) (vector-ref v i)) vectors))))))

  (cond ((eq? v2 c#absent-object)
	 (vector-map-1 f v1))
	((null? vs)
	 (vector-map-2 f v1 v2))
	(else
	 (vector-map-n f (cons v1 (cons v2 vs))))))

;;; removes "equal" adjacent elements of the list

(define (unique equal l)

  (define (helper v l)
    (cond ((null? l)
	   l)
	  ((equal v (car l))
	   (helper v (cdr l)))
	  (else
	   (cons v (unique equal (cdr l))))))

  (if (null? l)
      l
      (helper (car l) (cdr l))))

;;; removes "equal" adjacent elements of the list and conses a count before each element

(define (unique-with-count equal l)

  (define (helper count v l)
    (cond ((null? l)
	   (cons (cons count v) l))
	  ((equal v (car l))
	   (helper (fx+ count 1) v (cdr l)))
	  (else
	   (cons (cons count v)
		 (unique-with-count equal l)))))

  (if (null? l)
      l
      (helper 1 (car l) (cdr l))))