From cdd64714ad68980aaaa53bca0864d239cc2825ab Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 30 Jul 2020 13:28:35 +0200
Subject: Add stream-paginate.

---
 module/srfi/srfi-41/util.scm | 16 ++++++++++++++++
 tests/srfi-41-util.scm       | 35 +++++++++++++++++++++++++++++++++++
 2 files changed, 51 insertions(+)
 create mode 100644 tests/srfi-41-util.scm

diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm
index 2da2b479..472170d7 100644
--- a/module/srfi/srfi-41/util.scm
+++ b/module/srfi/srfi-41/util.scm
@@ -86,6 +86,22 @@
      (stream-map cadr (stream-filter car strm))
      (stream-map cadr (stream-remove car strm)))))
 
+(define-public (stream-split idx stream)
+  (stream-cons (stream-take idx stream)
+               (stream-drop idx stream)))
+
+(define-stream (stream-paginate% stream page-size)
+  (stream-match (stream-split page-size stream)
+                ((page . rest)
+                 (if (stream-null? page)
+                     stream-null
+                     (stream-cons
+                      page
+                      (stream-paginate rest page-size))))))
+
+(define*-public (stream-paginate stream optional: (page-size 10))
+  (stream-paginate% stream page-size))
+
 ;; Evaluates @var{body} in a context where most list fundamentals are
 ;; replaced by stream alternatives.
 ;; commented defifinitions are items which could be included, but for
diff --git a/tests/srfi-41-util.scm b/tests/srfi-41-util.scm
new file mode 100644
index 00000000..61bce71e
--- /dev/null
+++ b/tests/srfi-41-util.scm
@@ -0,0 +1,35 @@
+(((srfi srfi-41 util) stream-paginate)
+ ((srfi srfi-41) stream->list stream-ref stream-from
+  stream-filter stream-car stream)
+ ((ice-9 sandbox) call-with-time-limit)
+ )
+
+(test-equal "Finite stream"
+  '((0 1 2) (3 4 5) (6 7 8) (9))
+  (let ((strm
+         (stream-paginate (stream 0 1 2 3 4 5 6 7 8 9)
+                          3)))
+    (map stream->list (stream->list strm))))
+
+
+(test-equal "slice of infinite"
+    '(1000 1001 1002 1003 1004 1005 1006 1007 1008 1009)
+  (let ((strm (stream-paginate (stream-from 0))))
+    (stream->list (stream-ref strm 100))))
+
+
+
+(define unique-symbol (gensym))
+
+(test-equal "time out on infinite 'empty' stream"
+  unique-symbol
+  ;; defined outside time limit since creation should always
+  ;; succeed. Only reference is expected to fail.
+  (let ((strm (stream-paginate
+               ;; easy way to get stream which never finds
+               ;; any elements.
+               (stream-filter negative? (stream-from 0)))))
+    (call-with-time-limit
+     0.1
+     (lambda () (stream-car strm))
+     (lambda _ unique-symbol))))
-- 
cgit v1.2.3