vallog: fold わいいよ fold

2010/07/15

L-99 の01～09を、fold 系手続きを使って書いた例。

L01

view raw L01.scm hosted with ❤ by GitHub

L02

	;; P02 (*) Find the last but one box of a list.
	;; Example:
	;; * (my-but-last '(a b c d))
	;; (C D)

	(use srfi-1)
	(define (my-but-last ls . opt)
	(let-optionals* opt ((failed #f))
	(let/cc hop
	(pair-fold-right (lambda (pr acc)
	(if (not (null? (cdr pr)))
	(hop pr)
	acc))
	failed ls))))

	(my-but-last '(a b c d))
	;; (c d)
	(my-but-last '(c d))
	;; (c d)
	(my-but-last '(d))
	;; #f
	(my-but-last '() '())
	;; ()

view raw L02.scm hosted with ❤ by GitHub

L03

	;; P03 (*) Find the K'th element of a list.
	;; The first element in the list is number 1.
	;; Example:
	;; * (element-at '(a b c d e) 3)
	;; C

	(define (element-at ls n)
	(if (or (< (length ls) n)
	(not (positive? n)))
	(error "out of range")
	(let/cc hop
	(fold (lambda (e acc)
	(if (= acc 1)
	(hop e)
	(- acc 1)))
	n ls))))

	(element-at '(a b c d e) 3)
	;; c
	(element-at '(a b c d e) 0)
	;; error
	(element-at '() 0)
	;; error
	(element-at '(a b c) 5)
	;; error

view raw L03.scm hosted with ❤ by GitHub

L04

	;; P04 (*) Find the number of elements of a list.

	(define (my-length ls)
	(fold (lambda (e acc)
	(+ acc 1))
	0 ls))

	(my-length '(1 2 3 4 5))
	;; 5

view raw L04.scm hosted with ❤ by GitHub

L05

view raw L05.scm hosted with ❤ by GitHub

L07

	;; P07 (**) Flatten a nested list structure.
	;; Transform a list, possibly holding lists as elements into a `flat' list by replacing each list with its elements (recursively).

	;; Example:
	;; * (my-flatten '(a (b (c d) e)))
	;; (A B C D E)

	;; Hint: Use the predefined functions list and append.

	(define (flatten tree)
	(fold (lambda (e acc)
	(append acc
	(if (list? e)
	(flatten e)
	(list e))))
	'() tree))

	(flatten '(a (b (c d) e)))
	;; (a b c d e)
	(flatten '(((a)(b c d))(e (f g))(h i j (((((((k l m (n)))))))))))
	;; (a b c d e f g h i j k l m n)

view raw L07.scm hosted with ❤ by GitHub

L08

	;; P08 (**) Eliminate consecutive duplicates of list elements.
	;; If a list contains repeated elements they should be replaced with a single copy of the element. The order of the elements should not be changed.

	;; Example:
	;; * (compress '(a a a a b c c a a d e e e e))
	;; (A B C A D E)

	(define (compress ls . opt)
	(let-optionals* opt ((ep? equal?))
	(pair-fold
	(lambda (pr acc)
	(let/cc hop
	(append acc
	(if (null? (cdr pr))
	pr
	(if (ep? (car pr)(cadr pr))
	(hop acc)
	(list (car pr)))))))
	'() ls)))


	(compress '(a a a a b c c a a d e e e e))
	;; (a b c a d e)
	(compress '(a b))
	;; (a b)
	(compress '(a))
	;; (a)
	(compress (map (cut cons <> '()) '(a a a a b c c a a d e e e e)) eq?)
	;; ((a) (a) (a) (a) (b) (c) (c) (a) (a) (d) (e) (e) (e) (e))
	(compress (map (cut cons <> '()) '(a a a a b c c a a d e e e e)))
	;; ((a) (b) (c) (a) (d) (e))

view raw L08.scm hosted with ❤ by GitHub

L09

	;; P09 (**) Pack consecutive duplicates of list elements into sublists.
	;; If a list contains repeated elements they should be placed in separate sublists.

	;; Example:
	;; * (pack '(a a a a b c c a a d e e e e))
	;; ((A A A A) (B) (C C) (A A) (D) (E E E E))

	(define (pack ls . opt)
	(let-optionals* opt ((eq? eq?))
	(pair-fold-right
	(lambda (pr acc)
	(apply acons (car pr)
	(if (or (null? acc)
	(not (eq? (car pr)(caar acc))))
	`(() ,acc)
	`(,(car acc),(cdr acc)))))
	'() ls)))

	(pack '(a a a a b c c a a d e e e e))
	;; ((a a a a) (b) (c c) (a a) (d) (e e e e))
	(pack '(1))
	;; ((1))
	(pack '(1 2 3 1 2 3))
	;; ((1) (2) (3) (1) (2) (3))
	(pack '())
	;; ()
	(pack (map (cut cons <> '())
	'(a a a a b c c a a d e e e e)))
	;; (((a)) ((a)) ((a)) ((a)) ((b)) ((c)) ((c)) ((a)) ((a)) ((d)) ((e)) ((e)) ((e)) ((e)))
	(pack (map (cut cons <> '())
	'(a a a a b c c a a d e e e e)) equal?)
	;; (((a) (a) (a) (a)) ((b)) ((c) (c)) ((a) (a)) ((d)) ((e) (e) (e) (e)))

view raw L09.scm hosted with ❤ by GitHub

その他、一般的な再帰や末尾再帰でも書いています。

vallog