8パズルを解くプログラムを作ってみた

もっと効率の良い方法とかあるかも＞＜。

(use srfi-1)
(use gauche.sequence)
;;[1 2 3]
;;[4 5 6]
;;[7 8 ()]という形にしたら終了

;;※空白は'()で表す。
;;※上の表の状態はプログラム上では「(1 2 3 4 5 6 7 8 ())」と表す。

(define (make-state l)
  (if (= 9 (length l)) l (error "list size is must be 9")))

(define (search-index  x l)
  (fold-with-index 
   (lambda (i e it) (if (eq? x e) i it))
   'None l))

(define (search-empty l) (search-index '() l))

(define (get-swaped-point l)
  (let* ((n (search-empty l))
         (cands (list (+ n 1) (- n 1) (+ n 3) (- n 3))))
    (values (filter (lambda (n) (and (>= n 0) (<= n 8))) cands)
            n)))

(define (swap idx1 idx2 l)
  (map-with-index 
   (lambda (i e)
     (cond ((= i idx1) (ref l idx2))
           ((= i idx2) (ref l idx1))
           (else e)))
   l))

(define goal (make-state (append (iota 8 1) (list '()))))


;; ;;一つみつかればいい程度でいいかも
;; (define (run state)
;;   (let ((find-path? #f))
;;     (let ((end (lambda (re)
;;                   (set! find-path? #t)
;;                   (print re))))
;;       (let iter ((state state) (history '()))
;;         (unless find-path?
;;           (unless (member state history)
;;             (receive (cands empty-pos) 
;;                 (get-swaped-point state)
;;               (dolist (n (select cands))
;;                 (let1 next (swap n empty-pos state)
;;                   (if (equal? next goal)
;;                       (end (reverse (cons next (cons state history))))
;;                       (iter next (cons state history))))))))))))
;;これだと、1度の探索で1つの候補しか判断してない。

(use srfi-27)
(use srfi-42)

;;いろんな状態を渡せるようにしよう。
(define (shuffle-list l)
  (let1 lst (list-ec (: e l) (list (random-real) e))
    (map cadr (sort! lst (lambda (x y) (> (car x) (car y)))))))


;;goalに近い状態を選んでみよう。
(define (count-matching-element state)
  (fold (lambda (x y count)
          (if (eqv? x y) (+ count 1) count))
        0 goal state))
      
;; (define (select states)
;;   (find-max states :key count-matching-element))

(define (run state)
  (let ((find-path? #f)
        (result '()))
    (define (end re)
      (set! find-path? #t)
      (set! result re))
    (define (next-cands state)
      (receive (ns empty-pos) 
          (get-swaped-point state)
        (sort (map (cut swap <> empty-pos state) ns)
              (lambda (x y)
                (> (count-matching-element x)
                   (count-matching-element y))))))
    (let iter ((state state) (history '()))
      (unless find-path?
        (unless (member state history)
          (dolist (next (next-cands state))
            (if (equal? next goal)
                (end (reverse (cons next (cons state history))))
                (iter next (cons state history)))))))
  result)
)

;;shuffle-listを使って初期状態を作ると解けない問題がでてくる（のかなー？いつまでたっても計算が終わらない）。
;;必ず解ける問題を作るにはgoalから問題をつくる必要があるかも。

(define (make-problem n)
  (define (choose-state state)
    (receive (ns empty-pos)
        (get-swaped-point state)
      (let1 n (car (shuffle-list ns))
        (swap empty-pos n state))))
  (let iter ((state goal) (n n))
    (if (zero? n)
        state
        (iter (choose-state state) (- n 1)))))

時間とか計ってみる

(use gauche.time)
(define (bench thunk)
  (let1 t (make <real-time-counter>)
    (with-time-counter t (thunk))
    (print (time-counter-value t))))

(let1 ls (list-ec (: i 10) (make-problem 100))
  (for-each
   (lambda (p) (bench (lambda () (run p))))
   ls))


(let1 p (make-problem 100)
  (print p)
  (print (count-matching-element p))
  (print (length (run p)))
)

ファイルを指定して実行

gosh -I ./ -l 8puzzle.scm 8puzzle.tmp.scm

結果

0.017354
0.13862300000000005
0.001147
0.033938
0.125614
0.395092
0.121132
0.185637
0.026089
0.22393799999999997

(3 6 4 5 () 7 1 2 8)
0
935

935回の移動とか多すぎ＞＜。