[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: SRFI-1's fold is not fold-left!



Hallo again,

I don't know how many people actually use this stuff, but since I have
pressed on the "send" button I have realized that PAIR-FOLD was not 
even trying to do the left-associative pair-fold:

(pair-fold [lambda (x y) 
(cons (reduce + 0 x) y)] 
'() '(1 2 3)) 
-> (3 5 6)

which is ((+ 3) (+ 2 3) (+ 1 2 3)): clearly right-associative 
w.r.t the input list.

BTW, the same as:

(pair-fold-right [lambda (x y) 
  (append y (list (reduce + 0 x)))] 
  '() '(1 2 3)) 
-> (3 5 6)


Attached is the updated patch that behaves as follows:

(pair-fold-left [lambda (y x) 
  (append y (list (reduce + 0 x)))] 
  '() '(1 2 3))
-> (1 3 6)

which is ((+ 1) (+ 1 2) (+ 1 2 3)): clearly left-associative 
w.r.t. the input list.

Hopefully now the implementation should make more sense,

Kind regards,
Pjotr

On Wed, 2012-10-31 at 10:44 +0100, Peter Kourzanov wrote: 
> Dear Manuel, et.al.,
> 
> While translating some OCaml code I have come across the following
> discrepancy. Although it is known, it is worthwhile to mention it, I
> think. The SRFI-1's fold is not actually a fold-left (it is mentioned 
> in passing in SRFI-1 itself that F's args are flipped w.r.t. MIT-Scheme
> and Haskell). 
> 
> To set things straight, I think, it would make sense to add a fold-left
> function to Bigloo (and maybe to the SRFI-1 itself). An example patch is
> attached (fold-left)
> 
> Kind regards,
> Pjotr
> 
> P.S. Also attached is a comparable patch for SLIB.

--- slib/srfi-1.scm	2008-12-08 03:29:50.000000000 +0100
+++ slib/srfi-1.scm	2012-10-31 14:43:00.932721359 +0100
@@ -234,6 +234,13 @@
       z
       (apply fold (cons* f (apply f (append! (map car l) (list z)))
 			 (map cdr l)))))
+
+(define (fold-left f z l1 . l)
+  (set! l (cons l1 l))
+  (if (any null? l)
+      z
+      (apply fold-left (cons* f (apply f (cons z (map car l)))
+			 (map cdr l)))))
 ;;@args kons knil clist1 clist2 ...
 (define (fold-right f z l1 . l)
   (set! l (cons l1 l))
@@ -247,6 +254,18 @@
       z
       (let ((tail (cdr l)))
 	(pair-fold f (f l z) tail))))
+; good pair-fold-left now
+(define (pair-fold-left f z l)		;XXX should be multi-arg
+   (let rec ((lis l)
+	     (rlis #f)
+	     (last #f)
+	     (ans z))
+      (if (null? lis)
+	  ans
+	  (let ((new (list (car lis))))
+	     (if last (set-cdr! last new) (set! rlis new))
+	     (rec (cdr lis) rlis new (f ans rlis))))
+      ))
 ;;@args kons knil clist1 clist2 ...
 (define (pair-fold-right f z l)		;XXX should be multi-arg
   (if (null? l)
@@ -264,6 +283,17 @@
 		       ridentity
 		       (fold f (car list) (cdr list)))))
 	     args))))
+
+(define reduce-left
+  (let ((comlist-reduce reduce-left))
+    (lambda args
+      (apply (if (= 2 (length args))
+		 comlist-reduce
+		 (lambda (f ridentity list)
+		   (if (null? list)
+		       ridentity
+		       (fold-left f (car list) (cdr list)))))
+	     args))))
       
 (define (reduce-right f ridentity list)
   (if (null? list)
# HG changeset patch
# Parent 0929bf975f316a58f867df94e15cc687a4c1e027

diff -r 0929bf975f31 api/srfi1/src/Llib/srfi1.bgl
--- a/api/srfi1/src/Llib/srfi1.bgl	Wed Oct 31 10:26:36 2012 +0100
+++ b/api/srfi1/src/Llib/srfi1.bgl	Wed Oct 31 12:15:37 2012 +0100
@@ -60,10 +60,13 @@
 	   (unfold-right p f g seed . maybe-tail)
 	   (unfold p f g seed . maybe-tail-gen)
 	   (fold kons knil lis1 . lists)
+	   (fold-left kons knil lis1 . lists)
 	   (fold-right kons knil lis1 . lists)
 	   (pair-fold-right f zero lis1 . lists)
+	   (pair-fold-left f zero lis1 . lists)
 	   (pair-fold f zero lis1 . lists)
 	   (reduce f ridentity lis)
+	   (reduce-left f lidentity lis)
 	   (reduce-right f ridentity lis)
 	   (append-map f lis1 . lists)
 	   (append-map! f lis1 . lists)
diff -r 0929bf975f31 api/srfi1/src/Llib/srfi1.srfi
--- a/api/srfi1/src/Llib/srfi1.srfi	Wed Oct 31 10:26:36 2012 +0100
+++ b/api/srfi1/src/Llib/srfi1.srfi	Wed Oct 31 12:15:37 2012 +0100
@@ -835,8 +835,21 @@
       (let recur ((seed seed))
 	(if (p seed) '()
 	    (cons (f seed) (recur (g seed)))))))
-      
 
+; real fold-left (ala Haskell & OCaml)
+(define (fold-left kons knil lis1 . lists)
+  (check-arg procedure? kons fold-left)
+  (if (pair? lists)
+      (let lp ((lists (cons lis1 lists)) (ans knil))	; N-ary case
+	(receive (cars cdrs) (%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)))))))
+
+; fold-left with flipped args (kept for compatibility purposes)
 (define (fold kons knil lis1 . lists)
   (check-arg procedure? kons fold)
   (if (pair? lists)
@@ -875,6 +888,25 @@
       (let recur ((lis lis1))				; Fast path
 	(if (null-list? lis) zero (f lis (recur (cdr lis)))))))
 
+; Correct pair-fold-left now
+(define (pair-fold-left f zero lis1 . lists)
+  (check-arg procedure? f pair-fold-left)
+  (if (pair? lists)
+      (let lp ((lists (cons lis1 lists))
+	       (rlists (list-tabulate (+ 1 (length lists)) (lambda x '())))
+	       (ans zero))	; N-ary case
+	(receive (cars cdrs) (%cars+cdrs lists)
+	  (if (null? cars) ans ; Done.
+	      (let ((rlists (map! (lambda (x y) (append! y (list x))) cars rlists)))
+		 (lp cdrs rlists (apply f ans rlists)))
+	      )))
+	    
+      (let lp ((lis lis1) (rlis '()) (ans zero))	; Fast path
+	(if (null-list? lis) ans
+	    (let ((rlis (append! rlis (list (car lis)))))
+		   (lp (cdr lis) rlis (f ans rlis)))))
+      ))
+
 (define (pair-fold f zero lis1 . lists)
   (check-arg procedure? f pair-fold)
   (if (pair? lists)
@@ -897,6 +929,12 @@
   (if (null-list? lis) ridentity
       (fold f (car lis) (cdr lis))))
 
+; use fold-left rather than fold...
+(define (reduce-left f lidentity lis)
+  (check-arg procedure? f reduce-left)
+  (if (null-list? lis) lidentity
+      (fold-left f (car lis) (cdr lis))))
+
 (define (reduce-right f ridentity lis)
   (check-arg procedure? f reduce-right)
   (if (null-list? lis) ridentity