summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--sieve/sundaram.scm68
1 files changed, 68 insertions, 0 deletions
diff --git a/sieve/sundaram.scm b/sieve/sundaram.scm
new file mode 100644
index 0000000..457efb8
--- /dev/null
+++ b/sieve/sundaram.scm
@@ -0,0 +1,68 @@
+
+
+
+(use-modules (srfi srfi-41))
+
+
+
+(define base (stream-from 1))
+
+
+
+(define (curry f)
+ (lambda (x)
+ (lambda (y)
+ (f x y))))
+
+
+
+(define-stream (stream-ordered-diff xstrm ystrm)
+ (stream-match xstrm (() '()) ((x . xs)
+ (stream-match ystrm (() xstrm) ((y . ys)
+ (if (eq? x y)
+ (stream-ordered-diff xs ys)
+ (stream-cons x (stream-ordered-diff xs ystrm))))))))
+
+
+
+(define-stream (stream-merge xstrm ystrm)
+ (stream-match xstrm (() ystrm) ((x . xs)
+ (stream-match ystrm (() xstrm) ((y . ys)
+ (cond ((< x y) (stream-cons x (stream-merge xs ystrm)))
+ ((> x y) (stream-cons y (stream-merge xstrm ys)))
+ ((eq? x y) (stream-cons x (stream-merge xs ys)))))))))
+
+
+
+(define (f i j)
+ (+ i j (* 2 i j)))
+
+
+
+(define-stream (i-stream i)
+ (stream-map
+ ((curry f) i)
+ (stream-from i)))
+
+
+
+(define ij-stream
+ (stream-let loop ((n 1) (strm (i-stream 1)))
+ (let* ((cutoff ((curry >) (stream-car (i-stream n))))
+ (next (+ n 1))
+ (available (stream-take-while cutoff strm))
+ (remainder (stream-drop-while cutoff strm)))
+ (stream-append available (loop next (stream-merge remainder (i-stream next)))))))
+
+
+
+(define-stream (sieve input)
+ (stream-map
+ (lambda (x) (+ 1 (* 2 x)))
+ (stream-ordered-diff input ij-stream)))
+
+
+
+(define sundaram (stream-cons 2 (sieve base)))
+
+