From b1605ef9a7f21e7caf3d033b5ac7df0b8da5c3fe Mon Sep 17 00:00:00 2001
From: Leah Neukirchen <leah@vuxu.org>
Date: Fri, 18 Nov 2022 19:55:47 +0100
Subject: add xfold, xfold-right, xreduce, xreduce-right, xscan, xscan-right

Make scan, scan-right work with multiple lists.
---
 mew.scm | 101 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 89 insertions(+), 12 deletions(-)

(limited to 'mew.scm')

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 ()
-- 
cgit 1.4.1