The following example is a complete segment of code which allocates person objects to car objects. Note how once the class definitions have been made, the rules do not in any way reflect the fact that there is an underlying database. The example output assumes a database initialised by the following SQL statements:
drop table CAR ;
create table CAR
(PLATE CHAR(8) NOT NULL, MAKE CHAR(20),
VALUE INTEGER, OWNER CHAR(20) );
grant all on CAR to public ;
insert into CAR values
('E265 FOO', 'VAUXHALL', 5000, '');insert into CAR values
('XDG 792S', 'ROLLS', 50000, '');insert into CAR values
('F360 OOL', 'FORD', 4000, 'PERSEPHONE');insert into CAR values
('H151 EEE', 'JAGUAR', 15000, '');insert into CAR values
('G722 HAD', 'SKODA', 500, '');drop table PERSON ;
create table PERSON
(NAME CHAR(20) NOT NULL, SALARY INTEGER, CAR CHAR(8),
EMPLOYER CHAR(20) ) ;
insert into PERSON values ('FRED', 10000, '', 'IBM');insert into PERSON values ('HARRY', 20000, '', 'FORD');insert into PERSON values ('PHOEBE', 5000, '', '' );insert into PERSON values ('TOM', 50000, '', 'ACME' );insert into PERSON values
('PERSEPHONE', 15000, 'F360 OOL', 'ICL');drop table COMPANY ;
create table COMPANY
(NAME CHAR (20), PRODUCT CHAR(10) );
insert into COMPANY values ('IBM', 'COMPUTERS');insert into COMPANY values ('FORD', 'CARS');insert into COMPANY values ('ICL', 'COMPUTERS');insert into COMPANY values ('ACME', 'TEAPOTS');Below is an example rulebase that analyses the database and outputs a suggestion as to which car should be allocated to which person. The full code and the SQL statements to set up the database are included in the examples distributed with KnowledgeWorks.
(in-package "KW-USER");;; the car class maps onto the car table in the
;;; database owner is a join slot which looks up the
;;; owner person object
(sql:def-view-class car
(sql:standard-db-object standard-kb-object)
((number-plate :accessor car-number-plate
:type (string 8)
:db-kind :key
:column plate)
(make :accessor car-make
:type (string 20)
:db-kind :base
:column make)
(value :accessor car-value
:type integer
:db-kind :base
:column value)
(owner-name :type (string 20)
:db-kind :base
:column owner)
(owner :accessor car-owner
:db-kind :join
:db-info (:home-key owner-name
:foreign-key name
:join-class person
:set nil
:retrieval :deferred))))
;;; the person class maps onto the person table in the
;;; database
;;; car is a join slot which looks up the owned car
;;; object
;;; company is a join slot which looks up the company
;;; object
(sql:def-view-class person
(sql:standard-db-object standard-kb-object)
((name :accessor person-name
:type (string 20)
:db-kind :key
:column name)
(salary :accessor person-salary
:type integer
:db-kind :base
:column salary)
(car-number-plate :type (string 8)
:db-kind :base
:column car)
(car :accessor person-car
:db-kind :join
:db-info (:home-key car-number-plate
:foreign-key number-plate
:join-class car
:set nil
:retrieval :deferred))
(employer :type (string 20)
:db-kind :base
:column employer)
(company :accessor person-company
:db-kind :join
:db-info (:home-key employer
:foreign-key name
:join-class company
:set nil
:retrieval :deferred))))
;;; the company class maps onto the company table in
;;; the database
(sql:def-view-class company
(sql:standard-db-object standard-kb-object)
((name :accessor company-name
:type (string 20)
:db-kind :key
:column name)
(product :accessor company-product
:type (string 10)
:db-kind :base
:column product)))
;;; here we assume we have a database connected with
;;; the correct data in it - if we do we retrieve all
;;; the person and car objects but company objects will
;;; be retrieved only when needed by querying the
;;; company slot of the person objects
(if sql:*default-database*
(progn (sql:select 'car)
(sql:select 'person))
(format t
"~%Please connect to a database with
contents ~ created by file data.sql"))
;;; to store which cars a person can drive
(def-kb-struct cars-for-person person cars)
(defcontext database-example :strategy (priority))
;;; for every person initialise the list of cars they
;;; can drive
(defrule init-cars-for-person :forward
:context database-example
(person ?person car nil)
-->
(assert
(cars-for-person ? person ?person cars nil)))
;;; for every car a person can drive which hasn't yet
;;; been included in the list, add it to the list
(defrule car-for-person :forward
:context database-example
(person ?person car nil)
(car ?car owner nil)
(cars-for-person ?c-f-p person ?person cars ?cars)
(test (not (member ?car ?cars)))
; has it been included?
-->
(car-ok-for-person ?car ?person)
; check if ok to drive car
(assert
(cars-for-person ?c-f-p cars (?car . ?cars))))
;;; rules expressing what cars a person can drive:
;;; if they have no employer they can only drive a
;;; skoda otherwise they will refuse to drive a skoda.
;;; anyone will drive a rolls or a jag.
;;; they'll only drive a ford or vauxhall if salary is
;;; less than 40k.
(defrule car-ok-for-person :backward
((car-ok-for-person ?car ?person)
<--
(person ?person company nil)
(cut)
(car ?car make "SKODA"))
((car-ok-for-person ?car ?person)
<--
(car ?car make "SKODA")
(cut)
(fail))
((car-ok-for-person ?car ?person)
<--
(or (car ?car make "ROLLS")
(car ?car make "JAGUAR"))
(cut))
((car-ok-for-person ?car ?person)
<--
(or (car ?car make "VAUXHALL")
(car ?car make "FORD"))
(person ?person salary ?salary)
(test (< ?salary 40000))))
;;; next to rules are just simple allocation rules,
;;; trying out each possibility until one fits
(defrule alloc-cars-to-persons :backward
((alloc-cars-to-persons ?allocs)
<--
(alloc-internal nil nil nil ?allocs)))
(defrule alloc-internal :backward
((alloc-internal ?done-persons ?done-cars
?allocs ?allocs)
<--
(not (and (cars-for-person ? person ?person)
(not (member ?person ?done-persons))))
(cut))
((alloc-internal ?done-persons ?done-cars
?allocs-so-far ?allocs)
<--
(cars-for-person ? person ?person cars ?cars)
(not (member ?person ?done-persons))
(member ?car ?cars)
(not (member ?car ?done-cars))
(alloc-internal (?person . ?done-persons)
(?car . ?done-cars)
((?person . ?car) . ?allocs-so-far)
?allocs)))
;;; find a solution and print it out(defrule find-solution :forward
:context database-example
:priority 5
(not (not (cars-for-person ?)))
-->
(alloc-cars-to-persons ?solution)
((dolist (pair ?solution)
(format t "~%~A drives ~A"
(person-name (car pair))
(car-number-plate (cdr pair))))))
Below is sample output from the rulebase with SQL recording turned on to demonstrate the SQL statements that are automatically passed to the database by manipulating the objects:
KW-USER 53 > (infer :contexts '(database-example))
(SELECT CAR.PLATE,CAR.MAKE,CAR.VALUE,CAR.OWNER FROM CAR
WHERE (CAR.PLATE = 'F360 OOL'))
(SELECT CAR.PLATE,CAR.MAKE,CAR.VALUE,CAR.OWNER FROM CAR
WHERE (CAR.PLATE = ''))
(SELECT CAR.PLATE,CAR.MAKE,CAR.VALUE,CAR.OWNER FROM CAR
WHERE (CAR.PLATE = ''))
(SELECT
PERSON.NAME,PERSON.SALARY,PERSON.CAR,PERSON.EMPLOYER
FROM PERSON WHERE (PERSON.NAME = ''))
(SELECT CAR.PLATE,CAR.MAKE,CAR.VALUE,CAR.OWNER FROM CAR
WHERE (CAR.PLATE = ''))
(SELECT
PERSON.NAME,PERSON.SALARY,PERSON.CAR,PERSON.EMPLOYER
FROM PERSON WHERE (PERSON.NAME = ''))
(SELECT CAR.PLATE,CAR.MAKE,CAR.VALUE,CAR.OWNER FROM CAR
WHERE (CAR.PLATE = ''))
(SELECT
PERSON.NAME,PERSON.SALARY,PERSON.CAR,PERSON.EMPLOYER
FROM PERSON WHERE (PERSON.NAME = ''))
(SELECT
PERSON.NAME,PERSON.SALARY,PERSON.CAR,PERSON.EMPLOYER
FROM PERSON WHERE (PERSON.NAME = ''))
(SELECT
PERSON.NAME,PERSON.SALARY,PERSON.CAR,PERSON.EMPLOYER
FROM PERSON WHERE (PERSON.NAME = 'PERSEPHONE'))
(SELECT COMPANY.NAME,COMPANY.PRODUCT FROM COMPANY
WHERE (COMPANY.NAME = 'FORD'))
(SELECT COMPANY.NAME,COMPANY.PRODUCT FROM COMPANY
WHERE (COMPANY.NAME = 'ACME'))
(SELECT COMPANY.NAME,COMPANY.PRODUCT FROM COMPANY
WHERE (COMPANY.NAME = 'IBM'))
(SELECT COMPANY.NAME,COMPANY.PRODUCT FROM COMPANY
WHERE (COMPANY.NAME = ''))
HARRY drives E265 FOO
TOM drives XDG 792S
FRED drives H151 EEE
PHOEBE drives G722 HAD
26