fold （複数リスト引数）

• vallog: cars+cdrs

scheme を始めた当初から「どうなってんだろう？」と気になっていた複数のリストを引数に取れる fold や map 。
cars+cdrs 同様、カンニングしながら書いてみた。

• http://www.google.co.jp/codesearch/p?hl=ja#xAlgQDHmdnQ/pub/gentoo/distfiles/chicken-2.2.tar.gz%7CWcz_PeVdEwc/chicken-2.2/srfi-1.scm&q=lang:scheme%20%22(define%20(fold%22

	(use srfi-8)
	(define (fold proc init ls . lists)
	(let loop ((lists (cons ls lists))(acc init))
	(receive (cars cdrs)(apply cars+cdrs lists)
	(let ((ans (apply proc (append cars (list acc)))))
	(receive (l1 rest)(car+cdr cdrs)
	(if (null? l1)
	ans
	(loop cdrs ans)))))))
	(fold + 0 (with-module srfi-1 (iota 10 1)))
	;; 55
	(fold * 1 (with-module srfi-1 (iota 5 1)))
	;; 120
	(fold + 0 '(1 2 3 4 5)'(1 2 3 4 5))
	;; 30
	(fold cons '() '(a b c))
	;; (c b a)
	(fold acons '() '(a b c)'(1 2 3))
	;; ((c . 3) (b . 2) (a . 1))
	(with-module srfi-1 (fold acons '() '(a b c)'(1 2 3)))
	;; ((c . 3) (b . 2) (a . 1))

view raw fold.scm hosted with ❤ by GitHub

これはなるほど過ぎる。。
receive が一つ余計かな、というか二つ目の receive のところダメかも？

追記

修正版。複数のリストを渡した時に、リストの要素数が違うとエラーになっていた部分を修正。最も要素数の少ないリストが終わるまで処理を行ないます。

	;; srfi-1::fold
	(use srfi-8) ; receive
	(use srfi-1) ; car+cdr
	(define (cars+cdrs ls . rest-lists)
	(let/cc hop
	(let loop ((lists (cons ls rest-lists)))
	(if (null? lists)
	(values '() '())
	(receive (ls rest-lists)(car+cdr lists)
	(if (null? ls)
	(hop '() '())
	(receive (a d)(car+cdr ls)
	(receive (cars cdrs)(loop rest-lists)
	(values (cons a cars)(cons d cdrs))))))))))
	(define (fold proc init ls . lists)
	(let loop ((lists (cons ls lists))(acc init))
	(receive (cars cdrs)(apply cars+cdrs lists)
	(let ((ans (apply proc (append cars (list acc)))))
	(if (any null? cdrs)
	ans
	(loop cdrs ans))))))
	(fold + 0 (with-module srfi-1 (iota 10 1)))
	;; 55
	(fold * 1 (with-module srfi-1 (iota 5 1)))
	;; 120
	(fold + 0 '(1 2 3 4 5)'(1 2 3 4 5))
	;; 30
	(fold cons '() '(a b c))
	;; (c b a)
	(fold acons '() '(a b c)'(1 2 3))
	;; ((c . 3) (b . 2) (a . 1))
	(with-module srfi-1 (fold acons '() '(a b c)'(1 2 3)))
	;; ((c . 3) (b . 2) (a . 1))
	(fold acons '() '(1 2 3 4 5)'(a b c d))
	;; ((4 . d) (3 . c) (2 . b) (1 . a))
	(fold acons '() '(a b c)'(1 2 3 4 5))
	;; ((c . 3) (b . 2) (a . 1))
	(fold acons '() '(1 2 3)'(a b c d e))

view raw fold-modified.scm hosted with ❤ by GitHub