ISLisp 用の簡単な練習問題です。拙作のページ「簡単なプログラム」と重複する問題もありますが、あしからずご了承くださいませ。
次に示す関数を定義してください。
割り算は quotient を使います。結果は浮動小数点数になります。
次に示す関数を定義してください。
ISLisp の比較演算子は Common Lisp とは違って引数は 2 個だけです。
階乗を計算する関数を再帰呼び出しを使って定義してください。
フィボナッチ数を計算する関数を再帰呼び出しを使って定義してください。
フィボナッチ数は 0, 1, 1, 2, 3, 5, 8, 13 .... という直前の 2 項を足していく数列です。
累乗 xn を計算する関数を再帰呼び出しを使って定義してください。プログラムを簡単にするため、n は正の整数とします。
リストから要素を取り出す関数を定義してください。
リスト xs に cdr を n 回適用する関数 nthcdr n xs を再帰呼び出しを使って定義してください。
リストの n 番目の要素を取り出す関数 nth x xs を定義してください。
リストの長さを求める関数 my-length xs を再帰呼び出しを使って定義してください。
リスト xs, ys を連結する関数 my-append xs ys を再帰呼び出しを使って定義してください。
リスト : 問題１の解答例 (defun 1+ (n) (+ n 1)) (defun 1- (n) (- n 1)) (defun square (n) (* n n)) (defun cubic (n) (* n n n)) (defun half (n) (quotient n 2)) (defun medium (n m) (half (+ n m))) (defun square-medium (n m) (medium (square n) (square m)))
> (1+ 1) 2 > (1+ 0.5) 1.5 > (1- 1) 0 > (1- 0.5) -0.5 > (square 2) 4 > (square 1.111111) 1.234567654321 > (cubic 2) 8 > (cubic 1.1111111) 1.37174207133059 > (half 2) 1 > (half 1.5) 0.75 > (medium 2 4) 3 > (medium 2 3) 2.5 > (square-medium 2 3) 6.5 > (square-medium 1.5 2.5) 4.25
リスト : 問題２の解答例
(defun zerop (n) (= n 0))
(defun plusp (n) (< 0 n))
(defun minusp (n) (< n 0))
(defun sign (n)
(if (zerop n) ; cond を使ってもよい
0
(if (plusp n) 1 -1)))
(defun evenp (n) (zerop (mod n 2)))
(defun oddp (n) (not (evenp n)))
(defun between (n low high)
(and (<= low n) (<= n high)))
> (zerop 0) T > (zerop 0.0) T > (zerop 1) NIL > (plusp 10) T > (plusp 0) NIL > (plusp -1) NIL > (minusp -1) T > (minusp 0) NIL > (minusp 1) NIL > (sign 100) 1 > (sign 0) 0 > (sign -100) -1 > (evenp 100) T > (evenp 99) NIL > (oddp 99) T > (oddp 100) NIL > (between 5 1 10) T > (between 0 1 10) NIL > (between 100 1 10) NIL
リスト : 階乗
(defun fact (n)
(if (zerop n)
1
(* n (fact (1- n)))))
;; 末尾再帰
(defun fact-tail (n acc)
(if (zerop n)
acc
(fact-tail (1- n) (* acc n))))
> (fact 10) 3628800 > (fact 20) 2432902008176640000 > (fact-tail 10 1) 3628800 > (fact-tail 20 1) 2432902008176640000
fact-tail は局所関数を定義する labels を使って書き直すことができます。興味のある方は挑戦してみてください。
リスト : フィボナッチ数
(defun fibo (n)
(if (< n 2)
n
(+ (fibo (1- n)) (fibo (- n 2)))))
;; 末尾再帰
(defun fibo-tail (n a b)
(if (zerop n)
a
(fibo-tail (1- n) b (+ a b))))
> (fibo 10) 55 > (fibo 20) 6765 > (fibo-tail 10 0 1) 55 > (fibo-tail 20 0 1) 6765 > (fibo-tail 40 0 1) 102334155
fibo-tail は局所関数を定義する labels を使って書き直すことができます。興味のある方は挑戦してみてください。
リスト : 累乗
(defun power (x n)
(if (zerop n)
1
(* x (power x (1- n)))))
;; 末尾再帰
(defun power-tail (x n acc)
(if (zerop n)
acc
(power-tail x (1- n) (* acc x))))
;; 高速版
(defun power-fast (x n)
(cond ((zerop n) 1)
((= n 1) x)
(t (let ((z (power-fast x (div n 2))))
(if (oddp n)
(* x z z)
(* z z))))))
> (power 2 32) 4294967296 > (power-tail 2 32 1) 4294967296 > (power-fast 2 32) 4294967296 > (power-fast 2 64) 18446744073709551616
高速版の説明は拙作のページ「Scheme Programming: Scheme の基礎知識 (その４)」をお読みくださいませ。
リスト : リストの要素を取り出す (defun first (xs) (car xs)) (defun second (xs) (car (cdr xs))) (defun third (xs) (car (cdr (cdr xs)))) (defun fourth (xs) (car (cdr (cdr (cdr xs))))) (defun fifth (xs) (car (cdr (cdr (cdr (cdr xs))))))
> (first '(a b c d e)) A > (second '(a b c d e)) B > (third '(a b c d e)) C > (fourth '(a b c d e)) D > (fifth '(a b c d e)) E
ISLisp には cXXr, cXXXr, cXXXXr などの関数は用意されていません。
リスト : リストに cdr を n 回適用する
(defun nthcdr (n xs)
(if (zerop n)
xs
(nthcdr (1- n) (cdr xs))))
> (nthcdr 0 '(a b c d e)) (A B C D E) > (nthcdr 3 '(a b c d e)) (D E) > (nthcdr 5 '(a b c d e)) NIL
nthcdr を使うと third, fourth, fifth などは簡単に定義することができます。
リスト : リスト xs の n 番目の要素を取り出す (defun nth (n xs) (car (nthcdr n xs)))
> (nth 0 '(a b c d e)) A > (nth 3 '(a b c d e)) D > (nth 4 '(a b c d e)) E
nth も nthcdr を使うと簡単に定義することができます。
リスト : リストの長さを求める
(defun my-length (xs)
(if (null xs)
0
(1+ (my-length (cdr xs)))))
;; 末尾再帰
(defun my-length-tail (xs n)
(if (null xs)
n
(my-length-tail (cdr xs) (1+ n))))
> (my-length nil) 0 > (my-length '(a b c d e)) 5 > (my-length-tail nil 0) 0 > (my-length-tail '(a b c d e) 0) 5
my-length-tail は局所関数を定義する labels を使って書き直すことができます。興味のある方は挑戦してみてください。
リスト : リストの連結
(defun my-append (xs ys)
(if (null xs)
ys
(cons (car xs) (my-append (cdr xs) ys))))
> (my-append nil '(a b c)) (A B C) > (my-append '(a b c) nil) (A B C) > (my-append '(a b c) '(d e f g)) (A B C D E F G)
リスト xs を反転する関数 my-reverse xs を再帰呼び出しを使って定義してください。
リスト xs の末尾から n 個の要素を取り除く関数 butlast を定義してください。
リスト xs から x と等しい要素を探索する関数 my-member を定義してください。等値の判定には述語 eql を使ってください。返り値は関数 member と同じです。
リスト xs の n 番目に x を挿入する関数 insert-at n x xs を定義してください。なお、n がリストの長さ以上の場合は末尾に追加するものとします。
リスト xs の n 番目の要素を削除する関数 remove-at n xs を定義してください。
n 個の要素 x を格納したリストを生成する関数 make-list n x と、リスト xs をコピーする関数 copy-list を定義してください。
リスト xs の要素の総和を求める関数 sum xs と、すべての要素を乗算する関数 product xs を再帰呼び出しを使って定義してください。
リスト xs から最大値を求める maximum xs と最小値を求める minimum xs を再帰呼び出しを使って定義してください。
次に示す連想リスト (alist) を操作する関数を定義してください。
リスト xs を挿入ソートする関数 insert-sort xs を定義してください。
リスト : リストの反転
(defun my-reverse (xs)
(if (null xs)
nil
(append (my-reverse (cdr xs)) (list (car xs))))) ; append を使っているので効率が悪い
;; 末尾再帰
(defun my-reverse-tail (xs ys)
(if (null xs)
ys
(my-reverse-tail (cdr xs) (cons (car xs) ys))))
> (my-reverse nil) NIL > (my-reverse '(a)) (A) > (my-reverse '(a b c d e)) (E D C B A) > (my-reverse-tail nil nil) NIL > (my-reverse-tail '(a) nil) (A) > (my-reverse-tail '(a b c d e) nil) (E D C B A)
my-reverse-tail は局所関数を定義する labels を使って書き直すことができます。興味のある方は挑戦してみてください。
リスト : リストから末尾 n 個の要素を取り除く (defun butlast (xs n) (nreverse (nthcdr n (reverse xs))))
> (butlast '(a b c d e) 1) (A B C D) > (butlast '(a b c d e) 3) (A B) > (butlast '(a b c d e) 5) NIL
butlast は reverse を使うと簡単です。リストを反転して先頭から n 個の要素を取り除き、それを nreverse で反転します。nreverse はリストを破壊的に反転するので、新しいコンスセルを使うことはありません。
リスト : リストに x が含まれているか
(defun my-member (x xs)
(if (or (null xs) (eql x (car xs)))
xs
(my-member x (cdr xs))))
> (my-member 'a '(a b c d e)) (A B C D E) > (my-member 'e '(a b c d e)) (E) > (my-member 'f '(a b c d e)) NIL
リスト : リストの n 番目に x を挿入する
(defun insert-at (n x xs)
(if (or (null xs) (= n 0))
(cons x xs)
(cons (car xs) (insert-at (- n 1) x (cdr xs)))))
> (insert-at 0 'x '(a b c d e)) (X A B C D E) > (insert-at 3 'x '(a b c d e)) (A B C X D E) > (insert-at 5 'x '(a b c d e)) (A B C D E X)
リスト : リストの n 番目の要素を削除する
(defun remove-at (n xs)
(cond ((null xs) nil)
((= n 0) (cdr xs))
(t (cons (car xs) (remove-at (- n 1) (cdr xs))))))
> (remove-at 0 '(a b c d e)) (B C D E) > (remove-at 3 '(a b c d e)) (A B C E) > (remove-at 4 '(a b c d e)) (A B C D) > (remove-at 5 '(a b c d e)) (A B C D E)
リスト : make-list と copy-list
(defun make-list (n x)
(if (zerop n)
nil
(cons x (make-list (1- n) x))))
;; 末尾再帰
(defun make-list-tail (n x ys)
(if (zerop n)
ys
(make-list-tail (1- n) x (cons x ys))))
(defun copy-list (xs)
(if (null xs)
nil
(cons (car xs) (copy-list (cdr xs)))))
;; 末尾再帰
(defun copy-list-tail (xs ys)
(if (null xs)
(nreverse ys)
(copy-list-tail (cdr xs) (cons (car xs) ys))))
> (make-list 10 'a) (A A A A A A A A A A) > (make-list-tail 10 'b nil) (B B B B B B B B B B) > (copy-list '(a b c d e)) (A B C D E) > (copy-list-tail '(a b c d e) nil) (A B C D E)
copy-list-tail は累積変数 ys に要素を追加していき、最後に nreverse で反転することでリストをコピーしています。nreverse をしないと、逆順のリストを生成することに注意してください。
リスト : sum と product
(defun sum (xs)
(if (null xs)
0
(+ (car xs) (sum (cdr xs)))))
;; 末尾再帰
(defun sum-tail (xs acc)
(if (null xs)
acc
(sum-tail (cdr xs) (+ (car xs) acc))))
(defun product (xs)
(if (null xs)
1
(* (car xs) (product (cdr xs)))))
;; 末尾再帰
(defun product-tail (xs acc)
(if (null xs)
acc
(product-tail (cdr xs) (* (car xs) acc))))
> (sum '(1 2 3 4 5 6 7 8 9 10)) 55 > (sum-tail '(1 2 3 4 5 6 7 8 9 10) 0) 55 > (product '(1 2 3 4 5 6 7 8 9 10)) 3628800 > (product-tail '(1 2 3 4 5 6 7 8 9 10) 1) 3628800 > (apply #'+ '(1 2 3 4 5 6 7 8 9 10)) 55 > (apply #'* '(1 2 3 4 5 6 7 8 9 10)) 3628800
実をいうと、sum と product は apply を使うと簡単に定義することができます。
リスト : 最大値と最小値
(defun maximum-tail (xs m)
(if (null xs)
m
(maximum-tail (cdr xs) (max (car xs) m))))
(defun maximum (xs)
(if (null (cdr xs))
(car xs)
(maximum-tail (cdr xs) (car xs))))
(defun minimum-tail (xs m)
(if (null xs)
m
(minimum-tail (cdr xs) (min (car xs) m))))
(defun minimum (xs)
(if (null (cdr xs))
(car xs)
(minimum-tail (cdr xs) (car xs))))
> (maximum '(1)) 1 > (maximum '(5 4 6 3 7 2 8 1 9 0)) 9 > (minimum '(1)) 1 > (minimum '(5 6 4 7 3 8 2 9 1 0)) 0 > (apply #'max '(5 4 6 7 3 2 1 8 9 0)) 9 > (apply #'min '(5 6 4 7 3 8 2 9 1 0)) 0
実をいうと、maximum, minimum は apply と max, min を使うと、もっと簡単に定義することができます。
リスト : 連想リストの操作
(defun acons (x y alist)
(cons (cons x y) alist))
(defun pairlis (keys data alist)
(if (or (null keys) (null data))
alist
(acons (car keys) (car data) (pairlis (cdr xs) (cdr ys) alist))))
(defun my-assoc (key alist)
(cond ((null alist) nil)
((eql (car (car alist)) key) (car alist))
(t (my-assoc key (cdr alist)))))
> (acons 'a 1 nil) ((A . 1)) > (pairlis '(a b c d e) '(1 2 3 4 5) nil) ((A . 1) (B . 2) (C . 3) (D . 4) (E . 5)) > (my-assoc 'c '((a . 1) (b . 2) (c . 3))) (C . 3) > (my-assoc 'd '((a . 1) (b . 2) (c . 3))) NIL
リスト : 挿入ソート
(defun insert-element (x xs)
(if (or (null xs) (<= x (car xs)))
(cons x xs)
(cons (car xs)
(insert-element x (cdr xs)))))
(defun insert-sort (xs)
(if (null xs)
nil
(insert-element (car xs) (insert-sort (cdr xs)))))
> (insert-sort '(5 6 4 7 3 8 2 9 1 0)) (0 1 2 3 4 5 6 7 8 9) > (insert-sort '(9 8 7 6 5 4 3 2 1 0)) (0 1 2 3 4 5 6 7 8 9) > (insert-sort '(0 1 2 3 4 5 6 7 8 9)) (0 1 2 3 4 5 6 7 8 9)
リスト xs を木とみなし、葉 (要素) の個数を数える関数 count-leaf xs を定義してください。
リスト xs を木とみなし、x と等しい要素を探索する関数 member-tree x xs を定義してください。等しい要素を見つけた場合は t を、見つからない場合は nil を返します。なお、等値の判定には述語 eql を使うことにします。
リスト xs の要素で、引数 old と等しいものを new に置き換える関数 substitute old new xs を定義してください。等値の判定には述語 eql を使うことにします。
リスト xs を木とみなし、引数 old と等しい要素を new に置き換える関数 subst old new xs を定義してください。等値の判定には述語 eql を使うことにします。
リスト xs を平坦化する関数 flatten xs を定義してください。
次に示す高階関数を定義してください。
リスト xs を線形探索する高階関数を定義してください。
リスト xs の先頭から述語 pred を満たす要素を取り出す関数 take-while と、pred を満たす要素を取り除く関数 drop-while を定義してください。
リストの中で連続した等しい記号を部分リストにまとめる関数 pack xs を定義してください。
リスト xs において、連続している同じ記号を (code . num) に変換する関数 rle xs を定義してください。code は記号、num は個数を表します。このような変換を「ランレングス符号化」といいます。そして、rle の逆変換を行う関数 rld を定義してください。
リスト : 葉の個数をカウントする
(defun count-leaf (xs)
(cond ((null xs) 0)
((consp xs)
(+ (count-leaf (car xs))
(count-leaf (cdr xs))))
(t 1)))
> (count-leaf '(a b c d e)) 5 > (count-leaf '((a b) (c d) (e f))) 6 > (count-leaf '(a (b (c (d) e) f) g)) 7
リスト : 木の探索
(defun member-tree (x xs)
(cond ((eql x xs) t)
((consp xs)
(or (member-tree x (car xs))
(member-tree x (cdr xs))))
(t nil)))
> (member-tree 'd '(a b c d e)) T > (member-tree 'd '(a (b (c (d) e) f) g)) T > (member-tree 'h '(a (b (c (d) e) f) g)) NIL
リスト : リストの置換
(defun substitute (old new xs)
(cond ((null xs) nil)
((eql (car xs) old)
(cons new (substitute old new (cdr xs))))
(t (cons (car xs) (substitute old new (cdr xs))))))
> (substitute 'a 'x '(a b c a b c a b c)) (X B C X B C X B C) > (substitute 'd 'x '(a b c a b c a b c)) (A B C A B C A B C) > (substitute 'a 'x '((a b) (a c) (a d))) ((A B) (A C) (A D))
リスト : 木の置換
(defun subst (old new xs)
(cond ((eql old xs) new)
((consp xs)
(cons (subst old new (car xs))
(subst old new (cdr xs))))
(t xs)))
> (subst 'a 'x '(a b c a b c a b c)) (X B C X B C X B C) > (subst 'a 'x '((a b) (a c) (a d))) ((X B) (X C) (X D)) > (subst 'd 'x '(a (b (c) b) a)) (A (B (C) B) A)
リスト : リストの平坦化
(defun flatten (xs)
(cond ((null xs) nil)
((consp xs)
(append (flatten (car xs)) ; append を使っているので効率が悪い
(flatten (cdr xs))))
(t (list xs))))
> (flatten '(a b c d e)) (A B C D E) > (flatten '((a b) (c d) (e f))) (A B C D E F) > (flatten '(a (b (c (d) e) f) g)) (A B C D E F G)
リスト : 基本的な高階関数
;; マッピング
(defun map (func xs)
(if (null xs)
nil
(cons (funcall func (car xs)) (map func (cdr xs)))))
(defun flat-map (func xs)
(apply #'append (map func xs)))
;; フィルター
(defun filter (pred xs)
(cond ((null xs) nil)
((funcall pred (car xs))
(cons (car xs) (filter pred (cdr xs))))
(t (filter pred (cdr xs)))))
;; 畳み込み
(defun fold-left (func a xs)
(if (null xs)
a
(fold-left func (funcall func a (car xs)) (cdr xs))))
(defun fold-right (func a xs)
(if (null xs)
a
(funcall func (car xs) (fold-right func a (cdr xs)))))
;; 巡回
(defun for-each (func xs)
(cond ((not (null xs))
(funcall func (car xs))
(for-each func (cdr xs)))))
> (map #'square '(1 2 3 4 5 6 7 8)) (1 4 9 16 25 36 49 64) > (map (lambda (x) (make-list x x)) '(1 2 3 4 5)) ((1) (2 2) (3 3 3) (4 4 4 4) (5 5 5 5 5)) > (flat-map (lambda (x) (make-list x x)) '(1 2 3 4 5)) (1 2 2 3 3 3 4 4 4 4 5 5 5 5 5) > (filter #'evenp '(1 2 3 4 5 6 7 8)) (2 4 6 8) > (fold-left #'+ 0 '(1 2 3 4 5 6 7 8 9 10)) 55 > (fold-left (lambda (a x) (cons x a)) nil '(1 2 3 4 5 6 7 8)) (8 7 6 5 4 3 2 1) > (fold-right #'* 1 '(1 2 3 4 5 6 7 8 9 10)) 3628800 > (fold-right #'cons nil '(1 2 3 4 5 6 7 8)) (1 2 3 4 5 6 7 8) > (for-each (lambda (x) (format (standard-output) "~D " x)) '(1 2 3 4 5)) 1 2 3 4 5 NIL
リスト : リストの線形探索
(defun find-if (pred xs)
(cond ((null xs) nil)
((funcall pred (car xs)) (car xs))
(t (find-if pred (cdr xs)))))
(defun position-if (pred xs)
(block exit
(for ((i 0 (1+ i))
(ys xs (cdr ys)))
((null ys) -1)
(if (funcall pred (car ys))
(return-from exit i)))))
(defun count-if (pred xs)
(fold-left (lambda (a x) (if (pred x) (1+ a) a)) 0 xs))
> (find-if #'evenp '(1 3 5 7 8 9)) 8 > (find-if #'evenp '(1 3 5 7 9 11)) NIL > (position-if #'evenp '(1 3 5 7 8 9)) 4 > (position-if #'evenp '(1 3 5 7 9 11)) -1 > (count-if #'evenp '(1 2 3 4 5 6 7)) 3 > (count-if #'oddp '(1 2 3 4 5 6 7)) 4 > (count-if #'minusp '(1 2 3 4 5 6 7)) 0
リスト : take-while と drop-while
(defun take-while (pred xs)
(if (or (null xs) (not (funcall pred (car xs))))
nil
(cons (car xs) (take-while pred (cdr xs)))))
(defun drop-while (pred xs)
(if (or (null xs) (not (funcall pred (car xs))))
xs
(drop-while pred (cdr xs))))
> (take-while #'plusp '(1 2 3 4 5 -1 2 3 4 5)) (1 2 3 4 5) > (take-while #'plusp '(-1 2 3 4 5 6 7 8)) NIL > (drop-while #'plusp '(1 2 3 4 5 -1 2 3 4 5)) (-1 2 3 4 5) > (drop-while #'plusp '(-1 2 3 4 5 6 7 8)) (-1 2 3 4 5 6 7 8)
リスト : パッキング
(defun pack (xs)
(if (null xs)
nil
(cons (take-while (lambda (x) (eql (car xs) x)) xs)
(pack (drop-while (lambda (x) (eql (car xs) x)) xs)))))
> (pack '(a a a b c c d d d d d)) ((A A A) (B) (C C) (D D D D D)) > (pack '(a b c d e f g)) ((A) (B) (C) (D) (E) (F) (G))
リスト : ランレングス符号 (defun rle (xs) (map (lambda (ys) (cons (car ys) (length ys))) (pack xs))) (defun rld (xs) (flat-map (lambda (code) (make-list (cdr code) (car code))) xs))
> (rle '(a a b b b c c c c d d d d d)) ((A . 2) (B . 3) (C . 4) (D . 5)) > (rld '((a . 1) (b . 3) (c . 5))) (A B B B C C C C C) > (rld (rle '(a b b c c c d d d d e e e e e a))) (A B B C C C D D D D E E E E E A)
リスト xs の末尾のセル (要素ではない) を求める関数 last xs を定義してください。
リスト xs と ys を破壊的に連結する関数 my-nconc xs ys を定義してください。
リスト xs の n 番目の要素を x に破壊的に書き換える関数 set-nth n x xs を定義してください。
リストを破壊的に反転する関数 my-nreverse を定義してください。
リスト xs と ys を受け取り、xs を反転して ys と連結する関数 revappend xs ys と、xs を破壊的に反転して ys と連結する関数 nrevappend を定義してください。
リスト xs から n 個の要素を反転して取り出す関数 revtake n xs と、n 個の要素を取り出して返す関数 my-take n xs を定義してください。
my-append, insert-at, remove-at は繰り返し (末尾再帰) ではないので、長いリストを処理しようとするとスタックオーバーフロー (またはコアダンプ) します。長いリストでも処理できるように、これらの関数を改良してください。
map, filter, fold-left, take-while は繰り返し (末尾再帰) ではないので、長いリストを処理しようとするとスタックオーバーフロー (またはコアダンプ) します。長いリストでも処理できるように、これらの関数を改良してください。
引数を要素とする循環リストを生成する関数 circular-list と、循環リストを表示する関数 print-circular-list を定義してください。
リスト xs が循環リストか判定する述語 circular-listp xs を定義してください。
リスト : 末尾のセルを求める
(defun last (xs)
(if (or (null xs) (null (cdr xs)))
xs
(last (cdr xs))))
> (last nil) NIL > (last '(a)) (A) > (last '(a b c d e)) (E)
ISLisp の場合、コンスセル xs の CAR 部を obj に書き換えるには (set-car obj xs) または (setf (car xs) obj) を使います。CDR 部を書き換えるには (set-cdr obj xs) または (setf (cdr xs) obj) を使います。Common Lisp では rplaca, rplacd, setf を、Scheme では set-car!, set-cdr! を使います。
my-nconc は last で xs の末尾セルを求め、set-cdr で CDR 部を ys に書き換えるだけです。これで xs を破壊的に修正して、ys を連結することができます。
リスト : リストの破壊的連結 (defun my-nconc (xs ys) (set-cdr ys (last xs)) xs)
> (defglobal xs '(a b c d)) XS > (my-nconc xs '(e f g h)) (A B C D E F G H) > xs (A B C D E F G H)
set-nth は nthcdr と set-car を使えば簡単に定義することができます。
リスト : リストの n 番目の要素を破壊的に書き換える (defun set-nth (n x xs) (set-car x (nthcdr n xs)) xs)
> xs (A B C D E F G H) > (set-nth 4 'z xs) (A B C D Z F G H) > xs (A B C D Z F G H) > (set-nth 7 'z xs) (A B C D Z F G Z) > (set-nth 0 'z xs) (Z B C D Z F G Z)
my-nreverse のアルゴリズムは拙作のページ「Scheme Programming: Scheme プログラミング中級編 (その４)」で詳しく説明しています。よろしければ、そちらをお読みくださいませ。
リスト : リストの破壊的反転
(defun my-nreverse (xs)
(for ((ys xs) (rs nil))
((null ys) rs)
(let ((zs (cdr ys)))
(set-cdr rs ys)
(setq rs ys)
(setq ys zs))))
> (defglobal xs '(a b c d e)) XS > (my-nreverse xs) (E D C B A) > xs (A) > (my-nreverse nil) NIL > (my-nreverse '(1)) (1)
revappend は末尾再帰で簡単に定義することができます。nrevappend は my-nreverse とほとんど同じです。
リスト : リストを反転して連結する
(defun revappend (xs ys)
(if (null xs)
ys
(revappend (cdr xs) (cons (car xs) ys))))
(defun nrevappend (xs ys)
(for ((ys1 xs) (rs ys))
((null ys1) rs)
(let ((zs (cdr ys1)))
(set-cdr rs ys1)
(setq rs ys1)
(setq ys1 zs))))
> (revappend '(a b c d) '(e f g h)) (D C B A E F G H) > (nrevappend (list 1 2 3 4) '(5 6 7 8)) (4 3 2 1 5 6 7 8)
リスト : revtake と my-take
(defun revtake (n xs)
(for ((m n (1- m))
(rs nil (cons (car ys) rs))
(ys xs (cdr ys)))
((or (zerop m) (null ys)) rs)))
(defun my-take (n xs)
(nreverse (revtake n xs)))
revtake は繰り返し (for) を使いましたが、末尾再帰でも簡単にプログラムすることができます。my-take は revtake と nreverse を使うと簡単です。再帰呼び出しでも簡単にプログラムできますが、繰り返し (末尾再帰) になっていないと、長いリストを処理することができません。この方法だと、長いリストにも対応することができます。
> (revtake 3 '(a b c d e)) (C B A) > (revtake 0 '(a b c d e)) NIL > (revtake 1 '(a b c d e)) (A) > (my-take 3 '(a b c d e)) (A B C) > (my-take 0 '(a b c d e)) NIL > (my-take 1 '(a b c d e)) (A)
リスト : my-append, insert-at, remove-at の改良 (defun append-ok (xs ys) (nrevappend (reverse xs) ys)) (defun insert-at-ok (n x xs) (nrevappend (revtake n xs) (cons x (nthcdr n xs)))) (defun remove-at-ok (n xs) (nrevappend (revtake n xs) (nthcdr (1+ n) xs)))
どの関数も reverse, revtake で反転したリストを生成し、それを nrevappend で破壊的に反転して連結します。
> (append-ok '(a b c d) '(e f g h)) (A B C D E F G H) > (append-ok nil '(e f g h)) (E F G H) > (append-ok '(a b c d) nil) (A B C D) > (insert-at-ok 4 'x '(a b c d e f g h)) (A B C D X E F G H) > (insert-at-ok 8 'x '(a b c d e f g h)) (A B C D E F G H X) > (remove-at 4 '(a b c d e f g h)) (A B C D F G H) > (remove-at 7 '(a b c d e f g h)) (A B C D E F G)
リスト : map, filter, fold-right, take-while の改良
(defun map-ok (func xs)
(for ((ys xs (cdr ys))
(rs nil (cons (funcall func (car ys)) rs)))
((null ys) (nreverse rs))))
(defun filter-ok (pred xs)
(for ((ys xs (cdr ys))
(rs nil))
((null ys) (nreverse rs))
(if (funcall pred (car ys))
(setq rs (cons (car ys) rs)))))
(defun fold-right-ok (func a xs)
(for ((ys (reverse xs) (cdr ys))
(acc a (funcall func (car ys) acc)))
((null ys) acc)))
(defun take-while-ok (pred xs)
(for ((ys xs (cdr ys))
(rs nil (cons (car ys) rs)))
((or (null ys) (not (funcall pred (car ys))))
(nreverse rs))))
どの関数も for を使ってプログラムしています。map-ok, fiter-ok, take-while-ok は最後に nreverse でリストを破壊的に反転することに注意してください。fold-right-ok は最初に reverse でリストを反転することで繰り返しに対応しています。
> (map-ok #'square '(1 2 3 4 5 6 7 8)) (1 4 9 16 25 36 49 64) > (filter-ok #'evenp '(1 2 3 4 5 6 7 8)) (2 4 6 8) > (fold-right-ok #'cons nil '(a b c d e f g)) (A B C D E F G) > (fold-right-ok #'+ 0 '(1 2 3 4 5 6 7 8)) 36 > (take-while-ok #'plusp '(1 2 3 4 0 5 6 7 8)) (1 2 3 4) > (take-while-ok #'plusp '(0 1 2 3 4 5 6 7 8)) NIL > (take-while-ok #'plusp '(1 2 3 4 5 6 7 8)) (1 2 3 4 5 6 7 8)
リスト : 循環リスト
(defun circular-list (:rest args)
(set-cdr args (last args))
args)
(defun print-circular-list (xs)
(block exit
(let ((ys xs))
(while t
(format (standard-output) "~S " (car ys))
(setq ys (cdr ys))
(cond ((eq ys xs)
(format (standard-output) "~%")
(return-from exit nil)))))))
circular-list はリスト args の末尾セルを last で求め、その CDR 部を先頭セル args に書き換えるだけです。表示は先頭セル xs から順番にセルをたどり、先頭に戻ったら処理を終了します。
> (print-circular-list (circular-list 1 2 3 4 5)) 1 2 3 4 5 NIL > (print-circular-list (circular-list 1)) 1 NIL
循環リストのチェックは「うさぎとかめ」のアルゴリズムを使うと簡単です。「うさぎ」と「かめ」はリストをたどる変数として定義します。うさぎは cdr を 2 回適用して進みますが、かめは cdr を 1 回適用して進みます。うさぎがリストの終端に到達すれば、リストは循環していないことがわかります。うさぎがかめに追いつけば、リストは循環していると判断できます。プログラムは次のようになります。
リスト : 循環リストの判定 (修正 2018/03/21)
(defun circular-listp (xs)
(if (or (null xs) (null (cdr xs)))
nil
(block exit
(for ((fast (cdr (cdr xs)) (cdr (cdr fast)))
(slow (cdr xs) (cdr slow)))
((or (null fast) (null (cdr fast))) nil)
(if (eq fast slow) (return-from exit t))))))
> (circular-listp '()) NIL > (circular-listp '(1)) NIL > (circular-listp '(1 2)) NIL > (circular-listp '(1 2 3)) NIL > (circular-listp '(1 2 3 4)) NIL > (circular-listp (circular-list 1 2 3 4)) T > (circular-listp (circular-list 1 2 3)) T > (circular-listp (circular-list 1 2)) T > (circular-listp (circular-list 1)) T
今までのプログラム (下記リスト) は、引数に空リストまたは要素が 3 つ以上の奇数個のリストを与えるとエラーになります。ISLisp は空リストに cdr を適用するとエラーになることをうっかりしていました。ご指摘いただいた笹川さんに感謝いたします。
リスト : 循環リストの判定 (バグあり)
(defun circular-listp (xs)
(if (null (cdr xs))
nil
(block exit
(for ((fast (cdr (cdr xs)) (cdr (cdr fast)))
(slow (cdr xs) (cdr slow)))
((null fast) nil)
(if (eq fast slow) (return-from exit t))))))
0 から n - 1 までの整数を関数 func に適用し、その結果をリストに格納して返す関数 tabulate n func と、初項を a として関数 func に前項を適用して n 個の要素を生成する iterate n a func を定義してください。
次に示す数列を生成する関数を定義してください
リスト xs から要素を一つ選んで、選んだ要素と残りの要素を返す関数 select xs を定義してください。結果はリストに格納して返すものとします。以下に簡単な動作例を示します。
(select '(1 2 3)) => ((1 (2 3)) (2 (1 3)) (3 (1 2)))
リスト xs に x を挿入するパターンをすべて求めてリストに格納して返す関数 interleave x xs を定義してください。以下に簡単な動作例を示します。
(interleave 0 '(1 2)) => ((0 1 2) (1 0 2) (1 2 0))
リスト xs の順列を求める関数 permutations xs を定義してください。なお、生成した順列はリストに格納して返すものとします。
リスト xs から n 個の要素を選ぶ組み合わせを求める関数 combinations n xs を定義してください。なお、生成した組み合わせはリストに格納して返すものとします。
2 つのソート済みのリスト xs, ys をひとつのソート済みのリストにまとめる関数 merge-list xs ys を定義してください。
関数 merge-list を使ってリスト xs をソートする merge-sort xs を定義してください。
リスト xs を木とみなして、以下に示す高階関数を定義してください。
高階関数 map, fold-left, fold-right はリストの要素に関数が適用されますが、部分リストを関数に渡す方法も考えられます。部分リストを渡してマッピングを行う関数 my-maplist func xs と、リストの先頭から畳み込みを行う関数 pair-fold-left func a xs と、末尾から畳み込みを行う関数 pair-fold-right func a xs を定義してください。
リスト : tabulate と iterate
(defun tabulate (n func)
(for ((m (1- n) (1- m))
(xs nil (cons (funcall func m) xs)))
((minusp m) xs)))
(defun iterate (n a func)
(for ((a0 a (funcall func a0))
(m n (1- m))
(xs nil (cons a0 xs)))
((zerop m) (nreverse xs))))
> (tabulate 10 #'square) (0 1 4 9 16 25 36 49 64 81) > (tabulate 10 #'cubic) (0 1 8 27 64 125 216 343 512 729) > (iterate 10 1 (lambda (x) (+ x 2))) (1 3 5 7 9 11 13 15 17 19) > (iterate 10 1 (lambda (x) (* x 2))) (1 2 4 8 16 32 64 128 256 512)
リスト : 数列の生成
(defun iota (n s) (iterate n s #'1+))
(defun facts (n) (tabulate n #'fact))
(defun fibos (n)
(mapcar #'car
(iterate n
'(0 1)
(lambda (xs)
(list (second xs) (+ (first xs) (second xs)))))))
> (iota 10 1) (1 2 3 4 5 6 7 8 9 10) > (iota 10 100) (100 101 102 103 104 105 106 107 108 109) > (facts 10) (1 1 2 6 24 120 720 5040 40320 362880) > (facts 15) (1 1 2 6 24 120 720 5040 40320 362880 3628800 39916800 479001600 6227020800 7178291200) > (fibos 20) (0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181) > (nthcdr 20 (fibos 40)) (6765 10946 17711 28657 46368 75025 121393 196418 317811 514229 832040 1346269 2178309 3524578 5702887 9227465 14930352 24157817 39088169 63245986)
リスト : 要素の選択
(defun select (xs)
(if (null (cdr xs))
(list (list (car xs) nil))
(cons (list (car xs) (cdr xs))
(mapcar (lambda (ys) (list (first ys) (cons (car xs) (second ys))))
(select (cdr xs))))))
> (select '(1)) ((1 NIL)) > (select '(1 2)) ((1 (2)) (2 (1))) > (select '(1 2 3)) ((1 (2 3)) (2 (1 3)) (3 (1 2))) > (select '(1 2 3 4)) ((1 (2 3 4)) (2 (1 3 4)) (3 (1 2 4)) (4 (1 2 3)))
リスト : interleave
(defun interleave (x xs)
(if (null xs)
(list (list x))
(append (list (cons x xs))
(mapcar (lambda (ys) (cons (car xs) ys))
(interleave x (cdr xs))))))
> (interleave 0 '(1 2)) ((0 1 2) (1 0 2) (1 2 0)) > (interleave 0 '(1 2 3 4 5)) ((0 1 2 3 4 5) (1 0 2 3 4 5) (1 2 0 3 4 5) (1 2 3 0 4 5) (1 2 3 4 0 5) (1 2 3 4 5 0))
リスト : 順列の生成
(defun permutations (xs)
(if (null xs)
(list nil)
(flat-map (lambda (ys) (interleave (car xs) ys))
(permutations (cdr xs)))))
permutations は interleave を使うと簡単です。permutations を再帰呼び出しして (cdr xs) の順列を求め、順列を表す要素 ys に interleave で (car xs) を挿入すればいいわけです。リストを平坦化するため flat-map を使っていることに注意してください。
> (permutations '(a b c)) ((A B C) (B A C) (B C A) (A C B) (C A B) (C B A)) > (permutations '(a b c d)) ((A B C D) (B A C D) (B C A D) (B C D A) (A C B D) (C A B D) (C B A D) (C B D A) (A C D B) (C A D B) (C D A B) (C D B A) (A B D C) (B A D C) (B D A C) (B D C A) (A D B C) (D A B C) (D B A C) (D B C A) (A D C B) (D A C B) (D C A B) (D C B A))
リスト : 組み合わせの生成
(defun combinations (n xs)
(cond ((zerop n) (list nil))
((null xs) nil)
(t (append (mapcar (lambda (ys) (cons (car xs) ys))
(combinations (1- n) (cdr xs)))
(combinations n (cdr xs))))))
> (combinations 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)) > (combinations 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))
リスト : リストのマージ
(defun merge-list (xs ys)
(let ((zs nil))
(while (and xs ys)
(cond ((<= (car xs) (car ys))
(setq zs (cons (car xs) zs))
(setq xs (cdr xs)))
(t
(setq zs (cons (car ys) zs))
(setq ys (cdr ys)))))
(nrevappend zs (if (null xs) ys xs))))
> (merge-list '(1 3 5 7) '(2 4 6 8 10)) (1 2 3 4 5 6 7 8 10) > (merge-list '(5 6 7 8) '(1 2 3 4)) (1 2 3 4 5 6 7 8) > (merge-list '(1 2 7 8) '(3 4 5 6)) (1 2 3 4 5 6 7 8)
リスト : マージソート
(defun merge-sort (xs n)
(if (= n 1)
(list (car xs))
(let ((m (div n 2)))
(merge-list (merge-sort xs m)
(merge-sort (nthcdr m xs) (- n m))))))
> (merge-sort '(5 6 4 7 3 8 2 9 1 0) 10) (0 1 2 3 4 5 6 7 8 9) > (merge-sort '(0 1 2 3 4 5 6 7 8 9) 10) (0 1 2 3 4 5 6 7 8 9) > (merge-sort '(9 8 7 6 5 4 3 2 1 0) 10) (0 1 2 3 4 5 6 7 8 9)
リスト : 木の高階関数
;; マッピング
(defun map-tree (func xs)
(cond ((null xs) nil)
((consp xs)
(cons (map-tree func (car xs))
(map-tree func (cdr xs))))
(t (funcall func xs))))
;; 畳み込み
(defun fold-tree (func a xs)
(cond ((null xs) a)
((consp xs)
(fold-tree func (fold-tree func a (cdr xs)) (car xs)))
(t (funcall func xs a))))
;; 巡回
(defun for-each-tree (func xs)
(cond ((null xs) nil)
((consp xs)
(for-each-tree func (car xs))
(for-each-tree func (cdr xs)))
(t (funcall func xs))))
> (map-tree #'1+ '(1 2 3 4 5)) (2 3 4 5 6) > (map-tree #'1+ '(1 (2 (3 (4) 5) 6) 7)) (2 (3 (4 (5) 6) 7) 8) > (fold-tree #'+ 0 '(1 2 3 4 5)) 15 > (fold-tree #'+ 0 '(1 (2 (3 (4) 5) 6) 7)) 28 > (fold-tree #'cons nil '(1 2 3 4 5)) (1 2 3 4 5) > (fold-tree #'cons nil '(1 (2 (3 (4) 5) 6) 7)) (1 2 3 4 5 6 7) > (for-each-tree (lambda (x) (format (standard-output) "~S " x)) '(1 (2 (3) 4) 5)) 1 2 3 4 5 NIL
リスト : 部分リストを関数に渡す高階関数
(defun my-maplist (func xs)
(if (null xs)
nil
(cons (funcall func xs) (my-maplist func (cdr xs)))))
(defun pair-fold-left (func a xs)
(if (null xs)
a
(pair-fold-left func (funcall func a xs) (cdr xs))))
(defun pair-fold-right (func a xs)
(if (null xs)
a
(funcall func xs (pair-fold-right func a (cdr xs)))))
> (my-maplist (lambda (x) x) '(a b c d e)) ((a b c d e) (b c d e) (c d e) (d e) (e)) > (my-maplist (lambda (x) (fold + 0 x)) '(1 2 3 4 5)) (15 14 12 9 5) > (pair-fold-left (lambda (a x) (cons x a)) nil '(1 2 3 4 5)) ((5) (4 5) (3 4 5) (2 3 4 5) (1 2 3 4 5)) > (pair-fold-left (lambda (a x) (cons (apply #'+ x) a)) nil '(1 2 3 4 5)) (5 9 12 14 15) > (pair-fold-right (lambda (x a) (cons x a)) nil '(1 2 3 4 5)) ((1 2 3 4 5) (2 3 4 5) (3 4 5) (4 5) (5)) > (pair-fold-right (lambda (x a) (cons (apply #'+ x) a)) nil '(1 2 3 4 5)) (15 14 12 9 5)
;;
;; drill.lsp : ISLisp ドリル
;;
;; Copyright (C) 2017 Makoto Hiroi
;;
;; Q01
(defun 1+ (n) (+ n 1))
(defun 1- (n) (- n 1))
(defun square (n) (* n n))
(defun cubic (n) (* n n n))
(defun half (n) (quotient n 2))
(defun medium (n m) (half (+ n m)))
(defun square-medium (n m)
(medium (square n) (square m)))
;; Q02
(defun zerop (n) (= n 0))
(defun minusp (n) (< n 0))
(defun plusp (n) (< 0 n))
(defun sign (n)
(if (zerop n)
0
(if (plusp n) 1 -1)))
(defun evenp (n) (zerop (mod n 2)))
(defun oddp (n) (not (evenp n)))
(defun between (n low high)
(and (<= low n) (<= n high)))
;; Q03
(defun fact (n)
(if (zerop n)
1
(* n (fact (1- n)))))
(defun fact-tail (n acc)
(if (zerop n)
acc
(fact-tail (1- n) (* acc n))))
;; Q04
(defun fibo (n)
(if (< n 2)
n
(+ (fibo (1- n)) (fibo (- n 2)))))
(defun fibo-tail (n a b)
(if (zerop n)
a
(fibo-tail (1- n) b (+ a b))))
;; Q05
(defun power (x n)
(if (zerop n)
1
(* x (power x (1- n)))))
(defun power-tail (x n acc)
(if (zerop n)
acc
(power-tail x (1- n) (* acc x))))
(defun power-fast (x n)
(cond ((zerop n) 1)
((= n 1) x)
(t (let ((z (power-fast x (div n 2))))
(if (oddp n)
(* x z z)
(* z z))))))
;; Q06
(defun first (xs) (car xs))
(defun second (xs) (car (cdr xs)))
(defun third (xs) (car (cdr (cdr xs))))
(defun fourth (xs) (car (cdr (cdr (cdr xs)))))
(defun fifth (xs) (car (cdr (cdr (cdr (cdr xs))))))
;; Q07
(defun nthcdr (n xs)
(if (zerop n)
xs
(nthcdr (1- n) (cdr xs))))
;; Q08
(defun nth (n xs) (car (nthcdr n xs)))
;; Q09
(defun my-length (xs)
(if (null xs)
0
(1+ (my-length (cdr xs)))))
(defun my-length-tail (xs n)
(if (null xs)
n
(my-length-tail (cdr xs) (1+ n))))
;; Q10
(defun my-append (xs ys)
(if (null xs)
ys
(cons (car xs) (my-append (cdr xs) ys))))
;; Q11
(defun my-reverse (xs)
(if (null xs)
nil
(append (my-reverse (cdr xs)) (list (car xs)))))
(defun my-reverse-tail (xs ys)
(if (null xs)
ys
(my-reverse-tail (cdr xs) (cons (car xs) ys))))
;; Q12
(defun butlast (xs n)
(nreverse (nthcdr n (reverse xs))))
;; Q13
(defun my-member (x xs)
(if (or (null xs) (eql x (car xs)))
xs
(my-member x (cdr xs))))
;; Q14
(defun insert-at (n x xs)
(if (or (null xs) (= n 0))
(cons x xs)
(cons (car xs) (insert-at (- n 1) x (cdr xs)))))
;; Q15
(defun remove-at (n xs)
(cond ((null xs) nil)
((= n 0) (cdr xs))
(t (cons (car xs) (remove-at (- n 1) (cdr xs))))))
;; Q16
(defun make-list (n x)
(if (zerop n)
nil
(cons x (make-list (1- n) x))))
(defun make-list-tail (n x ys)
(if (zerop n)
ys
(make-list-tail (1- n) x (cons x ys))))
(defun copy-list (xs)
(if (null xs)
nil
(cons (car xs) (copy-list (cdr xs)))))
(defun copy-list-tail (xs ys)
(if (null xs)
(nreverse ys)
(copy-list-tail (cdr xs) (cons (car xs) ys))))
;; Q17
(defun sum (xs)
(if (null xs)
0
(+ (car xs) (sum (cdr xs)))))
(defun sum-tail (xs acc)
(if (null xs)
acc
(sum-tail (cdr xs) (+ (car xs) acc))))
(defun product (xs)
(if (null xs)
1
(* (car xs) (product (cdr xs)))))
(defun product-tail (xs acc)
(if (null xs)
acc
(product-tail (cdr xs) (* (car xs) acc))))
;; Q18
(defun maximum-tail (xs m)
(if (null xs)
m
(maximum-tail (cdr xs) (if (< m (car xs)) (car xs) m))))
(defun maximum (xs)
(if (null (cdr xs))
(car xs)
(maximum-tail (cdr xs) (car xs))))
(defun minimum-tail (xs m)
(if (null xs)
m
(minimum-tail (cdr xs) (if (< (car xs) m) (car xs) m))))
(defun minimum (xs)
(if (null (cdr xs))
(car xs)
(minimum-tail (cdr xs) (car xs))))
;; Q19
(defun acons (x y alist)
(cons (cons x y) alist))
(defun pairlis (keys data alist)
(if (or (null keys) (null data))
alist
(acons (car keys) (car data) (pairlis (cdr keys) (cdr data) alist))))
(defun my-assoc (key alist)
(cond ((null alist) nil)
((eql (car (car alist)) key) (car alist))
(t (my-assoc key (cdr alist)))))
;; Q20
(defun insert-element (x xs)
(if (or (null xs) (<= x (car xs)))
(cons x xs)
(cons (car xs)
(insert-element x (cdr xs)))))
(defun insert-sort (xs)
(if (null xs)
nil
(insert-element (car xs) (insert-sort (cdr xs)))))
;; Q21
(defun count-leaf (xs)
(cond ((null xs) 0)
((consp xs)
(+ (count-leaf (car xs))
(count-leaf (cdr xs))))
(t 1)))
;; Q22
(defun member-tree (x xs)
(cond ((eql x xs) t)
((consp xs)
(or (member-tree x (car xs))
(member-tree x (cdr xs))))
(t nil)))
;; Q23
(defun substitute (old new xs)
(cond ((null xs) nil)
((eql (car xs) old)
(cons new (substitute old new (cdr xs))))
(t (cons (car xs) (substitute old new (cdr xs))))))
;; Q24
(defun subst (old new xs)
(cond ((eql old xs) new)
((consp xs)
(cons (subst old new (car xs))
(subst old new (cdr xs))))
(t xs)))
;; Q25
(defun flatten (xs)
(cond ((null xs) nil)
((consp xs)
(append (flatten (car xs))
(flatten (cdr xs))))
(t (list xs))))
;; Q26
(defun map (func xs)
(if (null xs)
nil
(cons (funcall func (car xs)) (map func (cdr xs)))))
(defun flat-map (func xs)
(apply #'append (map func xs)))
(defun filter (pred xs)
(cond ((null xs) nil)
((funcall pred (car xs))
(cons (car xs) (filter pred (cdr xs))))
(t (filter pred (cdr xs)))))
(defun fold-left (func a xs)
(if (null xs)
a
(fold-left func (funcall func a (car xs)) (cdr xs))))
(defun fold-right (func a xs)
(if (null xs)
a
(funcall func (car xs) (fold-right func a (cdr xs)))))
(defun for-each (func xs)
(cond ((not (null xs))
(funcall func (car xs))
(for-each func (cdr xs)))))
;; Q27 (線形探索)
(defun find-if (pred xs)
(cond ((null xs) nil)
((funcall pred (car xs)) (car xs))
(t (find-if pred (cdr xs)))))
(defun position-if (pred xs)
(block exit
(for ((i 0 (1+ i))
(ys xs (cdr ys)))
((null ys) -1)
(if (funcall pred (car xs))
(return-from exit i)))))
(defun count-if (pred xs)
(fold-left (lambda (a x) (if (pred x) (1+ a) a)) 0 xs))
;; Q28
(defun take-while (pred xs)
(if (or (null xs) (not (funcall pred (car xs))))
nil
(cons (car xs) (take-while pred (cdr xs)))))
(defun drop-while (pred xs)
(if (or (null xs) (not (funcall pred (car xs))))
xs
(drop-while pred (cdr xs))))
;; Q29
(defun pack (xs)
(if (null xs)
nil
(cons (take-while (lambda (x) (eql (car xs) x)) xs)
(pack (drop-while (lambda (x) (eql (car xs) x)) xs)))))
;; Q30
(defun rle (xs)
(map (lambda (ys) (cons (car ys) (length ys))) (pack xs)))
(defun rld (xs)
(flat-map (lambda (code) (make-list (cdr code) (car code))) xs))
;; Q31
(defun last (xs)
(if (or (null xs) (null (cdr xs)))
xs
(last (cdr xs))))
;; Q32
(defun my-nconc (xs ys)
(set-cdr ys (last xs))
xs)
;; Q33
(defun set-nth (n x xs)
(set-car x (nthcdr n xs))
xs)
;; Q34
(defun my-nreverse (xs)
(for ((ys xs) (rs nil))
((null ys) rs)
(let ((zs (cdr ys)))
(set-cdr rs ys)
(setq rs ys)
(setq ys zs))))
;; Q35
(defun revappend (xs ys)
(if (null xs)
ys
(revappend (cdr xs) (cons (car xs) ys))))
(defun nrevappend (xs ys)
(for ((ys1 xs) (rs ys))
((null ys1) rs)
(let ((zs (cdr ys1)))
(set-cdr rs ys1)
(setq rs ys1)
(setq ys1 zs))))
;; Q36
(defun revtake (n xs)
(for ((m n (1- m))
(rs nil (cons (car ys) rs))
(ys xs (cdr ys)))
((or (zerop m) (null ys)) rs)))
(defun my-take (n xs)
(nreverse (revtake n xs)))
;; Q37
(defun append-ok (xs ys)
(nrevappend (reverse xs) ys))
(defun insert-at-ok (n x xs)
(nrevappend (revtake n xs) (cons x (nthcdr n xs))))
(defun remove-at-ok (n xs)
(nrevappend (revtake n xs) (nthcdr (1+ n) xs)))
;; Q38
(defun map-ok (func xs)
(for ((ys xs (cdr ys))
(rs nil (cons (funcall func (car ys)) rs)))
((null ys) (nreverse rs))))
(defun filter-ok (pred xs)
(for ((ys xs (cdr ys))
(rs nil))
((null ys) (nreverse rs))
(if (funcall pred (car ys))
(setq rs (cons (car ys) rs)))))
(defun fold-right-ok (func a xs)
(for ((ys (reverse xs) (cdr ys))
(acc a (funcall func (car ys) acc)))
((null ys) acc)))
(defun take-while-ok (pred xs)
(for ((ys xs (cdr ys))
(rs nil (cons (car ys) rs)))
((or (null ys) (not (funcall pred (car ys))))
(nreverse rs))))
;; Q39
(defun circular-list (:rest args)
(set-cdr args (last args))
args)
(defun print-circular-list (xs)
(block exit
(let ((ys xs))
(while t
(format (standard-output) "~S " (car ys))
(setq ys (cdr ys))
(cond ((eq ys xs)
(format (standard-output) "~%")
(return-from exit nil)))))))
;; Q40 (修正 2018/03/21)
(defun circular-listp (xs)
(if (or (null xs) (null (cdr xs)))
nil
(block exit
(for ((fast (cdr (cdr xs)) (cdr (cdr fast)))
(slow (cdr xs) (cdr slow)))
((or (null fast) (null (cdr fast))) nil)
(if (eq fast slow) (return-from exit t))))))
;; Q41
(defun tabulate (n func)
(for ((m (1- n) (1- m))
(xs nil (cons (funcall func m) xs)))
((minusp m) xs)))
(defun iterate (n a func)
(for ((a0 a (funcall func a0))
(m n (1- m))
(xs nil (cons a0 xs)))
((zerop m) (nreverse xs))))
;; Q42
(defun iota (n s) (iterate n s #'1+))
(defun facts (n) (tabulate n #'fact))
(defun fibos (n)
(mapcar #'car
(iterate n
'(0 1)
(lambda (xs)
(list (second xs) (+ (first xs) (second xs)))))))
;; Q43
(defun select (xs)
(if (null (cdr xs))
(list (list (car xs) nil))
(cons (list (car xs) (cdr xs))
(mapcar (lambda (ys) (list (first ys) (cons (car xs) (second ys))))
(select (cdr xs))))))
;; Q44
(defun interleave (x xs)
(if (null xs)
(list (list x))
(append (list (cons x xs))
(mapcar (lambda (ys) (cons (car xs) ys))
(interleave x (cdr xs))))))
;; Q45
(defun permutations (xs)
(if (null xs)
(list nil)
(flat-map (lambda (ys) (interleave (car xs) ys))
(permutations (cdr xs)))))
;; Q46
(defun combinations (n xs)
(cond ((zerop n) (list nil))
((null xs) nil)
(t (append (mapcar (lambda (ys) (cons (car xs) ys))
(combinations (1- n) (cdr xs)))
(combinations n (cdr xs))))))
;; Q47
(defun merge-list (xs ys)
(let ((zs nil))
(while (and xs ys)
(cond ((<= (car xs) (car ys))
(setq zs (cons (car xs) zs))
(setq xs (cdr xs)))
(t
(setq zs (cons (car ys) zs))
(setq ys (cdr ys)))))
(nrevappend zs (if (null xs) ys xs))))
;; Q48
(defun merge-sort (xs n)
(if (= n 1)
(list (car xs))
(let ((m (div n 2)))
(merge-list (merge-sort xs m)
(merge-sort (nthcdr m xs) (- n m))))))
;; Q49
(defun map-tree (func xs)
(cond ((null xs) nil)
((consp xs)
(cons (map-tree func (car xs))
(map-tree func (cdr xs))))
(t (funcall func xs))))
(defun fold-tree (func a xs)
(cond ((null xs) a)
((consp xs)
(fold-tree func (fold-tree func a (cdr xs)) (car xs)))
(t (funcall func xs a))))
(defun for-each-tree (func xs)
(cond ((null xs) nil)
((consp xs)
(for-each-tree func (car xs))
(for-each-tree func (cdr xs)))
(t (funcall func xs))))
;; Q50
(defun my-maplist (func xs)
(if (null xs)
nil
(cons (funcall func xs) (my-maplist func (cdr xs)))))
(defun pair-fold-left (func a xs)
(if (null xs)
a
(pair-fold-left func (funcall func a xs) (cdr xs))))
(defun pair-fold-right (func a xs)
(if (null xs)
a
(funcall func xs (pair-fold-right func a (cdr xs)))))