AI PROGRAMMING WITH PROLOG PART 3
ARTIFICIAL INTELLIGENCE PROGRAMMING WITH PROLOG
WORKSHOP I
PART 3 (Examples 141-203)
LEARNING prolog
BY EXAMPLE
I have recompiled over 200 prolog examples with test. Since this is a self-learning program, I recommend that you review the materials provided in the AI Programming resources page. Since I recommend using gnu prolog, you can also visit their User's Guide and their website.
To download the pdf guide, click here.
The easiest way to obtain an executable from a Prolog source file example1.pl is to use:
% gplc example1.pl
This will produce a native executable called example1 which can be executed from the prolog command line interface, as follows:
% example1
You can enhance the options you have, by studying the user's guide literature.
EXAMPLE 141
% A model of movement - state is set of facts object at place
:-op(690, xfx, at).
:-dynamic(at/2).
is_place(X):-_ at X.
is_object(X):-X at _.
% 'put' is already in reserved for char output.
place(X,At):-assert(X at At), write(X), write(' is now at '), write_ln(At),!.
take(X,From):-retract(X at From),
write(X), write(' was at '), write_ln(From),!.
move(X, To):-move(X,_,To).
move(X, From, To):-retract(X at From),
write(X), write(' was at '), write_ln(From),
assert(X at To),
write(X), write(' is now at '), write_ln(To),!.
d:-X at Y, write(X), write(' is at '), write_ln(Y), nl,
fail.
q:-halt.
EXAMPLE 142
%Prolog example developed by Dr. Klerer, CSUSB
test :- exp([a,s,i,n],_,0).
t(X) :- exp(X,_,0).
exp(X) :- size(X,Y), exp(X,Y,0).
exp(Text,Size,0) :- v(Text,Size).
exp(Text,Size,Count) :- S is Size-Count, v(T1,S),
append(T1,T2,Text), exp(T2,Count,0).
exp(Text,Size,Count) :- C is Count+1, C < Size, exp(Text,Size,C).
e1(X,L) :- size(X,Y), exp1(X,Y,0,L).
exp1(Text,Size,0,Text) :- v(Text,Size), !.
exp1(Text,Size,Count,[T1,L]) :- S is Size-Count, v(T1,S),
append(T1,T2,Text), exp1(T2,Count,0,L), !.
exp1(Text,Size,Count,L) :- C is Count+1, C < Size, exp1(Text,Size,C,L).
e(X,L) :- size(X,Y), e(X,Y,L).
e(Text,Size,Text) :- v(Text,Size).
e(Text,Size,[T1,L]) :-append(T1,T2,Text), v(T1,Size), e(T2,L).
e(Text,Size,L) :- S is Size-1, S > 0, e(Text,S,L).
append([],L,L).
append([X; L1],L2,[X; L3]) :- append(L1,L2,L3).
v(Word,Size) :- w(Word), size(Word,Size).
ex(T) :- va(T), !.
ex(T) :- va(T1), ex(T2), append(T1,T2,T).
ex(T,T) :- va(T).
ex(T,[T1; L]) :- append(T1,T2,T), va(T1), ex(T2,L).
va(Word) :- va(Word,10).
va(W,C) :- v(W,C).
va(W,C) :- C1 is C-1, C1 > 0, va(W,C1).
size([],0).
size([X; Y],Z) :- size(Y,Q), Z is Q+1.
w([a]).
w([s,i,n]).
w([x]).
w([y]).
w([x,y]).
:- write('Loaded'), nl.
EXAMPLE 143
oddity(1, 1).
oddity(N, ODD):-N>1, N1 is N-1, oddity(N1,ODD1), ODD is ODD1+2.
EXAMPLE 144
% Super-duper oddity predicate. Can be used in three ways:
% oddity(4,7)? oddity(3, F)? oddity(N, 27)?
numeric(X):- atomic(X), not(atom(X)).
% No, this is not a joke.
oddity(1, 1).
oddity(N, ODD) :-
numeric(N),
!,
N > 1,
N1 is N - 1,
oddity(N1, ODD1),
ODD is ODD1 + 2.
oddity(N, F) :-
numeric(F),
F > 2,
F2 is F - 2,
oddity(N2, F2),
N is 1 + N2.
EXAMPLE 145
oddity(1, 1).
oddity(N, ODD) :-
numeric(N),
N > 1,
N1 is N - 1,
oddity(N1, ODD1),
ODD is ODD1 + 2.
oddity(N, ODD) :-
numeric(ODD),
ODD > 1,
ODD1 is ODD - 2,
oddity(N1, ODD1),
N is N1 + 1.
numeric(X) :-
atom(X),
!,
fail.
numeric(X) :-
atomic(X),
!.
EXAMPLE 146
number(zero).
number(X) :-
X = next(Y),
number(Y).
less(0, X):-X\=0.
less(X, next(X)).
less(X, Z) :-
Z = next(Y),
less(X, Y).
less(next(X),X):-fail.
EXAMPLE 147
% generating primes in prolog
% This grows a data base of primes - with the largest prime first...
prime(3).
prime(2).
new_prime(I):-var(I),!, repeat,generate(I), asserta(prime(I)).
new_prime(I):- % nonvariable(I)
write('Usage: new_prime(Variable)'), nl, !, fail.
generate(Next):-
prime(Last),
Plus2 is Last +2, !,
scan(candidate, Plus2),
candidate(Next),
not has_divisor(Next),!.
has_divisor(J):- prime(D), 0 is J mod D.
% Scanning the integers scan the next with a property
% use like this: scan(i,First),i(I), Until,abolish(i)...
scan(Label,I):- V=I,
(Garbage=..[Label,_], Garbage,abolish(Label); true),
Count=..[Label,V], asserta(Count).
scan(Label,I):-Count=..[Label,V], retract(Count,_),
Next is V+2, Count2=..[Label,Next], asserta(Count2).
scan(Label,I):-abolish(Label), fail.
:-trace [generate, candidate, prime, scan].
:-listing.
:- write('input new_prime(P)? to generate a new prime'), nl.
EXAMPLE 148
% generating primes in prolog
% This grows a data base of primes - with the largest prime first...
:-dynamic(prime/1).
prime(3).
prime(2).
new_prime(I):-var(I),!,repeat, generate(I), asserta(prime(I)).
new_prime(_):- % nonvariable(I)
write('Usage: new_prime(Variable)'), nl, !, fail.
generate(Next):-
prime(Last),
!,
scan(Last, Next),
not( has_divisor(Next)),!.
has_divisor(J):- prime(D), 0 is J mod D.
% after the for statement from T Van Le 92
scan(N,I):-I is N+2.
scan(N,I):-scan(N,I2), I is I2+2.
EXAMPLE 149
% generating primes in prolog
% This grows a data base of primes - with the largest prime first...
:-dynamic(prime/1).
prime(3).
prime(2).
new_prime(I):-var(I),!,repeat, generate(I), asserta(prime(I)).
new_prime(_):- % nonvariable(I)
write('Usage: new_prime(Variable)'), nl, !, fail.
generate(Next):-
prime(Last),
!,
scan(Last, Next),
not( has_divisor(Next)),!.
has_divisor(J):- prime(D), 0 is J mod D.
% after the for statement from T Van Le 92
scan(N,I):-I is N+2.
scan(N,I):-scan(N,I2), I is I2+2.
EXAMPLE 150
% generating primes in prolog using the sieve of Eratosthenes
% start by generating a data base of natural numbers natural(i) for i = 2..N
% repeatedly take the first as a prime and strike out its multiples
% Afterwards if P is a Prime between 2 and N (inclusive) then prime(P) will
% be in the database
:-style_check(-singleton).
:-dynamic(lastnumber/1).
:-dynamic(natural/1).
:-dynamic(prime/1).
:-dynamic(multiply/1).
prin(X):-write(X).
primes(N):-cleanup, generate(N), !, strikeout(N), !, display.
cleanup:-abolish(lastnumber,1), abolish(natural,1), abolish(prime,1), abolish(multiple,1).
display:-prime(P), prin(P), prin(' '),fail.
status:-natural(N), prin(N), prin(' '),fail.
% Scanning the integers scan the next with a property
% use like this: scan(i,First),i(I), Until,abolish(i,1)...
scan(Label):- scan(Label, 2, 1).
scan(Label,First,Step):-V=First,
(Garbage=..[Label,_], Garbage,abolish(Label,1); true),
Count=..[Label,V], asserta(Count).
scan(Label,First,Step):-Count=..[Label,V], retract(Count,_),
Next is V+Step, Count2=..[Label,Next], asserta(Count2).
generate(N):- scan(lastnumber), lastnumber(Last),assertz(natural(Last)), Last>=N,!, abolish(lastnumber,1).
strikeout(N):- natural(Prime), write(Prime), nl, assertz(prime(Prime)), multiples(Prime,N), Prime>=N.
multiples(Prime, N):-
scan(multiple, Prime, Prime), multiple(M),
remove(M),
M>=N,!,
abolish(multiple,1).
remove(M):-natural(M),retract(natural(M),_),!.
remove(M):-true,!.
% trace [prime, multiples, multiple]!
:-listing.
:- write('Use primes(P). to generate primes in range 2..P'), nl.
EXAMPLE 151
random_state(7).
N is random( Largest)+1 :-
retract(random_state(Number)),
RN is 15 * Number mod 2027,
N is RN mod Largest + 1,
asserta(random_state(RN)).
:- write(' Number is random( LargestNumber), nl+1, random_state(LastNumber) loaded!').
EXAMPLE 152
% Generate random numbers. From Schnupp & Barnard p112
:-dynamic(random_state/1).
random_state(17).
random(N, Largest):- retract(random_state(Number)),
RN is (25173 * Number + 13849) mod 65536,
N is (RN mod Largest) + 1,
asserta(random_state(RN)).
:- write(' random( Variable, LargestNumber), nl+1, random_state(LastNumber) loaded!').
EXAMPLE 153
%Prolog example developed by Dr. Klerer
go(Start,Goal,Route) :- go1([[Start]],Goal,R),rev(R,Route).
go1([First| Rest],Goal,First) :- First = [Goal| _].
go1([[Last| Trail]| Others],Goal,Route) :-
findall([Z,Last| Trail],legalnode(Last,Trail,Z),List),
append(Others,List,Newroutes),
go1(Newroutes,Goal,Route).
legalnode(X,Trail,Y) :- (a(X,Y);a(Y,X)),not(member(Y,Trail)).
% reverse list O(n^2)
rev([],[]).
rev([H| T],L) :- rev(T,Z), append(Z,[H],L).
a(g,h).
a(g,d).
a(e,d).
a(h,f).
a(e,f).
a(a,e).
a(a,b).
a(b,f).
a(b,c).
a(f,c).
:- write('Shortest path demo loaded'), nl.
EXAMPLE 154
% allow the addition of new paths as they are found.
:-dynamic(path/1).
% data describe movements in maze
move(a,b). move(b,c). move(c,d). move(c,e). move(e,f).
% The simplest path is a single movement
path([X,Y]):-move(X,Y).
% construct more complex paths from simpler paths and movements
go([X,Y|Z]):-path([Y|Z]), move(X,Y),assert_if_new(path([X,Y|Z])), listing(path).
go:-go(Path), fail.
% add Fact to database if it is not already a Clause in the database
assert_if_new(Fact):-clause(Fact,true),!; assert(Fact).
EXAMPLE 155
% Prototype model of the ADT set with these operations
% X in S ::= True when X is a member of S
% add(Element, ToSet)
% Each element occurs once, if at all
% remove(Element, FromSet)
% Only if Element in FromSet
% null(Set)
% new_set(Set)
:-op(695,xfx,in).
:-dynamic(in/2).
new_set(S):-retract(X in S), fail.
new_set(S).
null(S):-not(X in S).
add(X,S):-not(X in S), !, asserta(X in S).
remove(X,S):-retract(X in S).
:-print! write('new_set(S), nl, null(S), add(X,S), remove(X,S), X in S loaded').
:-print('Try: add(1,a). add(2,a). 1 in a. 2 in a. 3 in a. X in a.').
EXAMPLE 156
% implementing stacks in Prolog is easy by using the data base
:-dynamic(stack_top/2).
new_stack(S):-retract(stack_top(S,_)), fail.
empty_stack(S):-not(stack_top(S,_)).
push(S,I):-asserta(stack_top(S, I)).
top(S,I):-stack_top(S,I), !.
pop(S,I):-retract(stack_top(S,I)).
EXAMPLE 157
%Example of prolog developed by Dr. Klerer, CSUSB
preorder(X,[X]) :- atomic(X).
preorder([X; [Y; Z]],[X,Y1,Z1]) :- preorder(Y,Y1), preorder(Z,Z1).
:-print('preorder(X,Y) is loaded').
EXAMPLE 158
%Prolog example developed by Dr. Klerer, CSUSB
t1(L) :- input([i,n,t,a,b,c,',',r,e,a,l,d],[],L).
input(S,SZ,[L1]) :- declaration(S,SZ,L1).
input(S,SZ,[L1,L]) :- declaration(S,S1,L1), comma(S1,S2), input(S2,SZ,L).
declaration(S,SZ,sym(intx,L)) :- intx(S,S1), variables(S1,SZ,L).
declaration(S,SZ,sym(realx,L)) :- realx(S,S1), variables(S1,SZ,L).
variables(S,SZ,[L]) :- variable(S,SZ,L).
variables(S,SZ,[L; L1]) :- variable(S,S1,L), variables(S1,SZ,L1).
variable([a; S],S,a).
variable([b; S],S,b).
variable([c; S],S,c).
variable([d; S],S,d).
variable([e; S],S,e).
intx([i,n,t; S],S).
realx([r,e,a,l; S],S).
comma([','; S],S).
:- write('Compilation example loaded'), nl.
EXAMPLE 159
%Prolog example developed by Dr. Klerer, New York
%/* */
go(Start,Goal,Route) :- go1([[Start]],Goal,R),rev(R,Route).
go1([First; Rest],Goal,First) :- First = [Goal; _].
go1([[Last; Trail]; Others],Goal,Route) :-
findall([Z,Last; Trail],legalnode(Last,Trail,Z),List),
append(Others,List,Newroutes),
go1(Newroutes,Goal,Route).
%/* */
%/* different_sides is used to provide a means of getting the boat */
%/* between the sides of the river. */
different_sides(a,b).
different_sides(b,a).
%/* */
%/* dinner_time is the predicate that demonstates the invalid */
%/* conditions of the problem. It should be noted that it is a */
%/* derivation to save time: (C>M and M\=0) or (3-C>3-M and 3-M\=0) */
%/* ==> (C>M and M\=0) or (C<M and M\=3) since when M=0 is may not */
%/* be greater than C and converely with M=3, we get: */
%/* M\=0 and M\=3 and (C>M or C<M). I could have avoided this */
%/* derivation by defining an or predicate. */
dinner_time(M,C) :-
M\=3,
M\=0,
M\=C.
%/* */
%/* The rule predicates decribe all of the possible state transitions */
%/* where the first variable is the description of the action */
%/* containing the occupants of the boat and the side of the river */
%/* the traversal originated at. The second and third variable */
%/* decribe the states before and after the action respectively. */
rule(boat(a_missionary,S1),state(M1,C1,S1),state(M2,C2,S2)) :-
M2 is 3-M1+1,
C2 is 3-C1,
different_sides(S1,S2),
not dinner_time(M2,C2),
M1>=1.
rule(boat(a_cannibal,S1),state(M1,C1,S1),state(M2,C2,S2)) :-
M2 is 3-M1,
C2 is 3-C1+1,
different_sides(S1,S2),
not dinner_time(M2,C2),
C1>=1.
rule(boat(two_cannibals,S1),state(M1,C1,S1),state(M2,C2,S2)) :-
M2 is 3-M1,
C2 is 3-C1+2,
different_sides(S1,S2),
not dinner_time(M2,C2),
C1>=2.
rule(boat(two_missionaries,S1),state(M1,C1,S1),state(M2,C2,S2)) :-
M2 is 3-M1+2,
C2 is 3-C1,
different_sides(S1,S2),
not dinner_time(M2,C2),
M1>=2.
rule(boat(one_of_each,S1),state(M1,C1,S1),state(M2,C2,S2)) :-
M2 is 3-M1+1,
C2 is 3-C1+1,
different_sides(S1,S2),
not dinner_time(M2,C2),
M1>=1,
C1>=1.
:-print('Missionaries, cannibals and boat is ready!').
EXAMPLE 160
% Example of colorring in a map so that no two adjacent areas have the same color.
% From Debray & Warren, IEEE Trans SE, 16, No 3, Mar 90, p345
adjacent(X, Y) :-
color(X),
color(Y),
X \= Y.
color(red).
color(blue).
color(green).
color(yellow).
doit :-
map(A, B, C, D, E),
write(A), nl,
write(B), nl,
write(C), nl,
write(D), nl,
write(E), nl.
map(A, B, C, D, E) :-
adjacent(A, B),
adjacent(C, D),
adjacent(C, E),
adjacent(A, C),
adjacent(A, D),
adjacent(B, C),
adjacent(B, E),
adjacent(D, E).
:- write('Map coloring loaded:'), nl.
:-listing.
EXAMPLE 161
%/* Monkey and the banana problem Robert Klerer */
%/* */
% solve(Time, Actions, States)? Generates possible plans...
solve(0,[],[state(a,c,d,couch,nil)]).
solve(T1,[A; H],[X,Y; Z]) :-
solve(T0,H,[Y; Z]) ,
rule(A,Y,X) ,
not member(X,[Y; Z]) ,
T1 is T0+1.
rule(get_off(couch),state(a,W,X,couch,Y),state(a,W,X,floor,Y)).
rule(get_off(chair),state(W,W,X,chair,Y),state(W,W,X,floor,Y)).
rule(get_on(chair),state(W,W,X,floor,Y),state(W,W,X,chair,Y)).
rule(get_on(couch),state(a,W,X,floor,Y),state(a,W,X,couch,Y)).
rule(move(self,a),state(W,X,Y,floor,nil),state(a,X,Y,floor,nil)).
rule(move(self,b),state(W,X,Y,floor,nil),state(b,X,Y,floor,nil)).
rule(move(self,c),state(W,X,Y,floor,nil),state(c,X,Y,floor,nil)).
rule(move(self,d),state(W,X,Y,floor,nil),state(d,X,Y,floor,nil)).
rule(move(stick,a),state(W,X,W,floor,stick),state(a,X,a,floor,stick)).
rule(move(stick,b),state(W,X,W,floor,stick),state(b,X,b,floor,stick)).
rule(move(stick,c),state(W,X,W,floor,stick),state(c,X,c,floor,stick)).
rule(move(stick,d),state(W,X,W,floor,stick),state(d,X,d,floor,stick)).
rule(move(chair,a),state(W,W,X,floor,nil),state(a,a,X,floor,nil)).
rule(move(chair,b),state(W,W,X,floor,nil),state(b,b,X,floor,nil)).
rule(move(chair,c),state(W,W,X,floor,nil),state(c,c,X,floor,nil)).
rule(move(chair,d),state(W,W,X,floor,nil),state(d,d,X,floor,nil)).
rule(grasp(stick),state(W,X,W,floor,nil),state(W,X,W,floor,stick)).
rule(drop(stick),state(W,X,W,floor,stick),state(W,X,W,floor,nil)).
rule(grasp(banana),state(b,X,Y,chair,stick),state(b,X,Y,chair,banana)).
:- write('Monkey and banana loaded!'), nl.
:-listing.
EXAMPLE 162
%/*****************************************************************************/
%/* ELIZA in Prolog */
%/* */
%/* Viren Patel */
%/* Artificial Intelligence Programs */
%/* University of Georgia, Athens, Georgia */
%/* Email: vpatel@aisun1.ai.uga.edu */
%/* */
%/* Reference */
%/* */
%/* Weizenbaum, J., (1966) ELIZA - A computer program for the study of */
%/* natural language communication between man and machine. Communications */
%/* of the ACM, 9.1:36-45. */
%/* */
%/* Acknowledgments */
%/* */
%/* read_atomics/1 and suporting clauses are courtesy of Dr. Michael A. */
%/* Covington, AI Programs, University of Georgia, Athens, Georgia from */
%/* his forthcoming book, Natural language processing for Prolog */
%/* programmers. */
%/* */
%/* match/2 and its supporting clauses make up the pattern matcher. The */
%/* basic code for the pattern matcher was obtained from the book by */
%/* R. A. O'Keefe, The craft of Prolog. */
%/* */
%/* Requires: Quintus Prolog */
%/* */
%/* To run: ?- consult(eliza). */
%/* To stop: > halt (`>' is the Eliza prompt) */
%/* */
%/* Last Revised: April 10, 1992 */
%/* */
%/*****************************************************************************/%/* Modified for UNSW Prolog at CSUSB by Rob Mallory with some */
%/* help from Dick Botting */
%/* Changes marked UNSW */
%/* (1) not --> 'not' and (2) '\+' --> not */
% Undone to fit SWI prolog 3.3.* Mar 6th 2001 by Dick Botting
%/*****************************************************************************/
% simplification rules
sr([do, 'not' ; X],[dont; Y],X,Y). % UNSW malformed list
sr([can, 'not' ; X],[cant; Y],X,Y). % UNSW malformed list
sr([cannot; X],[cant; Y],X,Y).
sr([will, 'not' ; X],[wont; Y],X,Y). % UNSW malformed list
sr([dreamed; X],[dreamt; Y],X,Y).
sr([dreams; X],[dream; Y],X,Y).
sr([how; X],[what; Y],X,Y).
sr([when; X],[what; Y],X,Y).
sr([alike; X],[dit; Y],X,Y).
sr([same; X],[dit; Y],X,Y).
sr([certainly; X],[yes; Y],X,Y).
sr([maybe; X],[perhaps; Y],X,Y).
sr([deutsch; X],[xfremd; Y],X,Y).
sr([francais; X],[xfremd; Y],X,Y).
sr([espanol; X],[xfremd; Y],X,Y).
sr([machine; X],[computer; Y],X,Y).
sr([machines; X],[computer; Y],X,Y).
sr([computers; X],[computer; Y],X,Y).
sr([am; X],[are; Y],X,Y).
sr([your; X],[my; Y],X,Y).
sr([were; X],[was; Y],X,Y).
sr([me; X],[you; Y],X,Y).
sr([you,are; X],[im; Y],X,Y). % im = i'm = i am
sr([i,am; X],[youre; Y],X,Y). % youre = you're = you are =\= your
sr([myself; X],[yourself; Y],X,Y).
sr([yourself; X],[myself; Y],X,Y).
sr([mom; X],[mother; Y],X,Y).
sr([dad; X],[father; Y],X,Y).
sr([i; X],[you; Y],X,Y).
sr([you; X],[i; Y],X,Y).
sr([my; X],[your; Y],X,Y).
sr([everybody; X],[everyone; Y],X,Y).
sr([nobody; X],[everyone; Y],X,Y).
%/*****************************************************************************/
% Make the rule base modifiable
% this is specific to Quintus Prolog and later SWI versions
% uncomment next line if needed UNSW
:- dynamic(rules/1).
%/*****************************************************************************/
% The rule base
% The format of the rules is:
%
% rules([[keyword, importance of keyword],[
% [pattern #, [the pattern], last response used,
% [response 1],
% [response 2],
% ...
% [response n]]]]).
rules([[sorry,0],[
[1,[_],0,
[please,do, 'not' ,apologize,.], % UNSW malformed list
[apologies,are, 'not' ,necessary,.], % UNSW malformed list
[what,feelings,do,you,have,when,you,apologize,'?'], % UNSW malformed list
['I',have,told,you,that,apologies,are, 'not' ,required,.]]]]).
rules([[remember,5],[
[1,[_,you,remember,Y],0,
[do,you,often,think,of,Y,'?'],
[does,thinking,of,Y,bring,anything,else,to,mind,'?'],
[what,else,do,you,remember,'?'],
[why,do,you,remember,Y,just,now,'?'],
[what,in,the,present,situation,reminds,you,of,Y,'?'],
[what,is,the,connection,between,me,and,Y,'?']],
[2,[_,do,i,remember,Y],0,
[did,you,think,'I',would,forget,Y, '?'],
[why,do,you,think,i,should,recall,Y,now,'?'],
[what,about,Y,'?'],
[equal,[what,0]],
[you,mentioned,Y,.]],
[3,[_],0,
[newkey]]]]).
rules([[if,3],[
[1,[_,if,Y],0,
[do,you,think,it,is,likely,that,Y,'?'],
[do,you,wish,that,Y,'?'],
[what,do,you,think,about,Y,'?'],
[really,',',if,Y,'?']]]]).
rules([[dreamt,4],[
[1,[_,you,dreamt,Y],0,
[really,',',Y,'?'],
[have,you,ever,fantasied,Y,while,you,were,awake,'?'],
[have,you,dreamt,Y,before,'?'],
[equal,[dream,3]],
[newkey]]]]).
rules([[dream,3],[
[1,[_],0,
[what,does,that,dream,suggest,to,you,'?'],
[do,you,dream,often,'?'],
[what,persons,appear,in,your,dreams,'?'],
[do,you,believe,that,dreaming,has,something,to,do,with,your,problem,'?'],
[newkey]]]]).
rules([[none,0],[
[1,[_],0,
['I',am, 'not' ,sure,'I',understand,you,fully,.],
[please,go,on,.],
[what,does,that,suggest,to,you,'?'],
[do,you,feel,strongly,about,discussing,such,things,'?']]]]).
rules([[perhaps,0],[
[1,[_],0,
[you,do, 'not' ,seem,halte,certain,.],
[why,the,uncertain,tone,'?'],
[can,you, 'not' ,be,more,positive,'?'],
[you,are, 'not' ,sure,'?'],
[do,you, 'not' ,know,'?']]]]).
rules([[name,15],[
[1,[_],0,
['I',am, 'not' ,interested,in,names,.],
['I',have,told,you,before,',','I',do, 'not' ,care,about,names,.],
[please,continue,.]]]]).
rules([[xfremd,75],[
[1,[_],0,
['I',am,sorry,',','I',only,speak,'English',.]]]]).
rules([[hello,0],[
[1,[_],0,
[how,do,you,do,'.','Please',state,your,problem,.]]]]).
rules([[computer,50],[
[1,[_],0,
[do,computers,worry,you,'?'],
[why,do,you,mention,computers,'?'],
[what,do,you,think,machines,have,to,do,with,your,problem,'?'],
[do,you, 'not' ,think,computers,can,help,people,'?'],
[what,about,machines,worries,you,'?'],
[what,do,you,think,about,machines,'?']]]]).
rules([[are,0],[
[1,[_,are,you,Y],0,
[do,you,believe,you,are,Y,'?'],
[would,you,want,to,be,Y,'?'],
[you,wish,'I',would,tell,you,you,are,Y,'?'],
[what,would,it,mean,if,you,were,Y,'?'],
[equal,[what,0]]],
[2,[_,are,i,Y],0,
[why,are,you,interested,in,whether,'I',am,Y,or, 'not' ,'?'],
[would,you,prefer,if,'I',were, 'not' ,Y,'?'],
[perhaps,'I',am,Y,in,your,fantasies,.],
[do,you,sometimes,think,'I',am,Y,'?'],
[equal,[what,0]]],
[3,[_,are,Y],0,
[did,you,think,they,might, 'not' ,be,Y,'?'],
[would,you,like,it,if,they,were, 'not' ,Y,'?'],
[what,if,they,were, 'not' ,Y,'?'],
[possibly,they,are,Y,.]],
[4,[_],0,
[why,do,you,say,am,'?'],
['I',do, 'not' ,understand,that,.]]]]).
rules([[my,0],[
[1,[_,my,Y],0,
[why,are,you,concerned,over,my,Y,'?'],
[what,about,your,own,Y,'?'],
[are,you,worried,about,someone,elses,Y,'?'],
[really,',',my,Y,'?']]]]).
rules([[was,2],[
[1,[_,was,you,Y],0,
[what,if,you,were,Y,'?'],
[do,you,think,you,were,Y,'?'],
[were,you,Y,'?'],
[what,would,it,mean,if,you,were,Y,'?'],
[what,does,Y,suggest,to,you,'?'],
[equal,[what,0]]],
[2,[_,you,was,Y],0,
[were,you,really,'?'],
[why,do,you,tell,me,you,were,Y,just,now,'?'],
[perhaps,'I',already,knew,you,were,Y,.]],
[3,[_,was,i,Y],0,
[would,you,like,to,believe,'I',was,Y,'?'],
[what,suggests,that,'I',was,Y,'?'],
[what,do,you,think,'?'],
[perhaps,'I',was,Y,.],
[what,if,'I',had,been,Y,'?']],
[4,[_],0,
[newkey]]]]).
rules([[im,0],[
[1,[_,im,_],0,
[equal,[i,0]]]]]).
rules([[youre,0],[
[1,[_,youre,_],0,
[equal,[you,0]]]]]).
rules([[you,0],[
[1,[_,you,cant,Y],0,
[how,do,you,know,you,can, 'not' ,Y,'?'],
[have,you,tried,'?'],
[perhaps,you,could,Y,now,'?'],
[do,you,really,want,to,be,able,to,Y,'?']],
[2,[_,you,dont,Y],0,
[do,you, 'not' ,really,Y,'?'],
[why,do,you, 'not' ,Y,'?'],
[do,you,wish,to,be,able,to,Y,'?'],
[does,that,trouble,you,'?']],
[3,[_,you,feel,Y],0,
[tell,me,more,about,such,feelings,.],
[do,you,often,feel,Y,'?'],
[do,you,enjoy,feeling,Y,'?'],
[of,what,does,feeling,Y,remind,you,'?']],
[4,[_,you,was,_],0,
[equal,[was,2]]],
[5,[_,you,Y,i,_],0,
[perhaps,in,your,fantasy,we,Y,each,other,'?'],
[do,you,wish,to,Y,me,'?'],
[you,seem,to,need,to,Y,me,.],
[do,you,Y,anyone,else,'?']],
[6,[_,you,[*,want,need,_],Y],0,
[what,would,it,mean,to,you,if,you,got,Y,'?'],
[why,do,you,want,Y,'?'],
[suppose,you,got,Y,soon,'?'],
[what,if,you,never,got,Y,'?'],
[what,would,getting,Y,mean,to,you,'?'],
[what,does,wanting,Y,have,to,do,with,this,discussion,'?']],
[7,[_,you,[*,feel,think,believe,wish,_],you,Y],0,
[do,you,really,think,so,'?'],
[but,you,are, 'not' ,sure,you,Y,'?'],
[do,you,really,doubt,you,Y,'?']],
[8,[_,you,_,[*,feel,think,believe,wish,_],_,i,_],0,
[equal,[you,0]]],
[9,[_,youre,_,[*,sad,unhappy,depressed,sick,M],_],0,
['I',am,sorry,to,hear,you,are,M,.],
[do,you,think,coming,here,will,help,you, 'not' ,to,be,M,'?'],
['I',am,sure,it,is, 'not' ,pleasant,to,be,M,.],
[can,you,explain,what,made,you,M,'?']],
[10,[_,youre,_,[*,happy,elated,glad,better,M],_],0,
[how,have,'I',helped,you,to,be,M,'?'],
[has,your,treatment,made,you,M, '?'],
[what,makes,you,M,just,now, '?'],
[can,you,explain,why,you,are,suddenly,M, '?']],
[11,[_,youre,Y],0,
[is,it,because,you,are,Y,that,you,came,to,me, '?'],
[how,long,have,you,been,Y, '?'],
[do,you,believe,it,normal,to,be,Y, '?'],
[do,you,enjoy,being,Y, '?']],
[12,[X],0,
[you,say,X],
[can,you,elaborate,on,that, '?'],
[do,you,say,X,for,some,special,reason, '?'],
[that,is,halte,interesting,.]]]]).
rules([[i,0],[
[1,[_,i,remind,you,of,_],0,
[equal,[dit,10]]],
[2,[_,im,Y],0,
[what,makes,you,think,'I',am,Y, '?'],
[does,it,please,you,to,believe,'I',am,Y, '?'],
[do,you,sometimes,wish,you,were,Y, '?'],
[perhaps,you,would,like,to,be,Y, '?']],
[3,[_,i,Y,you],0,
[why,do,you,think,'I',Y,you, '?'],
[you,like,to,think,'I',Y,you,',',do,you, 'not' , '?'],
[what,makes,you,think,'I',Y,you, '?'],
[really,',','I',Y,you,.],
[do,you,wish,to,believe,'I',Y,you, '?'],
[suppose,'I',did,Y,you,',',what,would,that,mean,to,you, '?'],
[does,someone,else,believe,'I',Y,you, '?']],
[4,[_,i,Y],0,
[we,were,discussing,you,',', 'not' ,me,.],
[oh,',',i,Y,.],
[you,are, 'not' ,really,talking,about,me,',',are,you, '?'],
[what,are,your,feelings,now, '?']]]]).
rules([[yes,0],[
[1,[_],0,
[you,seem,halte,positive,.],
[you,are,sure, '?'],
[i,see,.],
[i,understand,.]]]]).
rules([[no,0],[
[1,[_],0,
[are,you,saying,no,just,to,be,negative, '?'],
[you,are,being,a,bit,negative,.],
[why, 'not' , '?'],
[why,no, '?']]]]).
rules([[your,2],[
[1,[_,your,_,[*,mother,father,brother,sister,children,wife,M],Z],0,
[tell,me,more,about,your,family,.],
[who,else,in,your,family,Z, '?'],
[your,M, '?'],
[what,else,comes,to,mind,when,you,think,of,your,M, '?']],
[2,[_,your,Y],0,
[your,Y, '?'],
[why,do,you,say,your,Y, '?'],
[does,that,suggest,anything,else,which,belongs,to,you, '?'],
[is,it,important,to,you,that,your,Y, '?']]]]).
rules([[memory,0],[
[1,[_,your,Y],0,
[lets,discuss,further,why,your,Y,.],
[earlier,you,said,your,Y,.],
[but,your,Y, '?'],
[does,that,have,anything,to,do,with,the,fact,that,your,Y, '?']]]]).
rules([[can,0],[
[1,[_,can,i,Y],0,
[you,believe,'I',can,Y,',',do,you, 'not', '?'],
[equal,[what,0]],
[you,want,me,to,be,able,to,Y, '?'],
[perhaps,you,would,like,to,be,able,to,Y,yourself, '?']],
[2,[_,can,you,Y],0,
[whether,or, 'not',you,can,Y,depends,on,you,more,than,on,me,.],
[do,you,want,to,be,able,to,Y, '?'],
[perhaps,you,do, 'not',want,to,Y,.],
[equal,[what,0]]]]]).
rules([[what,0],[
[1,[_],0,
[why,do,you,ask, '?'],
[does,that,question,interest,you, '?'],
[what,is,it,you,really,want,to,know, '?'],
[are,such,questions,much,on,your,mind, '?'],
[what,answer,would,please,you,most, '?'],
[what,do,you,think, '?'],
[what,comes,to,your,mind,when,you,ask,that, '?'],
[have,you,asked,such,questions,before, '?'],
[have,you,asked,anyone,else, '?']]]]).
rules([[because,0],[
[1,[_],0,
[is,that,the,real,reason, '?'],
[do,any,other,reasons, 'not',come,to,mind, '?'],
[does,that,reason,seem,to,explain,anything,else, '?'],
[what,other,reasons,might,there,be, '?']]]]).
rules([[why,0],[
[1,[_,why,dont,i,Y],0,
[do,you,believe,'I',do, 'not',Y, '?'],
[perhaps,'I',will,Y,in,good,time,.],
[should,you,Y,yourself, '?'],
[you,want,me,to,Y, '?'],
[equal,[what,0]]],
[2,[_,why,cant,you,Y],0,
[do,you,think,you,should,be,able,to,Y, '?'],
[do,you,want,to,be,able,to,Y, '?'],
[do,you,believe,this,will,help,you,to,Y, '?'],
[have,you,any,idea,why,you,can, 'not',Y, '?'],
[equal,[what,0]]]]]).
rules([[everyone,2],[
[1,[_,[*,everyone,everybody,nobody,noone,M],_],0,
[really,',',M, '?'],
[surely, 'not',M, '?'],
[can,you,think,of,anyone,in,particular, '?'],
[who,',',for,example, '?'],
[you,are,thinking,of,a,very,special,person, '?'],
[who,',',may,i,ask, '?'],
[someone,special,perhaps, '?'],
[you,have,a,paticular,person,in,mind,',',do,you, 'not', '?'],
[who,do,you,think,you,are,talking,about, '?']]]]).
rules([[always,1],[
[1,[_],0,
[can,you,think,of,a,specific,example, '?'],
[when, '?'],
[what,incident,are,you,thinking,of, '?'],
[really,',',always, '?']]]]).
rules([[like,10],[
[1,[_,[*,im,youre,am,is,are,was,_],_,like,_],0,
[equal,[dit,10]]],
[2,[_],0,
[newkey]]]]).
rules([[dit,10],[
[1,[_],0,
[in,what,way, '?'],
[what,resemblance,do,you,see, '?'],
[what,does,that,similarity,suggest,to,you, '?'],
[what,other,connections,do,you,see, '?'],
[what,so,you,suppose,that,resemblance,means, '?'],
[what,is,the,connection,',',do,you,suppose, '?'],
[could,there,really,be,some,connection, '?'],
[how, '?']]]]).
rules([[halt,100],[
[1,[_],0,
[goodbye,.,'My',secretary,will,send,you,a,bill,.]]]]).
%/*****************************************************************************/
% eliza_char_type(+Char, '?Type)
% Char is an ASCII code.
% Type is whitespace, punctuation, numeric, alphabetic, or special.
eliza_char_type(46,period) :- !.
eliza_char_type(X,alphanumeric) :- X >= 65, X =< 90, !.
eliza_char_type(X,alphanumeric) :- X >= 97, X =< 123, !.
eliza_char_type(X,alphanumeric) :- X >= 48, X =< 57, !.
eliza_char_type(X,whitespace) :- X =< 32, !.
eliza_char_type(X,punctuation) :- X >= 33, X =< 47, !.
eliza_char_type(X,punctuation) :- X >= 58, X =< 64, !.
eliza_char_type(X,punctuation) :- X >= 91, X =< 96, !.
eliza_char_type(X,punctuation) :- X >= 123, X =< 126, !.
eliza_char_type(_,special).
%/*****************************************************************************/
% lower_case(+C, '?L)
% If ASCII code C is an upper-case letter, then L is the
% corresponding lower-case letter. Otherwise L=C.
lower_case(X,Y) :-
X >= 65,
X =< 90,
Y is X + 32, !.
lower_case(X,X).
%/*****************************************************************************/
% read_lc_string(-String)
% Reads a line of input into String as a list of ASCII codes,
% with all capital letters changed to lower case.
read_lc_string(String) :-
get0(FirstChar),
lower_case(FirstChar,LChar),
read_lc_string_aux(LChar,String).
read_lc_string_aux(10,[]) :- !. % end of line
read_lc_string_aux(-1,[]) :- !. % end of file
read_lc_string_aux(LChar,[LChar; Rest]) :- read_lc_string(Rest).
%/*****************************************************************************/
% extract_word(+String,-Rest,-Word) (final version)
% Extracts the first Word from String; Rest is rest of String.
% A word is a series of contiguous letters, or a series
% of contiguous digits, or a single special character.
% Assumes String does not begin with whitespace.
extract_word([C; Chars],Rest,[C; RestOfWord]) :-
eliza_char_type(C,Type),
extract_word_aux(Type,Chars,Rest,RestOfWord).
extract_word_aux(special,Rest,Rest,[]) :- !.
% if Char is special, don't read more chars.
extract_word_aux(Type,[C; Chars],Rest,[C; RestOfWord]) :-
eliza_char_type(C,Type), !,
extract_word_aux(Type,Chars,Rest,RestOfWord).
extract_word_aux(_,Rest,Rest,[]). % if previous clause did not succeed.
%/*****************************************************************************/
% remove_initial_blanks(+X, '?Y)
% Removes whitespace characters from the
% beginning of string X, giving string Y.
remove_initial_blanks([C; Chars],Result) :-
eliza_char_type(C,whitespace), !,
remove_initial_blanks(Chars,Result).
remove_initial_blanks(X,X). % if previous clause did not succeed.
%/*****************************************************************************/
% digit_value(?D, '?V)
% Where D is the ASCII code of a digit,
% V is the corresponding number.
digit_value(48,0).
digit_value(49,1).
digit_value(50,2).
digit_value(51,3).
digit_value(52,4).
digit_value(53,5).
digit_value(54,6).
digit_value(55,7).
digit_value(56,8).
digit_value(57,9).
%/*****************************************************************************/
% string_to_number(+S,-N)
% Converts string S to the number that it
% represents, e.g., '234' to 234.
% Fails if S does not represent a nonnegative integer.
string_to_number(S,N) :-
string_to_number_aux(S,0,N).
string_to_number_aux([D; Digits],ValueSoFar,Result) :-
digit_value(D,V),
NewValueSoFar is 10*ValueSoFar + V,
string_to_number_aux(Digits,NewValueSoFar,Result).
string_to_number_aux([],Result,Result).
%/*****************************************************************************/
% string_to_atomic(+String,-Atomic)
% Converts String into the atom or number of
% which it is the written representation.
string_to_atomic([C; Chars],Number) :-
string_to_number([C; Chars],Number), !.
string_to_atomic(String,Atom) :- name(Atom,String).
% assuming previous clause failed.
%/*****************************************************************************/
% extract_atomics(+String,-ListOfAtomics) (second version)
% Breaks String up into ListOfAtomics
% e.g., ' abc def 123 ' into [abc,def,123].
extract_atomics(String,ListOfAtomics) :-
remove_initial_blanks(String,NewString),
extract_atomics_aux(NewString,ListOfAtomics).
extract_atomics_aux([C; Chars],[A; Atomics]) :-
extract_word([C; Chars],Rest,Word),
string_to_atomic(Word,A), % <- this is the only change
extract_atomics(Rest,Atomics).
extract_atomics_aux([],[]).
%/*****************************************************************************/
% clean_string(+String,-Cleanstring)
% removes all punctuation characters from String and return Cleanstring
clean_string([C; Chars],L) :-
eliza_char_type(C,punctuation),
clean_string(Chars,L), !.
clean_string([C; Chars],[C; L]) :-
clean_string(Chars,L), !.
clean_string([C; []],[]) :-
eliza_char_type(C,punctuation), !.
clean_string([C; []],[C]).
%/*****************************************************************************/
% read_atomics(-ListOfAtomics)
% Reads a line of input, removes all punctuation characters, and converts
% it into a list of atomic terms, e.g., [this,is,an,example].
% read_atomics(ListOfAtomics) :-
% read_lc_string(String),
% clean_string(String,Cleanstring),
% extract_atomics(Cleanstring,ListOfAtomics).
% :-trace read_atomics.
read_atomics(ListOfAtomics):-read_atom(ListOfAtomics).
read_atom([A|T]):-atom(A), word(A), !, read_atom(T).
read_atom([]).
word(A):-not(eof), not(punct(A)).
punct('.'). punct(','). punct('?'). punct(';'). punct(':'). punct('!').
%/****************************************************************************/
% isalist(+List)
% checks if List is actually a list
isalist([_; _]).
%/****************************************************************************/
% member(?Element,+List)
% checks if Element is in List
% Uncomment the following two lines if not biult in R Botting UNSW
% member(X,[X; _]).
% member(X,[_|T]) :- member(X,T).
%/****************************************************************************/
% append(?List1, ?List2, ?List3)
% appends List2 on the end of List1 and returns it as List3
%
% append([],L,L).
% append([X; L1],L2,[X; L3]) :- append(L1,L2,L3).
%
%/****************************************************************************/
% flatten(+List,-FlatList)
% flattens List with sublists into FlatList
% flatten([],[]).
% flatten([H; T],[H; T2]) :- \+ isalist(H),
% flatten(T,T2).
% flatten([H; T],L) :- isalist(H),
% flatten(H,A),
% flatten(T,B),
% append(A,B,L).
%/****************************************************************************/
% last_member(-Last,+List)
% returns the last element of List in Last
last_member(End,List) :- append(_,[End],List).
%/****************************************************************************/
% findnth(+List,+Number,-Element)
% returns the Nth member of List in Element
findnth([E; _],1,E).
findnth([_; T],N,T1) :- V is N - 1,
findnth(T,V,T1).
%/****************************************************************************/
% replace(+Element1,+List1,+Element2,-List2)
% replaces all instances of Element1 in List1 with Element2 and returns
% the new list as List2
% does not replace variables in List1 with Element1
replace(_,[],_,[]).
replace(X,[H; T],A,[A; T2]) :- nonvar(H), H = X, !, replace(X,T,A,T2).
replace(X,[H; T],A,[H; T2]) :- replace(X,T,A,T2).
%/****************************************************************************/
% simplify(+List,-Result)
% implements non-overlapping simplification
% simplifies List into Result
simplify(List,Result) :- sr(List,Result,X,Y), !,
simplify(X,Y).
simplify([W; Words],[W; NewWords]) :- simplify(Words,NewWords).
simplify([],[]).
%/****************************************************************************/
% match(+MatchRule,+InputList)
% matches the MatchRule with the InputList. If they match, the variables
% in the MatchRule are instantiated to one of three things:
% an empty list
% a single word
% a list of words
match(A,C) :- match_aux1(A,C),!.
match(A,C) :- match_aux2(A,C).
match_aux1(A,C) :-
member(['*'; T],A),
nonvar(T),
member(Tm,T),
nonvar(Tm),
replace(['*'; T],A,Tm,B),
match_aux2(B,C),
!, last_member(L,T), L = Tm.
match_aux2([],[]).
match_aux2([Item; Items],[Word; Words]) :-
match_aux3(Item,Items,Word,Words),!.
match_aux2([Item1,Item2; Items],[Word; Words]) :-
var(Item1),
nonvar(Item2),
Item2 == Word,!,
match_aux2([Item1,Item2; Items],[[],Word; Words]).
match_aux2([Item1,Item2; Items],[Word; Words]) :-
var(Item1),
var(Item2),!,
match_aux2([Item1,Item2; Items],[[],Word; Words]).
match_aux2([[]],[]).
match_aux3(Word,Items,Word,Words) :-
match_aux2(Items,Words), !.
match_aux3([Word; Seg],Items,Word,Words0) :-
append(Seg,Words1,Words0),
match_aux2(Items,Words1).
%/****************************************************************************/
% makecomment(+KeyWordList,+InputList,-Comment)
% returns ELIZA's Comment to the InputList based on the KeyWordList
% takes care of special keywords 'your', and 'memory', which require
% additional processing before a comment can be generated
makecomment([[your,2]; T],InputList,Comment) :-
assertz(mem(InputList)),
rules([[your,2],Reassembly]),
mc_aux([[your,2]; T],Reassembly,InputList,Comment),!.
makecomment([[memory,0]; T],_,Comment) :-
retract(mem(I2)),
retractall(mem(I2)),
rules([[memory,0],Reassembly]),
mc_aux([[memory,0]; T],Reassembly,I2,Comment),!.
makecomment([[memory,0]; T],InputList,Comment) :-
\+ retract(mem(_)),!,
makecomment(T,InputList,Comment).
makecomment([Keyword; T],InputList,Comment) :-
rules([Keyword,Reassembly]),
mc_aux([Keyword; T],Reassembly,InputList,Comment),!.
makecomment([_; T],InputList,Comment) :-
makecomment(T,InputList,Comment),!.
mc_aux(KeyWordList,[[DRuleNum,MatchRule,N; T]; _],InputList,Comment) :-
match(MatchRule,InputList),
mc_aux2(KeyWordList,DRuleNum,N,T,InputList,Comment),!.
mc_aux(KeyWordList,[_; T],InputList,Comment) :-
mc_aux(KeyWordList,T,InputList,Comment).
mc_aux(_,[],_,_) :- !,fail.
mc_aux2(KeyWordList,DRuleNum,N,T,InputList,Comment) :-
length(T,TLen),
N < TLen, !,
NewN is N + 1,
findnth(T,NewN,Mn),
mc_aux3(KeyWordList,DRuleNum,N,NewN,Mn,InputList,Comment).
mc_aux2(KeyWordList,DRuleNum,N,T,InputList,Comment) :-
member(Mn,T),
mc_aux3(KeyWordList,DRuleNum,N,0,Mn,InputList,Comment).
mc_aux3([Keyword; T],DRuleNum,N,NewN,[equal,MnT],InputList,Comment) :-
!,
updaterule(Keyword,DRuleNum,N,NewN),
makecomment([MnT; T],InputList,Comment).
mc_aux3([Keyword; T],DRuleNum,N,NewN,[newkey],InputList,Comment) :-
!,
updaterule(Keyword,DRuleNum,N,NewN),
makecomment(T,InputList,Comment).
mc_aux3([Keyword; _],DRuleNum,N,NewN,Mn,_,Mn) :-
updaterule(Keyword,DRuleNum,N,NewN).
%/****************************************************************************/
% process_input(+Input_List,+[], '?Output)
% returns part of input after a comma, or
% part of input before a period
process_input([],L,L).
process_input(['.'; _],L,L) :- findkeywords(L,K), length(K,Kl), Kl >= 3,!.
process_input(['.'; T],_,L) :- !, process_input(T,[],L).
process_input([','; _],L,L) :- findkeywords(L,K), length(K,Kl), Kl >= 3,!.
process_input([','; T],_,L) :- !, process_input(T,[],L).
process_input([H; T],S,L) :- append(S,[H],S2), process_input(T,S2,L).
%/****************************************************************************/
% findkeywords(+InputList, '?KeyWordList)
% returns a list with the keywords in the input list
% if no keywords are found returns a list with keywords 'memory' and 'none'
findkeywords([],[[memory,0],[none,0]]).
findkeywords([H; T],[[H,I]; T1]) :- rules([[H,I]; _]), !, findkeywords(T,T1).
findkeywords([_; T],T1) :- findkeywords(T,T1).
%/****************************************************************************/
% sortkeywords(+KeyWordList, '?', SortedList)
% returns a list with the keywords sorted according to their importance
% this routine implements a simple bubble sort, customized for this
% application
sortkeywords(X,Y) :- sort_aux(X,A,1), !, sortkeywords(A,Y).
sortkeywords(X,Y) :- sort_aux(X,Y,_).
sort_aux([],[],0).
sort_aux([X],[X],0).
sort_aux([[A,X],[B,Y]; T],[[B,Y],[A,X]; T],1) :- X < Y.
sort_aux([X,Y; T],[X; T2],S) :- sort_aux([Y; T],T2,S).
%/****************************************************************************/
% updaterule(+KeyList,+DRuleNum,+N,+NewN)
% updates a rule by changing the number of the reassembly rule associated
% with a decomposition rule. The main rule to modify is indicated by
% KeyList. The decomposition rule within the main rule is indicated by
% DRuleNum. N is the previous reassembly rule used. NewN is the new
% one used. N is updated to NewN so that next time a different reassembly
% (actually the next in sequence) in used.
updaterule(KeyList,DRuleNum,N,NewN) :-
retract(rules([KeyList,Rt])),
replace([DRuleNum,A,N; T],Rt,[DRuleNum,A,NewN; T],Rt2),
assertz(rules([KeyList,Rt2])).
%/****************************************************************************/
% writecomment(+CommentList)
% prints the elements of CommentList. First Characater of first element is
% converted to uppercase befor printing
writecomment([]).
writecomment(['I'; T]) :- !, write('I'), writecomment_aux(T).
writecomment([H; T]) :- !,
name(H,[C; L]),
D is C - 32,
name(Z,[D; L]),
write(Z),
writecomment_aux(T).
writecomment_aux([]).
writecomment_aux([H; T]) :-
name(H,[C]),
eliza_char_type(C,punctuation), !,
write(H),
writecomment_aux(T).
writecomment_aux([H; T]) :-
write(' '),
write(H),
writecomment_aux(T).
%/****************************************************************************/
% halttime(+InputList)
% checks if the atom 'quit' is in the InputList
halttime(X) :- member('halt',X).
% Next twi lines needed if retractall(E) is not built in.
retractall(E):-retract(E), fail.
retractall(_).
%/****************************************************************************/
% eliza
% main routine of ELIZA
eliza :-
% reconsult('eliza.rls'),
retractall(mem(_)),nl,nl,
write('Hello. I am ELIZA. How can I help you?'),nl,write('> '),
repeat,
read_atomics(Input),nl,
process_input(Input,[],Input2),
simplify(Input2,Input3),
findkeywords(Input3,KeyWords),
sortkeywords(KeyWords,KeyWords2),
makecomment(KeyWords2,Input3,Comment),
flatten(Comment,Comment2),
writecomment(Comment2),nl,write('> '),
(eof; halttime(Input3)),
!.
:- eliza,nl,nl.
EXAMPLE 163
% A minesweeper end game
% In the last few steps of a minesweeper game you have a single mine to flag
% It is somewhere in the 4 squares in the bottom right hand corner of the board
% The corner looks like this ( f is a flag, W, X, Y, Z are unknown squares)
% f 2 1
% 2 W X
% 1 Y Z
% where is the last mine?
% Encode W, X, Y , Z is 1 for a mine and 0 for no mine on that square
% unique: u(...) is true if precisely one argument is 1 and the rest are 0
u(1,0,0,0). u(0,1,0,0). u(0,0,1,0). u(0,0,0,1).
% orginal problem
where(Field):-Field=[W, X, Y, Z], u(W,X,Y,Z),
1 is W+X,
2 is 1+W+X,
2 is 1+W+Y,
1 is W+Y.
% suppose whe don't know how many mines are in the corner
where2(Field) :- Field=[W, X, Y, Z],
(X=1;X=0), (W=1; W=0), (Y=1; Y=0), (Z=1; Z=0),
1 is W+X,
2 is 1+W+X,
2 is 1+W+Y,
1 is W+Y.
% optimized with unknown number of mines
where3(Field):-Field=[W, X, Y, Z],
(X=1;X=0), (W=1; W=0),
1 is W+X,
2 is 1+W+X,
(Y=1; Y=0),
2 is 1+W+Y,
1 is W+Y ,
(Z=1; Z=0).
go:-where3(Field), count(Field), fail.
results:-counters(W,X,Y,Z), total(T),
W1 is 100.0*W/T, write(W1), write('\t'),
X1 is 100.0*X/T, write(X1), nl,
Y1 is 100.0*Y/T, write(Y1), write('\t'),
Z1 is 100.0*Z/T, write(Z1), nl.
reset:-retract(counters(_,_,_,_)), assert(counters(0,0,0,0)), retract(total(_)), assert(total(0)).
:-dynamic(counters/4).
counters(0,0,0,0).
:-dynamic(total/1).
total(0).
count(Field):-retract(total(T0)), T1 is T0+1, assert(total(T1)),
retract(counters(W0, X0, Y0, Z0)), Field=[W,X,Y,Z],
W1 is W0+W, X1 is X0+X, Y1 is Y0+Y, Z1 is Z0+Z,
assert(counters(W1,X1,Y1,Z1)).
EXAMPLE 164
% experimental Post Correspondence system explorer -- Prolog
% examples of problem in /u/faculty/dick/cs505/pg3??.pl
:-consult(append).
change([T,X,Y], [NT,NX,NY]):-pair(L,A,B),
append(X,A,NX), append(Y,B,NY),append(T,[L],NT).
:-print('change([T,X,Y],[T1,X1,Y1]) loaded.').
start([[], [], []]).
:- write('start(X) loaded'), nl.
solution([T,X,X]):-print('Solution is ', T),ps(T).
% Printing out solution so it looks good
ps(T):-ps1(T),nl,
write('------------------------'), nl,
ps2(T), nl.
ps1([]):-!.
ps2([]):-!.
ps1([T0]):-pair(T0, X, Y), prin(X),!.
ps1([T0|TS]):-pair(T0,X,Y),prin(X),ps1(TS),!.
ps2([T0]):-pair(T0, X, Y), prin(Y),!.
ps2([T0|TS]):-pair(T0,X,Y),prin(Y),ps2(TS),!.
:- write('solution(X) loaded'), nl.
trim1([T, [X], [X]], [T, [],[]]):-!.
trim1([T, [X|Y], [X|Z]], [T, Y,Z]).
trim(X,Y):-trim1(X,T),!,trim(T,Y).
trim(X,X).
:-print('trim(X,Y) loaded.').
shortcut([T, [],X]):-!.
shortcut([T, X,[]]).
:- write('shortcut(X) loaded'), nl.
search:-prin('Number of steps? '), ratom(N), search(N,X), write(X), nl.
search(0,X):-start(X),!.
search(N,Z):-N1 is N-1, search(N1,X), change(X,Y), trim(Y,Z),shortcut(Z).
:-print('seach(N,Y) is loaded').
:-nl.
:-nl.
:-print('Try search(N,X),solution(X)? for various N=1,2,3,4...').
:-nl! nl.
EXAMPLE 165
% experimental Post Correspondence system explorer -- Prolog
% examples of problem in /u/faculty/dick/cs505/pg3??.pl
:-consult(append).
change([T,X,Y], [NT,NX,NY]):-pair(L,A,B),
append(X,A,NX), append(Y,B,NY),append(T,[L],NT).
:-print('change([T,X,Y],[T1,X1,Y1]) loaded.').
start([[], [], []]).
:- write('start(X) loaded'), nl.
solution([T,X,X]):-print('Solution is ', T),ps(T).
% Printing out solution so it looks good
ps(T):-ps1(T),nl,
write('------------------------'), nl,
ps2(T), nl.
ps1([]):-!.
ps2([]):-!.
ps1([T0]):-pair(T0, X, Y), prin(X),!.
ps1([T0|TS]):-pair(T0,X,Y),prin(X),ps1(TS),!.
ps2([T0]):-pair(T0, X, Y), prin(Y),!.
ps2([T0|TS]):-pair(T0,X,Y),prin(Y),ps2(TS),!.
:- write('solution(X) loaded'), nl.
trim1([T, [X], [X]], [T, [],[]]):-!.
trim1([T, [X|Y], [X|Z]], [T, Y,Z]).
trim(X,Y):-trim1(X,T),!,trim(T,Y).
trim(X,X).
:-print('trim(X,Y) loaded.').
shortcut([T, [],X]):-!.
shortcut([T, X,[]]).
:- write('shortcut(X) loaded'), nl.
search:-prin('Number of steps? '), ratom(N), search(N,X), write(X), nl.
search(0,X):-start(X),!.
search(N,Z):-N1 is N-1, search(N1,X), change(X,Y), trim(Y,Z),shortcut(Z).
:-print('seach(N,Y) is loaded').
:-nl.
:-nl.
:-print('Try search(N,X),solution(X)? for various N=1,2,3,4...').
:-nl! nl.
EXAMPLE 166
% Another minesweeper end game
% In the last few steps of a minesweeper game you have a single mine to flag
% There are 3 mines somewhere in the 6 squares in the bottom right hand corner of the board
% The corner looks like this ( f is a flag, U,V,W, X, Y, Z are unknown squares)
% 2 f 2 0
% 1 2 f 3 1
% 1 2 3 U V
% 1 1 f W X
% 1 2 Y Z
% Where is the best place to play to avoid hiting a mine and what are the odds?
% Encode U, ..., Z as 1 for a mine and 0 for no mine on that square
% b(X) -- bit X, X is either 0 or 1.
b(1). b(0).
:-dynamic(counters/6).
counters(0,0,0,0,0,0).
:-dynamic(total/1).
total(0).
% orginal problem
where(Field):-Field=[U,V,W, X, Y, Z],
b(U), b(V), b(W), b(X), b(Y),
Z is 3-Y-X-W-V-U, b(Z),
1 is U+V,
3 is 2+U+V,
3 is 2+U+W,
2 is 1+Y+Z.
% Optimized
where2(Field):-Field=[U,V,W, X, Y, Z],
b(U), V is 1-U, W is 1-U,
b(W), b(X), b(Y),
Z is 3-Y-X-W-V-U, b(Z),
1 is Y+Z.
field(F):-F=[U1,V1,W1,X1,Y1,Z1],
write(U1), write('\t'), write(V1), nl,
write(W1), write('\t'), write(X1), nl,
write(Y1), write('\t'), write(Z1), nl.
go:-where(Field), count(Field), fail.
results:-counters(U,V, W,X,Y,Z), total(T),
U1 is 100.0*U/T, write(U1), write('\t'),
V1 is 100.0*V/T, write(V1), nl,
W1 is 100.0*W/T, write(W1), write('\t'),
X1 is 100.0*X/T, write(X1), nl,
Y1 is 100.0*Y/T, write(Y1), write('\t'),
Z1 is 100.0*Z/T, write(Z1), nl.
reset:-retract(counters(_,_,_,_,_,_)), assert(counters(0,0,0,0,0,0)), retract(total(_)), assert(total(0)).
count(Field):-retract(total(T0)), T1 is T0+1, assert(total(T1)),
retract(counters(U0,V0,W0, X0, Y0, Z0)), Field=[U,V,W,X,Y,Z],
U1 is U0+U, V1 is V0+V, W1 is W0+W, X1 is X0+X, Y1 is Y0+Y, Z1 is Z0+Z,
assert(counters(U1,V1,W1,X1,Y1,Z1)).
EXAMPLE 167
% Chess board after Alekhnovich04
% unique: u(...) is true if precisely one argument is 1 and the rest are 0
u(1).
u(1,0). u(0,1).
u(1,0,0). u(0,1,0). u(0,0,1).
u(1,0,0,0). u(0,1,0,0). u(0,0,1,0). u(0,0,0,1).
% coding: o=square, x=removed square, number=possible domino
% o 2 o 6 o x
% 1 5 10
% o 4 o 9 o 14 o
% 3 8 13 18
% o 7 o 12 o 17 o
% 11 16 20
% x o 15 o 19 o
test(B):-B=[A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11,A12,A13,A14,A15,A16,A17,A18,A19,A20],
u(A1,A2),
u(A1,A4,A3), u(A2,A5,A6),
u(A3,A7), u(A4,A5,A9,A8), u(A6,A10),
u(A7,A8,A11,A12), u(A9,A10,A13,A14),
u(A11,A15), u(A12,A13,A16,A17), u(A14,A18),
u(A15,A16,A19), u(A17,A18,A20),
u(A19,A20).
% o 2 o 6 o 23 x
% 1 5 10 24
% o 4 o 9 o 14 o
% 3 8 13 18
% o 7 o 12 o 17 o
% 21 11 16 20
% x 22 o 15 o 19 o
test2(B):-B=[A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11,A12,A13,A14,A15,A16,A17,A18,A19,A20,
A21, A22, A23, A24],
u(A1,A2),
u(A1,A4,A3), u(A2,A5,A6),
u(A3,A7,A21), u(A4,A5,A9,A8), u(A6,A10,A23),
u(A21,A22),u(A7,A8,A11,A12), u(A9,A10,A13,A14), u(A23,A24),
u(A22,A11,A15), u(A12,A13,A16,A17), u(A14,A18,A24),
u(A15,A16,A19), u(A17,A18,A20),
u(A19,A20).
EXAMPLE 168
remove_sign(X,Y):- X>=0, Y is X; X<0, Y is -X.
both_signs(X,Y) :- Y is X; Y is -X.
absolution(X,Y) :- both_signs(X,Y), Y >= 0.
EXAMPLE 169
% Ice Cream Cones
scoop(vanilla). scoop(strawberry). scoop(chocolate).
cone(Top,Middle,Bottom):-scoop(Top), scoop(Middle), scoop(Bottom).
go:- setof(X+Y+Z, cone(X,Y,Z), List), length(List, N), write(N).
go2:- cone(X,Y,Z), write(X+Y+Z), nl, fail.
go3:- setof(X+Y+Z, (cone(X,Y,Z), X\=Y, Y\=Z, X\=Z), List), length(List, N), write(N),nl.
EXAMPLE 170
:-style_check(-singleton).
:-dynamic(cones/1).
% ice-cream cones.
scoop(vanilla). scoop(strawberry). scoop(chocolate).
cone(A,B,C):-scoop(A), scoop(B), scoop(C).
cones(0).
count:-retract(cones(X)), Y is X+1, assert(cones(Y)).
go:-cone(X,Y,Z), count,fail; cones(Number), write(number_cones(Number)).
EXAMPLE 171
% Factorial in prolog
% This one remembers its values, ready for the next call...
:-dynamic(f/2).
f(1,1):-!.
f(N,_):-N=<0,!,fail.
f(N,F):-N1 is N-1,
f(N1,F1),
F is F1 * N,
print(N),write('!='), print(F), nl,
Fact=.. [ :-, f(N,F),! ],
asserta(Fact).
EXAMPLE 172
% A for statement for(Identifier, Initial, Increment, Final)
% use like this: for(i,1,2,10),i(I)|..
for(Label,F):-for(Label,1,1,F).
for(Label,I,F):-for(Label,I,1,F).
for(Label,I,S,F):- V=I,V=<F,
(Garbage=..[Label,_], Garbage,abolish(Label); true),
Count=..[Label,V], asserta(Count).
for(Label,I,S,F):-Count=..[Label,V], retract(Count,_), V+S=<F,
Next is V+S, Count2=..[Label,Next], asserta(Count2).
for(Label,I,S,F):-abolish(Label), fail.
isqrt(N,Sqrt):-for(i,N), i(I), I*I>N,!, Sqrt is I-1, abolish(i).
pyth(N):-for(i,N),i(I), I1 is I+1, for(j,I),j(J), for(k,I1,N),k(K),
K*K=:=I*I+J*J, print([I,J,K]).
sample(N):-for(i,N),i(I), for(j,I),j(J), for(k,J),k(K),print([I,J,K]).
lagrange(N):-isqrt(N,L),
I1 is N - L*L, for(i,0,1,I1),i(I),prin(I),prin(' '),
J1 is I1 - I*I, for(j,I,1,J1),j(J),prin(J),prin(' '),
K1 is J1 - J*J, for(k,J,1,K1),k(K),prin(K),prin(' '),
N=:=I*I+J*J+K*K+L*L,print,print([I,J,K,L]).
EXAMPLE 173
% for statement from T Van Le 92
for(I,I,N):-I =< N.
for(I,M,N):-M < N, M1 is M+1, for(I,M1,N).
for(I,N):-for(I,1,N).
sample('for(I,1,10), write(I), nl, fail!').
go:-for(I,1,10), write(I), nl, fail.
EXAMPLE 174
% experiemnts with setof
go:-setof(X, (member(X,[1,2,3,4,0,-1,-2,-3,-4]), 4 is X*X), Root), write(Root).
id(1234, jim). id(2345, joan). id(3456, jane). id(4567, jo).
grade(1234, a). grade(2345, b). grade(3456, c). grade(4567, d).
grade_roster_by_SSN(List):- setof( student(SSN,Name,Grade), ( id(SSN,Name), grade(SSN,Grade) ), List).
grade_roster(List):- setof( student(Name,SSN,Grade), ( id(SSN,Name), grade(SSN,Grade) ), List).
print_set(List):-member(X,List),write(X),nl,fail.
one_name_grade(List):-setof(ng(Name,Grade), ( id(SSN,Name), grade(SSN,Grade) ), List).
list_name_grade(List):-setof(ng(Name,Grade), SSN^( id(SSN,Name), grade(SSN,Grade) ), List).
EXAMPLE 175
% This is a prologish variation
% This illstrates how to use the data base to accumulate partial results
% and when complete print them out.
square( X, SX):- SX is X * X.
data(1). data(2). data(3). data(4). data(5).
data(6). data(7). data(8). data(9). data(10).
% The 'object' sum(S) has two 'methods': add and clear
:-dynamic(sum/1).
sum(0).
clear:-abolish(sum,1),assert(sum(0)).
add(I):-retract(sum(S)),S2 is S+I,asserta(sum(S2)).
summer:-data(I), square(I, I2), add(I2), fail.
summer:-sum(S), write('The sum of data' = S), nl, clear.
go:-data(I),square(I,S), write(square(I)=S), nl,fail.
go:-write('---------------------'), nl, summer.
EXAMPLE 176
perm([],[]).
perm(X,[Y|Z]):-select(X,Y,R),perm(R,Z).
EXAMPLE 177
% Harry Potter and the seven potions
perm([],[]).
perm(X,[Y|Z]):-select(X,Y,R),perm(R,Z).
puzzle(Potions):- Potions=[P1,P2,P3,P4,P5,P6,P7],
F=forward, B=back, W=wine, P=poison,
perm(Potions, [F,B,W,W,P,P,P]),
P1\==W,
(P2\==W; P1=P),
(P3\==W; P2=P),
(P4\==W; P3=P),
(P5\==W; P4=P),
(P6\==W; P5=P),
(P7\==W; P6=P),
P1\==P7,
P1\==F,
P7\==F,
P2==P6.
solve(S):-setof(P,puzzle(P),S),member(T,S), write(T),nl,fail.
EXAMPLE 178
% Harry Potter and the seven potions
perm([],[]).
perm(X,[Y|Z]):-select(X,Y,R),perm(R,Z).
puzzle(Potions, Dwarf, Giant):- Potions=[P1,P2,P3,P4,P5,P6,P7],
F=forward, B=back, W=wine, P=poison,
perm(Potions, [F,B,W,W,P,P,P]),
P1\==W,
(P2\==W; P1=P),
(P3\==W; P2=P),
(P4\==W; P3=P),
(P5\==W; P4=P),
(P6\==W; P5=P),
(P7\==W; P6=P),
P1\==P7,
P1\==F,
P7\==F,
P2==P6,
select(Potions, Dwarf, BigPotions), member(Giant, BigPotions),
Dwarf\==P,
Giant\==P,
P7=back,
Dwarf=forward.
solve(S):-setof([P,D,G],puzzle(P,D,G),S),member(T,S), write(T),nl,fail.
:-print('solve(X), puzzle(X,Y,Z), ... loaded').
:-nl.
EXAMPLE 179
% Simulated memory
% Prolog variables are temporary local variables that can be lost
% during backtracking.
% The Prolog data base is global but does not associate a unique
% value with each variable.
% This file shows how to emulate a global random access memory.
% ram(x, v) is a clause when and only when x is a variable and v its
% current value.
:-dynamic(ram/2). % allow ram to change.
print_ram:-ram(X, VX), write('RAM['), write(X), write(']='), write(VX), nl,fail.
print_ram:- write('-------------'), nl.
initial_ram:-abolish(ram,2 ), !, assert(ram(nothing, empty)).
% Now define semantics of assignment statements used with our RAM.
% Notice these do not evaluate the value being stored.
set(X,V):- remove_old(X), assert(ram(X, V)),!.
remove_old(X):- (ram(X,Old), retract(ram(X,Old)); true),!.
% The following two definitions will work with functions.plg to
% allow variables in RAM to be used in functional expressions
:-consult('functions.plg').
function(X,V):-ram(X,V),!.
let(X,E):-EV es E, remove_old(X), assert(ram(X,EV)),!.
:-write('intial_ram, print_ram, set(X,V), let(X,Expr) loaded'),nl,nl.
EXAMPLE 180
xyz(a):-!.
xyz(b):-!.
xyz(c):-!.
EXAMPLE 181
/* Breadth-First Search */
/* */
/* DATA */
/* */
/* f */
/* / */
/* e */
/* / \ */
/* b g */
/* / */
/* a - c */
/* \ h */
/* d / */
/* - i - j */
/* */
e(a,b).
e(a,c).
e(a,d).
e(b,e).
e(e,f).
e(e,g).
e(d,h).
e(d,i).
e(i,j).
/***************************************************************/
/* */
/* Use breadth first search algorithm to search a graph, using */
/* the following algorithm : */
/* 1. Form a one element queue consisting of the root node. */
/* 2. Until the queue is empty or the goal has been reached, */
/* determine if the goal node is in the queue. */
/* 2a. If the goal node is in the queue, do nothing. */
/* 2b. If the goal node is not in the queue, remove the */
/* first element from the queue and add the first */
/* element's children, who have not been visited, to */
/* the back of the queue. */
/* 3. If the goal node has been found, announce success; */
/* otherwise announce failure. */
/* */
/***************************************************************/
?- list.
findall(X, G, _) :-
asserta(found(mark)),
call(G),
asserta(found(X)),
fail.
findall(_, _, L) :- collect_found([], M), !, L = M.
collect_found(S, L) :- getnext(X),
!,
collect_found([X|S], L).
collect_found(L, L).
getnext(X) :- retract(found(X)), !,
X \== mark.
search(Start, Goal) :- seek1([Start], Goal, [Start]).
/* The [] in the next rule says that there are no more */
/* live nodes to be expanded, so just fail. */
seek1([], _, _) :- !, fail.
seek1(Queue, Goal, _) :- member(Goal, Queue).
seek1(Queue, Goal, Oldtail) :-
seek2(Queue, [], Children, Oldtail, Newtail),
seek1(Children, Goal, Newtail).
seek2([], Children, Children, Newtail, Newtail) :- !.
seek2([N|Ns], Sf, Children, Oldtail, Newtail) :-
findall(D, (edge(N,D);edge(D,N)), Ds),
addon(Ds, Sf, Newque, Oldtail, Temptail),
seek2(Ns, Newque, Children, Temptail, Newtail).
addon([], L, L, Tn, Tn).
addon([N|Ns], L, M, To, Tn) :- (member(N, L);member(N, To)), !,
addon(Ns, L, M, To, Tn).
addon([N|Ns], L, M, To, Tn) :- addon(Ns, [N|L], M, [N|To], Tn).
member(X, [X|_]).
member(X, [_|Y]) :- member(X, Y).
edge(a,b). edge(a,c). edge(b,d).
edge(b,e). edge(c,f). edge(c,g).
EXAMPLE 182
/* SYS$USER2:[PROLOG.PRO]DFS.DAT;1 */
/* This program uses "depth first" search algorithm to search a */
/* graph. If two nodes, say a and b, in the graph have an edge */
/* connects them, then it is represented as edge(a, b). */
?- list.
search(X, X, T).
search(X, Y, T) :- (edge(X, Z); edge(Z, X)),
not(member(Z, T)),
search(Z, Y, [Z|T]).
member(X, [X|_]) :- !.
member(X, [_|Y]) :- member(X, Y).
edge(g,h). edge(g,d). edge(e,d). edge(h,f). edge(e,f).
edge(a,e). edge(a,b). edge(b,f). edge(b,c). edge(f,c).
EXAMPLE 183
member(X,[X| _]).
member(X,[_ |T]) :- member(X,T).
length([], 0).
length([A|B],N) :- length(B,M), N is M+1 .
smallest([A],A) :- !.
smallest([A|B],N) :- smallest(B,N), N<A, !.
smallest([A| _ ], A).
depth(X,0) :- atomic(X), !.
depth([X|Y],N) :- depth(X,XD), depth(Y,YD), X1 is XD+1, max(X1,YD,N).
max(X,Y,X) :- X>Y, !.
max(_,Y,Y).
EXAMPLE 184
val(X,N) :- expr(X,[],N).
expr(S1,S2,N):-term(S1,S3,N1), plus(S3,S4), expr(S4,S2,N2), N is N1+N2.
expr(S1,S2,N):- term(S1,S2,N).
term(S1,S2,N):- factor(S1,S3,N1), times(S3,S4), term(S4,S2,N2),
N is N1*N2.
term(S1,S2,N) :- factor(S1,S2,N).
factor(S1,S2,N) :- num(S1,S2,N).
factor(S1,S2,N) :- left_p(S1,S3),expr(S3,S4,N), right_p(S4,S2).
plus([P|S],S):- "+"= [P].
times([T|S],S):- "*" = [T].
left_p([L|S],S):- "(" = [L].
right_p([R|S],S):- ")" = [R].
num(S1,S2,N):- headMembers(S1,S2,"0123456789",N1), name(N,N1).
headMembers([],[],_,[]):- !.
headMembers([X|Y],Z,S,[X|W]) :- member(X,S),!,headMembers(Y,Z,S,W).
headMembers(X,X,_,[]).
member(X,[X|_]):- !.
member(X,[_|Y]):- member(X,Y).
EXAMPLE 185
?-use_module(library(lists)).
edge(a,b). edge(b,c). edge(a,c). edge(c,e). edge(b,f). edge(b,e). edge(d,f).
edge(f,g). edge(g,h). edge(f,j). edge(j,k). edge(e,g).
goal(k).
goal(g).
breadthFirst(In,[Z]):- setof(X,(member(X,In),goal(X)),Z), Z\=[], !.
breadthFirst(In,[U,V|W]):-
setof(Y, X^(member(X,In), edge(X,Y)),Set),
breadthFirst(Set,[V|W]),
setof(Son, Parent^(member(Parent,V), edge(Son,Parent),member(Son,In)), U).
?-breadthFirst([a,b],X), print(X), nl.
EXAMPLE 186
color(A,B,C,D,E):-next(A,B),
next(C,D),
next(A,C),
next(A,D),
next(B,C),
next(B,E),
next(C,E),
next(D,E).
next(X,Y):-selectcolor(X),selectcolor(Y), X \== Y.
selectcolor(red).
selectcolor(green).
selectcolor(blue).
selectcolor(yellow).
EXAMPLE 187
/* SYS$USER2:[PROLOG.PRO]LISTS.DAT;1 */
/* -------------------------- */
/* some list processing.... */
/* -------------------------- */
/* append */
/* append(List1, List2, List3) -> "List3 <-- List1 + List2" */
append([],L,L).
append([H | T],L,[H | V]) :- append(T,L,V).
/* last */
/* last(X, List) -> "X is the last element in List" */
last(X,[X]).
last(X,[_|Y]) :- last(X,Y).
/* nextto */
/* nextto(X,Y,List) -> "X and Y are consecutive elements in List" */
nextto(X,Y,[X,Y|_]).
nextto(X,Y,[_|Z]) :- nextto(X,Y,Z).
/* reverse */
/* reverse(List1, List2) -> "List2 is the reversing order of List1" */
reverse([],[]).
reverse([H|T],List) :- reverse(T,Z), append(Z,[H],List).
/* efface */
/* efface(X,List1,List2) -> "Delete the first occurrence */
/* of X from List1 to get List2" */
efface(_,[],[]).
efface(X,[X|L],L) :- !.
efface(X,[Y|L],[Y|M]) :- efface(X,L,M).
/* delete */
/* delete(X, List1, List2) -> "delete all the elements X from List1 to get List2*/
delete(_,[],[]).
delete(X,[X|L],M) :- !, delete(X,L,M).
delete(X,[Y|L1],[Y|L2]) :- delete(X,L1,L2).
/* subst */
/* subst(X,List1,A,List2�� -� "replace� all X in List 1 by A to get List2*/
subst(D1,[],D2,[]).
subst(X,[X|L],A,[A|M]) :- !, subst(X,L,A,M).
subst(X,[Y|L],A,[Y|M]) :- subst(X,L,A,M).
/* sublist */
/* sublist(S,List) -> "S is a sublist of List which appears consecutively, */
/* and in the same order" */
sublist([X|L],[X|M]) :- prefix(L,M).
sublist(L,[_|M]) :- sublist(L,M).
prefix([],_).
prefix([X|L],[X|M]) :- prefix(L,M).
/* --------- */
/* testing */
/* --------- */
?- last(X,[talk,of,the,town]), !.
?- last(town,[talk,of,the,town]), !.
?- last(of,[talk,of,the,town]), !.
?- nextto(X,Y,[a,b,c,d,e,f,g,h]), !.
?- nextto(d,Y,[a,b,c,d,e,f,g,h]), !.
?- nextto(X,g,[a,b,c,d,e,f,g,h]), !.
?- nextto(e,f,[a,b,c,d,e,f,g,h]), !.
?- nextto(b,g,[a,b,c,d,e,f,g,h]), !.
?- append([a,b,c],[d,e,f],List), !.
?- append(X,Y,[a,b,c,d]), !.
?- append(X,[d,e,f],[a,b,c,d,e,f]), !.
?- append([a,b,c],Y,[a,b,c,d,e,f]), !.
?- reverse([a,b,c,d,e],L), !.
?- reverse(L,[a,b,c,d,e]), !.
?- efface(s,[a,y,s,g,e,s,o,s],L), !.
?- efface(X,[h,e,e,l],L), !.
?- efface(X, [h,e,e,l], [h,e,l]), !.
?- delete(s,[s,o,s,s,y,s],L), !.
?- delete(X,[s,o,s,s,y,s],L), !.
?- subst(a,[a,b,b,a,u],i,L), !.
?- sublist([of,the,club],[meeting,of,the,club,shall,be,called]), !.
?- sublist([be,the,club],[meeting,of,the,club,shall,be,called]), !.
EXAMPLE 188
/* SYS$USER2:[PROLOG.PRO]SETS.DAT;1 */
/* ----------------------- */
/* some set maniputating */
/* ----------------------- */
/* member */
/* member(X,List) -> X is an element in List */
member(X,[X|Y]).
member(X,[Y|Z]) :- member(X,Z).
/* subset */
/* subset(X,Y) -> X is a subset of Y */
subset([A|X],Y) :- member(A,Y), subset(X,Y).
subset([],Y).
/* disjoint */
/* disjoint(X,Y) -> X is disjoint from Y */
disjoint(X,Y) :- not( (member(Z,X),member(Z,Y)) ).
/* intersection */
/* intersection(X,Y,Z) -> Z is the intersection of X and Y */
intersection([],X,[]).
intersection([X|R],Y,[X|Z]) :- member(X,Y), !, intersection(R,Y,Z).
intersection([X|R],Y,Z) :- intersection(R,Y,Z).
/* union */
/* union(X,Y,Z) -> Z is the union of X and Y */
union([],X,X).
union([X|R],Y,Z) :- member(X,Y), !, union(R,Y,Z).
union([X|R],Y,[X|Z]) :- union(R,Y,Z).
/* --------- */
/* testing */
/* --------- */
?- trace.
?- member(i,[a,e,i,o,u]).
?- member(t,[a,e,i,o,u]).
?- member(X,[a,e,i,o,u]).
/* ?- subset(X,[a,b,c,d,e]). */
?- subset([a,f],[a,b,c,d,e]).
?- subset([a,d],[a,b,c,d,e]).
?- disjoint([a,e,i],[o,u]).
?- disjoint([s,t,p],[t,x]).
?- intersection([a,e,i],[o,u],L).
?- intersection([s,u,m],[r,s,m],L).
?- union([a,e,i],[o,u],L).
?- union([x,y,z],[w,z],L).
EXAMPLE 187
?-op(100,xfy,':'). /* define : as a left-associative operator */
/* The major predicate is
solve(Current_state, Goal_state, Traversed_path, Solution_path).
where Traversed_path is a list of moves made so far.
*/
solve(Start, Start, Path, Path). /* If the current state is the
start state, then output the path to the 4th argument */
solve(Current, Start, Path, Solution) :-
edge(Step, Previous, Current),
not(marked(node(Previous))),
solve(Previous, Start, Step:Path, Solution).
edge(moveto(Y), X, Y) :- move(X,Y).
move([X,Y|Z],[Y,X|Z]):- X=' ';Y=' '.
move([X,Y,Z|W],[Z,Y,X|W]):- X=' ';Z=' '.
move([X|Y],[X|Z]):- move(Y,Z).
reset_marked :- retractall(marked(_)),
asserta( (marked(X) :- asserta((marked(X):- !)), fail) ).
blackWhite(X,Y,Z) :- reset_marked, solve(X,Y,[X],Z).
run(Answer) :- blackWhite(
[ b,b,b,' ',w,w,w], /*search backward from goal*/
[w,w,w,' ',b,b,b], /*to start*/
Answer), print(Answer),nl.
not(X) :- \+(X).
/* ?- run(X). */
EXAMPLE 188
/* SYS$USER2:[PROLOG.PRO]DERIV.DAT;1 */
/* d(Exp,X,D) -> D is the derivative of the expression Exp */
/* with respect to constant X */
?-op(301,yfx,'^').
d(X,X,1) :- ! .
d(C,X,0) :- atomic(C).
d( ~ U,X, ~ A) :- d(U,X,A).
d(U+V,X,A+B) :- d(U,X,A),d(V,X,B).
d(U-V,X,A-B) :- d(U,X,A),d(V,X,B).
d(C * U,X,C * A) :- atomic(C), C \= X , d(U,X,A), ! .
d(U * V,X,B * U + A * V) :- d(U,X,A),d(V,X,B).
d(U / V,X,A) :- d(U * V ^ ( ~ 1) ,X,A).
d(U ^ V,X,V * W * U ^ (V-1)) :- atomic(V),V \= X , d(U,X,W).
d(log(U),X,A * U ^ ( ~ 1)) :- d(U,X,A).
?- d(x+1,x,Dx).
?- d(x*x-2,x,Dx).
EXAMPLE 189
?-use_module(library(lists)).
:- dynamic marked/1, size/2.
/* This is a modification of the jug problem
using simple depth-first search of a graph.
The modified water-jug problem is as follows:
Jug A holds 4 liters, and jug B holds 3 liters.
There is a pump which can be used to fill either
jug. How can you get exactly 2 liters of water
into the 4-liter jug? */
not(X) :- \+(X).
?-op(100,yfx,':'). /* define : as a left-associative operator */
/* The major predicate is
solve(Current_state, Goal_state, Traversed_path, Solution_path).
where Traversed_path is a list of pourings made so far. */
solve(Goal, Goal, Path, Path). /* If the current state is the
goal state, then output the path to the 4th argument */
solve(Current, Goal, Path, Solution) :-
edge(Step, Current, New), /* 'Step' involves either pouring
or filling up from pump */
not( marked(solve(New, Goal, _, _))), /* Graph search requires
checking whether we've searched this node before */
solve(New, Goal, Path:Step, Solution). /* Use recursion to do
depth-first search. On failure, backup to 'pour'. */
edge(fill_up_a, A:B, S:B) :- size(a,S), A<S.
edge(fill_up_b, A:B, A:S) :- size(b,S), B<S.
edge(pour_a_down_drain, A:B , 0:B).
edge(pour_b_down_drain, A:B , A:0).
edge(pour_a_into_b, A:B, C:D) :-
size(b,S), A>0, B<S, T is A+B,
(T>=S, C is T-S, D=S ; T<S, C=0, D=T) .
edge(pour_b_into_a, A:B, C:D) :-
size(a,S), B>0, A<S, T is A+B,
(T>=S, D is T-S, C=S ; T<S, C=T, D=0) .
/*Check whether a node was already searched. The rule
marked(X) :- asserta((marked(X):- !)), fail.
causes a node to be marked if it was not marked before, and fails.
The next time it checks this node, it will succeed since that node
had been asserted to be marked. Reset_marked permits the
depth-first search to be done several times. */
reset_marked :- retractall(marked(_)),
asserta( (marked(X) :- asserta((marked(X):- !)), fail) ).
mod_jug_problem(X,Y,Z) :- reset_marked, solve(X,Y,start,Z).
size(a,4).
size(b,3).
?- mod_jug_problem(0:0, 2:_B, Solution), print('4,3 -> 2:B '), print(Solution),nl.
?-retractall(size(_ , _)).
size(a,5).
size(b,2).
?-mod_jug_problem(5:0, _A:1, Solution), print('5,2 -> A:1 '), print(Solution),nl.
breadthFirst(Queue,Goals,Paths) :-
breadthFirst2(Queue,Goals,NodeSets,[]), print(NodeSets), nl,
getPaths(NodeSets,Paths,_).
breadthFirst2(Q,Goals,[Sons],_):- not(Q=[]),
setof(X,(member(X,Goals),member(X,Q)),Sons), not(Sons=[]).
breadthFirst2(Q,Goals,[GoodParents,GoodSons|Rest],Seen):- not(Q=[]),
getSons(Q,Seen,Sons),
append(Seen,Q,NewSeen),
breadthFirst2(Sons,Goals,[GoodSons|Rest],NewSeen),
setof(P,getParents(P,Q,GoodSons),GoodParents).
getParents(P,Q,Sons):- member(P,Q),member(S,Sons), biedge(_Name,P,S).
getSons(Q,Seen,Sons):- setof(Son, Name^newEdge(Name,Q,Son,Seen),Sons),!.
getSons(_,_,[]).
getPaths([X,Y],[Name],A):- member(A,X), member(B,Y), biedge(Name,A,B).
getPaths([X|Z],[Name|U],A):- member(A,X),
getPaths(Z,U,B), biedge(Name,A,B).
newEdge(Name,Q,Son,Seen):- member(Parent,Q), biedge(Name, Parent,Son), not(member(Son,Q)),
not(member(Son,Seen)).
/*Allow commutative edges*/
biedge(N,X,Y) :- edge(N,X,Y).
/* biedge(N,X,Y) :- edge(N,Y,X). */
?-retractall(size(_ , _)).
?-nl,nl,print('Breadth first search:'),nl.
jug_problem(X,Y,Ops):- breadthFirst(X,Y,Ops),print(Ops),nl.
size(a,4).
size(b,3).
?- print('4,3 -> 2:B '), nl.
?-jug_problem([0:0],[2:B],Z).
?-retractall(size(_ , _)).
size(a,5).
size(b,2).
?- print('5,2 -> A:1 '), nl.
?-jug_problem([0:0],[A:1],Z).
EXAMPLE 190
/* SYS$USER2:[PROLOG.PRO]MONKEY.DAT;3 */
/* This is the "monkey and bananas" problem
using backward-chaining depth-first search of a graph.
The monkey and bananas problem is as follows:
A hungry monkey finds himself in a room in which
a bunch of bananas is hanging from the ceiling.
The monkey, unfortunately, cannot reach the
bananas. However, in the room there is a chair
and a stick. The ceiling is just the right
height so that the monkey, standing on the chair,
can knock the bananas down with the stick. What
is a sequence of actions which will permit the
monkey to acquire lunch?
*/
?-op(100,xfy,':'). /* define : as a left-associative operator */
/* The major predicate is
solve(Current_state, Goal_state, Traversed_path, Solution_path).
where Traversed_path is a list of moves made so far.
*/
solve(Start, Start, Path, Path). /* If the current state is the
start state, then output the path to the 4th argument */
solve(Current, Start, Path, Solution) :- /*searching backward
to the start state */
edge(Step, Previous, Current),
not(marked(node(Previous))), /* Graph search requires
checking whether we've searched this node before */
/* Backward search: add step to front*/
solve(Previous, Start, Step:Path, Solution).
/* States are represented as a vector
[Monkey-position, Monkey-on-chair?, Chair-position,
Monkey-has-stick?, Stick-position, Bananas-knocked-down? ]
*/
edge(go_to(Loc), [Curloc,no,C,D,E,no], [Loc,no,C,D,E,no]) :- pos(Curloc).
edge(push_chair(Loc), [A,no,A,D,E,no], [Loc,no,Loc,D,E,no]) :- pos(A),
A=chair_location, D=no . /*can't push chair if holding stick */
edge(climb_chair, [A,no,A,D,E,no], [A,yes,A,D,E,no]).
edge(get_stick, [A,no,C,no,A,no], [A,no,C,yes,A,no]).
edge(move_stick(Loc), [A,no,C,yes,A,no], [Loc,no,C,yes,Loc,no])
:- pos(A), A=stick_location.
edge(knock_down,[A,yes,A,yes,A,no], [A,yes,A,yes,A,yes])
:- A=banana_location.
pos(monkey_location).
pos(banana_location).
pos(stick_location).
pos(chair_location).
/*
Check whether a node was already searched. The rule
marked(X) :- asserta((marked(X):- !)), fail.
causes a node to be marked if it was not marked before, and fails.
The next time it checks this node, it will succeed since that node
had been asserted to be marked. Reset_marked permits the
depth-first search to be done several times.
*/
reset_marked :- retractall(marked(_)),
asserta( (marked(X) :- asserta((marked(X):- !)), fail) ).
monkey_bananas_problem(X,Y,Z) :- reset_marked, solve(X,Y,eatBanana,Z).
run(Answer) :- monkey_bananas_problem(
[ X, Y, Z, W, U, yes ], /*search backward from goal*/
[monkey_location, no, chair_location, no, stick_location, no], /*to start*/
Answer).
not(X) :- \+(X).
/* ?- run(X). */
EXAMPLE 191
?-op(100,yfx,':'). /* define : as a left-associative operator */
/* The major predicate is
solve(Current_state, Goal_state, Traversed_path, Solution_path).
where Traversed_path is a list of pourings made so far. */
solve(Goal, Goal, Path, Path). /* If the current state is the
goal state, then output the path to the 4th argument */
solve(Current, Goal, Path, Solution) :-
edge(Step, Current, New), /* move across river */
not(marked(solve(New, Goal, _, _))), /* Graph search requires
checking whether we've searched this node before */
solve(New, Goal, Path:Step, Solution). /* depth-first search. */
edge(goLeft(M,C, W:X:left), U:V:right, W:X:left) :-
digit(M), digit(C),
M+C>0, M+C<3,
W is U+M, X is V+C,
safe(W,X).
edge(goRight(M,C, W:X:right), U:V:left, W:X:right) :-
digit(M), digit(C),
M+C>0, M+C<3,
W is U-M, X is V-C,
safe(W,X).
safe(X,Y) :- X>=0, Y>=0, X=<3, Y=<3, (X>=Y ; X=:=0), (3-X>=3-Y ; 3-X=:=0).
digit(0).
digit(1).
digit(2).
not(X) :- \+(X).
/*Check whether a node was already searched. The rule
marked(X) :- asserta((marked(X):- !)), fail.
causes a node to be marked if it was not marked before, and fails.
The next time it checks this node, it will succeed since that node
had been asserted to be marked. Reset_marked permits the
depth-first search to be done several times. */
reset_marked :- retractall(marked(_)),
asserta( (marked(X) :- asserta((marked(X):- !)), fail) ).
missCann(Z) :- reset_marked, solve(3:3:left,0:0:right,start,Z).
?-missCann(W), print(W), nl, fail.
EXAMPLE 192
/* CRYPTARITHMETIC
This example demonstrates the use of depth-first backward
chaining with the generate and test strategy.
S E N D
+ M O R E
___________
M O N E Y
where no two digits are the same. */
goal([M,O,N,E,Y,S,D,R]) :- M=1,
digit(S), checkcarry(0,0,S,M,M), M\=S,
checksum(S,M,O), noton(O,[M,S]),
checksum(E,O,N), noton(E,[M,S,O]), checkcarry(S,M,E,O,O),
checksum(N,R,E), noton(R,[M,S,O,E,N]),
noton(N,[M,S,O,E,R]), checkcarry(E,O,N,R,N),
checksum(D,E,Y), noton(Y,[M,S,O,E,R,N,D]),
noton(D,[M,S,O,E,R,N,Y]), checkcarry(N,R,D,E,E),
not marked([M,O,N,E,Y,S,D,R]).
checksum(X,Y,Z) :- digit(X), digit(Y),
(Z is (X+Y) mod 10 ; Z is (X+Y+1) mod 10) .
checkcarry(X,Y,U,V,Sum) :- Sum is (X+Y + (U+V) / 10) mod 10 .
checkcarry(X,Y,U,V,Sum) :- Sum is (X+Y + (U+V+1) / 10) mod 10 .
noton(X,[X|Y]) :- !, fail.
noton(X,[]) :- ! .
noton(X,[Y|Z]) :- noton(X,Z).
marked(X) :- asserta((marked(X):- !)), fail.
digit(0).
digit(1).
digit(2).
digit(3).
digit(4).
digit(5).
digit(6).
digit(7).
digit(8).
digit(9).
/*goal(X)*/
EXAMPLE 193
/* Artificial Intelligence */
/* Shyh-Fong Hong 481411156 */
:-dynamic agenda/4.
goalreached(f).
successor(X,Y) :- piece_cost(X,Y,_).
not(X) :- call(X), !, fail.
not(_).
eval(a,8).
eval(b,7).
eval(c,8).
eval(d,5).
eval(e,3).
eval(f,1).
eval(g,2).
eval(h,0).
cost([X],0).
cost([X,Y|L],E):-piece_cost(Y,X,E2),cost([Y|L],E3),E is E2 + E3.
piece_cost(a,b,3).
piece_cost(a,d,5).
piece_cost(b,c,1).
piece_cost(b,d,2).
piece_cost(d,e,2).
piece_cost(d,g,3).
piece_cost(e,f,2).
piece_cost(e,g,1).
piece_cost(g,h,2).
astarsearch(Start,Goalpathlist):-cleandatabase,
add_state(Start,[]),repeatifagenda,
pick_best_state(State,Pathlist),
add_successors(State,Pathlist),
agenda(State,Goalpathlist,C,D),
retract(agenda(State,Goalpathlist,C,D)), measurework.
pick_best_state(State,Pathlist):-
asserta(beststate(dummy,dummy,dummy)),
agenda(S,SL,C,D),beststate(S2,SL2,D2),special_less_than(D,D2),
retract(beststate(S2,SL2,D2)),asserta(beststate(S,SL,D)),fail.
pick_best_state(State,Pathlist):-beststate(State,Pathlist,D),
retract(beststate(State,Pathlist,D)),not(D=dummy),!.
add_successors(State,Pathlist):-goalreached(State),!.
add_successors(State,Pathlist):-successor(State,Newstate),
add_state(Newstate,Pathlist),fail.
add_successors(State,Pathlist):-
retract(agenda(State,Pathlist,C,D)),
asserta(usedstate(State,C)),fail.
add_state(Newstate,Pathlist):-cost([Newstate|Pathlist],Cnew),!,
agenda_check(Newstate,Cnew),!,
usedstate_check(Newstate,Pathlist,Cnew),!,
eval(Newstate,Enew),D is Enew+Cnew,
asserta(agenda(Newstate,[Newstate|Pathlist],Cnew,D)),!.
add_state(Newstate,Pathlist):-
not(cost([Newstate|Pathlist],Cnew)),
write('Warning:your cost function failed on path list'),
write(Pathlist),nl,!.
add_state(Newstate,Pathlist):-not(eval(Newstate,Enew)),
write('Warning: your evaluation function failed on state'),
write(Newstate),nl,!.
agenda_check(S,C):-agenda(S,P2,C2,D2),C<C2,
retract(agenda(S,P2,C2,D2)),!.
agenda_check(S,C):-agenda(S,P2,C2,D2),!,fail.
agenda_check(S,C).
usedstate_check(S,P,C):-usedstate(S,C2),C<C2,
retract(usedstate(S,C2)),asserta(usedstate(S,C)),!,
fix_agenda(S,P,C,C2).
usedstate_check(S,P,C):-usedstate(S,C2),!,fail.
usedstate_check(S,P,C).
fix_agenda(S,P,C,OldC):-agenda(S2,P2,C2,D2),
replace_front(P,S,P2,Pnew),cost(Pnew,Cnew),
Dnew is D2+C-OldC,retract(agenda(S2,P2,C2,D2)),
asserta(agenda(S2,Pnew,Cnew,Dnew)),fail.
replace_front(P,S,P2,Pnew):-append(P3,[S|P4],P2),
append(P,[S|P4],Pnew),!.
repeatifagenda.
repeatifagenda:-agenda(X,Y,Z,W),repeatifagenda.
special_less_than(X,dummy):- !.
special_less_than(X,Y):- X<Y.
cleandatabase:-checkabolish(agenda,4),checkabolish(usedstate,2),
checkabolish(beststate,1),checkabolish(counter,1).
checkabolish(P,N):-abolish(P,N),!, functor(Q,P,N),assert((Q:-fail)).
checkabolish(P,N).
measurework:-countup(agenda(X,Y,C,D),NA),
countup(usedstate(S,C),NB),write(NA),
write(' incompetely examined state(s) and '),
write(NB),write(' examined state(s).'),!.
countup(P,N):-asserta(counter(0)),call(P),counter(K),
retract(counter(K)),K2 is K + 1,asserta(counter(K2)),fail.
countup(P,N):-counter(N),retract(counter(N)),!.
EXAMPLE 194
/* SYS$USER2:[PROLOG.PRO]ASTAR.DAT;33 */
/* A* algorithm for searching trees, or general OR graphs*/
/* for a heuristic function h which is a lower bound on */
/* the cost remaining until reaching the goal. */
search(Node,Answer) :-
searchsub([leaf(0,Node,[])], [], leaf(1000000000,Node,[]),Answer).
/* searchsub(priority_queue_of_leaves, internal_nodes,
best_goal_so_far, Answer)
where the search keeps going until the queue is empty or
the cost of the leaf node on the front of the priority queue
has a cost greater than the cost of the best_goal_so_far. */
searchsub([],Parents,leaf(Cutoff,Goal,Bestfather),Answer)
:- goal(Goal),
findanswer(Goal,Parents,Answer).
searchsub([leaf(Cost,_,_)|Rest],Parents,leaf(Cutoff,Goal,Bestfather),Answer)
:- Cost > Cutoff, !, goal(Goal), findanswer(Goal,Parents,Answer).
searchsub(Queue, Parents, Oldbest,Answer)
:- Queue=[leaf(_,Node,Father)|_],
/* Either change the Bestsofar if Node is a goal node, or else
put Node's sons in order into the priority Queue to get Newsorted */
goal_or_expand(Queue,Parents,Newparents,Node,Father,
Oldbest,Bestsofar,Newsorted),
searchsub(Newsorted, Newparents, Bestsofar, Answer).
goal_or_expand([First|Rest],Parents,Parents,Node,Father,Oldbest,Newbest,Rest)
:- goal(Node), !,
checkbest(First,Oldbest,Newbest) .
goal_or_expand([leaf(Cost,Node,Father) | Rest],
Parents, Newparents, _, _, Oldbest,Oldbest,Newsorted)
:- Oldbest=leaf(Cutoff,_,_),
findall(leaf(Evalfunc,Y,Node),
ok(Node,Y,Cost,Cutoff,Evalfunc),
List),
insertlist(List,Rest,Newsorted,Parents,Newparents).
checkbest(leaf(Cost,Node,Father),leaf(Cutoff,_,_),leaf(Cost,Node,Father)) :-
Cost =< Cutoff, !.
checkbest(_,X,X).
insertlist([],L,L,Parents,Parents) :- !.
insertlist([X|Y],L,Z,Parents,Newparents) :-
replace(X,Parents,Updatedparents),
!,
insert1(X,L,NewL),
insertlist(Y,NewL,Z,Updatedparents,Newparents).
insertlist([X|Y],L,Z,Parents,Newparents) :-
insert1(X,L,NewL), insertlist(Y,NewL,Z,Parents,Newparents).
insert1(X,[],[X]).
insert1(leaf(Cost,Node,W), Z, [leaf(Cost,Node,W)|Z]) :-
� Z=[leaf(C,_,_)| _], Cost=<C, ! .
insert1(X,[Y|Z],[Y|W]) :- insert1(X,Z,W).
/* Assume that h is a lower bound, so can cut off nodes whose
evaluation function > cost of best partial solution */
ok(Node,Son,Cost,Cutoff,T) :-
edge(Node,Son,C),
estimate(Son,C,Est),
T is C + Cost + Est,
T =< Cutoff.
replace(X,[],[X]) :- !.
replace(leaf(T,Son,Father),[leaf(Oldcost,Son,_)|Rest],
[leaf(T,Son,Father)|Rest]) :- !, T<Oldcost.
replace(X,[Y|Z],[Y|W]) :- replace(X,Z,W).
findanswer(Goal,Parents,[T,Goal|Path]) :-
member(leaf(T,Goal,Father), Parents),
Father\==[],
!,
findanswer(Father,Parents,Path).
findanswer(X,_,[0,X]).
member(X,[X|Y]) :- !.
member(X,[Y|Z]) :- member(X,Z), !.
findall(X,G,_) :-
asserta(found(mark)),
call(G),
asserta(found(X)),
fail.
findall(_,_,L) :- collect_found([],M), !, L = M.
collect_found(S,L) :- getnext(X), !, collect_found([X|S],L).
collect_found(L,L).
getnext(X) :- retract(found(X)), !, X \== mark.
/* The following heuristic function of the remaining cost should be
changed so that the 3rd argument is an underestimate (lower
bound) of the remaining cost to a goal. The first argument is
the new leaf node, and the second argument is the cost of the
edge which goes to this leaf node. */
estimate(_,_,0).
edge(a,b,10). edge(b,c,4). edge(a,c,5). edge(c,d,7). edge(b,d,4).
edge(d,e,5). edge(e,f,8). edge(b,d,3). edge(d,f,10). edge(e,g,4).
edge(b,g,15). goal(g).
EXAMPLE 195
/* BEST-FIRST AND/OR SEARCH
(from Prolog Programming for AI, Ivan Bratko, Addison-Wesley, 1986)
This program only generates one solution. This solution is guaranteed
to be a cheapest on if the heuristic function used is a lower
bound of the actual costs of solution trees.
Search tree is either:
tree(Node, F, C, Subtrees) Tree of candidate solutions
leaf(Node, F, C) Leaf of a search tree
solvedtree(Node, F, SubTrees) Solution tree
solvedleaf(Node, F) Leaf of a solution tree
C is the cost of the arc point to Node
F=C+H where H is the heuristic estimate of an optimal solution subtree
rooted in Node
SubTrees are always ordered so that:
(1) all solved subtrees are at the end of a list
(2) other (unsolved subtrees) are ordered according to ascending F-values
*/
:- op(500, xfx, :).
:- op(600, xfx, --->).
andor(Node, SolutionTree) :-
expand(leaf(Node, 0,0),999999999,SolutionTree,yes). /*Assuming 999999999
is less than any solution value*/
/*Case 1: bound exceeded */
expand(Tree,Bound, Tree, no) :-
f(Tree,F), F>Bound, !.
/*Case 2: goal encountered */
expand(leaf(Node,F,_C),_,solvedleaf(Node,F),yes) :-
goal(Node), !.
/*Case 3: expanding a leaf */
expand(leaf(Node,_F,C), Bound, NewTree, Solved) :-
expandnode(Node,C, Tree1), !,
expand(Tree1,Bound,NewTree, Solved).
expand(leaf(_,_,_),_,_,never) :- !.
/*Case 4: expanding a tree */
expand(tree(Node,_F,C,SubTrees),Bound,NewTree,Solved) :-
Bound1 is Bound-C,
expandlist(SubTrees, Bound1,NewSubs,Solved1),
continue(Solved1,Node,C,NewSubs,Bound,NewTree,Solved).
expandlist(Trees,Bound,NewTrees,Solved) :-
selecttree(Trees,Tree,OtherTrees,Bound,Bound1),
expand(Tree,Bound1,NewTree,Solved1),
combine(OtherTrees,NewTree,Solved1,NewTrees,Solved).
continue(yes,Node,C,SubTrees,_,solvedtree(Node,F,SubTrees),yes) :-
backup(SubTrees,H),F is C+H,!.
continue(never,_,-,_,_,_,never) :- !.
continue(no, Node, C,SubTrees,Bound,NewTree,Solved) :-
backup(SubTrees,H), F is C+H, !,
expand(tree(Node,F,C,SubTrees), Bound,NewTree,Solved).
combine(or: _, Tree, yes, Tree, yes) :- !.
combine(or:Trees, Tree, no, or:NewTrees,no) :-
insert(Tree,Trees, NewTrees), !. /*OR list still unsolved */
combine(or:[],_,never,_,never) :- !. /*No more candidates*/
combine(or:Trees,_,never,or:Trees,no) :- !. /*Ther are more candidates*/
combine(and:Trees,Tree,yes,and:[Tree|Trees],yes) :- allsolved(Trees),!.
/*AND list solved */
combine(and:_, _,never,_,never) :- !.
/*AND list unsolvable*/
combine(and:Trees,Tree,_YesNo,and:NewTrees,no) :-
insert(Tree,Trees,NewTrees), !. /*AND list still unsolved*/
/*Expandnode makes a tree of a node and its successors */
expandnode(Node,C,tree(Node,F,C,Op:SubTrees)) :-
Node ---> Op:Successors,
evaluate(Successors,SubTrees),
backup(Op:SubTrees,H), F is C+H.
evaluate([],[]).
evaluate([Node/C | NodesCosts],Trees) :-
h(Node,H), F is C+H,
evaluate(NodesCosts,Trees1),
insert(leaf(Node,F,C), Trees1, Trees).
/* Allsolved checks whethere all trees in a list are solved*/
allsolved([]).
allsolved([Tree|Trees]) :-
solved(Tree),
allsolved(Trees).
solved(solvedtree(_,_,_)).
solved(solvedleaf(_,_)).
f(Tree,F) :- arg(2,Tree,F), !.
insert(T,[],[T]) :- !.
insert(T,[T1|Ts],[T,T1|Ts]) :- solved(T1), !.
insert(T,[T1|Ts],[T1|Ts1]) :-
solved(T),
insert(T,Ts,Ts1), !.
insert(T,[T1|Ts],[T,T1|Ts]) :-
f(T,F), f(T1,F1), F=<F1, !.
insert(T,[T1|Ts],[T1|Ts1]) :-
insert(T,Ts,Ts1).
backup(or:[Tree|_],F) :- f(Tree,F), !.
backup(and:[],0):- !.
backup(and:[Tree1|Trees],F) :-
f(Tree1,F1),
backup(and:Trees,F2),
F is F1+F2, !.
backup(Tree,F) :- f(Tree,F).
selecttree(Op:[Tree],Tree,Op:[],Bound,Bound) :- !.
selecttree(Op:[Tree|Trees],Tree,Op:Trees,Bound,Bound1) :-
backup(Op:Trees,F),
(Op=or,!,min(Bound,F,Bound1);
Op=and, Bound1 is Bound-F).
min(A,B,A) :- A<B, !.
min(_A,B,B).
EXAMPLE 196
/* alpha is the minimal value of max nodes; already guaranteed to achieve,
beta is the maximum (worst) value of min nodes; guaranteed to achieve
Root's backed-up value is in the interval [alpha,beta] */
/* Interval gets smaller as search progresses */
alphabeta(Pos,Alpha,Beta,GoodPos,Val) :-
moves(Pos,PosList), !, /*user-provided*/
boundedbest(PosList,Alpha,Beta,GoodPos,Val).
alphabeta(Pos,_,_,_,Val) :- staticval(Pos,Val). /*user-provided*/
boundedbest([Pos | PosList], Alpha, Beta, GoodPos, GoodVal) :-
alphabeta(Pos,Alpha, Beta, _, Val),
goodenough(PosList, Alpha, Beta, Pos, Val, GoodPos, GoodVal).
goodenough([],_,_,Pos,Val,Pos,Val) :- !.
goodenough(_, _Alpha, Beta, Pos, Val, Pos, Val) :-
min_to_move(Pos), Val>Beta, !. /*Maximizer attained upper bound*/
goodenough(_,Alpha,_Beta,Pos,Val,Pos,Val) :-
max_to_move(Pos), Val<Alpha, !. /*Minimizer attained lower bound*/
goodenough(PosList, Alpha, Beta, Pos, Val, GoodPos, GoodVal) :-
newbounds(Alpha, Beta, Pos,Val, NewAlpha, NewBeta),
boundedbest(PosList, NewAlpha, NewBeta, Pos1, Val1),
betterof(Pos, Val, Pos1, Val1, GoodPos, GoodVal).
newbounds(Alpha, Beta, Pos, Val, Val, Beta) :-
min_to_move(Pos), Val>Alpha, !. /*Maximizer increased the lower bound*/
newbounds(Alpha,Beta, Pos, Val, Alpha, Val) :-
max_to_move(Pos), Val<Beta, !. /*Minimizer decreased the upper bound*/
newbounds(Alpha, Beta,_,_,Alpha, Beta).
betterof(Pos, Val, _Pos1, Val1, Pos, Val) :-
min_to_move(Pos), Val>Val1, !.
betterof(Pos, Val, _Pos1, Val1, Pos,Val) :-
max_to_move(Pos), Val<Val1, !.
betterof(_,_,Pos1,Val1,Pos1,Val1).
EXAMPLE 197
/************************************************************************/
/* AI homework 4 */
/* Author J. T. Jou */
/************************************************************************/
/* 1. This program was tested under SICStus Prolog */
/* 2. Please type start(X) to run */
/* 3. Type your input ending with a dot ('.'). */
/************************************************************************/
:-dynamic query/3.
start(X):-retractall(query(_,_,_)),!,mm(X).
mm(X):-guess(X),verify(X).
guess(X):-X=[X1,X2,X3,X4],
Y=[1,2,3,4,5,6,7,8,9,0],
select(X,Y).
select([X|Xs],Ys):-delete(X,Ys,Zs),
select(Xs,Zs).
select([],_).
delete(X,[X|Ys],Ys).
delete(X,[Y|Ys],[Y|Zs]):-delete(X,Ys,Zs).
verify(X):-not(inconsistent(X)),ask(X).
inconsistent(Y):-query(X,B,C),
bulls(X,Y,B1),
bulls_cows(X,Y,BC),
C1 is BC-B1,
(B\==B1;C\==C1).
bulls([],[],0).
bulls([X|Xs],[X|Ys],N1):-!,bulls(Xs,Ys,N),N1 is N+1.
bulls([_|Xs],[_|Ys],N):-bulls(Xs,Ys,N).
bulls_cows([],_,0).
bulls_cows([A|X],Y,N1):-member(A,Y),!,bulls_cows(X,Y,N),N1 is N+1.
bulls_cows([_|X],Y,N):-bulls_cows(X,Y,N).
ask(X):-write('How many bulls in '),write(X),write('? '),read(B),nl,
write('How many cows in '),write(X),write('? '),read(C),nl,
integer(B),integer(C),BC is B+C,BC=<4,assert(query(X,B,C)),!,
B=4.
not(X):-X,!,fail.
not(_).
member(X,[X|_]):-!.
member(X,[_|Xs]):-member(X,Xs).
query(_,_,_):-fail.
EXAMPLE 198
/* MASTERMIND.PL */
not(X) :- call(X), !, fail.
not(_).
/****************************************************************/
/* */
/* Mastermind */
/* */
/* Reference: Emde, M.v., Relational Programming, */
/* Research Report, CS-78-48, DCS, Univ. of */
/* Waterloo, Canada, 1978 */
/* */
/* also in: Coelho, H., Cotta, J.C., Prolog by Example, */
/* Symbolic Computation, Springer-Verlag, */
/* Berlin, 1988. */
/* */
/* reimplemented by Herbert Koenig and Thomas Hoppe 1983 */
/* */
/* Technical University of Berlin */
/* Faculty for Computer Science */
/* */
/* Description: This program implements the game of mastermind. */
/* either the user or the program tries to break */
/* the hidden color code, consisting of the colors */
/* black, blue, red, green, yellow, white. The */
/* result of a guess (black, a color is at the */
/* right position; white, a color occurs in the */
/* code) are internally represented as successors */
/* of 0. This could be extended to handle integers.*/
/* If the programm guesses, a simple but powerful */
/* generate-and-test procedure is used, where the */
/* scores of previous attempts are used as the test*/
/* criterion. */
/* */
/* Changes: We have slightly modified the internal represen- */
/* tation and the predicate names, documented the main */
/* routines and have changed the output routines. */
/* */
/****************************************************************/
/* 'play' is the toplevel goal for invocation of the system. */
/* The input of color codes has to be a list of four elements */
/* containing the atomic colors. */
/****************************************************************/
/****************************************************************/
/* This is some M-, C-, and YAP-Prolog specific stuff. */
/****************************************************************/
:- dynamic code/1.
:- dynamic random/1.
/****************************************************************/
/* operator: 's' is used for the internal representation of the */
/* black and white scores. */
/****************************************************************/
:- op(150,fy,s).
/****************************************************************/
/* Interface to the user. */
/****************************************************************/
play :-
nl,
abolish(random,1),
abolish(code,1),
write('Mastermind at your service !'), nl, nl,
write('Color codes should be entered as Prolog list '),
write('with four elements.'), nl,
write('Choose from [red, green, yellow, white, black, blue]'), nl,
write('Enter an Integer between 0 and 164: '),
read(RandomSeed), nl,
assert(random(RandomSeed)),
game_loop.
game_loop :-
write('Do you want to break the code (y/n)? '),
read(Answer), nl,
game(Answer).
terminatep :-
write('Another game (y/n)? '),
read(Answer), nl,
next_game(Answer).
next_game(y) :-
!, game_loop.
next_game(n) :-
retract(random(_)),
write('Mastermind was pleased to serve you.'),
nl.
/****************************************************************/
/* Player gives Code, which has to be guessed by mastermind ! */
/****************************************************************/
game(n) :-
write('Please enter color code, I promise not to look: '),
read([C1,C2,C3,C4]), nl,
assert(code([C1,C2,C3,C4])),
guess(Code),
write('First try is:'), put(9),
write_code(Code), put(9),
evaluate(Code,Score),
put(9), write_score(Score), nl,
extend_code([(Code,Score)]),
retract(code(_)),
!,
terminatep.
/****************************************************************/
/* If the code is guessed, i.e. all positions have the correct */
/* color, we can terminate the recursion. */
/****************************************************************/
extend_code([(Code,s s s s _,_)|_]) :-
nl, write('The hidden code must be:'), put(9),
write_code(Code), nl, nl.
/****************************************************************/
/* 'extend_code' extends the list of codes for every trial with */
/* a new code. */
/****************************************************************/
extend_code(CodeList) :-
code_possible(CodeList,NewTry),
write('Next try is:'), put(9),
write_code(NewTry), put(9),
evaluate(NewTry,Score),
put(9), write_score(Score), nl,
extend_code([(NewTry,Score)|CodeList]).
write_code([Color]) :-
write(Color).
write_code([Color|Colors]) :-
write(Color), put(9),
write_code(Colors).
write_score((Black,White)) :-
count(Black,B),
count(White,W),
write('Black:'), write(' '), write(B), write(' '),
write('White:'), write(' '), write(W).
count(0,0).
count(s(Ss),Y) :-
count(Ss,X),
Y is X + 1.
/****************************************************************/
/* 'code_possible' computes through 'mm' from the first try in */
/* the CodeList a NewTry which isn't inconsistent with the */
/* first Score. Of course, this NewTry must also be consistent */
/* with the rest of the CodeList. Thus, we proceed with */
/* recursion until we have processed all the codes. */
/****************************************************************/
code_possible([],_).
code_possible([(FirstTry,FirstScore)|CodeList],NewTry) :-
mm(FirstTry,NewTry,FirstScore),
code_possible(CodeList,NewTry).
/****************************************************************/
/* Player tries to guess the code. */
/****************************************************************/
game(y) :-
guess(Code),
assert(code(Code)),
put(9), put(9), put(9),
write('Enter first try: '), put(9),
read([C1,C2,C3,C4]),
evaluate([C1,C2,C3,C4],Score),
finished(Score),
!, terminatep.
/****************************************************************/
/* If the guess of the user evaluates to 'all colors are on the */
/* right positions', we can finish. Otherwise we ask for another*/
/* Try or give the user the opportunity to quit. */
/****************************************************************/
finished((s s s s _,_)) :-
nl,
write('You got it!'), nl, nl,
retract(code(_)).
finished(Score) :-
write_score(Score), put(9),
write('Enter try or quit:'), put(9),
read(Answer),
proceedp(Answer).
/****************************************************************/
/* If the user quits we show him/her the code, otherwise we */
/* evaluate his new try. */
/****************************************************************/
proceedp(quit) :-
retract(code(Code)), nl, nl,
write('The hidden code is: '), put(9),
write_code(Code), nl, nl.
proceedp(Try) :-
evaluate(Try,Score),
finished(Score) .
/****************************************************************/
/* For evaluating a try we pick up the hidden code stored in the*/
/* database and pass it to the function 'mm', which computes the*/
/* Score. */
/****************************************************************/
evaluate(Try,Score) :-
clause(code(HiddenCode),true),
mm(Try,HiddenCode,Score).
/****************************************************************/
/* 'mm' is our work-horse, first we determine the number of */
/* 'black pins which we have to set on the board'. ReducedTry */
/* and ReducedCode are the remaining colors and unused */
/* 'pinholes'. */
/* If the HiddenCode is uninstantiated, 'determine_blacks' */
/* looks for the first code, which could produce the Score, */
/* if one is found 'determine_whites' will check whether the */
/* remaining colors correspond to the white Score. If so the */
/* NextTry is determined. Otherwise, we backtrack to the next */
/* possible combination producing the black score, and continue */
/* as before. */
/****************************************************************/
mm(Try,HiddenCode,(Black,White)) :-
determine_blacks(Try,HiddenCode,ReducedTry,ReducedCode,Black),
determine_whites(ReducedTry,ReducedCode,White,ReducedCode).
/****************************************************************/
/* If we have processed all positions, we have 0 blacks and */
/* initialize ReducedTry and ReducedCode. Otherwise if there is */
/* the color in the Try and the Code in the same position, we */
/* increment the counter for the blacks. We forget in ReducedTry*/
/* and ReducedCode the corresponding color information. Other- */
/* wise, if the colors are different at the same position, we */
/* have to keep the color information. */
/****************************************************************/
determine_blacks([],[],[],[],0).
determine_blacks([Color|Try],[Color|Code],ReducedTry,ReducedCode,s Black) :-
determine_blacks(Try,Code,ReducedTry,ReducedCode,Black).
determine_blacks([Color1|Try],[Color2|Code],
[Color1|ReducedTry],[Color2|ReducedCode],Black) :-
color(_,Color1), color(_,Color2),
not(Color1 == Color2),
determine_blacks(Try,Code,ReducedTry,ReducedCode,Black).
/****************************************************************/
/* 'Determine_whites' tries to delete the Colors of the Try from*/
/* the Code, if this succeeds we can increment the counter for */
/* the whites. If we reach the end and still have some colors in*/
/* the code table, we determine over 'tuple' a ???? */
/****************************************************************/
determine_whites([],Code,0,NewTry) :-
tuple(Code,NewTry).
determine_whites([Color|Try],Code, s White,[UnboundColor|NewTry]) :-
delete(Color,Code,ReducedCode,NewTry),
determine_whites(Try,ReducedCode,White,NewTry).
determine_whites([Color|Try],Code,White,NewTry) :-
not_in(Color,Code,NewTry),
determine_whites(Try,Code,White,NewTry).
/****************************************************************/
/* The following is the random code generator */
/****************************************************************/
guess([C1,C2,C3,C4]) :-
randomcolor(C1),
randomcolor(C2),
randomcolor(C3),
randomcolor(C4) .
randomcolor(Color) :-
randomnumber(X),
Y is (X mod 6) + 1,
color(Y,Color).
randomnumber(R) :-
retract(random(R)),
NR is ((R * 125) + 1) mod 165,
assert(random(NR)).
color(1,black).
color(2,blue).
color(3,green).
color(4,red).
color(5,white).
color(6,yellow).
/*********************************************************************/
/* 'delete' deletes U from the second argument, if it occurs in the */
/* head it and returns over tuple the rest of the original codelist */
/* Ms. Otherwise, if U and the head are different, we search the rest*/
/* of the codelist. */
/*********************************************************************/
delete(U,[U|Y],Y,Ms) :-
tuple(Y,Ms).
delete(U,[V|Y],[V|Y1],[_|Ms]) :-
color(_,U), color(_,V),
not(U == V),
delete(U,Y,Y1,Ms).
/*********************************************************************/
/* If U is not in V, 'not_in' will succeed. */
/*********************************************************************/
not_in(_,[],[]).
not_in(U,[V|Vs],[_|Ws]) :-
color(_,U), color(_,V),
not(U == V),
not_in(U,Vs,Ws).
tuple([],[]).
tuple([U|Us],[_|Vs]) :-
color(_,U),
tuple(Us,Vs).
EXAMPLE 199
sel(X, [X|Y], Y).
sel(U, [X|Y], [X|V]) :- sel(U,Y,V).
safe([ ]).
safe([X|Y]) :- check(X,Y), safe(Y).
check(_,[ ]).
check(P, [Q|R]) :-
not_on_diag(P,Q), check(P,R).
not_on_diag(p(X1,Y1),p(X2,Y2)) :-
DX is X1-X2, DY is Y1-Y2,
MDY is Y2-Y1, DX=\=DY, DX=\=MDY.
queens(Rows, [Col|RestCols], Points):-
sel(Row,Rows,RestRows),
safe([p(Row,Col) | Points]),
queens(RestRows,RestCols,
[p(Row,Col) | Points]).
queens( [ ], [ ], Points) :-
print('Solution: '),print(Points),nl.
?- queens([1,2,3,4,5,6,7,8],
[1,2,3,4,5,6,7,8], [ ]), fail.
EXAMPLE 200
% BIRDS
% Copyright (c) 1990-1995 Amzi! inc.
% All rights reserved
% This is a sample of a classification expert system for identification
% of certain kinds of birds. The rules are rough excerpts from "Birds of
% North America" by Robbins, Bruum, Zim, and Singer.
% This type of expert system can easily use Prolog's built in inferencing
% system. While trying to satisfy the goal "bird" it tries to satisfy
% various subgoals, some of which will ask for information from the
% user.
% The information is all stored as attribute-value pairs. The attribute
% is represented as a predicate, and the value as the argument to the
% predicate. For example, the attribute-value pair "color-brown" is
% stored "color(brown)".
% "identify" is the high level goal that starts the program. The
% predicate "known/3" is used to remember answers to questions, so it
% is cleared at the beginning of the run.
% The rules of identification are the bulk of the code. They break up
% the problem into identifying orders and families before identifying
% the actual birds.
% The end of the code lists those attribute-value pairs which need
% to be asked for, and defines the predicate "ask" and "menuask"
% which are used to get information from the user, and remember it.
main :- identify.
identify:-
retractall(known(_,_,_)), % clear stored information
bird(X),
write('The bird is a '),write(X),nl.
identify:-
write('I can''t identify that bird'),nl.
order(tubenose):-
nostrils(external_tubular),
live(at_sea),
bill(hooked).
order(waterfowl):-
feet(webbed),
bill(flat).
order(falconiforms):-
eats(meat),
feet(curved_talons),
bill(sharp_hooked).
order(passerformes):-
feet(one_long_backward_toe).
family(albatross):-
order(tubenose),
size(large),
wings(long_narrow).
family(swan):-
order(waterfowl),
neck(long),
color(white),
flight(ponderous).
family(goose):-
order(waterfowl),
size(plump),
flight(powerful).
family(duck):-
order(waterfowl),
feed(on_water_surface),
flight(agile).
family(vulture):-
order(falconiforms),
feed(scavange),
wings(broad).
family(falcon):-
order(falconiforms),
wings(long_pointed),
head(large),
tail(narrow_at_tip).
family(flycatcher):-
order(passerformes),
bill(flat),
eats(flying_insects).
family(swallow):-
order(passerformes),
wings(long_pointed),
tail(forked),
bill(short).
bird(laysan_albatross):-
family(albatross),
color(white).
bird(black_footed_albatross):-
family(albatross),
color(dark).
bird(fulmar):-
order(tubenose),
size(medium),
flight(flap_glide).
bird(whistling_swan):-
family(swan),
voice(muffled_musical_whistle).
bird(trumpeter_swan):-
family(swan),
voice(loud_trumpeting).
bird(canada_goose):-
family(goose),
season(winter), % rules can be further broken down
country(united_states), % to include regions and migration
head(black), % patterns
cheek(white).
bird(canada_goose):-
family(goose),
season(summer),
country(canada),
head(black),
cheek(white).
bird(snow_goose):-
family(goose),
color(white).
bird(mallard):-
family(duck), % different rules for male
voice(quack),
head(green).
bird(mallard):-
family(duck), % and female
voice(quack),
color(mottled_brown).
bird(pintail):-
family(duck),
voice(short_whistle).
bird(turkey_vulture):-
family(vulture),
flight_profile(v_shaped).
bird(california_condor):-
family(vulture),
flight_profile(flat).
bird(sparrow_hawk):-
family(falcon),
eats(insects).
bird(peregrine_falcon):-
family(falcon),
eats(birds).
bird(great_crested_flycatcher):-
family(flycatcher),
tail(long_rusty).
bird(ash_throated_flycatcher):-
family(flycatcher),
throat(white).
bird(barn_swallow):-
family(swallow),
tail(forked).
bird(cliff_swallow):-
family(swallow),
tail(square).
bird(purple_martin):-
family(swallow),
color(dark).
country(united_states):- region(new_england).
country(united_states):- region(south_east).
country(united_states):- region(mid_west).
country(united_states):- region(south_west).
country(united_states):- region(north_west).
country(united_states):- region(mid_atlantic).
country(canada):- province(ontario).
country(canada):- province(quebec).
country(canada):- province(etc).
region(new_england):-
state(X),
member(X, [massachusetts, vermont, etc]).
region(south_east):-
state(X),
member(X, [florida, mississippi, etc]).
region(canada):-
province(X),
member(X, [ontario,quebec,etc]).
nostrils(X):- ask(nostrils,X).
live(X):- ask(live,X).
bill(X):- ask(bill,X).
size(X):- menuask(size,X,[large,plump,medium,small]).
eats(X):- ask(eats,X).
feet(X):- ask(feet,X).
wings(X):- ask(wings,X).
neck(X):- ask(neck,X).
color(X):- ask(color,X).
flight(X):- menuask(flight,X,[ponderous,powerful,agile,flap_glide,other]).
feed(X):- ask(feed,X).
head(X):- ask(head,X).
tail(X):- menuask(tail,X,[narrow_at_tip,forked,long_rusty,square,other]).
voice(X):- ask(voice,X).
season(X):- menuask(season,X,[winter,summer]).
cheek(X):- ask(cheek,X).
flight_profile(X):- menuask(flight_profile,X,[flat,v_shaped,other]).
throat(X):- ask(throat,X).
state(X):- menuask(state,X,[massachusetts,vermont,florida,mississippi,etc]).
province(X):- menuask(province,X,[ontario,quebec,etc]).
% "ask" is responsible for getting information from the user, and remembering
% the users response. If it doesn't already know the answer to a question
% it will ask the user. It then asserts the answer. It recognizes two
% cases of knowledge: 1) the attribute-value is known to be true,
% 2) the attribute-value is known to be false.
% This means an attribute might have multiple values. A third test to
% see if the attribute has another value could be used to enforce
% single valued attributes. (This test is commented out below)
% For this system the menuask is used for attributes which are single
% valued
% "ask" only deals with simple yes or no answers. a "yes" is the only
% yes value. any other response is considered a "no".
ask(Attribute,Value):-
known(yes,Attribute,Value), % succeed if we know its true
!. % and dont look any further
ask(Attribute,Value):-
known(_,Attribute,Value), % fail if we know its false
!, fail.
ask(Attribute,_):-
known(yes,Attribute,_), % fail if we know its some other value.
!, fail. % the cut in clause #1 ensures that if
% we get here the value is wrong.
ask(A,V):-
write(A:V), % if we get here, we need to ask.
write('? (yes or no): '),
read(Y), % get the answer
asserta(known(Y,A,V)), % remember it so we dont ask again.
Y = yes. % succeed or fail based on answer.
% "menuask" is like ask, only it gives the user a menu to to choose
% from rather than a yes on no answer. In this case there is no
% need to check for a negative since "menuask" ensures there will
% be some positive answer.
menuask(Attribute,Value,_):-
known(yes,Attribute,Value), % succeed if we know
!.
menuask(Attribute,_,_):-
known(yes,Attribute,_), % fail if its some other value
!, fail.
menuask(Attribute,AskValue,Menu):-
nl,write('What is the value for '),write(Attribute),write('?'),nl,
display_menu(Menu),
write('Enter the number of choice> '),
read(Num),nl,
pick_menu(Num,AnswerValue,Menu),
asserta(known(yes,Attribute,AnswerValue)),
AskValue = AnswerValue. % succeed or fail based on answer
display_menu(Menu):-
disp_menu(1,Menu), !. % make sure we fail on backtracking
disp_menu(_,[]).
disp_menu(N,[Item | Rest]):- % recursively write the head of
write(N),write(' : '),write(Item),nl, % the list and disp_menu the tail
NN is N + 1,
disp_menu(NN,Rest).
pick_menu(N,Val,Menu):-
integer(N), % make sure they gave a number
pic_menu(1,N,Val,Menu), !. % start at one
pick_menu(Val,Val,_). % if they didn't enter a number, use
% what they entered as the value
pic_menu(_,_,none_of_the_above,[]). % if we've exhausted the list
pic_menu(N,N, Item, [Item|_]). % the counter matches the number
pic_menu(Ctr,N, Val, [_|Rest]):-
NextCtr is Ctr + 1, % try the next one
pic_menu(NextCtr, N, Val, Rest).
EXAMPLE 201
/* The following five lines are necessary for Sicstus, but not for LPA prolog*/
retractone(X) :- retract(X), !.
member(X,[X|_]).
member(X,[_|Y]) :- member(X,Y).
\=(X,Y) :- \==(X,Y).
?- op(700,xfx,\=).
?- op(600, xfx, ::). /*Class qualifier*/
?- op(100,yfx,$). /*Eval sequence of functions*/
?- op(100,yfx,#). /*Dot symbol*/
?- op(110,xfy,mod). /*Modifier classes*/
?- op(100,yfx,sub). /*For subscript expressions */
?- op(100,yfx,key). /*Followed by a primitive or list of primitives*/
?- op(90, fx, @). /*Quote operator*/
?- op(110, fx, ^). /*Pointer operator*/
?- op(710, xfx, withProto). /*For declaring prototype of set or class*/
?- op(720, xfx, inClass). /*x inClass classexpr withProto (assignments) */
?- op(710, xfx, inverse). /*name inverse id inClass class_expr (Bin Reln Decl)*/
?- op(700, xfx, :=). /*Static assignment; right-side is primitive-valued*/
?- op(700, xfx, +=). /*Insertion into set (primitive-valued)*/
?- op(700, xfx, =@). /*Method assignment and subclass defn*/
?- op(700, xfx, +=@). /*Method rule insertion */
?- op(720, xfx, <@). /*b<@c Redefine b as a subclass of c. */
?- op(720, xfx, +<@). /* Add a subclass edge into ISA graph*/
?- op(690, xfx, where). /* For selection and subset defn*/
?- op(900, xfy, while). /* For while statements */
?- op(600, xfy, &).
?- op(750, xfy, ;).
?- op(740, xfy, ->).
?- op(500, fy, ~).
?- op(800, fx, for). /* For "for PrologVar in ListExpr do Statement" */
?- op(790, xfx, in).
?- op(780, xfx, do).
?- op(900, fx, cd). /* change directory */
?- op(1000,fx,print).
:-dynamic ':='/2 , modPass/1 .
:=(world#classes key X#invariant, @ (@true)) :- member(X,
[any,objects,primitives,numbers,classes]).
X#sdn := @[[world#classes key numbers]] :- number(X), !.
_#X#sdn := @[[world#classes key numbers]] :- number(X), !.
:=( (@_) #sdn, @[[world#classes key primitives]]).
world#classes key set#sdn:= @[[world#classes key objects]].
world#sdn := @[[world#classes key objects]].
world#classes#prototype#sdn := @[[world#classes key objects]].
world#classes key any#sdn := @[ ].
world#classes key objects#sdn:= @[[world#classes key any]].
world#classes key classes#sdn:= @[[world#classes key objects]].
world#classes key primitives#sdn := @[[world#classes key objects]].
world#classes key numbers#sdn := @[[world#classes key primitives]].
world#classes key any#subsets:=world#classes key objects.
world#classes key objects#subsets:= world#classes key primitives.
world#classes key objects#subsets:= world#classes key classes.
world#classes key primitives#subsets:=world#classes key numbers.
world#subsets:= world#classes.
/*Default assignment statements and insertion statements*/
world#classes key objects# @prologDefn(replace,
replace(ref(X),Y)=@ @true) := @true :-
nonvar(X), !, deleteDep(X), deleteRef(Y,R),
condAssert(:=(X,R)), assertParts(X,R).
world#classes key objects# @prologDefn(insert,
insert(ref(X),Y)=@ @true) := @true :-
nonvar(X), !, deleteRef(Y,R),
condAssert(:=(X,R)), assertParts(X,R).
/*Assignments involve 1-level copy of structures,
not including values contained in prototype of set.*/
assertParts(X,Y) :- :=(Y#A,V), checkNotBoundAlready(X,A,V),
A\=sdn, condAssert(:=(X#A,V)), fail.
assertParts(X,Y key Z) :- :=(Y#prototype#A,V), A\=sdn,
checkNotBoundAlready(X,A,V), condAssert(:=(X#A,V)), fail.
assertParts(X,Y) :- :=(Y key Z, V),
condAssert(:=(X key Z,V)), fail.
assertParts(_,_).
checkNotBoundAlready(X key _,A,V) :- :=(X#prototype#A,V), !, fail.
checkNotBoundAlready(X,A,V) :- :=(X#A,V), !, fail.
checkNotBoundAlready(_,_,_).
deleteDep(X) :- retract((:=(X,Y):- true)), fail. /*deletes all*/
deleteDep(X) :- retract((:=(X#Y ,Z):- true)),
reAssertSdns(X,Y,Z), deleteDep(X#Y),fail.
deleteDep(_).
reAssertSdns(X,Y,Z):- nonvar(Y), Y==sdn, assert(:=(X#sdn,Z)).
eval(_,X,X) :- var(X), !. /*Prolog variables evaluate to themselves*/
eval(_,@X,@X) :- !. /*Quotation mark*/
eval(Env,^X,ref(Z)) :- !, evalDot(Env,X,Z).
eval(_,ref(X),ref(X)) :- !.
eval(_,X,X) :- number(X), !.
eval(_,world,world) :- !.
eval(Env,this,Env) :- !.
eval(Env,props,ListProps) :- !,findset(P,V^(Env#P:=V),ListProps).
eval(Env,methods,L) :- !, findset(M,V^(Env#
@prologDefn(M,V):= @true),L).
eval(Env,(X,Y),V) :- !, eval(Env,X,_), eval(Env,Y,V).
eval(Env,(X->Y;Z),V) :- !, (eval(Env,X,@true)->eval(Env,Y,V));
eval(Env,Z,V).
eval(Env,(X;Y),V) :- !, (eval(Env,X,V); eval(Env,Y,V)).
eval(Env,(X->Y),V) :- !, eval(Env,X,@true),eval(Env,Y,V).
eval(Env,(X while Y),@true) :- eval(Env,X,@true), eval(Env,Y,_),
!, eval(Env,(X while Y),@true).
eval(_,(_ while _), @true) :- !.
eval(Env,for X in ListExpr do Statement,Val) :- !,
eval(Env, ListExpr, @List),
member(X,List),
eval(Env,Statement,Val).
eval(Env,member(ref(X)),Y key K):- checkSetSubscripted(X,K,Y).
eval(Env,member(X),Y) :- !, eval(Env,X,@[H|T]), member(Y,[H|T]).
eval(_,[],[]) :- !.
eval(Env,[X|Y],@Z) :- !, evalList(Env,[X|Y],Z).
eval(Env,X where Y,Z) :- !,
eval(Env,X,Z), eval(Z,Y,V),
V\= @false, V\=error(_).
eval(Env,ClassExpr$asSet,V) :- !,
eval(Env,asSet(ref(ClassExpr)),V).
eval(Env,asSet(ClassExpr),M) :-
deleteRef(ClassExpr,R),
checkClassExpr(R),!,
add2ClassExpr(R,C),
eval(Env,C,M).
eval(Env,asSet(Class),M) :-
deleteRef(Class,C),
evalDot(Env,C,D),
checkSetSubscripted(D,M).
/*Set intersection using & */
eval(Env,X&Y,Z) :- !, eval(Env,X,Z), eval(Env,Y,Z).
eval(Env,X & ~Y,Z) :- !, eval(Env,X,Z), myNot(eval(Env,Y,Z)).
eval(Env, ~(X&Y),Z) :- !, eval(Env,(~X; ~Y),Z).
eval(Env, ~(X;Y),Z) :- !, eval(Env,(~X & ~Y),Z).
eval(Env,~(~X),Z) :- !, eval(Env,X,Z).
eval(Env,~X,Z) :- !, eval(Env,world#classes key any$asSet,Z),
myNot(eval(Env,X,Z)).
eval(Env,empty(SetExpr),@true) :-
!, myNot(eval(Env,SetExpr,_)).
eval(Env,nonEmpty(ClassExpr),@true) :- !,
myNot(eval(Env,empty(ClassExpr),@true)), !.
eval(Env,X+<@ClassExpr,XDot) :- !, /*add ClassExpr as superclass of X*/
evalDot(Env,X,XDot),
(:=(XDot#sdn,@Old); Old=[]), !,
mkeBool(Old,OldExpr),
addEnv2ClassExpr(Env,ClassExpr,C),
normalize(C,YNormal),
addSdn(XDot,C),
addSubsets(XDot,YNormal).
eval(Env,X<@Y,Z) :- var(Y), !, eval(Env,X<@ (Y where true),Z).
eval(Env,(X<@(Y where Z)), @true):- !, /*adding X as subclass of Y */
addEnv2ClassExpr(Env,Y,C), /*fails if Y not a classExpr*/
evalDot(Env,X,XDot), /*defaults superclass to objects*/
deleteDep(XDot),
addInvar(XDot,Z),
normalize(C,YNormal),
addSdn(XDot,C),
addSubsets(XDot,YNormal).
eval(Env,X<@Y,V) :- !, eval(Env,X<@Y where true, V).
eval(Env,X+=Y, V) :- !, /* subset addition to X */
evalDot(Env,X,XDot),
eval(Env,Y,YVal),
checkInvar(XDot,YVal),
eval(Env,insert(ref(XDot),YVal),V).
eval(Env,(X:=Y),V) :- !, evalDot(Env,X,XDot),
eval(Env,Y,YVal),
checkInvar(XDot,YVal),
eval(Env,replace(ref(XDot),YVal),V).
eval(Env, X inClass Y withProto A,@true) :- !,
addEnv2ClassExpr(Env,Y,W), normalize(W,N),
evalDot(Env, X, XDot),
addAssX(A,XDot,AMod),
eval(Env,AMod,_), /*Execute assignments A */
condAssert(:=(XDot#sdn,@N)).
eval(Env,X inClass Y,V) :- !, eval(Env,X inClass Y withProto @true,V).
/* Unlike :=, function defn and insertion cannot be overridden*/
eval(Env,(X=@Y),@true) :- !, evalDot(Env,X,Oid#Expr),
functor(Expr,F,_),
retractall(:=(Oid# @prologDefn(F,_=@_),@true)),
assert(:=(Oid# @prologDefn(F,Expr=@Y), @true)).
eval(Env,(X+=@Y),@true) :- !, evalDot(Env,X,Oid#Expr),
functor(Expr,F,_),
assert(Oid# @prologDefn(F,Expr=@Y):= @true).
eval(Env,(X$hide),@true) :- !,
deleteRef(X,XDot),deleteDep(XDot).
eval(Parent key _, parent,Parent) :- !.
eval(Parent#_, parent, Parent) :- !.
/* Permits calls like pnt$move(1,2)$move(3,4)*/
eval(Env,(X$inv(Y)),Val) :- !, evalDot(Env,X$inv(Y),Val).
eval(Env,(X$of(Y)),Val) :- !, evalDot(Env,X$of(Y),Val).
eval(Env,(X$of(Y,Z)),Val) :- !, evalDot(Env,X$of(Y,Z),Val).
eval(Env,(X$Y), Val) :- !, Y=.. [F|Args],
evalDot(Env,X,Name),
Z=.. [F,ref(Name)|Args], /* change into a function call. */
eval(Env,Z,Val).
eval(Env,(X#Y), Val) :- evalDot(Env,X#Y,A#B), !,
eval(A,B,Val). /* a#b#(work) changes dir to a#b and evals work */
eval(Env,(X#Y),Val) :- !, evalDot(Env,(X#Y),Val). /*Return keyed name*/
eval(Env,(X sub Y), Val) :- !, evalDot(Env,(X sub Y), Name),
getVal(Name,Val).
eval(Env,(X key Y), Val) :- !, evalDot(Env,(X key Y), Name),
getVal(Name,Val).
eval(Env,mod(X,Y),mod(X,YDot)) :- !,
evalDot(Env,Y,YDot).
eval(Env,print(X),@true) :- !, eval(Env,X,V),
deleteRef(V,U),print(U), nl.
eval(Env,X::Y,X::Y) :- !.
eval(Oid,Call,Val) :- !, evalArgs(Oid,Call,Ecall),
evalCall(Oid,Ecall,Val).
checkInvar(XDot,YVal) :-
makeDefined(XDot),
:=(XDot#invariant,Invar),!,
eval(YVal,Invar,V),
V\= @false,
V\= @error(_).
checkInvar(_,_).
makeDefined(X key _) :- :=(X#sdn,_), !.
makeDefined(XDot) :- :=(XDot#sdn,_), !.
makeDefined(X key _) :- :=(X#prototype#sdn,_), !.
makeDefined(X key _ #Z) :- :=(X#prototype#Z#sdn,_), !.
makeDefined(XDot) :-
assert(:=(XDot#sdn,@[[world#classes key objects]])).
addAssX(A:=B,XDot,XDot#A:=B):- !.
addAssX(A inClass B,XDot,XDot#A inClass B) :- !.
addAssX((A:=B,T),XDot,(XDot#A:=B,U)) :- addAssX(T,XDot,U), !.
addAssX((A inClass B,T), XDot,(XDot#A inClass B,U)) :-
addAssX(T,XDot,U), !.
addAssX(@A,X,@A):- !.
addAssX(A,XDot,_) :- print('Invalid withProto assignment'),
print(A),nl,fail.
getVal(Name,Val) :- Name:=ref(Val), atomic(Val), !.
/*Simple value*/
getVal(Name,Val) :- :=(Name,_), !, :=(Name,Val).
getVal(Name,Name).
/*Compute all values, including both data and method calls*/
evalCall(Oid,Ecall,Val) :- getF(Ecall,Oid,F,Env,Ncall), !,
getAncestors(Env,F,Ans),
evalAns(Env,Ncall,Ans,Val).
getF(Ecall,_,F,Cls,Ncall) :- Ecall=..[F,Cls::A | B], !,
Ncall=..[F,A|B].
getF(Ecall,_,F,Env,Ecall) :- Ecall=..[F,Env|_], !.
getF(F,Oid,F,Oid,F).
/* Return simple-valued attributes and set elements*/
evalAns(_,_,A#F,Val) :- :=(A#F,_), !, :=(A#F,Val).
evalAns(_,_,A key F, Val) :- :=(A key F,_), !, :=(A key F,Val).
evalAns(Oid,Ecall,A # @F, Val) :- !,
:=(A# @prologDefn(F,(Ecall=@Expr)), @true),
eval(Oid,Expr,Val).
/* Return name of complex object */
evalAns(_,_,Name,Name). /*complex object; just return name*/
getAncestors(X,replace,world#classes key objects# @replace) :- var(X), !.
getAncestors(X,insert,world#classes key objects# @insert) :- var(X), !.
getAncestors(X,_,_) :- var(X), !,
print([' ***error: unbound environment: ',X]),nl,fail.
getAncestors(_,X,_) :- var(X), !,
print([' ****error: unbound attribute or functor symbol: ',X]), nl, fail.
getAncestors(ref(X),F,Y) :- !, getAncestors(X,F,Y).
getAncestors(X,F,Y#F) :- checkBound(X,F,Y). /*Dont cut*/
getAncestors(X,F,Y# @F) :- checkMethodDefn(X,F,Y).
getAncestors(X,F,Y key F) :- checkSubscripted(X,F,Y).
getAncestors(X key W #Z,F,Y) :- checkOverRiding(X key W#Z,F),
getAncestors(X#prototype#Z,F,Y), !. /*Get only 1 prototype*/
checkOverRiding(W,F) :- checkBound(W,F,_), !, fail.
checkOverRiding(_,_).
/*subclasses override superclasses' definitions, so cut*/
checkBound(X,F,X) :-
( :=(X#F,_); :=(X#F#_,_); :=(X#F key _,_)), !.
checkBound(X,F,Y) :- F\=sdn, F\=subsets,
isaParent(X,Z), checkBound(Z,F,Y).
checkMethodDefn(X,F,X) :- clause(:=(X# @prologDefn(F,_),_),_), !.
checkMethodDefn(X,F,Y) :- F\=sdn,F\=subsets,
isaParent(X,Z), checkMethodDefn(Z,F,Y).
checkSetSubscripted(X,Y) :-
findset(U key G,checkAllSubscripted(X,G,U),Z),
member(Y,Z).
checkSubscripted(X,F,Y) :- checkAllSubscripted(X,F,Y), !.
checkAllSubscripted(X,F,X) :- checkKey(X,F).
checkAllSubscripted(X,F,Y) :- isaSon(X,Z), checkAllSubscripted(Z,F,Y).
checkKey(X,F) :-
(:=(X key F, _); :=(X,@F); :=(X key F # _,_); :=(X key F key _,_)).
isaParent(X,_) :- var(X), !,fail.
isaParent(X,Y) :- (X#sdn:= @[H|T]), !, intersectSorted(H,T,D),
member(Y,D). /*Y must be in all conjunctions*/
isaParent(X key K,X):- !. /* Elements are subclasses of their array*/
isaAncestor(X,Y) :- isaParent(X,Y).
isaAncestor(X,Y) :- isaParent(X,Z), isaAncestor(Z,Y).
existAnc(X,Y) :- isaAncestor(X,Y), !.
getDescendantClasses(X,Z) :- isaSon(X,Y),
getDescendantClasses2(Y,Z).
getDescendantClasses2(Y,Y) :- isClass(Y).
getDescendantClasses2(X,Z) :- isaSon(X,Y),
getDescendantClasses2(Y,Z).
isClass(X) :- :=(X#invariant,_),!.
isaSon(X,Y) :- :=(X#subsets,Y).
addSubsets(XDot,Y) :- var(Y), !.
addSubsets(XDot,[SuperClasses]) :- /*Only match conjunctions*/
member(Y,SuperClasses),
deleteRef(XDot,X),
condAssert(:=(Y#subsets,X)), /*Add X into subsets of Y*/
addMods(Y),
fail.
addSubsets(_,_).
deleteRef(ref(X),X):- !.
deleteRef(X,X).
addMods(mod(A,B)) :- modPass(A),
condAssert(:=(B#subsets,mod(A,B))),!, addMods(B).
addMods(Y key mod(A,B)) :- modPass(Y key A),
condAssert(:=(B#subsets,Y key mod(A,B))), !,
addMods(Y key B).
addMods(Y#mod(A,B)) :- modPass(Y#A),
condAssert(:=(B#subsets,Y#mod(A,B))), !,
addMods(Y#B).
addMods(_).
allSubsumed(X,[]).
allSubsumed(X,[H|T]) :- subSortedList(X,H), allSubsumed(X,T).
intersectSorted([],_,[]) :- !.
intersectSorted(X,[],X) :- !.
intersectSorted(H,[A|B],V) :- intersect2(H,A,C), intersectSorted(C,B,V).
intersect2(X,[],[]) :- !.
intersect2([],X,[]) :- !.
intersect2([A|B],[A|C],[A|D]) :- !, intersect2(B,C,D).
intersect2([A|B],[C|D],E) :- compare(<,A,C), !, intersect2(B,[C|D],E).
intersect2(X,[C|D],E) :- !, intersect2(X,D,E).
evalDot(_,X,Y):- var(X), !, X=Y.
evalDot(_,ref(X),ref(X)) :- !.
evalDot(_,world,world) :- !.
evalDot(X#Y,parent,X) :- !.
evalDot(X,this,X) :- !.
evalDot(_,X,X) :- number(X), !. /* X#sdn is world#classes key numbers. */
evalDot(Env,ref(X)#Y,ref(X#Y)) :- !.
evalDot(Env,X$inv(A),Z) :- !, evalDot(Env,X,V),
:=(Z#A,V).
evalDot(Env,X$of(Y),Z) :- !, evalDot(Env,X$of(Y,_),Z).
evalDot(Env,X$of(Y,A),U#A) :-
!, evalDot(Env,X,V), /*A inherited from Y*/
:=(U#A,V), existAnc(U#A,world#classes key Y).
/*Y,A are not quoted*/
evalDot(Env,X$Y,Z) :- !, eval(Env,X$Y,Z). /*Use ref(X)*/
evalDot(Env,X sub Y,U key V) :- !,
evalDot(Env,X,U), eval(Env,Y,@V).
evalDot(Env,X key Y, U key Y) :- !, evalDot(Env,X,U).
evalDot(Env,mod(X,Y), W) :-
evalDot(Env,Y,YDot), getAncestors(Env,mod(X,YDot),W),!.
evalDot(Env,X#Y,B#Y) :- !, evalDot(Env,X,A),checkForKey(Env,A,B).
/* subscripts refer directly to (lowest sorted-order) ancestor array */
evalDot(Env,X,Y key V):- atomic(X), getAncestors(Env,X,Y key V),!.
evalDot(Env,X,Env#X).
checkForKey(Env,A,B key V) :- getAncestors(Env,A,B key V),!.
checkForKey(Env,A,A).
evalArgs(_,X,X) :- atomic(X), !.
evalArgs(Env,X,U) :- X=..[F|Args], evalList(Env,Args,Eargs),
U=..[F|Eargs].
evalList(_,[],[]).
evalList(Env,[A|B],[C|D]) :- eval(Env,A,C), evalList(Env,B,D).
:=(A key mod(X,Y)#sdn,@N) :- nonvar(Y),
modPass(A key X), !, normalize(Y,N).
:=(A#mod(X,Y)#sdn,@N) :- nonvar(Y),
modPass(A#X), !, normalize(Y,N).
:=(mod(X,Y)#sdn,@N) :- nonvar(Y),
modPass(X), !, normalize(Y,N).
addSdn(A key mod(X,Y),Y) :-
var(Y), !, condAssert(modPass(A key X)).
addSdn(A#mod(X,Y),Y) :- var(Y), !, condAssert(modPass(A#X)).
addSdn(mod(X,Y),Y) :- var(Y), !, condAssert(modPass(X)).
addSdn(XDot,Y) :-
retract(:=(XDot#sdn,@S)), !,
mkeBool(S,T),
normalize( &(Y,T), N),!,
assert(:=(XDot#sdn,@N)).
addSdn(XDot,Y) :-
normalize(Y,N),
assert(:=(XDot#sdn,@N)).
addInvar(XDot,Z) :- takeOutAmpersand(Z,W),
retract(:=(XDot#invariant,@ Xinvar)),!,
assert(:=(XDot#invariant, @ &(W,Xinvar))).
addInvar(XDot,Z) :- takeOutAmpersand(Z,W),
assert(:=(XDot#invariant,@ W)).
takeOutAmpersand(@X,X) :- !.
takeOutAmpersand(X,X).
checkOid(_ # _) :- !.
checkOid(X) :- print('***error: Not an object identifier: '),
print(X), nl.
addEnv2ClassExpr(Env,X,X) :- var(X), !.
addEnv2ClassExpr(_,world,world) :- !.
addEnv2ClassExpr(Env,X;Y,A;B) :- !, addEnv2ClassExpr(Env,X,A),
addEnv2ClassExpr(Env,Y,B).
addEnv2ClassExpr(Env,X&Y,A&B) :- !, addEnv2ClassExpr(Env,X,A),
addEnv2ClassExpr(Env,Y,B).
addEnv2ClassExpr(Env,~X,~A) :- !, addEnv2ClassExpr(Env,X,A).
addEnv2ClassExpr(Env, X mod Y, W) :-
var(Y), !, (getAncestors(Env,X mod Y,W) ; W=(X mod Y)), !.
addEnv2ClassExpr(Env, X mod Y, W) :- !,
addEnv2ClassExpr(Env,Y,Z),
(getAncestors(Env,X mod Z,W) ; W=(X mod Z)), !.
addEnv2ClassExpr(Env,X,X) :- isClass(X), !.
addEnv2ClassExpr(Env,X,V) :- getAncestors(Env,X,V).
add2ClassExpr(X,X) :- var(X),!.
add2ClassExpr(X&Y,A&B) :- !, add2ClassExpr(X,A),add2ClassExpr(Y,B).
add2ClassExpr(X;Y,A;B) :- !, add2ClassExpr(X,A),add2ClassExpr(Y,B).
add2ClassExpr(~X,~A) :- !, add2ClassExpr(X,A).
add2ClassExpr(X,X$asSet).
normalize(X,X) :- var(X), !.
normalize(X,W) :- normalize2(X,Z), sortDisj(Z,Y),
addresolvents(Y,W).
normalize2(~(X&Y), Z) :- !, normalize2(~X; ~Y,Z).
normalize2(~(X;Y), Z) :- !, normalize2(~X& ~Y, Z).
normalize2(~ ~X, Z) :- !, normalize2(X,Z).
normalize2((X;Y);Z, W) :-
!, normalize2(Y;Z,U), normalize2(X;U, W).
normalize2(X;Y, Z) :- normalize2(X,A), X\=A,
!, normalize2(A;Y,Z).
normalize2(X;Y,X;Z) :- normalize2(Y,Z).
normalize2(X&(Y;Z), A) :- !, normalize2(X&Y;X&Z,A).
normalize2((Y;Z)&X, A) :- !, normalize2(Y&X;Z&X,A).
normalize2((X&Y)&Z, W) :- !, normalize2(X&(Y&Z), W).
normalize2(X&Y, W) :- nonBool(X), !, normalize2(Y,Z), dist(X,Z,W).
normalize2(~X&Y, W) :- nonBool(X), !, normalize2(Y,Z), dist(~X,Z,W).
normalize2(~X&Y, Z) :- !, normalize2(~X,U), normalize2(U&Y,Z).
normalize2(~X,~X) :- nonBool(X), !.
normalize2(X,X) :- nonBool(X).
nonBool(X) :- functor(X,F,N), \=(F/N,; /2), \=(F/N,& /2), \=(F,~ ).
sortDisj(X,Y) :- disj2List(X,L), sortConjs(L,M),
removeSubs(M,N), sort(N,Y).
sortConjs([],[]).
sortConjs([H|T],[A|B]) :- sortConj(H,A), sortConjs(T,B).
sortConj(X,Z) :- conj2List(X,L), sort(L,M), removeDup(M,Y),
removeAncestors(Y,Z,Y).
removeAncestors([],[],_).
removeAncestors([H|T],M,N):- getDescendantClasses(H,A),
member(A,N),!,
removeAncestors(T,M,N).
removeAncestors([H|T],[H|M],N) :- removeAncestors(T,M,N).
dist(X,Y;Z,A;B) :- !, dist(X,Y,A), dist(X,Z,B).
dist(X,Y,X&Y).
conj2List((X&Y),[X|Z]) :- !, conj2List(Y,Z).
conj2List(X,[X]).
list2Conj([X],X) :- !.
list2Conj([X|Y], X&Z) :- list2Conj(Y,Z).
disj2List((X;Y),L) :- !, disj2List(X,L1), disj2List(Y,L2),
append(L1,L2,L).
disj2List(X,[X]).
list2Disj([X],X) :- !.
list2Disj([X|Y], X;Z) :- list2Disj(Y,Z).
mkeBool([],world#classes key any).
mkeBool([X],A):- !, list2Conj(X,A).
mkeBool([X|Y],A;B) :- list2Conj(X,A), mkeBool(Y,B).
removeDup([X],[X]) :- !.
removeDup([X|Y],Z) :- member(X,Y), !, removeDup(Y,Z).
removeDup([X|Y],[X|Z]) :- removeDup(Y,Z).
removeSubs(X,Z) :- removeTauts(X,Y), removeSubs(Y,Z,[]).
removeSubs([],[],_) :- !.
removeSubs([X|Y],Z,L) :- (member(M,Y);member(M,L)),
subSortedList(M,X), !,
removeSubs(Y,Z,L). /* X is subsumed */
removeSubs([X|Y], [X|Z],L) :- removeSubs(Y,Z,[X|L]).
removeTauts([],[]).
removeTauts([X|Y],Z) :- member(M,X), member(~M,X), !,
removeTauts(Y,Z).
removeTauts([X|Y],[X|Z]) :- removeTauts(Y,Z).
subSortedList([],_).
subSortedList([X|Y],[X|Z]) :- !, subSortedList(Y,Z).
subSortedList(X,[_|Z]) :- subSortedList(X,Z).
addresolvents(InitialList, Ans) :-
findall(X, resolvent(InitialList,X),L),
append(InitialList,L,NewList),
removeSubs(NewList,A),
sort(A,SortedList),
myNot(InitialList=SortedList),
!,
addresolvents(SortedList,Ans).
addresolvents(X,X).
resolvent(X,T) :- member(A,X), member(B,X), delete1(L,A,AP),
delete1(~L,B,BP), append(AP,BP,R), sort(R,S), removeDup(S,T).
/* Every conj of X must be a sublist of some conj of Y. */
subClass(X,Y) :- member(M,X), /*M is a list representing a conj*/
myNot(subListof(M,Y)), !, fail.
subClass(_,_).
subListof(M,Y):- member(N,Y), subSortedList(M,N).
delete1(X,[X|W],W) :- !.
delete1(X,[Y|Z],[Y|W]) :- delete1(X,Z,W).
getvals([],[]).
getvals([X|Y],[A|B]) :- getval(X,A), getvals(Y,B).
getval(X,XV) :- number(X), !, X=XV.
getval(ref(X),XV) :- nonvar(X), :=(X,XV).
findSdnValue(Env,[],_):- !.
findSdnValue(Env,Sdn,Value) :-
findMost(Sdn,[],Most) ,
deleteMost(Most,Sdn,Deleted,Others) ,
sdnCases(Env,Most,Deleted,Others,Value) .
sdnCases(Env,Most,Deleted,Others,Value) :-
findRest(Env,Most,Deleted,Value).
sdnCases(Env,_,_,Others,Value) :-
Others\= [], findSdnValue(Env,Others,Value).
findRest(Env,~Most,Deleted,Value) :- !, /* Negated class */
evalDot(Env,Most,C),
myNot(checkSetSubscripted(C,Value)),
findSdnValue(Env,Deleted,Value).
findRest(Env,Most,Deleted,Value) :-
evalDot(Env,Most,C),
checkSetSubscripted(C,Value),
findSdnValue(Env,Deleted,Value).
findMost([],Counts,X) :- findLargest(X:Most,Counts), !.
findMost([H|T],OldCounts,Most):-
updateCounts(H,OldCounts,NewCounts),
findMost(T,NewCounts,Most).
findLargest([]:0,[]).
findLargest(X:N,[_:M | T]) :- findLargest(X:N,T), N>=M, !.
findLargest(X:N,[X:N | _]).
deleteMost(_,[],[],[]).
deleteMost(Most,[H|T],L,NT) :- delete1(Most,H,NH), !,
deleteMost(Most,T,Y,NT), checkAppend(NH,NT,L).
deleteMost(Most,[H|T],NH,[H|NT]) :- deleteMost(Most,T,NH,NT).
checkAppend([],L,L):- !.
checkAppend(X,Y,Z) :- append(X,Y,Z).
updateCounts([],Counts,Counts).
updateCounts([H|T],Counts, NewCounts) :-
updateCounts(T,Counts,NT),
add1Count(H,NT,NewCounts).
add1Count(X,[],[X:1]).
add1Count(H,[H:C|T],[H:C1|T]) :- !, C1 is C+1.
add1Count(X,[H|T],[H|R]) :- add1Count(X,T,R).
checkClassExpr(X;Y):- !.
checkClassExpr(X&Y):- !.
checkClassExpr(~X) :- !.
condAssert(X) :- call(X),!.
condAssert(X) :- assert(X).
findset(X,Y,Z) :- findall(X,Y,W), removeDup(W,Z).
myNot(X) :- call(X), !, fail.
myNot(X).
:-assert((modPass(dummy) :- fail)). /*Some prologs must define all preds*/
/********Basic User Interface*************/
:-dynamic curDir/1.
main:- retractall(curDir(_)), assert(curDir(world)),
repeat, read(X), mainEval(X,Y), print(Y), nl,
X=end, !.
/* To change directory to Dir inside of the program, the
notation Dir.( , , ...) should be used to execute the statements*/
mainEval(end,bye) :- !.
mainEval(cd(parent),yes) :- !, mainEval(popd,yes).
mainEval(cd(X),yes) :- !,getCurDir(C),
evalDot(C,X,W), asserta(curDir(W)).
mainEval(popd,yes) :- !, retractone(curDir(_)).
mainEval(pwd,X) :- !, getCurDir(X).
mainEval(X,Y) :- getCurDir(CurDir), eval(CurDir,X,Y).
mainEval(_,'no more'). getCurDir(X) :- curDir(X), !.
?-member([F,N],[[+,2],[-,2],[*,2],[/,2],[mod,2],[div,2],
[~ ,1],[sin,1],[cos,1],[tan,1],[asin,1],[acos,1],[atan,1]]),
functor(Y,F,N),
assert((:=(world#classes key numbers# @prologDefn(F,Y=@ V),@true)
:-
Y=..[F|Args],
getvals(Args,Eargs), Z=..[F|Eargs],
V is Z)),
fail.
?-member([F,N],[[<,2],[>,2],[=,2],[\=,2],[==,2],[=\=,2],[>=,2],[=<,2]]),
functor(Y,F,N),
assert((:=(world#classes key numbers# @prologDefn(F,Y=@ V),@true)
:-
Y=..[F|Args],
getvals(Args,Eargs), Z=..[F|Eargs],
(call(Z)-> (V= @true);(V= @false)))),
fail.
/* A Sample execution */
?- main.
world#classes key mod(lockable,X) <@ any.
/*Don't inherit object's assignment*/
world#classes key mod(lockable,X)#
insert(ref(U),W) =@ (U$locked ->
@error('attempt to assign locked var', @U);
(insert(X::ref(U),W),
U#locked:= @true)).
world#classes key mod(lockable,X)#lock(ref(This)) =@
(This#locked:= @true).
world#classes key mod(lockable,X)#unlock(ref(This)) =@
(This#locked:= @false).
b<@mod(lockable,primitives).
b$lock.
b+=5.
b$unlock.
b+=7.
b.
numbers#factorial(This) =@
(This>1 -> This*factorial(This-1); 1).
print factorial(10).
world#classes key courses<@ objects,
world#classes key people<@ objects,
world#classes key profs<@ people,
world#classes key students<@ people.
world#classes key gradStudents<@
students where ((level=phd);(level=masters)).
print 1.
mod(our,This)<@This where (university := @'Chung Cheng').
print 2.
ourCourses <@ mod(our,courses), ourProfs <@ mod(our,profs),
ourStudents <@ mod(our,students).
print 3.
ourCourses+= member([@cs100,@cs105,@cs120,@cs200]).
print 4.
ourProfs+= member([@'John Doe', @'Henry James', @'Superman']).
print 5.
for X in @[tim,john,mary] do ourStudents key X inClass
mod(our,gradStudents) withProto (level:= @phd).
print 6.
newenvir<@world.
print 7.
for X in [^ourCourses,^ourProfs,^ourStudents,^world#classes]
do newenvir#subsets += X.
cd newenvir.
print 8.
print tim$level.
print 9.
world#classes key mod(singleton,X) <@ X.
print 10.
world#classes key mod(singleton,X)#insert(ref(U),W) =@
(nonEmpty(U) ->
@error('inserting in singleton set';X::U:=W);
insert(X::ref(U),W)).
print 11.
world#ourStudents#prototype#advisor<@
world#classes key mod(singleton,world#classes key profs).
print 12.
mary#taking+=member([cs100,cs200]).
mary#advisor:= 'John Doe'.
tim#taking+= member([cs100,cs105]).
tim#advisor+= 'John Doe'.
print 13.
john#advisor+=member(['Henry James', 'John Doe']).
print 14.
john#taking+= member([cs100,cs120]).
print 15.
'John Doe'#teaching += member([cs100,cs200]).
print 16.
'Henry James'#teaching:= cs120.
print 17.
profs#teachingOwnStudents(ref(This))=@
(nonEmpty(This$teaching$inv(taking) & This$inv(advisor))
-> This).
print mod(our,profs)$asSet$teachingOwnStudents.
end.
Comments
Post a Comment