zurück
;;;                                   [Missionare mit A-Stern.scm]
;;; Quelle: Oliver Grillmeyer: Exploring Computer Science with Scheme
;;; ===== Generic A* search: ========================================
; General a* search implemented using best-first search.
; start-path is the path to the start state.
; successors is a function that returns the next states.
; g is a function that returns the cost incurred so far and
; h is a function returning the expected cost to reach the goal.
(define (a*search goal-func start-path successors g h)
  (best-first-search goal-func (list start-path)
    (lambda (path1 path2)
      (<= (+ (g path1) (h path1)) (+ (g path2) (h path2))))
    successors) )
;;; ===== Code for searching: =======================================
; Parameters: goal-func, a function returning true if a goal has
; been met; choices, a list of paths to search; cost-func, a cost
; function to order new states; and next-states, a function that
; generates new states from a current path.
; Return the first path encountered that satisfies goal-func.
; The list of path choices is printed each time through the code.
(define (best-first-search goal-func choices cost-func next-states)
;  (display choices)(newline)
  (cond ((null? choices) #f)    ; no more choices
        ((goal-func (first choices)) (first choices))
        (else
          (best-first-search goal-func
            (add-paths
              (rest choices)
              (make-paths (next-states (first choices))
                (first choices))
              cost-func)
            cost-func
            next-states))) )

;;; Support code for missionaries and cannibals problem:

;;; ----- Hilfsfunktionen -------------------------------------------
(define first car)
(define rest cdr)
(define (second l) (cadr l))
(define (third l) (caddr l))
(define 1+ add1)
; Return the last element in a-list.
(define (last a-list)
  (list-ref a-list (- (length a-list) 1)))
;;; ===== insert ====================================================
; Liefert eine neue sortierte Liste mit dem eingeordneten Element.
; Das Vergleichspraedikat wird als Parameter übergeben.
(define
  (insert Element sortierte-Liste Praedikat?)
  (cond
    ((null? sortierte-Liste) (list Element))
    ((Praedikat? Element (first sortierte-Liste))
     (cons Element sortierte-Liste))
    (else
     (cons
      (first sortierte-Liste)
      (insert Element (rest sortierte-Liste) Praedikat?)))))

;;; ===== add-paths =================================================
; Fuegt die neuen Moeglichkeiten zu den alten sortiert hinzu.
; Das Sortierkriterium liefert die Kostenfunktion.
(define
  (add-paths alte neue Kosten)
  (if
   (null? neue)
   alte
   (insert
    (first neue)
     (add-paths alte (rest neue) Kosten)
     Kosten)))

;;; ===== make-paths ================================================
; Erhaelt die neuen Zustaende, entfernt leere Listen und erzeugt
; komplette Pfade.
(define
  (make-paths neue aktuell)
  (map
   (lambda (Zustand) (append aktuell (list Zustand)))
   (remove '() neue)))
;;; ===== set-difference ============================================
; Mengendifferenz: entfernt in set1 alle Elemente von set2.
(define (set-difference set1 set2)
  (cond ((null? set2)
          set1)
        ((null? set1)
          '())
        ((member (car set1) set2)
          (set-difference (cdr set1) set2))
        (else
          (cons (car set1) (set-difference (cdr set1) set2)))) )

;;; ===== remove ====================================================
; Entfernt Elemente aus Listen.
; Hier wird von der o.a. Funktion konkret das Entfernen leerer Listen
; verlangt.
(define
  (remove element liste)
  (cond
    ((null? liste) ())
    ((equal? element (first liste))
     (remove element (rest liste)))
    (else
     (cons (first liste) (remove element (rest liste))))))
;;; ===== keep-if ===================================================
; Liefert eine Liste mit allen Elemente, die das Praedikat erfuellen.
(define
  (keep-if Praedikat? Liste)
    (cond
      ((null? Liste) '())
      ((not
        (Praedikat? (first Liste)))
       (keep-if Praedikat? (rest Liste)))
      (else
       (cons
        (first Liste)
       (keep-if Praedikat? (rest Liste))))))

;;; ===== keep-if ===================================================
; Liefert zu einem Zustand die Liste alle zulässigen
; Nachfolgezustände
(define (move-people state)
  (keep-if
    (lambda (new-state)
      (or (= (caar new-state) 0)
          (= (caar new-state) 3)
          (= (caar new-state) (cadar new-state))) )
    (map (lambda (trans)
           (if (eq? (second state) 'left)
               (list (map - (first state) trans)
                     'right
                     (map + (third state) trans))
               (list (map + (first state) trans)
                     'left
                     (map - (third state) trans))) )
      '((1 0) (0 1) (2 0) (0 2) (1 1)))) )


;;; ===== Aufruf ====================================================
; Muster: (a*search goal-func start-path successors g h)
; Ziel-Funktion: Alle sind drüben.
; Start-Pfad: Hier nicht leer, sondern die Liste mit dem Startzustand
; Nachfolger: Im Prinzip alle, aber Ausschluss von Zyklen.
; g         : Länge des bisherigen Pfades
; h         : Wieviele müssen noch rüber?
(a*search
  (lambda (path) (equal? (last path) '((0 0) right (3 3))))
  '(((3 3) left (0 0)))
  (lambda (path) (set-difference (move-people (last path)) path))
  length
  (lambda (path) (apply + (first (last path)))))
Ergebnisse im Text.