+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: pipes.lisp
+;;;; Purpose: Pipes based on ideas from Norvig's PAIP book
+;;;; Programmers: Kevin M. Rosenberg and Peter Norvig
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: pipes.lisp,v 1.1 2002/11/02 17:49:10 kevin Exp $
+;;;;
+;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg and
+;;;; Copyright (c) 1998-2002 by Peter Norvig.
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :pipes)
+
+
+(defconstant +empty-pipe+ nil)
+
+(defmacro make-pipe (head tail)
+ "create a pipe by eval'ing head and delaying tail."
+ `(cons ,head #'(lambda () ,tail)))
+
+(defun pipe-tail (pipe)
+ "return tail of pipe or list, and destructively update
+ the tail if it is a function."
+ ;; pipes should never contain functions as values
+ (if (functionp (rest pipe))
+ (setf (rest pipe) (funcall (rest pipe)))
+ (rest pipe)))
+
+(defun pipe-head (pipe) (first pipe))
+
+(defun pipe-elt (pipe n)
+ "nth element of pipe, 0 based."
+ (if (= n 0) (pipe-head pipe)
+ (pipe-elt (pipe-tail pipe) (- n 1))))
+
+
+(defun enumerate (pipe &key count key (result pipe))
+ "go through all or count elements of pipe,
+ possibly applying the key function. "
+ (if (or (eq pipe +empty-pipe+) (eql count 0))
+ result
+ (progn
+ (unless (null key) (funcall key (pipe-head pipe)))
+ (enumerate (pipe-tail pipe)
+ :count (if count (1- count))
+ :key key
+ :result result))))
+
+(defun pipe-display (pipe &optional count)
+ (enumerate pipe :count count))
+
+(defun pipe-force (pipe)
+ (enumerate pipe))
+
+(defun pipe-filter (predicate pipe)
+ "keep only items in (non-null) pipe satisfying predicate"
+ (if (eq pipe +empty-pipe+)
+ +empty-pipe+
+ (let ((head (pipe-head pipe))
+ (tail (pipe-tail pipe)))
+ (if (funcall predicate head)
+ (make-pipe head (pipe-filter predicate tail))
+ (pipe-filter predicate tail)))))
+
+
+(defun pipe-map (fn pipe)
+ "Map fn over pipe, delaying all but the first fn call,
+ collecting res<ults"
+ (if (eq pipe +empty-pipe+)
+ +empty-pipe+
+ (make-pipe (funcall fn (pipe-head pipe))
+ (pipe-map fn (pipe-tail pipe)))))
+
+
+(defun pipe-map-filtering (fn pipe &optional filter-test)
+ "Map fn over pipe, delaying all but the first fn call,
+ collecting results"
+ (if (eq pipe +empty-pipe+)
+ +empty-pipe+
+ (let* ((head (pipe-head pipe))
+ (tail (pipe-tail pipe))
+ (result (funcall fn head)))
+ (if (or (and filter-test (funcall filter-test result))
+ result)
+ (make-pipe result (pipe-map-filtering fn tail filter-test))
+ (pipe-map-filtering fn tail filter-test)))))
+
+
+(defun pipe-append (pipex pipey)
+ "return a pipe that appends two pipes"
+ (if (eq pipex +empty-pipe+)
+ pipey
+ (make-pipe (pipe-head pipex)
+ (pipe-append (pipe-tail pipex) pipey))))
+
+(defun pipe-mappend (fn pipe)
+ "lazily map fn over pipe, appending results"
+ (if (eq pipe +empty-pipe+)
+ +empty-pipe+
+ (let ((x (funcall fn (pipe-head pipe))))
+ (make-pipe (pipe-head x)
+ (pipe-append (pipe-tail x)
+ (pipe-mappend fn (pipe-tail pipe)))))))
+
+(defun pipe-mappend-filtering (fn pipe &optional filter-test)
+ "Map fn over pipe, delaying all but the first fn call,
+ appending results, filtering along the way"
+ (if (eq pipe +empty-pipe+)
+ +empty-pipe+
+ (let* ((head (pipe-head pipe))
+ (tail (pipe-tail pipe))
+ (result (funcall fn head)))
+ (if (or (and filter-test (funcall filter-test result))
+ result)
+ (make-pipe (pipe-head result)
+ (pipe-append (pipe-tail result)
+ (pipe-mappend-filtering fn tail filter-test)))
+ (pipe-mappend-filtering fn tail filter-test)))))