alanf@bruce.OZ (Alan Grant Finlay) (03/29/90)
########################## 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 {
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 # in given context, returns updated context
if hd>tl then return ctext
if (q:=qry[hd]).name=="~" then # negation by failure
{if not resolve(q.args,1,1,ctext) then suspend resolve(qry,hd+1,tl,ctext)}
else every sub:=tryclause(scanpred(q,ctext),!dbase[q.name],ctext.subst) do
suspend resolve(qry,hd+1,tl,ctxt(ctext.env,sub))
end
procedure tryclause(term,cls,sub) # resolves term using given clause or fails
local ctext # 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
suspend resolve(cls.body,1,*cls.body,ctext).subst
end
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
######################## primitive domain operations ########################
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(str,sub) # converts a term to a string suitable for output
local s; s:=""
case type(str) of {
"integer" : return trmstr(sub[str],sub)
"struct" : {every s:=s||trmstr(!str.args,sub)||","
return str.name||(if *s=0 then "" else "("||s[1:-1]||")")}
"null" : return "undefined"}
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
local b; b:=[]
if put(b,pred()) then while ="," & put(b,pred())
return b
end
procedure pred() # ~pred | name(body) | uc_name | lc_name()
local name,args; args:=[]
if ="~" then return fun("~",[pred()])
if not (name:=tab(many(&ucase++&lcase++'0123456789._'))) then fail
if any(&ucase,name) then return var(name)
if ="(" & args:=body() then # arguments parsed
if not =")" then write("syntax error: \")\" expected before ",tab(0))
return fun(name,args)
end
procedure extractids(ids,pred)
if type(pred)=="fun" then every extractids(ids,!pred.args)
else if not (pred.name==!ids) then put(ids,pred.name)
return
endalanf@bruce.OZ (Alan Grant Finlay) (03/29/90)
# Prolog in Icon, version 2, (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 {
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 # in given context, returns updated context
if hd>tl then return ctext
if (q:=qry[hd]).name=="~" then # negation by failure
{if not resolve(q.args,1,1,ctext) then suspend resolve(qry,hd+1,tl,ctext)}
else every sub:=tryclause(scanpred(q,ctext),!dbase[q.name],ctext.subst) do
suspend resolve(qry,hd+1,tl,ctxt(ctext.env,sub))
end
procedure tryclause(term,cls,sub) # resolves term using given clause or fails
local ctext # 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
suspend resolve(cls.body,1,*cls.body,ctext).subst
end
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
######################## primitive domain operations ########################
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
############################## 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 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