alanf@bruce.OZ (Alan Grant Finlay) (03/29/90)
# Prolog in Icon, version 3, (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,cls,r # and returns updated context if hd>tl then return ctext 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 resolve(q.args,1,1,ctext) then suspend resolve(qry,hd+1,tl,ctext)} # negation by failure default : {goal:=scanpred(q,ctext) every cls := !dbase[q.name] do every sub:=tryclause(goal,cls,ctext.subst) do 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 } 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 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 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