append1, append

昨日TLで見かけたので。いろいろ書いてみるつもりでしたが、たいして差のないコードばかりになりました。やはりfold系は、余計なことを考えなくて済むので好きです。
recur, letrec, named-let, cps, let/cc, fold, fold-right など。

	;; append1
	;; fold-right
	(use srfi-1)
	(define (append1 l1 l2)
	(fold-right cons l2 l1))
	(append1 '(1 2 3)'(4 5 6))
	;; fold
	(define (append1 l1 l2)
	(fold cons l2 (reverse l1)))
	(append1 '(1 2 3)'(4 5 6))
	;; again recur
	(define (append1 l1 l2)
	(if (null? l1)
	l2
	(cons (car l1)
	(append1 (cdr l1) l2))))
	(append1 '(1 2 3)'(4 5 6))
	;; again named-let
	(define (append1 l1 l2)
	(let loop ((l l1)
	(acc l2))
	(if (null? l)
	acc
	(cons (car l)
	(loop (cdr l) acc)))))
	(append1 '(1 2 3)'(4 5 6))
	;; again letrec
	(define (append1 l1 l2)
	(letrec
	((rec (lambda (l acc)
	(if (null? l)
	acc
	(cons (car l)
	(rec (cdr l) acc))))))
	(rec l1 l2)))
	(append1 '(1 2 3)'(4 5 6))
	;; again accumulate
	(define (append1 l1 l2)
	(letrec
	((rec (lambda (l acc)
	(if (null? l)
	acc
	(rec (cdr l)(cons (car l)
	acc))))))
	(rec (reverse l1) l2)))
	(append1 '(1 2 3)'(4 5 6))
	;; again cps
	(define (append1 l1 l2)
	(letrec
	((rec/cps (lambda (l seed cont)
	(if (null? l)
	(cont seed)
	(rec/cps (cdr l)
	seed
	(lambda (ls)
	(cont (cons (car l)
	ls))))))))
	(rec l1 l2 identity)))
	(append1 '(1 2 3)'(4 5 6))
	;; again call/cc
	(define (append1 l1 l2)
	(let/cc return
	(let* ((continue #f)
	(l (reverse l1))
	(acc l2))
	(let/cc cont
	(set! continue cont))
	(when (null? l)
	(return acc))
	(set! acc (cons (car l)
	acc))
	(set! l (cdr l))
	(continue '()))))
	(append1 '(1 2 3)'(4 5 6))
	;; append
	(use srfi-1)
	(define (append . l)
	(fold (lambda (e acc)
	(fold-right cons e acc))
	'() l))
	(append '(1 2 3)'(4 5 6)'(7 8 9))
	;; again letrec
	(define (append . l)
	(if (null? l)
	'()
	(letrec
	((a1 (lambda (l acc)
	(if (null? l)
	acc
	(cons (car l)(a1 (cdr l) acc)))))
	(rec (lambda (l)
	(if (null? (cdr l))
	(car l)
	(a1 (car l)(rec (cdr l)))))))
	(rec l))))
	(append '(1 2 3)'(4 5 6)'(7 8 9))

view raw appends.scm hosted with ❤ by GitHub

追記

unfold, unfold-right

	;; again unfold
	;; http://practical-scheme.net/gauche/man/gauche-refj_225.html
	;; (unfold p f g seed tail-gen) ==
	;; (if (p seed)
	;; (tail-gen seed)
	;; (cons (f seed)
	;; (unfold p f g (g seed))))
	(define (append1 l1 l2)
	(unfold null? car cdr l1 (lambda (l)
	l2)))
	;; again unfold-right
	;; http://practical-scheme.net/gauche/man/gauche-refj_225.html
	;; (unfold-right p f g seed tail) ==
	;; (let lp ((seed seed) (lis tail))
	;; (if (p seed)
	;; lis
	;; (lp (g seed) (cons (f seed) lis))))
	(use srfi-1)
	(define (append1 l1 l2)
	(unfold-right null? car cdr (reverse l1) l2))

view raw unfold,unfold-right.scm hosted with ❤ by GitHub