// -*- Mode: Lisp; Syntax: Common-Lisp -*- // Code from Paradigms of AI Programming // Copyright (c) 1991 Peter Norvig // student.lisp: Chapter 7's STUDENT program to solve algebra word problems. requires("patmatch"); define class () slot rule-pattern, init-keyword: #"rule-pattern"; slot rule-response, init-keyword: #"rule-response"; end class ; define class () slot exp-op, init-keyword: #"exp-op"; slot exp-lhs, init-keyword: #"exp-lhs"; slot exp-rhs, init-keyword: #"exp-rhs"; end class ; define method exp-p (x) instance?(x, ); end method exp-p; define method exp-args (x) tail(x); end method exp-args; pat-match-abbrev(#"?x*", #(#"?*", #"?x")); pat-match-abbrev(#"?y*", #(#"?*", #"?y")); define variable *student-rules* = map(expand-pat-match-abbrev, #(#(#(#"?x*", #"."), #"?x"), #(#(#"?x*", #".", #"?y*"), #(#"?x", #"?y")), #(#(#"if", #"?x*", #",", #"then", #"?y*"), #(#"?x", #"?y")), #(#(#"if", #"?x*", #"then", #"?y*"), #(#"?x", #"?y")), #(#(#"if", #"?x*", #",", #"?y*"), #(#"?x", #"?y")), #(#(#"?x*", #",", #"and", #"?y*"), #(#"?x", #"?y")), #(#(#"find", #"?x*", #"and", #"?y*"), #(#(#"=", #"to-find-1", #"?x"), #(#"=", #"to-find-2", #"?y"))), #(#(#"find", #"?x*"), #(#"=", #"to-find", #"?x")), #(#(#"?x*", #"equals", #"?y*"), #(#"=", #"?x", #"?y")), #(#(#"?x*", #"same", #"as", #"?y*"), #(#"=", #"?x", #"?y")), #(#(#"?x*", #"=", #"?y*"), #(#"=", #"?x", #"?y")), #(#(#"?x*", #"is", #"equal", #"to", #"?y*"), #(#"=", #"?x", #"?y")), #(#(#"?x*", #"is", #"?y*"), #(#"=", #"?x", #"?y")), #(#(#"?x*", #"-", #"?y*"), #(#"-", #"?x", #"?y")), #(#(#"?x*", #"minus", #"?y*"), #(#"-", #"?x", #"?y")), #(#(#"difference", #"between", #"?x*", #"and", #"?y*"), #(#"-", #"?y", #"?x")), #(#(#"difference", #"?x*", #"and", #"?y*"), #(#"-", #"?y", #"?x")), #(#(#"?x*", #"+", #"?y*"), #(#"+", #"?x", #"?y")), #(#(#"?x*", #"plus", #"?y*"), #(#"+", #"?x", #"?y")), #(#(#"sum", #"?x*", #"and", #"?y*"), #(#"+", #"?x", #"?y")), #(#(#"product", #"?x*", #"and", #"?y*"), #(#"*", #"?x", #"?y")), #(#(#"?x*", #"*", #"?y*"), #(#"*", #"?x", #"?y")), #(#(#"?x*", #"times", #"?y*"), #(#"*", #"?x", #"?y")), #(#(#"?x*", #"/", #"?y*"), #(#"/", #"?x", #"?y")), #(#(#"?x*", #"per", #"?y*"), #(#"/", #"?x", #"?y")), #(#(#"?x*", #"divided", #"by", #"?y*"), #(#"/", #"?x", #"?y")), #(#(#"half", #"?x*"), #(#"/", #"?x", 2)), #(#(#"one", #"half", #"?x*"), #(#"/", #"?x", 2)), #(#(#"twice", #"?x*"), #(#"*", 2, #"?x")), #(#(#"square", #"?x*"), #(#"*", #"?x", #"?x")), #(#(#"?x*", #"%", #"less", #"than", #"?y*"), #(#"*", #"?y", #(#"/", #(#"-", 100, #"?x"), 100))), #(#(#"?x*", #"%", #"more", #"than", #"?y*"), #(#"*", #"?y", #(#"/", #(#"+", 100, #"?x"), 100))), #(#(#"?x*", #"%", #"?y*"), #(#"*", #(#"/", #"?x", 100), #"?y")))); define method student (words) // Solve certain Algebra Word Problems. solve-equations(create-list-of-equations(translate-to-expression(choose(complement(noise-word-p), words)))); end method student; define method translate-to-expression (words) // Translate an English phrase into an equation or expression. rule-based-translator(words, *student-rules*, rule-if: rule-pattern, rule-then: rule-response, action: method (bindings, response) replace-multiple-in-tree(map(translate-pair, bindings), response); end method) | make-variable(words); end method translate-to-expression; define method translate-pair (pair) // Translate the value part of the pair into an equation or expression. pair(binding-var(pair), translate-to-expression(binding-val(pair))); end method translate-pair; define method create-list-of-equations (exp) // Separate out equations embedded in nested parens. if (empty?(exp)) #f; elseif (not(instance?(first(exp), ))) list(exp); else concatenate(create-list-of-equations(first(exp)), create-list-of-equations(tail(exp))); end if; end method create-list-of-equations; define method noise-word-p (word) // Is this a low-content word which can be safely ignored? member?(word, #(#"a", #"an", #"the", #"this", #"number", #"of", #"$")); end method noise-word-p; define method make-variable (words) // Create a variable name based on the given list of words first(words); end method make-variable; define method solve-equations (equations) // Print the equations and their solution print-equations("The equations to be solved are:", equations); print-equations("The solution is:", solve(equations, #f)); end method solve-equations; define method solve (equations, known) // Solve a system of equations by constraint propagation. // Try to solve for one equation, and substitute its value into // the others. If that doesn't work, return what is known. any?(method (equation) let x = one-unknown(equation); if (x) let answer = solve-arithmetic(isolate(equation, x)); solve(replace-in-tree(answer.exp-rhs, answer.exp-lhs, remove(equations, equation)), pair(answer, known)); end if; end method, equations) | known; end method solve; define method isolate (e, x) // Isolate the lone x in e on the left hand side of e. // This assumes there is exactly one x in e, // and that e is an equation. if (e.exp-lhs == x) // Case I: X = A -> X = n e; elseif (in-exp(x, e.exp-rhs)) // Case II: A = f(X) -> f(X) = A isolate(mkexp(e.exp-rhs, #"=", e.exp-lhs), x); elseif (in-exp(x, e.exp-lhs.exp-lhs)) // Case III: f(X)*A = B -> f(X) = B/A isolate(mkexp(e.exp-lhs.exp-lhs, #"=", mkexp(e.exp-rhs, inverse-op(e.exp-lhs.exp-op), e.exp-lhs.exp-rhs)), x); elseif (commutative-p(e.exp-lhs.exp-op)) // Case IV: A*f(X) = B -> f(X) = B/A isolate(mkexp(e.exp-lhs.exp-rhs, #"=", mkexp(e.exp-rhs, inverse-op(e.exp-lhs.exp-op), e.exp-lhs.exp-lhs)), x); else // Case V: A/f(X) = B -> f(X) = A/B isolate(mkexp(e.exp-lhs.exp-rhs, #"=", mkexp(e.exp-lhs.exp-lhs, e.exp-lhs.exp-op, e.exp-rhs)), x); end if; end method isolate; define method print-equations (header, equations) // Print a list of equations. (method (s, #rest args) apply(maybe-initiate-xp-printing, method (xp, #rest args) begin pprint-newline+(unconditional: xp); fluid-bind (*print-escape* = #f) write+(pop!(args), xp); end fluid-bind; let args = pop!(args); block (return) local method go-l () if (empty?(args)) return(#f); end if; pprint-newline+(unconditional: xp); write-string++(" ", xp, 0, 2); let args = pop!(args); block (return) local method go-l () if (empty?(args)) return(#f); end if; write-char++(' ', xp); fluid-bind (*print-escape* = #f) write+(pop!(args), xp); end fluid-bind; go-l(); end method go-l; go-l(); end block; go-l(); end method go-l; go-l(); end block; pprint-newline+(unconditional: xp); end; if (args) copy-sequence(args); end if; end method, s, args); end method)(#t, header, map(prefix->infix, equations)); end method print-equations; define constant operators-and-inverses = #(#(#"+", #"-"), #(#"-", #"+"), #(#"*", #"/"), #(#"/", #"*"), #(#"=", #"=")); define method inverse-op (op) second(cl-assoc(op, operators-and-inverses)); end method inverse-op; define method unknown-p (exp) instance?(exp, ); end method unknown-p; define method in-exp (x, exp) // True if x appears anywhere in exp x == exp | (instance?(exp, ) & (in-exp(x, exp.exp-lhs) | in-exp(x, exp.exp-rhs))); end method in-exp; define method no-unknown (exp) // Returns true if there are no unknowns in exp. if (unknown-p(exp)) #f; elseif (not(instance?(exp, ))) #t; elseif (no-unknown(exp.exp-lhs)) no-unknown(exp.exp-rhs); else #f; end if; end method no-unknown; define method one-unknown (exp) // Returns the single unknown in exp, if there is exactly one. if (unknown-p(exp)) exp; elseif (not(instance?(exp, ))) #f; elseif (no-unknown(exp.exp-lhs)) one-unknown(exp.exp-rhs); elseif (no-unknown(exp.exp-rhs)) one-unknown(exp.exp-lhs); else #f; end if; end method one-unknown; define method commutative-p (op) // Is operator commutative? member?(op, #(#"+", #"*", #"=")); end method commutative-p; define method solve-arithmetic (equation) // Do the arithmetic for the right hand side. // This assumes that the right hand side is in the right form. mkexp(equation.exp-lhs, #"=", // LTD: Function EVAL not yet implemented. eval(equation.exp-rhs)); end method solve-arithmetic; define method binary-exp-p (x) exp-p(x) & size(exp-args(x)) = 2; end method binary-exp-p; define method prefix->infix (exp) // Translate prefix to infix expressions. if (not(instance?(exp, ))) exp; else map(prefix->infix, if (binary-exp-p(exp)) list(exp.exp-lhs, exp.exp-op, exp.exp-rhs); else exp; end if); end if; end method prefix->infix;