階乗を求めるプログラムです。
階乗の定義 0! = 1 n! = n * (n - 1)!
リスト : 階乗
;;; 再帰
(define (fact n)
(if (zero? n)
1
(* n (fact (- n 1)))))
;;; 末尾再帰
(define (fact1 n)
(define (facti n a)
(if (zero? n)
a
(facti (- n 1) (* a n))))
(facti n 1))
;;; letrec
(define (fact2 n)
(letrec
((facti (lambda (n a)
(if (zero? n)
a
(facti (- n 1) (* a n))))))
(facti n 1)))
;;; named-let
(define (fact3 n)
(let loop ((n n) (a 1))
(if (zero? n)
a
(loop (- n 1) (* a n)))))
gosh[r7rs.user]> (do ((i 0 (+ i 1))) ((> i 10)) (display (fact i)) (newline)) 1 1 2 6 24 120 720 5040 40320 362880 3628800 #t gosh[r7rs.user]> (fact1 10) 3628800 gosh[r7rs.user]> (fact2 10) 3628800 gosh[r7rs.user]> (fact3 10) 3628800 gosh[r7rs.user]> (fact3 20) 2432902008176640000
フィボナッチ関数のプログラムです。
フィボナッチ関数の定義 fibo(0) = 0 fibo(1) = 1 fibo(n) = fibo(n - 1) + fibo(n - 2), n > 1 0, 1, 1, 2, 3, 5, 8, 13 .... という直前の 2 項を足していく数列
リスト : フィボナッチ関数
;;; 二重再帰
(define (fibo n)
(if (< n 2)
n
(+ (fibo (- n 1)) (fibo (- n 2)))))
;;; 末尾再帰
(define (fibo1 n)
(define (fiboi n a b)
(if (zero? n)
a
(fiboi (- n 1) b (+ a b))))
(fiboi n 0 1))
;;; letrec
(define (fibo2 n)
(letrec
((fiboi (lambda (n a b)
(if (zero? n)
a
(fiboi (- n 1) b (+ a b))))))
(fiboi n 0 1)))
;;; named-let
(define (fibo3 n)
(let loop ((n n) (a 0) (b 1))
(if (zero? n)
a
(loop (- n 1) b (+ a b)))))
gosh[r7rs.user]> (do ((i 0 (+ i 1))) ((> i 10)) (display (fibo i)) (newline)) 0 1 1 2 3 5 8 13 21 34 55 #t gosh[r7rs.user]> (fibo1 10) 55 gosh[r7rs.user]> (fibo2 10) 55 gosh[r7rs.user]> (fibo3 10) 55 gosh[r7rs.user]> (fibo3 40) 102334155
基本的なリスト操作のプログラムです。
リスト : リストの操作
;;; 末尾のセルを求める
(define (last-pair xs)
(if (null? (cdr xs))
xs
(last-pair (cdr xs))))
;;; 末尾の要素を求める
(define (last xs) (car (last-pair xs)))
;;; リストの n 番目の要素を求める (R7RS-small の list-ref と同じ)
(define (list-ref1 xs n)
(if (zero? n)
(car xs)
(list-ref1 (cdr xs) (- n 1))))
;;; 先頭から n 個の要素を取り出す (SRFI-1 の take と同じ)
(define (take xs n)
(if (zero? n)
'()
(cons (car xs) (take (cdr xs) (- n 1)))))
;;; 先頭から n 個の要素を取り除く (R7RS-small の list-tail, SRFI-1 の drop と同じ)
(define (drop xs n)
(if (zero? n)
xs
(drop (cdr xs) (- n 1))))
;;; 反転 (R7RS-small の reverse と同じ)
(define (reverse1 xs)
(if (null? xs)
'()
(append (reverse1 (cdr xs)) (list (car xs)))))
;;; 末尾再帰
(define (reverse2 xs)
(let loop ((xs xs) (a '()))
(if (null? xs)
a
(loop (cdr xs) (cons (car xs) a)))))
;;; 破壊的反転 (Gauche の reverse! と同じ)
(define (reverse! xs)
(let loop ((xs xs) (r '()))
(if (null? xs)
r
(let ((x (cdr xs)))
(set-cdr! xs r)
(loop x xs)))))
;;; 連結 (R7RS-small の append と同じ)
(define (append-1 xs ys)
(if (null? xs)
ys
(cons (car xs) (append1 (cdr xs) ys))))
;;; 先頭から連結するので非効率
(define (append1 . args)
(cond
((null? args) '())
((null? (cdr args)) (car args))
(else
(apply append1 (append-1 (car args) (cadr args)) (cddr args)))))
;;; 後ろから連結するので効率的
(define (append2 . args)
(cond
((null? args) '())
((null? (cdr args)) (car args))
((null? (cddr args))
(append-1 (car args) (cadr args)))
(else
(append-1 (car args) (apply append2 (cdr args))))))
;;; 破壊的連結 (Common Lisp の nconc, Gauche の append! と同じ)
(define (nconc-1 xs ys)
(set-cdr! (last-pair xs) ys)
xs)
(define (nconc . args)
(cond
((null? args) '())
((null? (cdr args)) (car args))
(else
(nconc-1 (car args) (apply nconc (cdr args))))))
;;; 探索 (R7RS-small の member, assoc と同じ)
(define member1
(case-lambda
((x xs)
(member1 x xs equal?))
((x xs pred)
(let loop ((xs xs))
(cond
((null? xs) #f)
((pred (car xs) x) xs)
(else
(loop (cdr xs))))))))
(define assoc1
(case-lambda
((x xs)
(assoc1 x xs equal?))
((x xs pred)
(let loop ((xs xs))
(cond
((null? xs) #f)
((pred (caar xs) x) (car xs))
(else
(loop (cdr xs))))))))
;;; リストの生成 (SRFI-1 の iota, list-tabulate と同じ)
(define iota
(case-lambda
((n) (iota n 0 1))
((n start) (iota n start 1))
((n start step)
(if (zero? n)
'()
(cons start (iota (- n 1) (+ start step) step))))))
(define (list-tabulate n proc)
(let loop ((i 0))
(if (= i n)
'()
(cons (proc i) (loop (+ i 1))))))
gosh[r7rs.user]> (last-pair '(a b c d e)) (e) gosh[r7rs.user]> (last '(a b c d e)) e gosh[r7rs.user]> (last-pair '(a)) (a) gosh[r7rs.user]> (last-pair '()) => エラー gosh[r7rs.user]> (list-ref1 '(a b c d e) 0) a gosh[r7rs.user]> (list-ref1 '(a b c d e) 4) e gosh[r7rs.user]> (list-ref1 '(a b c d e) 5) => エラー gosh[r7rs.user]> (take '(a b c d e) 3) (a b c) gosh[r7rs.user]> (take '(a b c d e) 0) () gosh[r7rs.user]> (take '(a b c d e) 5) (a b c d e) gosh[r7rs.user]> (take '(a b c d e) 6) => エラー gosh[r7rs.user]> (drop '(a b c d e) 3) (d e) gosh[r7rs.user]> (drop '(a b c d e) 0) (a b c d e) gosh[r7rs.user]> (drop '(a b c d e) 5) () gosh[r7rs.user]> (drop '(a b c d e) 6) => エラー gosh[r7rs.user]> (reverse1 '(a b c d e)) (e d c b a) gosh[r7rs.user]> (reverse1 '(a)) (a) gosh[r7rs.user]> (reverse1 '()) () gosh[r7rs.user]> (reverse2 '(a b c d e)) (e d c b a) gosh[r7rs.user]> (reverse2 '(a)) (a) gosh[r7rs.user]> (reverse2 '()) () gosh[r7rs.user]> (define a (list 'a 'b 'c 'd 'e)) a gosh[r7rs.user]> a (a b c d e) gosh[r7rs.user]> (reverse! a) (e d c b a) gosh[r7rs.user]> a (a) gosh[r7rs.user]> (append1) () gosh[r7rs.user]> (append1 '(a b c) '(d e f)) (a b c d e f) gosh[r7rs.user]> (append1 '(a b c) '(d e f) '(g h) '(i j k)) (a b c d e f g h i j k) gosh[r7rs.user]> (append1 '(a b c) '(d e f) '() '(g h) '(i j k)) (a b c d e f g h i j k) gosh[r7rs.user]> (append2) () gosh[r7rs.user]> (append2 '(a b c) '(d e f)) (a b c d e f) gosh[r7rs.user]> (append2 '(a b c) '(d e f) '(g h) '(i j k)) (a b c d e f g h i j k) gosh[r7rs.user]> (append2 '(a b c) '(d e f) '() '(g h) '(i j k)) (a b c d e f g h i j k) gosh[r7rs.user]> (nconc) () gosh[r7rs.user]> (define a (list 1 2 3)) a gosh[r7rs.user]> (define b (list 4 5 6)) b gosh[r7rs.user]> (define c (list 7 8 9)) c gosh[r7rs.user]> (nconc a b c) (1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> a (1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> b (4 5 6 7 8 9) gosh[r7rs.user]> c (7 8 9) gosh[r7rs.user]> (member1 'a '(a b c d e)) (a b c d e) gosh[r7rs.user]> (member1 'e '(a b c d e)) (e) gosh[r7rs.user]> (member1 'f '(a b c d e)) #f gosh[r7rs.user]> (member1 '(c d) '((a b) (c d) (e f))) ((c d) (e f)) gosh[r7rs.user]> (member1 '(c d) '((a b) (c d) (e f)) eqv?) #f gosh[r7rs.user]> (assoc1 'c '((a b) (c d) (e f))) (c d) gosh[r7rs.user]> (assoc1 'g '((a b) (c d) (e f))) #f gosh[r7rs.user]> (assoc1 '(e f) '(((a b) 1) ((c d) 2) ((e f) 3))) ((e f) 3) gosh[r7rs.user]> (assoc1 '(e f) '(((a b) 1) ((c d) 2) ((e f) 3)) eqv?) #f gosh[r7rs.user]> (iota 10) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (iota 10 5) (5 6 7 8 9 10 11 12 13 14) gosh[r7rs.user]> (iota 10 1 2) (1 3 5 7 9 11 13 15 17 19) gosh[r7rs.user]> (list-tabulate 10 (lambda (x) (* x x))) (0 1 4 9 16 25 36 49 64 81) gosh[r7rs.user]> (list-tabulate 10 (lambda (x) (* x x x))) (0 1 8 27 64 125 216 343 512 729)
基本的な高階関数 map. remove, fold, fold-right のプログラムです。
リスト : 高階関数
(define (map-1 proc xs)
(if (null? xs)
'()
(cons (proc (car xs)) (map-1 proc (cdr xs)))))
(define (map-n proc xss)
(if (member '() xss)
'()
(cons (apply proc (map-1 car xss))
(map-n proc (map-1 cdr xss)))))
;;; R7RS-samll の map と同じ
(define map1
(case-lambda
((proc xs)
(map-1 proc xs))
((proc xs . args)
(map-n proc (cons xs args)))))
;;; SRFI-1 の remove と同じ
(define (remove pred xs)
(cond
((null? xs) '())
((pred (car xs))
(remove pred (cdr xs)))
(else
(cons (car xs) (remove pred (cdr xs))))))
(define (fold-1 proc a xs)
(if (null? xs)
a
(fold-1 proc (proc a (car xs)) (cdr xs))))
(define (fold-n proc a xss)
(if (member '() xss)
a
(fold-n proc (apply proc a (map-1 car xss)) (map-1 cdr xss))))
;;; SRFI-1 の fold と同じ
(define fold
(case-lambda
((proc a xs)
(fold-1 proc a xs))
((proc a xs . args)
(fold-n proc a (cons xs args)))))
(define (foldr-1 proc a xs)
(if (null? xs)
a
(proc (foldr-1 proc a (cdr xs)) (car xs))))
(define (foldr-n proc a xss)
(if (member '() xss)
a
(apply proc
(foldr-n proc a (map-1 cdr xss))
(map-1 car xss))))
;;; SRFI-1 の fold-right と同じ
(define fold-right
(case-lambda
((proc a xs)
(foldr-1 proc a xs))
((proc a xs . args)
(foldr-n proc a (cons xs args)))))
gosh[r7rs.user]> (map1 (lambda (x) (* x x)) (iota 10)) (0 1 4 9 16 25 36 49 64 81) gosh[r7rs.user]> (map1 cons (iota 10) (iota 10 11)) ((0 . 11) (1 . 12) (2 . 13) (3 . 14) (4 . 15) (5 . 16) (6 . 17) (7 . 18) (8 . 19) (9 . 20)) gosh[r7rs.user]> (map1 list (iota 5) (iota 5 5) (iota 5 10)) ((0 5 10) (1 6 11) (2 7 12) (3 8 13) (4 9 14)) gosh[r7rs.user]> (remove even? (iota 10)) (1 3 5 7 9) gosh[r7rs.user]> (remove odd? (iota 10)) (0 2 4 6 8) gosh[r7rs.user]> (remove odd? (iota 10 1 2)) () gosh[r7rs.user]> (remove even? (iota 10 1 2)) (1 3 5 7 9 11 13 15 17 19) gosh[r7rs.user]> (define (xcons a b) (cons b a)) xcons gosh[r7rs.user]> (fold xcons '() '(a b c d e f)) (f e d c b a) gosh[r7rs.user]> (fold (lambda (a x y) (cons (cons x y) a)) '() '(a b c d e f) '(1 2 3 4 5 6)) ((f . 6) (e . 5) (d . 4) (c . 3) (b . 2) (a . 1)) gosh[r7rs.user]> (fold-right xcons '() '(a b c d e f)) (a b c d e f) gosh[r7rs.user]> (fold-right (lambda (a x y) (cons (cons x y) a)) '() '(a b c d e f) '(1 2 3 4 5 6)) ((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))
リストのソートとマージを行うプログラムです。
リスト : ソートとマージ
;;; 挿入ソート
(define (insert-element x xs pred)
(cond
((null? xs) (list x))
((pred x (car xs)) (cons x xs))
(else
(cons (car xs) (insert-element x (cdr xs) pred)))))
(define (insert-sort xs pred)
(if (null? xs)
'()
(insert-element (car xs) (insert-sort (cdr xs) pred) pred)))
;;; リストの分割
(define (partition pred xs)
(if (null? xs)
(values '() '())
(let-values (((a b) (partition pred (cdr xs))))
(if (pred (car xs))
(values (cons (car xs) a) b)
(values a (cons (car xs) b))))))
;;; クイックソート
(define (quick-sort xs pred)
(if (null? xs)
'()
(let-values (((a b) (partition (lambda (x) (pred x (car xs))) (cdr xs))))
(append (quick-sort a pred)
(cons (car xs) (quick-sort b pred))))))
;;; リストのマージ
(define (merge-list xs ys pred)
(cond
((null? xs) ys)
((null? ys) xs)
((pred (car xs) (car ys))
(cons (car xs) (merge-list (cdr xs) ys pred)))
(else
(cons (car ys) (merge-list xs (cdr ys) pred)))))
;;; マージソート
(define (merge-sort xs n pred)
(cond ((= n 1) (list (car xs)))
((= n 2)
(let ((x (car xs)) (y (cadr xs)))
(if (pred x y) (list x y) (list y x))))
(else
(let ((m (quotient n 2)))
(merge-list
(merge-sort xs m pred)
(merge-sort (list-tail xs m) (- n m) pred)
pred)))))
gosh[r7rs.user]> (insert-sort '(5 6 4 7 3 8 2 9 1 0) <) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (insert-sort '(9 8 7 6 5 4 3 2 1 0) <) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (insert-sort '(0 1 2 3 4 5 6 7 8 9) <) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (partition even? (iota 10)) (0 2 4 6 8) (1 3 5 7 9) gosh[r7rs.user]> (partition odd? (iota 10)) (1 3 5 7 9) (0 2 4 6 8) gosh[r7rs.user]> (quick-sort '(5 6 4 7 3 8 2 9 1 0) <) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (quick-sort '(9 8 7 6 5 4 3 2 1 0) <) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (quick-sort '(0 1 2 3 4 5 6 7 8 9) <) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (merge-list '(1 3 5 7 9) '(0 2 4 6 8) <) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (merge-sort '(5 6 4 7 3 8 2 9 1 0) 10 <) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (merge-sort '(9 8 7 6 5 4 3 2 1 0) 10 <) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (merge-sort '(0 1 2 3 4 5 6 7 8 9) 10 <) (0 1 2 3 4 5 6 7 8 9)
順列を生成するプログラムです。
リスト : 順列の生成
;;; 要素の選択
(define (select xs)
(let ((z (car xs)) (zs (cdr xs)))
(if (null? zs)
(list (cons z '()))
(cons (cons z zs)
(map (lambda (ys) (cons (car ys) (cons z (cdr ys))))
(select zs))))))
;;; 平坦化
(define (flatmap proc xs)
(apply append (map proc xs)))
;;; 順列の生成
(define (permutation n xs)
(if (zero? n)
'(())
(flatmap
(lambda (ys)
(map (lambda (zs) (cons (car ys) zs))
(permutation (- n 1) (cdr ys))))
(select xs))))
gosh[r7rs.user]> (permutation 4 '(a b c d)) ((a b c d) (a b d c) (a c b d) (a c d b) (a d b c) (a d c b) (b a c d) (b a d c) (b c a d) (b c d a) (b d a c) (b d c a) (c a b d) (c a d b) (c b a d) (c b d a) (c d a b) (c d b a) (d a b c) (d a c b) (d b a c) (d b c a) (d c a b) (d c b a)) gosh[r7rs.user]> (permutation 3 '(a b c d)) ((a b c) (a b d) (a c b) (a c d) (a d b) (a d c) (b a c) (b a d) (b c a) (b c d) (b d a) (b d c) (c a b) (c a d) (c b a) (c b d) (c d a) (c d b) (d a b) (d a c) (d b a) (d b c) (d c a) (d c b)) gosh[r7rs.user]> (permutation 2 '(a b c d)) ((a b) (a c) (a d) (b a) (b c) (b d) (c a) (c b) (c d) (d a) (d b) (d c))
組み合わせの数を求めるプログラムと、組み合わせを生成するプログラムです。
リスト : 組み合わせ
;;; 組み合わせの数
(define (combination-number n r)
(if (or (= n r) (zero? r))
1
(/ (* (combination-number n (- r 1)) (+ (- n r) 1)) r)))
;;; パスカルの三角形
(define (pascal n)
(let loop ((n n) (buff '(1)))
(when
(positive? n)
(display buff)
(newline)
(loop (- n 1) (cons 1 (fold (lambda (a x y) (cons (+ x y) a)) '() buff (cons 0 buff)))))))
;;; 組み合わせの生成
(define (combination r xs)
(cond
((zero? r) '(()))
((null? xs) '())
(else
(append (map (lambda (ys) (cons (car xs) ys))
(combination (- r 1) (cdr xs)))
(combination r (cdr xs))))))
gosh[r7rs.user]> (combination-number 5 3) 10 gosh[r7rs.user]> (combination-number 10 5) 252 gosh[r7rs.user]> (combination-number 20 10) 184756 gosh[r7rs.user]> (combination-number 30 15) 155117520 gosh[r7rs.user]> (combination-number 50 25) 126410606437752 gosh[r7rs.user]> (pascal 12) (1) (1 1) (1 2 1) (1 3 3 1) (1 4 6 4 1) (1 5 10 10 5 1) (1 6 15 20 15 6 1) (1 7 21 35 35 21 7 1) (1 8 28 56 70 56 28 8 1) (1 9 36 84 126 126 84 36 9 1) (1 10 45 120 210 252 210 120 45 10 1) (1 11 55 165 330 462 462 330 165 55 11 1) gosh[r7rs.user]> (combination 2 '(a b c d e)) ((a b) (a c) (a d) (a e) (b c) (b d) (b e) (c d) (c e) (d e)) gosh[r7rs.user]> (combination 3 '(a b c d e)) ((a b c) (a b d) (a b e) (a c d) (a c e) (a d e) (b c d) (b c e) (b d e) (c d e)) gosh[r7rs.user]> (combination 4 '(a b c d e)) ((a b c d) (a b c e) (a b d e) (a c d e) (b c d e))
マスターマインド (master mind) は異なる 4 つの数字を当てるゲームです。コンピュータは 0 から 9 までの中から重複しないように数字を 4 つ選びます。私たちは数字だけではなく、その位置も当てなくてはいけません。数字は合っているが位置が間違っている個数を cows で表し、数字も位置も合っている個数を bulls で表します。つまり、bulls が 4 になると正解というわけです。ゲームの進行状況を下図に示します。
6 2 8 1
------------------------------
1. 0 1 2 3 : bulls 0 : cows 2
2. 1 0 4 5 : bulls 0 : cows 1
3. 2 3 5 6 : bulls 0 : cows 2
4. 3 2 7 4 : bulls 1 : cows 0
5. 3 6 0 8 : bulls 0 : cows 2
6. 6 2 8 1 : bulls 4 : cows 0 ***** 正解 *****
図 : マスターマインドの動作例
コンピュータが決めた数字は 6 2 8 1 です。プレーヤーは、最初に 0 1 2 3 を入力しました。0 と 3 は 6 2 8 1 に含まれていません。1 と 2 は 6 2 8 1 の中にあるのですが、位置が異なっているので、cows が 2 となります。この場合の bulls は 0 です。あとは bulls が 4 になるように数字を選んで入力していきます。4 番目の入力では、2 の位置が合っているので bulls は 1 となります。この例では 6 回で正解となりました。
リスト : マスターマインドの解法
;;; bulls を数える (fold は 高階関数 で作成したもの)
(define (count-bulls xs ys)
(fold (lambda (a x y) (if (= x y) (+ a 1) a)) 0 xs ys))
;;; 同じ数字を数える
(define (count-same-number xs ys)
(fold (lambda (a x) (if (memv x ys) (+ a 1) a)) 0 xs))
;;; 今までの質問と矛盾しないか
(define (check-query code qs)
(let loop ((qs qs))
(if (null? qs)
#t
(let* ((query (car qs))
(bulls (count-bulls code (car query)))
(cows (- (count-same-number code (car query)) bulls)))
(if (and (= bulls (cadr query)) (= cows (caddr query)))
(loop (cdr qs))
#f)))))
(define (print-answer qs)
(let loop ((n 1) (qs qs))
(cond
((null? qs) #t)
(else
(display n) (display ": ")
(display (car qs))
(newline)
(loop (+ n 1) (cdr qs))))))
(define (mastermind answer)
(let loop ((cs (permutation 4 (iota 10)))
(qs '()))
(cond
((null? cs) #f)
((check-query (car cs) qs)
(let* ((bulls (count-bulls answer (car cs)))
(cows (- (count-same-number answer (car cs)) bulls))
(q (list (car cs) bulls cows)))
(if (= bulls 4)
(print-answer (reverse (cons q qs)))
(loop (cdr cs) (cons q qs)))))
(else
(loop (cdr cs) qs)))))
gosh[r7rs.user]> (mastermind '(9 8 7 6)) 1: ((0 1 2 3) 0 0) 2: ((4 5 6 7) 0 2) 3: ((5 4 8 9) 0 2) 4: ((6 7 9 8) 0 4) 5: ((8 9 7 6) 2 2) 6: ((9 8 7 6) 4 0) #t gosh[r7rs.user]> (mastermind '(9 4 3 1)) 1: ((0 1 2 3) 0 2) 2: ((1 0 4 5) 0 2) 3: ((2 3 5 4) 0 2) 4: ((3 4 0 6) 1 1) 5: ((3 5 6 1) 1 1) 6: ((6 5 0 2) 0 0) 7: ((7 4 3 1) 3 0) 8: ((8 4 3 1) 3 0) 9: ((9 4 3 1) 4 0) #t gosh[r7rs.user]> (mastermind '(5 2 9 3)) 1: ((0 1 2 3) 1 1) 2: ((0 2 4 5) 1 1) 3: ((0 3 5 6) 0 2) 4: ((1 5 4 3) 1 1) 5: ((1 6 2 5) 0 2) 6: ((4 2 6 3) 2 0) 7: ((5 2 7 3) 3 0) 8: ((5 2 8 3) 3 0) 9: ((5 2 9 3) 4 0) #t
;;;
;;; junk1.scm : Scheme Junk Scripts 1 (R7RS-small 対応版)
;;;
;;; Copyright (C) 2006-2021 Makoto Hiroi
;;;
(import (scheme base) (scheme cxr) (scheme write))
;;;
;;; 階乗
;;;
;;; 再帰
(define (fact n)
(if (zero? n)
1
(* n (fact (- n 1)))))
;;; 末尾再帰
(define (fact1 n)
(define (facti n a)
(if (zero? n)
a
(facti (- n 1) (* a n))))
(facti n 1))
;;; letrec
(define (fact2 n)
(letrec
((facti (lambda (n a)
(if (zero? n)
a
(facti (- n 1) (* a n))))))
(facti n 1)))
;;; named-let
(define (fact3 n)
(let loop ((n n) (a 1))
(if (zero? n)
a
(loop (- n 1) (* a n)))))
;;;
;;; フィボナッチ関数
;;;
(define (fibo n)
(if (< n 2)
n
(+ (fibo (- n 1)) (fibo (- n 2)))))
;;; 末尾再帰
(define (fibo1 n)
(define (fiboi n a b)
(if (zero? n)
a
(fiboi (- n 1) b (+ a b))))
(fiboi n 0 1))
;;; letrec
(define (fibo2 n)
(letrec
((fiboi (lambda (n a b)
(if (zero? n)
a
(fiboi (- n 1) b (+ a b))))))
(fiboi n 0 1)))
;;; named-let
(define (fibo3 n)
(let loop ((n n) (a 0) (b 1))
(if (zero? n)
a
(loop (- n 1) b (+ a b)))))
;;;
;;; リスト操作
;;;
;;; 末尾のセルを求める
(define (last-pair xs)
(if (null? (cdr xs))
xs
(last-pair (cdr xs))))
;;; 末尾の要素を求める
(define (last xs) (car (last-pair xs)))
;;; リストの n 番目の要素を求める
(define (list-ref1 xs n)
(if (zero? n)
(car xs)
(list-ref1 (cdr xs) (- n 1))))
;;; 先頭から n 個の要素を取り出す
(define (take xs n)
(if (zero? n)
'()
(cons (car xs) (take (cdr xs) (- n 1)))))
;;; 先頭から n 個の要素を取り除く (R7RS-samll の list-tail と同じ)
(define (drop xs n)
(if (zero? n)
xs
(drop (cdr xs) (- n 1))))
;;; 反転 (R7RS-samll の reverse と同じ)
(define (reverse1 xs)
(if (null? xs)
'()
(append (reverse1 (cdr xs)) (list (car xs)))))
;;; 末尾再帰
(define (reverse2 xs)
(let loop ((xs xs) (a '()))
(if (null? xs)
a
(loop (cdr xs) (cons (car xs) a)))))
;;; 破壊的反転 (Gauche の reverse! と同じ)
(define (reverse! xs)
(let loop ((xs xs) (r '()))
(if (null? xs)
r
(let ((x (cdr xs)))
(set-cdr! xs r)
(loop x xs)))))
;;; 連結 (R7RS-small の append と同じ)
(define (append-1 xs ys)
(if (null? xs)
ys
(cons (car xs) (append1 (cdr xs) ys))))
;;; 先頭から連結するので非効率
(define (append1 . args)
(cond
((null? args) '())
((null? (cdr args)) (car args))
(else
(apply append1 (append-1 (car args) (cadr args)) (cddr args)))))
;;; 後ろから連結するので効率的
(define (append2 . args)
(cond
((null? args) '())
((null? (cdr args)) (car args))
((null? (cddr args))
(append-1 (car args) (cadr args)))
(else
(append-1 (car args) (apply append2 (cdr args))))))
;;; 破壊的連結 (Common Lisp の nconc, Gauche の append! と同じ)
(define (nconc-1 xs ys)
(set-cdr! (last-pair xs) ys)
xs)
(define (nconc . args)
(cond
((null? args) '())
((null? (cdr args)) (car args))
(else
(nconc-1 (car args) (apply nconc (cdr args))))))
;;; 探索 (R7RS-small の member, assoc と同じ)
(define member1
(case-lambda
((x xs)
(member1 x xs equal?))
((x xs pred)
(let loop ((xs xs))
(cond
((null? xs) #f)
((pred (car xs) x) xs)
(else
(loop (cdr xs))))))))
(define assoc1
(case-lambda
((x xs)
(assoc1 x xs equal?))
((x xs pred)
(let loop ((xs xs))
(cond
((null? xs) #f)
((pred (caar xs) x) (car xs))
(else
(loop (cdr xs))))))))
;;; リストの生成
;;; SRFI-1 の iota と同じ)
(define iota
(case-lambda
((n) (iota n 0 1))
((n start) (iota n start 1))
((n start step)
(if (zero? n)
'()
(cons start (iota (- n 1) (+ start step) step))))))
;;; SRFI-1 の list-tabulate と同じ
(define (list-tabulate n proc)
(let loop ((i 0))
(if (= i n)
'()
(cons (proc i) (loop (+ i 1))))))
;;;
;;; 高階関数
;;;
(define (map-1 proc xs)
(if (null? xs)
'()
(cons (proc (car xs)) (map-1 proc (cdr xs)))))
(define (map-n proc xss)
(if (member '() xss)
'()
(cons (apply proc (map-1 car xss))
(map-n proc (map-1 cdr xss)))))
;;; R7RS-samll の map と同じ
(define map1
(case-lambda
((proc xs)
(map-1 proc xs))
((proc xs . args)
(map-n proc (cons xs args)))))
;;; SRFI-1 の remove と同じ
(define (remove pred xs)
(cond
((null? xs) '())
((pred (car xs))
(remove pred (cdr xs)))
(else
(cons (car xs) (remove pred (cdr xs))))))
(define (fold-1 proc a xs)
(if (null? xs)
a
(fold-1 proc (proc a (car xs)) (cdr xs))))
(define (fold-n proc a xss)
(if (member '() xss)
a
(fold-n proc (apply proc a (map-1 car xss)) (map-1 cdr xss))))
;;; SRFI-1 の fold と同じ
(define fold
(case-lambda
((proc a xs)
(fold-1 proc a xs))
((proc a xs . args)
(fold-n proc a (cons xs args)))))
(define (foldr-1 proc a xs)
(if (null? xs)
a
(proc (foldr-1 proc a (cdr xs)) (car xs))))
(define (foldr-n proc a xss)
(if (member '() xss)
a
(apply proc
(foldr-n proc a (map-1 cdr xss))
(map-1 car xss))))
;;; SRFI-1 の fold-right と同じ
(define fold-right
(case-lambda
((proc a xs)
(foldr-1 proc a xs))
((proc a xs . args)
(foldr-n proc a (cons xs args)))))
;;;
;;; ソート
;;;
;;; 挿入ソート
(define (insert-element x xs pred)
(cond
((null? xs) (list x))
((pred x (car xs)) (cons x xs))
(else
(cons (car xs) (insert-element x (cdr xs) pred)))))
(define (insert-sort xs pred)
(if (null? xs)
'()
(insert-element (car xs) (insert-sort (cdr xs) pred) pred)))
;;; リストの分割
(define (partition pred xs)
(if (null? xs)
(values '() '())
(let-values (((a b) (partition pred (cdr xs))))
(if (pred (car xs))
(values (cons (car xs) a) b)
(values a (cons (car xs) b))))))
;;; クイックソート
(define (quick-sort xs pred)
(if (null? xs)
'()
(let-values (((a b) (partition (lambda (x) (pred x (car xs))) (cdr xs))))
(append (quick-sort a pred)
(cons (car xs) (quick-sort b pred))))))
;;; リストのマージ
(define (merge-list xs ys pred)
(cond
((null? xs) ys)
((null? ys) xs)
((pred (car xs) (car ys))
(cons (car xs) (merge-list (cdr xs) ys pred)))
(else
(cons (car ys) (merge-list xs (cdr ys) pred)))))
;;; マージソート
(define (merge-sort xs n pred)
(cond ((= n 1) (list (car xs)))
((= n 2)
(let ((x (car xs)) (y (cadr xs)))
(if (pred x y) (list x y) (list y x))))
(else
(let ((m (quotient n 2)))
(merge-list
(merge-sort xs m pred)
(merge-sort (list-tail xs m) (- n m) pred)
pred)))))
;;;
;;; 順列と組み合わせ
;;;
;;; 組み合わせの数
(define (combination-number n r)
(if (or (= n r) (zero? r))
1
(/ (* (combination-number n (- r 1)) (+ (- n r) 1)) r)))
;;; パスカルの三角形
(define (pascal n)
(let loop ((n n) (buff '(1)))
(when
(positive? n)
(display buff)
(newline)
(loop (- n 1) (cons 1 (fold (lambda (a x y) (cons (+ x y) a)) '() buff (cons 0 buff)))))))
;;; 組み合わせの生成
(define (combination r xs)
(cond
((zero? r) '(()))
((null? xs) '())
(else
(append (map (lambda (ys) (cons (car xs) ys))
(combination (- r 1) (cdr xs)))
(combination r (cdr xs))))))
;;; 要素の選択
(define (select xs)
(let ((z (car xs)) (zs (cdr xs)))
(if (null? zs)
(list (cons z '()))
(cons (cons z zs)
(map (lambda (ys) (cons (car ys) (cons z (cdr ys))))
(select zs))))))
;;; 平坦化
(define (flatmap proc xs)
(apply append (map proc xs)))
;;; 順列の生成
(define (permutation n xs)
(if (zero? n)
'(())
(flatmap
(lambda (ys)
(map (lambda (zs) (cons (car ys) zs))
(permutation (- n 1) (cdr ys))))
(select xs))))
;;;
;;; マスターマインドの解法
;;;
;;; bulls を数える
(define (count-bulls xs ys)
(fold (lambda (a x y) (if (= x y) (+ a 1) a)) 0 xs ys))
;;; 同じ数字を数える
(define (count-same-number xs ys)
(fold (lambda (a x) (if (memv x ys) (+ a 1) a)) 0 xs))
;;; 今までの質問と矛盾しないか
(define (check-query code qs)
(let loop ((qs qs))
(if (null? qs)
#t
(let* ((query (car qs))
(bulls (count-bulls code (car query)))
(cows (- (count-same-number code (car query)) bulls)))
(if (and (= bulls (cadr query)) (= cows (caddr query)))
(loop (cdr qs))
#f)))))
(define (print-answer qs)
(let loop ((n 1) (qs qs))
(cond
((null? qs) #t)
(else
(display n) (display ": ")
(display (car qs))
(newline)
(loop (+ n 1) (cdr qs))))))
(define (mastermind answer)
(let loop ((cs (permutation 4 (iota 10)))
(qs '()))
(cond
((null? cs) #f)
((check-query (car cs) qs)
(let* ((bulls (count-bulls answer (car cs)))
(cows (- (count-same-number answer (car cs)) bulls))
(q (list (car cs) bulls cows)))
(if (= bulls 4)
(print-answer (reverse (cons q qs)))
(loop (cdr cs) (cons q qs)))))
(else
(loop (cdr cs) qs)))))