探索アルゴリズムの実装(アルゴリズム)

tansaku-0.scm

(use srfi-1)
(use srfi-13)

(load "graph")

(define param-ogura35a  `(,ogura-graph35a ,ogura-cost35a  ,ogura-h35a ))
(define param-ogura35b  `(,ogura-graph35b ,ogura-cost35b  ,ogura-h35b ))
(define param-ogura36   `(,ogura-graph36  ,ogura-cost36   ,ogura-h36  ))
(define param-tahara319 `(,tahara-graph35 ,tahara-cost311 ,tahara-h319))
(define param-tahara327 `(,tahara-graph35 ,tahara-cost311 ,tahara-h327))

(define param      param-ogura36)
(define op         (car   param)) 
(define cost-table (cadr  param))
(define hfunc      (caddr param))


;OPEN,CLOSEDに指定ノードがあるかどうか調べる。あればそれを返す
(define (node-kensaku lst id)
  ;#?= lst
  (if (null? lst)
    #f ; 見つからない
    (if (char=? (caar lst) id)
      (car lst) ; 見つかった
      (node-kensaku (cdr lst) id) ) ))

;OPEN,CLOSEDの処理用: a から bの要素をのぞいたもの
; idで識別、属性データはみない
(define (nozoku a b)
  (lset-difference (lambda (x y) (char=? (car x) (car y)) ) a b))

;OPEN,CLOSEDの処理用: aのノードで、bと共通のもの
; idで識別、属性データはみない
(define (kyotu a b)
  (filter (lambda (x) (node-kensaku b (car x)) ) a))

; aがスタートか？
(define (start? a) (char=? a #\S))
; aがゴールか？
(define (goal? a) (char=? a #\G))

; オペレータopのノードaを展開する
; 親の情報を付加する
(define (tenkai op a)
 (let ( (pa (assoc a op) ))
    (if pa 
      (map (lambda (x) (list x a) ) (cdr pa)) 
      '() )))

;最良優先探索 : 展開したノードに評価値を付加
;h ... heuristics function
(define (heuristics-hyouka h pa)
  (map 
    (lambda (x) 
      (append 
        x 
        (list (h (car x))))) 
    pa))

;分枝限定法 : 展開したノードに評価値を付加
; cost-table .... 枝のコスト
; a  .... 展開したノードの情報 (id 親 評価値)
; pa .... 展開結果 
(define (keiro-hyouka cost-table a pa)
  (let ((g (if (start? (car a) ) 
             0 
             (caddr a) ) ) ) 
    (map 
      (lambda (x) 
        (let ((c (assoc (cons (car a) (car x) ) cost-table  )))
          (if c
            (append x (list (+ g (cdr c) ) ))
            #f ) ; <---- コストがコストが計算できないときの扱い。エラーとしたい。
          )) 
      pa)))

;評価値でソート
; paの要素は( id parent .....  評価値 ) : 末尾が評価値
; 評価値でソート
(define (naraberu pa)
  (sort 
    pa 
    (lambda (x y) 
      (let ((hx (last x))
            (hy (last y)))
        (if (= hx hy)
          (char<? (car x) (car y) ) 
          (< hx hy) 
          )
        ) ) ) )


;表示
(define (hyouji-list a)
  (string-concatenate (map (lambda (x) (format "~a~a " (car x) (cdr x) )) a)
  ))

;見つけたときに経路を追跡
(define (keiro open closed)
  (define (keiro-acc x acc) 
    (if (start? (car x))
      acc
      (begin
        (keiro-acc (assoc (car(cdr x)) closed) (cons (car x) acc) )))
    )
  (cons #\S (keiro-acc (car open) '())
  ))

(define (tansaku next-open-closed open-closed)
  (display (string-concatenate (list "Open["   (hyouji-list (car  open-closed) ) "] " )))
  (display (string-concatenate (list "Closed[" (hyouji-list (cadr open-closed) ) "]"  )))
  (newline)
  (let ((open   (car  open-closed))
        (closed (cadr open-closed)))
    (if (null? open)
      (cons 'mitsukaranai (cadr open-closed) )
      (let (
            (a (car open) )
            (new-open (cdr open) ) )
        (if (goal? (car a))
          (keiro open closed)
          (let ((pa (tenkai op (car a)))
                (new-closed (append closed (list a )) ) )
            ;(display pa)
            (if (null? pa)
              (tansaku next-open-closed (list new-open new-closed) )
              (tansaku next-open-closed (next-open-closed a pa new-open new-closed) ) 
              ) ) ) ) ) ) )

; 横型探索
(define (yokogata open closed)
  (tansaku 
    ; next-open-closed
    (lambda (a pa new-open new-closed)
      (list
        (append new-open (nozoku (nozoku pa new-open) new-closed) )
        new-closed ) ) 
    (list open closed) ) )

; 縦型探索「人工知能の基礎知識」版
(define (tategata-tahara open closed)
  (tansaku
    ; next-open-closed
    (lambda (a pa new-open new-closed)
      (list
        (append (nozoku (nozoku pa new-open) new-closed) new-open )
        new-closed ) )
    (list open closed) ) )

; 縦型探索「人工知能システムの構成」版
; あとから見つかったノード情報を優先するのでnew-openをpaで書き換えることあり
(define (tategata-ogura open closed)
  (tansaku
    ; next-open-closed
    (lambda (a pa new-open new-closed)
      (list
        (append (nozoku pa new-closed) (nozoku new-open pa) )
        new-closed ) )
    (list open closed) ) )

; 最良優先探索
(define (sairyo-yusen open closed)
  (tansaku 
    ; next-open-closed
    (lambda (a pa new-open new-closed)
      (list
        (naraberu 
          (append 
            new-open 
            (heuristics-hyouka hfunc (nozoku (nozoku pa new-open) new-closed) ) ) ) 
        new-closed) )
    (list open closed) ) )

; 分枝限定法
; 「人工知能の基礎知識」p.56 ~ p.58
(define (bunshi-gentei open closed)
  ;#?=open
  ;#?=closed
  (tansaku
    ; next-open-closed
    (lambda (a pa new-open new-closed)
      (list 
        ; 展開データのうちCLOSEDに含まれているものはとりのぞく
        (let ( (pb (nozoku pa new-closed) ) )
          ;#?= pb
          (if (null? pb)
            new-open ; 追加するものなし。(すでに最適な経路がある)
            (let ((pc (keiro-hyouka cost-table a pb))) 
              ; pc ... 展開データに経路評価を付加したもの
              ;#?= pc
              (let ( (pk (kyotu  pc new-open)) ; OPENにあるもの--->評価値を比較してOPENの要素を置換
                    )
                ;#?= pk
                (naraberu
                  (append 
                    (nozoku new-open pc)
                    (nozoku pc       new-open)
                    (map 
                      (lambda (x)
                        (let ((b (node-kensaku new-open (car x))))
                          (if (< (caddr b) (caddr x)) b x) )) 
                      pk)
                    ) ) ) ) ) ) 
        new-closed
        ) )
    (list open closed) ) )

;Aアルゴリズム
;「人工知能の基礎知識」p.65~p.68
; OPEN,CLOSEDの要素 = (id parent-id 経路評価 経路評価+ヒューリスティック  )
(define (algorithm-a open closed)
  (tansaku
    ; next-open-closed
    (lambda (a pa new-open new-closed)
      ;#?= (keiro-hyouka cost-table a pa)
      (let ((ph (map (lambda (x) 
                       ;#?= x
                       ;#?= (hfunc (car x) )
                       (append x (list (+ (hfunc (car x) ) (caddr x) ) ) ) ) 
                     (keiro-hyouka cost-table a pa) ) ) ) 
        ; ph ... 展開データに評価を付加したもの
        ;#?= ph
        (let ((pko (kyotu ph new-open  ))
              (pkc (kyotu ph new-closed))) 
          (let ((pkcf (filter
                        (lambda (x)
                          (let ((b (node-kensaku new-closed (car x))))
                            (< (cadddr x) (cadddr b) ) ) )
                        pkc )))
            (list
              ;open
              (naraberu
                (append 
                  (nozoku new-open ph)
                  (nozoku (nozoku ph new-open) new-closed)
                  (map 
                    (lambda (x)
                      (let ((b (node-kensaku new-open (car x))))
                        (if (< (cadddr b) (cadddr x)) b x) )) 
                    pko )
                  pkcf ) )
              ;closed
              (nozoku new-closed pkcf) )))))
    (list open closed) ) )