1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Pipes based on ideas from Norvig's PAIP book
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: pipes.lisp,v 1.2 2002/10/06 13:30:17 kevin Exp $
12 ;;;; This file, part of Kmrcl, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; Kmrcl users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the GNU General Public License.
16 ;;;; *************************************************************************
20 (defmacro make-pipe (head tail)
21 "create a pipe by eval'ing head and delaying tail."
22 `(cons ,head #'(lambda () ,tail)))
24 (defun pipe-tail (pipe)
25 "return tail of pipe or list, and destructively update
26 the tail if it is a function."
27 ;; This assumes that pipes will never contain functions as values...
28 (if (functionp (rest pipe))
29 (setf (rest pipe) (funcall (rest pipe)))
32 (defun pipe-head (pipe) (first pipe))
34 (defun pipe-elt (pipe i)
35 "ith element of pipe, 0 based."
36 (if (= i 0) (pipe-head pipe)
37 (pipe-elt (pipe-tail pipe) (- i 1))))
39 (defconstant +empty-pipe+ nil)
41 (defun enumerate (pipe &key count key (result pipe))
42 "go through all or count elements of pipe,
43 possibly applying the key function. "
44 (if (or (eq pipe +empty-pipe+) (eql count 0))
47 (unless (null key) (funcall key (pipe-head pipe)))
48 (enumerate (pipe-tail pipe)
49 :count (if count (1- count))
53 (defun pipe-display (pipe &optional count)
54 (enumerate pipe :count count))
56 (defun pipe-force (pipe)
59 ;;; incorrect version-- as in Norvig.
60 ;(defun filter-pipe (predicate pipe)
61 ; "keep only items in (non-null) pipe satisfying predicate"
62 ; (if (funcall predicate (head pipe))
63 ; (make-pipe (head pipe) (filter-pipe predicate (tail pipe)))
64 ; (pipe-filter predicate (tail pipe))))
67 (defun pipe-filter (predicate pipe)
68 "keep only items in (non-null) pipe satisfying predicate"
69 (if (eq pipe +empty-pipe+)
71 (let ((head (pipe-head pipe))
72 (tail (pipe-tail pipe)))
73 (if (funcall predicate head)
74 (make-pipe head (pipe-filter predicate tail))
75 (pipe-filter predicate tail)))))
78 (defun pipe-map (fn pipe)
79 "Map fn over pipe, delaying all but the first fn call,
81 (if (eq pipe +empty-pipe+)
83 (make-pipe (funcall fn (pipe-head pipe))
84 (pipe-map fn (pipe-tail pipe)))))
87 (defun pipe-map-filtering (fn pipe &optional filter-test)
88 "Map fn over pipe, delaying all but the first fn call,
90 (if (eq pipe +empty-pipe+)
92 (let* ((head (pipe-head pipe))
93 (tail (pipe-tail pipe))
94 (result (funcall fn head)))
95 (if (or (and filter-test (funcall filter-test result))
97 (make-pipe result (pipe-map-filtering fn tail filter-test))
98 (pipe-map-filtering fn tail filter-test)))))
101 (defun pipe-append (pipex pipey)
102 "return a pipe that appends two pipes"
103 (if (eq pipex +empty-pipe+)
105 (make-pipe (pipe-head pipex)
106 (pipe-append (pipe-tail pipex) pipey))))
108 (defun pipe-mappend (fn pipe)
109 "lazily map fn over pipe, appending results"
110 (if (eq pipe +empty-pipe+)
112 (let ((x (funcall fn (pipe-head pipe))))
113 (make-pipe (pipe-head x)
114 (pipe-append (pipe-tail x)
115 (pipe-mappend fn (pipe-tail pipe)))))))
117 (defun pipe-mappend-filtering (fn pipe &optional filter-test)
118 "Map fn over pipe, delaying all but the first fn call,
119 appending results, filtering along the way"
120 (if (eq pipe +empty-pipe+)
122 (let* ((head (pipe-head pipe))
123 (tail (pipe-tail pipe))
124 (result (funcall fn head)))
125 (if (or (and filter-test (funcall filter-test result))
127 (make-pipe (pipe-head result)
128 (pipe-append (pipe-tail result)
129 (pipe-mappend-filtering fn tail filter-test)))
130 (pipe-mappend-filtering fn tail filter-test)))))
137 (defun integers (&optional (start 0) end)
138 "a pipe of integers from START to END."
139 (if (or (null end) (<= start end))
140 (make-pipe start (integers (+ start 1) end))
144 (make-pipe a (fibgen b (+ a b))))
150 (defun divisible? (x y)
155 (pipe-filter #'(lambda (x) (not (divisible? x 7))) (integers)))
158 (defun sieve (stream)
163 (not (divisible? x (pipe-head stream))))
164 (pipe-tail stream)))))
167 (sieve (integers 2)))
172 (defun scale-pipe (factor pipe)
173 (pipe-map #'(lambda (x) (* x factor)) pipe))
175 (defun sum-pipe (sum s)
177 (sum-pipe (+ sum (pipe-head s))
180 (defun partial-sums (s)
181 (make-pipe (pipe-head s) (sum-pipe 0 s)))
183 (defun pi-summands (n)
185 (pipe-map #'- (pi-summands (+ n 2)))))
188 (scale-pipe 4d0 (partial-sums (pi-summands 1))))
193 (defun euler-transform (s)
194 (let ((s0 (pipe-elt s 0))
198 (if (eql s1 s2) ;;; series has converged
200 (make-pipe (- s2 (/ (square (- s2 s1))
201 (+ s0 (* -2 s1) s2)))
202 (euler-transform (pipe-tail s))))
206 (defun ln2-summands (n)
208 (pipe-map #'- (ln2-summands (1+ n)))))
211 (partial-sums (ln2-summands 1)))
213 (defun make-tableau (transform s)
215 (make-tableau transform
216 (funcall transform s))))
218 (defun accelerated-sequence (transform s)
219 (pipe-map #'pipe-head
220 (make-tableau transform s)))
223 (pipe-display (pi-stream) 10)
224 (pipe-display (euler-transform (pi-stream)) 10)
225 (pipe-display (accelerated-sequence #'euler-transform (pi-stream)) 10)