[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