Skip to content

Instantly share code, notes, and snippets.

@Hamayama Hamayama/cocoro.scm
Last active Jun 23, 2019

Embed
What would you like to do?
Gauche を使って、パズルの探索を行うプログラムです (不完全版)。
;; -*- 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.