素数
素数を求めるプログラムです。
●プログラム
リスト : 素数
;;; 素数のチェック
(define (prime? x ls)
(let loop ((ls ls))
(cond
((null? ls) #t)
((< (* x x) (car ls)) #t)
((zero? (modulo x (car ls))) #f)
(else
(loop (cdr ls))))))
;;; 素数を求める (単純版)
(define (prime n)
(let loop ((m 3) (ls '(2)))
(cond
((< n m) ls)
((prime? m ls)
(loop (+ m 2) (append ls (list m))))
(else
(loop (+ m 2) ls)))))
;;;
;;; エラトステネスの篩
;;;
;;; リスト版
(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 (remove pred xs)
(cond
((null? xs) '())
((pred (car xs))
(remove pred (cdr xs)))
(else
(cons (car xs) (remove pred (cdr xs))))))
(define (sieve1 n)
(let loop ((xs (iota (- n 1) 2)))
(if (null? xs)
#t
(let* ((p (car xs))
(ys (remove (lambda (x) (zero? (modulo x p))) (cdr xs))))
(display p)
(display " ")
(if (< n (* p p))
(for-each (lambda (x) (display x) (display " ")) ys)
(loop ys))))))
;;; vector 版
(define (sieve2 n)
(let ((p (make-vector (+ (quotient n 2) 1) #t)))
(display 2)
(display " ")
(do ((i 3 (+ i 2)) (j 1 (+ j 1)))
((< n (* i i))
(do ((i i (+ i 2)) (j j (+ j 1)))
((< n i))
(when
(vector-ref p j)
(display i)
(display " "))))
(when
(vector-ref p j)
(display i)
(display " ")
(do ((k (+ j i) (+ k i)))
((<= (vector-length p) k))
(vector-set! p k #f))))))
●実行例
gosh[r7rs.user]> (prime 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) gosh[r7rs.user]> (sive1 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 #<undef> gosh[r7rs.user]> (sieve2 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 #t
経路の探索
図 : 経路の探索
スタート (A) からゴール (G) までの経路を求めるプログラムです。
●プログラム
リスト : 経路の探索
;;; キュー (junk2.scm の Queue と同じ)
(define-record-type Queue
(make-queue front rear)
queue?
(front front set-front!)
(rear rear set-rear!))
(define (queue-empty? q) (null? (front q)))
(define (enqueue! q x)
(let ((cell (list x)))
(if (queue-empty? q)
(set-front! q cell)
(set-cdr! (rear q) cell))
(set-rear! q cell)))
(define (dequeue! q)
(if (queue-empty? q)
(error "dequeue!: empty queue")
(let ((x (car (front q))))
(set-front! q (cdr (front q)))
(when
(null? (front q))
(set-rear! q '()))
x)))
(define (queue-length q)
(length (front q)))
;;; 隣接リスト (連想リストで表現)
(define *adjacent*
'((a b c)
(b a c d)
(c a b e)
(d b e f)
(e c d g)
(f d)
(g e)))
;;; 深さ優先探索
(define (depth-first-search goal path)
(cond
((eq? goal (car path))
(display (reverse path))
(newline))
(else
(for-each
(lambda (n)
(unless
(memq n path)
(depth-first-search goal (cons n path))))
(assq (car path) *adjacent*)))))
;;; 幅優先探索 (junk2.scm の Queue を使う)
(define (breadth-first-search start goal)
(let ((q (make-queue '() '())))
(enqueue! q (list start))
(do ()
((queue-empty? q))
(let ((path (dequeue! q)))
(cond ((eq? (car path) goal)
(display (reverse path))
(newline))
(else
(for-each
(lambda (n)
(unless (memq n path)
(enqueue! q (cons n path))))
(assq (car path) *adjacent*))))))))
;;; 反復深化
(define (id-search start goal)
(define (dfs limit goal path)
(cond
((= limit (length path))
(when (eq? (car path) goal)
(display (reverse path))
(newline)))
(else
(for-each
(lambda (n)
(unless (memq n path)
(dfs limit goal (cons n path))))
(assq (car path) *adjacent*)))))
;;
(do ((n 1 (+ n 1)))
((> n 7))
(display n) (display " moves\n")
(dfs n 'g '(a))))
●実行例
gosh[r7rs.user]> (depth-first-search 'g '(a)) (a b c e g) (a b d e g) (a c b d e g) (a c e g) #<undef> gosh[r7rs.user]> (breadth-first-search 'a 'g) (a c e g) (a b c e g) (a b d e g) (a c b d e g) #t gosh[r7rs.user]> (id-search 'a 'g) 1 moves 2 moves 3 moves 4 moves (a c e g) 5 moves (a b c e g) (a b d e g) 6 moves (a c b d e g) 7 moves #t
ハノイの塔
ハノイの塔は、棒に刺さっている大きさが異なる複数の円盤を、次の規則に従ってほかの棒に移動させるパズルです。
- 一回に一枚の円盤しか移動できない。
- 小さな円盤の上に大きな円盤を置くことはできない。
- 最初すべての円盤は一本の棒に刺さっていて、各円盤はそれより大きな円盤の上に置かれている。
ハノイの塔は、再帰を使えば簡単に解ける問題です。
●プログラム
リスト : ハノイの塔
(define (print-disk n from to)
(display "disk ") (display n)
(display ": form ") (display from)
(display " to ") (display to)
(newline))
(define (hanoi n from to via)
(cond ((= n 1)
(print-disk n from to))
(else
(hanoi (- n 1) from via to)
(print-disk n from to)
(hanoi (- n 1) via to from))))
●実行結果
gosh[r7rs.user]> (hanoi 3 'a 'b 'c) disk 1: form a to b disk 2: form a to c disk 1: form b to c disk 3: form a to b disk 1: form c to a disk 2: form c to b disk 1: form a to b #<undef> gosh[r7rs.user]> (hanoi 4 'a 'b 'c) disk 1: form a to c disk 2: form a to b disk 1: form c to b disk 3: form a to c disk 1: form b to a disk 2: form b to c disk 1: form a to c disk 4: form a to b disk 1: form c to b disk 2: form c to a disk 1: form b to a disk 3: form c to b disk 1: form a to c disk 2: form a to b disk 1: form c to b #<undef>
小町算
[問題] 小町算
1 から 9 までの数字を順番に並べ、間に + と - を補って 100 になる式を作ってください。
例：1 + 2 + 3 - 4 + 5 + 6 + 78 + 9 = 100
パズルの世界では、1 から 9 までの数字を 1 個ずつすべて使った数字を「小町数」といいます。たとえば、123456789 とか 321654987 のような数字です。「小町算」というものもあり、たとえば 123 + 456 + 789 とか 321 * 654 + 987 のようなものです。この問題は小町算の中でも特に有名なパズルです。
●プログラム
リスト : 小町算
;;; 式の表示
(define (print-expr expr m)
(for-each (lambda (x) (display x) (display " ")) expr)
(display " = ")
(display m)
(newline))
;;; 式の計算
(define (calc-expr expr m)
(let loop ((xs (cdr expr)) (a (car expr)))
(if (null? xs)
(when
(= a m)
(print-expr expr m))
(loop (cddr xs)
(if (eq? (car xs) '+)
(+ a (cadr xs))
(- a (cadr xs)))))))
;;; 式の生成
(define (make-expr n expr m)
(cond
((= n 10)
(calc-expr (reverse expr) m))
(else
(make-expr (+ n 1) (cons n (cons '+ expr)) m)
(make-expr (+ n 1) (cons n (cons '- expr)) m)
(make-expr (+ n 1) (cons (+ (* (car expr) 10) n) (cdr expr)) m))))
;;; 実行
(define (komachi m) (make-expr 2 '(1) m))
●実行結果
gosh[r7rs.user]> (komachi 100) 1 + 2 + 3 - 4 + 5 + 6 + 78 + 9 = 100 1 + 2 + 34 - 5 + 67 - 8 + 9 = 100 1 + 23 - 4 + 5 + 6 + 78 - 9 = 100 1 + 23 - 4 + 56 + 7 + 8 + 9 = 100 12 + 3 + 4 + 5 - 6 - 7 + 89 = 100 12 + 3 - 4 + 5 + 67 + 8 + 9 = 100 12 - 3 - 4 + 5 - 6 + 7 + 89 = 100 123 + 4 - 5 + 67 - 89 = 100 123 + 45 - 67 + 8 - 9 = 100 123 - 4 - 5 - 6 - 7 + 8 - 9 = 100 123 - 45 - 67 + 89 = 100 #<undef>
騎士の巡歴
騎士（ナイト）はチェスの駒のひとつで、将棋の桂馬の動きを前後左右にとることができます。次の図を見てください。
このナイトを動かして、 N 行 M 列の盤面のどのマスにもちょうど一回ずつ訪れるような経路を求めるのが問題です。ちなみに、3 行 3 列、4 行 4 列の盤面には解がありませんが、5 行 5 列の盤面には解があります。大きな盤面を解くのは大変なので、問題 A の盤面でナイトの移動経路を求めてください。プログラムを作る前に、自分で考えてみるのも面白いでしょう。
●プログラム
リスト : 騎士の巡歴
;;; 隣接リスト
(define *adjacent-knight*
#((5 6 8) ; 0
(2 7 9) ; 1
(1 8 10) ; 2
(9 11) ; 3
(6 10) ; 4
(0 7 11) ; 5
(0 4 11) ; 6
(1 5) ; 7
(0 2) ; 8
(1 3 10) ; 9
(2 4 9) ; 10
(3 5 6))) ; 11
;;; 単純な深さ優先探索
(define (knight-tour n path)
(cond
((= n 12)
;; 解を発見
(display (reverse path))
(newline))
(else
(for-each
(lambda (x)
(unless
(memv x path)
(knight-tour (+ n 1) (cons x path))))
(vector-ref *adjacent-knight* (car path))))))
;;; 実行
;;; (knight-tour 1 '(0))
●実行例
gosh[r7rs.user]> (knight-tour 1 '(0)) (0 5 7 1 9 3 11 6 4 10 2 8) (0 6 4 10 9 3 11 5 7 1 2 8) (0 8 2 1 7 5 11 3 9 10 4 6) (0 8 2 1 7 5 11 6 4 10 9 3) (0 8 2 10 4 6 11 3 9 1 7 5) (0 8 2 10 4 6 11 5 7 1 9 3) #<undef>
８クイーン
[問題] ８クイーン
8 クイーンは 8 行 8 列のチェスの升目に 8 個のクイーンを互いの利き筋が重ならないように配置する問題です。これはコンピュータに解かせるパズルの中でもとくに有名な問題です。クイーンは将棋の飛車と角をあわせた駒で、縦横斜めに任意に動くことができます。解答の一例を次に示します。
図 : 8 クイーンの解答例
●プログラム
リスト : 8 クイーン
;;; 盤面の表示
(define (print-board board)
(define (print-line q size)
(display "| ")
(let loop ((x 0))
(when (< x size)
(if (= x q)
(display "Q ")
(display ". "))
(loop (+ x 1))))
(display "|\n"))
(define (print-waku size)
(display "*-")
(let loop ((x 0))
(when (< x size)
(display "--")
(loop (+ x 1))))
(display "*\n"))
(let ((size (length board)))
(print-waku size)
(let loop ((ls board))
(when (pair? ls)
(print-line (car ls) size)
(loop (cdr ls))))
(print-waku size)
(newline)))
;;; 衝突するか
(define (attack x xs)
(define (attack-sub x n ls)
(cond ((null? ls) #t)
((or (= x (+ (car ls) n))
(= x (- (car ls) n)))
#f)
(else
(attack-sub x (+ n 1) (cdr ls)))))
(attack-sub x 1 xs))
; 8 クイーンの解法
(define (queen nums board)
(if (null? nums)
(print-board board)
(for-each
(lambda (x)
(if (attack x board)
(queen (remove (lambda (y) (eqv? x y)) nums) (cons x board))))
nums)))
;;; 実行
;;; (queen (iota 8) '())
●実行例
gosh[r7rs.user]> (queen (iota 4) '()) *---------* | . . Q . | | Q . . . | | . . . Q | | . Q . . | *---------* *---------* | . Q . . | | . . . Q | | Q . . . | | . . Q . | *---------* #<undef> gosh[r7rs.user]> (queen (iota 8) '()) *-----------------* | . . . Q . . . . | | . Q . . . . . . | | . . . . . . Q . | | . . Q . . . . . | | . . . . . Q . . | | . . . . . . . Q | | . . . . Q . . . | | Q . . . . . . . | *-----------------* ・・・省略・・・ *-----------------* | . . . . Q . . . | | . . . . . . Q . | | . Q . . . . . . | | . . . . . Q . . | | . . Q . . . . . | | Q . . . . . . . | | . . . Q . . . . | | . . . . . . . Q | *-----------------* #<undef>
8 Queens の場合、解は重複解を含めて全部で 92 通りです。
８パズル
[問題] 8 パズル
8 パズルは上図 GOAL のように 1 から 8 までの駒を並べるパズルです。駒の動かし方は、1 回に 1 個の駒を空いている隣の場所に滑らせる、というものです。駒を飛び越したり持ち上げたりすることはできません。今回は GOAL までの最長手数とその局面をすべて求めてください。
●プログラム
以下のプログラムは拙作のページ Scheme 入門: パズルの解法編 パズルの解法 [2] と同じです。詳しい説明はそちらのページをお読みくださいませ。
;;;
;;; eight2.scm : 8 Puzzle の解法 (最長手数の探索)
;;;
;;; Copyright (C) 2008-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write) (scheme time)
(mylib hash))
;;; 盤面の大きさ
(define *size* 9)
;;; 隣接リスト
(define *adjacent*
#((1 3) ; 0
(0 2 4) ; 1
(1 5) ; 2
(0 4 6) ; 3
(1 3 5 7) ; 4
(2 4 8) ; 5
(3 7) ; 6
(4 6 8) ; 7
(5 7))) ; 8
;;; 局面の定義
(define-record-type State
(make-state board space move)
state?
(board get-board)
(space get-space)
(move get-move))
;;; 盤面の表示
(define (print-board board)
(let loop ((i 0))
(when
(< i *size*)
(display (vector-ref board i))
(display " ")
(if (or (= i 2) (= i 5) (= i 8)) (newline))
(loop (+ i 1))))
(newline))
;;; 解の表示
(define (print-answer state)
(display (get-move state))
(display ":\n")
(print-board (get-board state)))
;;; 駒の移動
(define (move-piece board space pos)
(let ((new-board (vector-copy board)))
(vector-set! new-board space (vector-ref new-board pos))
(vector-set! new-board pos 0)
new-board))
;;; ベクタの畳み込み
(define (vector-foldl fn a vec)
(vector-for-each (lambda (x) (set! a (fn a x))) vec)
a)
;;; ハッシュ関数
(define (hash-func board)
(vector-foldl (lambda (a x) (+ (* a *size*) x)) 0 board))
;;; 畳み込み
(define (foldl fn a xs)
(if (null? xs)
a
(foldl fn (fn a (car xs)) (cdr xs))))
;;; 最長手数の探索
(define (solver)
;; ハッシュ表
(define ht (make-hash-table 181499 hash-func equal?))
;; 幅優先探索
(define (bfs xs)
(let ((ys (foldl
(lambda (a st)
(let ((sp (get-space st))
(bd (get-board st)))
(foldl
(lambda (b x)
(let ((newbd (move-piece bd sp x)))
(cond
((hash-find ht newbd) b)
(else
(hash-set! ht newbd #t)
(cons (make-state newbd x (+ (get-move st) 1)) b)))))
a
(vector-ref *adjacent* sp))))
'()
xs)))
(if (pair? ys)
(bfs ys)
(for-each print-answer xs))))
;;
(let* ((start #(1 2 3 4 5 6 7 8 0))
(init-state (make-state start 8 0)))
(hash-set! ht start #t)
(bfs (list init-state))))
;;; 実行
(let ((s (current-jiffy)))
(solver)
(display (inexact (/ (- (current-jiffy) s) (jiffies-per-second))))
(newline))
●実行例
$ gosh -A . eight2.scm 31: 8 6 7 2 5 4 3 0 1 31: 6 4 7 8 5 0 3 2 1 1.8657366
三目並べ
三目並べは、皆さんお馴染みの二人で対戦するゲームです。ひとりが○側でもうひとりが×側を受け持ち、3 行 3 列のマス目に○×を書いて、3 つ並べた方が勝ちというゲームです。次の図は○側が先手で引き分けになった例です。
参考文献 1 によると、三目並べで両者が次の戦略を用いると、ゲームは常に引き分けになります。
- 3 つ並べることができるならばそうする
- 相手が 3 つ並べるのを妨げる
- 可能ならば中央へ着手する
- 可能ならば隅へ着手する
以下のプログラムで関数 play を実行すると、この戦略で指し手を選びます。また、三目並べは両者が最善を尽くすと引き分けになることが知られています。関数 solver を実行すると、ミニマックス法を使って初手がどこでも結果は引き分けになることを確かめます。
なお、以下のプログラムは拙作のページ Scheme 入門: 思考ルーチン編 ミニマックス法と三目並べ と同じです。詳しい説明はそちらのページをお読みくださいませ。
●参考文献
- 松原仁・竹内郁雄 編著,『bit別冊 ゲームプログラミング』, 共立出版, 1997
●プログラム
;;;
;;; tictactoe.scm : 三目並べ (ミニマックス法)
;;;
;;; Copyright (C) 2010-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write)
(mylib list))
;;; 定数
(define SIZE 9)
(define MARU 1)
(define DRAW 0)
(define BATU -1)
(define MAX-VALUE 2)
(define MIN-VALUE -2)
;;; 盤面 : #f space, O maru, X batu
;;; 0 1 2
;;; 3 4 5
;;; 6 7 8
(define *board* (make-vector SIZE #f))
;;; 直線
(define *lines*
#(((1 2) (3 6) (4 8)) ; 0
((0 2) (4 7)) ; 1
((0 1) (5 8) (4 6)) ; 2
((0 6) (4 5)) ; 3
((1 7) (3 5) (0 8) (2 6)) ; 4
((2 8) (3 4)) ; 5
((0 3) (2 4) (7 8)) ; 6
((1 4) (6 8)) ; 7
((0 4) (2 5) (6 7)))) ; 8
;;; アクセス関数
(define (get-piece n) (vector-ref *board* n))
(define (put-piece! n p) (vector-set! *board* n p))
(define (del-piece! n) (vector-set! *board* n #f))
;;; p が 3 つ並ぶか
(define (check-line? p a b)
(and (eq? (get-piece a) p) (eq? (get-piece b) p)))
;;; 勝負の判定
(define (win? n p)
(let loop ((ls (vector-ref *lines* n)))
(if (null? ls)
#f
(or (apply check-line? p (car ls))
(loop (cdr ls))))))
;;; 先手 (まる)
(define (think-maru n)
(if (= n SIZE)
DRAW
(let loop ((x 0) (value MIN-VALUE))
(cond
((= x SIZE) value)
((get-piece x)
(loop (+ x 1) value))
((win? x 'O) BATU) ; MARU)
(else
(put-piece! x 'O)
(let ((v (think-batu (+ n 1))))
(del-piece! x)
(loop (+ x 1) (max v value))))))))
;;; 後手 (ばつ)
(define (think-batu n)
(if (= n SIZE)
DRAW
(let loop ((x 0) (value MAX-VALUE))
(cond
((= x SIZE) value)
((get-piece x)
(loop (+ x 1) value))
((win? x 'X) MARU); BATU)
(else
(put-piece! x 'X)
(let ((v (think-maru (+ n 1))))
(del-piece! x)
(loop (+ x 1) (min v value))))))))
;;; 三目並べの解法
(define (solver)
(do ((x 0 (+ x 1)))
((>= x SIZE))
(put-piece! x 'O)
(display x) (display ":value = ")
(display (think-batu 1))
(newline)
(del-piece! x)))
;;;
;;; 戦略に基づいたプレイ
;;;
;;; 勝てる場所を探す
(define (get-win-position p xs)
(find-if (lambda (x) (and (not (get-piece x)) (win? x p))) xs))
;;; 空いているコーナーを探す
(define (get-corner)
(find-if (lambda (x) (not (get-piece x))) '(0 2 6 8)))
;;; COM の指し手
(define (move-com p xs)
(or (get-win-position p xs)
(get-win-position (if (eq? p 'O) 'X 'O) xs)
(and (not (get-piece 4)) 4)
(get-corner)
(car xs)))
;;; 盤面の表示
(define (print-piece p)
(display (if p p '_))
(display " "))
(define (print-board)
(do ((x 0 (+ x 1)))
((>= x SIZE) (newline))
(if (zero? (modulo x 3)) (newline))
(print-piece (get-piece x))))
;;; ゲームの進行
(define (play)
(vector-fill! *board* #f)
(let loop ((xs (iota 9 0)) (turn 'O))
(if (null? xs)
(display "DRAW\n")
(let ((x (move-com turn xs)))
(put-piece! x turn)
(print-board)
(cond
((win? x turn)
(display turn)
(display " WIN!\n"))
(else
(loop (remove x xs) (if (eq? turn 'O) 'X 'O))))))))
●実行例
gosh[r7rs.user]> (play) _ _ _ _ O _ _ _ _ X _ _ _ O _ _ _ _ X _ O _ O _ _ _ _ X _ O _ O _ X _ _ X _ O O O _ X _ _ X _ O O O X X _ _ X _ O O O X X _ O X X O O O X X _ O X X O O O X X O O DRAW #<undef>
確かに引き分けになりました。
gosh[r7rs.user]> (solver) 0: value = 0 1: value = 0 2: value = 0 3: value = 0 4: value = 0 5: value = 0 6: value = 0 7: value = 0 8: value = 0 #t
初手がどこでも引き分け (value = 0) になります。