;;; -*- Mode:LISP; Package:USER; Readtable:CL; Base:10 -*-

;;;FILTER-FILE
;;;
;;;Filter selected characters in a file to a new output file.  Pass
;;;FILTER-FILE a function to compare to each character; characters that
;;;pass the "test" are written to the output.  The default function is
;;;STANDARD-CHAR-P which has the effect of keeping only printable
;;;characters.

(defvar *last-filtered-chars*)

(defun filter-file (file &key outfile (test 'standard-char-p))
  "Filter characters from FILE that pass the TEST predicate into
output file OUTFILE."
  (declare (values outfile *last-filtered-chars*))
  (assert (functionp test) (test) "~s is not suitable as a function" test)
  (setq file (merge-pathnames file
			      (make-pathname :host si:associated-machine
					     :type "LISP"
					     :version :HIGHEST)))
  (check-type (pathname-name file) string)
  (check-type (pathname-type file) string)
  ;;
  ;;Should use MERGE-PATHNAMES here, but it's broken - it doesn't preserve
  ;;NIL components from both pathnames!
  ;;
  (let ((outfile-defaults (make-pathname :host (or (pathname-host file) si:associated-machine)
					 :type "FILTRD" :version :HIGHEST)))
    (setq outfile
	  (merge-pathnames 
	    (if outfile (merge-pathnames outfile outfile-defaults) outfile-defaults)
	    file)))
  (check-type (pathname-name outfile) string)
  (check-type (pathname-type outfile) string)
  ;;
  (format t "~&Filter input from ~a, output to ~a, testing for ~s"
	  file outfile test)
  ;;
  (setq *last-filtered-chars* nil)
  (with-open-file (in file)
    (with-open-file (out outfile :direction :output)
      (do ((ch (send in :tyi) (send in :tyi)))
	  ((null ch) (values outfile *last-filtered-chars*))
	(setq ch (character ch))
	(if (funcall test ch)
	    (send out :tyo ch)
	  (pushnew ch *last-filtered-chars* :test #'char=))))))