PACKET prolog (* Autor: P.Heyderhoff *) DEFINES (* Date: 03.07.1987 *) prolog, prolog again: { GLOBALS } LET { Stacksize parameter } limit = 800; LET { nil-POINTER } nil = 0; LET { bootstrap rules } boot = """|"".""!"".""MOD"".""-"".""+"".""*"".""/"".bye.listing. call(X).write(X).writeq(X).read(X).get(X).get0(X).put(X).incr(X). assertz(X).asserta(X).retract(X).var(X). X IS Y.X=X.X<>Y.X<=Y.X==Y.X=..Y.clause(X,_).name(X,Y). arg(X,Y,Z).functor(X,Y,Z).elan(X).elan(X,Y)"; LET { bootstrap symbols, see: boot } cons=1, cut=2, mod=3, {TOKEN: minus=4, plus=5, times=6, slash=7} bye=8, list=9, call=10, xpar=11, writ=12, wriq=13, read=14, get=15, get0=16, put0=17, incr=18, ass=19, assa=20, retr=21, vari=22, is=23, ypar=24, dif=26, leq=27, eq=28, univ=29, clau=30, claupar=31, nam=32, argi=33, zpar=34, func=35, elan=36, build ins=33; LET { TOKENS } stroke=1, exclamation=2, colon=3, minus=4, plus=5, times=6, slash=7, underscore=8, less=9, equal=10, uneq=11, grt=12, eqeq=13, eqdotdot=14, period=15, comma=17, semicolon=18, open paren=19, close paren=20, open bracket=21, close bracket=22, end of input=23, boldvar=24, number=25, identifier=26; LET { SYMBOLTYPES } tag=1, bold=2, num=3, tex=4, operator=5, delimiter=6, end of file=7, within com=8, within tex=9; INT CONST integer:= -1, var:= -2; LET TOKEN = INT; LET SYMBOLTYPE = INT; LET SYMBOL = INT; LET SYMBOLTABLE = THESAURUS; LET TERMS = INT; { LET TERMSCELL = STRUCT (TERM first, TERMS rest); } LET TERM = STRUCT (SYMBOL symbol, TERMS arguments, INT arity); LET CLAUSES = INT; { LET CLAUSESCELL = STRUCT (TERMS first, CLAUSES rest); } LET FRAME = INT; LET FRAMECELL = STRUCT (TERM call, FRAME father, TERMS subgoals, { remaining } ENVIRONMENT environment, EXPRESSIONS reset, CLAUSES rest { potential rules }, FRAME level ); LET ENVIRONMENT = INT; LET ENVIRONMENTCELL = STRUCT (SUBSTITUTION first, ENVIRONMENT rest); LET SUBSTITUTION = STRUCT (TERM variable, TERM substitute, FRAME others); LET FRAMESTACK = STRUCT (FRAME frame, goalframe, removed goal, INT last tp, last kp, last fp, last np); LET EXPRESSIONS = INT; LET EXPRESSION = STRUCT (TERM term, FRAME index); TEXT VAR tcsymbol, tcarguments, tcarity, tcrest; INT VAR tp; TEXT VAR kcfirst, kcrest; INT VAR kp; ROW limit FRAMECELL VAR fc; INT VAR fp; ROW limit ENVIRONMENTCELL VAR nc; INT VAR np; ROW limit FRAMESTACK VAR fsc; INT VAR fsp; ROW limit EXPRESSION VAR ec; INT VAR ep; ROW limit CLAUSES VAR freec; INT VAR freep; SYMBOL VAR look ahead value; TEXT VAR look ahead symbol, ahead symbol; BOOL VAR look ahead empty, ahead empty; INT VAR look ahead token, ahead symboltype; SYMBOL VAR pattern; TERMS VAR ts; TERM VAR t, t2, t3; CLAUSES VAR k, kl, knowledge base, candidates; FRAME VAR root, cut level, res frame; SYMBOLTABLE VAR symboltable, reset symboltable; FILE VAR file; BOOL VAR from file, tracing, testing, found, quoting, free of errors, finish; INT VAR i, j, reset tp, reset kp, reset freep, anonym value, inference level, inference count, rule count; TEXT VAR command; REAL VAR start time:= 0.0; PROC init globals: tp := nil; kp:= nil; tracing:= FALSE; testing:= FALSE; symboltable:= empty thesaurus; reset symboltable:= symboltable; reset tp:= nil; reset kp:= nil; reset freep:= nil; knowledge base:= nil; from file:= FALSE; inference count:= 0; tcsymbol:=""; tcarguments:=""; tcarity:=""; tcrest:=""; kcfirst:=""; kcrest:=""; quoting:= TRUE ENDPROC init globals; PROC init prooftree: root := nil; freep:= reset freep; fp:= nil; fsp:= nil; np:= nil; ep:= nil; tp:= reset tp; kp:= reset kp; symboltable:= reset symboltable; free of errors:= TRUE; candidates:= nil; new (fp, root); fc(root):= FRAMECELL:(t, nil, nil, nil, nil, nil, 0); anonym value:= 0; collect heap garbage; finish:= FALSE ENDPROC init proof tree; PROC prolog (TEXT CONST knowledge): line; last param (knowledge); init globals; bootstrap; IF exists (knowledge) THEN consult (knowledge) FI; IF free of errors THEN prolog again FI; last param (knowledge). bootstrap: TERMS VAR clauses:= nil; init proof tree; look ahead empty:= TRUE; ahead empty:= TRUE; scan (boot); WHILE look ahead <> end of input REP read clause; assertz (clauses); clauses:= nil PER; reset tp:= tp; reset kp:= kp; reset symboltable:= symboltable. read clause: TERM VAR term; read term (term); IF look ahead = period THEN remove token FI; insert term in clauses. insert term in clauses: TERMS VAR tmp; new tp (tmp); replace(tcsymbol,tmp,term.symbol); replace(tcarguments,tmp,term.arguments); replace(tcarity,tmp,term.arity); replace(tcrest,tmp, clauses); clauses:= tmp. remove token: look ahead empty:= TRUE. ENDPROC prolog; BOOL PROC prolog (TEXT CONST query, TEXT VAR answer): disable stop; init prooftree; read goals; BOOL VAR result:= NOT prove; answer is value of last variable; result . read goals: scan (query); look ahead empty:= TRUE; ahead empty:= TRUE; from file:= FALSE; fc(root).subgoals:= nil; read terms (fc(root).subgoals); IF look ahead = period THEN remove token FI; IF look ahead <> end of input THEN syntax error ("unexpected characters after last goal") FI. answer is value of last variable: IF fc(root).environment <> nil THEN value (nc(fc(root).environment).first.variable, t, root); file:= sequential file (output, "$$"); sysout ("$$"); write term backward (t); sysout (""); input (file); getline (file, answer); forget ("$$", quiet) ELSE answer:= "" FI . remove token: look ahead empty:= TRUE. ENDPROC prolog; PROC prolog again: disable stop; lernsequenz auf taste legen ("q","bye"13""); write (""13""10""5"?- "); REP init proof tree; initiate read terms (fc(root).subgoals, "-"); read goals; prove goals; UNTIL finish PER; lernsequenz auf taste legen ("q","break"13""). read goals: IF is error THEN c:= "?" ELIF look ahead = open bracket THEN remove token; read consult list ELSE read terms (fc(root).subgoals); IF look ahead = period THEN remove token FI; IF look ahead <> end of input THEN syntax error ("unexpected characters after last goal") FI FI. prove goals: IF tracing THEN inference level:= 0; line FI; inference count:= 0; start time:= clock (0); REP IF c <> "?" CAND prove THEN IF tracing THEN line FI; write (" no"13""10""5"?- "); LEAVE prove goals ELSE IF tracing THEN inference level:= 0 FI; get cursor (i,j); IF i > 1 THEN line FI; IF is error THEN put error; clear error; putline (""4""{cleop}); free of errors:= FALSE; sysout (""); sysin (""); putline ("type '?' to get explanations"); putline ("type ';' to try next alternative"); putline ("type any other key to stop") ELSE write answers FI; get cursor (i, j); write (""10""10""13""5"?- "); getchar (c); TEXT VAR c; SELECT pos ("?;",c) OF CASE 1: write ("?"); inform CASE 2: write (""13""5""3""3""); get cursor (j, k); cursor (i, k); putline (";"); OTHERWISE IF c >= " " COR c = ""27"" THEN push (c) FI; LEAVE prove goals END SELECT; IF tracing THEN line FI; IF is error THEN put error; clear error; putline (""4""{cleop}) FI FI PER. write answers: write (" "); IF fc(root).environment = nil THEN IF free of errors THEN put ("yes") ELSE put ("no") FI ELSE write environment list (root) FI. remove token: look ahead empty:= TRUE. ENDPROC prolog again; PROC prolog: prolog (last param) ENDPROC prolog; BOOL PROC prove: enable stop; initialize prove; find potential candidates. handle remaining subgoals: { all subgoals to the left are solved } IF subgoals remain THEN get candidates ELSE LEAVE prove WITH FALSE FI. find potential candidates: REP try one candidate PER; TRUE. try one candidate: { all candidates tried do not unify with the current goal } IF head of one candidate unifies with the current goal THEN push frame; handle remaining subgoals ELSE backtrack to the parent of the current goal FI. backtrack to the parent of the current goal: { none of the candidates unify with the current goal } IF prooftree exhausted THEN LEAVE prove WITH TRUE ELSE pop frame FI. prooftree exhausted: fsp = 1. initialize prove: TERM VAR curr call; FRAME VAR curr frame, top frame; EXPRESSIONS VAR last ep; IF fsp = nil THEN curr frame:= root; push frame; handle remaining subgoals ELSE IF tracing THEN line FI; backtrack to the parent of the current goal FI. head of one candidate unifies with the current goal: son { curr frame is the resulting next son }. subgoals remain: select frame {(curr frame, curr call)}. push frame: fsp INCR 1; fsc(fsp).frame:= curr frame; fsc(fsp).goalframe:= nil; fsc(fsp).last tp:= tp; fsc(fsp).last kp:= kp; fsc(fsp).last fp:= fp; fsc(fsp).last np:= np. pop frame: { fsp <> nil } top frame:= fsc(fsp).frame; curr frame:= fc(top frame).father; reinsert current call as subgoal; curr call:= fc(top frame).call; candidates:= fc(top frame).rest; cut level:= fc(top frame).level; tp:= fsc(fsp).last tp; kp:= fsc(fsp).last kp; fp:= fsc(fsp).last fp; np:= fsc(fsp).last np; fsp DECR 1; IF tracing CAND inference level > 0 CAND NOT testing THEN write (""13""5""3""5""); inference level DECR 1 FI; undo bindings (fc(top frame).reset). reinsert current call as subgoal: IF fsc(fsp).goalframe <> nil THEN fc(fsc(fsp).goalframe).subgoals:= fsc(fsp).removed goal FI. select frame: REP IF next call THEN LEAVE select frame WITH TRUE FI; curr frame:= fc(curr frame).father UNTIL curr frame = nil PER; FALSE. next call: ts:= fc(curr frame).subgoals; IF ts = nil THEN FALSE ELSE remove subgoals; TRUE FI. remove subgoals: curr call:= TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts); fc(curr frame).subgoals:= (tcrestISUB(ts)) ; fsc(fsp).goalframe:= curr frame; fsc(fsp).removed goal:= ts. get candidates: initialize clauses; WHILE more knowledge REP find next clause candidate in knowledge base PER { candidates = a list of clauses which may be unifiable with curr call } . initialize clauses: fc(curr frame).level:= cut level; cut level:= curr frame; IF curr call.arity = var THEN IF bound (curr call, curr frame, curr call, ts) THEN FI; IF curr call.arity = var THEN take goal itself as candidate; LEAVE get candidates FI FI; k:= knowledge base; found:= FALSE; candidates:= nil. take goal itself as candidate: new kp (candidates); replace (kcfirst, candidates, goal itself); replace (kcrest, candidates, nil). goal itself: new tp (ts); replace(tcsymbol,ts,curr call.symbol); replace(tcarguments,ts, curr call.arguments); replace(tcarity,ts, curr call.arity); replace(tcrest,ts, nil); ts. find next clause candidate in knowledge base: IF (tcsymbolISUB((kcfirstISUB(k)) )) = curr call.symbol THEN found:= TRUE; IF (tcarityISUB((kcfirstISUB(k)) )) = curr call.arity THEN insert clause in candidates FI ELIF found THEN LEAVE get candidates FI; k:= (kcrestISUB(k)) . more knowledge: k <> nil. insert clause in candidates: kl:= candidates; new kp (candidates); replace(kcfirst,candidates,kcfirstISUBk); replace(kcrest, candidates, kl). son: { If rules has n sons, then this refinement will return TRUE the first n times, it is called and FALSE forever after. IF son then curr frame has become a frame for the next son. So this refinement helps to construct the prooftree. } IF candidates = nil THEN FALSE ELSE create next son FI. create next son: initialize son; REP try to unify curr call with candidates UNTIL candidates exhausted PER; { not unified } forget son. initialize son: last ep:= ep; new (fp, res frame); fc(res frame).environment:= nil. try to unify curr call with candidates: k:= (kcfirstISUB(candidates)) ; IF unify (curr call, curr frame, TERM:(tcsymbolISUBk, tcargumentsISUBk, tcarityISUBk), res frame) THEN IF tracing THEN trace unification results FI; apply rule; fill result frame ELSE remove curr call from candidates FI. candidates exhausted: candidates = nil. forget son: fp DECR 1; FALSE. fill result frame: ts:= (kcfirstISUB(candidates)) ; fc(res frame):= FRAMECELL:(curr call, curr frame, tcrestISUBts, fc(res frame).environment, last ep, (kcrestISUB(candidates)) , cut level); curr frame:= res frame; LEAVE son WITH TRUE. remove curr call from candidates: candidates:= (kcrestISUB(candidates)) ; LEAVE try to unify curr call with candidates. apply rule: SELECT curr call.symbol OF CASE cons: {cons, to construct lists, see PROC unify} CASE cut: fc(res frame):= FRAMECELL:(curr call, curr frame, nil, fc(res frame).environment, last ep, nil, cut level); curr frame:= res frame; FOR ts FROM fp DOWNTO cut level REP fc(ts).rest:= nil PER; LEAVE son WITH TRUE CASE bye: IF curr call.arity = 0 THEN push (""13""); finish:= TRUE FI CASE list: IF curr call.arity = 0 COR curr call.arity = 1 THEN found:= TRUE; IF curr call.arity = 0 THEN pattern:= cut ELSE value (argfirst, t, curr frame); pattern:= t.symbol FI; write knowledgebase (knowledge base) FI CASE call: undo bindings (last ep); new tp (ts); replace(tcrest,ts, fc(curr frame).subgoals); fc(curr frame).subgoals:= ts; value (argfirst, t, curr frame); t.arguments:= revers (t.arguments); replace(tcsymbol,ts, t.symbol); replace(tcarguments,ts, t.arguments); replace(tcarity,ts, t.arity); LEAVE son WITH TRUE CASE xpar: {X parameter of call} CASE writ: IF curr call.arity = 1 THEN value (argfirst, t, curr frame); quoting:= FALSE; write term backward (t); write (" "); quoting:= TRUE FI CASE wriq: IF curr call.arity = 1 THEN value (argfirst, t, curr frame); write term backward (t); write (" ") FI CASE read: IF curr call.arity <> 1 THEN ELIF argfirst.arity = var THEN initiate read terms (ts, name (symboltable,argfirst.symbol)); read term (t); nc(fc(curr frame).environment).first.substitute:= t ELSE syntax error ("read parameter must be variable") FI CASE get0, get: IF curr call.arity <> 1 THEN ELIF argfirst.arity = var THEN getchar (command); WHILE curr call.symbol = get CAND code(command) < 32 REP getchar (command) PER; t.arity:= integer; t.arguments:= nil; t.symbol:= code (command); nc(fc(curr frame).environment).first.substitute:= t ELSE syntax error ("get parameter must be variable") FI CASE put0: value (argfirst, t, curr frame); IF curr call.arity = 1 CAND t.arity = integer THEN write (code (t.symbol)) FI CASE incr: IF curr call.arity = 1 THEN value(argfirst, t, curr frame); t.symbol INCR 1; IF t.arity = integer CAND argfirst.arity = var THEN k:= fc(curr frame).environment; nc(k).first.substitute:= t; ELSE syntax error ("integer variable expected") FI FI CASE ass: IF curr call.arity = 1 THEN value (argfirst,t,currframe); IF t.symbol = nil CAND t.arguments > nil THEN assertz (t.arguments); IF free of errors THEN reset tp:= tp; reset kp:= kp; reset symboltable:= symboltable FI ELSE syntax error ("parameter must be a list") FI FI CASE assa: IF curr call.arity = 1 THEN value (argfirst,t,currframe); IF t.symbol = nil CAND t.arguments > nil THEN asserta (t.arguments); IF free of errors THEN reset tp:= tp; reset kp:= kp; reset symboltable:= symboltable FI ELSE syntax error ("parameter must be a list") FI FI CASE retr: IF curr call.arity = 1 THEN value (argfirst,t,currframe); IF t.symbol = nil CAND t.arguments > nil THEN i:= rule count; retract (t.arguments); IF i <> rule count THEN remove curr call from candidates FI ELSE syntax error ("parameter must be a list") FI FI CASE vari: IF curr call.arity = 1 THEN value (argfirst, t, curr frame); IF t.arity <> var THEN remove curr call from candidates FI FI CASE is: IF curr call.arity = 2 THEN disable stop; t.symbol:= arith (TERM:(tcsymbolISUBargrest, tcargumentsISUBargrest, tcarityISUBargrest), curr frame); IF is error THEN put error; clear error FI; enable stop; t.arity := integer; t.arguments:= nil; IF unify (argfirst, curr frame, t, curr frame) THEN LEAVE apply rule FI FI; remove curr call from candidates CASE ypar: {Y parameter of is} CASE dif: IF curr call.arity = 2 CAND unify (argfirst, curr frame, TERM:(tcsymbolISUBargrest, tcargumentsISUBargrest, tcarityISUBargrest), curr frame) THEN remove curr call from candidates FI CASE leq: IF curr call.arity = 2 THEN get operands; IF t.arity = integer THEN IF t.symbol <= t2.symbol THEN LEAVE apply rule FI ELIF name (symboltable, t.symbol) <= name (symboltable, t2.symbol) THEN LEAVE apply rule FI FI; remove curr call from candidates CASE eq: IF curr call.arity = 2 THEN get operands; IF NOT ( t = t2 ) THEN remove curr call from candidates FI FI CASE univ: IF curr call.arity = 2 CAND np > fsc(fsp).last np THEN get operands; IF t2.arity = var CAND t.arity >= 0 THEN new tp (ts); replace (tcsymbol,ts,t.symbol); replace (tcarguments, ts, nil); replace (tcarity,ts,0); replace (tcrest,ts,revers(t.arguments)); nc(np).first.substitute.arguments:= ts; nc(np).first.substitute.symbol:= nil; nc(np).first.substitute.arity:= t.arity + 1 ELIF t.arity = var CAND t2.arity > 0 CAND t2.symbol <= cons THEN np DECR 1; t2. arguments:= revers(t2.arguments); nc(np).first.substitute.symbol:= tcsymbol ISUB t2.arguments; nc(np).first.substitute.arguments:= tcrest ISUB t2.arguments; nc(np).first.substitute.arity:= t2.arity - 1; np INCR 1 ELSE syntax error ("wrong parameter after =..") FI FI CASE clau: get operands; IF curr call.arity = 2 THEN IF t.arity < 0 THEN syntax error ("clause with wrong parameter") ELSE find clause; k:= tcrest ISUB (kcfirstISUBk); t3.symbol:= nil; t3.arguments:= k; t3.arity:= no of terms (k); IF NOT unify (t2, res frame, t3, curr frame) THEN remove curr call from candidates FI FI FI CASE claupar: { anonymous parameter of clause } CASE nam: IF curr call.arity = 2 THEN get operands; IF t.arity = var CAND t2.symbol = nil THEN command:= ""; k:= t2.arguments; REP command:= code (tcsymbolISUBk) + command; k:= tcrestISUBk UNTIL k <= nil PER; t.symbol:= link (symboltable, command); IF t.symbol = 0 THEN insert (symboltable, command, t.symbol); FI; t.arity:= 0; t.arguments:= nil; nc(fc(curr frame).environment).first.substitute:= t ELIF t2.arity = var CAND t.arity = 0 THEN command:= name (symboltable, t.symbol); ts:= nil; FOR k FROM 1 UPTO length(command) REP new tp (i); IF ts = nil THEN ts:= i ELSE replace (tcrest, j, i) FI; j:= i; replace (tcrest, i, nil); replace (tcarity, i, integer); replace (tcarguments, i, nil); replace (tcsymbol, i, code (command SUB k)) PER; t3.arity:= length(command); t3.arguments:= ts; t3.symbol:= nil; IF unify (t2, res frame, t3, curr frame) THEN FI ELSE syntax error ("name insufficient parameters") FI FI CASE argi: get operands; IF curr call.arity = 3 THEN k:= argrest; value (TERM:(tcsymbolISUB(tcrestISUB(k)), tcargumentsISUB(tcrestISUB(k)), tcarityISUB(tcrestISUB(k))), t3, curr frame); IF t.arity <> integer COR t2.arity <= 0 COR t.symbol <= 0 COR t.symbol > t2.arity THEN syntax error ("arg with wrong parameter") ELSE FOR k FROM t2.arity DOWNTO ( t.symbol + 1) REP IF t2.arguments <= nil THEN syntax error ("out of range"); LEAVE apply rule FI; t2.arguments:= tcrestISUB(t2.arguments) PER; IF t3.arity = var THEN nc(fc(curr frame).environment).first.substitute := TERM:(tcsymbolISUBt2.arguments, tcargumentsISUBt2.arguments, tcarityISUBt2.arguments) ELIF NOT unify (TERM:(tcsymbolISUBt2.arguments, tcargumentsISUBt2.arguments, tcarityISUBt2.arguments), curr frame, t3, curr frame) THEN remove curr call from candidates FI FI FI CASE zpar: {z parameter of arg} CASE func: IF curr call.arity = 3 THEN get operands; k:= argrest; value (TERM:(tcsymbolISUB(tcrestISUB(k)), tcargumentsISUB(tcrestISUB(k)), tcarityISUB(tcrestISUB(k))), t3, curr frame); IF t2.arity = var THEN IF t3.arity = var THEN t2.symbol:= argfirst.symbol; t2.arity := 0; nc(nc(fc(curr frame).environment).rest).first. substitute:= t2; k:= tcrestISUB(k); t3.symbol:= argfirst.arity; t3.arity := integer; nc(fc(curr frame).environment).first. substitute:= t3 ELIF t3.arity = integer CAND t.arity = t3.symbol THEN t.arity:= 0; t.arguments:= nil; nc(fc(curr frame).environment).first. substitute:= t ELSE remove curr call from candidates FI ELIF ( t.arity = var) CAND (t2.arity = 0) CAND (t3.arity = integer) THEN t2.arity:= t3.symbol; FOR k FROM 1 UPTO t3.symbol REP new tp (ts); replace (tcarity, ts, var); anonym value DECR 1; replace (tcsymbol, ts, anonym value); replace (tcarguments, ts, nil); replace (tcrest, ts, t2.arguments); t2.arguments:= ts PER; nc(fc(curr frame).environment).first. substitute:= t2 ELIF t2.arity <= 0 THEN IF t.symbol = t2.symbol THEN IF t.arity = t3.symbol CAND t3.arity = integer THEN ELIF t3.arity = var THEN t3.arity := integer; t3.symbol:= t.arity; nc(fc(curr frame).environment).first. substitute:= t3 ELSE remove curr call from candidates FI ELSE remove curr call from candidates FI ELSE syntax error ("wrong functor parameters") FI FI CASE elan: disable stop; lernsequenz auf taste legen ("q","break"13""); SELECT pos("consult,reconsult,sysout,sysin,forget,trace,line,abolish," ,name (symboltable, argfirst.symbol) + ",") OF CASE 01: consult (arg1) CASE 09: reconsult (arg1) CASE 19: sysout (arg1) CASE 26: sysin (arg1) CASE 32: forget (arg1, quiet) CASE 39: trace (arg1) CASE 45: line CASE 50: value (TERM:(tcsymbolISUBargrest, tcargumentsISUBargrest, tcarityISUBargrest), t, curr frame); abolish (t.symbol) OTHERWISE do (elan command) ENDSELECT; lernsequenz auf taste legen ("q","bye"13""); IF is error THEN put error; clear error FI; enable stop END SELECT. get operands: value (argfirst, t, curr frame); value (TERM:(tcsymbolISUBargrest, tcargumentsISUBargrest, tcarityISUBargrest), t2, curr frame). argfirst:TERM:(tcsymbolISUBcurr call.arguments, tcargumentsISUBcurr call.arguments, tcarityISUBcurr call.arguments). argrest: tcrestISUBcurr call.arguments. arg1: value (TERM:(tcsymbolISUBargrest, tcargumentsISUBargrest, tcarityISUBargrest), t, curr frame); name(symboltable, t.symbol). find clause: k:= knowledgebase; WHILE k <> nil REP ts:= kcfirstISUBk; IF TERM:(tcsymbolISUBts,tcargumentsISUBts,tcarityISUBts) = t THEN LEAVE find clause FI; k:= kcrestISUBk PER; remove curr call from candidates; LEAVE apply rule. elan command: command:= ""; ts:= curr call.arguments; WHILE ts <> nil REP value (TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts), t, curr frame); command CAT name (symboltable, t.symbol); found:= ts = curr call.arguments; ts:= tcrestISUB(ts); IF found THEN IF ts > nil THEN command CAT "(""" FI ELIF ts = nil THEN command CAT """)" ELSE command CAT """,""" FI PER; command. trace unification results: inference level INCR 1; write term (curr call); write ("="); value (TERM:(tcsymbolISUB(kcfirstISUB(candidates)) , tcargumentsISUB(kcfirstISUB(candidates)) , tcarityISUB(kcfirstISUB(candidates)) ), t, res frame); write term backward (t); IF testing THEN ts:= ep; IF ts > last ep THEN write (" with ") FI; list expressions FI; line. list expressions: WHILE ts > last ep REP k:= fc(ec(ts).index).environment; WHILE nc(k).first.variable.symbol <> ec(ts).term.symbol REP k:= nc(k).rest PER; write term (ec(ts).term); write ("="); write term (nc(k).first.substitute); write (" "); ts DECR 1 PER. ENDPROC prove; BOOL PROC unify (TERM CONST t1, FRAME CONST f1, TERM CONST t2, FRAME CONST f2): { Unifies the expressions and , If unification succeeds, both environments are updated. } {}{inference count INCR 1;} IF f1 = f2 CAND t1 = t2 THEN TRUE ELIF t1.arity = var THEN TERM VAR t; FRAME VAR f; IF bound (t1, f1, t, f) THEN unify (t, f, t2, f2) { ELIF occurs (t1, f1, t2, f2) THEN FALSE } ELSE bind expression 1; push expression 1; TRUE FI ELIF t2.arity = var THEN IF bound (t2, f2, t, f) THEN unify (t, f, t1, f1) { ELIF occurs (t2, f2, t1, f1) THEN FALSE } ELSE bind expression 2; push expression 2; TRUE FI ELIF t1.symbol = t2.symbol CAND t1.arity = t2.arity THEN constant or compound term ELIF t1.symbol = cons CAND t2.symbol = nil CAND t1.arity = 2 CAND t2.arguments > nil CAND unify (TERM:(tcsymbolISUBt1.arguments, tcargumentsISUBt1.arguments, tcarityISUBt1.arguments), f1, TERM:(tcsymbolISUBt2.arguments, tcargumentsISUBt2.arguments, tcarityISUBt2.arguments), f2) THEN construct list 1 ELIF t2.symbol = cons CAND t1.symbol = nil CAND t2.arity = 2 CAND t1.arguments > nil CAND unify (TERM:(tcsymbolISUBt2.arguments, tcargumentsISUBt2.arguments, tcarityISUBt2.arguments), f2, TERM:(tcsymbolISUBt1.arguments, tcargumentsISUBt1.arguments, tcarityISUBt1.arguments), f1) THEN construct list 2 ELSE FALSE FI. constant or compound term: { arguments of t1 and t2 are properly instantiated by the parser } EXPRESSIONS VAR last ep:= ep; TERMS VAR x:= t1.arguments, y:= t2.arguments; WHILE x <> nil REP IF unify (TERM:(tcsymbolISUBx, tcargumentsISUBx, tcarityISUBx), f1, TERM:(tcsymbolISUBy, tcargumentsISUBy, tcarityISUBy), f2) THEN x:= tcrestISUB(x); y:= tcrestISUB(y) ELSE undo bindings (last ep); LEAVE unify WITH FALSE FI PER; TRUE. construct list 1: last ep:= ep; IF t2.symbol = cons THEN TERM VAR tail:= TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)), tcargumentsISUB(tcrestISUB(t2.arguments)), tcarityISUB(tcrestISUB(t2.arguments))); ELSE tail:= TERM: (nil, (tcrestISUB(t2.arguments)) , no of terms (t2.arguments) - 1); FI; IF bound (TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)) , tcargumentsISUB(tcrestISUB(t1.arguments)) , tcarityISUB(tcrestISUB(t1.arguments)) ), f1, t, f) THEN IF unify (t, f, tail, f2) THEN TRUE ELSE undo bindings (last ep); FALSE FI ELSE bind tail 1; push tail 1; TRUE FI. construct list 2: last ep:= ep; IF t1.symbol = cons THEN tail:= TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)) , tcargumentsISUB(tcrestISUB(t1.arguments)) , tcarityISUB(tcrestISUB(t1.arguments)) ); ELSE tail:= TERM: (nil, tcrestISUB(t1.arguments), no of terms (t1.arguments) - 1); FI; IF bound (TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)) , tcargumentsISUB(tcrestISUB(t2.arguments)) , tcarityISUB(tcrestISUB(t2.arguments)) ), f2, t, f) THEN IF unify (t, f, tail, f1) THEN TRUE ELSE undo bindings (last ep); FALSE FI ELSE bind tail 2; push tail 2; TRUE FI. bind expression 1: { bind the expression to in the environment } new environment n; nc(n).first:= SUBSTITUTION:(t1, t2, f2); nc(n).rest :=fc(f1).environment; fc(f1).environment:= n. bind expression 2: new environment n; nc(n).first:= SUBSTITUTION:(t2, t1, f1); nc(n).rest :=fc(f2).environment; fc(f2).environment:= n. bind tail 1: new environment n; nc(n).first:= SUBSTITUTION:( TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)), tcargumentsISUB(tcrestISUB(t1.arguments)) , tcarityISUB(tcrestISUB(t1.arguments)) ), tail, f2); nc(n).rest :=fc(f1).environment; fc(f1).environment:= n. bind tail 2: new environment n; nc(n).first:= SUBSTITUTION:( TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)) , tcargumentsISUB(tcrestISUB(t2.arguments)) , tcarityISUB(tcrestISUB(t2.arguments)) ), tail, f1); nc(n).rest :=fc(f2).environment; fc(f2).environment:= n. push expression 1: ep INCR 1; ec(ep):= EXPRESSION:(t1, f1). push expression 2: ep INCR 1; ec(ep):= EXPRESSION:(t2, f2). push tail 1: ep INCR 1; ec(ep):= EXPRESSION:(TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)) , tcargumentsISUB(tcrestISUB(t1.arguments)) , tcarityISUB(tcrestISUB(t1.arguments)) ), f1). push tail 2: ep INCR 1; ec(ep):= EXPRESSION:(TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)) , tcargumentsISUB(tcrestISUB(t2.arguments)) , tcarityISUB(tcrestISUB(t2.arguments)) ), f2). new environment n: ENVIRONMENT VAR n; IF np = limit THEN pegeloverflow ELSE np INCR 1; n:= np FI ENDPROC unify; BOOL OP = (TERM CONST t1, t2): { INLINE; } { Two terms are equal iff their printed representations are indistinguishable. Don't confuse with equal expressions. } IF ( t1.symbol = t2.symbol ) CAND ( t1.arity = t2.arity ) THEN IF t1.arguments = 0 THEN terms are variables or constants ELSE terms are compound FI ELSE FALSE FI. terms are variables or constants: TRUE. terms are compound: TERMS VAR x:= t1.arguments, y:= t2.arguments; WHILE x <> nil REP IF recursive equal (TERM:(tcsymbolISUBx, tcargumentsISUBx, tcarityISUBx), TERM:(tcsymbolISUBy, tcargumentsISUBy, tcarityISUBy)) THEN x:= tcrestISUB(x); y:= tcrestISUB(y) ELSE LEAVE = WITH FALSE FI PER; TRUE. ENDOP =; BOOL PROC recursive equal (TERM CONST t1, t2): t1=t2 ENDPROC recursive equal; PROC undo bindings (EXPRESSIONS CONST last ep): { Remove the binding for each of the expressions } WHILE ep > last ep REP remove matching substitutions; remove expression PER. remove matching substitutions: { with variable equal to term t from environment env } TERM VAR t:= ec(ep).term; ENVIRONMENT VAR n:= env, last:= nil; WHILE n <> nil REP IF nc(n).first.variable.symbol = t.symbol THEN forget n ELSE last:= n FI; n:= nc(n).rest PER. forget n: IF last = nil THEN env := nc(n).rest ELSE nc(last).rest:= nc(n).rest FI; IF n = np THEN np DECR 1 FI. env: fc(ec(ep).index).environment. remove expression: { Removes the first expression from e recovering the space used } ep DECR 1. END PROC undo bindings; PROC consult (TEXT CONST knowledge): { asserts the clauses from the file into knowledge base } {} enable stop; IF NOT exists (knowledge) THEN syntax error ("consulting file not existing"); LEAVE consult FI; last param (knowledge); TERMS VAR clauses; BOOL VAR single:= TRUE; rule count:= 0; initiate read terms (knowledge, clauses); WHILE look ahead <> end of input REP rule count INCR 1; cout (rule count); read clause; assertz (clauses); clauses:= nil PER; remove token; IF anything noted THEN modify (file); note edit (file) FI; IF free of errors THEN reset tp:= tp; reset kp:= kp; reset symboltable:= symboltable; put (rule count) ELSE put (0); from file:= FALSE FI; putline ("rules inserted."); line . read clause: TERM VAR term; IF single THEN read term (term); IF term.arity = var THEN syntax error ("clause starts with variable") ELIF name (symboltable, term.symbol) = ":-" THEN read terms (clauses); call terms (clauses); LEAVE consult FI; IF look ahead = colon THEN remove token; read terms (clauses) FI ELIF look ahead = semicolon THEN remove token; read terms (clauses) FI; IF look ahead = semicolon THEN single:= FALSE ELIF look ahead = period THEN single:= TRUE; remove token ELSE syntax error ("period or semicolon expected") FI; insert term in clauses. insert term in clauses: TERMS VAR tmp; new tp (tmp); replace(tcsymbol,tmp,term.symbol); replace(tcarguments,tmp,term.arguments); replace(tcarity,tmp,term.arity); replace(tcrest,tmp, clauses); clauses:= tmp. remove token: look ahead empty:= TRUE. END PROC consult; PROC reconsult (TEXT CONST knowledge): { asserts the clauses from the file into knowledge base } {} enable stop; IF NOT exists (knowledge) THEN syntax error ("reconsulting file not existing"); LEAVE reconsult FI; last param (knowledge); TERMS VAR clauses; BOOL VAR single:= TRUE; rule count:= 0; initiate read terms (knowledge, clauses); WHILE look ahead <> end of input REP rule count INCR 1; cout (rule count); read clause; abolish (tcsymbol ISUB clauses); clauses:= nil PER; remove token; consult (knowledge). read clause: TERM VAR term; IF single THEN read term (term); IF term.arity = var THEN syntax error ("clause starts with variable") ELIF name (symboltable, term.symbol) = ":-" THEN read terms (clauses); call terms (clauses); LEAVE reconsult FI; IF look ahead = colon THEN remove token; read terms (clauses) FI ELIF look ahead = semicolon THEN remove token; read terms (clauses) FI; IF look ahead = semicolon THEN single:= FALSE ELIF look ahead = period THEN single:= TRUE; remove token ELSE syntax error ("period or semicolon expected") FI; insert term in clauses. insert term in clauses: TERMS VAR tmp; new tp (tmp); replace(tcsymbol,tmp,term.symbol); replace(tcarguments,tmp,term.arguments); replace(tcarity,tmp,term.arity); replace(tcrest,tmp, clauses); clauses:= tmp. remove token: look ahead empty:= TRUE. END PROC reconsult; PROC assertz (TERMS CONST clause): { Inserts the clause into the knowledge base before the first clause beginning with the same functor. Clauses beginning with the same functor are assumed to be listed consecutively. } CLAUSES VAR c1, c2, c3; IF free of errors THEN IF freep > nil THEN c3:= freec(freep); freep DECR 1; IF reset freep > freep THEN reset freep:= freep FI ELSE new kp (c3) FI; replace(kcfirst,c3, clause); IF knowledge base = nil COR (tcsymbolISUB((kcfirstISUB(knowledgebase)) )) = (tcsymbolISUB(clause)) THEN insert on top ELSE c1:= knowledge base; REP find and insert clause PER FI FI. find and insert clause: c2:= (kcrestISUB(c1)) ; IF c2 = nil THEN insert on top ELIF (tcsymbolISUB((kcfirstISUB(c2)) )) = (tcsymbolISUB(clause)) THEN insert before FI; c1:= c2. insert on top: replace(kcrest,c3, knowledge base); knowledge base:= c3; LEAVE assertz. insert before: replace(kcrest,c3, c2); replace(kcrest,c1, c3); LEAVE assertz. ENDPROC assertz; PROC asserta (TERMS CONST clause): { Inserts the clause into the knowledge base after the last clause beginning with the same functor. Clauses beginning with the same functor are assumed to be listed consecutively. } CLAUSES VAR c1, c2, c3; IF free of errors THEN IF freep > nil THEN c3:= freec(freep); freep DECR 1; IF reset freep > freep THEN reset freep:= freep FI ELSE new kp (c3) FI; replace(kcfirst,c3, clause); IF knowledge base = nil THEN replace(kcrest,c3, knowledge base); knowledge base:= c3 ELSE c1:= knowledge base; REP find and insert clause PER FI FI. find and insert clause: c2:= (kcrestISUB(c1)) ; IF c2 = nil THEN append after c1 ELIF (tcsymbolISUB((kcfirstISUB(c2)) )) = (tcsymbolISUB(clause)) THEN insert behind FI; c1:= c2. append after c1: replace(kcrest,c1, clause); LEAVE asserta. insert behind: REP c1:= c2; c2:= (kcrestISUB(c1)) ; UNTIL (tcsymbolISUB((kcfirstISUB(c2)) )) <> (tcsymbolISUB(clause)) PER; replace(kcrest,c3, c2); replace(kcrest,c1, c3); LEAVE asserta. ENDPROC asserta; PROC retract (TERMS CONST clause): { Retracts the clause from the knowledge base. } CLAUSES VAR c1:= knowledge base, c2; IF free of errors THEN IF c1 = nil THEN rule count DECR 1 ELIF c1 > build ins CAND terms eq ((kcfirstISUB(c1)) , clause) THEN retract top ELSE REP find and retract clause PER FI FI. find and retract clause: c2:= (kcrestISUB(c1)) ; IF c2 = nil THEN rule count DECR 1; LEAVE retract ELIF c2 > build ins CAND terms eq ((kcfirstISUB(c2)) , clause) THEN retract c2 FI; c1:= c2. retract top: freep INCR 1; reset freep:= freep; freec(freep):= knowledge base; knowledge base:= (kcrestISUB(knowledge base)) ; LEAVE retract. retract c2: replace(kcrest,c1, (kcrestISUB(c2)) ); freep INCR 1; reset freep:= freep; freec(freep):= c2; LEAVE retract. ENDPROC retract; PROC abolish (SYMBOL CONST clause): { Retracts all the clauses with this name from the knowledge base. } {} enable stop; CLAUSES VAR c1:= knowledge base, c2; IF free of errors THEN REP IF c1 = nil THEN rule count DECR 1; LEAVE abolish ELIF c1 = knowledgebase CAND c1 > build ins CAND (tcsymbol ISUB(kcfirstISUBc1)) = clause THEN retract top; c1:= knowledgebase ELSE find and retract clause FI PER FI. find and retract clause: c2:= kcrestISUBc1 ; IF c2 = nil THEN rule count DECR 1; LEAVE abolish ELIF c2 > build ins CAND (tcsymbol ISUB(kcfirstISUBc2)) = clause THEN retract c2 ELSE c1:= c2 FI. retract top: freep INCR 1; reset freep:= freep; freec(freep):= knowledge base; knowledge base:= (kcrestISUB(knowledge base)). retract c2: replace(kcrest,c1, (kcrestISUB(c2)) ); freep INCR 1; reset freep:= freep; freec(freep):= c2. ENDPROC abolish; BOOL PROC terms eq (TERMS CONST a, b): IF a = b THEN TRUE ELIF a = 0 COR b = 0 THEN FALSE ELIF TERM:(tcsymbolISUBa, tcargumentsISUBa, tcarityISUBa) = TERM:(tcsymbolISUBb, tcargumentsISUBb, tcarityISUBb) THEN terms eq ((tcrestISUB(a)) , (tcrestISUB(b)) ) ELSE FALSE FI ENDPROC terms eq; PROC value (TERM CONST t, TERM VAR r, FRAME CONST f): { sets r to the value of t in f^.environment } {} enable stop; IF t.arguments = 0 THEN IF t.arity = var THEN variable term ELSE constant term FI ELSE compound term FI. constant term: r:= t. variable term: TERM VAR t1, t2; FRAME VAR f1; IF bound (t, f, t1, f1) THEN value (t1, r, f1) ELSE r:= t FI. compound term: INT VAR step:= 3; TERMS VAR ts:= t.arguments; r.arguments:= nil; WHILE ts <> nil REP value (TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts), t1, f); IF stepping CAND step = 1 CAND t.symbol = cons CAND t1.symbol = nil THEN step:= 0; value (t1, t2, f); ts:= t2.arguments ELSE ts:= tcrestISUB(ts); push term in arguments FI; PER; IF step = 0 THEN r.symbol:= nil ELSE r.symbol:= t.symbol FI; r.arity:= no of terms (r.arguments). stepping: IF step > 1 THEN step DECR 1; TRUE ELSE FALSE FI. push term in arguments: TERMS VAR term; new tp (term); replace(tcsymbol,term, t1.symbol); replace(tcarguments,term, t1.arguments); replace(tcarity,term, t1.arity); replace(tcrest,term, r.arguments); r.arguments:= term. ENDPROC value; BOOL PROC bound (TERM CONST t1, FRAME CONST f1, TERM VAR t2, FRAME VAR f2): { returns TRUE iff the expression is bound and assigns the expression to which it is bound. } ENVIRONMENT VAR n:= fc(f1).environment; SUBSTITUTION VAR sub; WHILE n <> nil REP sub:= nc(n).first; IF t1.symbol = sub.variable.symbol THEN t2:= sub.substitute; f2:= sub.others; LEAVE bound WITH TRUE ELSE n:= nc(n).rest FI PER; FALSE ENDPROC bound; PROC append term (TERM CONST appendix, TERMS VAR list): TERMS VAR term, last term; IF list = nil THEN new tp (term); list:= term ELSE term:= list; REP last term:= term; term:= tcrestISUB(term) UNTILterm = nil PER; new tp (term); replace(tcrest,last term, term); FI; replace(tcsymbol,term,appendix.symbol); replace(tcarguments,term,appendix.arguments); replace(tcarity,term,appendix.arity); replace(tcrest,term, nil) END PROC append term; TERMS PROC revers (TERMS CONST ts): IF ts <= nil THEN ts ELSE TERMS VAR reverted:= revers ((tcrestISUB(ts)) ); append term (TERM:(tcsymbolISUBts, revers (tcargumentsISUBts), tcarityISUBts), reverted); reverted FI ENDPROC revers; PROC call terms (TERMS VAR ts): TEXT VAR old:= sysout; forget ("$sysin$",quiet); sysout ("$sysin$"); WHILE ts > nil REP write term (TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts)); line; ts:= tcrestISUB(ts) PER; write ("elan(sysin,())."); sysout (old); sysin ("$sysin$") ENDPROC call terms; PROC write environment list (FRAME CONST frame): write environment list (frame, fc(frame).environment); ENDPROC write environment list; PROC write environment list (FRAME CONST frame, ENVIRONMENT CONST en): IF en <> nil THEN write environment list (frame, nc(en).rest); write term (nc(en).first.variable); write (" = "); value (nc(en).first.variable, t, frame); write term backward (t); IF en <> fc(frame).environment THEN write (", ") FI FI ENDPROC write environment list; PROC write knowledge base (CLAUSES CONST k): TERMS VAR t:= (kcfirstISUB(k)) ; IF t > nil CAND k <= reset kp CAND k > build ins CAND (pattern = cut COR pattern = (tcsymbolISUB(t)) ) THEN found:= FALSE; IF (kcrestISUB(k)) > nil THEN write knowledge base ((kcrestISUB(k)) ) FI; write term (TERM:(tcsymbolISUBt, tcargumentsISUBt, tcarityISUBt)); t:= (tcrestISUB(t)) ; IF t > nil THEN write (":- "); write terms FI; write ("."); line ELIF (found COR k <= build ins) CAND (kcrestISUB(k)) > nil THEN write knowledge base ((kcrestISUB(k)) ) FI. write terms: BOOL VAR once:= FALSE; WHILE t <> nil REP IF once THEN write (", ") ELSE once:= TRUE FI; write term (TERM:(tcsymbolISUBt, tcargumentsISUBt, tcarityISUBt)); t:= (tcrestISUB(t)) ; PER. ENDPROC write knowledge base; PROC write symbol (TERM CONST t): TEXT VAR w1, w2:= name (symboltable, t.symbol); IF quoting THEN scan (w2); next symbol (w1, i); INT VAR i; IF w1 = w2 CAND i <> num THEN write (w2) ELSE write (""""); write (w2); write ("""") FI ELSE write (w2) FI ENDPROC write symbol; PROC write term backward (TERM CONST t): IF t.arity = integer THEN write (text (t.symbol)) ELIF t.symbol <= cons THEN IF t.symbol < 0 THEN write ("_"+text(-t.symbol)) ELSE write ("["); write subterms backward (t, t.arguments); write ("]") FI ELSE write symbol (t); IF t.arguments <> nil THEN compound term FI FI. compound term: write ("("); write subterms backward (t, t.arguments); write (")"). ENDPROC write term backward; PROC write subterms backward (TERM CONST t, TERMS CONST ts): IF ts = nil THEN ELSE write subterms backward (t, (tcrestISUB(ts)) ); write term backward ( TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts)); IF ts <> t.arguments THEN IF t.symbol = cons THEN write ("|") ELSE write (",") FI FI FI ENDPROC write subterms backward; PROC write term (TERM CONST t): IF t.arity = integer THEN write (text (t.symbol)) ELIF t.symbol <= cons THEN IF t.symbol < 0 THEN write ("_"+text(-t.symbol)) ELSE write ("["); write terms; write ("]") FI ELSE write symbol (t); IF t.arguments <> nil THEN compound term FI FI. compound term: write ("("); write terms; write (")"). write terms: TERMS VAR ts:= t.arguments; WHILE ts <> nil REP write term ( TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts)); ts:= tcrestISUB(ts); IF ts <> nil THEN IF t.symbol = cons THEN write ("|") ELSE write (",") FI FI PER. ENDPROC write term; PROC read consult list: TERM VAR t; TERMS CONST old tp:= tp; WHILE filename read REP PER; IF look ahead <> close bracket THEN syntax error ("closing bracket expected") FI; remove token; reset symboltable:= symboltable; TERMS CONST ts:= tp; tp:= old tp; consult list (ts); from file:= FALSE. filename read: BOOL VAR was minus:= FALSE; IF look ahead = minus THEN remove token; was minus:= TRUE FI; IF look ahead = identifier THEN new tp (tp); read term (t); replace(tcsymbol,tp, t.symbol); replace(tcarguments,tp, t.arguments); replace(tcarity,tp, t.arity); IF was minus THEN replace(tcarity,tp, var); FI; IF NOT exists (name (symboltable, (tcsymbolISUB(tp)) )) THEN syntax error ("file does not exist"); FALSE ELIF look ahead = comma THEN remove token; TRUE ELSE TRUE FI ELSE FALSE FI . remove token: look ahead empty:= TRUE. ENDPROC read consult list; PROC consult list (TERMS CONST ts): IF ts > tp THEN TERM VAR term:= TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts); consult list (ts-1); IF free of errors THEN TEXT VAR fname:= name (symboltable, term.symbol); IF term.arity = var THEN put ("reconsulting"); putline (fname); reconsult (fname) ELSE put ( "consulting"); putline (fname); consult (fname) FI FI FI ENDPROC consult list; PROC initiate read terms (TERMS VAR ts, TEXT CONST prompter): enable stop; look ahead empty:= TRUE; ahead empty:= TRUE; from file:= FALSE; TEXT VAR inputline; IF prompter = "-" THEN inputline:= "" ELSE inputline:= ""13"" FI; REP WHILE sysin = "" CAND is escape REP write (""13""15"gib kommando: "); get command; IF inputline = "" THEN write (""14""3""3"") ELSE write (""14""13""10""); IF prompter = "-" THEN lernsequenz auf taste legen ("k", inputline); FI; disable stop; lernsequenz auf taste legen ("q","break"13""); do (inputline); lernsequenz auf taste legen ("q","bye"13""); IF is error THEN put (errormessage); clear error FI; enable stop; FI; write (""13""10""5"?"); write (prompter); write (" ") PER; getline (inputline); IF inputline <> "" CAND (inputline SUB length (inputline)) <> "." THEN inputline CAT "." FI; scan (inputline); ts:= nil UNTIL inputline <> "" PER; IF prompter = "-" THEN lernsequenz auf taste legen ("k", inputline) FI. is escape: REP IF inputline = ""13"" THEN write (""13""10""5"?"); write (prompter); write (" ") ELIF inputline = "?" THEN putline ("?"); inform; push (""13"") FI; getchar (inputline) UNTIL pos ("?"13"", inputline) = 0 PER; IF inputline = ""27"" THEN getchar (inputline); IF inputline = ""27"" THEN TRUE ELSE push (inputline); push (""27""); FALSE FI ELSE push (inputline); FALSE FI. get command: getchar (inputline); IF inputline = ""27"" THEN getchar (inputline); IF inputline = ""27"" THEN inputline:= ""; line ELSE push (inputline); push (""27""); getline (inputline) FI ELSE push (inputline); getline (inputline) FI. ENDPROC initiate read terms; PROC initiate read terms (TEXT CONST knowledge, TERMS VAR ts): look ahead empty:= TRUE; ahead empty:= TRUE; file:= sequential file (input, knowledge); from file:= TRUE; scan (file); ts:= nil ENDPROC initiate read terms; PROC read terms (TERMS VAR ts): { the actual parameter for ts should be initiated < ts:=nil > at top level of recursion } TERM VAR t; WHILE look ahead <> close paren CAND look ahead <> close bracket CAND look ahead <> period REP read term (t); append term (t, ts) UNTIL end of list PER. end of list: IF look ahead = comma THEN remove comma; FALSE ELSE TRUE FI. remove comma: look ahead empty:= TRUE. ENDPROC read terms; PROC read term (TERM VAR t): IF look ahead = open paren THEN remove token; read term (t); transform infix to prefix (t, 0); IF look ahead = close paren THEN remove token ELSE syntax error ("closing parentheses missing") FI ELSE read prefix term (t); transform infix to prefix (t, 0) FI . remove token: look ahead empty:= TRUE . ENDPROC read term; PROC transform infix to prefix (TERM VAR t, INT CONST last prio): SELECT look ahead OF CASE minus, plus, times, slash, less, equal, uneq, grt, eqeq, eqdotdot, boldvar: operator:= look ahead value; IF last prio <= priority (operator) THEN remove token; IF look ahead = open paren THEN read term (t2); ELSE read prefix term (t2); FI; IF last prio < priority (operator) THEN transform infix to prefix (t2, priority (operator)); FI; form result; transform infix to prefix (t, last prio) FI ENDSELECT. form result: second operand; first operand; prefix. second operand: TERMS VAR p2; TERM VAR t2; new tp (p2); replace(tcsymbol, p2, t2.symbol); replace(tcarguments, p2, t2.arguments); replace(tcarity, p2, t2.arity); replace(tcrest, p2, nil). first operand: TERMS VAR p1; new tp (p1); replace(tcsymbol, p1, t.symbol); replace(tcarguments, p1, t.arguments); replace(tcarity, p1, t.arity); replace(tcrest, p1, p2). prefix: INT VAR operator; t.symbol:= operator; t.arguments:= p1; t.arity:= 2. remove token: look ahead empty:= TRUE. ENDPROC transform infix to prefix; INT PROC priority (INT CONST operator): SELECT operator OF CASE times, slash, mod: 7 CASE minus, plus: 6 CASE 9,10,11,12,13: 5 OTHERWISE 2 ENDSELECT ENDPROC priority; PROC read prefix term (TERM VAR t): SELECT look ahead OF CASE exclamation: term is cut CASE bold var: term is a variable CASE underscore: term is anonym CASE number: term is number CASE identifier, minus, plus, times, slash, less, equal, uneq, grt, eqeq, eqdotdot: IF look ahead = minus THEN remove token; IF look ahead = number {monadic minus} THEN look ahead value:= - look ahead value; term is number; LEAVE read prefix term FI ELSE remove token FI; term is identifier; IF look ahead = open paren THEN term is compound { ELSE term is a constant } FI CASE open bracket: term is list CASE colon: term is colon OTHERWISE syntax error ("wrong expression"); t:= TERM:(nil, nil, 0) ENDSELECT. term is cut: remove token; t:= TERM:(cut, nil, 0). term is a variable: remove token; t:= TERM:(look ahead value, nil, var). term is anonym: remove token; anonym value DECR 1; t:= TERM:(anonym value, nil, var). term is number: remove token; t:= TERM:(look ahead value, nil, integer). term is identifier: t:= TERM:(look ahead value, nil, 0). term is list: remove token; t:= TERM:(nil, nil, 0); IF look ahead = close bracket THEN remove token ELSE non empty list FI. non empty list: TERM VAR t1; read term (t1); append term (t1, t.arguments); IF look ahead = close bracket THEN remove token; t.arity:= 1 ELSE list with more than one element FI. list with more than one element: IF look ahead = stroke THEN t.symbol:= cons ELIF look ahead <> comma CAND look ahead <> colon THEN syntax error ("comma missing") FI; term is compound list. term is compound list: remove token; read terms (t.arguments); t.arity:= no of terms (t.arguments); IF look ahead = close bracket THEN remove token ELSE syntax error ("closing bracket missing") FI. term is compound: remove token; read terms (t.arguments); t.arity:= no of terms (t.arguments); IF look ahead = close paren THEN remove token ELSE syntax error ("closing parentheses missing") FI. term is colon: remove token; INT VAR i:= link (symboltable, ":-"); IF i = 0 THEN insert (symboltable, ":-", i) FI; t:= TERM:(i, nil, 0). remove token: look ahead empty:= TRUE. ENDPROC read prefix term; INT PROC no of terms (TERMS CONST ts): INT VAR i:= 0, t:=ts; WHILE t <> nil REP t:= (tcrestISUB(t)) ; i INCR 1 PER; i ENDPROC no of terms; INT PROC arith (TERM CONST term, FRAME CONST curr frame): TERM VAR t; IF term.arity = var THEN value (term, t, curr frame) ELSE t:= term FI; IF t.arity = integer THEN t.symbol ELIF t.arity = var THEN syntax error ("free variable in arith expression"); 0 ELIF t.arity = 1 THEN SELECT t.symbol OF CASE plus: arith (t1, curr frame) CASE minus: - arith (t1, curr frame) OTHERWISE syntax error ("unknown arith operator"); 0 ENDSELECT ELIF t.arity = 2 THEN SELECT t.symbol OF CASE plus: arith (t1, curr frame) + arith (t2, curr frame) CASE minus: arith (t1, curr frame) - arith (t2, curr frame) CASE times: arith (t1, curr frame) * arith (t2, curr frame) CASE slash: arith (t1, curr frame) DIV arith (t2, curr frame) CASE mod: arith (t1, curr frame) MOD arith (t2, curr frame) OTHERWISE syntax error ("unknown arith operator"); 0 ENDSELECT ELSE syntax error ("wrong arith expression"); 0 FI. t1: TERM:(tcsymbolISUBt.arguments, tcargumentsISUBt.arguments, tcarityISUBt.arguments) . t2: TERM:(tcsymbolISUB(tcrestISUB(t.arguments)) , tcargumentsISUB(tcrestISUB(t.arguments)) , tcarityISUB(tcrestISUB(t.arguments)) ) . ENDPROC arith; TOKEN PROC look ahead : { Returns the token in the look ahead. If the look ahead is empty it calls the scanner to get the next symbol, which is then placed into the look ahead. } SYMBOLTYPE VAR symboltype; IF look ahead empty THEN look ahead empty:= FALSE; get next symbol; store the symbol FI; look ahead token. get next symbol: IF ahead empty THEN IF from file THEN next symbol (file, look ahead symbol, symboltype) ELSE next symbol (look ahead symbol, symboltype) FI ELSE ahead empty:= TRUE; look ahead symbol:= ahead symbol; symboltype:= ahead symboltype FI. store the symbol: SELECT symboltype OF CASE tag,tex: look ahead token:= identifier; IF look ahead symbol = "" THEN look ahead value:= 0; ELSE install FI CASE num: look ahead token:= number; look ahead value:= int(look ahead symbol) CASE bold: look ahead token:= bold var; install CASE operator: look ahead token:= pos ("|!:-+*/_<=<>==..", look ahead symbol); IF look ahead token = equal THEN get next symbol; IF symboltype = operator CAND look ahead symbol = "=" THEN look ahead token:= eqeq; look ahead symbol:= "==" ELIF look ahead symbol = "." THEN get next symbol; IF look ahead symbol = "." THEN look ahead token:= eqdotdot; look ahead symbol:= "=.." ELSE syntax error ("second period missing") FI ELSE ahead symbol:= look ahead symbol; ahead symboltype:= symboltype; ahead empty:= FALSE; look ahead symbol:= "="; look ahead token := equal FI FI; IF look ahead token > 3 THEN install FI CASE delimiter: look ahead token:= pos ("|!:-+*/_<=<>==..,;()[]", look ahead symbol); SELECT look ahead token OF CASE colon: minus must follow CASE 0: syntax error ("wrong delimiter") ENDSELECT CASE endoffile: look ahead token:= end of input CASE within com: look ahead token:= end of input; syntax error ("within comment") CASE within tex: look ahead token:= end of input; syntax error ("within text") ENDSELECT. minus must follow: get next symbol; IF look ahead symbol <> "-" THEN syntax error ("minus after colon expected") FI. install: look ahead value:= link (symboltable, look ahead symbol); IF look ahead value = 0 THEN insert(symboltable,look ahead symbol,look ahead value) FI. ENDPROC look ahead; PROC inform: enable stop; put (" "); put (clock(0) - start time); put ("SEC"); IF inference count > 0 CAND clock(0) > start time THEN put (inference count); put ("inferences"); put (int (real (inference count) / (clock(0) - start time))); put ("LIPS") FI; FOR k FROM 2 UPTO fsp REP line; FRAME CONST f:= fsc(k).frame; INT CONST ind:= fc(f).level; IF ind <= 40 THEN write (ind*" ") ELSE write (text(ind) + ": ") FI; value (fc(f).call, t, fc(f).father); write term backward (t) PER; IF testing THEN put(tp); put(kp); put(fp); put(fsp); put(np); put(ep) FI; line ENDPROC inform; PROC syntax error (TEXT CONST message): free of errors:= FALSE; write ("!- "); write note (message); write note (" at '"); write note (look ahead symbol); write note ("' "); IF from file THEN write note ("in rule "); write note (rule count); write note ("line "); write note (lineno(file) - 1) FI; look ahead empty:= TRUE; line; note line ENDPROC syntax error; PROC write note (TEXT CONST t): write (t); IF from file THEN note (t) FI ENDPROC write note; PROC write note (INT CONST i): put (i); IF from file THEN note (i) FI ENDPROC write note; PROC trace (TEXT CONST on): testing:= test on; tracing:= trace on. trace on: pos (on, "on") > 0. test on : pos (on, "test") > 0 ENDPROC trace; PROC new kp (INT VAR pointer): kp INCR 1; pointer:= kp; IF length (kcfirst) < 2*kp THEN IF kp > 15990 THEN pegel overflow ELSE kcfirst CAT "1234567890123456"; kcrest CAT "1234567890123456"; FI FI ENDPROC new kp; PROC new tp (INT VAR pointer): tp INCR 1; pointer:= tp; IF length (tcsymbol) < 2*tp THEN IF tp = 15990 THEN pegel overflow ELSE tcsymbol CAT "1234567890123456"; tcarguments CAT "1234567890123456"; tcarity CAT "1234567890123456"; tcrest CAT "1234567890123456" FI FI ENDPROC new tp; PROC new (INT VAR pegel, pointer): IF pegel = limit THEN pegel overflow ELSE pegel INCR 1; pointer:= pegel FI ENDPROC new; PROC pegeloverflow: line; write (" "); put(tp); put(kp); put(fp); put(fsp); put(np); put(ep); errorstop ("pegeloverflow") ENDPROC pegeloverflow; { Programmtransformation: PASCAL mit Pointer ==> ELAN 1. Rekursive Datentypen: type t = ^tcell; ==> LET T = INT; { schwache Datenabstraktion mit LET ist besser, weil keine neuen Zugriffsprozeduren erforderlich. GLOBAL: } LET nil = 0, limit <= 500; ROW limit TCELL VAR tc; { t cell } INT VAR tp:= nil; { t pegel } 2. Deklaration: var x : t; ==> T VAR x; { Type checking selber machen ! } 3. Pointer-Initialisierung: x:= nil; ==> x:= nil; 4. Allokation: new (x); ==> new (tp,x); dispose (x); ==> kommt nicht vor 5. Applikation: x^.feld ==> TERMSCELL:(TERM:(tcsymbolISUBx, tcargumentsISUBx, tcarityISUBx), tcrestISUBx).feld WITH ==> Refinement verwenden { Programmtransformation ROW limit TERMSCELL VAR tc => TEXT VAR } T1; "new (tp, " CA "new tp ("; T1; REP col(1); D "tc("; IF at ("tc(tc(") THEN D "tc("; attest; col(1); D "tc(" FI; attest UNTIL eof PER . attest: IF at ("tc("+any**1+").first."+any**2+":="+any**3+";"+any**4) THEN C ("replace(tc"+match(2)+","+match(1)+","+match(3)+");"+match(4)) ELIF at ("tc("+any**1+").rest:="+any**3+";"+any**4) THEN C ("replace(tcrest,"+match(1)+","+match(3)+");"+match(4)) ELIF at ("tc("+any**1+").first:="+any**3+";"+any**4) THEN C ("replace(tcsymbol,"+match(1)+","+match(3)+ ".symbol); replace(tcarguments,"+match(1)+","+match(3)+ ".arguments); replace(tcarity,"+match(1)+","+match(3)+ ".arity);"+match(4)) ELIF at ("tc("+any**1+").first."+any**2+" "+any**4) THEN C ("(tc"+match(2)+"ISUB("+match(1)+")) "+match(4)) ELIF at ("tc("+any**1+").rest"+any**4) THEN C ("(tcrestISUB("+match(1)+")) "+match(4)) ELIF at ("tc("+any**1+").first).first"+any**4) THEN C ("TERM:(tcsymbolISUB"+match(1)+ ").first, tcargumentsISUB"+match(1)+ ").first, tcarityISUB"+match(1)+").first)"+match(4)) ELIF at ("tc("+any**1+").first"+any**4) THEN C ("TERM:(tcsymbolISUB"+match(1)+ ", tcargumentsISUB"+match(1)+", tcarityISUB"+match(1)+")"+match(4)) ELIF at ("tc("+any**1+"):= TERMSCELL:("+any**2+","+any**3+")"+any**4) THEN C ("replace(tcsymbol,"+match(1)+","+match(2)+ ".symbol); replace(tcarguments,"+match(1)+","+match(2)+ ".arguments); replace(tcarity,"+match(1)+","+match(2)+ ".arity); replace(tcrest,"+match(1)+","+match(3)+")"+match(4)) ELIF at ("tc("+any**1+")"+any**4) THEN C ("TERMSCELL:(TERM:(tcsymbolISUB"+match(1)+ ", tcargumentsISUB"+match(1)+", tcarityISUB"+match(1) +"), tcrestISUB"+match(1)+")" +match(4)) ELIF NOT eof THEN stop FI; col(col-1); D("*"); C "" . } END PACKET prolog; { TEST } lernsequenz auf taste legen ("7",""124""); lernsequenz auf taste legen ("ΓΌ",""91""); lernsequenz auf taste legen ("+",""93"");