mes: Add unfold.

* module/srfi/srfi-1.mes (unfold): New function.

diff --git a/module/srfi/srfi-1.mes b/module/srfi/srfi-1.mes
index 58de5b08032cde50e48c23cbc8ddbc556ca4ab13..c305302e4119d70a90a824f816ce683c7472f11c 100644 (file)
--- a/module/srfi/srfi-1.mes
+++ b/module/srfi/srfi-1.mes
@@ -1,7 +1,7 @@
 ;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
@@ -52,8 +52,6 @@
                     (filter-map f (cdr h) (cdar t))))
               (error 'unsupported (cons* "filter-map 3:" f h t))))))
 
-;;; nyacc requirements
-
 (define (fold proc init lst1 . rest)
   (if (null? rest)
       (let loop ((lst lst1) (result init))
@@ -68,6 +66,20 @@
             (proc (car lst) (loop (cdr lst)))))
       '*FOLD-RIGHT-n-NOT-SUPPORTED))
 
+(define (unfold p f g seed . rest)
+  (let ((tail-gen (if (null? rest) (const '())
+                      (car rest))))
+    (define (reverse+tail lst seed)
+            (let loop ((lst lst)
+                       (result (tail-gen seed)))
+              (if (null? lst) result
+                  (loop (cdr lst)
+                        (cons (car lst) result)))))
+    (let loop ((seed seed) (result '()))
+      (if (p seed) (reverse+tail result seed)
+          (loop (g seed)
+                (cons (f seed) result))))))
+
 (define (remove pred lst) (filter (lambda (x) (not (pred x))) lst))
 
 (define (reverse! lst . term)

diff --git a/tests/srfi-1.test b/tests/srfi-1.test
index 3778b7ec47ce9124d0c5b95e9a770d9acc760097..c5fd144358e103fa6774bbf0ada13176a478f029 100755 (executable)
--- a/tests/srfi-1.test
+++ b/tests/srfi-1.test
@@ -40,6 +40,10 @@ exit $?
                '(1 2 3)
                (fold-right cons '() '(1 2 3)))
 
+(pass-if-equal "unfold"
+               '(4 3 2 1 foo)
+               (unfold zero? identity 1- 4 (const '(foo))))
+
 (pass-if-equal "remove"
                '(1 3)
                (remove even? '(1 2 3)))