簡単なプログラム
●リストで遊ぼう
- リストの要素がただひとつか調べる関数 singlep を定義してください。
- リストの要素が二つあるか調べる関数 doublep を定義してください。
- リスト xs はリスト ys よりも長いか調べる関数 longerp を定義してください。
- リスト xs の最後尾から n 個の要素を取り除く関数 butlast xs n を定義してください。
- リスト xs を長さ n の部分リストに分割する関数 group xs n を定義してください。
- リスト xs を木とみなして、x と等しい要素 (葉) を探す関数 member-tree x xs を定義してください。
- リスト xs を木とみなして、要素 (葉) を数える関数 count-leaf を定義してください。
- リスト xs のべき集合を求める関数 power-set を定義してください。
- リストを使ってパスカルの三角形を表示するプログラムを作ってください。
- リストを使ってマスターマインドを解くプログラムを作ってください。
●解答１
リスト : リストの要素はひとつか？ (defun singlep (xs) (and xs (null (cdr xs))))
ISLisp>(singlep nil) NIL ISLisp>(singlep '(a)) T ISLisp>(singlep '(a b)) NIL
●解答２
リスト : リストの要素はふたつか？ (defun doublep (xs) (and xs (singlep (cdr xs))))
ISLisp>(doublep nil) NIL ISLisp>(doublep '(a)) NIL ISLisp>(doublep '(a b)) T ISLisp>(doublep '(a b c)) NIL
●解答３
リスト : リスト xs はリスト ys よりも長いか？
(defun longerp (xs ys)
(for ((xs xs (cdr xs))
(ys ys (cdr ys)))
((or (null xs) (null ys)) (not (null xs)))))
ISLisp>(longerp '(a b c) '(a b c d)) NIL ISLisp>(longerp '(a b c) '(a b c)) NIL ISLisp>(longerp '(a b c) '(a b)) T ISLisp>(longerp '(a b c) '(a)) T ISLisp>(longerp '(a b c) nil) T
●解答４
リスト : リストの末尾から n 個の要素を取り除く (defun butlast (xs n) (nreverse (drop (reverse xs) n)))
ISLisp>(butlast '(a b c d e) 1) (A B C D) ISLisp>(butlast '(a b c d e) 2) (A B C) ISLisp>(butlast '(a b c d e) 4) (A) ISLisp>(butlast '(a b c d e) 5) NIL
●解答５
リスト : リストを長さ n の部分リストに分割する
(defun group (xs n)
(for ((xs xs (drop xs n))
(a nil (cons (take xs n) a)))
((null xs) (nreverse a))))
ISLisp>(group '(a b c d e f) 2) ((A B) (C D) (E F)) ISLisp>(group '(a b c d e f) 3) ((A B C) (D E F)) ISLisp>(group '(a b c d e f) 4) ((A B C D) (E F)) ISLisp>(group '(a b c d e f) 6) ((A B C D E F))
●解答６
リスト : 木の探索
(defun member-tree (x xs)
(if (consp xs)
(or (member-tree x (car xs))
(member-tree x (cdr xs)))
(eql x xs)))
ISLisp>(member-tree 1 '(1 (2 (3 (4) 5) 6) 7)) T ISLisp>(member-tree 4 '(1 (2 (3 (4) 5) 6) 7)) T ISLisp>(member-tree 7 '(1 (2 (3 (4) 5) 6) 7)) T ISLisp>(member-tree 0 '(1 (2 (3 (4) 5) 6) 7)) NIL
●解答７
リスト : 葉の個数を数える
(defun count-leaf (xs)
(cond ((null xs) 0)
((consp xs)
(+ (count-leaf (car xs))
(count-leaf (cdr xs))))
(t 1)))
ISLisp>(count-leaf '(1 (2 (3 (4) 5) 6) 7)) 7 ISLisp>(count-leaf '((1 2) (3 4) (5 6))) 6
●解答８
リスト : べき集合の生成
(defun power-set (xs)
(if (null xs)
(list nil)
(append (power-set (cdr xs))
(mapcar (lambda (ys) (cons (car xs) ys)) (power-set (cdr xs))))))
ISLisp>(power-set '(a b c)) (NIL (C) (B) (B C) (A) (A C) (A B) (A B C)) ISLisp>(power-set '(a b c d)) (NIL (D) (C) (C D) (B) (B D) (B C) (B C D) (A) (A D) (A C) (A C D) (A B) (A B D) (A B C) (A B C D))
●解答９
リスト : パスカルの三角形
(defun pascal (n)
(for ((n n (- n 1))
(xs '(1) (maplist (lambda (xs)
(if (singlep xs)
(car xs)
(+ (car xs) (cadr xs))))
(cons 0 xs))))
((= n 0))
(format (standard-output) "~A~%" xs)))
ISLisp>(pascal 16) (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) (1 12 66 220 495 792 924 792 495 220 66 12 1) (1 13 78 286 715 1287 1716 1716 1287 715 286 78 13 1) (1 14 91 364 1001 2002 3003 3432 3003 2002 1001 364 91 14 1) (1 15 105 455 1365 3003 5005 6435 6435 5005 3003 1365 455 105 15 1) NIL
●解答10
リスト : マスターマインドの解法
(load "list.l")
;; アクセス関数
(defun get-code (xs) (first xs))
(defun get-bulls (xs) (second xs))
(defun get-cows (xs) (third xs))
;; bulls を数える
(defun count-bulls (xs ys)
(count t (mapcar #'= xs ys)))
;; 同じ数字を数える
(defun count-same-number (xs ys)
(count-if (lambda (x) (member x ys)) xs))
;; 質問したコードと矛盾していないか
(defun check-query (query code)
(block exit
(for ((qs query (cdr qs)))
((null qs) t)
(let* ((b (count-bulls (get-code (car qs)) code))
(c (- (count-same-number (get-code (car qs)) code) b)))
(if (or (/= (get-bulls (car qs)) b)
(/= (get-cows (car qs)) c))
(return-from exit nil))))))
;; 解の表示
(defun print-answer (qs)
(for ((n 1 (+ n 1))
(qs qs (cdr qs)))
((null qs))
(format (standard-output)
"~D: ~A, bulls ~D, cows ~D~%"
n
(get-code (car qs))
(get-bulls (car qs))
(get-cows (car qs)))))
;; 解法
(defun mastermind (answer)
(block exit
(for ((code (permutations 4 (iota 0 9)) (cdr code))
(query nil))
((null code))
(cond ((check-query query (car code))
(let* ((b (count-bulls (car code) answer))
(c (- (count-same-number (car code) answer) b)))
(setq query (cons (list (car code) b c) query))
(cond ((= b 4)
(print-answer (reverse query))
(return-from exit t)))))))))
ISLisp>(mastermind '(9 8 7 6)) 1: (0 1 2 3), bulls 0, cows 0 2: (4 5 6 7), bulls 0, cows 2 3: (5 4 8 9), bulls 0, cows 2 4: (6 7 9 8), bulls 0, cows 4 5: (8 9 7 6), bulls 2, cows 2 6: (9 8 7 6), bulls 4, cows 0 T ISLisp>(mastermind '(9 4 3 1)) 1: (0 1 2 3), bulls 0, cows 2 2: (1 0 4 5), bulls 0, cows 2 3: (2 3 5 4), bulls 0, cows 2 4: (3 4 0 6), bulls 1, cows 1 5: (3 5 6 1), bulls 1, cows 1 6: (6 5 0 2), bulls 0, cows 0 7: (7 4 3 1), bulls 3, cows 0 8: (8 4 3 1), bulls 3, cows 0 9: (9 4 3 1), bulls 4, cows 0 T
●配列で遊ぼう
- 配列を使ってフィボナッチ数列を求めるプログラムを作ってください。
- 配列を使ってパスカルの三角形を表示してください。
- 一次元配列 (ベクタ) を使って素数を求めるプログラムを作ってください。
- ベクタをクイックソートするプログラムを作ってください。
- ベクタを二分探索するプログラムを作ってください。
- ベクタを破壊的に反転する関数 vector-nreverse を定義してください。
- ベクタ xs を線形探索する高階関数 index pred xs を定義してください。
- ベクタをコピーする関数 vector-copy を定義してください。
- ベクタ用のマップ関数 vector-map を定義してください。
- ベクタ用の畳み込み関数 vector-foldl, vector-foldr を定義してください。
●解答１
リスト : フィボナッチ数
(defglobal fibo-table nil)
(defun make-fibo-table (n)
(setf fibo-table (create-vector (+ n 1)))
(setf (aref fibo-table 0) 0)
(setf (aref fibo-table 1) 1)
(for ((i 2 (+ i 1)))
((< n i))
(setf (aref fibo-table i)
(+ (aref fibo-table (- i 1))
(aref fibo-table (- i 2))))))
;;
(defun fibo (n)
(if (or (not fibo-table)
(< (length fibo-table) (+ n 1)))
(make-fibo-table n))
(aref fibo-table n))
ISLisp>(fibo 100) 354224848179261915075 ISLisp>(fibo 50) 12586269025 ISLisp>(fibo 10) 55
●解答２
リスト : パスカルの三角形
;; 二次元配列版
(defun pascal (n)
(let ((table (create-array (list n n) 1)))
(for ((i 2 (+ i 1)))
((>= i n))
(for ((j 1 (+ j 1)))
((>= j i))
(setf (aref table i j)
(+ (aref table (- i 1) (- j 1))
(aref table (- i 1) j)))))
(for ((i 0 (+ i 1)))
((>= i n))
(for ((j 0 (+ j 1)))
((> j i))
(format (standard-output) "~D " (aref table i j)))
(format (standard-output) "~%"))))
;; ベクタ版
(defun pascal1 (n)
(let ((table (create-vector n 1)))
(format (standard-output) "1~%")
(format (standard-output) "1 1~%")
(for ((i 2 (+ i 1)))
((>= i n))
(for ((j (- i 1) (- j 1)))
((= j 0))
(setf (aref table j)
(+ (aref table j) (aref table (- j 1)))))
(for ((j 0 (+ j 1)))
((> j i)
(format (standard-output) "~%"))
(format (standard-output) "~D " (aref table j))))))
ISLisp>(pascal1 16) 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 1 12 66 220 495 792 924 792 495 220 66 12 1 1 13 78 286 715 1287 1716 1716 1287 715 286 78 13 1 1 14 91 364 1001 2002 3003 3432 3003 2002 1001 364 91 14 1 1 15 105 455 1365 3003 5005 6435 6435 5005 3003 1365 455 105 15 1 NIL
●解答３
リスト : エラトステネスの篩
(defun sieve (n)
(let ((ps (create-vector (div n 2) t))
(x 3))
(format (standard-output) "2 ")
(while (< (* x x) n)
(let ((i (div (- x 3) 2)))
(cond ((aref ps i)
(format (standard-output) "~D " x)
(for ((i i (+ i x)))
((>= i (length ps)))
(setf (aref ps i) nil))))
(setq x (+ x 2))))
(while (<= x n)
(let ((i (div (- x 3) 2)))
(if (aref ps i)
(format (standard-output) "~D " x)))
(setq x (+ x 2)))))
ISLisp>(sieve 100) 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 NIL ISLisp>(sieve 500) 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 NIL
●解答４
リスト : クイックソート
(defun quick-sort (buff)
(labels ((qsort (low high)
(let ((p (aref buff (div (+ low high) 2)))
(i low)
(j high))
(block exit
(while t
(while (< (aref buff i) p) (setq i (+ i 1)))
(while (> (aref buff j) p) (setq j (- j 1)))
(if (>= i j) (return-from exit nil))
(let ((tmp (aref buff i)))
(setf (aref buff i) (aref buff j))
(setf (aref buff j) tmp))
(setq i (+ i 1))
(setq j (- j 1))))
(if (< low (- i 1)) (qsort low (- i 1)))
(if (> high (+ j 1)) (qsort (+ j 1) high)))))
(qsort 0 (- (length buff) 1)))
buff)
ISLisp>(quick-sort #(5 6 4 7 3 8 2 9 1 0)) #(0 1 2 3 4 5 6 7 8 9) ISLisp>(quick-sort #(0 1 2 3 4 5 6 7 8 9)) #(0 1 2 3 4 5 6 7 8 9) ISLisp>(quick-sort #(9 8 7 6 5 4 3 2 1 0)) #(0 1 2 3 4 5 6 7 8 9)
●解答５
リスト : バイナリサーチ
(defun binary-search (buff x)
(block exit
(let ((low 0)
(high (- (length buff) 1)))
(while (<= low high)
(let ((mid (div (+ low high) 2)))
(cond ((= (aref buff mid) x)
(return-from exit t))
((< x (aref buff mid))
(setq high (- mid 1)))
(t (setq low (+ mid 1))))))
nil)))
ISLisp>(binary-search #(10 20 30 40 50 60 70 80 90) 10) T ISLisp>(binary-search #(10 20 30 40 50 60 70 80 90) 50) T ISLisp>(binary-search #(10 20 30 40 50 60 70 80 90) 90) T ISLisp>(binary-search #(10 20 30 40 50 60 70 80 90) 0) NIL ISLisp>(binary-search #(10 20 30 40 50 60 70 80 90) 100) NIL ISLisp>(binary-search #(10 20 30 40 50 60 70 80 90) 55) NIL
●解答６
リスト : ベクタの反転
(defun vector-nreverse (xs)
(for ((i 0 (+ i 1))
(j (- (length xs) 1) (- j 1)))
((>= i j) xs)
(let ((tmp (aref xs i)))
(setf (aref xs i) (aref xs j))
(setf (aref xs j) tmp))))
ISLisp>(vector-nreverse #(0 1 2 3 4 5 6 7 8 9)) #(9 8 7 6 5 4 3 2 1 0) ISLisp>(vector-nreverse #(0 1 2 3 4 5 6 7 8)) #(8 7 6 5 4 3 2 1 0)
●解答７
リスト : 線形探索
(defun index (pred xs)
(block exit
(for ((i 0 (+ i 1)))
((>= i (length xs)) -1)
(if (funcall pred (aref xs i))
(return-from exit i)))))
ISLisp>(defun evenp (x) (= (mod x 2) 0)) EVENP ISLisp>(index #'evenp #(0 1 3 5 7 9)) 0 ISLisp>(index #'evenp #(1 3 5 7 9 2)) 5 ISLisp>(index #'evenp #(1 3 5 7 9)) -1
●解答８
リスト : ベクタのコピー
(defun vector-copy (xs)
(let ((ys (create-vector (length xs))))
(for ((i 0 (+ i 1)))
((>= i (length xs)) ys)
(setf (aref ys i) (aref xs i)))))
ISLisp>(vector-copy #(1 2 3 4 5)) #(1 2 3 4 5) ISLisp>(vector-copy #(1)) #(1) ISLisp>(vector-copy #()) #()
●解答９
リスト : ベクタのマップ関数
(defun vector-map (f &rest xs)
(let ((k (apply #'min (mapcar #'length xs))))
(for ((i 0 (+ i 1))
(a (create-vector k)))
((>= i k) a)
(setf (aref a i)
(apply f (mapcar (lambda (x) (aref x i)) xs))))))
ISLisp>(vector-map (lambda (x) (* x x)) #(1 2 3 4 5)) #(1 4 9 16 25) ISLisp>(vector-map #'+ #(1 2 3) #(4 5 6)) #(5 7 9) ISLisp>(vector-map #'+ #(1 2 3) #(4 5 6) #(7 8 9)) #(12 15 18) ISLisp>(vector-map #'+ #(1 2 3) #(5 6) #(7 8 9)) #(13 16)
●解答10
リスト : ベクタ用の畳み込み関数
(defun vector-foldl (f a xs)
(for ((i 0 (+ i 1))
(a a (funcall f a (aref xs i))))
((>= i (length xs)) a)))
(defun vector-foldr (f a xs)
(for ((i (- (length xs) 1) (- i 1))
(a a (funcall f (aref xs i) a)))
((< i 0) a)))
ISLisp>(vector-foldl #'+ 0 #(1 2 3 4 5)) 15 ISLisp>(defun xcons (x y) (cons y x)) XCONS ISLisp>(vector-foldl #'xcons nil #(1 2 3 4 5)) (5 4 3 2 1) ISLisp>(vector-foldr #'+ 0 #(1 2 3 4 5)) 15 ISLisp>(vector-foldr #'cons nil #(1 2 3 4 5)) (1 2 3 4 5)
●騎士の巡歴
ナイト (騎士) はチェスの駒のひとつで将棋の桂馬の動きを前後左右にとることができます。次の図を見てください。
問題 : 騎士の巡歴
このナイトを動かして、N 行 M 列の盤面のどのマスにもちょうど一回ずつ訪れるような経路を求めるのが問題です。3 行 3 列、4 行 4 列の盤面には解がありませんが、5 行 5 列の盤面には解があります。今回は 5 行 5 列の盤面でナイトの移動経路を求めるプログラムを作ります。
盤面は 2 次元配列で表すことにします。この場合、騎士の移動手順は 5 行 5 列の盤面に記録したほうが簡単です。騎士が訪れていないマスを 0 とし、騎士の移動手順を 1 から始めれば、移動できるマスの判定を簡単に行うことができます。また、経路の出力も盤面を表示した方が直感的でわかりやすいかもしれません。
次は盤面の構成を考えましょう。単純な 5 行 5 列の 2 次元配列にすると、騎士が盤面から飛び出さないようにするため座標の範囲チェックが必要になります。このような場合、盤面の外側に壁を設定するとプログラムが簡単になります。
騎士は最大で 2 マス移動するので、壁の厚さも 2 マス用意します。したがって、盤面を表す配列は 9 行 9 列の大きさになります。壁に 0 以外の値 (1) を設定しておけば、騎士が盤面から飛び出して壁の位置に移動しようとしても、盤面の値が 0 ではないので実際に移動することはできません。これで騎士を移動したときの範囲チェックを省略することができます。
リスト : 騎士の巡歴
;; 盤面
(defglobal board nil)
;; 移動量
(defglobal dx #( 1 2 2 1 -1 -2 -2 -1))
(defglobal dy #(-2 -1 1 2 2 1 -1 -2))
;; 盤面の初期化
(defun init-board ()
(setq board (create-array '(9 9) 1))
(for ((i 2 (+ i 1)))
((>= i 7))
(for ((j 2 (+ j 1)))
((>= j 7))
(setf (aref board i j) 0)))
(setf (aref board 2 2) 1))
;; 盤面の表示
(defun print-board ()
(for ((x 2 (+ x 1)))
((>= x 7))
(for ((y 2 (+ y 1)))
((>= y 7))
(format (standard-output) "~D " (aref board x y)))
(format (standard-output) "~%"))
(format (standard-output) "~%"))
;; 解法
(defun solver (n x y)
(if (> n 25)
(print-board)
(for ((i 0 (+ i 1)))
((>= i 8))
(let ((x1 (+ x (aref dx i)))
(y1 (+ y (aref dy i))))
(cond ((= (aref board x1 y1) 0)
(setf (aref board x1 y1) n)
(solver (+ n 1) x1 y1)
(setf (aref board x1 y1) 0)))))))
(defun test ()
(init-board)
(solver 2 2 2))
配列 dx は騎士の x 方向の変位、配列 dy は y 方向の変位を表します。現在の座標にこの値を加えることで、次の座標を決定します。配列 board は盤面を表します。関数 init-board で、壁の部分は 1 に、実際の盤面は 0 に初期化しておきます。
関数 solver は引数として手数 n と騎士の座標 x, y を受け取ります。まず、n が 25 よりも大きくなったかチェックします。そうであれば、騎士はすべてのマスを訪れたので、関数 print_board で盤面を出力します。
そうでなければ、次に移動するマスを選びます。for で dx と dy の要素を取り出して x と y の値に加え、solver を再帰呼び出しします。再帰呼び出しから戻ってきたら、board の値を 0 に戻すことをお忘れなく。あとはとくに難しいところはないと思います。
1 16 21 10 25 20 11 24 15 22 17 2 19 6 9 12 7 4 23 14 3 18 13 8 5 ・・・省略・・・ 1 16 11 6 3 10 5 2 17 12 15 22 19 4 7 20 9 24 13 18 23 14 21 8 25 NIL
●５パズル
「15 パズル」でお馴染みのスライドパズルです。
スタートからゴールまでの最短手順を求めるプログラムを作ってください。
;;
;; five.l : 5 パズル
;;
;; Copyright (C) 2016 Makoto Hiroi
;;
(load "list.l")
;; 隣接リスト
;; 0 1 2
;; 3 4 5
(defglobal adjacent
#((1 3) (0 2 4) (1 5)
(0 4) (1 3 5) (2 4)))
;; アクセス関数
(defun get-board (xs) (first xs))
(defun get-space (xs) (second xs))
(defun get-prev (xs) (third xs))
;; キュー
(defglobal que (create-vector (* 3 4 5 6)))
(defglobal front 0)
(defglobal rear 0)
(defun enq (x)
(setf (aref que rear) x)
(setq rear (+ rear 1)))
(defun deq ()
(let ((x (aref que front)))
(setq front (+ front 1))
x))
(defun emptyp () (= front rear))
;; 同一局面のチェック
(defun check-same-state (x)
(block exit
(for ((i 0 (+ i 1)))
((>= i rear))
(if (equal (get-board (aref que i)) x)
(return-from exit t)))))
;; 手順の表示
(defun print-answer (st)
(if (get-prev st)
(print-answer (get-prev st)))
(format (standard-output) "~A~%" (get-board st)))
;; 幅優先探索
(defun solver (start goal)
(block exit
(enq (list start (char-index #\0 start) nil))
(while (not (emptyp))
(let* ((st (deq))
(sp (get-space st)))
(if (equal (get-board st) goal)
(progn
(print-answer st)
(return-from exit t))
(for-each
(lambda (x)
(let ((bd (subseq (get-board st) 0 6)))
(setf (elt bd sp) (elt bd x))
(setf (elt bd x) #\0)
(if (not (check-same-state bd))
(enq (list bd x st)))))
(aref adjacent sp)))))))
(defun test ()
(setq front 0)
(setq rear 0)
(solver "450123" "123450"))
;; アクセス関数
(defun get-move (xs) (third xs))
;; 最長手数の探索
(defun solver-max (start)
(enq (list start (char-index #\0 start) 0))
(while (not (emptyp))
(let* ((st (deq))
(sp (get-space st)))
(for-each
(lambda (x)
(let ((bd (subseq (get-board st) 0 6)))
(setf (elt bd sp) (elt bd x))
(setf (elt bd x) #\0)
(if (not (check-same-state bd))
(enq (list bd x (+ (get-move st) 1))))))
(aref adjacent sp))))
(for ((move (get-move (aref que (- rear 1))))
(i (- rear 1) (- i 1)))
((/= move (get-move (aref que i))))
(format (standard-output) "~D: ~A~%" move (get-board (aref que i)))))
(defun test-max ()
(setq front 0)
(setq rear 0)
(solver-max "123450"))
ISLisp>(load "five.l") T ISLisp>(test) 450123 405123 045123 145023 145203 105243 150243 153240 153204 153024 053124 503124 523104 523140 520143 502143 052143 152043 152403 102453 120453 123450 T ISLisp>(test-max) 21: 450123 NIL
最短手数は 21 手、これが最長手数の局面です。
●ハッシュ表
ISLisp には「ハッシュ表 (hash-table)」がないので、ILOS の簡単な例題としてハッシュ表 <hash> を作ってみました。アルゴリズムには「チェイン法」を使っています。アルゴリズムの詳しい説明は、拙作のページ Algorithms with Python ハッシュ法 をお読みください。
- create (class <hash>)
ハッシュ表の生成 (size でハッシュ表の大きさを指定できる) - gethash ht key
ハッシュ表 ht からキー (key) の値を求める。見つからない場合は nil を返す。 - sethash ht key val
ハッシュ表 ht にキー (key) と値 (val) を登録する。 - remhash ht key
ハッシュ表 ht からキー (key) を削除する。削除した場合は t を、キーが見つからない場合は nil を返す。 - clrhash ht
ハッシュ表 ht を空にする。 - hash-count ht
ハッシュ表に登録されている要素の個数を返す。 - maphash fn ht
ハッシュ表の要素 (key, val) に関数 fn を適用する。mapcar と違って fn の返り値は捨てられる。
ハッシュ表を使うにはキーを正の整数値に変換するメソッド hash-func を定義してください。デフォルトで定義されているデータ型は整数と文字列だけです。
;;
;; hash.l : ハッシュ表 (チェイン法)
;;
;; Copyright (C) 2016 Makoto Hiroi
;;
(load "list.l")
(defglobal default-hash-size 8191)
(defclass <hash> ()
((size :accessor hash-size :initform default-hash-size :initarg size)
(cnt :accessor hash-cnt :initform 0)
(table :accessor hash-table)))
(defmethod initialize-object :after ((h <hash>) xs)
(setf (hash-table h)
(create-vector (hash-size h) nil)))
(defgeneric hash-func (k))
(defgeneric gethash (h k))
(defgeneric sethash (h k v))
(defgeneric remhash (h k))
(defgeneric clrhash (h))
(defgeneric hash-count (h))
(defgeneric maphash (f h))
;; 整数
(defmethod hash-func ((n <integer>)) (abs n))
;; 文字列
(defmethod hash-func ((s <string>))
(for ((i 0 (+ i 1))
(a 0))
((>= i (length s)) a)
(setq a (+ (* a 8) (convert (elt s i) <integer>)))))
;; 探索
(defun find-cell (key xs)
(block exit
(for ((xs xs (cdr xs)))
((null xs))
(if (equal (caar xs) key)
(return-from exit (car xs))))))
(defmethod gethash ((h <hash>) key)
(let ((cp (find-cell key (aref (hash-table h)
(mod (hash-func key) (hash-size h))))))
(and cp (cdr cp))))
;; 挿入
(defmethod sethash ((h <hash>) key val)
(let* ((ht (hash-table h))
(hv (mod (hash-func key) (hash-size h)))
(cp (find-cell key (aref ht hv))))
(cond (cp
(setf (cdr cp) val))
(t
(setf (aref ht hv)
(cons (cons key val) (aref ht hv)))
(setf (hash-cnt h) (+ (hash-cnt h) 1))))
val))
;; 削除
(defmethod remhash ((h <hash>) key)
(let* ((ht (hash-table h))
(hv (mod (hash-func key) (hash-size h)))
(cp (find-cell key (aref ht hv))))
(cond (cp
(setf (aref ht hv)
(remove-if (lambda (x) (eq x cp)) (aref ht hv)))
(setf (hash-cnt h) (- (hash-cnt h) 1))
t)
(t nil))))
;; クリア
(defmethod clrhash ((h <hash>))
(setf (hash-cnt h) 0)
(for ((ht (hash-table h))
(i 0 (+ i 1)))
((>= i (hash-size h)))
(setf (aref ht i) nil)))
;; 要素の個数
(defmethod hash-count ((h <hash>)) (hash-cnt h))
;; マップ関数
(defmethod maphash (f (h <hash>))
(for ((i 0 (+ i 1)))
((>= i (hash-size h)))
(for ((xs (aref (hash-table h) i) (cdr xs)))
((null xs))
(funcall f (caar xs) (cdar xs)))))
ISLisp>(load "hash.l") T ISLisp>(defglobal h (create (class <hash>))) H ISLisp>(sethash h "foo" 10) 10 ISLisp>(sethash h "bar" 20) 20 ISLisp>(sethash h "baz" 20) 20 ISLisp>(sethash h "baz" 30) 30 ISLisp>(sethash h "oops" 40) 40 ISLisp>(hash-count h) 4 ISLisp>(gethash h "foo") 10 ISLisp>(gethash h "bar") 20 ISLisp>(gethash h "baz") 30 ISLisp>(gethash h "oops") 40 ISLisp>(gethash h "Oops") NIL ISLisp>(maphash (lambda (x y) (format (standard-output) "~A ~D~%" x y)) h) bar 20 baz 30 foo 10 oops 40 NIL ISLisp>(remhash h "foo") T ISLisp>(hash-count h) 3 ISLisp>(remhash h "foo") NIL ISLisp>(remhash h "bar") T ISLisp>(remhash h "baz") T ISLisp>(remhash h "oops") T ISLisp>(hash-count h) 0
;;
;; ハッシュ表のテスト
;;
(load "hash.l")
;; 線形合同法
;; 種 (seed)
(defglobal *seed* 1)
;; シードの設定
(defun srand (x) (setq *seed* x))
;; 整数の一様乱数
(defun irand ()
(setq *seed* (mod (+ (* 69069 *seed*) 1) #x100000000))
*seed*)
;; 実数の一様乱数
(defun random ()
(* (quotient 1.0 #x100000000) (irand)))
;; 0 以上 n 未満の整数を生成する
(defun make-number (n)
(floor (* n (random))))
;; 線形探索
(defun check-data (x xs n)
(block exit
(for ((i 0 (+ i 1)))
((>= i n) t)
(if (equal x (aref xs i))
(return-from exit nil)))))
;;
(defun test (n)
(let ((buff (create-vector n))
(m 0))
(while (< m n)
(let ((xs (list (make-number 256)
(make-number 256)
(make-number 256))))
(cond ((check-data xs buff m)
(setf (aref buff m) xs)
(setq m (+ m 1))))))))
;; ハッシュ関数
(defmethod hash-func ((key <list>))
(fold-left (lambda (a x) (+ a (* x 256))) 0 key))
;;
(defun test1 (n)
(let ((ht (create (class <hash>))))
(while (< (hash-count ht) n)
(let ((xs (list (make-number 256)
(make-number 256)
(make-number 256))))
(if (not (gethash ht xs))
(sethash ht xs t))))))
表 : 実行結果 (単位 : 秒)
個数 : 1000 : 2000 : 3000 : 4000
------+------+------+------+------
test : 0.23 : 0.81 : 1.76 : 3.09
test1 : 0.05 : 0.06 : 0.13 : 0.16
実行環境 : Windows 7, Core i7-2670QM 2.20GHz
●８パズル
図 : 8 パズル
スタートからゴールまでの最短手順を求めるプログラムを作ってください。
;;
;; eight.l : 8 パズルの解法 (双方向探索)
;;
;; Copyright (C) 2016 Makoto Hiroi
;;
(load "hash.l")
;; ハッシュ関数
(defmethod hash-func ((key <list>))
(fold-left (lambda (a x) (+ (* a 10) x)) 0 key))
;; 隣接リスト
;; 0 1 2
;; 3 4 5
;; 6 7 8
(defglobal adjacent
#((1 3) (0 2 4) (1 5)
(0 4 6) (1 3 5 7) (2 4 8)
(3 7) (4 6 8) (5 7)))
;; アクセス関数
(defun get-board (xs) (first xs))
(defun get-space (xs) (second xs))
(defun get-prev (xs) (third xs))
(defun get-dir (xs) (fourth xs))
;; 手順の表示
(defun print-answer-f (st)
(if (get-prev st)
(print-answer-f (get-prev st)))
(format (standard-output) "~A~%" (get-board st)))
(defun print-answer-b (st)
(while st
(format (standard-output) "~A~%" (get-board st))
(setq st (get-prev st))))
(defun print-answer (st1 st2)
(cond ((eq (get-dir st1) 'f)
(print-answer-f st1)
(print-answer-b st2))
(t
(print-answer-f st2)
(print-answer-b st1))))
;; キュー
(defglobal q (create-vector 181440))
(defglobal front 0)
(defglobal rear 0)
(defun enq (x)
(setf (aref q rear) x)
(setq rear (+ rear 1))
x)
(defun deq ()
(let ((x (aref q front)))
(setq front (+ front 1))
x))
(defun emptyp () (= front rear))
;; 幅優先探索 (双方向探索)
(defun solver (start goal)
(block exit
(let ((h (create (class <hash>))))
(sethash h start (enq (list start (position 0 start) nil 'f)))
(sethash h goal (enq (list goal (position 0 goal) nil 'b)))
(while (not (emptyp))
(let* ((st (deq))
(sp (get-space st)))
(for-each
(lambda (x)
(let ((bd (subseq (get-board st) 0 9)))
(setf (elt bd sp) (elt bd x))
(setf (elt bd x) 0)
(let ((st1 (gethash h bd)))
(cond ((null st1)
(sethash h bd (enq (list bd x st (get-dir st)))))
((not (eq (get-dir st) (get-dir st1)))
(print-answer st st1)
(return-from exit t))))))
(aref adjacent sp)))))))
(defun test ()
(setq front 0)
(setq rear 0)
(solver '(8 6 7 2 5 4 3 0 1) '(1 2 3 4 5 6 7 8 0)))
ISLisp>(test) (8 6 7 2 5 4 3 0 1) (8 6 7 2 0 4 3 5 1) (8 0 7 2 6 4 3 5 1) (0 8 7 2 6 4 3 5 1) (2 8 7 0 6 4 3 5 1) (2 8 7 3 6 4 0 5 1) (2 8 7 3 6 4 5 0 1) (2 8 7 3 6 4 5 1 0) (2 8 7 3 6 0 5 1 4) (2 8 0 3 6 7 5 1 4) (2 0 8 3 6 7 5 1 4) (2 6 8 3 0 7 5 1 4) (2 6 8 0 3 7 5 1 4) (2 6 8 5 3 7 0 1 4) (2 6 8 5 3 7 1 0 4) (2 6 8 5 3 7 1 4 0) (2 6 8 5 3 0 1 4 7) (2 6 0 5 3 8 1 4 7) (2 0 6 5 3 8 1 4 7) (2 3 6 5 0 8 1 4 7) (2 3 6 0 5 8 1 4 7) (2 3 6 1 5 8 0 4 7) (2 3 6 1 5 8 4 0 7) (2 3 6 1 5 8 4 7 0) (2 3 6 1 5 0 4 7 8) (2 3 0 1 5 6 4 7 8) (2 0 3 1 5 6 4 7 8) (0 2 3 1 5 6 4 7 8) (1 2 3 0 5 6 4 7 8) (1 2 3 4 5 6 0 7 8) (1 2 3 4 5 6 7 0 8) (1 2 3 4 5 6 7 8 0) T
OKI-ISLisp の場合、単純な幅優先探索ではすごく時間がかかったので、スタートとゴールの両方向から探索しています。これを「双方向探索」といいます。アルゴリズムの説明は拙作のページ Algorithms with Python 幅優先探索と反復進化 をお読みくださいませ。
ところで、盤面はリストではなく配列や文字列で表すこともできます。文字列を使う場合、空き場所 (0) を探索するため関数 position のかわりに char-index を使います。これで動作するはずですが、途中で OKI-ISLisp が落ちてしまいました。もっと短い手数の問題、たとえば "123450678" は解くことができました。M.Hiroi のプログラムに何か問題があるのかもしれません。お気づきの点がありましたらご教示お願いいたします。