summaryrefslogtreecommitdiff
path: root/lang/prolog/1.8.7
diff options
context:
space:
mode:
authorLars-Dominik Braun <lars@6xq.net>2019-02-04 13:09:03 +0100
committerLars-Dominik Braun <lars@6xq.net>2019-02-04 13:09:03 +0100
commit04e68443040c7abad84d66477e98f93bed701760 (patch)
tree2b6202afae659e773bf6916157d23e83edfa44e3 /lang/prolog/1.8.7
downloadeumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.gz
eumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.bz2
eumel-src-04e68443040c7abad84d66477e98f93bed701760.zip
Initial import
Diffstat (limited to 'lang/prolog/1.8.7')
-rw-r--r--lang/prolog/1.8.7/doc/prolog handbuch581
-rw-r--r--lang/prolog/1.8.7/source-disk1
-rw-r--r--lang/prolog/1.8.7/src/calc32
-rw-r--r--lang/prolog/1.8.7/src/family29
-rw-r--r--lang/prolog/1.8.7/src/permute15
-rw-r--r--lang/prolog/1.8.7/src/prieks58
-rw-r--r--lang/prolog/1.8.7/src/prolog2488
-rw-r--r--lang/prolog/1.8.7/src/prolog installation117
-rw-r--r--lang/prolog/1.8.7/src/puzzle24
-rw-r--r--lang/prolog/1.8.7/src/quicksort14
-rw-r--r--lang/prolog/1.8.7/src/standard35
-rw-r--r--lang/prolog/1.8.7/src/sum13
-rw-r--r--lang/prolog/1.8.7/src/thesaurus360
-rw-r--r--lang/prolog/1.8.7/src/topographie59
14 files changed, 3826 insertions, 0 deletions
diff --git a/lang/prolog/1.8.7/doc/prolog handbuch b/lang/prolog/1.8.7/doc/prolog handbuch
new file mode 100644
index 0000000..ea7c6a5
--- /dev/null
+++ b/lang/prolog/1.8.7/doc/prolog handbuch
@@ -0,0 +1,581 @@
+____________________________________________________________________________
+
+
+#on("b")##on ("u")#
+#center#Betriebssystem E U M E L
+#off ("u")#
+
+
+#center#Prolog
+
+
+
+
+#off("b")#
+#center#Lizenzfreie Software der
+#on ("b")#
+
+#center#Gesellschaft für Mathematik und Datenverarbeitung mbH,
+#center#5205 Sankt Augustin
+
+
+#off("b")#
+#center#Die Nutzung der Software ist nur im Schul- und Hochschulbereich für
+#center#nichtkommerzielle Zwecke gestattet.
+
+#center#Gewährleistung und Haftung werden ausgeschlossen
+
+
+____________________________________________________________________________
+#page#
+
+Dr.P.Heyderhoff 12.03.1987
+GMD.F2.G2
+
+
+
+
+
+
+ E L A N - P R O L O G
+ _____________________
+
+ (Die Fachsprache der künstlichen Intelligenz)
+
+#on("u")#Benutzungsanleitung und technische Beschreibung#off("u")#
+
+
+Elan-Prolog ist eine Computersprache der fünften Generation, die für
+die Praxis der Programmierung und die Lehre in Informatik eine neue
+Dimension erschließt. Für den professionellen Programmierer eröffnet sie
+neue Möglichkeiten, mächtige Anwendungen, wie Expertensysteme und andere
+neuartige Systeme der Wissensverarbeitung zu entwickeln.
+
+Elan-Prolog unterscheidet sich grundsätzlich von üblichen konventionellen
+Programmiersprachen. In Sprachen wie Elan und Pascal muß der Programmierer
+genau angeben, wie ein gewünschtes Ergebnis errechnet werden soll. Um was es
+sich dabei handelt, steht bestenfalls dann in der Dokumentation. Ganz anders
+ist es in Prolog. PROLOG steht für PROgrammieren in LOgik und basiert auf
+dem Prädikaten-Kalkül, der bekanntesten Form der formalen Logik. Also in
+Prolog schreibt der Programmierer hin, worin das Problem besteht. Er bedient
+sich dabei dieser formalen Logik. Prolog versucht dann eine Lösung zu
+finden. Der Lösungsweg ist dabei im Programm nicht vorgeschrieben. Das
+entlastet den Programmierer, und er kann seine ganze Kraft auf die logische
+Beschreibung des Problems konzentrieren.
+
+Elan-Prolog ist ein interpretatives System, das voll kompatibel ist mit dem
+Edinburgh Standard Prolog und in in komfortabler Weise in das Betriebssystem
+Eumel eingebettet ist.
+
+Eigenschaftes von Elan-Prolog:
+
+- Syntax gemäß dem Edinburgh Standard Prolog nach Clocksin-Mellish
+
+- Interpretierendes System mit inkrementellem Einpass-Compiler
+
+- Interaktiver Mehrfenster-Texteditor des Eumelsystems
+
+- Zugriff auf Elan-Prozeduren als Prolog-Regeln
+
+- Geschwindigkeit ca. 100 LIPS auf IBM/PC-XT
+
+- optionale dynamische Ablaufverfolgung
+
+- Erklärungskomponente
+
+- Eingabe und Ausgabe von Prolog-Ausdrücken und Klartext
+
+- Programmiert und dokumentiert in ELAN (über 2000 Zeilen)
+
+- daher besonders für den Informatik-Unterricht geeignet
+#page#
+#on("u")#Beschränkungen des Elan-Prolog:#off("u")#
+
+Folgende Beschränkungen gelten für die Implementierung von Elan-Prolog im
+Eumel-Systems:
+
+- Maximal 16000 Fakten und Regeln
+
+- Maximal 16000 Terme zur Konstruktion von Ausdrücken, Listen und Regeln
+
+- Maximal 800 Variablenbindungen
+
+- Maximal 800 Einträge im Beweisbaum
+
+- Maximal 4000 Bezeichner für Atome und Variablen
+
+- Maximal 16000 Buchstaben für alle Bezeichner zusammen
+
+
+Wie sieht ein Prolog-Programm aus?
+
+Ein Prolog-Programm besteht aus
+
+ - Fakten über Objekte und ihre Beziehungen
+
+ - Regeln über Objekte und ihre Beziehungen
+
+und besonders wichtig:
+
+ - Der Benutzer kann Prolog über die Fakten und Regeln ausfragen.
+
+Fakten aus einer Wissensbasis, nämlich dem Prolog-Programm, sind z.B.:
+
+ enthaelt (wisky, aethanol).
+
+Das wird gelesen als: "Wisky enthält Aethanol.". Grundzüge der sehr
+einfachen Syntax lassen sich hieran erklären. Ein Faktum wird geschrieben
+wie in diesem Beispiel:
+
+ - Erst kommt der Name der Relation, geschrieben wie ein Elan-Name in
+ kleinen Buchstaben.
+
+ - Dann folgt in runden Klammern und durch Kommata getrennt eine Liste
+ von Objektnamen.
+
+ - Zum Schluß steht ein Punkt.
+
+Regeln sind Problembeschreibungen in der Form von logischen Ausdrücken der
+symbolischen Logik, wie z.B. die folgende Regel:
+
+ bewirkt (A, B, kopfschmerz) :- enthaelt (A, aethanol),
+ enthaelt (B, aspirin ).
+
+Das wird gelesen als: "Wenn man eine Droge A, die Aethanol enthält,
+und eine Droge B, die Aspirin enthält gleichzeitig einnimmt, dann bewirkt
+das Kopfschmerzen." Wie man sieht werden logische Variablen mit großen
+Buchstaben (wie Elan-Operatoren) geschrieben. Das Zeichen ":-" steht für das
+logische Wenn, und das Komma(",") für die logische Konjunktion. Die logische
+Disjunktion wird durch Semikolon(";") ausgedrückt.
+#page#
+Neben der hiermit vorgestellten Prefix-Schreibweise für Relationen gibt es in
+ELAN-Prolog auch noch eine Infix-Schreibweise für zweistellige Relationen.
+Hierbei werden die Relationen als Infix-Operatoren in großen
+Buchstaben geschrieben (wie in ELAN) und zwischen die beiden Operanden
+gesetzt. Als Operatoren sind auch die in Elan üblichen Operatoren
+
+ ( +, -, *, /, MOD, =, <, >, <=, >=, <> )
+zulässig.
+
+In Infixausdrücken (wie z.B. 2+3*4) gelten die bekannten Vorrangregeln. Auch
+Klammern sind zulässig. Selbstdefinierte Operatoren haben niedrigste
+Priorität.
+
+Obiges Beispiel in Infix-Schreibweise:
+
+ wisky ENTHAELT aethanol.
+
+ bewirkt (A, B, kopfschmerz) :- A ENTHAELT aethanol,
+ B ENTHAELT aspirin.
+
+
+Objekte in Prolog können Atome oder Listen sein. Für Atome gibt es zwei
+Schreibweisen:
+
+ - genau so wie Elan-Bezeichner, also bestehend aus kleinen Buchstaben
+ und Blanks. Dabei werden die Blanks eliminiert.
+
+ - genauso wie Elan-Texte, nämlich in Gänsefüßchen eingeschlossen.
+
+Für Listen von Objekten gibt es wiederrum zwei Schreibweisen, wie folgende
+zwei unterschiedlichen Notationen des gleichen Beispiels zeigen:
+
+ - [ das, ist, [ zum, beispiel ], eine, liste ]
+
+ - [ das, ist, [ zum | [ beispiel | [] ] ], eine, liste ]
+
+Im zweiten Fall ist die als drittes Element in der Gesamtlisten enthaltene
+Teilliste mit dem Konstruktor "|" und der leeren Liste "[]" zusammengesetzt.
+Die Grundoperationen, die aus der Programmiersprache LISP bekannt sind,
+können als Prolog-Fakten unmittelbar wie folgt definiert werden:
+
+ eq (X, X).
+ head ([X|Y], X).
+ tail ([X|Y], Y).
+ cons (X, Y, [X|Y]).
+#page#
+#on("u")#Standard - Operatoren von Elan-Prolog:#off("u")#
+
+Im System sind nur ganz wenige Standardoperatoren eingebaut. Es sind die
+folgenden Fakten:
+
+ - ! . der CUT-Operator schaltet des Backtracking ab.
+
+ - bye. beendet die prolog Anwendung.
+
+ - listing. zeigt alle insertierten Regeln.
+
+ - listing (X). zeigt alle insertierten Regeln über X.
+
+ - call (X). X wird ausgeführt.
+
+ - write (X). das an X gebundenen Prolog-Objekts wird ausgegeben,
+ writeq (X). und wenn nicht eindeutig, gequotet,
+ put (X). das Zeichen, dessen ASCII-Code X ist wird ausgegeben,
+ name (X,[Y]). unifiziert das Atom X mit der Liste seiner Buchstaben.
+
+ - read (X). ein Objekt wird gelesen und an die Variable gebunden.
+ get0 (X). das nächste Zeichen wird gelesen,
+ get (X). das nächste druckbare Zeichen wird gelesen,
+
+ - X = Y . Die an X und Y gebundenen Objekte sind gleich,
+ X <> Y . sie sind ungleich,
+ X <= Y . sie sind kleiner oder gleich,
+ X == Y . sie sind wörtlich gleich,
+ X =.. [F|A] . X ist der Term mit Funktor F und Argumentliste A.
+
+ - X + Y . sie sollen addiert,
+ X - Y . subtrahiert,
+ X * Y . multipliziert,
+ X / Y . dividiert,
+ X MOD Y . der Divisionsrest soll ermittelt werden,
+ die Auswertung geschieht durch den 'is'-Operators.
+
+ - X IS EXPR . Das Ergebnis des arithmetischen Ausdrucks EXPR wird
+ gebildet und mit X unifiziert.
+
+ - incr (X). der arithmetische Wert von X wird um eins erhöht.
+
+ - assertz ([X]). insertiert die Regel X am Ende einfügend.
+ asserta ([Χ]). insertiert die Regel X am Anfang einfügend.
+ retract ([X]). entfernt die Regel X wieder.
+ clause (X,[Y]). holt die Regel Y mit dem Kopf X aus der Knowledgebase.
+
+ - functor (X,Y,Z) Y ist der Funktor von X und Z ist seine Arität.
+ arg (X,Y,Z). Z ist das x-te Argument der Funktion Y.
+
+ - elan (X). Ausführung der insertierten ELAN-Prozedur X
+ elan (X,Y). Ausführung von X mit dem TEXT-CONST-Parameter Y
+
+ - elan(trace,on). schaltet den dynamischen Ablaufverfolger ein und
+ elan(trace,off) schaltet ihn wieder ab.
+
+ - elan(consult,X) lädt das Prologprogramm aus der Datei namens X hinzu.
+ elan(reconsult,X) ersetzt das Prologprogramm aus der Datei X.
+ elan(abolish,X) entfernt alle Regeln mit dem Namen X.
+#page#
+#on("u")#Das Dialogverhalten von Elan-Prolog:#off("u")#
+
+Elan-Prolog wird, sobald es in das Eumel-System insertiert ist, als Prozedur
+mit dem Namen "prolog" und einem optionalen TEXT-Parameter aufgerufen. Der
+Textparameter enthält den Namen einer Datei, die ein Prolog-Programm enthält,
+das geladen werden soll. Fehlt der Parameter, wird, wie üblich, die zuletzt
+bearbeitete Datei genommen. Im Prolog-Dialog können später weitere
+Prolog-Programme mit der Prozedur namens "consult" hinzugeladen werden.
+
+Also
+einfachster Aufruf: prolog ("")
+
+Antwort: ?-
+Beispiel-Eingabe: 3 = 3
+Antwort: yes
+ ?-
+Eingabe: 4 = -5
+Antwort: no
+ ?-
+
+Besondere Dialogkommandos:
+
+ ?-
+Eingabe: ?
+Antwort z.B.: 13.5 SEC
+ ?-
+Eingabe: listing
+Antwort: { zeigt alle aktuell verfügbaren Regeln }
+ ?-
+Eingabe: {ESCAPE} q
+Ausgabe: gib kommando:
+
+Eingabe: prolog again
+Ausgabe: ?-
+Eingabe: [sum, permute] {in eckigen Klammern!}
+ { konsultiert diese beiden Dateien }
+Antwort z.B.: 25 rules inserted.
+ ?-
+Eingabe: [-sum, -permute]
+ { löscht und rekonsultiert aus diesen Dateien }
+Antwort z.B.: 25 rules inserted.
+
+Eingabe: {ESCAPE} {ESCAPE}
+Antwort: gib kommado:
+Elan-Eingabe z.B.: show ("standard")
+ { zeigt die Datei dieses Namens }
+ ?-
+
+Auf diese Weise können bequem Eumel-Kommandos gegeben werden. Die
+Umschaltung vom Prolog- zum Eumelmonitor-Betrieb erfolgt durch die Tasten
+{ESCAPE},{ESCAPE} und {RETURN}. Wie üblich ist das zuletzt verwendete
+Kommando auch im Prolog-Dialog mit dem Escapekommando "{ESCAPE} k"
+wiederzubekommen. Das Kommando "{ESCAPE} q" beendet den Dialog.
+#page#
+#on("u")#Ausprobieren der Prolog-Programmbeispiele:#off("u")#
+
+Zum Ausprobieren sind die Prologbeispiele "eq", "permute" und "mann"
+beigefügt.
+
+Beispiel: ?-
+Eingabe: [permute] {in eckigen Klammern!}
+Antwort: 5 rules inserted.
+ ?-
+Eingabe: marquise(X)
+Antwort: beautiful marquise your beautiful eyes make me die of love
+Eingabe: {Semicolon}
+Antwort: your beautiful eyes beautiful marquise make me die of love
+ { usw }
+Eingabe: {Return}
+Antwort: ?-
+
+Jede #on("u")#Eingabe von Semicolon#off("u")# liefert als Antwort die nächste Permutation. Wenn
+eine andere Taste gedrückt wird, bricht die Ausgabe weiterer Ergebnisse ab.
+
+#on("u")#Eingabe von Fragezeichen#off("u")# liefert neben der Angabe der benötigten
+Rechenzeit eine Erklärung der letzten Antwort durch Ausgabe aller zu dieser
+Antwort führenden Schlußfolgerungen. Dabei wird der Beweisbaum in Form einer
+Einrückstruktur dargestellt. Die Einrückung stellt die Erklärungstiefe dar.
+
+
+#on("u")#Benutzung von Prolog von Elan-Programmen aus#off("u")#
+
+Wenn man Prolog als Unterprogramm von Elan aus aufrufen will, geht man
+folgendermaßen vor:
+
+1. Laden einer Wissensbasis,
+ die in einer Datei namens <knowledgebase> z.B."permute" bereitsteht:
+
+ push ("bye"13"");
+ prolog ("permute");
+
+
+2. Abfragen an diese Wissensbasis:
+
+ TEXT VAR query, answer;
+ query:= "marquise (X)";
+ IF prolog ( query, answer)
+ THEN put (answer)
+ ELSE put ("NO")
+ FI;
+
+In diesem Anwendungsbeispiel liefert die Ausgabeanweisung 'put (answer)':
+
+ beautiful marquise your beatiful eyes make me die of love
+
+#page#
+#on("u")#Literatur:#off("u")#
+
+
+1.) W.F.Clocksin, C.S.Mellish:
+ Programming in Prolog
+ Springer 1984
+
+2.) M.H.van Emden:
+ An interpreting algorithm for prolog programs
+ in Implementations of Prolog, Ellis Herwood Ltd, 1984
+
+3.) Alain Colmerauer:
+ Prolog in 10 Figures
+ Communications of the ACM December 1985
+
+4.) J. Cohen:
+ Describing Prolog by its Interpretation and Compilation
+ Communications of the ACM December 1985
+
+5.) Alain Colmerauer:
+ Les system q ou un formalisme pour alalyser et synthetiser des phrases
+ sur ordinateur.
+ Intern.Rep. 43, Departement d'informatique. Universite de Montreal
+ Sept. 1970
+#page#
+(*************************************************************************)
+(* *)
+(* Elan-Prolog *)
+(* *)
+(* Programm-Beispiele: *)
+(* *)
+(****************** standard (nach Clocksin-Mellish) ********************)
+
+abolish (X) :- elan (abolish, X).
+append ([], X, X) :- !.
+append ([X|Y], Z, [X|W]) :- append (Y, Z, W).
+atom (X) :- functor (X, Y, 0).
+atomic (X) :- atom (X); integer (X).
+consult (X) :- elan (consult, X).
+end :- bye.
+fail :- [].
+findall (X, Y, Z) :- tell ("$$"), write ("("), findall (X,Y);
+ write (")"), told, see ("$$"), read (Z),
+ seen, elan (forget, "$$").
+findall (X, Y) :- call (Y), writeq (X), write (","), [].
+integer (X) :- functor (X, Y, -1).
+listing (X).
+member (X, [X|Z]).
+member (X, [Y|Z]) :- member (X, Z).
+nl :- elan (line).
+non var (X) :- var (X), !, []; .
+not (X) :- call (X), !, []; .
+notrace :- elan (trace, off).
+reconsult (X) :- elan (reconsult, X).
+repeat.
+repeat :- repeat.
+see (X) :- elan (sysin, X).
+seen :- elan (sysin, "").
+tab (X) :- tab(X,1).
+tab (X,Y) :- Y<=X, !, put (32), incr(Y), tab(X,Y);.
+tell (X) :- elan (sysout, X).
+told :- elan (sysout, "").
+trace :- elan (trace, on).
+true.
+< (X, Y) :- <= (X, Y), <> (X, Y).
+> (X, Y) :- <= (Y, X).
+>= (X, Y) :- < (Y, X).
+#page#
+(**************************** sum ***********************************)
+
+suc (0, 1). suc (1, 2). suc (2, 3). suc (3, 4). suc (4, 5).
+suc (5, 6). suc (6, 7). suc (7, 8). suc (8, 9).
+sum (0, X, X).
+sum (X, Y, Z):- suc (V, X), sum (V, Y, W), suc (W, Z).
+plus (X, [0,0], X):- !.
+plus (X, Y, Z):- plus one (V, Y), plus (X, V, W), !, plus one (W, Z).
+plus one ([X, Y], [V, W]):- suc (Y, W), X = V, !;
+ Y = 9, suc (X, V), W = 0.
+treereverse (X,Y):- rev (X,Y), !; rev (Y,X), !.
+rev ([], []).
+rev ([X|Y], Z):- X <> [H|T], rev (Y, W), !, append (W, [X], Z);
+ rev (X, V), rev (Y, W), !, append (W, [V], Z).
+
+(**************************** permute ************************************)
+
+permute ([], []).
+permute ([E|X], Z):-
+ permute (X, Y), insert (E, Y, Z).
+insert (E, X, [E|X]).
+insert (E, [F|X], [F|Y]):-
+ insert (E, X, Y).
+marquise(RESULT):-
+ permute (["beautiful marquise",
+ "your beautiful eyes",
+ "make me",
+ "die",
+ "of love"
+ ],
+ RESULT).
+
+(**************************** puzzle ************************************)
+
+ {Solution: 9,5,6,7,0,8,2}
+puzzle:- repeat, permute ((9,8,7,6,5,2,0), SENDMORY),
+ write (SENDMORY),
+ puzzle (SENDMORY, SEND, MORE, MONEY),
+ elan (line),
+ write (SEND), write (+),
+ write (MORE), write (=),
+ write (MONEY).
+
+puzzle([S,E,N,D,O,R,Y], SEND, MORE, MONEY):-
+ SEND IS ((S * 10 + E) * 10 + N) * 10 + D,
+ MORE IS ((10 + O) * 10 + R) * 10 + E,
+ MONEY IS (((10 + O) * 10 + N) * 10 + E) * 10 + Y,
+ MONEY IS SEND + MORE.
+
+permute ([], []).
+permute ([E|X], Z):- permute (X, Y), insert (E, Y, Z).
+
+insert (E, X, [E|X]).
+insert (E, [F|X], [F|Y]):- insert (E, X, Y).
+
+repeat.
+repeat:- repeat.
+#page#
+(**************************** prieks ***********************************)
+
+ist priek (bo priek).
+ist priek (ki priek).
+ist priek (bla priek).
+
+WER GNASELT WEN :- population (B),
+ member ([WEN, WER, _], B),
+ bedingungen (B).
+
+WER KNAUDERT WEN:- population (B),
+ member ([WER, _, WEN], B),
+ bedingungen (B).
+
+population (B):- sind prieks (U, V, W),
+ sind knauderarten (R, S, T),
+ B = [ [drausla puemfe, U, R],
+ [glessla puemfe, V, S],
+ [hapla puemfe, W, T] ].
+
+sind prieks (X,Y,Z):- ist priek (G),
+ ist priek (H), H<>G,
+ ist priek (I), I<>G, I<>H, !,
+ permute ([G,H,I], [X,Y,Z]).
+
+sind knauderarten (X,Y,Z):- ist knauderart (G),
+ ist knauderart (H), H<>G,
+ ist knauderart (I), I<>G, I<>H, !,
+ permute ([G,H,I],[X,Y,Z]).
+
+ist knauderart (an).
+ist knauderart (ab).
+ist knauderart (ueber).
+
+bedingungen (B):- not member ([hapla puemfe,ki priek,_],B) ,
+ not member ([hapla puemfe,_,ueber],B) ,
+ not member ([drausla puemfe,bo priek,_],B) ,
+ not member ([_,bo priek,ab],B) ,
+ noch ne bedingung (B) ,
+ weitere bedingungen (B) , !.
+
+weitere bedingungen (B):- not member([_,ki priek,ueber],B),
+ not member([_,bo priek,ueber],B)
+ ;
+ member([drausla puemfe,_,an],B).
+
+noch ne bedingung (B):- not member ([drausla puemfe,ki priek,_],B)
+ ;
+ not member ([glessla puemfe,_,ueber],B).
+
+permute ([], []).
+permute (X, [Y|Z]):- delete (Y ,X, E), permute (E, Z).
+delete (X, [X|Z], Z).
+delete (X, [Y|Z], [Y|E]):- delete (X, Z, E).
+member (X, [X|Z]).
+member (X, [Y|Z]):- member (X, Z).
+not member (X, []).
+not member (X, [Y|Z]):- X <> Y, not member (X,Z).
+#page#
+(**************************** calc ************************************)
+
+{ CALC evaluates arithmetic expressions with store }
+
+calc:- eval ([], RS), write (result store), write (RS), nl.
+
+eval (SI, SO):-
+ read (CALC), nonvar (CALC), eval member (CALC, SI, SO).
+
+eval member (CALC, SI, SO):-
+ member (CALC, [stop,end,bye,eof]), SO=SI;
+ eval (CALC,I,SI,ST), write (I), eval (ST,SO);
+ write (error in), write (CALC), nl, eval (SI, SO).
+
+eval (I, I, S, S):- integer (I).
+eval (N, I, S, S):- atom (N), eval atom (N, I, S).
+
+eval atom (N, I, S):-
+ member (N=I, S);
+ write ("error: Cell"), write (N),
+ write("not found in store. 0 substituted."), nl, I=0.
+
+eval ( L+R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J+K.
+eval ( L-R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J-K.
+eval ( L*R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J*K.
+eval ( L/R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J/K.
+
+eval (N=O, I, SI, SO):-
+ atom (N), eval (O,I,SI,ST), eval repl (N,I,ST,SO).
+
+eval repl (N, I, [], [=(N,I)]).
+eval repl (N, I, [=(N,_)|S], [=(N,I)|S]).
+eval repl (N, I, [=(M,J)|SI], [=(M,J)|SO]):- eval repl (N, I, SI, SO).
+
diff --git a/lang/prolog/1.8.7/source-disk b/lang/prolog/1.8.7/source-disk
new file mode 100644
index 0000000..e61107d
--- /dev/null
+++ b/lang/prolog/1.8.7/source-disk
@@ -0,0 +1 @@
+informatikpaket/01_sprachen.img
diff --git a/lang/prolog/1.8.7/src/calc b/lang/prolog/1.8.7/src/calc
new file mode 100644
index 0000000..0ed11af
--- /dev/null
+++ b/lang/prolog/1.8.7/src/calc
@@ -0,0 +1,32 @@
+{ CALC evaluates arithmetic expressions with store }
+
+calc:- eval ([], RS), write (result store), write (RS), nl.
+
+eval (SI, SO):-
+ read (CALC), nonvar (CALC), eval member (CALC, SI, SO).
+
+eval member (CALC, SI, SO):-
+ member (CALC, [stop,end,bye,eof]), SO=SI;
+ eval (CALC,I,SI,ST), write (I), eval (ST,SO);
+ write (error in), write (CALC), nl, eval (SI, SO).
+
+eval (I, I, S, S):- integer (I).
+eval (N, I, S, S):- atom (N), eval atom (N, I, S).
+
+eval atom (N, I, S):-
+ member (N=I, S);
+ write ("error: Cell"), write (N),
+ write("not found in store. 0 substituted."), nl, I=0.
+
+eval ( L+R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J+K.
+eval ( L-R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J-K.
+eval ( L*R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J*K.
+eval ( L/R,I,SI,SO):- eval (L,J,SI,ST), eval (R,K,ST,SO), I IS J/K.
+
+eval (N=O, I, SI, SO):-
+ atom (N), eval (O,I,SI,ST), eval repl (N,I,ST,SO).
+
+eval repl (N, I, [], [=(N,I)]).
+eval repl (N, I, [=(N,_)|S], [=(N,I)|S]).
+eval repl (N, I, [=(M,J)|SI], [=(M,J)|SO]):- eval repl (N, I, SI, SO).
+
diff --git a/lang/prolog/1.8.7/src/family b/lang/prolog/1.8.7/src/family
new file mode 100644
index 0000000..8419cc6
--- /dev/null
+++ b/lang/prolog/1.8.7/src/family
@@ -0,0 +1,29 @@
+
+mann(jürgen). mann(detlef). mann (frank). mann (peter). mann(jochen).
+frau(gaby). frau(yvonne). frau(sinha). frau(rita). frau(viktoria).
+frau(adelheid).
+vater(gaby, peter). vater(yvonne, peter). vater(frank, peter).
+mutter(gaby, rita). mutter(yvonne, rita). mutter(frank, rita).
+mutter(rita,viktoria).
+vater(jürgen, heinz). mutter(jürgen, natalie).
+vater(kalle, heinz). mutter(kalle, natalie).
+mann(gaby, jürgen). mann(yvonne, detlef). mann(sinha,frank).
+mann(rita, peter). mann(adelheid, jochen).
+frau(X,Y) :- mann (Y,X).
+großmutter(X,Y):- mutter(X,H), mutter(H,Y); vater(X,H), mutter(H,Y).
+sohn(X,Y):- vater(Y,X), mann(Y); mutter(Y,X), mann(Y) .
+tochter(X,Y):- vater(Y,X), frau(Y); mutter(Y,X), frau(Y).
+geschwister(X,Y):-vater(X,A),vater(Y,A),mutter(X,B),mutter(Y,B),<>(X,Y).
+bruder(X,Y):- geschwister(X,Y), mann(Y).
+schwester(X,Y):- geschwister(X,Y), frau(Y).
+schwager(X,Y):- mann(X,Z), bruder(Z,Y); frau(X,Z), bruder(Z,Y).
+schwägerin(X,Y):-mann(X,Z),schwester(Z,Y);frau(X,Y),schwester(Z,Y).
+freund (X,Y):- mann(Y), mann(X), <>(X,Y);
+ mann(Y), frau(X), mann(Z,Y), <>(X,Z);
+ mann(Y), frau(X), !, mann(Z,Y), [];
+ mann(Y), frau(X).
+freundin (X,Y):- frau(Y), frau(X), <>(X,Y);
+ frau(Y), mann(X), mann(Y,Z), <>(X,Z);
+ frau(Y), mann(X), !, mann(Y,Z), [];
+ frau(Y), mann(X).
+
diff --git a/lang/prolog/1.8.7/src/permute b/lang/prolog/1.8.7/src/permute
new file mode 100644
index 0000000..54f8fee
--- /dev/null
+++ b/lang/prolog/1.8.7/src/permute
@@ -0,0 +1,15 @@
+permute ([], []).
+permute ([E|X], Z):-
+ permute (X, Y), insert (E, Y, Z).
+insert (E, X, [E|X]).
+insert (E, [F|X], [F|Y]):-
+ insert (E, X, Y).
+marquise(RESULT):-
+ permute (["beautiful marquise",
+ "your beautiful eyes",
+ "make me",
+ "die",
+ "of love"
+ ],
+ RESULT).
+
diff --git a/lang/prolog/1.8.7/src/prieks b/lang/prolog/1.8.7/src/prieks
new file mode 100644
index 0000000..372ec9d
--- /dev/null
+++ b/lang/prolog/1.8.7/src/prieks
@@ -0,0 +1,58 @@
+
+ist priek (bo priek).
+ist priek (ki priek).
+ist priek (bla priek).
+
+WER GNASELT WEN :- population (B),
+ member ([WEN, WER, _], B),
+ bedingungen (B).
+
+WER KNAUDERT WEN:- population (B),
+ member ([WER, _, WEN], B),
+ bedingungen (B).
+
+population (B):- sind prieks (U, V, W),
+ sind knauderarten (R, S, T),
+ B = [ [drausla puemfe, U, R],
+ [glessla puemfe, V, S],
+ [hapla puemfe, W, T] ].
+
+sind prieks (X,Y,Z):- ist priek (G),
+ ist priek (H), H<>G,
+ ist priek (I), I<>G, I<>H, !,
+ permute ([G,H,I], [X,Y,Z]).
+
+sind knauderarten (X,Y,Z):- ist knauderart (G),
+ ist knauderart (H), H<>G,
+ ist knauderart (I), I<>G, I<>H, !,
+ permute ([G,H,I],[X,Y,Z]).
+
+ist knauderart (an).
+ist knauderart (ab).
+ist knauderart (ueber).
+
+bedingungen (B):- not member ([hapla puemfe,ki priek,_],B) ,
+ not member ([hapla puemfe,_,ueber],B) ,
+ not member ([drausla puemfe,bo priek,_],B) ,
+ not member ([_,bo priek,ab],B) ,
+ noch ne bedingung (B) ,
+ weitere bedingungen (B) , !.
+
+weitere bedingungen (B):- not member([_,ki priek,ueber],B),
+ not member([_,bo priek,ueber],B)
+ ;
+ member([drausla puemfe,_,an],B).
+
+noch ne bedingung (B):- not member ([drausla puemfe,ki priek,_],B)
+ ;
+ not member ([glessla puemfe,_,ueber],B).
+
+permute ([], []).
+permute (X, [Y|Z]):- delete (Y ,X, E), permute (E, Z).
+delete (X, [X|Z], Z).
+delete (X, [Y|Z], [Y|E]):- delete (X, Z, E).
+member (X, [X|Z]).
+member (X, [Y|Z]):- member (X, Z).
+not member (X, []).
+not member (X, [Y|Z]):- X <> Y, not member (X,Z).
+
diff --git a/lang/prolog/1.8.7/src/prolog b/lang/prolog/1.8.7/src/prolog
new file mode 100644
index 0000000..7ac2e6a
--- /dev/null
+++ b/lang/prolog/1.8.7/src/prolog
@@ -0,0 +1,2488 @@
+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 <t1,f1^.environment> and <t2,f2^.environment>,
+ 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 <t1, f1> to <t2, f2> in the environment <f1> }
+ 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 <t1, f1^.environment> is bound and
+ assigns <t2, f2^.environment> 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"");
+
diff --git a/lang/prolog/1.8.7/src/prolog installation b/lang/prolog/1.8.7/src/prolog installation
new file mode 100644
index 0000000..cc674fa
--- /dev/null
+++ b/lang/prolog/1.8.7/src/prolog installation
@@ -0,0 +1,117 @@
+(*************************************************************************)
+(*** Insertiert die für PROLOG benötigten Pakete und holt die ***)
+(*** Beispiele vom Archiv. ***)
+(*** ***)
+(*** Autor : W. Metterhausen Stand : 03.12.87 ***)
+(*************************************************************************)
+
+erste bildschirmmeldung;
+
+
+IF yes("Prolog insertieren?")
+
+ THEN
+ hole sourcen vom archiv;
+ insertiere alle pakete;
+ hole beispiele vom archiv;
+ forget ("prolog installation", quiet);
+ type("push(""bye""13""prolog again"");prolog(""standard"")"13"");
+FI.
+
+
+insertiere alle pakete :
+ insert and say ("thesaurus");
+ insert and say ("prolog").
+
+erste bildschirmmeldung :
+ page;
+ put center (" Generator für Prolog gestartet."); line;
+ put center ("--------------------------------------------------");line;
+ put center (" Prolog kann nur in einer Task aufgebaut werden, ");line;
+ put center (" die nicht bereits umfangreiche insertierte Pakete ");line;
+ put center (" enthält! Gegebenenfalls sollte Prolog in ");line;
+ put center (" einer Task direkt unter ""UR"" angelegt werden. ");line;
+ line (2).
+
+hole sourcen vom archiv :
+ TEXT VAR datei;
+ datei := "thesaurus"; hole wenn noetig;
+ datei := "prolog"; hole wenn noetig;
+ line.
+
+hole beispiele vom archiv :
+ datei := "standard"; hole wenn noetig;
+ datei := "sum"; hole wenn noetig;
+ datei := "permute"; hole wenn noetig;
+ datei := "family"; hole wenn noetig;
+ datei := "puzzle"; hole wenn noetig;
+ datei := "calc"; hole wenn noetig;
+ datei := "prieks"; hole wenn noetig;
+ datei := "topographie"; hole wenn noetig;
+ datei := "quicksort"; hole wenn noetig;
+ datei := "prolog dokumentation";
+ hole wenn noetig;
+ release(archive);
+ line.
+
+hole wenn noetig :
+ IF NOT exists (datei) THEN
+ put line (""""+ datei + """ wird vom Archiv geholt");
+ fetch (datei, archive)
+ FI.
+
+PROC insert and say (TEXT CONST datei) :
+
+ INT VAR cx, cy;
+ put line ("Inserting """ + datei + """...");
+ get cursor (cx, cy);
+ checkoff;
+ insert (datei);
+ checkon;
+ cl eop (cx, cy); line;
+ forget (datei, quiet).
+
+END PROC insert and say;
+
+TEXT PROC inverse (TEXT CONST t):
+ ""15"" + t + " " + ""14""
+END PROC inverse;
+
+PROC put center (TEXT CONST t):
+ put center (t, 80)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+ put center (zeile, t, 80)
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+ INT VAR cy;
+ get cursor (cy, cy);
+ put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+END PROC put center;
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+PROC cl eol (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eol
+END PROC cl eol;
+
+PROC cl eop (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eop
+END PROC cl eop;
+
+
diff --git a/lang/prolog/1.8.7/src/puzzle b/lang/prolog/1.8.7/src/puzzle
new file mode 100644
index 0000000..648beb6
--- /dev/null
+++ b/lang/prolog/1.8.7/src/puzzle
@@ -0,0 +1,24 @@
+ {Solution: 9,5,6,7,0,8,2}
+puzzle:- repeat, permute ((9,8,7,6,5,2,0), SENDMORY),
+ write (SENDMORY),
+ puzzle (SENDMORY, SEND, MORE, MONEY),
+ elan (line),
+ write (SEND), write (+),
+ write (MORE), write (=),
+ write (MONEY).
+
+puzzle([S,E,N,D,O,R,Y], SEND, MORE, MONEY):-
+ SEND IS ((S * 10 + E) * 10 + N) * 10 + D,
+ MORE IS ((10 + O) * 10 + R) * 10 + E,
+ MONEY IS (((10 + O) * 10 + N) * 10 + E) * 10 + Y,
+ MONEY IS SEND + MORE.
+
+permute ([], []).
+permute ([E|X], Z):- permute (X, Y), insert (E, Y, Z).
+
+insert (E, X, [E|X]).
+insert (E, [F|X], [F|Y]):- insert (E, X, Y).
+
+repeat.
+repeat:- repeat.
+
diff --git a/lang/prolog/1.8.7/src/quicksort b/lang/prolog/1.8.7/src/quicksort
new file mode 100644
index 0000000..79276c0
--- /dev/null
+++ b/lang/prolog/1.8.7/src/quicksort
@@ -0,0 +1,14 @@
+(* quicksort algorithm nach Clocksin-Mellish *)
+
+(* Example : quicksort ([1,3,2,4], [1,2,3,4], []) *)
+
+quicksort ([H|T], S, X) :-
+ split (H, T, A, B),
+ quicksort (A, S, [H|Y]),
+ quicksort (B, Y, X).
+quicksort ([], X, X).
+
+split (H, [A|X], [A|Y], Z) :- A <= H, split (H, X, Y, Z).
+split (H, [A|X], Y, [A|Z]) :- split (H, X, Y, Z).
+split (_, [], [], []).
+
diff --git a/lang/prolog/1.8.7/src/standard b/lang/prolog/1.8.7/src/standard
new file mode 100644
index 0000000..bc983ca
--- /dev/null
+++ b/lang/prolog/1.8.7/src/standard
@@ -0,0 +1,35 @@
+abolish (X) :- elan (abolish, X).
+append ([], X, X) :- !.
+append ([X|Y], Z, [X|W]) :- append (Y, Z, W).
+atom (X) :- functor (X, Y, 0).
+atomic (X) :- atom (X); integer (X).
+consult (X) :- elan (consult, X).
+end :- bye.
+fail :- [].
+findall (X, Y, Z) :- tell ("$$"), write ("[ "), findall (X,Y);
+ write (" ]"), told, see ("$$"), read (Z),
+ seen, elan (forget, "$$").
+findall (X, Y) :- call (Y), writeq (X), write (","), [].
+integer (X) :- functor (X, Y, -1).
+listing (X).
+member (X, [X|Z]).
+member (X, [Y|Z]) :- member (X, Z).
+nl :- elan (line).
+non var (X) :- var (X), !, []; .
+not (X) :- call (X), !, []; .
+notrace :- elan (trace, off).
+reconsult (X) :- elan (reconsult, X).
+repeat.
+repeat :- repeat.
+see (X) :- elan (sysin, X).
+seen :- elan (sysin, "").
+tab (X) :- tab(X,1).
+tab (X,Y) :- Y<=X, !, put (32), incr(Y), tab(X,Y);.
+tell (X) :- elan (sysout, X).
+told :- elan (sysout, "").
+trace :- elan (trace, on).
+true.
+< (X, Y) :- <= (X, Y), <> (X, Y).
+> (X, Y) :- <= (Y, X).
+>= (X, Y) :- < (Y, X).
+
diff --git a/lang/prolog/1.8.7/src/sum b/lang/prolog/1.8.7/src/sum
new file mode 100644
index 0000000..e1b6b13
--- /dev/null
+++ b/lang/prolog/1.8.7/src/sum
@@ -0,0 +1,13 @@
+suc (0, 1). suc (1, 2). suc (2, 3). suc (3, 4). suc (4, 5).
+suc (5, 6). suc (6, 7). suc (7, 8). suc (8, 9).
+sum (0, X, X).
+sum (X, Y, Z):- suc (V, X), sum (V, Y, W), suc (W, Z).
+plus (X, [0,0], X):- !.
+plus (X, Y, Z):- plus one (V, Y), plus (X, V, W), !, plus one (W, Z).
+plus one ([X, Y], [V, W]):- suc (Y, W), X = V, !;
+ Y = 9, suc (X, V), W = 0.
+treereverse (X,Y):- rev (X,Y), !; rev (Y,X), !.
+rev ([], []).
+rev ([X|Y], Z):- X <> [H|T], rev (Y, W), !, append (W, [X], Z);
+ rev (X, V), rev (Y, W), !, append (W, [V], Z).
+
diff --git a/lang/prolog/1.8.7/src/thesaurus b/lang/prolog/1.8.7/src/thesaurus
new file mode 100644
index 0000000..4694981
--- /dev/null
+++ b/lang/prolog/1.8.7/src/thesaurus
@@ -0,0 +1,360 @@
+(* ------------------- VERSION 2 19.01.87 ------------------- *)
+PACKET thesaurus handling (* Autor: J.Liedtke *)
+
+ DEFINES THESAURUS ,
+ := ,
+ empty thesaurus ,
+ insert, (* fuegt ein Element ein *)
+ delete, (* loescht ein Element falls vorhanden *)
+ rename, (* aendert ein Element falls vorhanden *)
+ CONTAINS , (* stellt fest, ob enthalten *)
+ link , (* index in thesaurus *)
+ name , (* name of entry *)
+ decode invalid chars ,(* Steuerzeichen dekodieren *)
+ get , (* get next entry ("" is eof) *)
+ highest entry : (* highest valid index of thes *)
+
+
+TYPE THESAURUS = TEXT ;
+
+LET nil = 0 ,
+ niltext = "" ,
+ max name length = 80 ,
+ begin entry char = ""0"" ,
+ end entry char = ""255"" ,
+ nil entry = ""0""255"" ,
+ nil name = "" ,
+ quote = """" ;
+
+TEXT VAR entry ,
+ dummy ;
+INT VAR cache index := 0 ,
+ cache pos ;
+
+
+TEXT PROC decode (INT CONST number) :
+
+ dummy := " " ;
+ replace (dummy, 1, number) ;
+ dummy .
+
+ENDPROC decode ;
+
+INT PROC decode (TEXT CONST string, INT CONST position) :
+
+ subtext (string, position, position + 1) ISUB 1 .
+
+ENDPROC decode ;
+
+PROC access (THESAURUS CONST thesaurus, TEXT CONST name) :
+
+ construct entry ;
+ IF NOT cache identifies entry
+ THEN search through thesaurus list
+ FI ;
+ IF entry found
+ THEN cache index := decode (list, cache pos - 2)
+ ELSE cache index := 0
+ FI .
+
+construct entry :
+ entry := begin entry char ;
+ entry CAT name ;
+ decode invalid chars (entry, 2) ;
+ entry CAT end entry char .
+
+search through thesaurus list :
+ cache pos := pos (list, entry) .
+
+cache identifies entry :
+ cache pos <> 0 AND
+ pos (list, entry, cache pos, cache pos + LENGTH entry) = cache pos .
+
+entry found : cache pos > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC access ;
+
+PROC access (THESAURUS CONST thesaurus, INT CONST index) :
+
+ IF cache identifies index
+ THEN cache index := index ;
+ construct entry
+ ELSE cache pos := pos (list, decode (index) + begin entry char) ;
+ IF entry found
+ THEN cache pos INCR 2 ;
+ cache index := index ;
+ construct entry
+ ELSE cache index := 0 ;
+ entry := niltext
+ FI
+ FI .
+
+construct entry :
+ entry := subtext (list, cache pos, pos (list, end entry char, cache pos)) .
+
+cache identifies index :
+ subtext (list, cache pos-2, cache pos) = decode (index) + begin entry char .
+
+entry found : cache pos > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC access ;
+
+
+
+THESAURUS PROC empty thesaurus :
+
+ THESAURUS : (""1""0"")
+
+ENDPROC empty thesaurus ;
+
+
+OP := (THESAURUS VAR dest, THESAURUS CONST source ) :
+
+ CONCR (dest) := CONCR (source) .
+
+ENDOP := ;
+
+TEXT VAR insert name ;
+
+PROC insert (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) :
+
+ insert name := name ;
+ decode invalid chars (insert name, 1) ;
+ insert name if possible .
+
+insert name if possible :
+ IF insert name = "" OR LENGTH insert name > max name length
+ THEN index := nil ; errorstop ("Name unzulaessig")
+ ELIF overflow
+ THEN index := nil
+ ELSE insert element
+ FI .
+
+overflow :
+ LENGTH CONCR (thesaurus) + LENGTH insert name + 4 > max text length .
+
+insert element :
+ search free entry ;
+ IF entry found
+ THEN insert into directory
+ ELSE add entry to directory if possible
+ FI .
+
+search free entry :
+ access (thesaurus, nil name) .
+
+insert into directory :
+ change (list, cache pos + 1, cache pos, insert name) ;
+ index := cache index .
+
+add entry to directory if possible :
+ INT CONST next free index := decode (list, LENGTH list - 1) ;
+ add entry to directory .
+
+add entry to directory :
+ list CAT begin entry char ;
+ cache pos := LENGTH list ;
+ cache index := next free index ;
+ list CAT insert name ;
+ list CAT end entry char + decode (next free index + 1) ;
+ index := cache index .
+
+entry found : cache index > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC insert ;
+
+PROC decode invalid chars (TEXT VAR name, INT CONST start pos) :
+
+ INT VAR invalid char pos := pos (name, ""0"", ""31"", start pos) ;
+ WHILE invalid char pos > 0 REP
+ change (name, invalid char pos, invalid char pos, decoded char) ;
+ invalid char pos := pos (name, ""0"", ""31"", invalid char pos)
+ PER ;
+ change all (name, ""255"", quote + "255" + quote) .
+
+decoded char : quote + text(code(name SUB invalid char pos)) + quote.
+
+ENDPROC decode invalid chars ;
+
+PROC insert (THESAURUS VAR thesaurus, TEXT CONST name) :
+
+ INT VAR index ;
+ insert (thesaurus, name, index) ;
+ IF index = nil AND NOT is error
+ THEN errorstop ("THESAURUS-Ueberlauf")
+ FI .
+
+ENDPROC insert ;
+
+PROC delete (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) :
+
+ access (thesaurus, name) ;
+ index := cache index ;
+ delete (thesaurus, index) .
+
+ENDPROC delete ;
+
+PROC delete (THESAURUS VAR thesaurus, INT CONST index) :
+
+ access (thesaurus, index) ;
+ IF entry found
+ THEN delete entry
+ FI .
+
+delete entry :
+ IF is last entry of thesaurus
+ THEN cut off as much as possible
+ ELSE set to nil entry
+ FI .
+
+set to nil entry :
+ change (list, cache pos, cache pos + LENGTH entry - 1, nil entry) .
+
+cut off as much as possible :
+ WHILE predecessor is also nil entry REP
+ set cache to this entry
+ PER ;
+ list := subtext (list, 1, cache pos - 1) ;
+ erase cache .
+
+predecessor is also nil entry :
+ subtext (list, cache pos - 4, cache pos - 3) = nil entry .
+
+set cache to this entry :
+ cache pos DECR 4 .
+
+erase cache :
+ cache pos := 0 ;
+ cache index := 0 .
+
+is last entry of thesaurus :
+ pos (list, end entry char, cache pos) = LENGTH list - 2 .
+
+list : CONCR (thesaurus) .
+
+entry found : cache index > nil .
+
+ENDPROC delete ;
+
+
+BOOL OP CONTAINS (THESAURUS CONST thesaurus, TEXT CONST name ) :
+
+ IF name = niltext OR LENGTH name > max name length
+ THEN FALSE
+ ELSE access (thesaurus, name) ; entry found
+ FI .
+
+entry found : cache index > nil .
+
+ENDOP CONTAINS ;
+
+PROC rename (THESAURUS VAR thesaurus, TEXT CONST old, new) :
+
+ rename (thesaurus, link (thesaurus, old), new)
+
+ENDPROC rename ;
+
+PROC rename (THESAURUS VAR thesaurus, INT CONST index, TEXT CONST new) :
+
+ insert name := new ;
+ decode invalid chars (insert name, 1) ;
+ IF overflow
+ THEN errorstop ("THESAURUS-Ueberlauf")
+ ELIF insert name = "" OR LENGTH insert name > max name length
+ THEN errorstop ("Name unzulaessig")
+ ELSE change to new name
+ FI .
+
+overflow :
+ LENGTH CONCR (thesaurus) + LENGTH insert name + 4 > max text length .
+
+change to new name :
+ access (thesaurus, index) ;
+ IF cache index <> 0 AND entry <> ""
+ THEN change (list, cache pos + 1, cache pos + LENGTH entry - 2, insert name)
+ FI .
+
+list : CONCR (thesaurus) .
+
+ENDPROC rename ;
+
+INT PROC link (THESAURUS CONST thesaurus, TEXT CONST name) :
+
+ access (thesaurus, name) ;
+ cache index .
+
+ENDPROC link ;
+
+TEXT PROC name (THESAURUS CONST thesaurus, INT CONST index) :
+
+ access (thesaurus, index) ;
+ subtext (entry, 2, LENGTH entry - 1) .
+
+ENDPROC name ;
+
+PROC get (THESAURUS CONST thesaurus, TEXT VAR name, INT VAR index) :
+
+ identify index ;
+ REP
+ to next entry
+ UNTIL end of list COR valid entry found PER .
+
+identify index :
+ IF index = 0
+ THEN cache index := 0 ;
+ cache pos := 1
+ ELSE access (thesaurus, index)
+ FI .
+
+to next entry :
+ cache pos := pos (list, begin entry char, cache pos + 1) ;
+ IF cache pos > 0
+ THEN correct cache pos ;
+ get entry
+ ELSE get nil entry
+ FI .
+
+correct cache pos :
+ IF (list SUB cache pos + 2) = begin entry char
+ THEN cache pos INCR 2
+ ELIF (list SUB cache pos + 1) = begin entry char
+ THEN cache pos INCR 1
+ FI .
+
+get entry :
+ cache index INCR 1 ;
+ index := cache index ;
+ name := subtext (list, cache pos + 1, end entry pos - 1) .
+
+get nil entry :
+ cache index := 0 ;
+ cache pos := 0 ;
+ index := 0 ;
+ name := "" .
+
+end entry pos : pos (list, end entry char, cache pos) .
+
+end of list : index = 0 .
+
+valid entry found : name <> "" .
+
+list : CONCR (thesaurus) .
+
+ENDPROC get ;
+
+INT PROC highest entry (THESAURUS CONST thesaurus) : (*840813*)
+
+ decode (list, LENGTH list - 1) - 1 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC highest entry ;
+
+ENDPACKET thesaurus handling ;
+
diff --git a/lang/prolog/1.8.7/src/topographie b/lang/prolog/1.8.7/src/topographie
new file mode 100644
index 0000000..c0924cf
--- /dev/null
+++ b/lang/prolog/1.8.7/src/topographie
@@ -0,0 +1,59 @@
+member(X,[X|_]).
+member(X,[_|Y]):-
+ member(X,Y).
+
+append([],L,L).
+append([X|A],B,[X|C]):-
+ append(A,B,C).
+
+efface(A,[A|L],L):-
+ !.
+efface(A,[B|L],[B|M]):-
+ efface(A,L,M).
+efface(_,[],[]).
+
+
+nol(N):-
+ read(N).
+
+input(_,_,N,N,L,L).
+input(X,Y,R,N,L,O):-
+ read(X),
+ read(Y),
+ append([[X,Y]],L,M),
+ C IS R+1,
+ input(_,_,C,N,M,O).
+
+enter(L):-
+ nol(N),
+ input(X,Y,0,N,[],L).
+
+
+searchnext(X,Y,[H|T]):-
+ H=[X,Y];
+ H=[Y,X];
+ searchnext(X,Y,T).
+
+onemove(_,_,[],L):-
+ write(L).
+onemove(X,Y,L,H):-
+ searchnext(X,Y,L),
+ efface([X,Y],L,N),
+ L<>N,
+ write(N),elan(line),
+ append(H,[Y],F),
+ onemove(Y,Z,N,F).
+onemove(X,Y,L,H):-
+ searchnext(X,Y,L),
+ efface([Y,X],L,N),
+ L<>N,
+ write(N),elan(line),
+ append(H,[Y],F),
+ onemove(Y,Z,N,F).
+
+
+
+go:-
+ enter(L),!,
+ onemove(X,Y,L,[X]).
+