Gauche 穴掘り法で迷路作成
2010年01月21日
穴掘り法という迷路作成アルゴリズムを使って、迷路を作成するプログラムを Gauche で作ってみた。
(use gauche.sequence) ; for-each-with-index (use srfi-27) ; random-source-randomize! (use srfi-19) ; date-nanosecond (use math.mt-random) ; <mersenne-twister> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-constant WALL_CHAR #\*) (define-constant ROAD_CHAR #\space) (define-constant START_CHAR #\S) (define-constant GOAL_CHAR #\G) (define-constant DEFAULT_SIZE 10) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-class <maze> () ((width :init-keyword :width :init-value DEFAULT_SIZE) (height :init-keyword :height :init-value DEFAULT_SIZE) (maze-map :init-value '()) )) (define-method initialize ((self <maze>) initargs) (next-method) (let ((width (ref self 'width)) (height (ref self 'height))) (when (even? width) (set! (ref self 'width) (+ width 1))) (when (even? height) (set! (ref self 'height) (+ height 1))) (set! (ref self 'maze-map) (make-vector (* (ref self 'width) (ref self 'height)) WALL_CHAR)))) ;;; マップを印字 (define-method print-map ((self <maze>)) (let1 width (ref self 'width) (for-each-with-index (lambda (i c) (cond ((= (remainder i width) (- width 1)) (display c) (newline)) (else (display c)))) (ref self 'maze-map)))) ;;; 座標 (x y) の vector 対応インデックスを生成 (define-method pos-to-index ((self <maze>) . args) (+ (car args) (* (cadr args) (ref self 'width)))) ;;; (put maze 1 3 #\S) => x:1, y:3 に文字 S をセット (define-method put ((self <maze>) . args) (vector-set! (ref self 'maze-map) (pos-to-index self (car args) (cadr args)) (caddr args))) ;;; (get maze 1 3) => x:1, y:3 の文字をゲット (define-method get ((self <maze>) . args) (vector-ref (ref self 'maze-map) (pos-to-index self (car args) (cadr args)))) ;;; 穴掘り (define-method dig ((self <maze>)) (let* ((width (ref self 'width)) (height (ref self 'height)) (x-left 1) (y-top 1) (x-right (- width 2)) (y-bottom (- height 2))) (put self x-left y-top ROAD_CHAR) ; 座標左上に空白文字を配置(スタート位置) (call/cc (lambda (break) (let loop ((pos (cons x-left y-top)) ; 現在位置座標 (from-list '())) ; これまでたどってきた位置座標リスト (let ((next-pos-list (get-next-pos self (car pos) (cdr pos)))) (cond ((null? next-pos-list) ; 移動先が無い場合 (cond ((null? from-list) (break)) ; スタートに戻ってきたら終了 (else (loop (car from-list) (cdr from-list))))) ; 前の位置に戻って繰り返す (else ; 移動先がある場合 (let* ((next-pos (list-ref-random next-pos-list)) (x (car pos)) (y (cdr pos)) (nx (car next-pos)) (ny (cdr next-pos)) (mx (if (= x nx) x (/ (+ x nx) 2))) (my (if (= y ny) y (/ (+ y ny) 2)))) (put self nx ny ROAD_CHAR) (put self mx my ROAD_CHAR) (loop (cons nx ny) (cons pos from-list))))))))) (put self x-left y-top START_CHAR) ; 座標左上にスタート文字 S を配置 (put self x-right y-bottom GOAL_CHAR) ; 座標右下にゴール文字 G を配置 )) ;;; 現在座標から2マス先の非空白座標を探す (define-method get-next-pos ((self <maze>) . args) (let* ((x (car args)) (y (cadr args)) (width (ref self 'width)) (height (ref self 'height)) (next-pos-list (filter pair? (list (if (> x 2) (cons (- x 2) y) '()) (if (< x (- width 3)) (cons (+ x 2) y) '()) (if (> y 2) (cons x (- y 2)) '()) (if (< y (- height 3)) (cons x (+ y 2)) '()))))) (fold (lambda (pos ret) (if (char=? (get self (car pos) (cdr pos)) WALL_CHAR) (cons pos ret) ret)) '() next-pos-list))) ;;; リストからランダムに要素を1つ取り出す (define (list-ref-random lis) (let1 mt (make <mersenne-twister> :seed (sys-time)) (mt-random-set-seed! mt (date-nanosecond (current-date))) (let* ((range (length lis)) (i (mt-random-integer mt range))) (list-ref lis i)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (define (make-size args) (let ((args-length (length args))) (lambda (type) (cond ((> args-length 2) (string->number (cond ((eq? type 'width) (cadr args)) ((eq? type 'height) (caddr args)) (else (error "Unknown type -- MAKE-SIZE" type))))) (else DEFAULT_SIZE))))) ;;; (define (main args) (let* ((w ((make-size args) 'width)) (h ((make-size args) 'height)) (maze (make <maze> :width w :height h))) (dig maze) (print-map maze) ) 0)
"穴掘り法"については、以下のサイトを参考にした。
実行結果
引数に横と縦のサイズを渡している。
引数なしの場合は横11、縦11のサイズのマップとなる。
$ ./makemap.scm 51 15 *************************************************** *S* * * * * * * * * *** *** *** *** ***** * * * * *** * * ***** *** * * * * * * * * * * * * * * * * ******* *** *** *** ***** * ***** *** * ******* * * * * * * * * * * * * * * * * * * ***** * * * *** ***** ***** * *** * ***** * * * * * * * * * * * * * * * * * * * * *************** * *********** * ***** *** * * * * * * * * * * * * * * *** * * ***** *********** *** *** * * * * ***** * * * * * * * * * * * * * * * * * * *** * * *** * * * *** * * *** *** *** *** * *** * * * * * * * * * * G* ***************************************************
"最短経路探索プログラム Gauche 版 その2" で作ったプログラムを標準入力から読み込みできるように修正して、作成した迷路をパイプで渡して最短経路を見つける。
$ ./makemap.scm 51 15 | ./maze2.scm *************************************************** *S* * * * * $$$* * * *$* ******* *** * *** * *** *** *****$*$* * * *** * *$* * * * * * * * *$$$$$*$* * * * * *$* * * * ***** ******* * *** * *$*****$* * *** * * *$* * * * * * * * *$*$$$$$* * * * *$*** * *** ***** ******* * *****$*$***** ******* * *$$$* * * * * * *$$$$$*$* * * * ***$* *** ********* *** * ***$*****$* * ******* *** * *$* * * *$$$* *$$$* *$$$$$* * * *$* *************** *** *$*** *$*******$***$*** * * *$* *$$$$$$$$$$$$$* *$$$* *$* $$$*$* *$$$* * * *$***$***********$*********$* *$***$*$*$* ***$* * * $$$$$* $$$$$$$$$$$* $$$$$*$$$* $$G* ***************************************************
ファイル引数が与えられなかった場合に、標準入力からマップデータを読み込むために行った修正。
(define (main args) (let* ((map-list (make-map (if (null? (cdr args)) (port->string (standard-input-port)) (file->string (cadr args))))) (walked-pos-list (drop-right (search (cons (cons (find-pos #\S map-list) '()) '()) map-list) 1))) (let loop ((walked walked-pos-list) (maps map-list)) (if (null? walked) (print-map maps) (loop (cdr walked) (mark-pos (car walked) maps)))) ) 0)
プログラミングGauche
posted with amazlet at 10.01.21
Kahuaプロジェクト
オライリージャパン
売り上げランキング: 180753
オライリージャパン
売り上げランキング: 180753