Family
% GENE.PRO - genealogical relationships
%
% A Prolog database of relations derived from basic information about
% individuals. The relations ships can all be read as 'relationship
% of', so for example, parent(P,C) means P is parent of C.
%
% When there is a performance trade-of in the implementation of a rule,
% it is assumed that in general the second argument of a relation will
% most likely be bound. See for example full_sibling/2, which will
% have a smaller search for full_sibling(X,joe), than full_sibling(joe,X).
%
% This code is used as an example of an embedded Prolog application.
% One is a C++ application and the other Visual Basic.
%
% To use this code from Prolog, consult it in the listener and use the
% following predicates:
%
% open(F) - opens a file of family relationships, ex. open('england.fam').
% open/1 just does a consult, so you can use consult instead.
% close - retracts all the persons currently defined
% save(F) - saves the persons in the named file
% add_person(Name, Mother, Father, Gender, Spouse) - adds a person
% fact with the specified attributes, checking semantics as it does
% Relationship(P1, P2) - any relationship query, such as child(X,Y).
% relation(R, P1, P2) - can be used to find the relationship between
% individuals as well as pose relationship queries.
parent(P,C) :-
(mother(P,C) ; father(P,C)).
child(C,P) :- parent(P,C).
son(C,P) :- parent(P,C), male(C).
daughter(C,P) :- parent(P,C), female(C).
wife(W,P) :-
spouse(W,P),
female(W).
husband(H,P) :-
spouse(H,P),
male(H).
ancestor(A,P) :-
parent(A,P).
ancestor(A,P) :-
parent(X,P),
ancestor(A,X).
descendent(D,P) :-
parent(P,D).
descendent(D,P) :-
parent(P,X),
descendent(D,X).
full_sibling(S1, S2) :-
mother(M,S2),
mother(M,S1),
S1 \= S2,
father(F,S1),
father(F,S2).
half_sibling(S1, S2) :-
mother(M,S2),
mother(M,S1),
S1 \= S2,
father(F1,S1),
father(F2,S2),
F1 \= F2.
half_sibling(S1, S2) :-
father(F,S2),
father(F,S1),
S1 \= S2,
mother(M1,S1),
mother(M2,S2),
M1 \= M2.
sibling(S1, S2) :-
full_sibling(S1,S2).
sibling(S1, S2) :-
half_sibling(S1,S2).
sister(S,P) :-
sibling(S,P),
female(S).
brother(B,P) :-
sibling(B,P),
male(B).
step_sibling(S1, S2) :-
parent(P2, S2),
spouse(M2, P2),
parent(M2, S1),
not(parent(M2,S2)),
not(half_sibling(S1,S2)).
uncle(U,X) :-
parent(P,X),
brother(U,P).
aunt(A,X) :-
parent(P,X),
sister(A,P).
step_parent(P2,C) :-
parent(P,C),
spouse(P2,P),
not(parent(P2,C)).
step_mother(M,C) :- step_parent(M,C), female(M).
step_father(F,C) :- step_parent(F,C), male(F).
step_child(C2,P) :- step_parent(P,C2).
step_daughter(D,P) :- step_child(D,P), female(D).
step_son(S,P) :- step_child(S,P), male(S).
nephew(N,X) :-
sibling(S,X),
parent(S,N),
male(N).
niece(N,X) :-
sibling(S,X),
parent(S,N),
female(N).
cousin(X,Y) :-
parent(P,Y),
sibling(S,P),
parent(S,X).
grandmother(GM,X) :-
parent(P,X),
mother(GM,P).
grandfather(GF,X) :-
parent(P,X),
father(GF,P).
grandparent(GP,X) :-
parent(P,X), parent(GP,P).
grandson(GS,X) :-
grandchild(GS,X),
male(GS).
granddaughter(GD,X) :-
grandchild(GD,X),
female(GD).
grandchild(GC,X) :-
parent(X,C),
parent(C,GC).
%----------------------------------------------------------------------
% relation/3 - used to find relationships between individuals
%
relations([parent, wife, husband, ancestor, descendent, full_sibling,
half_sibling, sibling, sister, brother, step_sibling, uncle,
aunt, mother, father, child, son, daughter, step_parent,
step_child, step_mother, step_father, step_son, step_daughter,
nephew, niece, cousin, grandmother, grandfather, grandparent,
grandson, granddaughter, grandchild]).
relation(R, X, Y) :-
relations(Rs),
member(R,Rs),
Q =.. [R,X,Y],
call(Q).
%----------------------------------------------------------------------
% person object
%
% These predicates define the interface to a person. All of the
% genealogical rules are based on these predicates, which are
% based on the basic representation of a person. These are the
% only rules which need to be changed if the representation of
% a person is changed.
%
% The current representation is flat database relations of the form:
% person(Name, Gender, Mother, Father, Spouse).
%
add(Name,Gender,Mother,Father,Spouse) :-
assert(person(Name,Gender,Mother,Father,Spouse)).
add(Name,_,_,_,_) :-
delete(Name),
fail.
open(FileName) :-
consult(FileName).
close :-
retractall(person(_,_,_,_,_)).
save(FileName) :-
tell(FileName),
listing(person),
told.
delete(X) :-
retract(person(X,_,_,_,_)).
person(X) :-
person(X,_,_,_,_).
male(X) :-
person(X,male,_,_,_).
female(Y) :-
person(Y,female,_,_,_).
mother(M,C) :-
person(C,_,M,_,_).
father(F,C) :-
person(C,_,_,F,_).
spouse(S,P) :-
person(P,_,_,_,S),
S \= single.
%----------------------------------------------------------------------
% Semantic Integrity Checks on Update
%
add_person(Name,Gender,Mother,Father,Spouse) :-
retractall(message(_)),
dup_check(Name),
add(Name,Gender,Mother,Father,Spouse),
ancestor_check(Name),
mother_check(Name, Gender, Mother),
father_check(Name, Gender, Father),
spouse_check(Name, Spouse).
dup_check(Name) :-
person(Name),
assert(message($Person is already in database$)),
!, fail.
dup_check(_).
ancestor_check(Name) :-
ancestor(Name,Name),
assert(message($Person is their own ancestor/descendent$)),
!, fail.
ancestor_check(_).
mother_check(_, _, Mother) :- not(person(Mother)), !.
mother_check(_, _, Mother) :-
male(Mother),
assert(message($Person's mother is a man$)),
!, fail.
mother_check(Name, male, _) :-
mother(Name, X),
assert(message($Person, a male, is someone's mother$)),
!, fail.
mother_check(_,_,_).
father_check(_, _, Father) :- not(person(Father)), !.
father_check(_, _, Father) :-
female(Father),
assert(message($Person's father is a man$)),
!, fail.
father_check(Name, female, _) :-
father(Name, X),
assert(message($Person, a female, is someone's father$)),
!, fail.
father_check(_,_,_).
spouse_check(Name, Spouse) :-
spouse(Name, X),
X \= Spouse,
assert(message($Person is already someone else's spouse$)),
!, fail.
spouse_check(Name, Spouse) :-
blood_relative(Name, Spouse),
assert(message($Person is a blood relative of spouse$)),
!, fail.
spouse_check(_,_).
blood_relative(X,Y) :- (ancestor(X,Y); ancestor(Y,X)).
blood_relative(X,Y) :- sibling(X,Y).
blood_relative(X,Y) :- cousin(X,Y).
blood_relative(X,Y) :- (uncle(X,Y); uncle(Y,X)).
blood_relative(X,Y) :- (aunt(X,Y); aunt(Y,X)).
Custord
% CUSTORD
% This is a sample Prolog program which implements a portion
% of a customer order inventory application. It is not intended to
% be complete, and only illustrates the concept of writing a database
% application in Prolog.
% This example extends the concept of an intelligent database to include
% a full database application. It is really a rule based approach to
% transaction processing. In fact a large percentage of the procedural
% code normally written in database applications has to do with
% enforcing semantic integrity rules involving multiple records.
% The distinction between data and process is thoroughly blurred. Both
% reside together in the same logicbase.
% There is pure data as it might be defined in a relational database
% (customer, item, inventory, order); there are rules which really
% represent data views (item_quant); there are rules which add
% intelligence to the logicbase (good_customer, valid_order); and there
% are rules which are processes (order, report_inventory).
main :- order.
% customer(Name, Town, Credit-rating).
customer(dennis, winchester, xxx).
customer(dave, lexington, aaa).
customer(ron, lexington, bbb).
customer(julie, winchester, aaa).
customer(jawaid, cambridge, aaa).
customer(tom, newton, ccc).
% item(Number, Name, Reorder-quantity).
item(p1,thing,10).
item(p2,stuff,10).
item(p3,article,10).
item(p4,object,10).
item(p5,substance,10).
item(p6,piece,10).
item(p7,matter,10).
% inventory(Number, Quantity).
inventory(p1,10).
inventory(p2,10).
inventory(p3,10).
inventory(p4,78).
inventory(p5,23).
inventory(p6,14).
inventory(p7,8).
% item-inv view or join
item_quant(Item, Quantity):-
item(Partno, Item, _),
inventory(Partno, Quantity).
% reorder if inventory below reorder point
reorder(Item):-
item(Partno, Item, Reorder_point),
inventory(Partno, Quantity),
Quantity < Reorder_point,
write('Time to reorder '),
write(Item), nl.
reorder(Item):-
write('Inventory level ok for '),
write(Item), nl.
% a good customer has a credit rating of aaa
% or lives in winchester
% or has ordered something
good_customer(Cust):-
customer(Cust, _, aaa).
good_customer(Cust):-
customer(Cust, winchester, _).
good_customer(Cust):-
order(Cust, _, _).
% process order
order:-
write('Customer: '),
read(Customer),
write('Item: '),
read(Item),
write('Quantity: '),
read(Quantity),
valid_order(Customer,Item,Quantity),
asserta(order(Customer,Item,Quantity)),
update_inventory(Item,Quantity),
reorder(Item).
% an order is valid if
% it doesn't go below zero inventory and
% the customer is a good customer
valid_order(C, I, Q):-
item(Partno, I, _),
inventory(Partno, Onhand),
Q =< Onhand,
good_customer(C).
valid_order(C, I, Q):-
write('Bad order'),
nl,
fail.
% update the inventory
update_inventory(I,Q):-
item(Pn, I, _),
inventory(Pn, Amount),
NewQ is Amount - Q,
retract(inventory(Pn, Amount)),
asserta(inventory(Pn, NewQ)).
% inventory report
report_inventory:-
item_quant(I, Q),
write(I), tab(1),
write(Q), nl,
fail.
report_inventory:-true.
Birds
% BIRDS
% 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).