This program is a simplified version of the General Problem Solver, loosely derived from Chapter 4 of Peter Norvig's Paradigms of Artificial Intelligence Programming (San Mateo, California: Morgan Kaufmann Publishers, 1991) and, even more loosely, from Alan Newell and Herbert A. Simon's ``GPS, a program that simulates human thought,'' in Edward A. Feigenbaum and Julian Feldman, Computers and Thought (New York: McGraw-Hill, 1963), pages 279 - 293.
;; Programmer: John Stone, Grinnell College. ;; June 9, 1996.The
GPSprocedure takes as arguments an initial state, a list of goals to be reached, and a list of operations that can be performed to transform the state in the course of a solution. If the specified goals can be attained from the given initial state, the GPS procedure displays the sequence of operations that will achieve them; otherwise, it reports that it is unable to find a solution.
(define GPS (lambda (initial-state goals operations) (let ((result (achieve-all goals initial-state operations))) (if result (display-steps (cdr result)) (writeln "GPS was unable to find a solution.")))))Given a list of goals, an initial state, and a list of state-transforming operations, the
achieve-allprocedure attempts to achieve each of the goals successively, using the final state reached during the achievement of a goal as the initial state for the achievement of the next. If it is successful, it returns a pair in which the first component is the state reached at the end of the entire process and the second component is a list of the operations by which the result was achieved. If it is unsuccessful in achieving any one of the goals, the achieve-all procedure returns
(define achieve-all (lambda (goals initial-state operations) (if (null? goals) (cons initial-state '()) (let ((first-part (achieve (car goals) initial-state operations))) (and first-part (let ((rest-part (achieve-all (cdr goals) (car first-part) operations))) (and rest-part (cons (car rest-part) (append (cdr first-part) (cdr rest-part))))))))))Given a single goal, an initial state, and a list of state-transforming operations, the
achieveprocedure tries to find a way to achieve the goal starting from the initial state. If the goal is already met in the initial state, the problem is trivial; otherwise, achieve searches for an appropriate operation -- one that would result in the addition of the goal to the current state -- and attempts to achieve all of the preconditions for that goal. If it succeeds, the achieve procedure returns a pair in which the first component is the state reached at the end of the process and the second component is a list of the operations by which the result was achieved. If it is unsuccessful, the achieve procedure returns
(define achieve (lambda (goal initial-state operations) (if (member? goal initial-state) (cons initial-state '()) (try (lambda (possible) (let ((result (achieve-all (preconditions possible) initial-state operations))) (and result (cons (apply-operation (car result) possible) (attach-at-end possible (cdr result)))))) (filter (lambda (op) (member? goal (products op))) operations)))))The
member?procedure determines whether a given value occurs as an element of a given list.
(define member? (lambda (val li) (cond ((null? li) #f) ((equal? val (car li)) #t) (else (member? val (cdr li))))))The
tryprocedure takes a procedure and a list of potential arguments to that procedure. It applies the procedure to successive elements of the list until either the list is exhausted (in which case it returns
#f) or the procedure returns a value other than
#f(in which case the try procedure returns that value).
(define try (lambda (proc li) (if (null? li) #f (or (proc (car li)) (try proc (cdr li))))))The
filteroperation takes a predicate and a list and returns a list containing the elements from the given list that satisfy the predicate.
(define filter (lambda (pred li) (letrec ((helper (lambda (rest so-far) (if (null? rest) (reverse so-far) (helper (cdr rest) (let ((first (car rest))) (if (pred first) (cons first so-far) so-far))))))) (helper li '()))))Given a value and a list, the
attach-at-endprocedure constructs and returns a new list, containing the same elements as the given list except that the given value has been added as the last element.
(define attach-at-end (lambda (val li) (if (null? li) (cons val '()) (cons (car li) (attach-at-end val (cdr li))))))To apply an operation to the current state, remove the conditions that the operation consumes or falsifies and add those that it produces.
(define apply-operation (lambda (state operation) (union (products operation) (set-difference state (sumpta operation)))))Given two lists, the
unionoperation forms a list containing exactly those values that appear on one or both of the given lists.
(define union (lambda (set-1 set-2) (letrec ((helper (lambda (set so-far) (if (null? set) so-far (helper (cdr set) (let ((first (car set))) (if (member first set-2) so-far (cons first so-far)))))))) (helper set-1 set-2))))Given two lists, the
set-differenceoperation forms a list containing exactly those values that appear in the first of the given lists and not in the second.
(define set-difference (lambda (set-1 set-2) (letrec ((helper (lambda (set so-far) (if (null? set) so-far (helper (cdr set) (let ((first (car set))) (if (member first set-2) so-far (cons first so-far)))))))) (helper set-1 '()))))An operation is a list of four elements: a string indicating what the operation does, a list of the preconditions for the operation, a list of the conditions that the operation produces, and a list of the conditions that it consumes or falsifies.
make-op operation constructs such a list from its
(define make-op (lambda (action preconditions products sumpta) (list action preconditions products sumpta)))The following operations recover the respective fields of an operation.
(define action car) (define preconditions cadr) (define products caddr) (define sumpta cadddr)The
writelnprocedure writes out its arguments in order, immediately adjacent to one another, and then starts a new line.
(define writeln (lambda args (for-each display args) (newline)))The
display-stepsprocedure prints out the ``action'' field of each operation in a sequence, one operation to a line.
(define display-steps (lambda (operation-sequence) (for-each (lambda (operation) (writeln (action operation))) operation-sequence)))Here is the setting for one kind of problem that this simple version of
GPScan solve: a collection of six operations from the daily life of a parent.
(define *school-ops* (list ;; If your son is at home and your car works, it is possible to drive ;; him to school. (Then he'll be at school and will no longer be at ;; home.) (make-op "drive son to school" '(son-at-home car-works) '(son-at-school) '(son-at-home)) ;; If your car needs a new battery, and the mechanic knows the problem ;; and has been paid, it is possible him to install the new battery. ;; Then the car will work. (make-op "have the mechanic install a new battery" '(car-needs-battery mechanic-knows-problem mechanic-has-money) '(car-works) '(car-needs-battery)) ;; If you can communicate with the mechanic, you can tell him about the ;; problem with your car, and then he'll know what it is. (make-op "tell the mechanic what the problem is" '(in-communication-with-mechanic) '(mechanic-knows-problem) '()) ;; If you know the mechanic's telephone number, you can call him, and ;; then you'll be able to communicate with him. (make-op "telephone the mechanic" '(know-phone-number) '(in-communication-with-mechanic) '()) ;; If you have a telephone book, you can look up the mechanic's number, ;; and then you'll know what it is. (make-op "look up the telephone number" '(have-phone-book) '(know-phone-number) '()) ;; If you have money, then you can pay the mechanic. Then he'll have ;; the money and you won't. (make-op "pay the mechanic" '(have-money) '(mechanic-has-money) '(have-money))))Here, then, are a couple of problems that GPS can solve, using these operations:
> (GPS '(son-at-home car-works) '(son-at-school) *school-ops*) drive son to school > (GPS '(son-at-home car-needs-battery have-phone-book have-money) '(son-at-school) *school-ops*) look up the telephone number telephone the mechanic tell the mechanic what the problem is pay the mechanic have the mechanic install a new battery drive son to schoolOn the other hand:
> (GPS '(son-at-home car-needs-battery have-phone-book) '(son-at-school) *school-ops*) GPS was unable to find a solution.
John David Stone (email@example.com)