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
GPS
procedure 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-all
procedure 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 #f
.
(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
achieve
procedure 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 #f
.
(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
try
procedure 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
filter
operation 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-end
procedure
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
union
operation 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-difference
operation 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.
The make-op
operation constructs such a list from its
components.
(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
writeln
procedure 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-steps
procedure 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
GPS
can 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.