Serendip

Web Studio

最短経路探索プログラムの問題を、今度は Gauche で解いてみた。

こちらは、スタートからの移動距離を記録してゆき、ゴールから戻るかたちで最短経路にマークを付けてゆく方法で作った。

マップ座標(x, y)をキーにするハッシュテーブルでマップデータを作り、マップ上の "文字"、移動先の"座標リスト"、スタートからの"移動距離" を値とした。

(use file.util)
(use srfi-1)

;;; 文字列から各文字を、ハッシュテーブルに追加していく。
;;; 行を y 座標とし、各行の左からの文字位置を x 座標とする (x y) のリストをキーとする。
;;; ノードデータリスト構造を (<文字> <移動先座標リスト> <スタートからの距離>) とする。
(define (make-map-table str map-table)
  (define (set-table-iter lis key)
    (if (null? lis)
        map-table
        (let ((c (car lis)))
             (hash-table-put! map-table
                              key
                              (list c '() 0))
             (set-table-iter (cdr lis)
                             (if (char=? c #\newline)
                                 (list 0 (+ (get-y key) 1))
                                 (list (+ (get-x key) 1) (get-y key)))))))
  (set-table-iter (string->list str) (list 0 0)))

;;; 座標から x 座標を取り出す
(define (get-x key) (car key))
;;; 座標から y 座標を取り出す
(define (get-y key) (cadr key))
;;; ノードデータリストから文字を取り出す
(define (get-char node) (car node))
;;; ノードデータリストから移動先座標リストを取り出す
(define (get-nexts node) (cadr node))
;;; ノードデータリストからスタートからの移動距離を取り出す
(define (get-distance node) (caddr node))

;;; 特定文字の座標検索
(define (search-pos char map-table)
  (hash-table-map map-table
                  (lambda (key value)
                          (if (char=? (get-char value) char)
                              key
                              '()))))
;;; スタート座標の検索
(define (search-start map-table)
  (car (filter pair? (search-pos #\S map-table))))
;;; ゴール座標の検索
(define (search-goal map-table)
  (car (filter pair? (search-pos #\G map-table))))

;;; スタート地点からの移動距離をセットし、移動先座標をセットしていく。
(define (set-distances nexts current-distance map-table)
  (let ((next-nexts '()))
       (if (null? nexts)
           '()
           (for-each
             (lambda (key)
                     (let* ((x (get-x key))
                            (y (get-y key))
                            (move (list (list x (- y 1)) (list x (+ y 1)) (list (- x 1) y) (list (+ x 1) y))))
                           (for-each
                             (lambda (k)
                                     (let* ((nd (hash-table-get map-table k))
                                            (ch (get-char nd))
                                            (nx (get-nexts nd))
                                            (ds (get-distance nd)))
                                           (if (and (or (char=? #\space ch)
                                                        (char=? #\S ch)
                                                        (char=? #\G ch))
                                                    (= ds 0))
                                               (begin
                                                 (set! next-nexts (cons k next-nexts))
                                                 (hash-table-put! map-table k (list ch (list key) (+ current-distance 1)))))))
                             move)))
             nexts))
       (if (null? next-nexts)
           map-table
           (set-distances next-nexts (+ current-distance 1) map-table))))

;;; ゴールノードから隣接ノードのスタートからの距離がより短いものを探して、文字を $ に変更していく
(define (mark-root nexts distance map-table)
  (if (null? nexts)
      map-table
      (let* ((next-key (car nexts))
             (next-node (hash-table-get map-table next-key))
             (next-char (get-char next-node))
             (next-nexts (get-nexts next-node))
             (next-distance (get-distance next-node)))
            (if (char=? next-char #\S)
                map-table
                (if (= next-distance (- distance 1))
                    (begin
                      (hash-table-put! map-table next-key (list #\$ next-nexts next-distance))
                      (mark-root next-nexts next-distance map-table))
                    (mark-root (cdr nexts) distance map-table))))))

;;; マップを印字
(define (print-map map-table)
  (define (iter x y)
    (let ((key (list x y)))
         (if (hash-table-exists? map-table key)
             (let* ((node (hash-table-get map-table key))
                    (char (get-char node)))
                   (display char)
                   (if (char=? char #\newline)
                       (iter 0 (+ y 1))
                       (iter (+ x 1) y))))))
  (iter 0 0))

;;;
(define (main args)
  (let ((file (cadr args)))
       (let ((map-table (make-hash-table 'equal?)))
            (make-map-table (file->string file) map-table)
            (let ((start-key (search-start map-table))
                  (goal-key (search-goal map-table)))
                 (print-map
                   (let* ((measured-map (set-distances (cons start-key '()) 1 map-table))
                          (goal-node (hash-table-get measured-map goal-key))
                          (goal-nexts (get-nexts goal-node))
                          (goal-distance (get-distance goal-node)))
                         (mark-root goal-nexts goal-distance measured-map))))))
  0)

実行結果

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

プログラミングGauche

posted with amazlet at 10.01.16

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

Amazon.co.jp で詳細を見る