Gauche を使って、パズルの探索を行うプログラムです (不完全版)。

cocoro.scm

;; -*- coding: utf-8 -*-
;;
;; cocoro.scm
;; 2019-6-23 v1.11
;;
;; ＜内容＞
;;   Gauche を使って、パズル ( https://game.nicovideo.jp/atsumaru/games/gm8913 )
;;   の探索を行うプログラムです (不完全版)。
;;
;; ＜使い方＞
;;   下の map-data 変数に地図データを設定して実行すると、ゴールの探索を行います。
;;   (文字の意味は chr-table 参照)
;;   10000 ステップ探索するごとに、途中経過を表示します。
;;   ゴールが見つかった場合には、例えば (R R U L) のようにルートを表示します。
;;   (シンボル U D L R が上下左右に対応)
;;   探索ステップ数が scount-max を超えた場合には、
;;   ハートが取れていない局面を削除(掃除)して探索を続行し、
;;   それでも見つからなければ、ギブアップします。
;;
(use gauche.uvector)
(use gauche.version)

;; for Gauche v0.9.5
(define hash-table-from-pairs
  (if (global-variable-bound? 'gauche 'hash-table-from-pairs)
    (with-module gauche hash-table-from-pairs)
    hash-table))

;; u8vector をハッシュテーブルのキーに使えるようにする
;; (Gauche v0.9.8 からは、デフォルトで使用可能)
(when (guard (ex (else #t)) (default-hash #u8(1)) #f)
  ;; for Gauche v0.9.4 - v0.9.7
  (if (version<=? (gauche-version) "0.9.4")
    ;; 文字列に変換した方が少しだけ省メモリになる
    ;;   ベクタに変換 L66 (2000000) : 使用メモリ = 物1437M + 仮1740M
    ;;   文字列に変換 L66 (2000000) : 使用メモリ = 物1380M + 仮1669M
    ;;   Gauche改造   L66 (2000000) : 使用メモリ = 物 979M + 仮1279M
    (define-method object-hash ((obj <u8vector>))
      ;(hash (u8vector->vector obj)))
      (hash (u8vector->string obj)))
    (define-method object-hash ((obj <u8vector>) rec-hash)
      ;(rec-hash (u8vector->vector obj)))
      (rec-hash (u8vector->string obj)))
      ))

(define map-data ; 地図データ(文字列のリスト)
#;'("       "    ;   L48 - ok      (4002721) scount-max=2000000
    "       "
    "V     V"
    "       "
    "R  H   "
    "G++++++")

  '("    V  "    ;   L66 - give up (3949547) scount-max=2000000
    "  V O  "    ;       - ok      (5873012) scount-max=3000000
    " RO    "
    " G-H++H"
    "H-     ")

  )

(define mw (string-length (car map-data))) ; 地図の幅
(define mh (length map-data))              ; 地図の高さ
(define msize (* mw mh))  ; 地図のサイズ
(define (pt x y)          ; 配列番号への変換
  (+ (* y mw) x))
(define (in? x y)         ; 範囲チェック
  (and (<= 0 x) (< x mw) (<= 0 y) (< y mh)))
(define chr-table         ; 文字テーブル
  ;                       ;   (アルファベットの大文字小文字は区別しない)
  ($ hash-table-from-pairs 'eqv?
     '(#\space . #x00)    ;   空白
     '(#\R     . #x10)    ;   ロボット
     '(#\G     . #x02)    ;   ゴール
     '(#\V     . #x03)    ;   ハート
     '(#\O     . #x04)    ;   固定ブロック
     '(#\+     . #x05)    ;   交換ブロック
     '(#\H     . #x06)    ;   はしご
     '(#\-     . #x07)    ;   鉄棒
     '(#\@     . #x12)    ;   ロボット+ゴール
     '(#\N     . #x16)    ;   ロボット+はしご
     '(#\T     . #x17)    ;   ロボット+鉄棒
     '(#\!     . #x80)    ;   無効/エラー
     ))
(define chr-rev-table     ; 文字逆引きテーブル
  (alist->hash-table
   (map (lambda (x) (cons (cdr x) (car x)))
        (hash-table->alist chr-table))
   'eqv?))
(define dup-search-table  ; 局面の重複検索用テーブル
  (make-hash-table 'equal?))
(define goal-flag    #f)  ; ゴールフラグ
(define goal-sp      #f)  ; ゴールに到達した探索点
(define vcount       0)   ; ハートの数
(define vcount-sweep 0)   ; ハートの数(掃除用)
(define sps          '()) ; 探索点のリスト
(define scount       -1)  ; 探索ステップ数のカウンタ
(define scount-max   2000000) ; 探索ステップ数の最大値(ギブアップ用)

;; 探索点クラス
(define-class <search-point> ()
  ((rx    :init-value 0)  ; ロボットのX座標
   (ry    :init-value 0)  ; ロボットのY座標
   (vc    :init-value 0)  ; ハートの数
   (prev  :init-value #f) ; 移動元の探索点
   (next  :init-value #f) ; 次の探索点
   (move  :init-value #f) ; 移動情報(シンボル U D L R が上下左右に対応)
   (mdata :init-form (make-u8vector msize 0))
   ;                      ; 地図データ(u8vector)
   ;                      ;   (掃除後は #f になるので注意)
   ))
(define (search-point-copy sp rx ry move)
  ;; (目的に特化したコピーなので注意)
  (define sp2 (make <search-point>))
  (slot-set! sp2 'rx   rx)
  (slot-set! sp2 'ry   ry)
  (slot-set! sp2 'vc   (slot-ref sp 'vc))
  (slot-set! sp2 'prev sp)
  (slot-set! sp2 'move move)
  (u8vector-copy! (slot-ref sp2 'mdata) 0 (slot-ref sp 'mdata))
  sp2)
(define (mdata-get  mdata x y)
  ;; (目的に特化したデータ取得なので注意)
  (if-let1 data (u8vector-ref mdata (pt x y) #f)
    (logand #x0f data) ; ロボット以外を返す
    #x80))             ; 無効/エラー
(define (mdata-on!  mdata x y d)
  (u8vector-set! mdata (pt x y)
                 (logior (u8vector-ref mdata (pt x y)) d)))
(define (mdata-off! mdata x y d)
  (u8vector-set! mdata (pt x y)
                 (logand (u8vector-ref mdata (pt x y)) (lognot d))))
(define (mdata-move-ok? sp x y)
  (define mdata (slot-ref sp 'mdata))
  (not (= (mdata-get mdata x y) #x04))) ; 固定ブロック
(define (search-point-print sp)
  (define mdata (slot-ref sp 'mdata))
  (print scount ":")
  ;; 地図データの表示
  (when mdata
    (let loop ((x 0) (y 0))
      (let* ((data (u8vector-ref mdata (pt x y) #x80))
             (chr  (hash-table-get chr-rev-table data #\!)))
        (when (= x 0)        (display "  \""))
        (display chr)
        (when (= x (- mw 1)) (display "\"") (newline))
        (cond
         ((< x (- mw 1)) (loop (+ x 1) y))
         ((< y (- mh 1)) (loop 0 (+ y 1)))))))
  ;; ここまでのルートの表示
  (let loop ((sp sp) (route '()))
    (let ((prev (slot-ref sp 'prev))
          (move (slot-ref sp 'move)))
      (if prev
        (loop prev (cons move route))
        (print "  " route))))
  (flush))

;; 地図データの読み込み
(define (read-map)
  (define sp    (make <search-point>))
  (define mdata (slot-ref sp 'mdata))
  (let loop ((x 0) (y 0))
    (let* ((chr  (char-upcase (string-ref (list-ref map-data y) x)))
           (data (hash-table-get chr-table chr #x80)))
      (mdata-on! mdata x y data)
      (cond
       ((= (logand data #xf0) #x10) ; ロボット
        (slot-set! sp 'rx x)
        (slot-set! sp 'ry y))
       ((= (logand data #x0f) #x03) ; ハート
        (inc! vcount)
        (set! vcount-sweep vcount)
        (slot-set! sp 'vc vcount)))
      (cond
       ((< x (- mw 1)) (loop (+ x 1) y))
       ((< y (- mh 1)) (loop 0 (+ y 1))))))
  sp)

;; 判定と落下処理
(define (check-and-fall-down sp)
  (define rx    (slot-ref sp 'rx))
  (define ry0   (slot-ref sp 'ry))
  (define ry    (slot-ref sp 'ry))
  (define vc    (slot-ref sp 'vc))
  (define mdata (slot-ref sp 'mdata))
  ;; 判定と落下処理のループ
  (let loop ()
    (case (mdata-get mdata rx ry)
      ((#x00) ; 空白
       (when (memv (mdata-get mdata rx (+ ry 1)) ; 1個下
                   '(#x00 #x03 #x07)) ; 空白/ハート/鉄棒
         (inc! ry)
         (slot-set! sp 'ry ry)
         (loop)))
      ((#x02) ; ゴール
       (set! goal-flag #t))
      ((#x03) ; ハート
       (dec! vc)
       (slot-set! sp 'vc vc)
       (mdata-off! mdata rx ry #x03)
       (loop))))
  ;; ロボットの移動
  (unless (= ry0 ry)
    (mdata-off! mdata rx ry0 #x10)
    (mdata-on!  mdata rx ry  #x10))
  sp)

;; 局面の重複チェック
;; (ここがボトルネックになっているもよう)
;; (ハッシュテーブルにしたら 100 倍以上速くなった。。。)
(define (map-data-dup? mdata)
  ;(find (lambda (sp)
  ;        (equal? (slot-ref sp 'mdata) mdata))
  ;      sps)
  (hash-table-exists? dup-search-table mdata)
  )

;; 探索点の追加
(define (search-point-add sp move)
  (define rx  (slot-ref sp 'rx))
  (define ry  (slot-ref sp 'ry))
  (define rx2 (+ rx (case move ((L) -1) ((R) +1) (else 0))))
  (define ry2 (+ ry (case move ((U) -1) ((D) +1) (else 0))))
  ;; 範囲チェックと移動可能チェック
  (when (and (in? rx2 ry2) (mdata-move-ok? sp rx2 ry2))
    ;; 探索点を生成
    (let* ((sp2    (search-point-copy sp rx2 ry2 move))
           (vc2    (slot-ref sp2 'vc))
           (mdata2 (slot-ref sp2 'mdata))
           (data1  (mdata-get mdata2 rx  ry))
           (data2  (mdata-get mdata2 rx2 ry2)))
      ;; ロボットの移動
      (mdata-off! mdata2 rx  ry  #x10)
      (mdata-on!  mdata2 rx2 ry2 #x10)
      ;; ブロック交換処理
      (when (or (= data2 #x05)
                (and (= data2 #x02) (> vc2 0)))
        (mdata-off! mdata2 rx  ry  data1)
        (mdata-off! mdata2 rx2 ry2 data2)
        (mdata-on!  mdata2 rx  ry  data2)
        (mdata-on!  mdata2 rx2 ry2 data1))
      ;; 判定と落下処理
      (check-and-fall-down sp2)
      ;; 局面の重複チェック
      ;; (同一局面がすでにあったら、追加しない)
      (unless (map-data-dup? mdata2)
        ;; 探索点の追加
        (slot-set! (car sps) 'next sp2)
        (push! sps sp2)
        (hash-table-put! dup-search-table mdata2 #t)
        ;; ゴールチェック
        (when (and goal-flag (not goal-sp))
          (set! goal-sp sp2))
        ))))

;; 掃除処理
;; (ハートが取れていない局面を削除して、探索を続行する)
(define (sweep-map-data)
  (when (> vcount-sweep 0)
    (dec! vcount-sweep)
    (print "sweep start (heart > " vcount-sweep ")")
    (flush)
    (let1 dcount 0
      (for-each
       (lambda (sp)
         (when (and (> (slot-ref sp 'vc) vcount-sweep)
                    (slot-ref sp 'mdata))
           (inc! dcount)
           (hash-table-delete! dup-search-table (slot-ref sp 'mdata))
           (slot-set! sp 'mdata #f)))
       sps)
      (inc! scount-max dcount)
      (gc)
      (print "sweep done  (+" dcount ")")
      (flush)
      )))

;; ゴールの探索(幅優先探索)
(define (search-goal)
  ;; 初期探索点の設定
  (push! sps (check-and-fall-down (read-map)))
  ;; 探索のループ
  (let loop ((sp (car sps)))
    (let ((rx    (slot-ref sp 'rx))
          (ry    (slot-ref sp 'ry))
          (mdata (slot-ref sp 'mdata)))
      (when mdata
        (inc! scount)
        ;; 途中経過の表示
        (when (= (mod scount 10000) 0)
          (search-point-print sp))
        ;; 移動可能な場所を、新たな探索点として追加
        (case (mdata-get mdata rx ry)
          ((#x00 #x07) ; 空白/鉄棒
           (search-point-add sp 'R)
           (search-point-add sp 'L)
           (when (memv (mdata-get mdata rx (- ry 1)) ; 1個上
                       '(#x02 #x05)) ; ゴール/交換ブロック
             (search-point-add sp 'U))
           (search-point-add sp 'D))
          ((#x06)      ; はしご
           (search-point-add sp 'R)
           (search-point-add sp 'L)
           (search-point-add sp 'U)
           (search-point-add sp 'D))
          )
        ;; 掃除処理
        (when (>= scount scount-max)
          (sweep-map-data))
        )
      ;; 次の探索点を取り出す
      (when (and (slot-ref sp 'next)
                 (not goal-flag)
                 (< scount scount-max))
        (loop (slot-ref sp 'next))))))

;; メイン処理
(define (main args)
  ;; ゴールを探索
  (search-goal)
  ;; 探索結果表示
  (cond
   (goal-flag
    (search-point-print goal-sp)
    (print "found !"))
   (else
    (search-point-print (car sps))
    (print "not found ...")))
  (print "HIT ENTER KEY!")
  (flush)
  (read-line)
  0)