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