add xfold, xfold-right, xreduce, xreduce-right, xscan, xscan-right

Make scan, scan-right work with multiple lists.

3 files changed, 130 insertions, 14 deletions

diff --git a/mew.scm b/mew.scm
index 520001f..aa438bd 100644
--- a/mew.scm
+++ b/mew.scm
@@ -22,7 +22,7 @@
      while
      uniq-accumulator unlist until
      vals void?
-     xcond
+     xcond xfold xfold-right xreduce xreduce-right xscan xscan-right
      -> fun-> fun->> set->
      =? <>?
      ~?
@@ -197,7 +197,7 @@
                         (seq body ...)))
          (if (null? vals)
            (void)
-           (car vals))))))         
+           (car vals))))))
 
   (define-syntax fin
     (syntax-rules ()
@@ -844,25 +844,102 @@
                  (loop (+ i (get t (get haystack (+ i ln) #f) (inc ln)))))
                #f)))))))
 
+  (define-syntax imp
+    (syntax-rules ()
+      ((_ a b)
+       (or (not a) b))
+      ((_ a b c ...)
+       (or (not a) (imp b c ...)))))
+
+  ;; adapted from https://code.call-cc.org/svn/chicken-eggs/release/5/srfi-1/trunk/srfi-1.scm ------------------------------
+  (define (##srfi1#cars+cdrs lists)
+    (##sys#call-with-current-continuation
+     (lambda (abort)
+       (let recur ((lists lists))
+         (if (pair? lists)
+	   (receive (list other-lists) (car+cdr lists)
+	     (if (null-list? list)
+               (abort '() '()) ; LIST is empty -- bail out
+	       (receive (a d) (car+cdr list)
+		 (receive (cars cdrs) (recur other-lists)
+		   (values (cons a cars) (cons d cdrs))))))
+	   (values '() '()))))))
+
+  (define (##srfi1#cdrs lists)
+    (##sys#call-with-current-continuation
+     (lambda (abort)
+       (let recur ((lists lists))
+	 (if (pair? lists)
+	   (let ((lis (car lists)))
+	     (if (null-list? lis)
+               (abort '())
+	       (cons (cdr lis) (recur (cdr lists)))))
+	   '())))))
+
+  (define (xfold kons knil lis1 . lists)
+    (if (pair? lists)
+      (let lp ((lists (cons lis1 lists)) (ans knil))	; N-ary case
+	(receive (cars cdrs) (##srfi1#cars+cdrs lists)
+	  (if (null? cars)
+            ans ; Done.
+	    (lp cdrs (apply kons ans cars)))))
+
+      (let lp ((lis lis1) (ans knil))			; Fast path
+	(if (null-list? lis)
+          ans
+	  (lp (cdr lis) (kons ans (car lis)))))))
+
+  (define (xfold-right kons knil lis1 . lists)
+    (if (pair? lists)
+      (let recur ((lists (cons lis1 lists)))		; N-ary case
+        (let ((cdrs (##srfi1#cdrs lists)))
+	  (if (null? cdrs)
+            knil
+	    (apply kons (recur cdrs) (map car lists)))))
+
+      (let recur ((lis lis1))				; Fast path
+	(if (null-list? lis)
+          knil
+	  (let ((head (car lis)))
+	    (kons (recur (cdr lis)) head))))))
+
+  (define (xreduce f ridentity lis)
+    (if (null-list? lis)
+      ridentity
+      (xfold f (car lis) (cdr lis))))
+
+  (define (xreduce-right f ridentity lis)
+    (if (null-list? lis)
+      ridentity
+      (let recur ((head (car lis)) (lis (cdr lis)))
+	(if (pair? lis)
+	  (f (recur (car lis) (cdr lis)) head)
+	  head))))
+  ;; end of code lifted from srfi-1.scm ------------------------------
+
   (define (scan kons knil . lists)
-    (reverse (apply fold (lambda (elt acc)
-                           (cons (kons elt (car acc)) acc))
+    (reverse (apply xfold (lambda (acc . elts)
+                            (cons (apply kons (append elts (list (car acc)))) acc))
                     (list knil)
                     lists)))
 
   (define (scan-right kons knil . lists)
-    (apply fold-right (lambda (elt acc)
-                        (cons (kons elt (car acc)) acc))
+    (apply xfold-right (lambda (acc . elts)
+                         (cons (apply kons (append elts (list (car acc)))) acc))
            (list knil)
            lists))
 
-  (define-syntax imp
-    (syntax-rules ()
-      ((_ a b)
-       (or (not a) b))
-      ((_ a b c ...)
-       (or (not a) (imp b c ...)))))
+  (define (xscan kons knil . lists)
+    (reverse (apply xfold (lambda (acc . elts)
+                           (cons (apply kons (car acc) elts) acc))
+                    (list knil)
+                    lists)))
 
+  (define (xscan-right kons knil . lists)
+    (apply xfold-right (lambda (acc . elts)
+                         (cons (apply kons (car acc) elts) acc))
+           (list knil)
+           lists))
 
   (let ((old-repl-prompt (repl-prompt)))
     (repl-prompt (lambda ()
diff --git a/mew.svnwiki b/mew.svnwiki
index f11e5d6..c10a557 100644
--- a/mew.svnwiki
+++ b/mew.svnwiki
@@ -253,6 +253,19 @@ Returns true if {{<va>}} is an unspecified value, else false.
 <procedure>(scan-right <kons> <knil> <lists>...)</procedure>
 
 Like {{fold}}/{{fold-right}}, but collects all accumulator values.
+Prefer {{xscan}}/{{xscan-right}}.
+
+<procedure>(xfold <kons> <knil> <lists>...)</procedure>
+<procedure>(xfold-right <kons> <knil> <lists>...)</procedure>
+<procedure>(xreduce <kons> <knil> <lists>...)</procedure>
+<procedure>(xreduce-right <kons> <knil> <lists>...)</procedure>
+<procedure>(xscan <kons> <knil> <lists>...)</procedure>
+<procedure>(xscan-right <kons> <knil> <lists>...)</procedure>
+
+Like {{fold}}/{{fold-right}}/{{reduce}}/{{reduce-right}}/{{scan}}/{{scan-right}},
+but {{<kons>}} always takes the accumulator as first arguments,
+and the items after.  This is more practical when multiple {{lists}}
+are passed.
 
 <syntax>(imp <antedecent>... <consequent>)<syntax>
 
diff --git a/tests/test.mew b/tests/test.mew
index 328e282..e638377 100644
--- a/tests/test.mew
+++ b/tests/test.mew
@@ -532,11 +532,37 @@
 
 (test-group "scan"
   (test '(0 -4 -9 -15) (scan (flip -) 0 '(4 5 6)))
-  (test '(42) (scan * 42 '())))
+  (test '(42) (scan * 42 '()))
+  (test '(0 6 14 24 36) (scan + 0 '(1 2 3 4) '(5 6 7 8)))
+  (test '(0 -4 0 -4 0) (scan - 0 '(1 2 3 4) '(5 6 7 8))))
+
+(test-group "xscan"
+  (test '(0 6 14 24 36) (xscan + 0 '(1 2 3 4) '(5 6 7 8)))
+  (test '(0 -6 -14 -24 -36) (xscan - 0 '(1 2 3 4) '(5 6 7 8))))
 
 (test-group "scan-right"
   (test '(5 -1 6 0)    (scan-right - 0 '(4 5 6)))
-  (test '(42) (scan-right * 42 '())))
+  (test '(42) (scan-right * 42 '()))
+  (test '(36 30 22 12 0) (scan-right + 0 '(1 2 3 4) '(5 6 7 8))))
+
+(test-group "xscan-right"
+  (test '(36 30 22 12 0) (xscan-right + 0 '(1 2 3 4) '(5 6 7 8))))
+
+(test-group "xfold"
+  (test -10 (xfold - 0 '(1 2 3 4)))
+  (test '((((() 1 5) 2 6) 3 7) 4 8) (xfold list '() '(1 2 3 4) '(5 6 7 8))))
+
+(test-group "xfold-right"
+  (test '((((() 4 8) 3 7) 2 6) 1 5) (xfold-right list '() '(1 2 3 4) '(5 6 7 8)))
+  (test -10 (xfold-right - 0 '(1 2 3 4))))
+
+(test-group "xreduce"
+  (test -8 (xreduce - 0 '(1 2 3 4)))
+  (test #f (xreduce - #f '())))
+
+(test-group "xreduce-right"
+  (test -2 (xreduce-right - 0 '(1 2 3 4)))
+  (test #f (xreduce-right - #f '())))
 
 (test-group "imp"
   (test #t (imp #t #t))