Icon

########################## 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
end