Examples


This section presents a few (small) exampleswhich make use of the matcher and othe utils functions.

example 1: retrieving information from sets of triples
example 2: specifying and applying rules
example 3: using GPS operators
 
 

retrieving information from sets of triples

This example builds a generalised query mechanism to retrieve information from a set of statements where each statements is a triple of the form: (relation object value).

For the sake of experimentation this example presents a simple world environment describing a collection of blocks. In Lisp this can be defined as...
 

(defvar *blocks*
    '(  (isa    b1  cube)       (isa    b2  wedge)
        (isa    b3  cube)       (isa    b4  wedge)
        (isa    b5  cube)       (isa    b6  wedge)
        (color  b1  red)        (color  b2  red)
        (color  b3  red)        (color  b4  blue)
        (color  b5  blue)       (color  b6  blue)
        (on     b1  table)      (on     b2  table)
        (on     b5  table)
    ))


The matcher's foreach form can be used to retrieve the names of objects satisfying a specified relation from this type of structure. The form below matches all triple statements of the isa-wedge type and returns the relevant object names.
 

> (foreach ('(isa ?obj wedge) *blocks*) #?obj)
==> (b2 b4 b6)


This approach can be used to build a general purpose function lookup which is defined and used as follows...
 

(defun lookup (pair triples)
  (foreach ( `(,(first pair) ?obj ,(second pair))
               triples)
           #?obj))

> (lookup '(isa cube) *blocks*)  ==>  (b1 b3 b5)
> (lookup '(on table) *blocks*)  ==>  (b1 b2 b5)


 Lookup returns a set of object names so results of different lookup operations can be combined with set operators like $* (set intersection) and $+ (set union). This allows multiple queries to be satisfied. NB: $+ and $* are included in utils.
 

> ($* (lookup '(isa cube) *blocks*)
       (lookup '(on table) *blocks*))
==>  (b5 b1)


A generalised query function can be built which maps pairs like (isa cube) and (color blue) over the lookup function and reduces results using $* (in the case of logically ANDed queries).
 

(defun query-and (pairs triples)
  (reduce #'$*
          (mapcar #'(lambda (p) (lookup p triples)) pairs)
          ))

> (query-and '((isa cube)(on table)) *blocks*)
==> (b5 b1)


Logically ORed queries can be similarly handled using $+ in place of $*. The final query function shown below can then be used in conjunction with two variables Qand & Qor (introduced for readibility) which deal with ANDed results and ORed results.
 

(defvar Qand #'$*)
(defvar Qor  #'$+)

(defun query (logic-op pairs triples)
  (reduce logic-op
          (mapcar #'(lambda (p) (lookup p triples)) pairs)
          ))

> (query Qand '((isa cube)(color red)) *blocks*)
==>  (b3 b1)
> (query Qor '((isa cube)(color red)) *blocks*)
==>  (b5 b1 b2 b3)


 

specifying and applying rules

This example considers the specification of rules and the development of functions to apply them.

Assuming data about family relations like...
 

(setf family
   '((parent-of Sarah Tom)  (parent-of Steve Joe)
     (parent-of Sally Sam)  (parent-of Ellen Sarah)
     (parent-of Emma  Bill) (parent-of Rob   Sally)
    ))
The rule which says that a person's parents' parents are their grand-parents could be written using the matcher as follows. Note that rules are typically written in two parts: their preconditions (antecedents) and their conclusions (consequents)...

antecedents    ((parent-of ?a ?b) (parent-of ?b ?c))
consequents   (grandparent ?a ?c)

Rule application can be achieved directly using the forevery form...
 

> (forevery ('((parent-of ?a ?b) (parent-of ?b ?c))
             family)
      (match-bind '(grandparent ?a ?c)))
==>  ((GRANDPARENT ELLEN TOM) (GRANDPARENT ROB SAM))


This approach can be used to develop a general purpose mechanism for applying rules to facts which return an updated set of facts. This function uses the matcher to deconstruct a rule and then forevery to apply it.
 

(defun apply-rule (r facts)
  (mlet ('(RULE ?n ??antecedents => ??consequents) r)
        (forevery (#?antecedents facts)
            (setf facts
              ($+ (match-bind #?consequents) facts)))
        facts))

> (apply-rule
      '(Rule 15 (parent-of ?a ?b) (parent-of ?b ?c)
                         => (grandparent ?a ?c))
              family)

==> ((GRANDPARENT ROB SAM) (GRANDPARENT ELLEN TOM)
     (PARENT-OF SARAH TOM) (PARENT-OF ELLEN SARAH)
     (PARENT-OF STEVE JOE)....)

To completed this example here is a mechanism which repeatedly applies a set of rules to update facts, continuing until the rules are unable to generate any new inference - it acts like a simple forward chaining process.

NB: Some Lisp programmers may question the structure of the iteration below preferring to replace let and loop with do or make more use of the loop macro facilities. The function is presented as shown since this does not require the reader to know any details of the loop macro or work with Lisps do/do* forms since some students report that the unusual structure of do/do* is hard to read.
 

 (defun fwd-chain (rules facts)
  (let (old-facts)            ; setup new variable
    (loop                     ; loop until return
      (setf old-facts facts)  ; save existing facts
      (setf facts             ; do one pass of rules
        (reduce #'$+
            (mapcar #'(lambda (r)
                         (apply-rule r facts))
                    rules)))
      (if ($= old-facts facts) ; are facts updated?
          (return facts))      ; if not finished
      )))                      ; so quit

; a slightly larger set of facts & rules

(defvar facts1
    '((big elephant) (small mouse) (small sparrow)
      (big whale)    (ontop elephant mouse)
      ))

(defvar rules1
    '((Rule 1 (heavy ?x) (small ?y) (ontop ?x ?y)
             => (squashed ?y) (sad ?x))
      (Rule 2 (big ?x)   => (heavy ?x))
      (Rule 3 (light ?x) => (portable ?x))
      (Rule 4 (small ?x) => (light ?x))
      ))

> (fwd-chain rules1 facts1))

==> ((PORTABLE SPARROW) (PORTABLE MOUSE)
     (SQUASHED MOUSE) (SAD ELEPHANT) (HEAVY WHALE)
     (HEAVY ELEPHANT) (LIGHT SPARROW) (LIGHT MOUSE)
     (BIG ELEPHANT) (SMALL MOUSE) (SMALL SPARROW)
     (BIG WHALE) (ONTOP ELEPHANT MOUSE))


 

using GPS operators

This third example examines the use of General Problem Solver (GPS) style operators used within a blocks world environment. Since first presented by Newell and Simon this has become a classic example of symbolic computation.

At one level of abstraction, commands like (pick-up ?x) and (drop-it-on ?y) are issued to a virtual robot existing in a simple blocks-world environment. The robot carries out these commands by effecting changes to the description of its virtual world. At another level, individual operators are defined in terms of their preconditions (what needs to exist in the world for the operator to be used) and their effects. The effects of operators are defined in two parts: what is no longer true about the world after the operator is applied (parts of the world description that the operator deletes) and what becomes true (parts of the world description that the operator adds). In this way simple operators can be described in terms of three sets of facts: preconditions deletions and additions.

Using the type of world description below, the (pick-up ?x) operator could be defined as shown.
 

(defvar blocks
  '((isa b1 block) (isa b2 block) (isa p1 pyramid)
    (supports b1 p1) (supports floor b1)
    (supports floor b2)
    (cleartop p1) (cleartop b2) (cleartop floor)
    (holds nil)))

(defvar pick-up       ; pick up the object ?x
  '((pre (holds nil) (cleartop ?x) (supports ?y ?x))
    (del (holds nil) (supports ?y ?x))
    (add (holds ?x)  (cleartop ?y))
    ))


Note: since pick-up is an association list its parts can be accessed using the -> function in utils...
 

> (-> pick-up 'del)
==> ((HOLDS NIL) (SUPPORTS ?Y ?X))


Given the kind of operator description above, a generalised apply operator function can be built around the use of the matcher.
 

(defun apply-op (op object world)
   (let ((pre (-> op 'pre))
         (del (-> op 'del))
         (add (-> op 'add))
         )
      (all-present (pre world `((x ,object)))
        ($+ (match-bind add)
            ($- world (match-bind del)))
        )))

> (apply-op pick-up 'p1 blocks)
==> ((CLEARTOP B1) (HOLDS P1) (CLEARTOP FLOOR)
     (CLEARTOP B2) (CLEARTOP P1) (SUPPORTS FLOOR B2)
     (SUPPORTS FLOOR B1) (ISA P1 PYRAMID)...)


This example is concluded here by creating more GPS operators and a mechanism which will apply a series of commands.
 

(defvar ops
 '((pick-up     ; as defined above
     (pre (holds nil) (cleartop ?x) (supports ?y ?x))
     (del (holds nil) (supports ?y ?x))
     (add (holds ?x)  (cleartop ?y)))
   (drop-on     ; puts one object on top of another
     (pre (holds ?obj) (cleartop ?x))
     (del (holds ?obj) (cleartop ?x))
     (add (holds nil) (supports ?x ?obj))  )))

; arm-control accepts a series of commands like
;   (pick-up b1) & provides textual output

(defun arm-control (world commands)
  (dolist (com commands)
    (format t "~2&Applying ~a..." com)
    (setf world
      (apply-op (-> ops (first com)) (second com)
             world))
    (format t "ok~%")
    (pprint world)   ))

> (arm-control blocks '((pick-up p1) (drop-on b2)))

==> Applying (PICK-UP P1)...ok
==> ((CLEARTOP B1) (HOLDS P1) (CLEARTOP FLOOR)
     (CLEARTOP B2) (CLEARTOP P1) (SUPPORTS FLOOR B2)
     (SUPPORTS FLOOR B1) (ISA P1 PYRAMID)
     (ISA B2 BLOCK) (ISA B1 BLOCK))

==> Applying (DROP-ON B2)...ok
==> ((SUPPORTS B2 P1) (HOLDS NIL) (ISA B1 BLOCK)
     (ISA B2 BLOCK) (ISA P1 PYRAMID)
     (SUPPORTS FLOOR B1) (SUPPORTS FLOOR B2)
     (CLEARTOP P1) (CLEARTOP FLOOR) (CLEARTOP B1))
    NIL