+++ /dev/null
-;;;; -*- 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)
-
-||#
-
projects / kmrcl.git / commitdiff