;;;
;;; Filters of SRFI-1
;;;

;; $Id: filter.scm,v 1.4 2003/09/23 10:29:57 shirok Exp $

;; This code is based on the reference implementation by Olin Shivers
;;
;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
;; this code as long as you do not remove this copyright notice or
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.

;; NB: original SRFI-1 reference implementation uses non-tail recursive
;; calls a lot.  Unfortunately, Gauche is awkward to handle very deep
;; non-tail recursive calls, since the stack overflow handler is not
;; optimized well.  The simple tail-recursion and reverse!-ing the result
;; is much much faster.

(select-module srfi-1)

(define (filter pred lis)
  (let loop ((lis lis) (r '()))
    (cond
     ((null-list? lis) (reverse! r))
     ((pred (car lis))
      (loop (cdr lis) (cons (car lis) r)))
     (else
      (loop (cdr lis) r)))))

(define (filter$ pred) (pa$ filter pred))

(define (filter! pred lis)
  (let lp ((ans lis))
    (cond ((null-list? ans) ans)			; Scan looking for
	  ((not (pred (car ans))) (lp (cdr ans)))	; first cons of result.

	  ;; ANS is the eventual answer.
	  ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED.
	  ;;          Scan over a contiguous segment of the list that
	  ;;          satisfies PRED.
	  ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous
	  ;;           segment of the list that *doesn't* satisfy PRED.
	  ;;           When the segment ends, patch in a link from PREV
	  ;;           to the start of the next good segment, and jump to
	  ;;           SCAN-IN.
	  (else (letrec ((scan-in (lambda (prev lis)
				    (if (pair? lis)
					(if (pred (car lis))
					    (scan-in lis (cdr lis))
					    (scan-out prev (cdr lis))))))
			 (scan-out (lambda (prev lis)
				     (let lp ((lis lis))
				       (if (pair? lis)
					   (if (pred (car lis))
					       (begin (set-cdr! prev lis)
						      (scan-in lis (cdr lis)))
					       (lp (cdr lis)))
					   (set-cdr! prev lis))))))
		  (scan-in ans (cdr ans))
		  ans)))))

;; Avoid non-tail recursion.
(define (partition pred lis)
  (let recur ((lis lis)
              (in  '())
              (out '()))
    (if (null-list? lis)
        (values (reverse! in) (reverse! out))
        (if (pred (car lis))
            (recur (cdr lis) (cons (car lis) in) out)
            (recur (cdr lis) in (cons (car lis) out))))))

(define (partition$ pred) (pa$ partition pred))

(define (partition! pred lis)
  (check-arg procedure? pred)
  (if (null-list? lis) (values lis lis)

      ;; This pair of loops zips down contiguous in & out runs of the
      ;; list, splicing the runs together. The invariants are
      ;;   SCAN-IN:  (cdr in-prev)  = LIS.
      ;;   SCAN-OUT: (cdr out-prev) = LIS.
      (letrec ((scan-in (lambda (in-prev out-prev lis)
			  (let lp ((in-prev in-prev) (lis lis))
			    (if (pair? lis)
				(if (pred (car lis))
				    (lp lis (cdr lis))
				    (begin (set-cdr! out-prev lis)
					   (scan-out in-prev lis (cdr lis))))
				(set-cdr! out-prev lis))))) ; Done.

	       (scan-out (lambda (in-prev out-prev lis)
			   (let lp ((out-prev out-prev) (lis lis))
			     (if (pair? lis)
				 (if (pred (car lis))
				     (begin (set-cdr! in-prev lis)
					    (scan-in lis out-prev (cdr lis)))
				     (lp lis (cdr lis)))
				 (set-cdr! in-prev lis)))))) ; Done.

	;; Crank up the scan&splice loops.
	(if (pred (car lis))
	    ;; LIS begins in-list. Search for out-list's first pair.
	    (let lp ((prev-l lis) (l (cdr lis)))
	      (cond ((null-list? l) (values lis l))
		    ((pred (car l)) (lp l (cdr l)))
		    (else (scan-out prev-l l (cdr l))
			  (values lis l))))	; Done.

	    ;; LIS begins out-list. Search for in-list's first pair.
	    (let lp ((prev-l lis) (l (cdr lis)))
	      (cond ((null-list? l) (values l lis))
		    ((pred (car l))
		     (scan-in l prev-l (cdr l))
		     (values l lis))		; Done.
		    (else (lp l (cdr l)))))))))

(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
(define (remove  pred l) (filter  (lambda (x) (not (pred x))) l))

(define (remove$ pred) (pa$ remove pred))
