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.3 2002/10/10 16:23:48 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 Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
21 (defmacro make-pipe (head tail)
22 "create a pipe by eval'ing head and delaying tail."
23 `(cons ,head #'(lambda () ,tail)))
25 (defun pipe-tail (pipe)
26 "return tail of pipe or list, and destructively update
27 the tail if it is a function."
28 ;; This assumes that pipes will never contain functions as values...
29 (if (functionp (rest pipe))
30 (setf (rest pipe) (funcall (rest pipe)))
33 (defun pipe-head (pipe) (first pipe))
35 (defun pipe-elt (pipe i)
36 "ith element of pipe, 0 based."
37 (if (= i 0) (pipe-head pipe)
38 (pipe-elt (pipe-tail pipe) (- i 1))))
40 (defconstant +empty-pipe+ nil)
42 (defun enumerate (pipe &key count key (result pipe))
43 "go through all or count elements of pipe,
44 possibly applying the key function. "
45 (if (or (eq pipe +empty-pipe+) (eql count 0))
48 (unless (null key) (funcall key (pipe-head pipe)))
49 (enumerate (pipe-tail pipe)
50 :count (if count (1- count))
54 (defun pipe-display (pipe &optional count)
55 (enumerate pipe :count count))
57 (defun pipe-force (pipe)
60 ;;; incorrect version-- as in Norvig.
61 ;(defun filter-pipe (predicate pipe)
62 ; "keep only items in (non-null) pipe satisfying predicate"
63 ; (if (funcall predicate (head pipe))
64 ; (make-pipe (head pipe) (filter-pipe predicate (tail pipe)))
65 ; (pipe-filter predicate (tail pipe))))
68 (defun pipe-filter (predicate pipe)
69 "keep only items in (non-null) pipe satisfying predicate"
70 (if (eq pipe +empty-pipe+)
72 (let ((head (pipe-head pipe))
73 (tail (pipe-tail pipe)))
74 (if (funcall predicate head)
75 (make-pipe head (pipe-filter predicate tail))
76 (pipe-filter predicate tail)))))
79 (defun pipe-map (fn pipe)
80 "Map fn over pipe, delaying all but the first fn call,
82 (if (eq pipe +empty-pipe+)
84 (make-pipe (funcall fn (pipe-head pipe))
85 (pipe-map fn (pipe-tail pipe)))))
88 (defun pipe-map-filtering (fn pipe &optional filter-test)
89 "Map fn over pipe, delaying all but the first fn call,
91 (if (eq pipe +empty-pipe+)
93 (let* ((head (pipe-head pipe))
94 (tail (pipe-tail pipe))
95 (result (funcall fn head)))
96 (if (or (and filter-test (funcall filter-test result))
98 (make-pipe result (pipe-map-filtering fn tail filter-test))
99 (pipe-map-filtering fn tail filter-test)))))
102 (defun pipe-append (pipex pipey)
103 "return a pipe that appends two pipes"
104 (if (eq pipex +empty-pipe+)
106 (make-pipe (pipe-head pipex)
107 (pipe-append (pipe-tail pipex) pipey))))
109 (defun pipe-mappend (fn pipe)
110 "lazily map fn over pipe, appending results"
111 (if (eq pipe +empty-pipe+)
113 (let ((x (funcall fn (pipe-head pipe))))
114 (make-pipe (pipe-head x)
115 (pipe-append (pipe-tail x)
116 (pipe-mappend fn (pipe-tail pipe)))))))
118 (defun pipe-mappend-filtering (fn pipe &optional filter-test)
119 "Map fn over pipe, delaying all but the first fn call,
120 appending results, filtering along the way"
121 (if (eq pipe +empty-pipe+)
123 (let* ((head (pipe-head pipe))
124 (tail (pipe-tail pipe))
125 (result (funcall fn head)))
126 (if (or (and filter-test (funcall filter-test result))
128 (make-pipe (pipe-head result)
129 (pipe-append (pipe-tail result)
130 (pipe-mappend-filtering fn tail filter-test)))
131 (pipe-mappend-filtering fn tail filter-test)))))
138 (defun integers (&optional (start 0) end)
139 "a pipe of integers from START to END."
140 (if (or (null end) (<= start end))
141 (make-pipe start (integers (+ start 1) end))
145 (make-pipe a (fibgen b (+ a b))))
151 (defun divisible? (x y)
156 (pipe-filter #'(lambda (x) (not (divisible? x 7))) (integers)))
159 (defun sieve (stream)
164 (not (divisible? x (pipe-head stream))))
165 (pipe-tail stream)))))
168 (sieve (integers 2)))
173 (defun scale-pipe (factor pipe)
174 (pipe-map #'(lambda (x) (* x factor)) pipe))
176 (defun sum-pipe (sum s)
178 (sum-pipe (+ sum (pipe-head s))
181 (defun partial-sums (s)
182 (make-pipe (pipe-head s) (sum-pipe 0 s)))
184 (defun pi-summands (n)
186 (pipe-map #'- (pi-summands (+ n 2)))))
189 (scale-pipe 4d0 (partial-sums (pi-summands 1))))
194 (defun euler-transform (s)
195 (let ((s0 (pipe-elt s 0))
199 (if (eql s1 s2) ;;; series has converged
201 (make-pipe (- s2 (/ (square (- s2 s1))
202 (+ s0 (* -2 s1) s2)))
203 (euler-transform (pipe-tail s))))
207 (defun ln2-summands (n)
209 (pipe-map #'- (ln2-summands (1+ n)))))
212 (partial-sums (ln2-summands 1)))
214 (defun make-tableau (transform s)
216 (make-tableau transform
217 (funcall transform s))))
219 (defun accelerated-sequence (transform s)
220 (pipe-map #'pipe-head
221 (make-tableau transform s)))
224 (pipe-display (pi-stream) 10)
225 (pipe-display (euler-transform (pi-stream)) 10)
226 (pipe-display (accelerated-sequence #'euler-transform (pi-stream)) 10)