alanf@bruce.OZ (Alan Grant Finlay) (03/29/90)
# Prolog in Icon, version 4, (C) Alan Finlay, Monash University.
########################## global variables and types ######################
record ctxt(env,subst) # integer[string] * ((integer | struct | null) list)
record struct(name,args) # string * ((integer | struct) list)
record rule(ids,head,body)# string list * predicate * predicate list \
record all(ids,body) # string list * predicate list } clauses
record one(ids,body) # string list * predicate list /
record fun(name,args) # string * predicate list \ types of
record var(name) # string / predicates
global dbase # table of clauses indexed by head name
global consult # stack of files being consulted
global query # top level query
################################## driver ##################################
procedure main()
dbase:=table([]); consult:=[&input] # empty dbase; standard input
while \query | *consult>0 do { # more queries possible
prog() # parse clauses, possibly setting query as a side effect
if \query then case type(query) of {
"all" : {every printsoln(query); write("no more solutions")}
"one" : if not printsoln(query) then write("no")}
else pop(consult)}
end
procedure printsoln(qry) # print first or next solution to qry
local ans,v
every ans:=resolve(qry.body,1,*qry.body,newctxt(qry.ids,[])) do {
if (type(ans)=="string") & (ans=="cut") then fail # cut query
writes("yes")
every v:=!qry.ids do writes(", ",v,"=",trmstr(ans.env[v],ans.subst))
suspend write()}
end
########################### Prolog interpreter #############################
procedure resolve(qry,hd,tl,ctext) # generates all solutions of qry[hd:tl]
local sub,q,cls,r # and returns updated context
if hd>tl then return ctext # terminate linear recursion
case (q:=qry[hd]).name of {
"assert" : {r:=rule([],q.args[1],q.args[2:0])
every extractids(r.ids,!q.args)
dbase[q.args[1].name]:=dbase[q.args[1].name]|||[r]
suspend resolve(qry,hd+1,tl,ctext)} # always succeeds
"retract" : suspend retract(q.args[1],ctext) & resolve(qry,hd+1,tl,ctext)
"~" : {if not (sub:=resolve(q.args,1,1,ctext).subst) |
(type(sub)=="string" & sub=="cut") then
suspend resolve(qry,hd+1,tl,ctext)} # negation by failure
"!" : {suspend resolve(qry,hd+1,tl,ctext)
return "cut"} # causes failure of parent clause
default : {goal:=scanpred(q,ctext)
every cls := !dbase[q.name] do
every sub:=tryclause(goal,cls,ctext.subst) do {
if type(sub)=="string" & sub=="cut" then fail
else suspend resolve(qry,hd+1,tl,ctxt(ctext.env,sub))}
}
}
end
procedure retract(pred,ctext) # removes a clause matching pred from dbase
local cand,goal,entry,i; i:=1 # fails when no more matching clauses to remove
goal:=scanpred(pred,ctext)
every entry:=!dbase[goal.name] do { # check for matching clause
cand:=scanpred(entry.head,newctxt(entry.ids,ctext.subst))
if unify(goal,cand,copy(ctext.subst)) then { # found one so remove it
dbase[goal.name]:=extract(dbase[goal.name],i)
suspend} # on backtracking more retractions can occur
else i+:=1 # i keeps track of the entry number even with extractions
} # n.b. this is a primitive retract since only the head is matched
end
procedure tryclause(term,cls,sub) # resolves term using given clause or fails
local ctext,res # a copy of sub is used so no side effects
ctext:=newctxt(cls.ids,copy(sub)) # preallocate context for whole clause
if unify(term,scanpred(cls.head,ctext),ctext.subst) then
every res:=resolve(cls.body,1,*cls.body,ctext) do {
if (type(res)=="string") & (res=="cut") then suspend "cut"
else suspend res.subst}
end
######################## primitive domain operations ########################
procedure scanpred(prd,ctext) # converts predicate to structure
local args; args:=[]
if type(prd)=="var" then return ctext.env[prd.name]
every put(args,scanpred(!prd.args,ctext))
return struct(prd.name,args)
end
procedure unify(t1,t2,sub) # (integer | struct),(integer | struct),sub
local v,i,num # side effect: sub is updated
if type(t1)=="integer" then {
while type(v:=sub[t1])=="integer" do t1:=v # apply sub to t1
return if type(v)=="struct" then unify(v,t2,sub) else sub[t1]:=t2}
if type(t2)=="integer" then return unify(t2,t1,sub)
if (t1.name==t2.name) & ((num:=*t1.args)=*t2.args) then {
every i:=1 to num do if not unify(t1.args[i],t2.args[i],sub) then fail
return}
end
procedure newctxt(ids,sub) # forms a new context by extending sub
local env; env:=table(&null) # to accommodate the unbound identifiers
every env[!ids]:=*put(sub,&null)
return ctxt(env,sub)
end
procedure trmstr(trm,sub) # converts a term to a string suitable for output
local s; s:=""
case type(trm) of {
"integer" : return trmstr(sub[trm],sub)
"struct" : if s:=lstr(trm,sub) then return "["||s||"]" # non-empty list
else {every s:=s||trmstr(!trm.args,sub)||","
return trm.name||(if *s=0 then "" else "("||s[1:-1]||")")}
"null" : return "undefined"}
end
procedure lstr(l,sub) # succeeds if l is a proper non-empty list and
local hd,tl # converts l to string suitable for output
if l.name=="." & *l.args=2 then {
hd:=trmstr(l.args[1],sub); tl:=l.args[2]
while type(tl)=="integer" do tl:=sub[tl] # apply sub to tl
case type(tl) of {
"struct" : {if tl.name=="nil" & *tl.args=0 then return hd # nil
return hd||","||lstr(tl,sub)} # cons
"null" : return "undefined"}}
end
procedure extract(list,el) # extract list element in position [el:el+1]
return list:=list[1:el]|||list[el+1:0]
end
############################## Prolog parser ###############################
procedure prog() # parses consult[1] until query found or end of file
query:=&null
while write(read(consult[1])) ? clause()
if /query & consult[1]~===&input then close(consult[1])
end
procedure clause() # adds a clause to the dbase or fails when query set
local p,b,ids,t; b:=[]; ids:=[]
if =":-" then query:=all(ids,b:=body())
else if ="?-" then query:=one(ids,b:=body())
else {p:=pred(); if =":-" then b:=body()}
if (t:=trim(tab(0)))~=="." then # syntax error
return write("syntax error: ",t,if *t=0 then "." else " not"," expected")
every extractids(ids,\p|!b) # list of variable identifiers
if (\p).name=="consult" then every push(consult,open((!p.args).name))
return dbase[(\p).name]:=dbase[p.name]|||[rule(ids,p,b)]
end
procedure body() # list of predicates (may be empty)
local b; b:=[]
if put(b,pred()) then while ="," & put(b,pred())
return b
end
procedure dots() # converts non-empty body of list to cons cells
local p
if p:=pred() then if ="," then return fun(".",[p,dots()])
else return fun (".",[p,fun("nil",[])])
end
procedure pred() # ~pred , name(body) , uc_name , lc_name , [body] , pred|pred
local name,args,d,p,pp; args:=[]
if ="~" then p:=fun("~",[pred()])
else if ="!" then p:=fun("!",[])
else if name:=tab(many(&ucase++&lcase++'0123456789._')) then {
if any(&ucase,name) then p:=var(name)
else {if ="(" & args:=body() then check(")"); p:=fun(name,args)}}
else if ="[]" then p:=fun("nil",[]) # empty list abbreviation
else if ="[" then {p:=dots(); check("]")} # non-empty list abbreviation
if ="|" then if pp:=pred() then return fun(".",[p,pp]) # infix cons
else write("syntax error: missing second argument to \"|\"")
return \p # n.b. fails if predicate invalid
end
procedure check(s) # report error if s not present or skip over it
if not =s then write("syntax error: ",s," expected before ",tab(0))
end
procedure extractids(ids,pred) # build the set of variable identifiers
if type(pred)=="fun" then every extractids(ids,!pred.args)
else if not (pred.name==!ids) then put(ids,pred.name)
return # the identifiers have been appended to reference parameter ids
end