;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          pipes.lisp
;;;; Purpose:       Pipes based on ideas from Norvig's PAIP book
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Apr 2000
;;;;
;;;; $Id: pipes.lisp,v 1.3 2002/10/10 16:23:48 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; 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 :kmrcl)

(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."
  ;; This assumes that pipes will 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 i)
  "ith element of pipe, 0 based."
  (if (= i 0) (pipe-head pipe)
     (pipe-elt (pipe-tail pipe) (- i 1))))

(defconstant +empty-pipe+ nil)

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

;;; incorrect version-- as in Norvig.
;(defun filter-pipe (predicate pipe)
;  "keep only items in (non-null) pipe satisfying predicate"
;  (if (funcall predicate (head pipe))
;    (make-pipe (head pipe) (filter-pipe predicate (tail pipe)))
;    (pipe-filter predicate (tail 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)))))



#||
;; Applications

(defun integers (&optional (start 0) end)
  "a pipe of integers from START to END."
  (if (or (null end) (<= start end))
    (make-pipe start (integers (+ start 1) end))
    nil))

(defun fibgen (a b)
    (make-pipe a (fibgen b (+ a b))))

(defun fibs ()
  (fibgen 0 1))


(defun divisible? (x y) 
  (zerop (rem x y)))


(defun no-sevens ()
   (pipe-filter #'(lambda (x) (not (divisible? x 7))) (integers)))


(defun sieve (stream)
  (make-pipe
   (pipe-head stream)
   (sieve (pipe-filter
           #'(lambda (x)
	       (not (divisible? x (pipe-head stream))))
           (pipe-tail stream)))))

(defun primes ()
  (sieve (integers 2)))


;; Pi

(defun scale-pipe (factor pipe)
  (pipe-map #'(lambda (x) (* x factor)) pipe))

(defun sum-pipe (sum s)
  (make-pipe sum
	     (sum-pipe (+ sum (pipe-head s))
		       (pipe-tail s))))

(defun partial-sums (s)
  (make-pipe (pipe-head s) (sum-pipe 0 s)))

(defun pi-summands (n)
  (make-pipe (/ 1d0 n)
	     (pipe-map #'- (pi-summands (+ n 2)))))

(defun pi-stream ()
   (scale-pipe 4d0 (partial-sums (pi-summands 1))))

(defun square (x)
  (* x x))

(defun euler-transform (s)
      (let ((s0 (pipe-elt s 0))
	    (s1 (pipe-elt s 1))    
	    (s2 (pipe-elt s 2)))
	(if (and s0 s1 s2)
	    (if (eql s1 s2)	;;; series has converged 
		+empty-pipe+
	      (make-pipe (- s2 (/ (square (- s2 s1))
				  (+ s0 (* -2 s1) s2)))
			 (euler-transform (pipe-tail s))))
	  +empty-pipe+)))
  

(defun ln2-summands (n)
  (pipe-map (/ 1d0 n)
	    (pipe-map #'- (ln2-summands (1+ n)))))

(defun ln2-stream ()
  (partial-sums (ln2-summands 1)))

(defun make-tableau (transform s)
  (make-pipe s
	     (make-tableau transform
			   (funcall transform s))))

(defun accelerated-sequence (transform s)
  (pipe-map #'pipe-head
	    (make-tableau transform s)))


 (pipe-display (pi-stream) 10)
 (pipe-display (euler-transform (pi-stream)) 10)
 (pipe-display (accelerated-sequence #'euler-transform (pi-stream)) 10)

||#