pipes.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          pipes.lisp
   6 ;;;; Purpose:       Pipes based on ideas from Norvig's PAIP book
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: pipes.lisp,v 1.3 2002/10/10 16:23:48 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  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 ;;;; *************************************************************************
  18
  19 (in-package :kmrcl)
  20
  21 (defmacro make-pipe (head tail)
  22   "create a pipe by eval'ing head and delaying tail."
  23   `(cons ,head #'(lambda () ,tail)))
  24
  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)))
  31     (rest pipe)))
  32
  33 (defun pipe-head (pipe) (first pipe))
  34
  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))))
  39
  40 (defconstant +empty-pipe+ nil)
  41
  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))
  46     result
  47     (progn
  48       (unless (null key) (funcall key (pipe-head pipe)))
  49       (enumerate (pipe-tail pipe)
  50                  :count (if count (1- count))
  51                  :key key
  52                  :result result))))
  53
  54 (defun pipe-display (pipe &optional count)
  55   (enumerate pipe :count count))
  56
  57 (defun pipe-force (pipe)
  58   (enumerate pipe))
  59
  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))))
  66
  67
  68 (defun pipe-filter (predicate pipe)
  69   "keep only items in (non-null) pipe satisfying predicate"
  70      (if (eq pipe +empty-pipe+)
  71       +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)))))
  77
  78
  79 (defun pipe-map (fn pipe)
  80   "Map fn over pipe, delaying all but the first fn call,
  81    collecting res<ults"
  82   (if (eq pipe +empty-pipe+)
  83     +empty-pipe+
  84     (make-pipe (funcall fn (pipe-head pipe))
  85                (pipe-map fn (pipe-tail pipe)))))
  86
  87
  88 (defun pipe-map-filtering (fn pipe &optional filter-test)
  89   "Map fn over pipe, delaying all but the first fn call,
  90    collecting results"
  91   (if (eq pipe +empty-pipe+)
  92     +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))
  97               result)
  98         (make-pipe result (pipe-map-filtering fn tail filter-test))
  99         (pipe-map-filtering fn tail filter-test)))))
 100
 101
 102 (defun pipe-append (pipex pipey)
 103   "return a pipe that appends two pipes"
 104   (if (eq pipex +empty-pipe+)
 105     pipey
 106     (make-pipe (pipe-head pipex)
 107                (pipe-append (pipe-tail pipex) pipey))))
 108
 109 (defun pipe-mappend (fn pipe)
 110   "lazily map fn over pipe, appending results"
 111   (if (eq pipe +empty-pipe+)
 112     +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)))))))
 117
 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+)
 122     +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))
 127               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)))))
 132
 133
 134
 135 #||
 136 ;; Applications
 137
 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))
 142     nil))
 143
 144 (defun fibgen (a b)
 145     (make-pipe a (fibgen b (+ a b))))
 146
 147 (defun fibs ()
 148   (fibgen 0 1))
 149
 150
 151 (defun divisible? (x y)
 152   (zerop (rem x y)))
 153
 154
 155 (defun no-sevens ()
 156    (pipe-filter #'(lambda (x) (not (divisible? x 7))) (integers)))
 157
 158
 159 (defun sieve (stream)
 160   (make-pipe
 161    (pipe-head stream)
 162    (sieve (pipe-filter
 163            #'(lambda (x)
 164                (not (divisible? x (pipe-head stream))))
 165            (pipe-tail stream)))))
 166
 167 (defun primes ()
 168   (sieve (integers 2)))
 169
 170
 171 ;; Pi
 172
 173 (defun scale-pipe (factor pipe)
 174   (pipe-map #'(lambda (x) (* x factor)) pipe))
 175
 176 (defun sum-pipe (sum s)
 177   (make-pipe sum
 178              (sum-pipe (+ sum (pipe-head s))
 179                        (pipe-tail s))))
 180
 181 (defun partial-sums (s)
 182   (make-pipe (pipe-head s) (sum-pipe 0 s)))
 183
 184 (defun pi-summands (n)
 185   (make-pipe (/ 1d0 n)
 186              (pipe-map #'- (pi-summands (+ n 2)))))
 187
 188 (defun pi-stream ()
 189    (scale-pipe 4d0 (partial-sums (pi-summands 1))))
 190
 191 (defun square (x)
 192   (* x x))
 193
 194 (defun euler-transform (s)
 195       (let ((s0 (pipe-elt s 0))
 196             (s1 (pipe-elt s 1))
 197             (s2 (pipe-elt s 2)))
 198         (if (and s0 s1 s2)
 199             (if (eql s1 s2)     ;;; series has converged
 200                 +empty-pipe+
 201               (make-pipe (- s2 (/ (square (- s2 s1))
 202                                   (+ s0 (* -2 s1) s2)))
 203                          (euler-transform (pipe-tail s))))
 204           +empty-pipe+)))
 205
 206
 207 (defun ln2-summands (n)
 208   (pipe-map (/ 1d0 n)
 209             (pipe-map #'- (ln2-summands (1+ n)))))
 210
 211 (defun ln2-stream ()
 212   (partial-sums (ln2-summands 1)))
 213
 214 (defun make-tableau (transform s)
 215   (make-pipe s
 216              (make-tableau transform
 217                            (funcall transform s))))
 218
 219 (defun accelerated-sequence (transform s)
 220   (pipe-map #'pipe-head
 221             (make-tableau transform s)))
 222
 223
 224  (pipe-display (pi-stream) 10)
 225  (pipe-display (euler-transform (pi-stream)) 10)
 226  (pipe-display (accelerated-sequence #'euler-transform (pi-stream)) 10)
 227
 228 ||#
 229