Serendip

Web Studio

最短経路探索プログラム Gauche 版 を "「人材獲得作戦・４　試験問題ほか」を解いてみた(2) | 山本隆の開発日誌" で紹介されていた "通った経路に文字を埋めてゆく方法" で書いてみた。

今回はマップのデータを文字のリストから成る行リストで作る。
隣接する座標に一歩づつ移動して経路を記録して文字を埋めてゆき、ゴールが見つかった時点で call/cc を使ってループを脱出する。
そして、結果の移動経路座標の文字を $ に書き換えていったマップデータを印字する。

(use file.util)       ; file->string
(use srfi-1)          ; list-index
(use gauche.sequence) ; fold-with-index

;;; マップ文字列からマップデータリストを作る
;;; マップデータリスト
;;; ((* * * * * * * * * * * * * * * * * * * * * * * * * *)
;;;  (* S *   *                                         *)
;;;  ... 省略 ...
;;;  (* * * * * * * * * * * * * * * * * * * * * * * * * *))
;;;
(define (make-map str)
  (let loop ((str-list (string->list str))
             (map-list '())
             (line-list '()))
       (if (null? str-list)
           (reverse map-list)
           (let ((c (car str-list))
                 (rest (cdr str-list)))
                (cond ((char=? c #\newline)
                       (loop rest (cons (reverse line-list) map-list) '()))
                      (else
                        (loop rest map-list (cons c line-list))))))))

;;; 文字 char の座標 (x . y) を探す
(define (find-pos char map-list)
  (let loop ((lines map-list) (x 0) (y 0))
       (if (null? lines)
           (cons x y)
           (let* ((line (car lines))
                  (_x (list-index
                        (lambda (c) (char=? char c))
                        line)))
                 (if (number? _x) ; 文字 char が見つかれば
                     (loop '() _x y) ; 検索終了
                     (loop (cdr lines) x (+ y 1)))))))

;;; 座標 pos => (x . y) の文字を取り出す
(define (get-char pos map-list)
  (let ((x (car pos))
        (y (cdr pos)))
       (list-ref
         (list-ref map-list y)
         x)))

;;; 座標 pos => (x . y) の文字を new-char に書き換えたマップデータリストを返す
(define (set-char pos new-char map-list)
  (let ((x (car pos))
        (y (cdr pos)))
       (reverse
         (fold-with-index
           (lambda (_y line result)
                   (cons
                     (reverse
                       (fold-with-index
                         (lambda (_x char rest)
                                 (if (and (= _x x) (= _y y))
                                     (cons new-char rest)
                                     (cons char rest)))
                         '()
                         line))
                       result))
           '()
           map-list))))

;;; 座標 pos に移動済みマーク $ を付ける
(define (mark-pos pos map-list)
  (let* ((x (car pos))
         (y (cdr pos))
         (new-char #\$))
       (set-char pos new-char map-list)))

;;; 経路探索処理 search
;;; 座標データリストとマップデータリストを渡し、移動可能な次の座標にマークを付けて再帰的に処理していく
;;; ゴールを見つけると、最短経路移動座標リスト(スタート位置を含む)を返す
;;; 座標データリスト: (<座標データ: (<座標:(x . y)> <移動経路座標リスト:((x . y) (x . y) ...)>)> <座標データ:(...)> <座標データ:(...)> ...)
(define (search pos-list map-list)
  (if (null? pos-list)
      '()
      (call/cc
        (lambda (break)
                (let ((next-pos-list '()))
                     (for-each
                       (lambda (pos-data) ; pos-data : 座標データ
                               (let* ((pos (car pos-data))
                                      (x (car pos))
                                      (y (cdr pos))
                                      (nexts (list (cons x (- y 1)) (cons x (+ y 1)) (cons (- x 1) y) (cons (+ x 1) y))))
                                     (for-each
                                       (lambda (next-pos)
                                               (let* ((next-x (car next-pos))
                                                      (next-y (cdr next-pos))
                                                      (char (get-char next-pos map-list)))
                                                     (cond ((char=? char #\G)
                                                            (break (cons pos (cdr pos-data))))
                                                           ((char=? char #\space)
                                                            (set! map-list (mark-pos next-pos map-list))
                                                            (set! next-pos-list (cons (cons next-pos (cons pos (cdr pos-data))) next-pos-list))))))
                                       nexts))) ; nexts : 移動先座標リスト
                       pos-list) ; pos-list : 座標データリスト
                     (search next-pos-list map-list))))))

;;; マップデータリストからマップを印字する
(define (print-map map-list)
  (if (null? map-list)
      '()
      (let ((line (car map-list)))
           (let loop ((l line))
                (if (null? l)
                    (newline)
                    (let ((c (car l)))
                         (display c)
                         (loop (cdr l)))))
           (print-map (cdr map-list)))))

;;;
(define (main args)
  (let* ((file (cadr args))
         (map-list (make-map (file->string file)))
         (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)

実行結果

$ ./maze2.scm map.txt
**************************
*S* * $$$                *
*$* *$$*$ *************  *
*$* $$* $$$************  *
*$$$$*    $$$$$          *
**************$***********
* $$$$$$$$$$$$$          *
**$***********************
* $$$$$* $$$$$$$$$$$$$G  *
*  *  $$$$*********** *  *
*    *        ******* *  *
*       *                *
**************************

プログラミングGauche

posted with amazlet at 10.01.18

Kahuaプロジェクト
オライリージャパン
売り上げランキング: 134071

Amazon.co.jp で詳細を見る