;;; [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.