summaryrefslogtreecommitdiff
path: root/app/mpg
diff options
context:
space:
mode:
Diffstat (limited to 'app/mpg')
-rw-r--r--app/mpg/2.2/doc/GRAPHIK.dok.e2235
-rw-r--r--app/mpg/2.2/source-disk4
-rw-r--r--app/mpg/2.2/src/AMPEX 2-1-6.GCONF84
-rw-r--r--app/mpg/2.2/src/AMPEX 3-1-4.GCONF84
-rw-r--r--app/mpg/2.2/src/Atari 3-9.GCONF119
-rw-r--r--app/mpg/2.2/src/DATAGRAPH 3-7.GCONF119
-rw-r--r--app/mpg/2.2/src/ENVIRONMENT2.GCONF5
-rw-r--r--app/mpg/2.2/src/ENVIRONMENT3.GCONF7
-rw-r--r--app/mpg/2.2/src/FKT.help24
-rw-r--r--app/mpg/2.2/src/GRAPHIK.Basis1574
-rw-r--r--app/mpg/2.2/src/GRAPHIK.Configurator946
-rw-r--r--app/mpg/2.2/src/GRAPHIK.Fkt1379
-rw-r--r--app/mpg/2.2/src/GRAPHIK.Install84
-rw-r--r--app/mpg/2.2/src/GRAPHIK.Manager925
-rw-r--r--app/mpg/2.2/src/GRAPHIK.Plot1237
-rw-r--r--app/mpg/2.2/src/GRAPHIK.Turtle139
-rw-r--r--app/mpg/2.2/src/GRAPHIK.list28
-rw-r--r--app/mpg/2.2/src/HERCULES XT.GCONF105
-rw-r--r--app/mpg/2.2/src/Muster75
-rw-r--r--app/mpg/2.2/src/NEC P-3 3-15.GCONF126
-rw-r--r--app/mpg/2.2/src/NEC P-6 MD.GCONF221
-rw-r--r--app/mpg/2.2/src/NEC P-9 2-15.HD.GCONF244
-rw-r--r--app/mpg/2.2/src/NEC P-9 2-15.MD.GCONF221
-rw-r--r--app/mpg/2.2/src/PUBLIC.insert3412
-rw-r--r--app/mpg/2.2/src/VC 404 2-7.GCONF93
-rw-r--r--app/mpg/2.2/src/VIDEOSTAR 3-6.GCONF92
-rw-r--r--app/mpg/2.2/src/WATANABE 3-8.GCONF94
-rw-r--r--app/mpg/2.2/src/ZEICHENSATZbin0 -> 9216 bytes
-rw-r--r--app/mpg/2.2/src/matrix printer130
-rw-r--r--app/mpg/2.2/src/printer.targets3
-rw-r--r--app/mpg/2.2/src/std primitives80
-rw-r--r--app/mpg/2.2/src/terminal plot114
32 files changed, 14003 insertions, 0 deletions
diff --git a/app/mpg/2.2/doc/GRAPHIK.dok.e b/app/mpg/2.2/doc/GRAPHIK.dok.e
new file mode 100644
index 0000000..7e61cd4
--- /dev/null
+++ b/app/mpg/2.2/doc/GRAPHIK.dok.e
@@ -0,0 +1,2235 @@
+#type ("prop.lq")##limit (16.0)#
+#free(10.0)#
+#headoff##bottomoff#
+
+#type("prop.breit.lq")##center##on("u")#Dokumentation des MPG-Graphik-Systems#off("u")#
+
+#free(1.0)#
+#type("prop")##center#Version 2.1 vom 10.09.87
+
+#free(0.5)#
+#center#(c) 1987 Beat Jegerlehner & Carsten Weinholz
+
+#page#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Inhaltsverzeichnis
+#type("pica.lq")##free(1.0)#
+#type("prop")##limit(16.0)##linefeed(01.0)#
+#type("pica")##on("u")#Inhaltsverzeichnis#off("u")##type("prop.lq")#
+#free(0.5)#
+#type ("prop.lq")##limit (16.0)#
+ Teil 1: Komponenten des Graphik-Systems ................... 1
+ 1.0 GRAPHIK.Basis ................................ 1
+ 2.0 GRAPHIK.Configuration/GRAPHIK.Configurator ... 1
+ 3.0 GRAPHIK.Plot ................................. 1
+ Teil 1.1: Generierung der Graphik ......................... 2
+ Teil 1.2: Tasks des Graphik-Systems ....................... 3
+ 1.0 Task: 'GRAPHIK' .............................. 3
+ 2.0 Task: 'PLOT' ................................. 3
+ 3.0 Task: 'FKT' .................................. 4
+ Teil 2: Operationen der Basisgraphik ...................... 5
+ 1.0 Paket: 'transformation' ...................... 5
+ 2.0 Paket: picture ............................... 8
+ 3.0 Paket: 'picfile' ............................. 13
+ 4.0 Paket: 'devices' ............................. 17
+ Teil 2.1: Operationen des 'device interface' .............. 19
+ 1.0 Paket: 'device interface' .................... 19
+ Teil 2.2: Operationen zur Graphik-Ausgabe ................. 23
+ 2.0 Paket: 'basisplot' ........................... 23
+ 3.0 Paket: 'plot interface' ...................... 27
+ 4.0 Paket: 'plot' ................................ 29
+ Teil 3: Konfigurierung der Graphik ........................ 30
+ Teil 3.1: Der Graphik-Konfigurator ........................ 30
+ Teil 3.2: Erstellung der Konfigurationsdateien ............ 31
+ 1.0 Pseudo-Schlüsselworte ........................ 32
+ 2.0 Pseudo-Prozeduren ............................ 34
+ Teil 4: Graphik-Applikationen ............................. 37
+ Teil 4.1: Der Funktionenplotter 'FKT' ..................... 37
+ 1.0 Allgemeines über FKT ......................... 37
+ 2.0 Das FKT-Menue ................................ 37
+ 3.0 FKT-Menuepunkte .............................. 38
+ Teil 4.2: Die TURTLE-Graphik .............................. 44
+ 1.0 Paket: 'turtlegraphics' ...................... 44
+ Stichwortverzeichnis ....................................... XX
+#page(1)#
+#head on##bottom on#
+#bottom#
+#right#Seite %
+#end#
+#head#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Teil 1: Komponenten des Graphik-Systems
+#type("pica.lq")##free(1.0)#
+#end#
+#type("pica")##on("u")##ib(1)#Teil 1: Komponenten des Graphik-Systems#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+
+ Das MPG-Graphik-System besteht aus folgenden Komponenten:
+
+ #ib(1)#1.0 GRAPHIK.Basis#ie(1)#
+
+ 1.1 #ib(2," (1.1)")#PACKET transformation#ie(2,"")#
+ - Transformations- und Umrechnungsprozeduren zur Endgerät­
+ unabhängigen Abbildung von PICTURES bzw. PICFILES.
+
+ 1.2 #ib(2," (1.2)")#PACKET picture#ie(2,"")#
+ - Verwaltung des Datentyps PICTURE, der eine Bildebene objekt­
+ orientiert beschreibt.
+
+ 1.3 #ib(2," (1.3)")#PACKET picfile#ie(2,"")#
+ - Verwaltung des Datentyps PICFILE, der ein aus verschiedenen Bild­
+ ebenen (PICTURES) bestehendes Bild und seine (allgemeine) Abbildung
+ auf den Endgeräten beschreibt.
+
+ 1.4 #ib(2," (1.4)")#PACKET devices#ie(2,"")#
+ - Allgemeine Verwaltung der verschiedenen Endgeräte.
+
+
+ #ib(1)#2.0 GRAPHIK.Configuration/GRAPHIK.Configurator#ie(1)#
+
+ 2.1 #ib(2," (2.1)")#PACKET deviceinterface#ie(2,"")#
+ - Bereitstellung der allgemeinen graphischen Basisoperationen, die
+ für jedes Endgerat gleichartig vorhanden sind.
+ - Das 'deviceinterface' wird vom 'GRAPHIK.Configurator' bei Bedarf
+ durch geeignetes Zusammenbinden veschiedener Endgerät-
+ Konfigurationsdateien automatisch erzeugt.
+
+
+ #ib(1)#3.0 GRAPHIK.Plot#ie(1)#
+
+ 3.1 #ib(2," (3.1)")#PACKET basisplot#ie(2,"")#
+ - Bereitstellung der von der EUMEL-Graphik benötigten
+ Basisoperationen.
+
+ 3.2 #ib(2," (3.2)")#PACKET plotinterface#ie(2,"")#
+ - Paket zur Ansteuerung und Kontrolle der Endgeräte.
+
+ 3.3 #ib(2," (3.3)")#PACKET plot#ie(2,"")#
+ - Ausgabeprozeduren für PICTURES bzw. PICFILES für alle Endgeräte.
+#page#
+#type("pica")##on("u")##ib(1)#Teil 1.1: Generierung der Graphik#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+ Es wird zunächst eine Task 'GRAPHIK' (o.ä.) eingerichtet.
+ Das MPG-Graphik-Sytem befindet sich auf der Diskette 'GRAPHIK 2.1':
+
+ - archive ("GRAPHIK 2.1")
+ - fetch ("GRAPHIK.Install",archive)
+ - run ("GRAPHIK.Install")
+
+ 'GRAPHIK.Install' enthält ein Generierungsprogramm, das die weitere Generierung
+ des Graphik-Systems vornimmt.
+ Existiert auf dem Archiv eine Datei 'GRAPHIK.Configuration', so wird nachge­
+ fragt, ob das Graphiksystem hinsichtlich der anzusteuernden Endgeräte neu­
+ konfiguriert('GRAPHIK.Configuration' also in Abhängigkeit von den ebenfalls
+ auf der Diskette vorhandenen Endgerät-Konfigurationsdateien neu erstellt
+ werden soll). Fehlt 'GRAPHIK.Configuration', so wird es zwangsläufig neu er­
+ stellt (siehe 'Neukonfiguration des Graphik-Systems', S. #to page ("newconf")#).
+ Mit der im Hintergrund ablaufenden Installation des Plotmanagers in der
+ (Sohn-)Task 'PLOT' (siehe 'Funktion von PLOT', S.#to page ("plotmanager")#) steht dann die Graphik allen
+ Sohntasks von 'GRAPHIK' zur Verfügung:
+
+ .
+ .
+ GRAPHIK
+ PLOT
+ FKT
+ EUCLID
+ user
+ usw.
+ .
+ .
+#page#
+#type("pica")##on("u")##ib(1)#Teil 1.2: Tasks des Graphik-Systems#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+
+ #ib(1)#1.0 Task: 'GRAPHIK'#ie(1)#
+
+ 'GRAPHIK' ist die Ausgangstask des Graphik-Systems; in ihr werden (s.o) die
+ einzelnen Graphikpakete insertiert, und stehen den Sohntasks zur Verfügung
+ (siehe 'Operationen der Basisgraphik', S. #topage("gfuncts")#). Zusätzlich kann sie den Plot­
+ manager in der Task 'PLOT' kontrollieren
+
+ #ib(1)#2.0 Task: 'PLOT'#ie(1)##goalpage("plotmanager")#
+
+ 'PLOT' enthält den Multispool-Manager des Graphik-Systems, der die indirekte
+ Ausgabe von PICFILES auf jedem Endgerät der Station ermöglicht. Der Manager
+ verwaltet im Gegensatz zum 'PRINTER' aber nicht nur eine Warteschlange bzw.
+ Server sondern mehrere (die Anzahl ist durch die Konstante 'max spools' in
+ 'GRAPHIK.Manager' festgelegt).
+ (Achtung !, eine Task kann nicht mehr als 255 Datenräume, also Einträge in
+ Warteschlangen verwalten !).
+ Sollte PLOT neben PRINTER zur graphischen Ausgabe auf dem Drucker arbei­
+ ten, so ist in PRINTER 'spool control task (/"PLOT")' einzustellen.
+ Der Plotmanager besitzt eine Kommandoebene, die wie folgt arbeitet:
+ Nach 'continue' erscheint der Prompt 'All-Plotter', der anzeigt, daß nach­
+ folgende Kommandos gleichermassen auf alle Spools/Server wirken; sollen
+ die Kommandos auf nur einen Spool/Server wirken, so ist dieser mit 'select
+ plotter' einzustellen, was durch eine Änderung des Prompts auf den
+ Plotternamen angezeigt wird.
+
+ - 2.1 #ib(2," (2.1)")#listspool#ie(2,"")#
+ Gibt Auskunft über die Inhalte und Aktivitäten aller bzw. des
+ gewählten Spools.
+
+ - 2.2 #ib(2," (2.2)")#clearspool#ie(2,"")#
+ Initialisiert nach Rückfrage alle bzw. den gewählten Spool;
+ sämtliche Einträge werden gelöscht, evtl. laufende Ausgaben
+ abgebrochen (der Server beendet).
+
+ - 2.3 #ib(2," (2.3)")#spool control#ie(2,"")#
+ (TEXT CONST control task)
+ Stellt die Task mit dem Namen 'control task' und alle ihre Söhne
+ als privilegiert ein, d.h. Kommandos wie 'start', 'stop' usw. werden
+ von diesen Tasks wie auch von Systemstasks und von 'GRAPHIK'
+ aus zugelassen.
+
+ - 2.4 #ib(2," (2.4)")#stop#ie(2,"")#
+ Unterbricht eine evtl. laufende Ausgabe und unterbindet die
+ weitere Ausgabe von Einträgen aller bzw. des gewählten Spools;
+ wobei nach Rückfrage die abgebrochene Ausgabe als erster
+ Eintrag erneut eingetragen wird.
+
+ - 2.5 #ib(2," (2.5)")#start#ie(2,"")#
+ Nimmt die Ausgabe des gewählten bzw. aller Spools wieder auf.
+
+ - 2.6 #ib(2," (2.6)")#halt#ie(2,"")#
+ Unterbindet die weitere Ausgabe von Einträgen aller bzw. des
+ gewählten Spools; evtl. laufende Ausgaben werden jedoch nicht
+ abgebrochen.
+
+ - 2.7 #ib(2," (2.7)")#select plotter#ie(2,"")#
+ Bietet als Auswahl die Endgeräte der Station an; die obenge­
+ nannten Operationen wirken danach nur auf den gewählten Spool,
+ was durch die Änderung des Prompts auf den Namen des gewählten
+ Endgerätes angezeigt wird.
+ Der Abbruch der Auswahloperation führt dementsprechend wieder
+ zur Einstellung 'All-Plotter'.
+ Das aktuell zu kontrollierende Endgerät kann jedoch auch mit
+ den Standard-Auswahloperationen gewählt werden; diese lassen
+ aber auch die Wahl von Plottern anderer Stationen zu, was im
+ Plotmanager als 'All-Plotter' gewertet wird.
+
+ Folgende Funktionen können nur auf einzelne Spools; also nicht auf
+ 'All-Plotter' angewendet werden:
+
+ - 2.8 #ib(2," (2.8)")#killer#ie(2,"")#
+ Bietet im Dialog alle im Spool enthaltenen Einträge zum Löschen
+ an.
+
+ - 2.9 #ib(2," (2.9)")#first#ie(2,"")#
+ Bietet im Dialog alle dem ersten Eintrag nachfolgenden Einträge
+ zum Vorziehen an.
+
+ #ib(1)#3.0 Task: 'FKT'#ie(1)#
+
+ Die Task 'FKT' stellt den Funktionenplotter FKT, bzw. dessen menuegesteuerten
+ Monitor als Taskmonitor zur Verfügung.
+ Wird die Task mit dem Menuepunkt
+ 'q' - in die Kommandoebene zurueck
+ verlassen, so werden alle enthaltenen PICFILES gelöscht.
+ Der Funktionenplotter wird in 'FKT' mit dem Kommando 'fktmanager' instal­
+ liert; er ist jedoch auch in jeder anderen Task mit dem Kommando 'fktplot'
+ erreichbar.
+
+#page#
+#bottom#
+#right#Seite %
+#end#
+#head#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Teil 2: Operationen der Basisgraphik
+#type("pica.lq")##free(1.0)#
+#end#
+#type("pica")##on("u")##ib(1)#Teil 2: Operationen der Basisgraphik#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+#goalpage("gfuncts")#
+ Die Pakete der Basisgraphik sind in der Datei 'GRAPHIK.Basis' enthalten, und
+ realisieren folgende Aufgaben:
+ - Vektorielle Abbildung virtueller Koordinaten unter Verwendung einer
+ Transformationsmatrix auf die konkrete Endgerät-Zeichenfläche unter
+ Berücksichtigung des eingestellten Teils der Zeichenfläche ('viewport')
+ und des Fensters ('window').
+ - Bereitstellung des Datentyps PICTURE, der die gemeinsame Manipulation
+ von Objekten ermöglicht.
+ - Bereitstellung des Datentyps PICFILE, der die gemeinsame Manipulation
+ von PICTURES hinsichtlich ihrer Ausgabe ermöglicht.
+ - Bereitstellung des Datentyps PLOTTER, der die freie Auswahl von End­
+ geräten ermöglicht, und Informationen über sie liefert.
+
+ Zu den mit '*' gekennzeichneten Beschreibungen vgl. die Beschreibung im
+ Programmierhandbuch.
+
+ #ib(1)#1.0 Paket: 'transformation'#ie(1)#
+
+ 1.1 BOOL PROC #ib(2," (1.1)")#clippedline#ie(2," (PROC)")#
+ (REAL VAR x0, y0, x1, y1)
+ - Intern verwendete Prozedur, welche die in den Variablen über­
+ gebenen Anfangs- und Endkoordinaten einer Geraden auf die
+ Ausmaße der aktuellen Endgerät-Zeichenfläche begrenzt.
+ Es wird zurückgeliefert, ob Teile der übergebenen Geraden inner­
+ halb der Zeichenfläche liegen, also gezeichnet werden müssen.
+
+ 1.2 PROC #ib(2," (1.2)")#drawingarea *#ie(2," (PROC)")#
+ (REAL VAR x cm, REAL VAR y cm, REAL VAR xp, REAL yp)
+ - Trägt in die übergebenen Variablen die Ausmaße der aktuellen
+ Endgerät-Zeichenfläche in cm und Pixel ein.
+
+ 1.3 PROC #ib(2," (1.3)")#getvalues#ie(2," (PROC)")#
+ (ROW 3 ROW 2 REAL VAR, ROW 2 ROW 2 REAL VAR,
+ ROW 4 REAL VAR, ROW 2 REAL VAR, ROW 3 REAL VAR)
+ - Intern verwendete Prozedur, die in die übergebenen Felder die
+ aktuellen Werte der Transformationsmatrix einträgt.
+
+ 1.4 BOOL PROC #ib(2," (1.4)")#newvalues#ie(2," (PROC)")#
+ - Intern verwendete Prozedur, die anzeigt, ob die Transformations­
+ matrix verändert wurde.
+
+ 1.5 PROC #ib(2," (1.5)")#oblique *#ie(2," (PROC)")#
+ (REAL CONST a, b)
+ - Stellt für o.g. Abbildungsfunktion die Projektionsart
+ 'schiefwinklig' ein; 'a;b' ist der Punkt in der X-Y-Ebene, auf den der
+ Einheitsvektor in Z-Richtung abgebildet werden soll.
+
+ 1.6 PROC #ib(2," (1.6)")#orthographic *#ie(2," (PROC)")#
+ - Stellt die Projektionsart 'Paralellprojektion' ein (s.o.).
+
+ 1.7 PROC #ib(2," (1.7)")#perspective *#ie(2," (PROC)")#
+ (REAL CONST x,y,z)
+ - Stellt die Abbildungsart 'perspektivisch' ein; 'x;y;z' gibt den
+ Fluchtpunkt der Zentralperspektive an.
+
+ 1.8 PROC #ib(2," (1.8)")#setdrawingarea#ie(2," (PROC)")#
+ (REAL CONST x cm, y cm, x p, y p)
+ - Intern verwendete Prozedur, die vorm Beginn des Zeichnens dem
+ Transformationspaket die Ausmaße der Endgerät-Zeichenfläche
+ übergibt.
+
+ 1.9 PROC #ib(2," (1.9)")#setvalues#ie(2," (PROC)")#
+ (ROW 3 ROW 2 REAL CONST, ROW 2 ROW 2 REAL CONST,
+ ROW 4 REAL CONST, ROW 2 REAL CONST, ROW 3 REAL CONST)
+ - Intern verwendete Prozedur, welche die Transformationsmatrix mit
+ den Werten der übergebenen Felder füllt.
+
+ 1.10 PROC #ib(2," (1.10)")#transform#ie(2," (PROC)")#
+ (REAL CONST x, y, z, xp, yp)
+ - Intern verwendete Prozedur zur Abbildung eines drei­
+ dimensionalen Vektors in virtuellen Koordinaten auf
+ (zweidimensionale) Bildschirmkoordinaten.
+
+ 1.11 PROC #ib(2," (1.11)")#view *#ie(2," (PROC)")#
+ (REAL CONST alpha, phi, theta)
+ - Stellt für o.g. Abbildungsfunktion zusätzlich die Drehwinkel der
+ Abbildung in Polarkoordinaten ein.
+ In der derzeitigen Version fehlerhaft !
+
+ 1.12 PROC #ib(2," (1.12)")#view *#ie(2," (PROC)")#
+ (REAL CONST alpha, phi)
+ - s.o.; ebenfalls fehlerhaft !
+
+ 1.13 PROC #ib(2," (1.13)")#view *#ie(2," (PROC)")#
+ (REAL CONST alpha)
+ - Dreht die Abbildung um den Mittelpunkt der Zeichenfläche um
+ 'alpha' Grad !
+
+ 1.14 PROC #ib(2," (1.14)")#viewport *#ie(2," (PROC)")##goalpage("viewport")#
+ (REAL CONST hormin, hormax, vertmin, vertmax)
+ - Definiert den verwendeten Teil der Endgerät-Zeichenfläche in
+ Welt- oder Gerätekoordinaten, bei Verwendung dieser Prozedur ist
+ vorangehend 'window (TRUE)' aufzurufen; damit die neuen Werte
+ auch Berücksichtigung finden.
+
+ 1. Angabe in Weltkoordinaten (cm):
+ 'hor min;vert min' - Position der unteren linken Ecke der ver­
+ wendeten Zeichenfläche in cm.
+ 'hor max;vert max' - Position der oberen rechten Ecke der ver­
+ wendeten Zeichenfläche in cm.
+
+ 2. Angabe in Gerätekoordinaten:
+ Es wird eine Angabe in Gerätekoordinaten angenommen, wenn
+ hor max < 2.0 und vert max < 2.0 gilt.
+ Die Werte werden als Bruchteile der Größe der gesamten Zei­
+ chenfläche aufgefaßt, wobei für die horizontalen Werte zu­
+ sätzlich das Verhältnis 'Horizontale/Vertikale' (i.d. Regel > 1)
+ berücksichtigt wird.
+ Das bedeutet für 'vert max' = 'hor max' = 1,
+ daß der obere Rand der spezifizierten Zeichenfläche an der
+ Oberkante der Gesamt-Zeichenfläche, und der rechte Rand an
+ der rechten Kante des durch die Gesamthöhe der Zeichenfläche
+ gegebenen Quadrates liegt (unverzerrt).
+ Soll die gesamte Zeichenfläche genutzt werden, so ist 'hor min'
+ = 'vert min' = 0 und 'vert max' = 1 zu setzen;
+ 'hor max' dagegen auf das Verhältnis 'Horizontale/Vertikale' !.
+ Die halbe horizontale Verwendung der Zeichenfläche ist durch
+ Halbierung des Seitenverhältnisses zu erreichen.
+
+ 1.15 PROC #ib(2," (1.15)")#window *#ie(2," (PROC)")#
+ (REAL CONST xmin, xmax, ymin, ymax, zmin, zmax)
+ - Stellt die Fenstergröße der virtuellen Zeichenfläche, zu der die
+ virtuellen Koordinaten in Bezug gesetzt werden sollen, mittels
+ der gegenüberliegenden Ecken 'min' und 'max' ein.
+
+ 1.16 PROC #ib(2," (1.16)")#window *#ie(2," (PROC)")#
+ (REAL CONST xmin, xmax, ymin, ymax)
+ - s.o., jedoch für zweidimensionale Darstellungen.
+
+ 1.17 PROC #ib(2," (1.17)")#window *#ie(2," (PROC)")#
+ (BOOL CONST update)
+ - Die Übergabe von TRUE verursacht die interne Neuberechnung der
+ Transformationsmatrix beim nächsten 'set values'; die immer dann
+ notwendig wird, wenn die Zeichenfläche oder das mit 'viewport'
+ eingestellte virtuelle Fenster verändert werden soll.
+#page#
+ #ib(1)#2.0 Paket: picture#ie(1)#
+
+ 2.1 #ib(2," (2.1)")#TYPE PICTURE *#ie(2,"")#
+ - Datentyp zur Verwaltung eines einfarbigen Bildes; das aus entwe­
+ der zwei- oder dreidimensionalen Objekten besteht.
+
+ 2.2 OP #ib(2," (2.2)")#:= *#ie(2," (OP)")#
+ (PICTURE VAR dest, PICTURE CONST source)
+ - Zuweisungsoperator für den Datentyp PICTURE.
+
+ 2.3 PROC #ib(2," (2.3)")#bar *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST width, height, pattern)
+ - Zeichnet in 'pic' an der aktuellen Position ein Rechteck
+ 'width/height' mit dem Muster 'pattern', wobei zu beachten ist, daß
+ die aktuelle X-Position die horizontale Position der vertikalen
+ Symmetrieachse des Rechtecks angibt.
+ Als 'pattern' z.Zt. implementiert:
+ 0 - nicht gefüllt
+ 1 - halb gefüllt (zeitaufwendig!)
+ 2 - gefüllt
+ 3 - horizontal schraffiert
+ 4 - vertikal schraffiert
+ 5 - horizontal und vertikal schraffiert
+ 6 - diagonal rechts schraffiert
+ 7 - diagonal links schraffiert
+ 8 - diagonal rechts und links schraffiert
+
+ 2.4 OP #ib(2," (2.4)")#CAT *#ie(2," (OP)")#
+ (PICTURE VAR dest, PICTURE CONST add)
+ - Fügt die Bilder 'dest' und 'add' in 'dest' zusammen.
+
+ 2.5 PROC #ib(2," (2.5)")#circle *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x, y, rad, INT CONST pattern)
+ - Zeichnet in 'pic' an der Position 'x;y' mit dem Radius 'rad' und dem
+ Muster 'pattern' gefüllt ('pattern' z.Zt. wirkungslos)
+
+ 2.6 INT PROC #ib(2," (2.6)")#dim *#ie(2," (PROC)")#
+ (PICTURE CONST pic)
+ - Liefert die für 'pic' eingestellte Dimensionalität
+ (2 - zweidimensional; 3 - dreidimensional); wobei die Dimensionali­
+ tät mit der ersten Zeichenoperation eingestellt wird.
+
+ 2.7 PROC #ib(2," (2.7)")#draw *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x, y, z)
+ - Zeichnet in 'pic' von der aktuellen Position einen Gerade zur
+ Position 'x;y'.
+
+ 2.8 PROC #ib(2," (2.8)")#draw *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x, y, z)
+ - s.o., jedoch für zweidimensionale Bilder.
+
+ 2.9 PROC #ib(2," (2.9)")#draw *#ie(2," (PROC)")#
+ (PICTURE VAR pic, TEXT CONST text, REAL CONST angle, height, width)
+ - Zeichnet in 'pic' an der aktuellen Position 'text' in der Größe
+ 'height/width' unter dem Winkel 'angle'.
+
+ 2.10 PROC #ib(2," (2.10)")#draw *#ie(2," (PROC)")#
+ (PICTURE VAR pic, TEXT CONST text)
+ - Zeichnet in 'pic' an der aktuellen Position 'text' in Standardgröße
+ und normaler Ausrichtung.
+
+ 2.11 PROC #ib(2," (2.11)")#draw cm *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x cm, y cm)
+ - Zeichnet in 'pic' eine Gerade zur cm-Position 'x;y', d.h., die Projek­
+ tionseinstellung wird nicht beachtet.
+
+ 2.12 PROC #ib(2," (2.12)")#draw cm r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx cm, dy cm)
+ - Zeichnet in 'pic' eine Gerade zur um 'dx cm;dy cm' verschobenen
+ Zeichenposition, d.h, die Projektionseinstellung wird nicht beach­
+ tet.
+
+ 2.13 PROC #ib(2," (2.13)")#draw r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy, dz)
+ - Zeichnet in 'pic' eine Gerade der Länge 'dx;dy;dz' relativ zur
+ aktuellen Position.
+
+ 2.14 PROC #ib(2," (2.14)")#draw r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy)
+ - s.o., jedoch für zweidimensionale Bilder.
+
+ 2.15 PROC #ib(2," (2.15)")#extrema *#ie(2," (PROC)")#
+ (PICTURE CONST pic, REAL VAR x min, x max, y min, y max, z min, z max)
+ - Trägt in die übergebenen Variablen die grössten und kleinsten
+ Koordinaten aller Objekte in 'pic' ein.
+
+ 2.16 PROC #ib(2," (2.16)")#extrema *#ie(2," (PROC)")#
+ (PICTURE CONST pic, REAL VAR x min, x max, y min, y max)
+ - s.o., jedoch für zweidimensionale Bilder.
+
+ 2.17 INT PROC #ib(2," (2.17)")#length *#ie(2," (PROC)")#
+ (PICTURE CONST pic)
+ - Liefert die Länge des Objekt-Verwaltungstextes von 'pic'.
+
+ 2.18 PROC #ib(2," (2.18)")#move *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x, y, z)
+ - Fährt den Zeichenstift auf 'pic' an die Position 'x;y;z'.
+
+ 2.19 PROC #ib(2," (2.19)")#move *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x, y)
+ - s.o., jedoch für zweidimensionale Bilder.
+
+ 2.20 PROC #ib(2," (2.20)")#move cm *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x cm, y cm)
+ - Die aktuelle Zeichenposition wird auf 'x cm;y cm' verschoben, wobei
+ die Darstellungsart unberücksichtigt bleibt.
+
+ 2.21 PROC #ib(2," (2.21)")#move cm r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST d xcm, d ycm)
+ - Die aktuelle Zeichenposition wird um 'd xcm;d ycm' verschoben,
+ wobei die Darstellungsart unberücksichtigt bleibt.
+
+ 2.22 PROC #ib(2," (2.22)")#move r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy, dz)
+ - Verschiebt die aktuelle Zeichenposition in 'pic' um 'dx;dy;dz'.
+
+ 2.23 PROC #ib(2," (2.23)")#move r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy)
+ - s.o., jedoch für zweidimensionale Bilder.
+
+ 2.24 PICTURE PROC #ib(2," (2.24)")#nilpicture *#ie(2," (PROC)")#
+ - Initialisierungsfunktion; liefert 'leeres Bild'.
+
+ 2.25 INT PROC #ib(2," (2.25)")#pen *#ie(2," (PROC)")#
+ (PICTURE CONST pic)
+ - Liefert den für 'pic' eingestellten Stift (Nummer 1 - 16).
+
+ 2.26 PROC #ib(2," (2.26)")#pen *#ie(2," (PROC)")#
+ (PICTURE VAR pic, INT CONST no)
+ - Stellt den Stift 'no' für 'pic' ein, wobei 'no' die Werte 1 - 16 an­
+ nehmen darf.
+
+ 2.27 PICTURE PROC #ib(2," (2.27)")#picture *#ie(2," (PROC)")#
+ (TEXT CONST objects)
+ - Die Objektbeschreibung aller Objekte eines Bildes wird in einem
+ Text verwaltet; mit dieser Prozedur wird ein TEXT im entsprechen­
+ den Format in ein PICTURE verwandelt.
+ Das Format des TEXTes: <INT> Dimension : 2- oder 3-D
+ <INT> Zeichenstift-Nummer
+ <...> Objekteinträge
+
+ Die Objekteinträge haben folgendes Format:
+ <INT> Objektcode <...> Parameter.
+
+ Objektcodes für: > Die Parameter entsprechen der
+ - draw 1 Parameterfolge der Prozeduren.
+ - move 2
+ - text 3 > Vor dem Text wird als <INT> die
+ - move r 4 Textlänge gehalten.
+ - draw r 5
+ - move cm 6
+ - draw cm 7
+ - move cm r 8
+ - draw cm r 9
+ - bar 10
+ - circle 11
+
+ 2.28 PROC #ib(2," (2.28)")#rotate *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST alpha, beta, gamma)
+ - Die Objekte von 'pic' werden gemäß den Winkeln 'alpha;beta;gamma'
+ im positiven Sinne um die X-,Y-,Z-Achse gedreht; wobei nur ein
+ Winkel <> 0.0 sein darf.
+
+ 2.29 PROC #ib(2," (2.29)")#rotate *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST alpha)
+ - Die Objekte von 'pic' werden gemäß dem Winkel 'alpha' im positiven
+ Sinne um die X-Achse gedreht.
+
+ 2.30 PROC #ib(2," (2.30)")#stretch *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST xc, yc, zc)
+ - 'pic' wird um die Faktoren 'xc;yc;zc' gestreckt oder gestaucht:
+ Faktor > 1 -> Streckung
+ Faktor < 1 -> Stauchung
+ Faktor < 0 -> zusätzlich Achsenspiegelung
+
+ 2.31 PROC #ib(2," (2.31)")#stretch *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST xc, yc)
+ - s.o., jedoch für zweidimensionale Bilder.
+
+ 2.32 TEXT PROC #ib(2," (2.32)")#text *#ie(2," (PROC)")#
+ (PICTURE CONST pic)
+ - Liefert den Objekt-Verwaltungstext von 'pic'(vergleiche
+ 'picture').
+
+ 2.33 PROC #ib(2," (2.33)")#translate *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy, dz)
+ - 'pic' wird um 'dx;dy;dz' verschoben.
+
+ 2.34 PROC #ib(2," (2.34)")#translate *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy)
+ - s.o., jedoch für zweidimensionale Bilder.
+
+ 2.35 PROC #ib(2," (2.35)")#where *#ie(2," (PROC)")#
+ (PICTURE CONST pic, REAL VAR x, y, z)
+ - Trägt die aktuelle Zeichenposition in 'pic' in die übergebenen
+ Variablen 'x;y;z' ein.
+
+ 2.36 PROC #ib(2," (2.36)")#where *#ie(2," (PROC)")#
+ (PICTURE CONST pic, REAL VAR x, y)
+ - s.o., jedoch für zweidimensionale Bilder.
+#page#
+ #ib(1)#3.0 Paket: 'picfile'#ie(1)#
+
+ 3.1 #ib(2," (3.1)")#TYPE PICFILE#ie(2,"")#
+ - Datentyp zur Verwaltung mehrerer Bilder (PICTUREs) und der
+ Darstellungsparameter.(Aktuelle Typnummer: 1102 !).
+
+ 3.2 OP #ib(2," (3.2)")#:= *#ie(2," (OP)")#
+ (PICFILE VAR dest, DATASPACE CONST source)
+ - Assoziiert das PICFILE 'dest' mit dem DATASPACE 'source'.
+
+ 3.3 OP #ib(2," (3.3)")#:= *#ie(2," (OP)")#
+ (PICFILE VAR dest, PICFILE CONST source):
+ - Assoziiert das PICFILE 'dest' mit 'source'; wie bei Files entsteht
+ keine Kopie!
+
+ 3.4 INT PROC #ib(2," (3.4)")#background *#ie(2," (PROC)")#
+ (PICFILE CONST pf)
+ - Liefert die auf 'pf' eingestellte Hintergrundfarbe.
+
+ 3.5 PROC #ib(2," (3.5)")#background *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST no)
+ - Stellt die Farbe 'no' als Hintergrundfarbe für 'pf' ein:
+
+ 3.6 PROC #ib(2," (3.6)")#delete picture *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Löscht das aktuelle Bild in 'pf'.
+
+ 3.7 PROC #ib(2," (3.7)")#down *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Positioniert in 'pf' ein Bild weiter.
+
+ 3.8 PROC #ib(2," (3.8)")#down *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST step)
+ - Positioniert in 'pf' 'step'-Bilder weiter.
+
+ 3.9 BOOL PROC #ib(2," (3.9)")#eof *#ie(2," (PROC)")#
+ (PICFILE CONST)
+ - Liefert zurück, ob das aktuelle Bild auch das letzte des PICFILES
+ ist.
+
+ 3.10 PROC #ib(2," (3.10)")#extrema *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL VAR x min, x max, y min, y max, z min, z max)
+ - Trägt in die übergebenen Variablen die kleinsten bzw. größten
+ Koordinaten aller Bilder in 'pf' ein.
+
+ 3.11 PROC #ib(2," (3.11)")#extrema *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL VAR x min, x max, y min, y max)
+ - s.o., jedoch für zweidimensionale PICFILEs.
+
+ 3.12 PROC #ib(2," (3.12)")#get *#ie(2," (PROC)")#
+ (PICFILE VAR pf, FILE VAR source)
+ - Liest die in 'source' enthaltenen Informationen über Bilder nach
+ 'pf' ein.
+
+ 3.13 PROC #ib(2," (3.13)")#get values *#ie(2," (PROC)")#
+ (PICFILE CONST pf, ROW 3 ROW 2 REAL VAR,ROW 2 ROW 2 REAL VAR,
+ ROW 4 REAL VAR, ROW 2 REAL VAR, ROW 3 REAL VAR)
+ - Trägt die Werte der Transformationsmatrix von 'pf' in die über­
+ gebenen Variablenfelder ein.
+
+ 3.14 PROC #ib(2," (3.14)")#insert picture *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Fügt vor das aktuelle Bild von 'pf' ein leeres Bild ein.
+
+ 3.15 BOOL PROC #ib(2," (3.15)")#is first picture *#ie(2," (PROC)")#
+ (PICFILE CONST pf)
+ - Liefert zurück, ob das aktuelle auch das erste Bild von 'pf' ist.
+
+ 3.16 PROC #ib(2," (3.16)")#oblique *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST a, b)
+ - Stellt für 'pf' die Projektionsart 'schiefwinklig' ein; 'a;b' ist der
+ Punkt in der X-Y-Ebene, auf den der Einheitsvektor in Z-Richtung
+ abgebildet werden soll.
+
+ 3.17 PROC #ib(2," (3.17)")#perspective *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST x, y, z)
+ - Stellt für 'pf' die Projektionsart 'perspektivisch' ein; 'x;y;z' gibt
+ den Fluchtpunkt der Zentralperspektive an.
+
+ 3.18 INT PROC #ib(2," (3.18)")#picture no *#ie(2," (PROC)")#
+ (PICFILE CONST pf)
+ - Liefert die Nummer des aktuellen Bildes von 'pf' zurück.
+
+ 3.19 INT PROC #ib(2," (3.19)")#pictures *#ie(2," (PROC)")#
+ (PICFILE CONST pf)
+ - Liefert die Anzahl der in 'pf' enthaltenen Bilder zurück.
+
+ 3.20 PROC #ib(2," (3.20)")#put *#ie(2," (PROC)")#
+ (FILE VAR dest, PICFILE CONST pf)
+ - Liest 'pf' nach 'dest' aus.
+
+ 3.21 PROC #ib(2," (3.21)")#put picture *#ie(2," (PROC)")#
+ (PICFILE VAR pf, PICTURE CONST ins)
+ - Fügt das Bild 'ins' vor das aktuelle Bild von 'pf' ein.
+
+ 3.22 PROC #ib(2," (3.22)")#read picture *#ie(2," (PROC)")#
+ (PICFILE VAR pf, PICTURE VAR pic)
+ - Trägt das aktuelle Bild von 'pf' in 'pic' ein.
+
+ 3.23 PROC #ib(2," (3.23)")#selected pen *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST no, INT VAR color, thickness, linetype,
+ BOOL VAR visible)
+ - Trägt in die übergebenen Variablen die für den Stift 'no' aktuell
+ eingestellten Werte ein, wobei 'no' die Werte 1 - 16 annehmen darf.
+
+ 3.24 PROC #ib(2," (3.24)")#select pen *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST no, INT CONST color, thickness, linetype,
+ BOOL CONST visible)
+ - Stellt für den Stift 'no' von 'pf' die übergebenen Werte für Farbe,
+ Stiftbreite, Art des Linenzuges ein, wobei 'no' die Werte 1 - 16
+ annehmen darf.
+ 'visible' = FALSE bedeutet, das die mit diesem Stift gezogenen
+ Linien innerhalb bereits durch das Zeichnen entstandener Flächen
+ nicht gezeichnet werden, die Flächen sie also 'verdecken'.
+ Vordefiniert sind:
+ - color:
+ <0 - nicht standardisierte XOR-Modi
+ 0 - Löschstift
+ 1 - Standardfarbe d. Endgerätes (s/w)
+ 2 - rot
+ 3 - blau
+ 4 - grün
+ 5 - schwarz
+ 6 - weiss
+ n - Sonderfarben
+ - thickness:
+ 0 - Standardstrichstärke d. Endgerätes
+ n - Strichstärke in 1/10 mm
+ - linetype:
+ 0 - keine Linie
+ 1 - durchgängige Linie
+ 2 - gepunktete Linie
+ 3 - kurz gesrichelte Linie
+ 4 - lang gestrichelte Linie
+ 5 - Strichpunktlinie
+ (Standard-Definitionen, die Linetypes können
+ über 'basisplot' auch verändert werden.)
+
+ 3.25 PROC #ib(2," (3.25)")#set values *#ie(2," (PROC)")#
+ (PICFILE VAR pf, ROW 3 ROW 2 REAL CONST,
+ ROW 2 ROW 2 REAL CONST,
+ ROW 4 REAL CONST,
+ ROW 2 REAL CONST, ROW 3 REAL CONST)
+ - Die übergebenen Felder werden in die Transformationsmatrix von
+ 'pf' übernommen.
+
+ 3.26 PROC #ib(2," (3.26)")#to eof *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Positioniert auf das letzte Bild von 'pf'.
+
+ 3.27 PROC #ib(2," (3.27)")#to first pic *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Positioniert auf das erste Bild von 'pf'.
+
+ 3.28 PROC #ib(2," (3.28)")#to pic *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST n)
+ - Positioniert auf das 'n'-te Bild von 'pf'.
+
+ 3.29 PROC #ib(2," (3.29)")#up *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Positioniert in 'pf' ein Bild zurück.
+
+ 3.30 PROC #ib(2," (3.30)")#up *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST step)
+ - Positioniert in 'pf' 'step'-Bilder zurück.
+
+ 3.31 PROC #ib(2," (3.31)")#view *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST alpha, phi, theta)
+ - Stellt für die Abbildung von 'pf' zusätzlich die Drehwinkel der
+ Abbildung in Polarkoordinaten ein.
+ In der derzeitigen Version fehlerhaft !
+
+ 3.32 PROC #ib(2," (3.32)")#view *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST alpha, phi)
+ - s.o.; in der derzeitigen Version fehlerhaft !
+
+ 3.33 PROC #ib(2," (3.33)")#view *#ie(2," (PROC)")#
+ (REAL CONST alpha)
+ - Dreht das Bild um den Mittelpunkt der Zeichenfläche um 'alpha'
+ Grad !
+
+ 3.34 PROC #ib(2," (3.34)")#viewport *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST hor min, hor max, vert min, vert max)
+ - Spezifiziert die Zeichenfläche, auf die 'pf' abgebildet werden soll.
+ Siehe dazu auch 'viewport' im 'transformation'-Paket (S. #topage("viewport")#).
+
+ 3.35 PROC #ib(2," (3.35)")#window *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST x min, x max, y min, y max, z min, z max)
+ - Definiert die virtuelle Zeichenfläche von 'pf'.
+
+ 3.36 PROC #ib(2," (3.36)")#window *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST x min, x max, y min, y max)
+ - s.o., jedoch für zweidimensionale PICFILEs.
+
+ 3.37 PROC #ib(2," (3.37)")#write picture *#ie(2," (PROC)")#
+ (PICFILE VAR pf, PICTURE CONST new)
+ - Überschreibt das aktuelle Bild von 'pf' mit 'new'.
+#page#
+ #ib(1)#4.0 Paket: 'devices'#ie(1)#
+
+ 4.1 #ib(2," (4.1)")#TYPE PLOTTER#ie(2,"")#
+ - Verwaltungstyp zur Repräsentation eines Endgerätes hinsichtlich
+ seiner Station, seines Kanals, seines Namens sowie seiner Zeichen­
+ fläche. Dabei ist zu beachten, daß der gültige Endgerät-
+ Descriptor, der zur Selektion verwendet wird, aus Station, Kanal
+ und Namen besteht; die Namen also nicht eindeutig vergeben
+ werden müssen.
+
+ 4.2 OP #ib(2," (4.2)")#:=#ie(2," (OP)")#
+ (PLOTTER VAR dest, PLOTTER CONST source)
+ - Zuweisungsoperator für den Datentyp 'PLOTTER'.
+
+ 4.3 BOOL OP #ib(2," (4.3)")#=#ie(2," (OP)")#
+ (PLOTTER CONST left, right)
+ - Vergleichsoperator für den Datentyp 'PLOTTER'.
+
+ 4.4 INT PROC #ib(2," (4.4)")#actual plotter#ie(2," (PROC)")#
+ - Liefert die interne Verwaltungsnummer des eingestellten End­
+ gerätes (Kein Endgerät eingestellt -> 0).
+
+ 4.5 INT PROC #ib(2," (4.5)")#channel#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Liefert den Kanal von 'plotter'.
+
+ 4.6 PROC #ib(2," (4.6)")#drawingarea#ie(2," (PROC)")#
+ (REAL VAR x cm, y cm, INT VAR x p, y p)
+ - Trägt in die übergebenen Variablen die Maße der
+ Zeichenfläche des eingestellten Endgerätes ein.
+
+ 4.7 PROC #ib(2," (4.7)")#drawingarea#ie(2," (PROC)")#
+ (REAL VAR x cm, y cm, INT VAR x p, y p, PLOTTER CONST plotter)
+ - Trägt in die übergebenen Variablen die Maße der Zeichenfläche
+ von 'plotter' ein.
+
+ 4.8 PROC #ib(2," (4.8)")#install plotter#ie(2," (PROC)")#
+ (TARGET VAR new descriptors)
+ - Übergibt dem Verwaltungspacket den zu verwaltenden Satz End­
+ geräte. Wird intern vom 'device interface' verwendet, kann aber
+ auch im nachhinein zur Installation von Endgeräten anderer
+ Stationen oder zum Ausblenden von Endgeräten dienen. Nachdem
+ die Graphik installiert wurde, können jedoch keine neuen sta­
+ tionseigenen Endgeräte erzeugt werden (oder nur verwaltungs­
+ seitig, d.h. die Ansteuerung fehlt).
+
+ 4.9 TEXT PROC #ib(2," (4.9)")#name#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Liefert den Namen von 'plotter'
+
+ 4.10 PLOTTER PROC #ib(2," (4.10)")#no plotter#ie(2," (PROC)")#
+ - Liefert den Endgerät-Descriptor 'kein Plotter'.
+
+ 4.11 PLOTTER PROC #ib(2," (4.11)")#plotter#ie(2," (PROC)")#
+ - Liefert den Endgerät-Descriptor des eingestellten Endgerätes.
+
+ 4.12 PLOTTER PROC #ib(2," (4.12)")#plotter#ie(2," (PROC)")#
+ (TEXT CONST descriptor)
+ - Liefert den Endgerät-Descriptor des durch 'descriptor' beschrie­
+ benen Endgerätes.
+ 'descriptor' hat folgendes Format:
+ <Stationsnummer>/<Kanalnummer>/Endgerätname,
+ wobei nicht vorhandene Endgeräte abgelehnt werden.
+
+ 4.13 TEXT PROC #ib(2," (4.13)")#plotterinfo#ie(2," (PROC)")#
+ (TEXT CONST descriptor, INT CONST length)
+ - Liefert einen auf die Länge 'length' eingerichteten TEXT, der
+ 'descriptor' in aufbereiteter Form wiedergibt.
+ Format von 'descriptor' s.o.
+
+ 4.14 THESAURUS PROC #ib(2," (4.14)")#plotters#ie(2," (PROC)")#
+ - Liefert alle vorhandenen Endgeräte in Form o.g. Descriptoren.
+
+ 4.15 PROC #ib(2," (4.15)")#select plotter#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Stellt 'plotter' als aktuelles Endgerät ein.
+
+ 4.16 PROC #ib(2," (4.16)")#select plotter#ie(2," (PROC)")#
+ (TEXT CONST descriptor)
+ - Stellt das durch 'descriptor' beschriebene Endgerät als aktuelles
+ Endgerät ein.
+
+ 4.17 PROC #ib(2," (4.17)")#select plotter#ie(2," (PROC)")#
+ - Bietet eine Auswahl aller Endgeräte an, und stellt das gewählte
+ als aktuelles Endgerät ein.
+
+ 4.18 INT PROC #ib(2," (4.18)")#station#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Liefert die Stationsnummer von 'plotter' zurück.
+#page#
+#type("pica")##on("u")##ib(1)#Teil 2.1: Operationen des 'device interface'#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+
+ Das automatisch vom 'GRAPHIK.Configurator' anhand von Konfigurationsda­
+ teien erstellte Paket 'device interface' realisiert die normierte, jedoch von
+ der Zeichenfläche des Endgeräts abhängige Ansteuerung der verschiedenen
+ Endgeräte. Es entspricht dabei dem Paket 'Endgerät.Basis' der EUMEL-Graphik,
+ geht aber teilweise über dessen Leistungen hinaus.Hinweis: Falls diese Lei­
+ stung nicht bereits endgerätseitig implementiert ist, wird nicht geclipped;
+ die Überschreitung der Zeichengrenzen hat also Undefiniertes zur Folge.
+ Zudem ist die Mehrheit der Prozeduren ausschließlich nach 'initplot' funk­
+ tionsfähig.
+
+ #ib(1)#1.0 Paket: 'device interface'#ie(1)#
+
+ 1.1 INT PROC #ib(2," (1.1)")#background#ie(2," (PROC)")#
+ - Liefert die Nummer der aktuell für den Hintergrund eingestellten
+ Farbe zurück.
+
+ 1.2 PROC #ib(2," (1.2)")#background#ie(2," (PROC)")#
+ (INT CONST color no)
+ - Stellt die Farbe 'color no' als Hintergrundfarbe ein.
+
+ 1.3 PROC #ib(2," (1.3)")#box#ie(2," (PROC)")#
+ (INT CONST x1, y1, x2, y2, pattern)
+ - Zeichnet ein Rechteck mit den gegenüberliegenden Ecken 'x1;y1'
+ und 'x2;y2', das mit dem Muster 'pattern' gefüllt wird, wobei
+ 'pattern' endgerätspezifisch ist.
+
+ 1.4 PROC #ib(2," (1.4)")#circle#ie(2," (PROC)")#
+ (INT CONST x, y, rad, from, to)
+ - Zeichnet an der Stelle 'x;y' einen Kreis (bzw. Kreissegment) des
+ Radius 'rad' mit dem Anfangswinkel 'from' und dem Endwinkel 'to'.
+
+ 1.5 PROC #ib(2," (1.5)")#clear#ie(2," (PROC)")#
+ - Initialisiert die Zeichenfläche des aktuellen Endgerätes, wobei
+ die Zeichenposition auf '0;0' und die Standardfarben
+ gesetzt werden.
+
+ 1.6 PROC #ib(2," (1.6)")#clear#ie(2," (PROC)")#
+ (BOOL CONST onoff)
+ - Die Übergabe von FALSE bewirkt, daß alle nachfolgenden Aufrufe
+ von 'clear' wirkungslos sind; mit TRUE werden sie entsprechend
+ wieder aktiviert.
+
+ 1.7 INT PROC #ib(2," (1.7)")#color#ie(2," (PROC)")#
+ (INT CONST color no)
+ - Liefert den für die Farbe 'color no' eingestellten Farbwert im
+ normierten RGB-Code von 0-999.
+
+ 1.8 INT PROC #ib(2," (1.8)")#colors#ie(2," (PROC)")#
+ - Liefert die Anzahl möglicher Farben für das aktuelle Endgerät.
+
+ 1.9 PROC #ib(2," (1.9)")#draw to#ie(2," (PROC)")#
+ (INT CONST x, y)
+ - Zieht von der aktuellen Zeichenposition eine Gerade zur Position
+ 'x;y'.
+
+ 1.10 PROC #ib(2," (1.10)")#endplot#ie(2," (PROC)")#
+ - Wartet auf eine Eingabe des Benutzers und beendet dann die
+ graphische Ausgabe; ggf. durch Umschalten in den Text-Modus.
+ Falls möglich, sollte die ausgegebene Graphik jedoch auf dem
+ Bildschirm erhalten bleiben.
+
+ 1.11 PROC #ib(2," (1.11)")#end plot#ie(2," (PROC)")#
+ (BOOL CONST onoff)
+ - Die Übergabe von FALSE bewirkt, daß alle nachfolgenden Aufrufe
+ von 'endplot' wirkungslos sind; mit TRUE werden sie entsprechend
+ wieder aktiviert.
+
+ 1.12 PROC #ib(2," (1.12)")#fill#ie(2," (PROC)")#
+ (INT CONST x, y, INT CONST pattern)
+ - Die Umgebung von 'x;y' wird mit dem Muster 'pattern' gefüllt, wobei
+ sowohl 'pattern' als auch die genauen Füll-Bedingungen (Art der
+ Umrahmung usw.) endgerätspezifisch sind.
+
+ 1.13 INT PROC #ib(2," (1.13)")#foreground#ie(2," (PROC)")#
+ - Liefert die Nummer der aktuell für den Vordergrund eingestellten
+ Farbe zurück.
+
+ 1.14 PROC #ib(2," (1.14)")#foreground#ie(2," (PROC)")#
+ (INT CONST color no)
+ - Stellt die Farbe 'color no' als Vordergrundfarbe ein.
+
+ 1.15 PROC #ib(2," (1.15)")#get cursor#ie(2," (PROC)")#
+ (INT VAR x, y, TEXT VAR exit char)
+ - Nach Aufruf dieser Prozedur sollte das Endgerät die Eingabe
+ einer Position mittels eines graphischen Cursors (i.d.R.
+ Fadenkreuz) ermöglichen. Dieser Modus soll bleibt solange auf­
+ rechterhalten bis eine Taste gedrückt wird; in 'x;y' findet sich
+ dann die Position des Cursors, und in 'exit char' die gedrückte
+ Taste.
+ Diese Prozedur ist jedoch nicht für das Ein bzw. Ausschalten des
+ graphischen Cursors zuständig, d.h der eingeschaltete Cursor ist
+ ständig sichtbar; bei ausgeschaltetem Cursor kehrt die Prozedur
+ sofort mit 'exit char' = ""0"" zurück.
+
+ 1.16 BOOL PROC #ib(2," (1.16)")#graphik cursor#ie(2," (PROC)")#
+ - Diese Prozedur gibt an, ob graphische Eingabeoperationen und
+ die dazugehörigen Operationen auf dem aktuellen Endgerät ver­
+ fügbar sind.
+
+ 1.17 PROC #ib(2," (1.17)")#graphik cursor#ie(2," (PROC)")#
+ (INT CONST x, y, BOOL CONST onoff)
+ - Diese Prozedur schaltet den graphischen Cursor an bzw. aus oder
+ positioniert ihn. Nach dem Einschalten sollte der Cursor perma­
+ nent sichtbar sein. Ein erneutes Einschalten hat die
+ Neupositionierung des Cursors zur Folge.
+
+ 1.18 PROC #ib(2," (1.18)")#home#ie(2," (PROC)")#
+ - Positioniert die aktuelle Zeichenposition auf den Punkt '0;0'; bei
+ eingeschaltetem graphischen Cursor diesen auf die Mitte der
+ Zeichenfläche.
+
+ 1.19 PROC #ib(2," (1.19)")#init plot#ie(2," (PROC)")#
+ - Initialisiert das aktuelle Endgerät zur graphischen Ausgabe,
+ (schaltet ggf. in den Graphik-Modus), wobei der Bildschirm jedoch
+ möglichst nicht gelöscht werden sollte.
+
+ 1.20 PROC #ib(2," (1.20)")#move to#ie(2," (PROC)")#
+ (INT CONST xp, yp)
+ - Die Position 'xp;yp' wird neue Stiftposition; die Wirkung ist unde­
+ finiert bei Überschreitung der Bildschrimgrenzen.
+
+ 1.21 PROC #ib(2," (1.21)")#prepare#ie(2," (PROC)")#
+ - Bereitet die Ausgabe auf einem Endgerät vor; d.h. die Task wird an
+ den entsprechenden Kanal angekoppelt, und andere Tasks am An­
+ koppeln gehindert (z.B. 'stop' des PRINTER-Servers). Dabei wird die
+ Prozedur erst dann verlassen, wenn die Aktion erfolgreich been­
+ det ist. (z.B. bis zur Freigabe des Kanals).
+
+
+ 1.22 PROC #ib(2," (1.22)")#set color#ie(2," (PROC)")#
+ (INT CONST no, rgb)
+ - Setzt die Farbe von 'no' auf die normierte RGB-Farbkombination
+ 'rgb' (0 - 999).
+
+ 1.23 PROC #ib(2," (1.23)")#setmarker#ie(2," (PROC)")#
+ (INT CONST xp, yp, type)
+ - Zeichnet an der Position 'xp;yp' eine Markierung; wobei die Wir­
+ kung bei Überschreitung der Bildschirmgrenzen undefiniert ist.
+ Als 'type' sollten vorhanden sein:
+ 0 - Kreuz '+'
+ 1 - Kreuz diagonal 'x'
+ - weitere beliebig
+
+ 1.24 PROC #ib(2," (1.24)")#setpalette#ie(2," (PROC)")#
+ - Initialisiert die Farben des Endgerätes gemäß den im Paket ge­
+ setzten Farben.
+
+ 1.25 PROC #ib(2," (1.25)")#setpixel#ie(2," (PROC)")#
+ (INT CONST xp, yp)
+ - Setzt das Pixel 'xp;yp' in der aktuellen Schreibfarbe.
+
+ 1.26 PROC #ib(2," (1.26)")#stdcolors#ie(2," (PROC)")#
+ - Initialisiert die Paket-Intern verwendete Farbtabelle auf die
+ standardmäßig für das Endgerät definierten Farben;
+ wobei die Farben jedoch nicht auf dem Endgerät eingestellt
+ werden.
+
+ 1.27 PROC #ib(2," (1.27)")#stdcolors#ie(2," (PROC)")#
+ (BOOL CONST onoff)
+ - Die Übergabe von FALSE bewirkt, daß alle nachfolgenden Aufrufe
+ von 'stdcolors' wirkungslos sind; mit TRUE werden sie entspre­
+ chend wieder aktiviert.
+#page#
+#type("pica")##on("u")##ib(1)#Teil 2.2: Operationen zur Graphik-Ausgabe#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+ Die Pakete zur Ausgabe von Graphiken (PICFILES) sind in der Datei
+ 'GRAPHIK.Basis' enthalten, und realisieren folgende Leistungen:
+ - Im Datentyp PICTURE bzw. PICFILE in Codierter Form verwendete Ausgabe­
+ prozeduren auf einzelne Objekte unter Berücksichtigung der Abbil­
+ dungsparameter und Zeichenfläche.
+ - Kommunikations- und Kontrolloperationen auf die Task 'PLOT' zur
+ indirekten Ausgabe von PICFILES.
+ - Ausgabeoperationen auf den Datentyp PICTURE bzw. PICFILE unter Be­
+ rücksichtung des eingestellten Endgerätes.
+ Wird für die Angabe von Koordinaten der Typ REAL verwendet, so handelt es
+ sich um virtuelle Koordinaten, d.h. die Ausgabe-Parameter wie 'viewport' und
+ 'window' werden berücksichtigt; bei Verwendung von INT ist die Ausgabe end­
+ gerätspezifisch.
+
+ #ib(1)#2.0 Paket: 'basisplot'#ie(1)#
+
+ 2.1 PROC #ib(2," (2.1)")#bar *#ie(2," (PROC)")#
+ (INT CONST x, y, height, width, pattern)
+ - Zeichnet an der Position 'x;y' ein Rechteck der Länge/Breite
+ 'width/height' mit dem Muster 'pattern', wobei 'x;y' die untere linke
+ Ecke des Rechtecks angibt.
+ Als 'pattern' z.Zt. implementiert:
+ 0 - nicht gefüllt
+ 1 - halb gefüllt
+ 2 - gefüllt
+ 3 - horizontal schraffiert
+ 4 - vertikal schraffiert
+ 5 - horizontal und vertikal schraffiert
+ 6 - diagonal rechts schraffiert
+ 7 - diagonal links schraffiert
+ 8 - diagonal rechts und links schraffiert
+
+ 2.2 PROC #ib(2," (2.2)")#bar *#ie(2," (PROC)")#
+ (REAL CONST height, width, INT CONST pattern)
+ - siehe oben, jedoch mit Ausgangspunkt an der aktuellen Zeichen­
+ position, wobei zu beachten ist, daß die x-Koordinate die horizon­
+ tale Position der vertikalen Symmetrieachse des Rechtecks angibt.
+
+ 2.3 PROC #ib(2," (2.3)")#beginplot#ie(2," (PROC)")#
+ - Leitet die graphische Ausgabe ein, wobei das Endgerät in seinen
+ Startzustand versetzt wird, und dem Transformationspaket die
+ Abmessungen der Zeichenfläche mitgeteilt werden.
+
+ 2.4 PROC #ib(2," (2.4)")#box *#ie(2," (PROC)")#
+ - Zeichnet eine Umrahmung der gesamten Zeichenfläche (Nicht nur
+ des verwendeten Teiles).
+
+ 2.5 PROC #ib(2," (2.5)")#circle *#ie(2," (PROC)")#
+ (REAL CONST rad, from, to, INT CONST pattern)
+ - Zeichnet an aktuellen Position einen Kreis od. ein Kreissegment
+ des Radius 'rad'; beginnend bei 'from' bis zum Endwinkel 'to' und
+ gefüllt mit dem Muster 'pattern' ('pattern' z.Zt. nicht
+ implementiert).
+
+ 2.6 PROC #ib(2," (2.6)")#draw *#ie(2," (PROC)")#
+ (INT CONST x, y)
+ - Zeichnet von der aktuellen Position eine Gerade zur Position 'x;y'.
+
+ 2.7 PROC #ib(2," (2.7)")#draw *#ie(2," (PROC)")#
+ (INT CONST x0, y0, x1, y1)
+ - Zieht eine Gerade von der Position 'x0;y0' bis zur Position 'x1;y1'.
+
+ 2.8 PROC #ib(2," (2.8)")#draw *#ie(2," (PROC)")#
+ (REAL CONST x, y, z)
+ - Zieht von der aktuellen Zeichenposition eine Gerade zur
+ (transformierten) 3-D Position 'x;y;z'.
+
+ 2.9 PROC #ib(2," (2.9)")#draw *#ie(2," (PROC)")#
+ (REAL CONST x, y)
+ - s.o., jedoch für zweidimensionale Bilder.
+
+ 2.10 PROC #ib(2," (2.10)")#draw *#ie(2," (PROC)")#
+ (TEXT CONST text, REAL CONST angle, height, width)
+ - Zeichnet den TEXT 'text' ab der aktuellen Zeichenposition unter
+ dem Winkel 'angle' und in der Höhe/Breite 'height;width'.
+
+ 2.11 PROC #ib(2," (2.11)")#draw *#ie(2," (PROC)")#
+ - s.o., jedoch in Standard-Ausrichtung (0 Grad) und
+ Standard-Höhe/Breite (0.5/0.5).
+
+ 2.12 PROC #ib(2," (2.12)")#draw cm *#ie(2," (PROC)")#
+ (REAL CONST x cm, y cm)
+ - Zeichnet von der aktuellen Position eine Gerade zur cm-Position
+ 'x cm;y cm'.
+
+ 2.13 PROC #ib(2," (2.13)")#draw cm r *#ie(2," (PROC)")#
+ (REAL CONST x cm, REAL CONST y cm)
+ - Zieht von der aktuellen Zeichenposition eine Gerade zur um 'x cm;
+ y cm' verschobenen Zielposition.
+
+ 2.14 PROC #ib(2," (2.14)")#draw r *#ie(2," (PROC)")#
+ (REAL CONST dx, dy)
+ - Zieht von der aktuellen Zeichenposition eine Gerade zur um 'dx;dy'
+ Einheiten verschobenen Zielposition.
+
+ 2.15 PROC #ib(2," (2.15)")#draw r *#ie(2," (PROC)")#
+ (REAL CONST dx, dy, dz)
+ - Zeichnet von der aktuellen Zeichenposition eine Gerade zur um
+ 'dx;dy;dz' Einheiten verschobenen und transformierten 3-D Ziel­
+ position.
+
+ 2.16 PROC #ib(2," (2.16)")#hidden lines *#ie(2," (PROC)")#
+ (BOOL CONST visible)
+ - Schaltet die vektorisierte Speicherung aller zukünftigen Aus­
+ gabe ein (FALSE) bzw. aus.Ist dieser Modus eingeschaltet, so werden
+ alle durch vorheriges Zeichnen entstandenen Flächen beim Zeichen
+ berücksichtigt, also nicht übermalt; sie 'verdecken' die weiteren
+ Linien.
+
+ 2.17 PROC #ib(2," (2.17)")#linetype#ie(2," (PROC)")#
+ (INT CONST line no, TEXT CONST bitpattern)
+ - Stellt für den Linientyp 'line no' das Bitmuster 'bitpattern' ein;
+ wobei der 'bitpattern'-TEXT ausschließlich aus den Zeichen '0' und
+ '1' bestehen sollte.
+
+ 2.18 PROC #ib(2," (2.18)")#move *#ie(2," (PROC)")#
+ (INT CONST x,y)
+ - Zeichnet von der aktuellen Position eine Gerade zur Position 'x;y'.
+
+ 2.19 PROC #ib(2," (2.19)")#move *#ie(2," (PROC)")#
+ (REAL CONST x, y, z)
+ - Zeichnet von der aktuellen Position eine Gerade zur trans­
+ formierten 3-D-Position 'x;y;z'
+
+ 2.20 PROC #ib(2," (2.20)")#move *#ie(2," (PROC)")#
+ (REAL CONST x, y)
+ - s.o., jedoch für zweidimensionale Bilder.
+
+ 2.21 PROC #ib(2," (2.21)")#move cm#ie(2," (PROC)")#
+ (REAL CONST x cm, y cm)
+ - Setzt die aktuelle Zeichenposition auf die cm-Position 'x cm,;y cm'.
+
+ 2.22 PROC #ib(2," (2.22)")#move cm r *#ie(2," (PROC)")#
+ (REAL CONST d x cm, d y cm)
+ - Zeichnet von der aktuellen Position eine Gerade zur um
+ 'd x cm;d y cm' verschobenen Zielposition.
+
+ 2.23 PROC #ib(2," (2.23)")#move r *#ie(2," (PROC)")#
+ (REAL CONST d x, d y, d z)
+ - Zeichnet von der aktuellen Position eine Gerade zur um 'd x;d y;d z'
+ Einheiten verschobenen und transformierten Zielposition.
+
+ 2.24 PROC #ib(2," (2.24)")#move r *#ie(2," (PROC)")#
+ (REAL CONST d x, d y)
+ - s.o., jedoch für zweidimensionale Bilder.
+
+ 2.25 PROC #ib(2," (2.25)")#pen *#ie(2," (PROC)")#
+ (INT CONST background, foreground, thickness, linetype)
+ - Aktiviert für alle folgenden Ausgaben mit virtuellen Koordi­
+ naten den Hintergrund 'background'; die Schreibfarbe
+ 'foreground'; die Zeichenstärke 'thickness' in 1/10 mm und den
+ Linientyp 'linetype' (i.d.R. 1-6). Vergleiche 'select pen'.
+
+ 2.26 PROC #ib(2," (2.26)")#reset *#ie(2," (PROC)")#
+ - Die mit 'hidden lines (FALSE)' vektorisiert abgespeicherte
+ Ausgabe wird gelöscht.
+
+ 2.27 PROC #ib(2," (2.27)")#reset linetypes *#ie(2," (PROC)")#
+ - Setzt die Linientypen 1-6 auf Standard-Linientypen: 1 - durch­
+ gängige Linie
+ 2 - gepunktete Linie
+ 3 - kurz gestrichelte Linie
+ 4 - lang gestrichelte Linie
+ 5 - Strichpunktlinie
+
+ 2.28 PROC #ib(2," (2.28)")#reset zeichensatz *#ie(2," (PROC)")#
+ - Setzt den Zeichensatz auf den Standard-Zeichensatz 'ZEICHENSATZ'.
+
+ 2.29 PROC #ib(2," (2.29)")#where *#ie(2," (PROC)")#
+ (REAL VAR x, y, z)
+ - Trägt die aktuelle Zeichenposition als (retransformierte) 3-D
+ Position in die übergeben Variablen ein.
+
+ 2.30 PROC #ib(2," (2.30)")#where *#ie(2," (PROC)")#
+ (REAL VAR x, y)
+ - s.o., jedoch für zweidimensionale Bilder.
+
+ 2.31 PROC #ib(2," (2.31)")#zeichensatz *#ie(2," (PROC)")#
+ (TEXT CONST zeichenname)
+ - Lädt den Zeichensatz 'zeichenname' zur Verwendung bei Beschrif­
+ tungen.
+#page#
+ #ib(1)#3.0 Paket: 'plot interface'#ie(1)#
+
+ 3.1 THESAURUS OP #ib(2," (3.1)")#ALL#ie(2," (OP)")#
+ (PLOTTER CONST plotter)
+ - Liefert die Namen der z.Zt. im Spool 'plotter' zur indirekten
+ Graphik-Ausgabe gespoolten task-eigenen PICFILES.
+ Bei Aufruf aus 'GRAPHIK' werden die Namen aller zur Ausgabe
+ gespoolten PICFILES geliefert.
+
+ 3.2 PROC #ib(2," (3.2)")#erase#ie(2," (PROC)")#
+ (TEXT CONST picname, PLOTTER CONST plotter)
+ - Löscht nach Rückfrage das im Spool 'plotter' zur indirekten
+ Graphik-Ausgabe gespoolte task-eigene PICFILE 'picname'.
+ Bei Aufruf aus 'GRAPHIK' ist auch das Löschen fremder zur Ausgabe
+ gespoolter PICFILES möglich.
+
+ 3.3 PROC #ib(2," (3.3)")#erase#ie(2," (PROC)")#
+ (THESAURUS CONST piclist, PLOTTER CONST plotter)
+ - Löscht im Dialog alle in 'piclist' und im Spool 'plotter' zur in­
+ direkten Graphik-Ausgabe gespoolten task-eigenen PICFILES.
+ Bei Aufruf aus 'GRAPHIK' ist auch das Löschen fremder zur Ausgabe
+ gespoolter PICFILES möglich.
+
+ 3.4 BOOL PROC #ib(2," (3.4)")#exists#ie(2," (PROC)")#
+ (TEXT CONST picname, PLOTTER CONST plotter)
+ - Liefert zurück, ob z.Zt. im Spool 'plotter' ein task-eigenes PICFILE
+ 'picname' zur indirekten Graphik-Ausgabe gespoolt wird.
+ Bei Aufruf aus 'GRAPHIK' kann auch die Existenz fremder zur Aus­
+ gabe gespoolter PICFILES erfragt werden.
+
+ 3.5 PROC #ib(2," (3.5)")#first#ie(2," (PROC)")#
+ (TEXT CONST picname, PLOTTER CONST plotter)
+ - Zieht das im Spool 'plotter' zur indirekten Ausgabe gespoolte
+ PICFILE 'picname' an die erste Stelle der Warteschlange. Der Auf­
+ ruf ist nur aus 'GRAPHIK' zulässig.
+
+ 3.6 PROC #ib(2," (3.6)")#generate plotmanager#ie(2," (PROC)")#
+ - Erzeugt die Task 'PLOT', in der dann im Hintergrund der Plot­
+ manager insertiert wird. Dabei darf 'PLOT' zuvor nicht existieren,
+ und in der Task muß die Datei 'GRAPHIK.Manager' vorhanden sein.
+
+ 3.7 PROC #ib(2," (3.7)")#halt#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Unterbindet die weitere indirekte Graphik-Ausgabe aus dem Spool
+ 'plotter'; eine aktuell laufende Ausgabe wird jedoch nicht ab­
+ gebrochen. Der Aufruf ist nur aus 'GRAPHIK' zulässig.
+
+ 3.8 PROC #ib(2," (3.8)")#list#ie(2," (PROC)")#
+ (FILE VAR list file, PLOTTER CONST plotter)
+ - Erzeugt in 'list file' eine Inhalts/Aktivitätsübersicht des Spools
+ 'plotter'.
+
+ 3.9 PROC #ib(2," (3.9)")#list#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Zeigt eine Inhalts/Aktivitätsübersicht des Spools 'plotter'.
+
+ 3.10 THESAURUS PROC #ib(2," (3.10)")#picfiles#ie(2," (PROC)")#
+ - Liefert eine Liste der Namen aller in der Task enthaltenen
+ PICFILES.
+
+ 3.11 PROC #ib(2," (3.11)")#save#ie(2," (PROC)")#
+ (TEXT CONST picname, PLOTTER CONST plotter)
+ - Sendet das PICFILE 'picname' zwecks indirekter Graphik-Ausgabe
+ zum Spool 'plotter'.
+
+ 3.12 PROC #ib(2," (3.12)")#save#ie(2," (PROC)")#
+ (THESAURUS CONST piclist, PLOTTER CONST plotter)
+ - Sendet alle in 'piclist' namentlich enthaltenen PICFILES zwecks
+ indirekter Graphik-Ausgabe zum Spool 'plotter'.
+
+ 3.13 PROC #ib(2," (3.13)")#start#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Nimmt die zuvor mit 'halt','wait for halt','stop' oder spoolseitig
+ unterbrochene indirekte Graphik-Ausgabe des Spools 'plotter'
+ wieder auf. Der Aufruf ist nur aus 'GRAPHIK' zulässig.
+
+ 3.14 PROC #ib(2," (3.14)")#stop#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Unterbricht sofort die aktuell laufende Ausgabe des Spools
+ 'plotter', und unterbindet weitere Ausgaben. Nach Rückfrage wird
+ das PICFILE, das aktuell ausgegeben wurde, erneut an erster
+ Steller der Warteschlange eingetragen.
+
+ 3.15 PROC #ib(2," (3.15)")#wait for halt#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Unterbindet die weitere Ausgabe der
+ gespoolten PICFILES, und wartet bis die aktuell laufende Ausgabe
+ beendet ist.
+#page#
+ #ib(1)#4.0 Paket: 'plot'#ie(1)#
+
+ 4.1 PROC #ib(2," (4.1)")#plot *#ie(2," (PROC)")#
+ (PICTURE CONST picture)
+ - Ausgabe der Objektebene 'picture', unter Verwendung des in
+ 'picture' angegebenen Stiftes gemäß seiner aktuellen Einstellung
+ im 'basisplot'.Nur für Direkt-Ausgaben verwendbar.
+
+ 4.2 PROC #ib(2," (4.2)")#plot *#ie(2," (PROC)")#
+ (PICFILE CONST pf)
+ - Ausgabe des Bildes 'pf' unter vollständiger Berücksichtung der in
+ 'pf' mit 'select pen';'window';'viewport' usw. eingestellten
+ Ausgabeparameter. Nur für Direkt-Ausgaben verwendbar.
+
+ 4.3 PROC #ib(2," (4.3)")#plot *#ie(2," (PROC)")#
+ (TEXT CONST picfile name)
+ - Direkte oder indirekte Ausgabe des Bildes 'picfile name'.
+ Bei direkter Ausgabe wird obiges 'plot' verwendet; bei indirekter
+ Ausgabe wird das PICFILE an den aktuell eingestellten Spool zur
+ graphischen Ausgabe gesendet.
+#page#
+#bottom#
+#right#Seite %
+#end#
+#head#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Teil 3: Konfigurierung der Graphik
+#type("pica.lq")##free(1.0)#
+#end#
+#type("pica")##on("u")##ib(1)#Teil 3: Konfigurierung der Graphik#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+
+#type("pica")##on("u")##ib(1)#Teil 3.1: Der Graphik-Konfigurator#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+#goalpage("newconf")#
+ Die MPG-EUMEL-Graphik besitzt eine normierte Schnittstelle zu allen graphischen
+ Endgeräten. Diese wird vom Programm 'GRAPHIK.Configurator' aus verschiede­
+ nen Dateien, die einer gewissen Syntax zu genügen haben, zu einem Paket
+ namens 'device interface' zusammengefügt. Diese Dateien enthalten verschie­
+ dene Informationen und endgerätspezifische ELAN-Prozeduren, die zur
+ Erzeugung graphischer Primitiva wie Gerade, Kreis, Rechteck und zur Be­
+ rechnung der konkreten Abbildung graphischer Objekte sowie zur Realisa­
+ tion von Eingaben benötigt werden. Das Konfigurationsprogramm erkennt
+ diese Dateien an der Namensendung '.GCONF', und bietet diese zu
+ Programmbeginn zur Auswahl an.
+ Dann werden die gewählten Dateien inhaltlich untersucht und die relevan­
+ ten Informationen, Rümpfe der benötigten Prozeduren sowie alle vom Benut­
+ zer zusätzlich eingetragenen globalen Objekte (globale Variablen,
+ LET-Objekte, zusätzlich benötigte Prozeduren usw.) vom Programm extrahiert
+ und zwischengespeichert.
+ Im letzten Schritt erstellt das Programm schließlich das Paket 'device
+ interface' in der Datei 'GRAPHIK.Configuration', indem die zwischengespei­
+ cherten Texte sinnvoll zusammengefügt werden.
+ Die benötigten Konfigurationsdateien sind relativ einfach zu erstellen, da
+ sich der Programmierer ausschließlich mit der Realisation der geforderten
+ Leistungen auf einem Endgerät-Typ befassen kann, da die programmseitige
+ Einbindung ins Graphiksystem vom Konfigurationsprogramm vorgenommen
+ wird.
+#page#
+#type("pica")##on("u")##ib(1)#Teil 3.2: Erstellung der Konfigurationsdateien#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+ Namensgebung: "<Endgerätname><Kanalangaben>.GCONF"
+ Konfigurationsdateien zur Anbindung eines Endgerät-Types auf der
+ eigenen Station enthalten die benötigten ELAN-Quelltexte zur Realisa­
+ tion der geforderten Leistungen und weitere Verwaltungs- und Berech­
+ nungsoperationen.
+ Das Konfigurationsprogramm erkennt die relevanten Daten bzw. Quelltexte
+ dieser Dateien an verschiedenen Pseudo-Schlüsselworten bzw. Pseudo-
+ Prozedurdeklarationen, wobei die Namensgebung hinsichtlich des Pro­
+ zedurnamens, der Parameter sowie ihrer Namen vollständig festgelegt ist.
+ Daher ist es unzulässig, Parameternamen zu ändern oder Delimiter
+ (Semikolon, Doppelpunkt) fortzulassen.
+ Derartige Fehler werden jedoch i.d.R. vom Konfigurationsprogramm
+ erkannt und gemeldet, wohingegen Fehler in den Prozedurrümpfen, den
+ zusätzlichen Prozeduren bzw. das Fehlen zusätzlich benötigter Pro­
+ zeduren nicht erkannt, sondern erst beim Compilieren des Gesamt-Paketes
+ vom ELAN-Compiler gemeldet werden.
+ (Die Korrektur im Gesamt-Paket sollte unterlassen werden, vielmehr ist
+ der Fehler in der entsprechenden Konfigurationsdatei zu beheben, falls
+ nicht einfach die Einbindung eines zusätzlichen Paketes vergessen
+ wurde.)
+ Zudem ist zu beachten, daß die benötigten Prozedurrümpfe vom Kon­
+ figurationsprogramm in Refinements umgewandelt werden, und zusätz­
+ liche Objekte (Prozeduren, LET-Objekte, Variablen) einfach mit ein­
+ gebunden werden, so daß:
+ - Globale und lokale Variablen eindeutig für alle! Konfigurations­
+ dateien benannt werden müssen.
+ (Zweckmässig: ... VAR endgerätname variablenname)
+ - Zusätzliche Prozeduren und LET-Objekte ebenso eindeutig benannt
+ werden müssen.
+ - Überflüssige Delimiter, die aber vom ELAN-Compiler nicht bemängelt
+ werden (z.B. Punkt am Ende des Prozedurrumpfes) nicht vorkommen
+ dürfen.
+ - Nicht realisierbare Pseudo-Prozeduren mit leerem Rumpf enthalten
+ sein müssen (z.B. Vordergrund/Hintergrund od. Farben bei
+ Monochrom-Endgeräten)
+ - Prozedur-Köpfe bzw. -Enden allein in einer Zeile und an ihrem Anfang
+ stehen müssen.
+
+ Namensgebung: "ENVIRONMENT.GCONF"
+ Dient zur verwaltungsseitigen Einbindung von Endgeräten anderer
+ Stationen, da für diese Endgeräte nur die Verwaltungsinformationen
+ benötigt werden, weil die konkrete Anpassung auf der anderen Station
+ erfolgt.
+ Die in 'ENVIRONMENT.GCONF' zeilenweise enthaltenen Informationen werden
+ dem Benutzer bei der Auswahl der Konfigurationsdateien mit angeboten; er
+ kann sie aber auch 'von Hand' in die THESAURUS-Auswahl einfügen.
+
+ Namensgebung: "Dateizweck" (also beliebig)
+ Darüberhinaus existieren weitere Dateien, die globale Prozeduren und
+ weitere Objekte enthalten, die für verschiedene Endgerät-Anpassungen
+ nützlich sein können, wie z.B. unten beschriebene Dateien:
+ - 'std primitives'
+ Enthält Prozeduren zur softwareseitigen Emulation von zwar gefor­
+ derten, hardwareseitig aber eventuell nicht bereitgestellten
+ Leistungen wie 'circle' und 'box'.
+ - 'matrix printer'
+ Enthält Prozeduren zur Erzeugung von Geraden und Füllmustern auf
+ einer Bitmatrix, die zur graphischen Ausgabe auf Druckern benötigt
+ wird.
+ - 'terminal plot'
+ Enthält grundlegende Prozeduren zur (behelfsmäßigen) Ausgabe von
+ Graphiken auf Ascii-Terminals (Zeichenorientiert, nicht graphikfähig)
+
+ Folgende Pseudo-Schlüsselworte bzw. Pseudo-Prozeduren werden vom
+ Konfigurationsprogramm erkannt und behandelt:
+
+ #ib(1)#1.0 Pseudo-Schlüsselworte#ie(1)#
+
+ 1.1 #ib(2," (1.1)")#COLORS#ie(2,"")#
+ Syntax: COLORS "RGB-Kombinationen";
+ - Dient der Definition der Standard-Farben.
+ - "RGB-Kombinationen": (TEXT) Pro Farbe 3-ziffrige RGB-
+ (Rot-Grün-Blau)-
+ Kombinationen in normierter
+ Notation
+ (jeder Farbanteil wird durch
+ die Ziffern 0-9 dargestellt;
+ sollte das Endgerät dieser
+ Notation nicht genügen, so ist
+ eine anteilige Umrechnung
+ vorzunehmen).
+ Die erste RGB-Kombination
+ wird für die Hintergrundfarbe
+ verwendet (i.d.R. 000), bei
+ monochromen Endgeräten ist
+ also "000999" einzusetzen.
+
+ 1.2 #ib(2," (1.2)")#EDITOR#ie(2,"")#
+ Syntax: EDITOR;
+ - Schlüsselwort, das dem Konfigurationsprogramm anzeigt, daß
+ folgende Eingabeprozeduren vorhanden sind:
+ - 'graphik cursor'
+ - 'get cursor'
+ - 'set marker'
+ Fehlt das Schlüsselwort, so können o.g. Pseudo-Prozeduren weg­
+ gelasssen werden, brauchen also nicht mit leerer Leistung
+ implementiert werden.
+
+ 1.3 #ib(2," (1.3)")#INCLUDE#ie(2,"")#
+ Syntax: INCLUDE "Name der Includedatei";
+ - Schlüsselwort, mit dem weitere Dateien in die Konfigurationsdatei
+ textuell eingebunden werden können (s.o).
+
+ 1.4 #ib(2," (1.4)")#LINK#ie(2,"")#
+ Syntax: LINK <Station>/<Kanal>, .... ;
+ - Dient zur Anbindung mehrerer Endgeräte an einen Endgerät-Typ,
+ die hier genannten Kanäle werden eigenständig verwaltet, aber
+ wie das bei 'PLOTTER' definierte Endgerät angesteuert; wobei für
+ alle Endgeräte der gleiche Name gilt, sie also durch die Kanal­
+ nummer unterschieden werden.
+ Durch Kommata getrennt, können mit dieser Anweisung beliebig
+ viele Endgeräte zusätzlich angebunden werden.
+ - <Station> : (INT) Stationsnummer des Endgerätes
+ (eigene Station)
+ - <Kanal> : (INT) Kanalnummer des Endgerätes
+
+ 1.5 #ib(2," (1.5)")#PLOTTER#ie(2,"")#
+ Syntax: PLOTTER "Endgerätname",<Station>,<Kanal>,
+ <Xpixel>,<Ypixel>,<Xcm>,<Ycm>;
+ - Dient zur Erkennung als Endgerät-Konfigurationsdatei, und zur
+ Übergabe der verwaltungsseitig benötigten
+ Endgerät-Spezifikationen:
+ - "Endgerätname": (TEXT) Name des Endgerätes
+ - <Station> : (INT) Stationsnummer des Endgerätes
+ (eigene Station)
+ - <Kanal> : (INT) Kanalnummer des Endgerätes
+ Jedes Endgerät wird über diese drei Werte eindeutig identifiziert,
+ der Endgerätname kann also mehrfach verwendet werden.
+ - <Xpixel> : (INT) X-Rasterkoordinate des letzten
+ Pixels in X-Richtung (i.d.R
+ adressierbare Pixel - 1)
+ - <Ypixel> : (INT) Y-Rasterkoordinate des letzten
+ Pixels in Y-Richtung (s.o.)
+ - <Xcm> : (REAL) Breite der Zeichenfläche in cm.
+ - <Ycm> : (REAL) Höhe der Zeiuchenfläche in cm.
+ (Möglichst genau ausmessen od. berechnen, um Verzerrungen zu
+ vermeiden)
+ 'PLOTTER' muß als erstes in der Konfigurationsdatei stehen!
+
+ #ib(1)#2.0 Pseudo-Prozeduren#ie(1)#
+
+ 2.1 PROC #ib(2," (2.1)")#background#ie(2," (PROC)")#
+ Syntax: PROC background (INT VAR type):
+ - Stellt die Hintergrundfarbe 'type' ein. Ist bei monochromen End­
+ geräten mit leerer Leistung zu implementieren.In 'type' ist die
+ tatsächlich eingestellte Hintergrundfarbe angegeben, womit die
+ erbrachte Leistung kontrolliert werden kann.
+
+ 2.2 PROC #ib(2," (2.2)")#box#ie(2," (PROC)")#
+ Syntax: PROC box (INT CONST x1, y1, x2, y2, pattern):
+ - Zeichnet ein Rechteck mit den gegenüberliegenden Ecken
+ 'x1;y1/x2;y2'. Sollte das Endgerät diese Leistung nicht erbringen,
+ so muß 'std box' aus 'std.GCONF' mit gleichen Parametern aufge­
+ rufen werden.
+ 'pattern' als Füllmuster kann endgerätspezifisch implementiert
+ werden, wobei von System nur 'pattern' = 0 verwendet wird, was ein
+ ungefülltes Rechteck anfordert.
+
+ 2.3 PROC #ib(2," (2.3)")#circle#ie(2," (PROC)")#
+ Syntax: PROC circle (INT CONST x, y, rad, from, to):
+ - Zeichnet einen Kreis oder ein Kreissegment an den Raster-
+ Koordinaten 'x;y', die auch neue Zeichenposition werden. 'rad' gibt
+ den Radius und 'from,to' den Start bzw. Endwinkel im mathematisch
+ positivem Sinne an.
+ Sollte das Endgerät diese Leistung nicht erbringen, so muß 'std
+ circle' aus 'std.GCONF' mit gleichen Parametern aufgerufen werden.
+
+ 2.4 PROC #ib(2," (2.4)")#clear#ie(2," (PROC)")#
+ Syntax: PROC clear:
+ - Löscht den Bildschirm bzw. initialisiert das Ausgabe-Raster.
+ Die Zeichenposition wird '0;0' und die Standardfarben werden
+ eingestellt.
+
+ 2.5 PROC #ib(2," (2.5)")#drawto#ie(2," (PROC)")#
+ Syntax: PROC drawto (INT CONST x, y):
+ - Zieht von der aktuellen Zeichenposition eine Gerade zu den Ko­
+ ordinaten 'x;y', die Zeichenposition wird entsprechend geändert.
+
+ 2.6 PROC #ib(2," (2.6)")#endplot#ie(2," (PROC)")#
+ Syntax: PROC endplot:
+ - Schließt die Graphik-Ausgabe auf einem Endgerät ab; evtl. Wechsel
+ in den Text-Modus, ggf. Cursor einschalten.
+ Bei Terminals sollte der Bildschirm nicht gelöscht werden.
+
+ 2.7 PROC #ib(2," (2.7)")#fill#ie(2," (PROC)")#
+ Syntax: PROC fill (INT CONST x, y, pattern):
+ - Zusätzliche vom System nicht verwendete Leistung zum Füllen von
+ Polygonen (rundum geschlossen), wobei die genau erbrachte Lei­
+ stung und die Bedingungen endgerätspezifisch sind.
+
+ 2.8 PROC #ib(2," (2.8)")#foreground#ie(2," (PROC)")#
+ Syntax: PROC foreground (INT VAR type):
+ - Stellt die Vordergrundfarbe 'type' ein. Ist bei monochromen
+ Endgeräten mit leerer Leistung zu implementieren.In 'type' ist die
+ tatsächlich eingestellte Hintergrundfarbe angegeben, womit die
+ erbrachte Leistung kontrolliert werden kann.
+
+ 2.9 PROC #ib(2," (2.9)")#get cursor#ie(2," (PROC)")#
+ Syntax: PROC get cursor (INT VAR x, y, TEXT VAR exit char):
+ - Wartet auf eine Eingabe vom Endgerät, wobei der Cursor beweglich
+ bleiben muß. Wird eine Taste gedrückt, so wird deren Code in 'exit
+ char' und die aktuelle Position des Cursors in 'x;y' eingetragen.
+ Der Cursor sollte nur innerhalb dieser Prozedur beweglich sein,
+ aber immer sichtbar bleiben (falls er eingeschaltet ist).
+
+ 2.10 PROC #ib(2," (2.10)")#graphik cursor#ie(2," (PROC)")#
+ Syntax: PROC graphik cursor (INT CONST x, y, BOOL CONST on):
+ - Schaltet einen endgerätseitig vorhandenen graphischen Cursor
+ (i.d.R Fadenkreuz) ein oder aus bzw. setzt ihn auf eine bestimmte
+ Position.
+ Mit 'on' = TRUE wird der Cursor dauerhaft! eingeschaltet bzw. neu
+ positioniert, falls er bereits eingeschaltet war.
+ Mit 'on' = FALSE wird er grundsätzlich abgeschaltet.
+ Durch Einschalten des Cursors wird die Wirkung von 'home'
+ verändert:
+ normal - 'home' positioniert die Zeichenposition auf
+ '0;0'
+ cursor - 'home' positioniert die Zeichenposition und
+ den graphischen Cursor auf die Mitte der
+ Zeichenfläche.
+
+ 2.11 PROC #ib(2," (2.11)")#home#ie(2," (PROC)")#
+ Syntax: PROC home:
+ - Die Zeichenposition wird auf '0;0' eingestellt; ist ein graphischer
+ Cursor eingeschaltet, so sollte dieser, sowie die Zeichenposition,
+ jedoch auf den Mittelpunkt der Zeichenfläche gesetzt werden.
+
+ 2.12 PROC #ib(2," (2.12)")#initplot#ie(2," (PROC)")#
+ Syntax: PROC initplot:
+ - Bereitet die Graphik-Ausgabe auf einem Endgerät vor; evtl.
+ Wechsel in den Graphik-Modus, ggf. Cursor abschalten.
+ Bei Terminals sollte der Bildschirm nicht gelöscht werden.
+
+ 2.13 PROC #ib(2," (2.13)")#moveto#ie(2," (PROC)")#
+ Syntax: PROC moveto (INT CONST x, y):
+ - Die Zeichenposition wird auf die Koordinaten 'x;y' gesetzt, bei
+ Überschreitung der Zeichenfläche ist die Wirkung undefiniert.
+
+ 2.14 PROC #ib(2," (2.14)")#prepare#ie(2," (PROC)")#
+ Syntax: PROC prepare:
+ - Bereitet die Ausgabe auf einem Kanal vor.
+ Die eigene Task sollte an den Kanal angekoppelt, und andere Tasks
+ ggf. am Ankoppeln gehindert bzw. abgekoppelt werden (z.B. der
+ PRINTER-Server bei Drucker-Graphik). Es darf erst nach erfolg­
+ reichem Abschluß der Aktion zurückgekehrt werden.
+
+ 2.15 PROC #ib(2," (2.15)")#set marker#ie(2," (PROC)")#
+ Syntax: PROC set marker (INT CONST x, y, type):
+ - Zeichnet an der Position 'x;y', die auch neue Zeichenposition wird,
+ eine Markierung. Folgende Markierungsarten können systemseitig
+ verwendet werden:
+ 0 - Kreuz '+'
+ 1 - Kreuz diagonal 'x'
+ Weitere Typen können endgerätspezifisch implementiert werden.
+
+ 2.16 PROC #ib(2," (2.16)")#setpalette#ie(2," (PROC)")#
+ Syntax: PROC setpalette:
+ - Stellt die aktuell eingestellten RGB-Kombinationen auf dem End­
+ gerät ein. Dazu sind die vom Konfigurationsprogramm
+ hinzugefügten Prozeduren 'colors' und 'color' zu verwenden:
+ INT PROC colors
+ - Liefert die Anzahl der für das Endgerät möglichen Farben
+ (abgeleitet aus den mit 'COLOR' angebenen
+ Standard-Kombinationen).
+ INT PROC color (INT CONST no)
+ - Liefert die normierte RGB-Kombination der für 'no' ein­
+ gestellten Farbe (0 - 999). Die Rückgabe von 'maxint' (32767)
+ bedeutet: Farbe nicht initialisiert oder existiert nicht.
+
+ 2.17 PROC #ib(2," (2.17)")#setpixel#ie(2," (PROC)")#
+ Syntax: PROC setpixel (INT CONST x, y):
+ - Setzt ein Pixel an den Raster-Koordinaten 'x;y'.
+#page#
+#bottom#
+#right#Seite %
+#end#
+#head#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Teil 4: Graphik-Applikationen
+#type("pica.lq")##free(1.0)#
+#end#
+#type("pica")##on("u")##ib(1)#Teil 4: Graphik-Applikationen#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+
+#type("pica")##on("u")##ib(1)#Teil 4.1: Der Funktionenplotter 'FKT'#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+ Mit diesem Programmpaket kann man für beliebige reelle und reellwertige
+ Funktionen Graphen erstellen. Diese Graphen werden im System gespeichert.
+
+ Zur Ausgabe der erstellten Graphen stehen alle graphikfähigen Endgeräte
+ zur Verfügung.
+
+ #ib(1)#1.0 Allgemeines über FKT#ie(1)#
+ Zu einer Zeichnung, wie sie mit 'FKT' erstellt werden kann, gehören
+ folgende Eigenschaften:
+ - Der Name der Zeichnung (zum Wiederfinden)
+ - Das Format
+ - Der Graph mit den Achsen bzw. dem Rahmen.
+
+ Es können beliebig viele Zeichnungen angelegt und aufbewahrt werden,
+ wobei der Name aller Zeichnungen mit "PICFILE." beginnt.
+
+ Es wird von FKT zwischen den Definitions- und Wertebereich einerseits
+ und dem Format anderseits unterschieden:
+ - Der Definitionsbereich wird vom Benutzer gewählt. Er gibt das
+ Intervall an, über dem der Graph gezeichnet wird. Der
+ Wertebereich wird vom Rechner automatisch ermittelt.
+ - Das Format besteht aus der Angabe von vier Werten, die Auskunft
+ geben über die maximale Ausdehnung der Koordinatenachsen, wobei
+ die Zeichnung auf den Endgeräten stets so abgebildet wird, daß sie
+ unverzerrt in maximaler Größe (also im größtmöglichen Quadrat)
+ gezeichnet wird.
+
+ Der Funktionenplotter FKT ist in allen Sohntasks von 'GRAPHIK' verfüg­
+ bar, zusätzlich existiert die Task 'FKT', in der das FKT-Menue als
+ Kommandoebene verwendet wird.
+
+ #ib(1)#2.0 Das FKT-Menue#ie(1)#
+ Das Menue des Funktionenplotters ist wie folgt aufgebaut:
+ - in der obersten Zeile wird der eingegebene Funktionsterm angezeigt
+ - die nachfolgende Zeile zeigt in eckigen Klammern den Definitions­
+ bereich und die Schachtelung des Intervalles, über dem der Graph
+ gezeichnet wird.
+ - dann folgt ebenfalls in eckigen Klammern der von FKT selbst zu
+ ermittelnde Wertebereich der Funktion innerhalb des zuvor
+ definierten Intervalles.
+ Wird kein Funktionsterm angezeigt, oder erscheinen in den eckigen
+ Klammern Sternchen, so wurde noch kein Funktionsterm bzw.
+ Definitionsbereich eingegeben, oder der Wertebereich noch nicht
+ ermittelt.
+ - Der Bereich zwischen o.g Anzeige und der Auflistung der Menuepunkte
+ ist der Dialogbereich, in dem weitere Anfragen an den Benutzer oder
+ auch Fehlermeldungen erscheinen.
+ - Unterhalb der Bildschirmmitte werden die unten beschriebenen
+ Menuepunkte zur Auswahl aufgeführt.
+ - Dann folgt der Endgerät-Auswahlbereich, das Endgerät, auf dem eine
+ Zeichnung ausgegeben werden soll, kann mit den Tasten 'Links' bzw.
+ 'Rechts' eingestellt werden, wobei der Name des aktuell eingestellten
+ Endgerätes invertiert erscheint.
+ - Als unterste Zeile der FKT-Tapete folgt der Eingabebereich, hier wird
+ der Benutzer zur Eingabe eines bei den Menuepunkten genannten
+ Buchstabens aufgefordert, und dieser bei einem zulässigen
+ Tastendruck dort angezeigt.
+
+ #ib(1)#3.0 FKT-Menuepunkte#ie(1)#
+
+ Jede Eingabe oder Operation kann durch Drücken der Taste 'ESC'
+ abgebrochen werden, die Eingabe wird dann ignoriert, und im Dialog­
+ bereich erscheint die Fehlermeldung 'F E H L E R : Abgebrochen'.
+
+ 3.1 #ib(2," (3.1)")#(f) Funktionsterm eingeben#ie(2,"")#
+ Im Dialogbereich wird die Eingabe des Funktionsterms erwartet, wobei
+ als Variable im Term 'x' verwendet werden muß.
+ Es stehen alle mathematischen Funktionen des EUMEL-Systems zur
+ Verfügung, sofern sie reelle Werte (REAL) zurückliefern.
+ Beispiele von Funktionstermen (alternative Möglichkeiten in eckigen,
+ Erklärungen in runden Klammern):
+
+ 2*x
+ [2x]
+ 2x*x + 3x ­ 5
+ [2.0*x*x + 3.0*x ­ 5.0]
+ 0.7 * sqrt (x) (sqrt : Quadratwurzel aus)
+ log10 (x) (log10 : 10­er Logar.)
+ ln (3x) (ln : Nat. Logar.)
+ 2**x (** : Potenzieren)
+ exp (1/x)
+ [e**(1/x)] (exp : Expon.Fktn)
+ arctan (pi*x) (arctan: arkus tangens )
+ sin (x) (sin : Sinus in Radiant )
+ sind (x) (sind : Sinus in Altgrad )
+ 1/(x*x+1)
+
+ Die Klammern dürfen dabei NICHT weggelassen werden, es sind nur
+ runde Klammern zulässig, auch geschachtelt, wie z.B. in:
+
+ log10 (abs (sin (x) + 5)) (abs : Absolutbetrag )
+
+ Ein Dezimalkomma gibt es nicht, sondern nur den Dezimalpunkt.
+
+ Beispiele von abschnittsweise definierten Funktionen:
+
+ IF x < 5 THEN x*x ELSE sqrt (x ­ 5) END IF
+ IF x = 0 THEN 0 ELSE 1/x END IF
+ IF x < 0 THEN x ELIF x = 0 THEN 1 ELSE x*x END IF
+
+ Die sog. Schlüsselworte "IF" "THEN" "ELIF" "ELSE" "END IF" müssen
+ dabei immer in der angegebenen Form (alle, in der angegebenen Reihen­
+ folge, vollständig aus Großbuchstaben) auftauchen.
+
+ IF --+--> THEN --+--> ELSE --> END IF
+ | |
+ | |
+ +--- ELIF --+
+
+
+ Es können bei IF auch mehrere Bedingungen mit logischem OR oder AND
+ verknüpft werden:
+
+ IF x <= 0 OR x > 100 THEN 0 ELSE x*x END IF
+
+ Hat die Funktion eine Definitionslücke an einer bereits bekannten
+ Stelle, so kann dies im Term auf folgende Art berücksichtigt werden,
+ z.B.:
+
+ IF x = 0 THEN luecke ELSE 1/x END IF
+ IF x < ­0.05 THEN ­1/x ELIF x > 0.05 THEN 1/x ELSE luecke END IF
+
+ Taucht eine unvorhergesehene Definitionslücke auf, so wird beim
+ Erstellen des Wertebereichs eine entspr. Fehlermeldung ausgegeben.
+ Dann muß entweder der Funktionsterm durch Fallunterscheidung (s.o.)
+ angepaßt, oder der Definitionsbereich geändert werden.
+
+ Graphen mit Definitionslücken können auch in zwei oder mehr Teilen
+ erstellt werden, nämlich jeweils über den zusammenhängenden
+ Definitionsintervallen, die keine Lücke enthalten. Dazu muß jeweils
+ die Zeichnung ergänzt (siehe '(z) Zeichnung anfertigen') werden.
+
+ Fehlerquelle: Der Funktionsterm ist fehlerhaft.
+ Es tauchen z.B. dem Rechner unbekannte Operationen auf,
+ Multiplikationszeichen fehlen, andere Symbole als 'x' wurden
+ für die Variable benutzt, 'END IF' fehlt o.ä.
+
+ 3.2 #ib(2," (3.2)")#(d) Definitionsbereich waehlen#ie(2,"")#
+ Im Dialogbereich wird die Eingabe von Unter- und Obergrenze erwartet,
+ wobei Untergrenze < Obergrenze gilt, ansonsten wird die Eingabe der
+ Obergrenze nochmals gefordert.
+ Erscheinen in der zug. Informationszeile Sterne, so ist die gewählte
+ Genauigkeit zu groß und sollte umgewählt werden.
+
+ Fehlerquelle: Der Funktionsterm ist noch nicht vorhanden.
+
+ 3.3 #ib(2," (3.3)")#(w) Wertebereich ermitteln lassen#ie(2,"")#
+ Es werden automatisch der größte und kleinste Funktionswert
+ ermittelt, also die tatsächlichen Grenzen des Wertebereichs.
+ Erscheinen in der zug. Informationszeile Sterne, so ist die gewählte
+ Genauigkeit zu groß und sollte umgewählt werden.
+
+ 3.4 #ib(2," (3.4)")#(z) Zeichnung anfertigen#ie(2,"")#
+ Eine Zeichnung kann auf allen zur Verfügung stehenden Geräten
+ ausgegeben werden, wenn sie erzeugt ist.
+ Mit diesem Menuepunkt werden die Zeichnungen nur erstellt, d.h. der
+ Graph erscheint noch nicht auf einem Ausgabegerät.
+ Diese Zeichnungen werden dann im System aufbewahrt und können
+ somit mehrfach ausgegeben werden.
+
+ Im Dialogbereich wird zunächst der Name der Zeichnung angefordert,
+ dieser beginnt grundsätzlich mit dem Prefix 'PICFILE.', das nicht
+ verändert werden kann.
+ Dabei wird als Ergänzung des Namens der Funktionsterm angeboten, so
+ daß die Zeichnung z.B. 'PICFILE.sin(x)' heißt.
+ Dieser Teil des Namens kann aber frei verändert werden.
+ Existiert bereits eine Zeichnung gleichen Namens, so erscheint im
+ Dialogbereich eine Anfrage, wie verfahren werden soll, wobei
+ folgende Möglichkeiten genannt werden:
+
+ - <l> : Die alte Zeichnung wird gelöscht.
+ - <n> : Der Name wird erneut zur Änderung angeboten.
+ - <e> : Die neue Zeichnung, welche hiernach erstellt wird, wird an die
+ schon existierende Zeichnung angahängt. Dies ist vorteil­
+ haft, wenn mehrere od. abschnittsweise definierte Graphen
+ auf in eine Zeichnung kommen sollen.
+ Die Eingabe anderer Buchstaben wird ignoriert.
+
+ Ansonsten wird eine Zeichnung erstellt, die unter dem eingegebenen
+ Namen abgelegt wird.
+
+ Danach wird im Dialogbereich erfragt, ob und wie das Format der
+ Zeichnung geändert werden soll.
+ Nachdem die Zeichnung erstellt wurde, was durch den
+ Stützpunkt-Zähler angezeigt wird, muß noch die Farbe, in der der
+ Graph gezeichnet werden soll eingegeben werden.
+
+ Fehlerquelle: Wertebereich ist noch nicht bestimmt (siehe 4).
+ Unzuläessiges Format: ymax ist kleiner oder gleich
+ ymin, bzw. xmax ist kleiner
+ oder gleich xmin.
+
+ 3.5 #ib(2," (3.5)")#(a) Ausgabe der Zeichnung auf Endgerät#ie(2,"")#
+ Im Dialogbereich wird der Name der auszugebenden Zeichnung erfragt,
+ wobei die zuletzt bearbeitete Zeichnung angeboten wird.
+ Die Wahl von '?' als Namen der Zeichnung ('PICFILE.?') führt zu einer
+ Auswahl aller vorhanden Bilder, von denen eines zur Ausgabe
+ ausgewählt werden kann.
+ Danach kann wie oben nochmals das Format variiert werden.
+ Dann wird im Dialogbereich die Überschrift der Zeichnung erfragt,
+ wobei der Funktionsterm angeboten wird. Die Überschrift erscheint
+ zentriert am oberen Rand.
+ Je nach Lage des Ursprungs (innerhalb od. außerhalb der Zeichnung)
+ kann die Ausgabe mit Koordinatensystem od. mit Rahmen gewählt
+ werden, liegt der Ursprung nicht innerhalb der Zeichnung, so wird
+ grundsätzlich der Rahmen verwendet.
+ Zum Abschluß wird dann die Farbgebung von Koordinatensystem bzw.
+ Rahmen sowie der Überschrift erfragt, dann wird die Zeichnung auf
+ dem im unteren Teil eingestelltem Endgerät ausgegeben.
+
+ 3.6 #ib(2," (3.6)")#(t) Wertetafel erstellen lassen#ie(2,"")#
+ In dem gewählten Definitionsbereich kann eine Wertetafel erstellt
+ werden, die in einer von Ihnen gewünschten Schrittweite ermittelte
+ Funktionswerte zeigt.
+ Zunächst wird die Schrittweite erfragt, dann die von FKT formatiert
+ erstellte Wertetafel gezeigt.
+ Diese befindet sich in einer Datei, die den Namen des zugehörigen
+ Funktionsterms trägt, existiert diese bereits, so wird die Wertetafel
+ ergänzt.
+ Enthält diese Tafel Sterne, so müssen Sie die Genauigkeit umwählen
+ und die Tafel neu erstellen lassen.
+ Nach Verlassen der Anzeige wird noch gefragt, ob die Wertetafel
+ gedruckt, und ob sie aufbewahrt werden soll.
+
+ Fehlerquelle: Definitionsbereich bzw. Funktionsterm ist noch nicht
+ gewählt.
+ Die Schrittweite wurde zu klein gewählt. Sie muß so
+ groß sein, daß nicht mehr als 512 Werte zu berechnen
+ sind.
+
+ 3.7 #ib(2," (3.7)")#(l) Zeichnungen auflisten#ie(2,"")#
+ Es wird eine Namesliste aller vorhandenen Zeichnungen gezeigt.
+
+ 3.8 #ib(2," (3.8)")#(?) Hilfestellung#ie(2,"")#
+ Es wird eine Kurzanleitung gezeigt.
+
+ 3.9 #ib(2," (3.9)")#(q) in die Kommandoebene zurück#ie(2,"")#
+ Die Arbeit mit dem Funktionsplotter wird beendet, in normalen Tasks
+ erscheint die Ebene, aus der 'FKT' mit 'fktplot' aufgerufen wurde.
+ Wird die Task 'FKT' mit 'q' verlassen, so wird dagegen die Task
+ abgekoppelt und alle in ihr enthaltenen Zeichnungen gelöscht!
+
+ 3.10 #ib(2," (3.10)")#(s) Anzahl der Stützpunkte waehlen#ie(2,"")#
+ Bei der Ermittlung des Wertebereiches und beim Erstellen des Funk­
+ tionsgraphen ist es wegen der Endlichkeit des Computers nicht mög­
+ lich, alle Punkte des Definitionsbereiches zu benutzen. Deshalb wird
+ der Definitionsbereich diskretisiert, d.h. es wird eine endliche An­
+ zahl von Stützpunkten ausgesucht. Diese Stützpunkte liegen gleich­
+ verteilt über dem Definitionsbereich. Die Mindestanzahl ist 2, d.h. als
+ Stützpunkte werden nur die beiden Randwerte zugelassen. Aus
+ technischen Gründen ist die Höchstgrenze 512.
+
+ Fehlerquelle: Zahl der Stützpunkte ist fehlerhaft.
+ Nur ganze Zahlen aus dem Intervall [2;512] zulässig.
+
+ 3.11 #ib(2," (3.11)")#(n) Nachkommastellenzahl wählen#ie(2,"")#
+ Hier kann die Zahl der angezeigten Nachkommastellen eingestellt
+ werden (intern wird immer höchstmögliche Genauigkeit verwendet).
+ Maximal sind neun Nachkommastellen zulässigt, jedoch kann die
+ Genauigkeit zu groß für das Anzeigeformat werden; dann erscheinen
+ in der Anzeige Sterne (*************).
+ Es gilt grundsätzlich:
+ Anzahl Vorkommastellen + Anz. Nachkommastellen = 12.
+
+ 3.12 #ib(2," (3.12)")#(e) Arbeit beenden#ie(2,"")#
+ Die Arbeit mit 'FKT' wird abgeschlossen, die Task vom Terminal
+ abgekoppelt. Für jede Task bleibt dabei FKT das laufende Programm,
+ d.h. nach erneutem Ankoppeln erscheint wieder die FKT-Tapete. In der
+ Task FKT bleiben die Zeichnungen bei Verlassen mit 'e' erhalten (im
+ Gegensatz zum Verlassen mit 'q').
+
+ 3.13 #ib(2," (3.13)")#(L) Zeichnungen loeschen#ie(2,"")#
+ Es erscheint eine Namensliste aller in der Task enthaltenen
+ Zeichnungen. Die dann ausgewählten Zeichnungen werden nach noch­
+ maliger Rückfrage gelöscht.
+
+ 3.14 #ib(2," (3.14)")#(A) Zeichnungen archivieren#ie(2,"")#
+ Nach Aufruf dieses Menuepunktes können Zeichnungen zu anderen
+ Tasks geschickt, oder auch auf Diskette geschrieben werden.
+ Dazu wird der MPG-Dateimanager 'dm' verwendet.
+
+ 3.15 #ib(2," (3.15)")#(b) Zeichnungen beschriften#ie(2,"")#
+ Mit diesem Menuepunkt können Zeichnungen frei beschriftet werden.
+ Zunächst wird im Dialogbereich erfragt, wie mit bereits bestehenden
+ Beschriftungen verfahren werden soll:
+
+ ­ <e> : Die nachfolgenden Texte werden zusätzlich zu den schon
+ vorhandenen Beschriftungen angefügt.
+ ­ <l> : Die vorhandenen Beschriftungen werden gelöscht, und es wird
+ zum Menue zurückgekehrt.
+ ­ <a> : Die Operation wird abgebrochen.
+
+ Nun wird die Farbgebung aller Beschriftungen erfragt,
+ danach wird das aktuelle Format der Zeichnung gezeigt, was bei der
+ Positionierung hilfreich sein kann.
+ Nach der nun geforderten Eingabe des Beschriftungstextes wird die
+ Positionierung der Beschriftung in zwei Weisen angeboten:
+ - in cm : Die nachfolgend einzugebenden Werte werden als
+ cm-Angabe relativ zur unteren linken Ecke der Zeichnung
+ aufgefaßt.
+ - in REAL: Die nachfolgend einzugebenden Werte werden als
+ Koordinatenangabe im Koordinatensystem der erstellten
+ Zeichnung aufgefaßt ('0;0' demnach im Ursprung) Nach
+ Eingabe o.g. Werte wird noch die Texthöhe und Breite erfragt, wobei die
+ eingegebenen Werte als mm-Angaben aufgefäßt werden (Standard: 5 * 5
+ mm).
+ Anschließend wird erfragt, ob noch weitere Beschriftungen
+ vorgenommen werden sollen.
+
+ Fehlerquelle: Zeichnung existiert nicht.
+#page#
+
+#type("pica")##on("u")##ib(1)#Teil 4.2: Die TURTLE-Graphik#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+ Die TURTLE-Graphik bietet die Möglichkeit, sehr einfach zweidimensionale
+ Zeichnungen zu erstellen. Sie basiert auf dem in LOGO verwendeten Modell, in
+ dem eine Zeichenposition in jeweils eine bestimmte Richtung vorwärts bzw.
+ rückwärts bewegt werden kann, und die Zeichenrichtung verändert werden
+ kann.Bei den Bewegungen, die vornehmlich relativ zur alten Position bzw.
+ Zeichenrichtung ausgeführt werden, kann dann eine Linie hinterlassen
+ werden. Diese Art der Graphik eignet sich insbesondere für Programm­
+ gesteuerte Zeichnungen, wie z.B. die rekursiven 'Sierpinski' - bzw. 'Hilbert'-
+ "Funktionen".
+
+ Die Koordinaten bewegen sich im Intervall von [-500.0,500.0].
+ (0,0) liegt dabei in der Bildschirmmitte und ist auch die Anfangsposition.
+ Der Anfangswinkel ist 0. Winkel werden in Grad angegeben.
+
+ #ib(1)#1.0 Paket: 'turtlegraphics'#ie(1)#
+
+ 1.1 REAL PROC #ib(2," (1.1)")#angle#ie(2," (PROC)")#
+ - liefert den momentanen Winkel zwischen Zeichenrichtung und
+ X-Achse.
+
+ 1.2 PROC #ib(2," (1.2)")#turnto#ie(2," (PROC)")#
+ (REAL CONST w)
+ - Die Zeichenrichtung wird absolut auf den Winkel 'w' als Winkel
+ zwischen Zeichenrichtung und X-Achse eingestellt.
+
+ 1.3 PROC #ib(2," (1.3)")#forward#ie(2," (PROC)")#
+ (REAL CONST s)
+ - Die Zeichenposition wird in Zeichenrichtung um die Strecke 's'
+ verschoben, wobei ggf. gezeichnet wird.
+
+ 1.4 PROC #ib(2," (1.4)")#penup#ie(2," (PROC)")#
+ - Der Zeichenstift wird abgehoben, Bewegungen erzeugen keine
+ Linien mehr.
+
+ 1.5 PROC #ib(2," (1.5)")#forward to#ie(2," (PROC)")#
+ (REAL CONST x,y)
+ - Die Zeichenposition wird absolut auf die Position 'x;y' gesetzt, die
+ Zeichenrichtung wird nicht verändert.
+
+ 1.6 PROC #ib(2," (1.6)")#endturtle#ie(2," (PROC)")#
+ - Wurde die Graphik im Direktmodus ('begin turtle' ohne Parameter),
+ also auch sofort sichtbar erzeugt, so wird die Graphikausgabe in
+ üblicher Weise beendet, sonst nunmehr das erzeugte PICFILE
+ ausgegeben.
+
+ 1.7 PROC #ib(2," (1.7)")#pendown#ie(2," (PROC)")#
+ - Der Zeichenstift wird gesenkt, Bewegungen erzeugen Linien.
+
+ 1.8 PROC #ib(2," (1.8)")#beginturtle#ie(2," (PROC)")#
+ (TEXT CONST picfile name)
+ - öffnet ein PICFILE 'picfile name', in das alle Aktionen eingetragen
+ werden. Auf dem Bildschirm geschieht nichts. Ist das Picfile schon
+ vorhanden, werden die Aktionen hinzugefügt.
+
+ 1.9 PROC #ib(2," (1.9)")#beginturtle#ie(2," (PROC)")#
+ - Leitet die direkte graphische Ausgabe einer TURTLE-Graphik ein,
+ alle Aktionen werden sofort auf dem Bildschirm sichtbar.
+
+ 1.10 PROC #ib(2," (1.10)")#turn#ie(2," (PROC)")#
+ (REAL CONST w)
+ - Dreht die Zeichenposition um 'w'-Grad im mathematisch positiven
+ Sinne.
+
+ 1.11 BOOL PROC #ib(2," (1.11)")#pen#ie(2," (PROC)")#
+ - Liefert zurück, ob der Zeichenstift oben (FALSE) oder unten (TRUE)
+ ist, also ob Bewegungen Linien hervorrufen oder nicht.
+
+ 1.12 PROC #ib(2," (1.12)")#getturtle#ie(2," (PROC)")#
+ - In die übergebenen Variablen wird die aktuelle Zeichenposition
+ absolut eingetragen.
+#page#
+ Diese Dokumentation und die einzelnen Programme wurden mit größtmöglicher
+ Sorgfalt erstellt bzw. weiterentwickelt.
+ Dennoch kann keine Fehlerfreiheit garantiert oder die Haftung für evtl. aus
+ Fehlern resultierende Folgen übernommen werden.
+ Für Hinweise auf Fehler sind die Autoren stets dankbar.
+#page#
+#bottom off#
+#head#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Stichwortverzeichnis
+#type("pica.lq")##free(1.0)#
+#end#
+#type("pica")##on("u")##ib(1)#Stichwortverzeichnis#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+(a) Ausgabe der Zeichnung auf Endgerät ........... 41 (3.5)
+actual plotter (PROC) ............................ 17 (4.4)
+ALL (OP) ......................................... 27 (3.1)
+angle (PROC) ..................................... 44 (1.1)
+(A) Zeichnungen archivieren ...................... 42 (3.14)
+background * (PROC) .............................. 13 (3.4), 13 (3.5), 19 (1.1),
+ 19 (1.2), 34 (2.1)
+bar * (PROC) ..................................... 8 (2.3), 23 (2.1), 23 (2.2)
+beginplot (PROC) ................................. 23 (2.3)
+beginturtle (PROC) ............................... 45 (1.9), 45 (1.8)
+box (PROC) ....................................... 19 (1.3), 23 (2.4), 34 (2.2)
+(b) Zeichnungen beschriften ...................... 42 (3.15)
+CAT * (OP) ....................................... 8 (2.4)
+channel (PROC) ................................... 17 (4.5)
+circle (PROC) .................................... 8 (2.5), 19 (1.4), 24 (2.5),
+ 34 (2.3)
+clear (PROC) ..................................... 19 (1.5), 19 (1.6), 34 (2.4)
+clearspool ....................................... 3 (2.2)
+clippedline (PROC) ............................... 5 (1.1)
+color (PROC) ..................................... 19 (1.7)
+COLORS ........................................... 32 (1.1)
+colors (PROC) .................................... 20 (1.8)
+(d) Definitionsbereich waehlen ................... 39 (3.2)
+delete picture * (PROC) .......................... 13 (3.6)
+dim * (PROC) ..................................... 8 (2.6)
+down * (PROC) .................................... 13 (3.7), 13 (3.8)
+draw cm * (PROC) ................................. 9 (2.11), 24 (2.12)
+draw cm r * (PROC) ............................... 9 (2.12), 24 (2.13)
+drawingarea * (PROC) ............................. 5 (1.2), 17 (4.6), 17 (4.7)
+draw * (PROC) .................................... 8 (2.8), 8 (2.7), 9 (2.10),
+ 9 (2.9), 24 (2.6), 24 (2.9),
+ 24 (2.8), 24 (2.7), 24 (2.11),
+ 24 (2.10)
+draw r * (PROC) .................................. 9 (2.13), 9 (2.14), 24 (2.14),
+ 25 (2.15)
+drawto (PROC) .................................... 20 (1.9), 34 (2.5)
+(e) Arbeit beenden ............................... 42 (3.12)
+EDITOR ........................................... 33 (1.2)
+end plot (PROC) .................................. 20 (1.10), 20 (1.11), 34 (2.6)
+endturtle (PROC) ................................. 44 (1.6)
+eof * (PROC) ..................................... 13 (3.9)
+erase (PROC) ..................................... 27 (3.3), 27 (3.2)
+exists (PROC) .................................... 27 (3.4)
+extrema * (PROC) ................................. 9 (2.16), 9 (2.15), 13 (3.11),
+ 13 (3.10)
+(f) Funktionsterm eingeben ....................... 38 (3.1)
+fill (PROC) ...................................... 20 (1.12), 34 (2.7)
+first ............................................ 4 (2.9)
+first (PROC) ..................................... 27 (3.5)
+foreground (PROC) ................................ 20 (1.14), 20 (1.13), 35 (2.8)
+forward (PROC) ................................... 44 (1.3)
+forward to (PROC) ................................ 44 (1.5)
+generate plotmanager (PROC) ...................... 27 (3.6)
+get cursor (PROC) ................................ 20 (1.15), 35 (2.9)
+get * (PROC) ..................................... 14 (3.12)
+getturtle (PROC) ................................. 45 (1.12)
+getvalues (PROC) ................................. 5 (1.3), 14 (3.13)
+graphik cursor (PROC) ............................ 20 (1.16), 21 (1.17), 35 (2.10)
+halt ............................................. 4 (2.6)
+halt (PROC) ...................................... 27 (3.7)
+hidden lines * (PROC) ............................ 25 (2.16)
+(?) Hilfestellung ................................ 41 (3.8)
+home (PROC) ...................................... 21 (1.18), 35 (2.11)
+INCLUDE .......................................... 33 (1.3)
+init plot (PROC) ................................. 21 (1.19), 35 (2.12)
+insert picture * (PROC) .......................... 14 (3.14)
+install plotter (PROC) ........................... 17 (4.8)
+is first picture * (PROC) ........................ 14 (3.15)
+killer ........................................... 4 (2.8)
+length * (PROC) .................................. 9 (2.17)
+linetype (PROC) .................................. 25 (2.17)
+LINK ............................................. 33 (1.4)
+list (PROC) ...................................... 27 (3.8), 28 (3.9)
+listspool ........................................ 3 (2.1)
+(l) Zeichnungen auflisten ........................ 41 (3.7)
+(L) Zeichnungen loeschen ......................... 42 (3.13)
+move cm (PROC) ................................... 10 (2.20), 25 (2.21)
+move cm r * (PROC) ............................... 10 (2.21), 25 (2.22)
+move * (PROC) .................................... 9 (2.19), 9 (2.18), 25 (2.18),
+ 25 (2.19), 25 (2.20)
+move r * (PROC) .................................. 10 (2.23), 10 (2.22),
+ 25 (2.23), 25 (2.24)
+move to (PROC) ................................... 21 (1.20), 35 (2.13)
+name (PROC) ...................................... 17 (4.9)
+newvalues (PROC) ................................. 5 (1.4)
+nilpicture * (PROC) .............................. 10 (2.24)
+(n) Nachkommastellenzahl wählen .................. 42 (3.11)
+no plotter (PROC) ................................ 17 (4.10)
+oblique * (PROC) ................................. 5 (1.5), 14 (3.16)
+:= (OP) .......................................... 8 (2.2), 13 (3.2), 13 (3.3),
+ 17 (4.3), 17 (4.2)
+orthographic * (PROC) ............................ 5 (1.6)
+PACKET basisplot ................................. 1 (3.1)
+PACKET deviceinterface ........................... 1 (2.1)
+PACKET devices ................................... 1 (1.4)
+PACKET picfile ................................... 1 (1.3)
+PACKET picture ................................... 1 (1.2)
+PACKET plot ...................................... 1 (3.3)
+PACKET plotinterface ............................. 1 (3.2)
+PACKET transformation ............................ 1 (1.1)
+pendown (PROC) ................................... 44 (1.7)
+pen * (PROC) ..................................... 10 (2.25), 10 (2.26),
+ 26 (2.25), 45 (1.11)
+penup (PROC) ..................................... 44 (1.4)
+perspective * (PROC) ............................. 6 (1.7), 14 (3.17)
+picfiles (PROC) .................................. 28 (3.10)
+picture no * (PROC) .............................. 14 (3.18)
+picture * (PROC) ................................. 11 (2.27)
+pictures * (PROC) ................................ 14 (3.19)
+plot * (PROC) .................................... 29 (4.3), 29 (4.2), 29 (4.1)
+PLOTTER .......................................... 33 (1.5)
+plotterinfo (PROC) ............................... 18 (4.13)
+plotter (PROC) ................................... 18 (4.11), 18 (4.12)
+plotters (PROC) .................................. 18 (4.14)
+prepare (PROC) ................................... 21 (1.21), 36 (2.14)
+put picture * (PROC) ............................. 14 (3.21)
+put * (PROC) ..................................... 14 (3.20)
+(q) in die Kommandoebene zurück .................. 41 (3.9)
+read picture * (PROC) ............................ 14 (3.22)
+reset linetypes * (PROC) ......................... 26 (2.27)
+reset * (PROC) ................................... 26 (2.26)
+reset zeichensatz * (PROC) ....................... 26 (2.28)
+rotate * (PROC) .................................. 11 (2.28), 11 (2.29)
+(s) Anzahl der Stützpunkte waehlen ............... 42 (3.10)
+save (PROC) ...................................... 28 (3.12), 28 (3.11)
+selected pen * (PROC) ............................ 15 (3.23)
+select pen * (PROC) .............................. 15 (3.24)
+select plotter ................................... 4 (2.7)
+select plotter (PROC) ............................ 18 (4.16), 18 (4.15), 18 (4.17)
+set color (PROC) ................................. 21 (1.22)
+setdrawingarea (PROC) ............................ 6 (1.8)
+set marker (PROC) ................................ 21 (1.23), 36 (2.15)
+setpalette (PROC) ................................ 21 (1.24), 36 (2.16)
+setpixel (PROC) .................................. 21 (1.25), 36 (2.17)
+setvalues (PROC) ................................. 6 (1.9), 15 (3.25)
+spool control .................................... 3 (2.3)
+start ............................................ 4 (2.5)
+start (PROC) ..................................... 28 (3.13)
+station (PROC) ................................... 18 (4.18)
+stdcolors (PROC) ................................. 22 (1.26), 22 (1.27)
+stop ............................................. 3 (2.4)
+stop (PROC) ...................................... 28 (3.14)
+stretch * (PROC) ................................. 11 (2.31), 11 (2.30)
+text * (PROC) .................................... 11 (2.32)
+to eof * (PROC) .................................. 15 (3.26)
+to first pic * (PROC) ............................ 16 (3.27)
+to pic * (PROC) .................................. 16 (3.28)
+transform (PROC) ................................. 6 (1.10)
+translate * (PROC) ............................... 12 (2.33), 12 (2.34)
+turn (PROC) ...................................... 45 (1.10)
+turnto (PROC) .................................... 44 (1.2)
+(t) Wertetafel erstellen lassen .................. 41 (3.6)
+TYPE PICFILE ..................................... 13 (3.1)
+TYPE PICTURE * ................................... 8 (2.1)
+TYPE PLOTTER ..................................... 17 (4.1)
+up * (PROC) ...................................... 16 (3.30), 16 (3.29)
+viewport * (PROC) ................................ 7 (1.14), 16 (3.34)
+view * (PROC) .................................... 6 (1.13), 6 (1.12), 6 (1.11),
+ 16 (3.32), 16 (3.31), 16 (3.33)
+wait for halt (PROC) ............................. 28 (3.15)
+where * (PROC) ................................... 12 (2.35), 12 (2.36),
+ 26 (2.30), 26 (2.29)
+window * (PROC) .................................. 7 (1.15), 7 (1.16), 7 (1.17),
+ 16 (3.35), 16 (3.36)
+write picture * (PROC) ........................... 16 (3.37)
+(w) Wertebereich ermitteln lassen ................ 40 (3.3)
+zeichensatz * (PROC) ............................. 26 (2.31)
+(z) Zeichnung anfertigen ......................... 40 (3.4)
+
+
diff --git a/app/mpg/2.2/source-disk b/app/mpg/2.2/source-disk
new file mode 100644
index 0000000..f00ec02
--- /dev/null
+++ b/app/mpg/2.2/source-disk
@@ -0,0 +1,4 @@
+mpg/mpg-graphik-system-2.1_1987-09-10.1.img
+mpg/mpg-graphik-system-2.1_1987-09-10.2.img
+mpg/mpg-graphik-system-2.1_1987-09-10.3.img
+mpg/mpg-graphik-system-2.1_1987-09-10.4.img
diff --git a/app/mpg/2.2/src/AMPEX 2-1-6.GCONF b/app/mpg/2.2/src/AMPEX 2-1-6.GCONF
new file mode 100644
index 0000000..030efd4
--- /dev/null
+++ b/app/mpg/2.2/src/AMPEX 2-1-6.GCONF
@@ -0,0 +1,84 @@
+INCLUDE "terminal plot";
+INCLUDE "std primitives";
+
+PLOTTER "AMPEX",2,1,78,47,21.5,16.0;
+
+LINK 2/2,2/3,2/4,2/5,2/6;
+
+COLORS "000999";
+
+PROC clear:
+ IF plot
+ THEN INT VAR i;
+ FOR i FROM 1 UPTO 24
+ REP display [i] := empty line PER;
+ page
+ ELSE errorstop ("PROC clear : clear without plotmodus") FI
+END PROC clear;
+
+PROC prepare:
+ break(quiet);
+ REP
+ disable stop;
+ continue (channel(plotter));
+ clear error;
+ enable stop;
+ IF NOT online
+ THEN pause (300)
+ FI
+ UNTIL online PER
+END PROC prepare;
+
+PROC initplot:
+ plot := TRUE;
+ cursor (x pos + 1, 24 - (y pos) DIV 2)
+END PROC initplot;
+
+PROC endplot:
+ pause;
+ plot := FALSE
+END PROC endplot;
+
+PROC home:
+ move to (0,0)
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ x pos := x ;
+ y pos := y
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ new x pos := x;
+ new y pos := y;
+ plot vector (new x pos - x pos, new y pos - y pos) ;
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ move to (x,y);
+ point
+END PROC setpixel;
+
+PROC foreground (INT VAR type):
+ type := 1
+END PROC foreground;
+
+PROC background (INT VAR type):
+ type := 0
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ std circle (x,y,rad,from,to)
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1,y1,x2,y2,pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+END PROC fill;
+
+
diff --git a/app/mpg/2.2/src/AMPEX 3-1-4.GCONF b/app/mpg/2.2/src/AMPEX 3-1-4.GCONF
new file mode 100644
index 0000000..cc3a7ad
--- /dev/null
+++ b/app/mpg/2.2/src/AMPEX 3-1-4.GCONF
@@ -0,0 +1,84 @@
+INCLUDE "terminal plot";
+INCLUDE "std primitives";
+
+PLOTTER "AMPEX",3,1,78,47,21.5,16.0;
+
+LINK 3/2,3/3,3/4;
+
+COLORS "000999";
+
+PROC clear:
+ IF plot
+ THEN INT VAR i;
+ FOR i FROM 1 UPTO 24
+ REP display [i] := empty line PER;
+ page
+ ELSE errorstop ("PROC clear : clear without plotmodus") FI
+END PROC clear;
+
+PROC prepare:
+ break(quiet);
+ REP
+ disable stop;
+ continue (channel(plotter));
+ clear error;
+ enable stop;
+ IF NOT online
+ THEN pause (300)
+ FI
+ UNTIL online PER
+END PROC prepare;
+
+PROC initplot:
+ plot := TRUE;
+ cursor (x pos + 1, 24 - (y pos) DIV 2)
+END PROC initplot;
+
+PROC endplot:
+ pause;
+ plot := FALSE
+END PROC endplot;
+
+PROC home:
+ move to (0,0)
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ x pos := x ;
+ y pos := y
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ new x pos := x;
+ new y pos := y;
+ plot vector (new x pos - x pos, new y pos - y pos) ;
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ move to (x,y);
+ point
+END PROC setpixel;
+
+PROC foreground (INT VAR type):
+ type := 1
+END PROC foreground;
+
+PROC background (INT VAR type):
+ type := 0
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ std circle (x,y,rad,from,to)
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1,y1,x2,y2,pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+END PROC fill;
+
+
diff --git a/app/mpg/2.2/src/Atari 3-9.GCONF b/app/mpg/2.2/src/Atari 3-9.GCONF
new file mode 100644
index 0000000..82b4826
--- /dev/null
+++ b/app/mpg/2.2/src/Atari 3-9.GCONF
@@ -0,0 +1,119 @@
+INCLUDE "std primitives";
+
+PLOTTER "ATARI",3,9,640,400,21.0,13.0;
+
+COLORS "000999";
+
+TEXT VAR atari kommando;
+TEXT VAR atari puffer 2 := "12",
+ atari puffer 4 := "1234";
+
+PROC atari g c (TEXT CONST kommando kennung):
+ LET esc g = ""27"g";
+ atari kommando := esc g;
+ atari kommando CAT kommando kennung
+
+END PROC atari g c;
+
+PROC atari g w (INT CONST unsigned integer):
+ replace (atari puffer 2, 1, unsigned integer);
+ atari kommando CAT atari puffer 2
+
+END PROC atari g w;
+
+PROC atari g k (INT CONST x, y):
+ replace (atari puffer 4, 1, x);
+ replace (atari puffer 4, 2, y);
+ atari kommando CAT atari puffer 4
+
+END PROC atari g k;
+
+PROC atari g e:
+ out (atari kommando)
+
+END PROC atari g e;
+
+PROC initplot:
+ INT VAR atari d;
+ control (11, channel, 255, atari d);
+ atari g c ("B");
+ atari g e
+END PROC initplot;
+
+PROC endplot:
+ pause;
+ INT VAR atari d;
+ atari g c ("E");
+ atari g e;
+ control (11, channel, 25, atari d)
+END PROC endplot;
+
+PROC prepare:
+ break(quiet);
+ REP
+ disable stop;
+ continue (channel(plotter));
+ clear error;
+ enable stop;
+ IF NOT online
+ THEN pause (300)
+ FI
+ UNTIL online PER
+END PROC prepare;
+
+PROC clear:
+ atari g c("C");
+ atari g e
+END PROC clear;
+
+PROC home:
+ move to(0,0)
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ atari g c("M");
+ atari g k(x,y);
+ atari g e
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ atari g c ("D");
+ atari g k(x,y);
+ atari g e
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ atari g c(".");
+ atari g k(x,y);
+ atari g e
+END PROC setpixel;
+
+PROC foreground (INT VAR type):
+ type := 1
+END PROC foreground;
+
+PROC background (INT VAR type):
+ type := 0
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ atari g c("K");
+ atari g k(x,y);
+ atari g w(rad);
+ atari g w(from);
+ atari g w(to);
+ atari g e
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1,y1,x2,y2,pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+END PROC fill;
+
+
+
diff --git a/app/mpg/2.2/src/DATAGRAPH 3-7.GCONF b/app/mpg/2.2/src/DATAGRAPH 3-7.GCONF
new file mode 100644
index 0000000..6ed887d
--- /dev/null
+++ b/app/mpg/2.2/src/DATAGRAPH 3-7.GCONF
@@ -0,0 +1,119 @@
+PLOTTER "DATAGRAPH",3,7,511,241,25.0,16.5;
+
+COLORS "000999900029490000990751";
+
+LET csi = ""27"[?";
+
+PROC datagraph palette:
+ INT VAR coln, rgb;
+ REAL VAR anteil;
+ FOR coln FROM 0 UPTO colors - 1 REP
+ rgb := color (coln);
+ IF rgb <> maxint
+ THEN out (csi + text (coln) + ";");
+ anteil := real (rgb DIV 100) / 9.0;
+ out (text (int (7.0 * anteil + 0.5)) + ";");
+ anteil := real ((rgb MOD 100) DIV 10) / 9.0;
+ out (text (int (7.0 * anteil + 0.5)) + ";");
+ anteil := real (rgb MOD 10) / 9.0;
+ out (text (int (3.0 * anteil + 0.5)) + "m");
+ FI
+ PER
+END PROC datagraph palette;
+
+PROC prepare:
+ break(quiet);
+ REP
+ disable stop;
+ continue (channel(plotter));
+ clear error;
+ enable stop;
+ IF NOT online
+ THEN pause (300)
+ FI
+ UNTIL online PER
+END PROC prepare;
+
+PROC clear:
+ out (csi + "2D");
+ foreground (1)
+END PROC clear;
+
+PROC initplot:
+ out (csi + "1a");
+ out (csi + "0j");
+ out (csi + "3j");
+ out (csi + "4j")
+END PROC initplot;
+
+PROC endplot:
+ pause;
+ out (csi + "0a");
+ out (csi + "3;7;5;1m");
+ out (csi + "0;0;0;0m");
+ out (""27"[33m")
+END PROC endplot;
+
+PROC home:
+ move to (0,0);
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ out (csi + "1;"+text(y)+";"+text(x)+"C")
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ out (csi + "0V");
+ out (csi + "1V");
+ out (csi + "3;"+text(y)+";"+text(x)+"V")
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ out (""27"[?0;"+text(y)+";"+text(x)+"P")
+END PROC setpixel;
+
+PROC foreground (INT VAR type):
+ IF type >= 0 AND type <= 7
+ THEN out (csi + text (type) + ";f")
+ ELSE type := 1;out (csi + "1;f")
+ FI
+END PROC foreground;
+
+PROC background (INT VAR type):
+ IF color (type) <> maxint
+ THEN set color (0,color (type))
+ ELSE type := 0;set color (0,000)
+ FI;
+ set palette
+END PROC back ground;
+
+PROC set palette:
+ datagraph palette
+END PROC set palette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ move to (x, y);
+ IF from = 0 AND to = 360
+ THEN out (csi + "0;" + text(y) + ";" + text (x) + ";" +
+ text (y) + ";" + text (x+rad) + "K")
+ ELSE out (csi + "2;" + text (y) + ";" + text (x+rad) +"C");
+ out (csi + "2;" + text (to-from) + "S")
+ FI
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ move to (x1, y1);
+ out (csi + text (pattern + 3 * sign(pattern)) + ";" +
+ text (y1) + ";" + text (x1) + ";" +
+ text (y2) + ";" + text (x2) + "R")
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+ move to (x,y);
+ IF pattern > 6 OR pattern = 0
+ THEN out (csi + "0I")
+ ELSE out (csi + text (pattern+3) + "I")
+ FI
+END PROC fill;
+
+
diff --git a/app/mpg/2.2/src/ENVIRONMENT2.GCONF b/app/mpg/2.2/src/ENVIRONMENT2.GCONF
new file mode 100644
index 0000000..da04554
--- /dev/null
+++ b/app/mpg/2.2/src/ENVIRONMENT2.GCONF
@@ -0,0 +1,5 @@
+PLOTTER "VC 404",2,7,78,47,21.5,16.0;
+PLOTTER "NEC P9 HD",2,15,2880,2880,20.32,20.32;
+PLOTTER "NEC P9 MD",2,15,2340,1984,33.02,27.99644;
+
+
diff --git a/app/mpg/2.2/src/ENVIRONMENT3.GCONF b/app/mpg/2.2/src/ENVIRONMENT3.GCONF
new file mode 100644
index 0000000..27a4412
--- /dev/null
+++ b/app/mpg/2.2/src/ENVIRONMENT3.GCONF
@@ -0,0 +1,7 @@
+PLOTTER "DATAGRAPH",3,7,511,241,25.0,16.5;
+PLOTTER "WATANABE",3,8,3449,2599,34.5,26.0;
+PLOTTER "VIDEOSTAR",3,6,640,480,27.0,19.5;
+PLOTTER "NEC P3",3,15,1024,1024,21.68,21.68;
+PLOTTER "ATARI",3,9,640,400,21.0,13.0;
+
+
diff --git a/app/mpg/2.2/src/FKT.help b/app/mpg/2.2/src/FKT.help
new file mode 100644
index 0000000..05e82dc
--- /dev/null
+++ b/app/mpg/2.2/src/FKT.help
@@ -0,0 +1,24 @@
+* <f> : Funktionsterm waehlen bzw. umwaehlen *
+* <d> : Definitionsbereich setzen *
+* ACHTUNG : Untergrenze < Obergrenze *
+* <s> : Anzahl der Stuetzpunkte waehlen; 2 <= s <= 512 *
+* <w> : Wertebereich wird ermittelt *
+* ACHTUNG : Anzahl der Stuetzpunkte *
+* <t> : Wertetafel wird erstellt *
+* ACHTUNG : Nicht mehr als 512 Werte koennen ermittelt werden*
+* <z> : Zeichnung wird erstellt *
+* ACHTUNG : Erst Funktionsterm einegeben *
+* ACHTUNG : Erst Wertebereich ermitteln lassen *
+* <a> : Erstellte Zeichnung zeigen lassen *
+* ACHTUNG : Auf Endgeraet achten *
+* <l> : Liste aller bereits erstellten Zeichnungen wird gezeigt *
+* <n> : Nachkommastellen setzen *
+* <e> : Sitzung beenden *
+* <q> : Auf Kommandoebene zurueck (nicht in der Task FKT) *
+* <?> : Diese Anleitung wird gezeigt *
+* <A> : Zeichnungen koennen auf Diskette geschrieben werden *
+* <b> : Zeichnungen koennen mit beliebigen Texten versehen werden *
+* <L> : Es werden alle Zeichnungen zum Loeschen angeboten *
+* <<- ->> : Das Endgeraet umwaehlen. *
+*****************VERLASSEN DIESER ANLEITUNG MIT <ESC><q>*******************
+
diff --git a/app/mpg/2.2/src/GRAPHIK.Basis b/app/mpg/2.2/src/GRAPHIK.Basis
new file mode 100644
index 0000000..733297d
--- /dev/null
+++ b/app/mpg/2.2/src/GRAPHIK.Basis
@@ -0,0 +1,1574 @@
+(**************************************************************************)
+(* *)
+(* MPG - Graphik - System *)
+(* *)
+(* Version 2.2 vom 23.09.1987 *)
+(* *)
+(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *)
+(* unter Verwendung der Standard-Graphik *)
+(* "Graphik-Basis" geschrieben von C.Weinholz/EUMEL-Std *)
+(* *)
+(**************************************************************************)
+(* *)
+(* Paket I: Endgeraet-unabhaengige Graphikroutinen *)
+(* *)
+(* 1. Transformation (Umsetzung 3D -> 2D), *)
+(* Clipping und Normierung *)
+(* 2. PICTURE - Verwaltung *)
+(* (geanderte Standard-Version) *)
+(* 3. PICFILE - Verwaltung *)
+(* (geanderte Standard-Version) *)
+(* 4. Endgeraet - Verwaltung *)
+(* *)
+(**************************************************************************)
+(* Urversion : 10.09.87 *)
+(* Aenderungen: 23.09.87, Carsten Weinholz *)
+(* OP := (PICFILE VAR, PICFILE CONST) hinzugefuegt *)
+(* TEXT PROC text (PICTURE CONST) *)
+(* wg. Heapueberlauf geaendert *)
+(* *)
+(**************************************************************************)
+
+(****************************** transformation ****************************)
+
+PACKET transformation DEFINES
+ transform,
+ set values,
+ get values,
+ new values,
+ drawing area,
+ set drawing area,
+
+ window,
+ viewport,
+ view,
+ oblique,
+ orthographic,
+ perspective,
+
+ clipped line:
+
+BOOL VAR new limits :: TRUE,
+ values new :: TRUE,
+ perspective projektion :: FALSE;
+
+REAL VAR display hor, display vert, (* Anzahl der Pixel *)
+ size hor, size vert, (* Groesse des Bildschirms *)
+ size hor d, size vert d,
+ h min limit, h max limit,
+ v min limit, v max limit,
+ h min, h max,
+ v min, v max,
+ relation;
+
+ROW 5 ROW 5 REAL VAR p ;
+ROW 3 ROW 2 REAL VAR size d ;
+ROW 2 ROW 2 REAL VAR limits d ;
+ROW 4 REAL VAR angles d ;
+ROW 2 REAL VAR oblique d ;
+ROW 3 REAL VAR perspective d ;
+
+INT VAR i, j;
+
+PROC init transformation rows:
+ size d := ROW 3 ROW 2 REAL : (ROW 2 REAL : (0.0, 1.0),
+ ROW 2 REAL : (0.0, 1.0),
+ ROW 2 REAL : (0.0, 1.0));
+
+ limits d := ROW 2 ROW 2 REAL : (ROW 2 REAL : (0.0, relation),
+ ROW 2 REAL : (0.0, 1.0));
+
+ angles d := ROW 4 REAL : (0.0, 0.0, 0.0, 0.0);
+
+ oblique d := ROW 2 REAL : (0.0, 0.0);
+
+ perspective d := ROW 3 REAL : (0.0, 0.0, 0.0);
+ set values (size d, limits d, angles d, oblique d, perspective d);
+END PROC init transformation rows;
+
+BOOL OP = (ROW 3 ROW 2 REAL CONST l, r):
+ FOR i FROM 1 UPTO 3
+ REP IF l [i][1] <> r [i][1] OR l [i][2] <> r [i][2]
+ THEN LEAVE = WITH FALSE FI
+ PER;
+ TRUE
+END OP =;
+
+BOOL OP = (ROW 2 ROW 2 REAL CONST l, r):
+ FOR i FROM 1 UPTO 2
+ REP IF l [i][1] <> r [i][1] OR l [i][2] <> r [i][2]
+ THEN LEAVE = WITH FALSE FI
+ PER;
+ TRUE
+END OP =;
+
+BOOL OP = (ROW 2 REAL CONST l, r):
+ l [1] = r [1] AND l [2] = r [2]
+END OP =;
+
+BOOL OP = (ROW 3 REAL CONST l, r):
+ l [1] = r [1] AND l [2] = r [2] AND l [3] = r [3]
+END OP =;
+
+BOOL OP = (ROW 4 REAL CONST l, r):
+ l [1] = r [1] AND l [2] = r [2] AND l [3] = r [3] AND l [4] = r [4]
+END OP =;
+
+PROC oblique (REAL CONST a, b) :
+ set values (size d, limits d, angles d, ROW 2 REAL : (a, b), ROW 3 REAL : (0.0, 0.0, 0.0))
+END PROC oblique;
+
+PROC orthographic :
+ set values (size d, limits d, angles d, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (0.0, 0.0, 0.0))
+END PROC orthographic;
+
+PROC perspective (REAL CONST cx, cy, cz) :
+ set values (size d, limits d, angles d, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (cx, cy,-cz))
+END PROC perspective;
+
+PROC window (BOOL CONST dev) :
+ new limits := dev
+END PROC window;
+
+PROC window (REAL CONST x min, x max, y min, y max) :
+ window (x min, x max, y min, y max, 0.0, 1.0)
+END PROC window;
+
+PROC window (REAL CONST x min, x max, y min, y max, z min, z max) :
+ set values (ROW 3 ROW 2 REAL : (ROW 2 REAL : (x min, x max),
+ ROW 2 REAL : (y min, y max),
+ ROW 2 REAL : (z min, z max)),
+ limits d, angles d, oblique d, perspective d)
+END PROC window;
+
+PROC viewport (REAL CONST h min, h max, v min, v max) :
+ set values (size d, ROW 2 ROW 2 REAL : (ROW 2 REAL : (h min, h max),
+ ROW 2 REAL : (v min, v max)),
+ angles d, oblique d, perspective d)
+END PROC view port;
+
+PROC view (REAL CONST alpha) :
+ set values (size d, limits d, ROW 4 REAL : (alpha, angles d(2), angles d (3), angles d (4)),
+ oblique d, perspective d)
+END PROC view;
+
+PROC view (REAL CONST phi, theta) :
+ set values (size d, limits d, ROW 4 REAL : (angles d(1), sind (theta) * cosd (phi),
+ sind (theta) * sind (phi), cosd (theta)),
+ oblique d, perspective d)
+END PROC view;
+
+PROC view (REAL CONST x, y, z) :
+ set values (size d, limits d, ROW 4 REAL : (angles d (1), x, y, z), oblique d, perspective d)
+END PROC view;
+
+PROC drawing area (REAL VAR min h, max h, min v, max v):
+ min h := h min limit; max h := h max limit;
+ min v := v min limit; max v := v max limit
+END PROC drawing area;
+
+PROC set drawing area (REAL CONST new size hor,new size vert,
+ new display hor,new display vert):
+ size hor := new size hor;
+ size vert:= new size vert;
+ display hor := new display hor;
+ display vert:= new display vert;
+ relation := size hor/size vert;
+ new limits := TRUE;
+ init transformation rows
+END PROC set drawing area;
+
+BOOL PROC new values:
+ IF values new
+ THEN values new := FALSE;
+ TRUE
+ ELSE FALSE FI
+END PROC new values;
+
+PROC get values (ROW 3 ROW 2 REAL VAR size,
+ ROW 2 ROW 2 REAL VAR limits,
+ ROW 4 REAL VAR angles,
+ ROW 2 REAL VAR oblique,
+ ROW 3 REAL VAR perspective) :
+ size := size d;
+ limits := limits d;
+ angles := angles d;
+ oblique := oblique d;
+ perspective := perspective d;
+
+END PROC get values;
+
+PROC set values (ROW 3 ROW 2 REAL CONST size,
+ ROW 2 ROW 2 REAL CONST limits,
+ ROW 4 REAL CONST angles,
+ ROW 2 REAL CONST oblique,
+ ROW 3 REAL CONST perspective) :
+ IF NOT same values
+ THEN values new := TRUE;
+ copy values;
+ set views;
+ check perspective projektion;
+ calc limits;
+ change projektion
+ FI .
+
+same values:
+ size hor d = size hor AND size vert d = size vert AND
+ size d = size AND limits d = limits AND angles d = angles AND
+ oblique d = oblique AND perspective d = perspective .
+
+copy values :
+ size hor d := size hor;
+ size vert d := size vert;
+ size d := size;
+ limits d := limits;
+ angles d := angles;
+ oblique d := oblique;
+ perspective d := perspective .
+
+set views :
+ REAL VAR diagonale := sqrt (angles [2] * angles [2] +
+ angles [3] * angles [3] +
+ angles [4] * angles [4]),
+ projektion := sqrt (angles [2] * angles [2] +
+ angles [4] * angles [4]),
+ sin p, cos p, sin t, cos t, sin a, cos a;
+
+ IF diagonale = 0.0
+ THEN sin p := 0.0; cos p := 1.0;
+ sin t := 0.0; cos t := 1.0
+ ELIF projektion = 0.0
+ THEN sin p := angles [3] / diagonale;
+ cos p := projektion / diagonale;
+ sin t := 0.0; cos t := 1.0
+ ELSE sin p := angles [3] / diagonale;
+ cos p := projektion / diagonale;
+ sin t := angles [2] / projektion;
+ cos t := angles [4] / projektion
+ FI;
+
+ REAL VAR sin p sin t := sin p * sin t,
+ sin p cos t := sin p * cos t,
+ cos p sin t := cos p * sin t,
+ cos p cos t := cos p * cos t,
+
+ dx := size [1][2] - size [1][1],
+ dy := size [2][2] - size [2][1],
+ dz := size [3][2] - size [3][1],
+ norm az := oblique [1] ,
+ norm bz := oblique [2] ,
+ norm cx := perspective [1] / dx,
+ norm cy := perspective [2] / dy,
+ norm cz := perspective [3] / dz;
+
+p := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : ( cos t / dx - cos p sin t / dx * norm az ,
+ - sin p sin t / dx - cos p sin t / dx * norm bz,
+ 0.0,
+ - cos p sin t / dx * norm cz,
+ 0.0 ),
+ ROW 5 REAL : ( - sin p / dy * norm az,
+ cos p / dy - sin p / dy * norm bz,
+ 0.0,
+ - sin p / dy * norm cz,
+ 0.0 ),
+ ROW 5 REAL : ( sin t / dz + cos p cos t / dz * norm az,
+ + sin p cos t / dz + cos p cos t / dz * norm bz,
+ 0.0,
+ cos p cos t / dz * norm cz,
+ 0.0 ),
+ ROW 5 REAL : (- norm cx, - norm cy, 0.0, 1.0, 0.0 ),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 0.0, 1.0));
+
+ IF angles (1) = 0.0
+ THEN set alpha as y vertical
+ ELSE sin a := sind (angles (1));
+ cos a := cosd (angles (1))
+ FI;
+
+ FOR j FROM 1 UPTO 5
+ REP REAL CONST p j 1 := p (j)(1);
+ p (j)(1) := p j 1 * cos a - p (j)(2) * sin a;
+ p (j)(2) := p j 1 * sin a + p (j)(2) * cos a
+ PER .
+
+set alpha as y vertical :
+ REAL VAR r := sqrt (p(2)(1)**2 + p(2)(2)**2);
+ IF r = 0.0
+ THEN sin a := 0.0;
+ cos a := 1.0
+ ELSE sin a :=-p(2)(1)/r;
+ cos a := p(2)(2)/r
+ FI .
+
+check perspective projektion:
+ perspective projektion := perspective [3] <> 0.0 .
+
+calc limits :
+ IF new limits
+ THEN calc two dim extrema;
+ IF all limits smaller than 2
+ THEN prozente
+ ELSE zentimeter FI
+ FI .
+
+calc two dim extrema :
+ h min := max real; h max :=-max real;
+ v min := max real; v max :=-max real;
+
+ extrema (size [1][1], size [2][1], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][1], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][2], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][2], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][1], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][1], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][2], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][2], size [3][2], h min, h max, v min, v max) .
+
+all limits smaller than 2 :
+ limits (1)(2) < 2.0 AND limits (2)(2) < 2.0 .
+
+prozente :
+ h min limit := display hor * limits (1)(1)/relation;
+ h max limit := display hor * limits (1)(2)/relation;
+
+ v min limit := limits (2)(1) * display vert;
+ v max limit := limits (2)(2) * display vert .
+
+zentimeter :
+ h min limit := display hor * (limits (1)(1)/size hor);
+ h max limit := display hor * (limits (1)(2)/size hor);
+
+ v min limit := display vert * (limits (2)(1)/size vert);
+ v max limit := display vert * (limits (2)(2)/size vert) .
+
+change projektion :
+ REAL VAR sh := (h max limit - h min limit) / (h max - h min),
+ sv := (v max limit - v min limit) / (v max - v min),
+ dh := h min limit - h min*sh,
+ dv := v min limit - v min*sv;
+
+ FOR j FROM 1 UPTO 5
+ REP
+ p (j)(1) := p (j)(1) * sh;
+ p (j)(2) := p (j)(2) * sv
+ PER;
+ p (5)(1) := dh;
+ p (5)(2) := dv.
+END PROC set values;
+
+PROC transform (REAL CONST x, y, z, INT VAR h, v) :
+ disable stop;
+ IF perspective projektion
+ THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0);
+ h := int ((x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (4)(1))*w + p (5)(1));
+ v := int ((x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (4)(2))*w + p (5)(2))
+ ELSE h := int (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (5)(1));
+ v := int (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (5)(2));
+ FI;
+ IF is error
+ THEN h := -1;
+ v := -1;
+ clear error
+ FI
+END PROC transform;
+
+PROC extrema (REAL CONST x, y, z, REAL VAR h min, h max, v min, v max):
+ REAL VAR h, v;
+ IF perspective projektion
+ THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0);
+ h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) +p (4)(1))*w;
+ v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) +p (4)(2))*w
+ ELSE h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1));
+ v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2))
+ FI;
+
+ IF h < h min
+ THEN h min := h
+ ELIF h > h max
+ THEN h max := h FI;
+
+ IF v < v min
+ THEN v min := v
+ ELIF v > v max
+ THEN v max := v FI
+
+END PROC extrema;
+
+BOOL PROC clipped line (REAL VAR x0,y0,x1,y1):
+ REAL VAR dx :: (display hor - 1.0) / 2.0,
+ dy :: (display vert- 1.0) / 2.0,
+ rx0 :: x0 - dx,
+ ry0 :: y0 - dy,
+ rx1 :: x1 - dx,
+ ry1 :: y1 - dy;
+ INT VAR cx0,
+ cy0,
+ cx1,
+ cy1;
+ calculate cells;
+ IF (cx0*cx1 = 1) OR (cy0 * cy1 = 1)
+ THEN FALSE
+ ELIF (x0 = x1) AND (y0 = y1)
+ THEN cx0 = 0 AND cy0 = 0
+ ELSE do clipping
+ FI.
+
+ do clipping:
+ IF cx0 <> 0
+ THEN REAL VAR next x :: real(cx0) * dx;
+ ry0 := (ry1 - ry0) / (rx1 - rx0) * (next x - rx0) + ry0;
+ rx0 := next x
+ FI;
+ calculate cells;
+ IF cy0 <> 0
+ THEN REAL VAR next y :: real(cy0) * dy;
+ rx0 := (rx1 - rx0) / (ry1 - ry0) * (next y - ry0) + rx0;
+ ry0 := next y
+ FI;
+ IF cx1 <> 0
+ THEN next x := real(cx1) * dx;
+ ry1 := (ry1 - ry0) / (rx1 - rx0) * (next x - rx1) + ry1;
+ rx1 := next x
+ FI;
+ calculate cells;
+ IF cy1 <> 0
+ THEN next y := real(cy1) * dy;
+ rx1 := (rx1 - rx0) / (ry1 - ry0) * (next y - ry1) + rx1;
+ ry1 := next y
+ FI;
+ IF (rx1 = rx0) AND (ry1 = ry0)
+ THEN FALSE
+ ELSE x0 := rx0+dx;
+ y0 := ry0+dy;
+ x1 := rx1+dx;
+ y1 := ry1+dy;
+ TRUE
+ FI.
+
+ calculate cells:
+ cx0 := 0;
+ cy0 := 0;
+ cx1 := 0;
+ cy1 := 0;
+ IF abs(rx0) > dx
+ THEN cx0 := sign(rx0)
+ FI;
+ IF abs(rx1) > dx
+ THEN cx1 := sign(rx1)
+ FI;
+ IF abs(ry0) > dy
+ THEN cy0 := sign(ry0)
+ FI;
+ IF abs(ry1) > dy
+ THEN cy1 := sign(ry1)
+ FI.
+
+END PROC clipped line;
+
+END PACKET transformation;
+
+(******************************** picture ********************************)
+
+PACKET picture DEFINES (* Autor: H.Indenbirken *)
+ PICTURE, (* Stand: 23.02.1985 *)
+ :=, CAT, nilpicture,
+ draw, draw r, draw cm, draw cm r,
+ move, move r, move cm, move cm r,
+ bar, circle,
+ length, dim, pen, where,
+ extrema, rotate, stretch, translate,
+ text, picture:
+
+LET draw key = 1,
+ move key = 2,
+ text key = 3,
+ move r key = 4,
+ draw r key = 5,
+ move cm key = 6,
+ draw cm key = 7,
+ move cm r key = 8,
+ draw cm r key = 9,
+ bar key = 10,
+ circle key = 11,
+ max 2 dim = 31983,
+ max 3 dim = 31975,
+ max text = 31974,
+ max bar = 31982,
+ max circle = 31974,
+ max length = 32000;
+
+
+TYPE PICTURE = STRUCT (INT dim, pen, TEXT points);
+
+
+INT VAR read pos;
+REAL VAR x, y, z;
+TEXT VAR r2 :: 16*""0"", r3 :: 24*""0"", i1 :: ""0""0"";
+
+OP := (PICTURE VAR l, PICTURE CONST r) :
+ CONCR (l) := CONCR (r)
+END OP :=;
+
+OP CAT (PICTURE VAR l, PICTURE CONST r) :
+ IF l.dim <> r.dim
+ THEN errorstop ("OP CAT : left dimension <> right dimension")
+ ELIF length (l.points) > max length - length (r.points)
+ THEN errorstop ("OP CAT : Picture overflow") FI;
+
+ l.points CAT r.points
+END OP CAT;
+
+PICTURE PROC nilpicture :
+ PICTURE : (0, 1, "")
+END PROC nilpicture;
+
+PROC draw (PICTURE VAR p, TEXT CONST text) :
+ draw (p, text, 0.0, 0.0, 0.0)
+END PROC draw;
+
+PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle, height, bright):
+ write (p, text, angle, height, bright, text key)
+END PROC draw;
+
+PROC draw (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, draw key)
+END PROC draw;
+
+PROC draw (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, draw key)
+END PROC draw;
+
+PROC draw r (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, draw r key)
+END PROC draw r;
+
+PROC draw r (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, draw r key)
+END PROC draw r;
+
+PROC draw cm (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, draw cm key)
+END PROC draw cm;
+
+PROC draw cm r (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, draw cm r key)
+END PROC draw cm r;
+
+PROC move (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, move key)
+END PROC move;
+
+PROC move (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, move key)
+END PROC move;
+
+PROC move r (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, move r key)
+END PROC move r;
+
+PROC move r (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, move r key)
+END PROC move r;
+
+PROC move cm (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, move cm key)
+END PROC move cm;
+
+PROC move cm r (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, move cm r key)
+END PROC move cm r;
+
+PROC bar (PICTURE VAR p, REAL CONST width, height, INT CONST pattern):
+ write (p, width, height, pattern, bar key)
+END PROC bar;
+
+PROC circle (PICTURE VAR p, REAL CONST radius, from, to, INT CONST pattern):
+ write (p, radius, from, to, pattern, circle key)
+END PROC circle;
+
+
+PROC write (PICTURE VAR p, REAL CONST x, y, z, INT CONST key) :
+ IF length (p.points) < max 3 dim
+ THEN p.points CAT code (key);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ p.points CAT r3
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, REAL CONST x, y, INT CONST key) :
+ IF length (p.points) < max 2 dim
+ THEN p.points CAT code (key);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ p.points CAT r2
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, REAL CONST x, y, INT CONST n, key) :
+ IF length (p.points) < max bar
+ THEN p.points CAT code (key);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ p.points CAT r2;
+ replace (i1, 1, n);
+ p.points CAT i1
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, REAL CONST x, y, z, INT CONST n, key) :
+ IF length (p.points) < max circle
+ THEN p.points CAT code (key);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ p.points CAT r3;
+ replace (i1, 1, n);
+ p.points CAT i1
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, TEXT CONST t, REAL CONST angle, height, bright,
+ INT CONST key) :
+ IF max text - length (p.points) >= length (t)
+ THEN p.points CAT code (key);
+ replace (i1, 1, length (t));
+ p.points CAT i1;
+ p.points CAT t;
+ replace (r3, 1, angle);
+ replace (r3, 2, height);
+ replace (r3, 3, bright);
+ p.points CAT r3
+ FI;
+END PROC write;
+
+PROC check dim (PICTURE VAR p, INT CONST dim):
+ IF p.dim = 0
+ THEN p.dim := dim
+ ELIF p.dim <> dim
+ THEN errorstop ("Picture is " + text (p.dim) + " dimensional") FI
+END PROC check dim;
+
+INT PROC length (PICTURE CONST p):
+ length (p.points)
+END PROC length;
+
+INT PROC dim (PICTURE CONST pic) :
+ pic.dim
+END PROC dim;
+
+PROC pen (PICTURE VAR p, INT CONST pen) :
+ IF pen < 0 OR pen > 16
+ THEN errorstop ("pen out of range [0-16]") FI;
+ p.pen := pen
+END PROC pen;
+
+INT PROC pen (PICTURE CONST p) :
+ p.pen
+END PROC pen;
+
+PROC where (PICTURE CONST p, REAL VAR x, y) :
+ IF p.dim = 0
+ THEN x := 0.0; y := 0.0
+ ELIF p.dim = 3
+ THEN errorstop ("Picture is 3 dimensional")
+ ELSE x := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1;
+ y := subtext (p.points, length (p.points)-7, length (p.points)) RSUB 1
+ FI
+END PROC where;
+
+PROC where (PICTURE CONST p, REAL VAR x, y, z) :
+ IF p.dim = 0
+ THEN x := 0.0; y := 0.0; z := 0.0
+ ELIF p.dim = 2
+ THEN errorstop ("Picture is 2 dimensional")
+ ELSE x := subtext (p.points, length (p.points)-23, length (p.points)-16) RSUB 1;
+ y := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1;
+ z := subtext (p.points, length (p.points)-7, length (p.points)) RSUB 1;
+ FI
+END PROC where;
+
+
+PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max, z min, z max) :
+ x min := max real; x max :=-max real;
+ y min := max real; y max :=-max real;
+ z min := max real; z max :=-max real;
+ read pos := 0;
+ INT CONST pic length := length (p.points);
+ WHILE read pos < pic length
+ REP check position PER .
+
+check position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : calc extrema
+ CASE move key : calc extrema
+ CASE move r key : calc rel extrema
+ CASE draw r key : calc rel extrema
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+calc extrema :
+ x := next real; y := next real; z := next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y);
+ z min := min (z min, z); z max := max (z max, z) .
+
+calc rel extrema :
+ x INCR next real; y INCR next real; z INCR next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y);
+ z min := min (z min, z); z max := max (z max, z) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC extrema;
+
+PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max):
+ x min := max real; x max :=-max real;
+ y min := max real; y max :=-max real;
+ read pos := 0;
+ INT CONST pic length := length (p.points);
+ WHILE read pos < pic length
+ REP check position PER .
+
+check position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : calc extrema
+ CASE move key : calc extrema
+ CASE move r key : calc rel extrema
+ CASE draw r key : calc rel extrema
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+calc extrema :
+ x := next real; y := next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y) .
+
+calc rel extrema :
+ x INCR next real; y INCR next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC extrema;
+
+PROC rotate (PICTURE VAR p, REAL CONST angle) : (* X-Rotation *)
+ REAL CONST s :: sind( angle ), c := cosd( angle );
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( 1.0, 0.0, 0.0 ),
+ ROW 3 REAL : ( 0.0, c , s ),
+ ROW 3 REAL : ( 0.0, -s , c ),
+ ROW 3 REAL : ( 0.0, 0.0, 0.0 )))
+END PROC rotate;
+
+PROC yrotate (PICTURE VAR p, REAL CONST angle): (* Y-Rotation *)
+ REAL CONST s :: sind (angle), c :: cosd (angle);
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( c , 0.0, -s ),
+ ROW 3 REAL : ( 0.0, 1.0, 0.0 ),
+ ROW 3 REAL : ( s , 0.0, c ),
+ ROW 3 REAL : ( 0.0, 0.0, 0.0 )))
+END PROC yrotate;
+
+PROC zrotate (PICTURE VAR p, REAL CONST angle): (* Z-Rotation *)
+ REAL CONST s :: sind (angle), c :: cosd (angle);
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( c , s , 0.0 ),
+ ROW 3 REAL : ( -s , c , 0.0 ),
+ ROW 3 REAL : ( 0.0, 0.0, 1.0 ),
+ ROW 3 REAL : ( 0.0, 0.0, 0.0 )))
+END PROC zrotate;
+
+PROC rotate (PICTURE VAR p, REAL CONST phi, theta, lambda ) :
+ IF phi <> 0.0
+ THEN rotate (p, phi) FI;
+ IF theta <> 0.0
+ THEN yrotate (p, theta) FI;
+ IF lambda <> 0.0
+ THEN zrotate (p, lambda)
+ FI
+END PROC rotate;
+
+PROC stretch (PICTURE VAR pic, REAL CONST sx, sy) :
+ stretch (pic, sx, sy, 1.0)
+END PROC stretch;
+
+PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz) :
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( sx, 0.0, 0.0),
+ ROW 3 REAL : (0.0, sy, 0.0),
+ ROW 3 REAL : (0.0, 0.0, sz),
+ ROW 3 REAL : (0.0, 0.0, 0.0)))
+END PROC stretch;
+
+PROC translate (PICTURE VAR p, REAL CONST dx, dy) :
+ translate (p, dx, dy, 0.0)
+END PROC translate;
+
+PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz) :
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : (1.0, 0.0, 0.0),
+ ROW 3 REAL : (0.0, 1.0, 0.0),
+ ROW 3 REAL : (0.0, 0.0, 1.0),
+ ROW 3 REAL : ( dx, dy, dz)))
+END PROC translate;
+
+PROC transform (PICTURE VAR p, ROW 4 ROW 3 REAL CONST a) :
+ INT CONST pic length := length (p.points);
+ INT VAR begin pos;
+ read pos := 0;
+ x := 0.0; y := 0.0; z := 0.0;
+ IF p.dim = 2
+ THEN transform 2 dim pic
+ ELSE transform 3 dim pic FI .
+
+transform 2 dim pic:
+ WHILE read pos < pic length
+ REP transform 2 dim position PER .
+
+transform 2 dim position:
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : transform 2 dim point
+ CASE move key : transform 2 dim point
+ CASE move r key : transform 2 dim point
+ CASE draw r key : transform 2 dim point
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+transform 2 dim point:
+ begin pos := read pos+1;
+ x := next real; y := next real;
+ transform (a, x, y, z);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ replace (p.points, begin pos, r2) .
+
+transform 3 dim pic:
+ WHILE read pos < pic length
+ REP transform 3 dim position PER .
+
+transform 3 dim position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : transform 3 dim point
+ CASE move key : transform 3 dim point
+ CASE move r key : transform 3 dim point
+ CASE draw r key : transform 3 dim point
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+transform 3 dim point:
+ begin pos := read pos+1;
+ x := next real; y := next real; z := next real;
+ transform (a, x, y, z);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ replace (p.points, begin pos, r3) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC transform;
+
+PROC transform (ROW 4 ROW 3 REAL CONST a, REAL VAR x, y, z) :
+ REAL CONST ox :: x, oy :: y, oz :: z;
+ x := ox*a(1)(1) + oy*a(2)(1) + oz*a(3)(1) + a(4)(1);
+ y := ox*a(1)(2) + oy*a(2)(2) + oz*a(3)(2) + a(4)(2);
+ z := ox*a(1)(3) + oy*a(2)(3) + oz*a(3)(3) + a(4)(3)
+END PROC transform;
+
+TEXT PROC text (PICTURE CONST pic):
+ TEXT VAR result :: ""0""0""0""0""; (* 23.09.87 -cw- *)
+ replace (result, 1, pic.dim); (* wegen Heap-Ueberlauf *)
+ replace (result, 2, pic.pen);
+ result CAT pic.points;
+ result
+END PROC text;
+
+PICTURE PROC picture (TEXT CONST text):
+ PICTURE : (text ISUB 1, text ISUB 2, subtext (text, 5))
+END PROC picture;
+
+END PACKET picture;
+
+(******************************** picfile *********************************)
+
+PACKET picfile DEFINES (* Autor: H.Indenbirken *)
+ (* Stand: 23.02.1985 *)
+ PICFILE, :=, picture file,
+ select pen, selected pen, background,
+ set values, get values,
+ view, viewport, window, oblique, orthographic, perspective,
+ extrema,
+
+ put, get,
+ to first pic, to eof, to pic, up, down,
+ is first picture, eof, picture no, pictures,
+ delete picture, insert picture, read picture,
+ write picture, put picture:
+
+
+LET max pics = 1024,
+ pic dataspace = 1102;
+
+
+TYPE PICFILE = BOUND STRUCT (INT size, pos, background,
+ ROW 16 ROW 3 INT pens,
+ ROW 16 BOOL hidden,
+ ROW 3 ROW 2 REAL sizes,
+ ROW 2 ROW 2 REAL limits,
+ ROW 4 REAL angles,
+ ROW 2 REAL obliques,
+ ROW 3 REAL perspectives,
+ ROW max pics PICTURE pic);
+
+TEXT VAR i text :: ""0""0"", r text :: ""0""0""0""0""0""0""0""0"";
+INT VAR i;
+
+OP := (PICFILE VAR dest, PICFILE CONST source):
+ EXTERNAL 260
+END OP := ;
+
+OP := (PICFILE VAR p, DATASPACE CONST d) :
+ IF type (d) = pic dataspace
+ THEN CONCR (p) := d
+ ELIF type (d) < 0
+ THEN type (d, pic dataspace) ;
+ CONCR (p) := d ;
+ init picfile dataspace ;
+ ELSE errorstop ("dataspace is no PICFILE") FI .
+
+init picfile dataspace :
+ r.size := 0;
+ r.pos := 0;
+ r.background := 0;
+ r.sizes [1][1] := 0.0;
+ r.sizes [1][2] := 1.0;
+ r.sizes [2][1] := 0.0;
+ r.sizes [2][2] := 1.0;
+ r.sizes [3][1] := 0.0;
+ r.sizes [3][2] := 1.0;
+ r.limits [1][1] := 0.0;
+ r.limits [1][2] := 1.0;
+ r.limits [2][1] := 0.0;
+ r.limits [2][2] := 1.0;
+ r.angles [1] := 0.0;
+ r.angles [2] := 0.0;
+ r.angles [3] := 0.0;
+ r.angles [4] := 0.0;
+ r.obliques [1] := 0.0;
+ r.obliques [2] := 0.0;
+ r.perspectives [1] := 0.0;
+ r.perspectives [2] := 0.0;
+ r.perspectives [3] := 0.0;
+ FOR i FROM 1 UPTO 16
+ REP r.pens [i][1] := 1;
+ r.pens [i][2] := 0;
+ r.pens [i][3] := 1;
+ r.hidden [i] := TRUE
+ PER.
+
+r : CONCR (CONCR (p)).
+
+END OP :=;
+
+DATASPACE PROC picture file (TEXT CONST name) :
+ IF exists (name)
+ THEN old (name)
+ ELSE new (name) FI
+END PROC picture file;
+
+PROC select pen (PICFILE VAR p, INT CONST pen, colour, thickness, line type,
+ BOOL CONST hidden):
+ IF pen < 1 OR pen > 16
+ THEN errorstop ("pen out of range") FI;
+ p.pens [pen][1] := colour;
+ p.pens [pen][2] := thickness;
+ p.pens [pen][3] := line type;
+ p.hidden [pen] := hidden
+END PROC select pen;
+
+PROC selected pen (PICFILE CONST p, INT CONST pen,
+ INT VAR colour, thickness, line type,
+ BOOL VAR hidden):
+ IF pen < 1 OR pen > 16
+ THEN errorstop ("pen out of range") FI;
+ colour := p.pens [pen][1];
+ thickness := p.pens [pen][2];
+ line type := p.pens [pen][3];
+ hidden := p.hidden [pen]
+END PROC selected pen;
+
+INT PROC background (PICFILE CONST p):
+ p.background
+END PROC background;
+
+PROC background (PICFILE VAR p, INT CONST colour):
+ p.background := colour
+END PROC background;
+
+PROC get values (PICFILE CONST p,
+ ROW 3 ROW 2 REAL VAR size,
+ ROW 2 ROW 2 REAL VAR limits,
+ ROW 4 REAL VAR angles,
+ ROW 2 REAL VAR oblique,
+ ROW 3 REAL VAR perspective) :
+ size := p.sizes;
+ limits := p.limits;
+ angles := p.angles;
+ oblique := p.obliques;
+ perspective := p.perspectives;
+
+END PROC get values;
+
+PROC set values (PICFILE VAR p,
+ ROW 3 ROW 2 REAL CONST size,
+ ROW 2 ROW 2 REAL CONST limits,
+ ROW 4 REAL CONST angles,
+ ROW 2 REAL CONST oblique,
+ ROW 3 REAL CONST perspective) :
+ p.sizes := size;
+ p.limits := limits;
+ p.angles := angles;
+ p.obliques := oblique;
+ p.perspectives := perspective;
+
+END PROC set values;
+
+PROC view (PICFILE VAR p, REAL CONST alpha):
+ p.angles [1] := alpha
+END PROC view;
+
+PROC view (PICFILE VAR p, REAL CONST phi, theta):
+ p.angles [2] := sind (theta) * cosd (phi);
+ p.angles [3] := sind (theta) * sind (phi);
+ p.angles [4] := cosd (theta);
+END PROC view;
+
+PROC view (PICFILE VAR p, REAL CONST x, y, z):
+ p.angles [2] := x;
+ p.angles [3] := y;
+ p.angles [4] := z
+END PROC view;
+
+PROC viewport (PICFILE VAR p,REAL CONST hor min,hor max,vert min,vert max) :
+ p.limits [1][1] := hor min;
+ p.limits [1][2] := hor max;
+ p.limits [2][1] := vert min;
+ p.limits [2][2] := vert max;
+END PROC viewport;
+
+PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max) :
+ window (p, x min, x max, y min, y max, 0.0, 1.0)
+END PROC window;
+
+PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max, z min, z max) :
+ p.sizes [1][1] := x min;
+ p.sizes [1][2] := x max;
+ p.sizes [2][1] := y min;
+ p.sizes [2][2] := y max;
+ p.sizes [3][1] := z min;
+ p.sizes [3][2] := z max;
+END PROC window;
+
+PROC oblique (PICFILE VAR p, REAL CONST a, b) :
+ p.obliques [1] := a;
+ p.obliques [2] := b;
+ p.perspectives [1] := 0.0;
+ p.perspectives [2] := 0.0;
+ p.perspectives [3] := 0.0
+END PROC oblique;
+
+PROC orthographic (PICFILE VAR p) :
+ p.obliques [1] := 0.0;
+ p.obliques [2] := 0.0;
+ p.perspectives [1] := 0.0;
+ p.perspectives [2] := 0.0;
+ p.perspectives [3] := 0.0
+END PROC orthographic;
+
+PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz) :
+ p.obliques [1] := 0.0;
+ p.obliques [2] := 0.0;
+ p.perspectives [1] := cx;
+ p.perspectives [2] := cy;
+ p.perspectives [3] := cz
+END PROC perspective;
+
+PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max) :
+ REAL VAR dummy;
+ extrema (p, x min, x max, y min, y max, dummy, dummy)
+END PROC extrema;
+
+PROC extrema (PICFILE VAR p, REAL VAR x min,x max,y min,y max,z min,z max) :
+ REAL VAR new x min, new x max, new y min, new y max, new z min, new z max;
+ x min := max real; x max := - max real;
+ y min := max real; y max := - max real;
+ z min := max real; z max := - max real;
+ FOR i FROM 1 UPTO p.size
+ REP IF dim (p.pic [i]) = 2
+ THEN extrema (p.pic [i], new x min, new x max, new y min, new y max)
+ ELSE extrema (p.pic [i], new x min, new x max, new y min, new y max,
+ new z min, new z max)
+ FI;
+ x min := min (x min, new x min); x max := max (x max, new x max);
+ y min := min (y min, new y min); y max := max (y max, new y max);
+ z min := min (z min, new z min); z max := max (z max, new z max);
+ PER
+END PROC extrema;
+
+PROC put (FILE VAR f, PICFILE CONST p):
+ put line (f, parameter);
+ FOR i FROM 1 UPTO p.size
+ REP put line (f, text (p.pic [i])) PER .
+
+parameter:
+ intern (p.size) + intern (p.pos) + intern (p.background) + intern (p.pens) +
+ intern (p.hidden) + intern (p.sizes) + intern (p.limits) + intern (p.angles) +
+ intern (p.obliques) + intern (p.perspectives) .
+
+END PROC put;
+
+PROC get (PICFILE VAR p, FILE VAR f):
+ TEXT VAR record;
+ get line (f, record);
+ convert parameter;
+ FOR i FROM 1 UPTO p.size
+ REP get line (f, record);
+ p.pic [i] := picture (record)
+ PER .
+
+convert parameter:
+ convert (record, p.size); convert (record, p.pos);
+ convert (record, p.background); convert (record, p.pens);
+ convert (record, p.hidden); convert (record, p.sizes);
+ convert (record, p.limits); convert (record, p.angles);
+ convert (record, p.obliques); convert (record, p.perspectives) .
+
+END PROC get;
+
+PROC to first pic (PICFILE VAR p):
+ p.pos := 1
+END PROC to first pic;
+
+PROC to eof (PICFILE VAR p):
+ p.pos := p.size+1
+END PROC to eof;
+
+PROC to pic (PICFILE VAR p, INT CONST n):
+ IF n < 1
+ THEN errorstop ("Position underflow")
+ ELIF n > p.size
+ THEN errorstop ("Position after end of PICFILE")
+ ELSE p.pos := n FI
+END PROC to pic;
+
+PROC up (PICFILE VAR p):
+ to pic (p, p.pos-1)
+END PROC up;
+
+PROC up (PICFILE VAR p, INT CONST n):
+ to pic (p, p.pos-n)
+END PROC up;
+
+PROC down (PICFILE VAR p):
+ to pic (p, p.pos+1)
+END PROC down;
+
+PROC down (PICFILE VAR p, INT CONST n):
+ to pic (p, p.pos+n)
+END PROC down;
+
+BOOL PROC is first picture (PICFILE CONST p):
+ p.pos = 1
+END PROC is first picture;
+
+BOOL PROC eof (PICFILE CONST p):
+ p.pos >= p.size
+END PROC eof;
+
+INT PROC picture no (PICFILE CONST p):
+ p.pos
+END PROC picture no;
+
+INT PROC pictures (PICFILE CONST p):
+ p.size
+END PROC pictures;
+
+PROC delete picture (PICFILE VAR p) :
+ INT VAR i;
+ FOR i FROM p.pos+1 UPTO p.size
+ REP p.pic [i-1] := p.pic [i] PER;
+
+ p.pic [p.size] := nilpicture;
+ IF p.size > 1
+ THEN p.size DECR 1 FI
+END PROC delete picture;
+
+PROC insert picture (PICFILE VAR p) :
+ INT VAR i;
+ IF p.size >= max pics
+ THEN errorstop ("PICFILE overflow")
+ ELSE p.size INCR 1;
+ FOR i FROM p.size DOWNTO p.pos+1
+ REP p.pic [i] := p.pic [i-1] PER;
+
+ p.pic [p.pos] := nilpicture;
+ FI
+END PROC insert picture;
+
+PROC read picture (PICFILE VAR p, PICTURE VAR pic) :
+ pic := p.pic (p.pos) .
+END PROC read picture;
+
+PROC write picture (PICFILE VAR p, PICTURE CONST pic) :
+ p.pic (p.pos) := pic .
+END PROC write picture;
+
+PROC put picture (PICFILE VAR p, PICTURE CONST pic) :
+ IF p.size >= max pics
+ THEN errorstop ("PICFILE overflow")
+ ELSE p.size INCR 1;
+ p.pic [p.size] := pic;
+ FI
+END PROC put picture;
+
+TEXT PROC intern (INT CONST n):
+ replace (i text, 1, n);
+ i text
+END PROC intern;
+
+TEXT PROC intern (ROW 16 ROW 3 INT CONST n):
+ INT VAR i, j;
+ TEXT VAR result :: "";
+ FOR i FROM 1 UPTO 16
+ REP FOR j FROM 1 UPTO 3
+ REP result CAT intern (n [i][j]) PER
+ PER;
+ result
+END PROC intern;
+
+TEXT PROC intern (ROW 16 BOOL CONST n):
+ INT VAR i, result :: 0;
+ FOR i FROM 1 UPTO 16
+ REP IF n [i]
+ THEN set bit (result, i-1) FI
+ PER;
+ intern (result)
+END PROC intern;
+
+TEXT PROC intern (REAL CONST r):
+ replace (r text, 1, r);
+ r text
+END PROC intern;
+
+TEXT PROC intern (ROW 3 ROW 2 REAL CONST r):
+ INT VAR i, j;
+ TEXT VAR result :: "";
+ FOR i FROM 1 UPTO 3
+ REP FOR j FROM 1 UPTO 2
+ REP result CAT intern (r [i][j]) PER
+ PER;
+ result
+END PROC intern;
+
+TEXT PROC intern (ROW 2 ROW 2 REAL CONST r):
+ INT VAR i, j;
+ TEXT VAR result :: "";
+ FOR i FROM 1 UPTO 2
+ REP FOR j FROM 1 UPTO 2
+ REP result CAT intern (r [i][j]) PER
+ PER;
+ result
+END PROC intern;
+
+TEXT PROC intern (ROW 4 REAL CONST r):
+ intern (r [1]) + intern (r [2]) + intern (r [3]) + intern (r [4])
+END PROC intern;
+
+TEXT PROC intern (ROW 3 REAL CONST r):
+ intern (r [1]) + intern (r [2]) + intern (r [3])
+END PROC intern;
+
+TEXT PROC intern (ROW 2 REAL CONST r):
+ intern (r [1]) + intern (r [2])
+END PROC intern;
+
+PROC convert (TEXT VAR record, INT VAR n):
+ n := record ISUB 1;
+ record := subtext (record, 3)
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 16 ROW 3 INT VAR n):
+ INT VAR i, j;
+ FOR i FROM 1 UPTO 16
+ REP FOR j FROM 1 UPTO 3
+ REP convert (record, n [i][j]) PER
+ PER
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 16 BOOL VAR n):
+ INT VAR i, result;
+ convert (record, result);
+ FOR i FROM 1 UPTO 16
+ REP n [i] := bit (i-1, result) PER
+END PROC convert;
+
+PROC convert (TEXT VAR record, REAL VAR r):
+ r := record RSUB 1;
+ record := subtext (record, 9)
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 3 ROW 2 REAL VAR r):
+ INT VAR i, j;
+ FOR i FROM 1 UPTO 3
+ REP FOR j FROM 1 UPTO 2
+ REP convert (record, r [i][j]) PER
+ PER;
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 2 ROW 2 REAL VAR r):
+ INT VAR i, j;
+ FOR i FROM 1 UPTO 2
+ REP FOR j FROM 1 UPTO 2
+ REP convert (record, r [i][j]) PER
+ PER;
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 4 REAL VAR r):
+ convert (record, r [1]); convert (record, r [2]);
+ convert (record, r [3]); convert (record, r [4])
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 3 REAL VAR r):
+ convert (record, r [1]); convert (record, r [2]); convert (record, r [3])
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 2 REAL VAR r):
+ convert (record, r [1]); convert (record, r [2])
+END PROC convert;
+
+END PACKET picfile;
+
+(********************************* devices ********************************)
+
+PACKET devices DEFINES PLOTTER,
+ select plotter,
+ install plotter,
+ plotters,
+ plotter,
+ no plotter,
+ name,
+ channel,
+ station,
+ actual plotter,
+ drawing area,
+ plotter info,
+ :=,
+ = :
+
+LET trenn = "/";
+
+TYPE PLOTTER = STRUCT (INT station, channel, TEXT name);
+PLOTTER CONST noplotter :: PLOTTER : (0,0,"");
+PLOTTER VAR plotter id :: no plotter;
+TARGET VAR devices;
+TEXT VAR plotter set;
+INT VAR act plotter;
+
+OP := (PLOTTER VAR dest, PLOTTER CONST source):
+ CONCR (dest) := CONCR (source)
+END OP := ;
+
+BOOL OP = (PLOTTER CONST a, b):
+ (a.station = b.station) AND
+ (a.channel = b.channel) AND
+ (a.name = b.name )
+END OP =;
+
+PLOTTER PROC plotter:
+ plotter id
+END PROC plotter;
+
+PLOTTER PROC plotter (TEXT CONST def plotter):
+ select target (devices, def plotter, plotter set);
+ IF plotter set = ""
+ THEN IF def plotter = ""
+ THEN act plotter := 0;
+ no plotter
+ ELSE errorstop ("Unbekannter Plot-Id : " + def plotter);
+ no plotter
+ FI
+ ELSE select;plotter id
+ FI.
+
+ select:
+ INT VAR tp;
+ PLOTTER VAR plotter id;
+ plotter id.station := int(def plotter);
+ tp := pos (def plotter, trenn) + 1;
+ plotter id.channel := int(subtext (def plotter,tp));
+ plotter id.name := subtext (def plotter, pos (def plotter,trenn,tp)+1);
+END PROC plotter;
+
+PROC select plotter:
+ THESAURUS VAR plotter list :: empty thesaurus;
+ TEXT VAR plotter name;
+ INT VAR index :: 0;
+ get (plotters, plotter name, index);
+ WHILE index > 0 REP
+ insert (plotter list,plotter info (plotter name,60));
+ get (plotters, plotter name, index)
+ PER;
+ select plotter (name (plotters, link (plotter list, one(plotter list))))
+END PROC select plotter;
+
+PROC select plotter (PLOTTER CONST plotter):
+ select plotter (text (plotter.station) + trenn + text (plotter.channel) +
+ trenn + plotter.name)
+END PROC select plotter;
+
+PROC select plotter (TEXT CONST def plotter):
+ select target (devices, def plotter, plotter set);
+ IF plotter set = ""
+ THEN IF def plotter = ""
+ THEN act plotter := 0;
+ plotter id := no plotter
+ ELSE errorstop ("Unbekannter Plot-Id : " + def plotter)
+ FI
+ ELSE select
+ FI.
+
+ select:
+ INT VAR xp, yp, tp; REAL VAR xc, yc;
+ act plotter := link (plotters, def plotter);
+ plotter id.station := int(def plotter);
+ tp := pos (def plotter, trenn) + 1;
+ plotter id.channel := int(subtext (def plotter,tp));
+ plotter id.name := subtext (def plotter, pos (def plotter,trenn,tp)+1);
+ drawing area (xc, yc, xp, yp);
+ set drawing area (xc, yc, real (xp), real (yp));
+END PROC select plotter;
+
+PROC install plotter (TARGET VAR new plotset):
+ THESAURUS VAR new plotter :: target names (new plotset);
+ INT VAR index :: 0;
+ TEXT VAR name,set;
+ initialize target (devices);
+ get (new plotter,name,index);
+ WHILE index > 0 REP
+ select target (new plotset, name, set);
+ complete target (devices, name, set);
+ get (new plotter, name, index)
+ PER
+END PROC install plotter;
+
+INT PROC actual plotter:
+ act plotter
+END PROC actual plotter;
+
+THESAURUS PROC plotters:
+ target names (devices)
+END PROC plotters;
+
+TEXT PROC name (PLOTTER CONST plotter):
+ plotter.name
+END PROC name;
+
+INT PROC channel (PLOTTER CONST plotter):
+ plotter.channel
+END PROC channel;
+
+INT PROC station (PLOTTER CONST plotter):
+ plotter.station
+END PROC station;
+
+PROC drawing area (REAL VAR xcm, ycm, INT VAR xp, yp):
+ IF plotter set <> ""
+ THEN INT VAR cp;
+ xp := int(plotter set);
+ cp := pos (plotter set,",")+1;
+ yp := int (subtext (plotter set,cp));
+ cp := pos (plotter set,",",cp)+1;
+ xcm := real (subtext (plotter set,cp));
+ cp := pos (plotter set,",",cp)+1;
+ ycm := real (subtext (plotter set,cp))
+ FI
+END PROC drawing area;
+
+PROC drawing area (REAL VAR xcm, ycm, INT VAR xp, yp,PLOTTER CONST pl):
+ PLOTTER CONST keep :: plotter;
+ select plotter (pl);
+ drawing area (xcm, ycm, xp, yp);
+ select plotter (keep)
+END PROC drawing area;
+
+TEXT PROC plotter info (TEXT CONST plotter id,INT CONST len):
+ INT VAR tp :: pos (plotter id, trenn)+1;
+ TEXT VAR plotter name :: plotter id,
+ station :: "/Station" + text (int(plotter name),2),
+ kanal :: " Kanal" + text (int (subtext (plottername,tp)),3);
+ plotter name := subtext (plotter name, pos (plotter name, trenn,tp)+1) + " ";
+ INT VAR llen :: length (plotter name + kanal + station);
+ plotter name + (max(len-llen,0) * ".") + kanal + station
+END PROC plotter info;
+
+END PACKET devices
+
diff --git a/app/mpg/2.2/src/GRAPHIK.Configurator b/app/mpg/2.2/src/GRAPHIK.Configurator
new file mode 100644
index 0000000..68bf070
--- /dev/null
+++ b/app/mpg/2.2/src/GRAPHIK.Configurator
@@ -0,0 +1,946 @@
+(**************************************************************************)
+(* *)
+(* MPG - Graphik - System *)
+(* *)
+(* Version 2.2 vom 11.11.1987 *)
+(* *)
+(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *)
+(* unter Verwendung der Standard-Graphik *)
+(* "Graphik-Konfiguration" geschrieben von C.Weinholz *)
+(* *)
+(**************************************************************************)
+(* *)
+(* Graphik-Konfiguration *)
+(* *)
+(* Erstellung eines fuer alle Engeraete gueltigen *)
+(* Basisgraphik-Paketes durch zusammenfuegen *)
+(* von '.GCONF'-Dateien *)
+(* *)
+(* Aufruf durch 'configurate graphik', wenn insertiert *)
+(* (normalerweise nicht notwendig) *)
+(* Bei 'run' muss 'configurate graphik' ans Dateiende *)
+(* geschrieben werden. *)
+(* *)
+(**************************************************************************)
+PACKET graphik configuration DEFINES configurate graphik:
+
+LET PLOTTERCONF = STRUCT (TEXT name, station, channel, area, prep, init, end,
+ clear, home, move, draw, pixel, foreground,
+ background, palette, std colors, circle, box,
+ fill, cursor, get cursor, set marker, linked,
+ BOOL editor,
+ BOOL no plotter);
+LET max conf = 15,
+ dquote = ""34""34"",
+ interface = "GRAPHIK.Configuration",
+ env conf file = "ENVIRONMENT.GCONF",
+ packet header = "PACKET device interface DEFINES prepare, init plot, endplot, clear, home, moveto, drawto, setpixel, foreground, background, set color, stdcolors, color, colors, set palette, circle, box,fill,graphik cursor, get cursor, set marker:",
+ packet end = "END PACKET device interface",
+ target = "TARGET VAR  plotter; initialize target ( plotter);",
+ install target= "install plotter ( plotter);",
+ init set = "PROC initplot: IF  wsc THEN  palette :=  std palette
+ ELSE  palette :=  empty palette FI;  initplot; set palette
+ END PROC initplot;",
+ end set = "BOOL VAR  we::TRUE;
+ PROCendplot(BOOL CONSTs): we:=s
+ END PROCendplot;
+ PROCendplot: IF weTHEN endplotFI
+ END PROCendplot;",
+ clear set = "BOOL VAR  wc::TRUE; PROCclear(BOOL CONSTs): wc:=s
+ END PROC clear; PROC clear:IF wcTHEN clearFI END PROC clear;",
+ color set = "BOOL VAR  wsc::TRUE; TEXT VAR  palette; PROC setcolor (INT CONST no,rgb):
+ IF (no+1) <= colors THEN replace( palette,no+1,rgb)
+ FI END PROC set color;",
+ color set2 = "INT PROC colors : length ( palette) DIV 2 END PROC colors;
+ INT PROC color (INT CONST no): IF no >= 0 AND (no+1) <= colors
+ THEN  palette ISUB (no+1) ELSE maxint FI END PROC color;",
+ std colors = "PROCstdcolors(BOOL CONSTs):  wsc:=s END PROCstdcolors;
+ PROC stdcolors:IF wscTHEN palette :=  std palette;set palette FI END PROCstdcolors;",
+ foreground = "INT VAR af::1; INT PROCforeground: af END PROCforeground;
+ PROCforeground(INT CONSTm):  af:=m; foreground( af) END PROCforeground;",
+ background = "INT VAR  ab::0; INT PROCbackground: ab END PROCbackground;
+ PROCbackground(INT CONSTm):  ab:=m; background( ab) END PROCbackground;";
+
+ROW max conf PLOTTERCONF VAR plotter;
+ROW max conf DATASPACE VAR global data;
+
+TEXT CONST spaces :: 20 * " ";
+INT VAR inst plotter, targets, error line :: 0;
+TEXT VAR errorm1, errorm2, procvalue :: "", env conf, error source :: "";
+BOOL VAR errors :: FALSE;
+FILE VAR f;
+DATASPACE VAR conf ds;
+THESAURUS VAR plotconfs;
+
+PROC configurate graphik:
+ FOR inst plotter FROM 1 UPTO max conf REP
+ act plotter.name := "";
+ act plotter.area := "";
+ act plotter.prep := "";
+ act plotter.init := "";
+ act plotter.end := "";
+ act plotter.clear:= "";
+ act plotter.home := "";
+ act plotter.move := "";
+ act plotter.draw := "";
+ act plotter.pixel:= "";
+ act plotter.foreground := "";
+ act plotter.background := "";
+ act plotter.palette := "";
+ act plotter.circle := "";
+ act plotter.box := "";
+ act plotter.fill := "";
+ act plotter.cursor := "";
+ act plotter.get cursor := "";
+ act plotter.set marker := "";
+ act plotter.linked := "";
+ act plotter.editor := FALSE;
+ PER;
+ env conf := "";
+ inst plotter := 0;
+ plotconfs := empty thesaurus;
+ IF exists (env conf file)
+ THEN plotconfs := ALL env conf file
+ FI;
+ plotconfs := SOME (plotconfs + (all LIKE "*.GCONF") - env conf file);
+ INT VAR id :: 0; TEXT VAR conf file;
+ get (plotconfs, conf file, id);
+ WHILE id > 0 REP
+ IF exists (conf file)
+ THEN extract conf data (conf file)
+ ELSE get environment plotter
+ FI;
+ get (plotconfs, conf file, id);
+ PER;
+ IF inst plotter > 0
+ THEN generate interface
+ ELSE errorstop ("Kein Interface erzeugt")
+ FI;
+ last param (interface).
+
+ get environment plotter:
+ check sequence (conf file, "PLOTTER *,*,*,*,*,*,*;",
+ "2|4,3,3,3,3,3,3;",
+ "PLOTTER erwartet,"+
+ "Name erwartet,,"+
+ "Station erwartet,,"+
+ "Kanal erwartet,,"+
+ "XPixel erwartet,,"+
+ "YPixel erwartet,,"+
+ "Xcm erwartet,,"+
+ "Ycm erwartet,,"+
+ "Plotterkommando fehlerhaft");
+ IF errors
+ THEN errorstop (errorm2)
+ ELSE TEXT VAR one int :: ""0""0"", one real :: 8 * ""0"";
+ replace (one int,1,length(get var (1)));
+ env conf CAT one int;
+ env conf CAT get var (1);
+ replace (one int, 1, int (get var (2)));
+ env conf CAT one int;
+ replace (one int, 1, int (get var (3)));
+ env conf CAT one int;
+ replace (one int, 1, int (get var (4)));
+ env conf CAT one int;
+ replace (one int, 1, int (get var (5)));
+ env conf CAT one int;
+ replace (one real, 1, real (get var (6)));
+ env conf CAT one real;
+ replace (one real, 1, real (get var (7)));
+ env conf CAT one real;
+ FI
+END PROC configurate graphik;
+
+PROC extract conf data (TEXT CONST conf file):
+ TEXT VAR line;
+ inst plotter INCR 1;
+ IF inst plotter > max conf
+ THEN putline ("Warnung: Es koennen nicht mehr als " + text(max conf) +
+ " Geraete konfiguriert werden");
+ inst plotter DECR 1
+ ELSE error source := conf file;
+ conf ds := old (conf file);
+ f := sequential file (modify, conf ds);
+ set line numbers;
+ IF is plotter configuration
+ THEN get name and area (line, act plotter.name,
+ act plotter.station,
+ act plotter.channel,
+ act plotter.area);
+ get linked (act plotter.linked);
+ get includes;
+ putline ("""" + act plotter.name + """ wird eingelesen");
+ get paramless ("initplot",act plotter.init);
+ get paramless ("endplot" ,act plotter.end);
+ get paramless ("clear" ,act plotter.clear);
+ get paramless ("home" ,act plotter.home);
+ get paramless ("prepare" ,act plotter.prep);
+ get koord ("moveto" ,act plotter.move);
+ get koord ("drawto" ,act plotter.draw);
+ get koord ("setpixel",act plotter.pixel);
+ get var param ("foreground",act plotter.foreground);
+ get var param ("background",act plotter.background);
+ get paramless ("setpalette",act plotter.palette);
+ get std colors(act plotter.std colors);
+ get circle (act plotter.circle);
+ get box (act plotter.box);
+ get fill (act plotter.fill);
+ IF editor available
+ THEN get graphik cursor (act plotter.cursor);
+ get get cursor (act plotter.get cursor);
+ get set marker (act plotter.set marker)
+ FI;
+ push error;
+ IF anything noted
+ THEN f := sequential file (modify,conf file);
+ out (""7"");note edit (f);errorstop("")
+ FI
+ FI;
+ global data [inst plotter] := conf ds;
+ forget (conf ds)
+ FI.
+
+ is plotter configuration:
+ plotter [inst plotter].no plotter := NOT sequence found ("PLOTTER",
+ line, 1,TRUE);
+ NOT plotter [inst plotter].no plotter.
+
+ editor available:
+ plotter [inst plotter].editor := sequence found ("EDITOR", line, 1,TRUE);
+ IF plotter [inst plotter].editor
+ THEN delete record (f);
+ check sequence (line, "EDITOR;", "2;",
+ "EDITOR erwartet,"+
+ "Semikolon erwartet," +
+ "Editorkommando fehlerhaft")
+ FI;
+ plotter [inst plotter].editor.
+
+ set line numbers:
+ INT VAR line number;
+ to line (f,1);
+ FOR line number FROM 1 UPTO lines (f)-1 REP
+ cout (line number);
+ insert line number;
+ down (f)
+ PER;
+ insert line number.
+
+ insert line number:
+ TEXT VAR new line;
+ read record (f, new line);
+ insert char (new line, " ", 1);
+ insert char (new line, " ", 1);
+ replace (new line, 1, line number);
+ write record (f, new line).
+
+ get includes:
+ BOOL VAR include found :: sequence found ("INCLUDE",line, 1, TRUE);
+ WHILE include found REP
+ push error;
+ include found := sequence found ("INCLUDE",line, line no (f), TRUE);
+ IF include found
+ THEN add to plotconfs
+ FI
+ PER.
+
+ add to plotconfs:
+ check sequence (line, "INCLUDE *;","2|4;",
+ "INCLUDE erwartet,Dateiname erwartet," +
+ "Includekommando fehlerhaft");
+ IF NOT errors CAND exists (get var (1))
+ THEN IF NOT (plotconfs CONTAINS get var (1))
+ THEN insert (plotconfs,get var (1))
+ FI;
+ ELIF NOT errors
+ THEN error ("""" + get var (1) + """ existiert nicht")
+ FI;
+ delete record (f)
+END PROC extract conf data;
+
+PROC generate interface:
+ INT VAR act conf;
+ conf ds := nilspace;
+ forget (interface,quiet);
+ proc value := "";
+ FILE VAR f :: sequential file (output, conf ds);
+ putline (f,packet header);
+ putline (f,target);
+ generate target;
+ putline (f,install target);
+ putline (f,init set);
+ putline (f,end set);
+ putline (f,clear set);
+ putline (f,color set);
+ putline (f,color set 2);
+ putline (f, std colors);
+ putline (f,foreground);
+ putline (f,background);
+ FOR act conf FROM 1 UPTO inst plotter REP
+ FILE VAR source := sequential file (modify,global data [act conf]);
+ copy lines (f,source)
+ PER;
+ generate proc (""," initplot", TEXT PROC (INT CONST) initplotbody);
+ generate proc (""," endplot", TEXT PROC (INT CONST) endplotbody);
+ generate proc (""," clear", TEXT PROC (INT CONST) clearbody);
+ generate proc ("","prepare", TEXT PROC (INT CONST) prepbody);
+ proc value := " TEXT";
+ generate proc (""," std palette", TEXT PROC (INT CONST) std palette body);
+ generate proc (""," empty palette", TEXT PROC (INT CONST) empty palette body);
+ proc value := "";
+ generate proc ("","home", TEXT PROC (INT CONST) homebody);
+ generate proc ("INT CONST x,y","moveto", TEXT PROC (INT CONST) movebody);
+ generate proc ("INT CONST x,y","drawto", TEXT PROC (INT CONST) drawbody);
+ generate proc ("INT CONST x,y","set pixel", TEXT PROC (INT CONST) pixelbody);
+ generate proc ("INT VAR type"," foreground", TEXT PROC (INT CONST) foregroundbody);
+ generate proc ("INT VAR type"," background", TEXT PROC (INT CONST) backgroundbody);
+ generate proc ("","set palette", TEXT PROC (INT CONST) set palette body);
+ generate proc ("INT CONST x,y,rad,from,to","circle", TEXT PROC (INT CONST) circlebody);
+ generate proc ("INT CONST x1,y1,x2,y2,pattern", "box", TEXT PROC (INT CONST) box body);
+ generate proc ("INT CONST x,y,pattern","fill", TEXT PROC (INT CONST) fill body);
+ generate proc ("INT CONST x,y, BOOL CONST on","graphik cursor",TEXT PROC (INT CONST) graphik cursor body);
+ generate proc ("INT VAR x,y, TEXT VAR exit char","get cursor",TEXT PROC (INT CONST) get cursor body);
+ generate proc ("INT CONST x,y, type","set marker",TEXT PROC (INT CONST) set marker body);
+ proc value := "BOOL ";
+ generate proc ("","graphik cursor",TEXT PROC (INT CONST) editor available);
+ generate device link;
+ putline (f,packet end);
+ copy (conf ds,interface);
+ IF yes ("""" + interface + """ insertieren")
+ THEN insert (interface)
+ FI.
+
+ generate target:
+ INT VAR devices :: 0;
+ targets := 0;
+ FOR act conf FROM 1 UPTO inst plotter REP
+ TEXT VAR linked :: plotter[act conf].linked,
+ one int:: ""0""0"";
+ plotter [act conf].linked := "";
+ IF NOT plotter [act conf].no plotter
+ THEN putline (f,"complete target ( plotter,""" +
+ plotter [act conf].station + "/" +
+ plotter [act conf].channel + "/" +
+ plotter [act conf].name +
+ """,""" + plotter [act conf].area + """);");
+ devices INCR 1;
+ targets INCR 1;
+ replace (one int, 1, devices);
+ plotter [act conf].linked CAT one int;
+ replace (one int, 1, targets);
+ plotter [act conf].linked CAT one int;
+ IF linked > ""
+ THEN INT VAR x :: 1;
+ WHILE x <= length (linked) DIV 2 REP
+ putline (f,"complete target ( plotter, """ +
+ text(linked ISUB x) + "/" +
+ text(linked ISUB (x+1)) + "/" +
+ plotter[act conf].name + """,""" +
+ plotter[act conf].area + """);");
+ targets INCR 1;
+ replace (one int, 1, targets);
+ plotter [act conf].linked CAT one int;
+ x INCR 2
+ PER
+ FI
+ FI
+ PER;
+ WHILE env conf <> "" REP
+ generate env target (env conf)
+ PER
+END PROC generate interface;
+
+PROC generate env target (TEXT VAR conf):
+ INT VAR nlen :: conf ISUB 1;
+ TEXT VAR tnam :: subtext (conf, 3, 2+nlen);
+ conf := subtext (conf, nlen + 3);
+ putline (f,"complete target ( plotter, """ + text (conf ISUB 1) + "/" +
+ text (conf ISUB 2) + "/" + tnam + """,""" +
+ text (conf ISUB 3) + "," + text (conf ISUB 4) + "," +
+ first real + "," + text (conf RSUB 2) + """);");
+ conf := subtext (conf, 17).
+
+ first real:
+ conf := subtext (conf, 9);
+ text (conf RSUB 1)
+END PROC generate env target;
+
+TEXT PROC initplotbody (INT CONST no):
+ plotter [no].init
+END PROC initplotbody;
+
+TEXT PROC endplotbody (INT CONST no):
+ plotter [no].end
+END PROC endplotbody;
+
+TEXT PROC clearbody (INT CONST no):
+ plotter [no].clear
+END PROC clearbody;
+
+TEXT PROC prepbody (INT CONST no):
+ plotter [no].prep
+END PROC prepbody;
+
+TEXT PROC homebody (INT CONST no):
+ plotter [no].home
+END PROC homebody;
+
+TEXT PROC movebody (INT CONST no):
+ plotter [no].move
+END PROC movebody;
+
+TEXT PROC drawbody (INT CONST no):
+ plotter [no].draw
+END PROC drawbody;
+
+TEXT PROC pixelbody (INT CONST no):
+ plotter [no].pixel
+END PROC pixelbody;
+
+TEXT PROC std palette body (INT CONST no):
+ TEXT CONST rgb codes :: plotter [no].std colors;
+ TEXT VAR body :: dquote;
+ INT VAR x;
+ FOR x FROM 1 UPTO length (rgb codes) DIV 3 REP
+ INT VAR color :: int (subtext(rgb codes, (x-1)*3+1, x*3));
+ body CAT (text (color AND 255) + dquote);
+ body CAT (text (color DIV 256) + dquote);
+ PER;
+ body
+END PROC std palette body;
+
+TEXT PROC empty palette body (INT CONST no):
+ text (length (plotter[no].std colors) DIV 3) + "*" + dquote +
+ "255" + dquote + "127" + dquote
+END PROC empty palette body;
+
+TEXT PROC set palette body (INT CONST no):
+ plotter[no].palette
+END PROC set palette body;
+
+TEXT PROC foregroundbody (INT CONST no):
+ plotter [no].foreground
+END PROC foregroundbody;
+
+TEXT PROC backgroundbody (INT CONST no):
+ plotter [no].background
+END PROC backgroundbody;
+
+TEXT PROC circle body (INT CONST no):
+ plotter [no].circle
+END PROC circle body;
+
+TEXT PROC box body (INT CONST no):
+ plotter [no].box
+END PROC box body;
+
+TEXT PROC fill body (INT CONST no):
+ plotter [no].fill
+END PROC fill body;
+
+TEXT PROC graphik cursor body (INT CONST no):
+ plotter [no].cursor
+END PROC graphik cursor body;
+
+TEXT PROC get cursor body (INT CONST no):
+ plotter [no].get cursor
+END PROC get cursor body;
+
+TEXT PROC set marker body (INT CONST no):
+ plotter [no].set marker
+END PROC set marker body;
+
+TEXT PROC editor available (INT CONST no):
+ IF plotter [no].editor
+ THEN "TRUE"
+ ELSE "FALSE"
+ FI
+END PROC editor available;
+
+PROC generate device link:
+ INT VAR actconf;
+ putline (f, "INT PROC  act device :");
+ putline (f, "SELECT actual plotter OF");
+ FOR act conf FROM 1 UPTO inst plotter REP
+ IF NOT plotter [act conf].no plotter
+ THEN putline (f,"CASE " + text (plotter[act conf].linked ISUB 2) + ":");
+ put (f,text (plotter[act conf].linked ISUB 1));
+ IF length (plotter[act conf].linked) > 2
+ THEN generate table
+ FI
+ FI
+ PER;
+ putline (f,"OTHERWISE errorstop (""Kein Endgeraet angekoppelt"");0");
+ putline (f,"END SELECT END PROC  act device;").
+
+ generate table:
+ INT VAR x;
+ FOR x FROM 3 UPTO length (plotter[act conf].linked) DIV 2 REP
+ put (f,"CASE");
+ put (f,text (plotter[act conf].linked ISUB x));
+ put (f,":");
+ put (f, text (plotter[act conf].linked ISUB 1))
+ PER
+END PROC generate device link;
+
+PROC generate proc (TEXT CONST params,procname,TEXT PROC (INT CONST)procbody):
+ INT VAR actconf, no plotter :: 0;
+ IF params = ""
+ THEN putline (f,procvalue + " PROC " + procname + ":")
+ ELSE putline (f,procvalue + " PROC " + procname + "(" + params + "):")
+ FI;
+ IF procvalue <> ""
+ THEN putline (f,procvalue + " VAR  d;")
+ FI;
+ putline (f,"SELECT  act device OF");
+ FOR act conf FROM 1 UPTO inst plotter REP
+ IF NOT plotter [act conf].no plotter
+ THEN putline (f, "CASE " + text (act conf-no plotter) + ":" +
+ lowercase(plotter[act conf].name) +
+ plotter [act conf].channel + procname)
+ ELSE no plotter INCR 1
+ FI
+ PER;
+ IF procvalue <> ""
+ THEN putline (f," OTHERWISE  d END SELECT")
+ ELSE putline (f," END SELECT")
+ FI;
+ FOR act conf FROM 1 UPTO inst plotter REP
+ IF NOT plotter [act conf].no plotter
+ THEN putline (f,".");
+ putline (f,lowercase(plotter[act conf].name)+
+ plotter[act conf].channel + procname + ":");
+ putline (f,procbody (act conf))
+ FI
+ PER;
+ putline (f,"END PROC "+ procname +";")
+END PROC generate proc;
+
+PROC get name and area (TEXT CONST line, TEXT VAR name, station, channel, area):
+ push error;
+ check sequence (line, "PLOTTER *,*,*,*,*,*,*;",
+ "2|4,3,3,3,3,3,3;",
+ "PLOTTER erwartet,"+
+ "Name erwartet,,"+
+ "Station erwartet,,"+
+ "Kanal erwartet,,"+
+ "XPixel erwartet,,"+
+ "YPixel erwartet,,"+
+ "Xcm erwartet,,"+
+ "Ycm erwartet,,"+
+ "Plotterkommando fehlerhaft");
+ name := get var (1);
+ station := get var (2);
+ channel := get var (3);
+ area := "";
+ area CAT (get var (4) + ",");
+ area CAT (get var (5) + ",");
+ area CAT (get var (6) + ",");
+ area CAT (get var (7) + ",");
+ delete record (f)
+END PROC get name and area;
+
+PROC get linked (TEXT VAR keep):
+ TEXT VAR line;
+ IF sequence found ("LINK", line, 1, TRUE)
+ THEN extract data;
+ delete record (f)
+ FI.
+
+ extract data:
+ TEXT VAR symbol, one int :: ""0""0"";
+ INT VAR ltyp :: 2,type :: 0;(* 0 = ',' 1 = '/' 2 = Station 3 = Kanal*)
+ push error; (* 4 = Ende erwartet ! *)
+ keep := "";
+ errorm1 := line;
+ scan (line);
+ next symbol (symbol);
+ IF symbol <> "LINK"
+ THEN error ("LINK erwartet")
+ FI;
+ WHILE type < 7 AND NOT errors REP
+ next symbol (symbol, type);
+ IF ltyp = 0
+ THEN IF symbol = ","
+ THEN ltyp := 2
+ ELIF symbol = ";"
+ THEN ltyp := 4
+ ELSE error ("Semikolon oder Komma erwartet")
+ FI
+ ELIF ltyp = 1
+ THEN IF symbol = "/"
+ THEN ltyp := 3
+ ELSE error ("'/' erwartet")
+ FI
+ ELIF ltyp = 4
+ THEN IF type = 8
+ THEN error ("Kommentarende fehlt")
+ ELIF type = 9
+ THEN error ("Text unzulaessig (Textende fehlt)")
+ ELIF type <> 7
+ THEN error ("Zeilenende nach Semikolon erwartet")
+ FI
+ ELIF type = 3
+ THEN replace (one int, 1, int (symbol));
+ keep CAT one int;
+ ltyp DECR 1;
+ IF ltyp = 2
+ THEN ltyp := 0
+ FI
+ FI
+ PER
+END PROC get linked;
+
+PROC get graphik cursor (TEXT VAR keep):
+ get proc ("graphik cursor","(INT CONST x,y, BOOL CONST on)",
+ "(2|2 x,y,2|2 on)","INT erwartet, CONST erwartet,"+
+ "Formaler Parameter muss x heissen,"+
+ "Formaler Parameter muss y heissen,"+
+ "BOOL erwartet, CONST erwartet,"+
+ "Formaler Parameter muss on heissen",
+ keep);
+END PROC get graphik cursor;
+
+PROC get get cursor (TEXT VAR keep):
+ get proc ("get cursor","(INT VAR x,y, TEXT VAR exit char)",
+ "(2|2 x,y,2|2 exit char)","INT erwartet, VAR erwartet,"+
+ "Formaler Parameter muss x heissen,"+
+ "Formaler Parameter muss y heissen,"+
+ "TEXT erwartet, VAR erwartet,"+
+ "Formaler Parameter muss exit char heissen",
+ keep);
+END PROC get get cursor;
+
+PROC get set marker (TEXT VAR keep):
+ get proc ("set marker","(INT CONST x,y,type)","(2|2 x,y,type)",
+ "INT erwartet, CONST erwartet,"+
+ "Formaler Parameter muss x heissen,"+
+ "Formaler Parameter muss y heissen,"+
+ "Formaler Parameter muss type heissen",
+ keep);
+END PROC get set marker;
+
+PROC get std colors (TEXT VAR keep):
+ TEXT VAR line;
+ push error;
+ IF sequence found ("COLORS", line, 1, TRUE)
+ THEN extract data
+ ELSE error ("COLORS fehlt")
+ FI.
+
+ extract data:
+ check sequence (line, "COLORS *;","2|4;",
+ "COLORS erwartet,"+
+ "Rgbcodes erwartet,Semikolon fehlt");
+ keep := get var (1);
+ delete record (f);
+END PROC get std colors;
+
+PROC get paramless (TEXT CONST procname, TEXT VAR keep):
+ get proc (procname, "", "", "", keep)
+END PROC get paramless;
+
+PROC get var param (TEXT CONST procname, TEXT VAR keep):
+ get proc (procname, "(INT VAR type)","(2|2 type)",
+ "INT erwartet, VAR erwartet, Formaler Parameter muss type heissen",
+ keep);
+END PROC get var param;
+
+PROC get koord (TEXT CONST procname, TEXT VAR keep):
+ get proc (procname, "(INT CONST x,y)","(2|2 x,y)",
+ "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen,"+
+ "Formaler Parameter muss y heissen",keep)
+END PROC get koord;
+
+PROC get circle (TEXT VAR keep):
+ get proc ("circle","(INT CONST x,y,rad,from,to)","(2|2 x,y,rad,from,to)",
+ "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen,"+
+ "Formaler Parameter muss y heissen,Formaler Parameter muss rad heissen,"+
+ "Formaler Parameter muss from heissen,Formaler Parameter muss to heissen",
+ keep);
+END PROC get circle;
+
+PROC get box (TEXT VAR keep):
+ get proc ("box","(INT CONST x1,y1,x2,y2,pattern)","(2|2 x1,y1,x2,y2,pattern)",
+ "INT erwartet,CONST erwartet,Formaler Parameter muss x1 heissen,"+
+ "Formaler Parameter muss y1 heissen,Formaler Parameter muss x2 heissen,"+
+ "Formaler Parameter muss y2 heissen,Formaler Parameter muss pattern heissen",
+ keep);
+END PROC get box;
+
+PROC get fill (TEXT VAR keep):
+ get proc ("fill","(INT CONST x,y,pattern)","(2|2 x,y,pattern)",
+ "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen"+
+ "Formaler Parameter muss y heissen,Formaler Parameter muss pattern heissen",
+ keep);
+END PROC get fill;
+
+PROC get proc (TEXT CONST procname, psym, ptyp, perr,
+ TEXT VAR keep):
+ TEXT VAR line;
+ push error;
+ IF sequence found ("PROC"+procname, line, 1, TRUE)
+ THEN errors := FALSE;
+ get body (line,procname,psym,ptyp,perr,keep)
+ ELSE error (procname + " nicht gefunden")
+ FI
+END PROC get proc;
+
+PROC get body (TEXT CONST header,procname,psyms,ptypes ,perrs, TEXT VAR keep body):
+ INT VAR start, ende;
+ start := line no(f);
+ keep body := "";
+ check sequence (header, "PROC " + procname + psyms + ":",
+ "2|1"+ ptypes + ":",
+ "PROC erwartet," +
+ procname + " erwartet,,"+
+ perrs+
+ ",Fehler in " + procname + "-Header");
+ IF NOT errors
+ THEN get to end of proc
+ FI.
+
+ get to end of proc:
+ TEXT VAR last;
+ errors := FALSE;
+ IF sequence found ("END PROC " + procname, last, line no(f),FALSE)
+ THEN ende := line no (f);
+ check sequence (last, "END PROC " + procname + ";",
+ "2|2|1;",
+ "END erwartet,"+
+ "PROC erwartet,"+
+ "PROC heisst " + procname +
+ ",Semikolon fehlt");
+ IF NOT errors
+ THEN to line (f,start);
+ delete record (f);
+ INT VAR lc;
+ FOR lc FROM start UPTO ende-2 REP
+ TEXT VAR scratch;
+ read record (f,scratch);
+ scratch := subtext (scratch, 3);
+ keep body CAT (" " + scratch);
+ delete record (f);
+ PER;
+ delete record (f)
+ FI
+ ELSE error ("END PROC " + procname + " nicht gefunden")
+ FI
+END PROC get body;
+
+BOOL PROC sequence found (TEXT CONST sequence text,
+ TEXT VAR sequence line, INT CONST from line,
+ BOOL CONST evtl at):
+ BOOL VAR found :: FALSE, at char :: evtl at;
+ to line (f,from line);
+ col (f,1);
+ WHILE NOT (found OR eof (f)) REP
+ cout (line no (f));
+ to first char;
+ IF found
+ THEN read record (f, sequence line);
+ error line := sequence line ISUB 1;
+ sequence line := subtext (sequence line, 3);
+ scan sequence
+ FI
+ PER;
+ IF NOT found
+ THEN read record (f, sequence line);
+ IF pos (first char, sequence line) > 0
+ THEN scan sequence
+ FI
+ FI;
+ found.
+
+ to first char:
+ IF at char
+ THEN downety (f, first char)
+ ELSE down (f, first char)
+ FI;
+ at char := FALSE;
+ found := pattern found.
+
+ scan sequence:
+ TEXT VAR source symbols,symbols;
+ scan (sequence text);
+ get symbols;
+ source symbols := symbols;
+ scan (sequence line);
+ get symbols;
+ found := pos (symbols,source symbols) = 1.
+
+ get symbols:
+ TEXT VAR symbol;
+ INT VAR type;
+ symbols := "";
+ REP
+ next symbol (symbol, type);
+ symbols CAT symbol
+ UNTIL type > 6 PER.
+
+ first char:
+ sequence text SUB 1
+END PROC sequence found;
+
+PROC error (TEXT CONST emsg):
+ IF NOT eof (f)
+ THEN read record (f,errorm1);
+ errorm1 := """" + error source + """, Zeile " +
+ text (error line) + ":"
+ ELSE errorm1 := """" + error source + """, Fileende:"
+ FI;
+ errorm2 := spaces + emsg;
+ errors := TRUE
+END PROC error;
+
+PROC push error:
+ IF errors
+ THEN note (errorm1);note line;
+ note (10* " " + errorm2); note line;
+ errors := FALSE
+ FI
+END PROC push error;
+
+ (* Hinweis: bei Fehlermeldungen statt Blank ' ' (geschuetzt) verwenden.
+ Bei verschiedenen Typen ohne trennenden Delimiter zur
+ Abgrenzung in 'seq typ' '|' verwenden.
+ '*' wird in 'seq sym' als Wildcard verwendet (Itemweise)
+ Bei Delimitern wird der 'allgemeine Fehler' (letzter i.d Liste)
+ verwendet. Jedoch muss auch fuer Delimiter ein Eintrag
+ in der Liste freigehalten werden (...,,... oder ...,dummy,...).
+*)
+
+ROW 100 STRUCT (TEXT sym, INT typ, BOOL var) VAR seqlist;
+INT VAR scanpos;
+
+TEXT PROC get var (INT CONST no):
+ INT VAR count :: 0, checkpos :: 1;
+ WHILE checkpos <= scanpos REP
+ IF seqlist[checkpos].var
+ THEN count INCR 1;
+ IF count >= no
+ THEN LEAVE get var WITH seqlist[checkpos].sym
+ FI
+ FI;
+ checkpos INCR 1
+ PER;""
+END PROC get var;
+
+PROC check sequence (TEXT CONST seq, seq sym, seq typ, seq err):
+ ROW 100 TEXT VAR err;
+ INT VAR checkpos,erpos, typ, error1 :: 0,error2 :: 0;
+ TEXT VAR sym;
+ scan (seq err);
+ next symbol (sym, typ);
+ erpos := 1;
+ err[erpos] := "";
+ REP
+ SELECT typ OF
+ CASE 5: err[erpos] CAT " "
+ CASE 6: erpos INCR 1;
+ err [erpos] := ""
+ OTHERWISE err[erpos] CAT sym
+ END SELECT;
+ next symbol (sym, typ)
+ UNTIL typ >= 7 PER;
+ scan (seq);
+ FOR scanpos FROM 1 UPTO 100 REP
+ next symbol (seqlist[scanpos].sym,seqlist[scanpos].typ);
+ UNTIL seqlist[scanpos].typ >= 7 PER;
+ SELECT seqlist[scanpos].typ OF
+ CASE 8: error ("Kommentarende fehlt")
+ CASE 9: error ("Textende fehlt")
+ OTHERWISE IF scanpos = 100
+ THEN error ("Kommando zu schwierig")
+ FI
+ END SELECT;
+ scan (seq sym);
+ FOR checkpos FROM 1 UPTO scanpos REP
+ next symbol (sym, typ);
+ IF sym = "*"
+ THEN seqlist[checkpos].var := TRUE
+ ELSE seqlist[checkpos].var := FALSE
+ FI
+ PER;
+ scan (seq typ);
+ next symbol (sym,typ);
+ FOR checkpos FROM 1 UPTO scanpos REP
+ WHILE sym = "|" REP
+ next symbol (sym, typ)
+ PER;
+ BOOL VAR std err :: typ <> 3;
+ IF NOT std err
+ THEN typ := int(sym);
+ IF seqlist[checkpos].typ <> typ
+ THEN error1 := checkpos
+ FI;
+ ELIF seqlist[checkpos].sym <> sym
+ THEN error1 := erpos
+ FI;
+ next symbol (sym, typ)
+ UNTIL error1 > 0 OR typ >= 7 PER;
+ scan (seq sym);
+ next symbol (sym,typ);
+ FOR checkpos FROM 1 UPTO scanpos-1 REP
+ std err := typ = 6;
+ IF (seqlist[checkpos].sym <> sym) AND (sym <> "*")
+ THEN IF std err
+ THEN error2 := erpos
+ ELSE error2 := checkpos
+ FI
+ FI;
+ next symbol (sym, typ)
+ UNTIL error2 > 0 PER;
+ IF error1 = 0
+ THEN error1 := error2
+ ELIF error1 = erpos
+ THEN IF (error2 <> 0) AND (error2 <> erpos)
+ THEN error1 := error2
+ FI
+ FI;
+ IF error1 > 0
+ THEN error (err [error1])
+ FI
+END PROC check sequence;
+
+INT PROC lower pair (INT CONST upper pair):
+ INT VAR lower :: upper pair;
+ set bit (lower,5);
+ set bit (lower,13);
+ lower
+END PROC lower pair;
+
+TEXT PROC lower case (TEXT CONST uppercase):
+ TEXT VAR lower :: uppercase;
+ INT VAR x;
+ IF length(lower) MOD 2 <> 0
+ THEN lower CAT ""0""
+ FI ;
+ FOR x FROM 1 UPTO length(lower)DIV2 REP
+ replace (lower,x,lower pair (lower ISUB x))
+ PER;
+ lower
+END PROC lower case;
+
+PROC copy lines (FILE VAR dest, source):
+ INT VAR l;
+ input(source);
+ output(dest);
+ FOR l FROM 1 UPTO lines (source) REP
+ TEXT VAR scratch,test;
+ getline (source,scratch);
+ scratch := subtext (scratch,3);
+ test := scratch;
+ change all (test," ","");
+ IF test <> ""
+ THEN putline (dest, scratch)
+ FI
+ PER
+END PROC copy lines;
+
+.act plotter:
+ plotter[inst plotter]
+
+END PACKET graphik configuration;
+configurate graphik
+
diff --git a/app/mpg/2.2/src/GRAPHIK.Fkt b/app/mpg/2.2/src/GRAPHIK.Fkt
new file mode 100644
index 0000000..6e42af4
--- /dev/null
+++ b/app/mpg/2.2/src/GRAPHIK.Fkt
@@ -0,0 +1,1379 @@
+(***************************************************************************)
+(* *)
+(* FKT - Funktionenplotter *)
+(* *)
+(* Grundversion : MPG, KB, KN, LP 23.05.84 | 7756 Byte Code *)
+(* Version 6.20 : MPG, Rainer Kottmann 23.09.85 | 7196 Byte Paketdaten *)
+(* Angepasst an MPG-Turtle-Standard : 07.03.85 | 1374 Zeilen *)
+(* Version 8.21 : MPG,Beat Jegerlehner 18.09.87 | *)
+(* Angepasst an MPG EUMELGRAPHIK/EUMEL Version 1.8.1| *)
+(* *)
+(***************************************************************************)
+PACKET funktionen DEFINES fkt plot, (*************************************)
+ y grenzen, (* Interaktives Programm *)
+ wertetafel, (* Einzelprozeduren fuer "do" *)
+ ~, (* BOOL OP "ungefaehr gleich" *)
+ luecke : (* Dummykonstante fuer "undefiniert" *)
+ (*************************************)
+ (* Autoren: Klaus Bovermann *)
+ (* Kai Nikisch *)
+ (* Lutz Prechelt *)
+ (* Rainer Kottmann *)
+ (* Beat Jegerlehner *)
+ (*************************************)
+
+LET fkpos = 1, (* Diese LETs sind Bildschirmpositionen *)
+ inpos = 2,
+ wpos = 3,
+ fehlerpos = 5,
+ eingpos = 7,
+ textpos = 11,
+ wahlpos = 24,
+ xupos = 16,
+ yupos = 16,
+ xopos = 32,
+ yopos = 32,
+ stuetzpktpos = 48,
+ endgeraetepos = 20;
+
+LET punkte = 512, (* maximale Anzahl der Stuetzpunkte *)
+ ug1 = 0.15051, (* Hilfswerte fuer 'gauss' *)
+ ug2 = 0.5,
+ ug3 = 0.84948,
+ din a 4 hoehe = 5.0, (* Hoehe der Beschriftung *)
+ din a 4 breite = 5.0, (* in mm *)
+ ziffern = 12, (* Genauigkeitsangabe *)
+ gross = 8.888888e88,
+ epsilon = 1.0e-11;
+
+LET wahlstring = ""8""2"fdwsazntlLAqeb~?",
+ farbstr = "<CR>Standard <r>ot <b>lau <g>ruen <s>chwarz",
+ farbchars = ""13"rbgs",
+ graphikvater = "GRAPHIK",
+ helpfile = "FKT.help";
+
+ROW punkte REAL VAR graph;
+
+TEXT VAR term :: "",
+ rohterm :: "",
+ picfilename :: "",
+ prefix :: "PICFILE.",
+ postfix :: "",
+ fehlernachricht :: "",
+ proc,
+ inline;
+
+REAL VAR x min :: -gross, x max :: gross,
+ y min :: maxreal, y max :: -maxreal,
+ xstep;
+
+INT VAR nachkomma :: 2,
+ stuetzen :: punkte,
+ endgeraet :: 1,
+ endgeraete :: highest entry(plotters);
+
+BOOL VAR intervall definiert :: FALSE,
+ wertebereich bestimmt :: FALSE,
+ wertetafel vorhanden :: FALSE,
+ fehlerzustand :: FALSE;
+
+REAL CONST luecke :: gross;
+
+PICTURE VAR dummy picture :: nilpicture;
+move (dummy picture,0.0,0.0);
+
+(***************************************************************************)
+(* Alte Prozeduren (Graphik-unabhaengig) *)
+(***************************************************************************)
+
+PROC get (TEXT VAR text): (* moeglichkeit, ueberall abzubrechen! *)
+ text := "";
+ TEXT VAR exit char;
+ editget (text,""27"","",exit char);
+ IF exit char = ""27""
+ THEN errorstop("Abgebrochen")
+ FI
+END PROC get;
+
+PROC get (INT VAR nr):
+ TEXT VAR t;
+ get(t);
+ line;
+ nr := int(t)
+END PROC get;
+
+PROC get (REAL VAR nr):
+ TEXT VAR t;
+ get(t);
+ line;
+ nr := real(t)
+END PROC get;
+
+PROC editget (TEXT VAR t):
+ TEXT VAR t2 :: t,exit char;
+ editget(t2,""27"","",exit char);
+ IF exit char = ""27""
+ THEN errorstop("Abgebrochen")
+ FI;
+ t := t2
+END PROC editget;
+
+PROC inchar (TEXT VAR a,TEXT CONST b):
+ REP
+ inchar (a)
+ UNTIL pos(b,a) <> 0 OR a = ""27"" PER;
+ IF a = ""27""
+ THEN errorstop("Abgebrochen")
+ FI
+END PROC inchar;
+
+BOOL OP ~ (REAL CONST left , right) :
+ abs (left - right) <= xstep
+END OP ~;
+
+(******************* MAIN PROGRAMM *****************************)
+
+PROC fkt plot:
+ auswahlbild;
+ select plotter(name(plotters,endgeraet));
+ REP
+ bild;
+ auswahl (inline)
+ UNTIL inline = "q" PER
+
+END PROC fkt plot;
+
+(****************** LAY OUT *****************************)
+
+PROC auswahlbild:
+ page;
+ cursor (1,textpos);
+ put ("(f) Funktionsterm eingeben ");
+ putline ("(?) Hilfestellung ");
+ put ("(d) Definitionsbereich waehlen ");
+ putline ("(q) in die Kommandoebene zurueck ");
+ put ("(w) Wertebereich ermitteln lassen ");
+ putline ("(s) Anzahl der Stuetzpunkte waehlen ");
+ put ("(z) Zeichnung anfertigen ");
+ putline ("(n) Nachkommastellenzahl waehlen ");
+ put ("(a) Ausgabe der Zeichnung auf Endgeraet");
+ putline ("(e) Arbeit beenden ");
+ put ("(t) Wertetafel erstellen lassen ");
+ putline ("(L) Zeichnungen loeschen ");
+ put ("(l) Zeichnungen auflisten ");
+ putline ("(A) Zeichnungen archivieren ");
+ put (" ");
+ putline ("(b) Zeichnung beschriften ");
+ cursor (1,wahlpos);
+ put ("Ihre Wahl:")
+END PROC auswahlbild;
+
+PROC bild:
+ cursor (1,fkpos);
+ put ("f(x) = " + rohterm);
+ out (""5"");
+ cursor (1,inpos);
+ put ("Def.Bereich: [ / ]");
+ cursor (xupos,inpos);
+ put (text (x min,ziffern,nachkomma));
+ cursor (xopos,inpos);
+ put (text (x max,ziffern,nachkomma));
+ cursor (1,wpos);
+ put ("Wertebereich: [ / ]");
+ cursor (yupos,wpos);
+ put (text (y min,ziffern,nachkomma));
+ cursor (yopos,wpos);
+ put (text (y max,ziffern,nachkomma));
+ cursor (1,endgeraetepos);
+ put endgeraetestring;
+ cursor (stuetzpktpos,inpos);
+ put ("Anzahl der Stuetzpunkte: " + text (stuetzen,3));
+ drei zeilen ab eingpos loeschen.
+END PROC bild;
+
+(****************** MONITOR *****************************)
+
+PROC auswahl 1 (TEXT VAR wahl):
+ enable stop;
+ SELECT code (wahl) OF
+ CASE 8 : endgeraet := max(endgeraet-1,1);
+ select plotter(name(plotters,endgeraet))
+ CASE 2 : endgeraet := min(endgeraet+1,endgeraete);
+ select plotter(name(plotters,endgeraet))
+ CASE 102 : fkt lesen (* f *)
+ CASE 100 : defbereich waehlen (* d *)
+ CASE 119 : wertebereich erstellen (* w *)
+ CASE 116 : wertetafel erstellen (* t *)
+ CASE 113 : LEAVE auswahl 1 (* q *)
+ CASE 122 : graph erstellen (* z *)
+ CASE 97 : graph zeigen (* a *)
+ CASE 110 : genauigkeitsangabe (* n *)
+ CASE 65 : dm; (* A *)
+ auswahlbild
+ CASE 108 : dateien listen (* l *)
+ CASE 76 : dateien aus task raeumen (* L *)
+ CASE 101 : unterbrechung (* e *)
+ CASE 126 : spezialeingabe (* TIL *)
+ CASE 63 : hilfe (* ? *)
+ CASE 115 : stuetzpunkte setzen (* s *)
+ CASE 98 : zeichnung beschriften (* b *)
+ END SELECT;
+END PROC auswahl 1;
+
+PROC auswahl (TEXT VAR wahl): (* Faengerebene *)
+ cursor (12,24);
+ out (""5"");
+ inchar (wahl,wahlstring);
+ fehlerloeschen;
+ disable stop;
+ auswahl 1 (wahl);
+ IF is error
+ THEN fehlersetzen (error message);
+ clear error
+ FI;
+ enable stop;
+ IF fehlerzustand
+ THEN fehleraus (fehlernachricht)
+ FI
+END PROC auswahl;
+
+PROC put endgeraetestring:
+ TEXT VAR s :: "Endgeraet: ";
+ INT VAR i;
+ THESAURUS CONST t :: plotters;
+ FOR i FROM 1 UPTO endgeraete REP
+ IF length(s)+length(name(t,i))+4 > 79
+ THEN putline(s+""5"");
+ s := " "
+ FI;
+ IF i = endgeraet
+ THEN s CAT ""15"" + name(t,i) + " "14" "
+ ELSE s CAT " "+name(t,i) + " "
+ FI
+ PER;
+ putline(s+""5"")
+
+END PROC put endgeraetestring;
+
+
+(**************************** f *******************************************)
+
+PROC fkt lesen:
+ reset wertebereich;
+ cursor (1,eingpos);
+ put ("f(x) =");
+ out (""5"");
+ cursor (1,eingpos + 1);
+ out(""5"");
+ cursor (8,eingpos);
+ editget (rohterm);
+ change int to real (rohterm,term);
+ change all (term,"X","x");
+ change all (term,"=","~"); (* Ueberdeckung von = *)
+ change all (term,"<~","<="); (* ruecksetzen von <= *)
+ change all (term,">~",">="); (* " >= *)
+ term testen;
+ wertetafel vorhanden := FALSE.
+
+term testen:
+ disable stop;
+ proc := "REAL PROC f (REAL CONST x):";
+ proc CAT term;
+ proc CAT " END PROC f";
+ do ("do ("""+proc+""")"); (* komischer do-Fehler *)
+ IF is error
+ THEN fehlersetzen ("Term fehlerhaft");
+ clear error;
+ LEAVE fkt lesen
+ FI
+END PROC fkt lesen;
+
+(**************************** d *******************************************)
+
+PROC defbereich waehlen:
+ cursor (1,eingpos);
+ put ("Untergrenze :");
+ out (""5"");
+ get (x min);
+ obergrenze lesen;
+ intervall definiert := TRUE;
+ reset wertebereich.
+
+obergrenze lesen:
+ REP
+ put ("Obergrenze :");
+ out (""5"");
+ get (x max);
+ IF x max <= x min
+ THEN out (""7""13""3""5"")
+ FI
+ UNTIL x max > x min PER
+END PROC defbereich waehlen;
+
+(**************************** w *******************************************)
+
+PROC wertebereich erstellen:
+ IF rohterm = ""
+ THEN fehlersetzen ("Erst Fkts.Term eingeben! (f)");
+ LEAVE wertebereich erstellen
+ ELIF NOT intervall definiert
+ THEN fehlersetzen ("Erst Def.Bereich waehlen (d)");
+ LEAVE wertebereich erstellen
+ ELIF wertebereich bestimmt
+ THEN fehlersetzen ("Wertebereich ist bereits bestimmt");
+ LEAVE wertebereich erstellen
+ FI;
+ proc := "REAL PROC f (REAL CONST x):"+ term;
+ proc CAT " END PROC f; ygrenzen (PROC f)";
+ do (proc)
+END PROC wertebereich erstellen;
+
+PROC ygrenzen (REAL PROC (REAL CONST) f):
+ REAL VAR x, f von x;
+ INT VAR i :: 1;
+
+ disable stop;
+ xstep := (x max - x min) / real (stuetzen - 1);
+ x := x min;
+ y min := maxreal;
+ y max := -maxreal;
+ cursor (1,eingpos);
+ putline ("Wertebereich wird ermittelt");
+ out (""5"");
+ out ("bei Stuetzpunkt Nr.: ");
+ wertegrenzen berechnen;
+ IF is error
+ THEN fehler setzen (error message);
+ reset wertebereich;
+ LEAVE ygrenzen
+ ELIF fehlerzustand
+ THEN reset wertebereich;
+ LEAVE ygrenzen
+ ELSE wertebereich bestimmt := TRUE
+ FI;
+ IF y min = y max
+ THEN y min DECR 1.0;
+ y max INCR 1.0
+ FI.
+
+wertegrenzen berechnen:
+ FOR i FROM 1 UPTO stuetzen REP
+ x := real (i-1) * xstep + x min;
+ cout (i);
+ f von x := f (x);
+ graph [i] := f von x;
+ IF f von x <> luecke
+ THEN y min := min (y min, f von x);
+ y max := max (y max, f von x)
+ FI
+ UNTIL is error OR interrupt PER .
+
+interrupt:
+ IF incharety = ""27""
+ THEN fehlersetzen ("Abgebrochen");
+ TRUE
+ ELSE FALSE
+ FI
+END PROC ygrenzen;
+
+(**************************** t *******************************************)
+
+PROC wertetafel erstellen:
+ IF rohterm = ""
+ THEN fehleraus ("Erst Fkts.Term eingeben (f)");
+ LEAVE wertetafel erstellen
+ ELIF NOT intervall definiert
+ THEN fehleraus ("Erst Def.Bereich waehlen (d)");
+ LEAVE wertetafel erstellen
+ FI;
+ proc := "REAL PROC f (REAL CONST x):"+ term;
+ proc CAT " END PROC f; wertetafel (PROC f)";
+ do (proc)
+END PROC wertetafel erstellen;
+
+PROC wertetafel (REAL PROC (REAL CONST ) f):
+ FILE VAR g :: sequential file (output,rohterm);
+ REAL VAR x, f von x;
+ INT VAR i :: 0;
+
+ REP
+ schrittweite einlesen
+ UNTIL (xstep > 0.0) CAND ((x max-x min) / xstep < real (punkte)) PER;
+ x := x min;
+ evtl ueberschrift;
+ disable stop;
+ REP
+ datei erstellen
+ UNTIL x > x max OR is error PER;
+ fehleraus in tafel;
+ enable stop;
+ modify (g);
+ edit (g);
+ line;
+ IF yes("Tafel drucken")
+ THEN print (rohterm)
+ FI;
+ line (2);
+ IF yes("Tafel loeschen")
+ THEN forget(rohterm,quiet);
+ wertetafel vorhanden := FALSE
+ ELSE wertetafel vorhanden := TRUE
+ FI;
+ auswahlbild.
+
+evtl ueberschrift:
+ IF NOT wertetafel vorhanden
+ THEN putline (g, " W E R T E T A F E L");
+ line (g);
+ putline (g, " x ! " + rohterm);
+ putline (g, "----------------!----------------")
+ FI.
+
+fehleraus in tafel:
+ IF is error
+ THEN fehlernachricht := errormessage;
+ clearerror;
+ line (g,2);
+ putline (g,fehlernachricht);
+ fehlernachricht := ""
+ FI.
+
+datei erstellen:
+ i INCR 1;
+ cout (i);
+ put (g, text (x,ziffern,nachkomma));
+ put (g, " !");
+ f von x := f (x);
+ IF f von x <> luecke
+ THEN put (g, text (f von x,ziffern,nachkomma))
+ ELSE put (g, "Definitionsluecke")
+ FI;
+ line (g);
+ x INCR xstep.
+
+schrittweite einlesen:
+ cursor (1,eingpos);
+ put ("Schrittweite:");
+ out (""5"");
+ cursor (1,eingpos + 1);
+ out (""5"");
+ cursor (15,eingpos);
+ get (xstep);
+ put ("Zwischenpunkt :");
+ IF (xstep <= 0.0) COR ((x max-x min) / xstep > real (punkte))
+ THEN fehleraus ("Schrittweite zu klein");
+ LEAVE wertetafel
+ FI
+END PROC wertetafel;
+
+(*********************************** n *************************************)
+
+PROC genauigkeitsangabe:
+ cursor (1,eingpos);
+ put ("Anzahl der Nachkommastellen : ");
+ get (nachkomma);
+ disable stop;
+ nachkomma := min (nachkomma, ziffern - 3);
+ nachkomma := max (nachkomma, 0);
+ IF is error
+ THEN fehlersetzen ("Falscher Wert");
+ clear error;
+ nachkomma := 2
+ FI
+END PROC genauigkeitsangabe;
+
+(********************************l ****************************************)
+
+PROC dateien listen:
+ th(all LIKE (prefix+"*"));
+ auswahlbild
+END PROC dateien listen;
+
+(********************************L ****************************************)
+
+PROC dateien aus task raeumen:
+ forget(some(all LIKE (prefix+"*")));
+ auswahlbild
+END PROC dateien aus task raeumen;
+
+(**************************** s *******************************************)
+
+PROC stuetzpunkte setzen:
+ cursor (1,eingpos);
+ put ("Anzahl der Stuetzpunkte :");
+ get (stuetzen);
+ disable stop;
+ IF stuetzen <= 1 OR stuetzen > punkte
+ THEN fehler setzen ("Achtung Stuetzpunkte fehlerhaft")
+ FI;
+ stuetzen := max (stuetzen, 2) ;
+ stuetzen := min (stuetzen, punkte);
+ IF is error
+ THEN fehlersetzen ("Falscher Wert");
+ clear error;
+ stuetzen := punkte
+ FI;
+ reset wertebereich
+END PROC stuetzpunkte setzen;
+(**************************** e *******************************************)
+
+PROC unterbrechung:
+ break;
+ auswahlbild
+END PROC unterbrechung;
+
+(****************************** ? ******************************************)
+
+PROC hilfe:
+ IF NOT exists(helpfile)
+ THEN fetch(helpfile,task (graphikvater))
+ FI;
+ FILE VAR f :: sequential file(input,helpfile);
+ headline(f,"Verlassen mit <ESC> <q>");
+ open editor(f,FALSE);
+ edit (groesster editor,"q",PROC (TEXT CONST) dummy ed);
+ auswahlbild
+END PROC hilfe;
+
+PROC dummy ed (TEXT CONST t):
+ IF t = "q"
+ THEN quit
+ ELSE out(""7"")
+ FI
+END PROC dummy ed;
+
+(**************************** TILDE ****************************************)
+
+PROC spezialeingabe:
+ TEXT CONST termeingabename :: "Bitte Funktionsrumpf eingeben";
+ TEXT VAR t;
+ FILE VAR f :: sequential file (modify, termeingabename);
+
+ edit (f);
+ lese den term aus;
+ teste den term;
+ rohterm := "spezial";
+ reset wertebereich;
+ auswahlbild.
+
+lese den term aus:
+ term := "";
+ input (f);
+ WHILE NOT eof (f) REP
+ getline (f,t);
+ term CAT t;
+ term CAT " "
+ PER.
+
+teste den term:
+ disable stop;
+ proc := "REAL PROC f (REAL CONST x):";
+ proc CAT term;
+ proc CAT " END PROC f";
+ do (proc);
+ IF is error
+ THEN fehlersetzen ("Funktionsrumpf fehlerhaft");
+ clear error;
+ term := "";
+ rohterm := "";
+ reset wertebereich;
+ auswahlbild;
+ LEAVE spezialeingabe
+ FI
+END PROC spezialeingabe;
+
+(***************************************************************************)
+(********* Ab hier Hilfsprozeduren *********)
+(***************************************************************************)
+
+PROC fehleraus (TEXT CONST t):
+ cursor (1,fehlerpos);
+ out (""7"F E H L E R : ", t);
+ fehlerzustand := FALSE
+END PROC fehleraus;
+
+PROC fehlerloeschen:
+ cursor (1,fehlerpos);
+ out (""5"");
+ fehlernachricht := "";
+ fehlerzustand := FALSE
+END PROC fehlerloeschen;
+
+PROC fehler setzen (TEXT CONST message):
+ fehlernachricht := message;
+ fehlerzustand := TRUE;
+ clear error
+END PROC fehler setzen;
+
+REAL PROC gauss (REAL CONST z):
+ IF is integer (z)
+ THEN round (z,0)
+ ELIF sign (z) = -1
+ THEN floor (z) - 1.0
+ ELSE floor (z)
+ FI
+END PROC gauss;
+
+BOOL PROC is integer (REAL CONST x):
+ abs (x - floor (x)) < epsilon
+END PROC is integer;
+
+PROC berechnung (REAL CONST min, max,
+ REAL VAR sweite,
+ INT VAR styp):
+
+ sweite := faktor * round (10.0 ** expo,11).
+
+faktor:
+ IF nachkomma < ug1
+ THEN styp := 1;
+ 1.0
+ ELIF nachkomma < ug2
+ THEN styp := 2;
+ 2.0
+ ELIF nachkomma < ug3
+ THEN styp := 5;
+ 5.0
+ ELSE styp := 1;
+ 10.0
+ FI.
+
+nachkomma:
+ IF frac (logwert) < -epsilon
+ THEN 1.0 + frac (logwert)
+ ELIF frac (logwert) > epsilon
+ THEN frac (logwert)
+ ELSE 0.0
+ FI.
+
+differenz:
+ max - min.
+
+expo:
+ gauss (logwert) - 1.0.
+
+logwert:
+ round (log10 (differenz),8)
+END PROC berechnung;
+
+REAL PROC runde ab (REAL CONST was, auf):
+ auf * gauss (was / auf)
+END PROC runde ab;
+
+REAL PROC runde auf (REAL CONST was, auf):
+ REAL VAR hilf :: runde ab (was,auf);
+
+ IF abs (hilf - was) < epsilon
+ THEN was
+ ELSE hilf + auf
+ FI
+END PROC runde auf;
+
+PROC loesche zeile (INT CONST zeile):
+ cursor (1,zeile);
+ out (""5"")
+END PROC loesche zeile;
+
+PROC drei zeilen ab eingpos loeschen:
+ loesche zeile (eingpos);
+ loesche zeile (eingpos + 1);
+ loesche zeile (eingpos + 2);
+END PROC drei zeilen ab eingpos loeschen;
+
+PROC change int to real (TEXT CONST term alt,TEXT VAR term neu):
+ TEXT VAR symbol :: "", presymbol :: "";
+ INT VAR type :: 0, pretype :: 0, position;
+ LET number = 3,
+ tag = 1,
+ end of scan = 7,
+ pot = "**";
+
+ term neu := "";
+ scan (term alt);
+ WHILE type <> end of scan REP
+ presymbol := symbol;
+ pretype := type;
+ next symbol (symbol,type);
+ IF type <> number OR presymbol = pot
+ THEN term neu CAT evtl mal und symbol
+ ELSE term neu CAT changed symbol
+ FI
+ PER.
+
+evtl mal und symbol:
+ IF pretype = number AND type = tag
+ THEN "*" + symbol
+ ELSE symbol
+ FI.
+
+changed symbol:
+ position := pos (symbol,"e");
+ IF position <> 0
+ THEN text (symbol,position - 1) + ".0" +
+ subtext (symbol,position,length (symbol))
+ ELIF pos (symbol,".") = 0
+ THEN symbol CAT ".0";
+ symbol
+ ELSE symbol
+ FI
+END PROC change int to real;
+
+PROC reset wertebereich:
+ y min := -maxreal;
+ y max := maxreal;
+ wertebereich bestimmt := FALSE
+END PROC reset wertebereich;
+
+TEXT PROC textreal (REAL CONST z):
+ TEXT VAR t :: text (z);
+
+ IF (t SUB length (t)) = "."
+ THEN subtext (t,1,length (t) - 1)
+ ELIF (t SUB 1) = "."
+ THEN "0" + t
+ ELIF (t SUB 2) = "." AND sign (z) = -1
+ THEN "-0" + subtext (t,2)
+ ELIF t = "0.0"
+ THEN "0"
+ ELSE t
+ FI
+END PROC textreal;
+
+INT PROC length (REAL CONST z):
+ length (text (z))
+END PROC length;
+
+PROC put format(INT CONST wo, REAL CONST xxmi,xxma,yymi,yyma):
+ cursor (1,wo);
+ put ("Aktuelles Format: xmin xmax" +
+ " ymin ymax");
+ cursor (19,wo + 1);
+ put (text (xx mi,ziffern,nachkomma));
+ cursor (34,wo + 1);
+ put (text (xx ma,ziffern,nachkomma));
+ cursor (49,wo + 1);
+ put (text (yy mi,ziffern,nachkomma));
+ cursor (64,wo + 1);
+ put (text (yy ma,ziffern,nachkomma))
+END PROC put format;
+
+PROC out (TEXT CONST a, b) :
+ out (a); out (b)
+END PROC out;
+
+(***************************************************************************)
+(* Neue Prozeduren *)
+(***************************************************************************)
+
+PROC graph erstellen:
+ PICFILE VAR funktionen;
+ PICTURE VAR funktionsgraph :: nilpicture,
+ formatpic :: nilpicture;
+ REAL VAR xx min :: x min,
+ xx max :: x max,
+ yy min :: y min,
+ yy max :: y max;
+
+ IF rohterm = ""
+ THEN fehlersetzen ("Erst Funktionsterm waehlen (f)");
+ LEAVE graph erstellen
+ ELIF NOT wertebereich bestimmt
+ THEN fehlersetzen ("Erst Wertebereich bestimmen lassen (w)");
+ LEAVE graph erstellen
+ FI;
+
+ hole filenamen;
+ funktionen := picture file (picfilename);
+ initialisiere stifte;
+ waehle format;
+ zeichne graphen;
+ pictures ins picfile.
+
+hole filenamen:
+ TEXT VAR t :: "";
+ REP
+ namen lesen
+ UNTIL t = "l" OR t = "e" PER.
+
+namen lesen:
+ cursor (1,eingpos);
+ out ("Welchen Namen soll die Zeichnung haben: "+ prefix);
+ postfix:= rohterm;
+ editget (postfix);
+ line;
+ IF (postfix SUB 1) = "?"
+ THEN picfilename := one(all LIKE (prefix+"*"));
+ auswahlbild;
+ bild;
+ cursor(1,eingpos)
+ ELSE picfilename := prefix + postfix;
+ picfilename := compress (picfilename)
+ FI;
+ IF NOT exists (picfilename)
+ THEN LEAVE hole filenamen
+ FI;
+ putline ("Zeichnung gibt es schon!");
+ put ("loeschen (l), Namen neuwaehlen (n), " +
+ "alte Zeichnung ergaenzen (e):");
+ inchar (t,"lne");
+ IF t = "l"
+ THEN forget (picfilename,quiet)
+ ELIF t = "n"
+ THEN drei zeilen ab eingpos loeschen
+ FI.
+
+initialisiere stifte:
+ select pen (funktionen, 1, 1, 0, 1, TRUE); (* Standardfarbe *)
+ select pen (funktionen, 2, 2, 0, 1, TRUE); (* Rot *)
+ select pen (funktionen, 3, 3, 0, 1, TRUE); (* Blau *)
+ select pen (funktionen, 4, 4, 0, 1, TRUE); (* Gruen *)
+ select pen (funktionen, 5, 5, 0, 1, TRUE). (* Schwarz *)
+
+waehle format:
+ IF altes picfile
+ THEN ergaenze wertebereich
+ FI;
+ drei zeilen ab eingpos loeschen;
+ REAL VAR step;
+ INT VAR i dummy;
+ berechnung (yy min, yy max, step, idummy);
+ yy min := runde ab (yy min, step);
+ yy max := runde auf (yy max, step);
+ put format(eingpos, xx min, xx max, yy min, yy max);
+ pause ;
+ drei zeilen ab eingpos loeschen;
+ cursor(1,eingpos);
+ IF yes("Format aendern")
+ THEN interactive change of format (xx min,xx max,yy min,yy max)
+ FI;
+ drei zeilen ab eingpos loeschen.
+
+ergaenze wertebereich:
+ to pic (funktionen,3); (* Formatpicture *)
+ read picture (funktionen,formatpic);
+ move (formatpic, xx min, yy min);
+ move (formatpic, xx max, yy max);
+ extrema (formatpic, xx min, xx max, yy min, yy max).
+
+altes picfile:
+ t = "e".
+
+zeichne graphen:
+ REAL VAR x :: x min,
+ x schrittweite :: (x max - x min) / real (stuetzen - 1);
+ INT VAR i;
+
+ cursor (1,eingpos);
+ put ("Graph bei Stuetzpunkt Nr. ");
+ FOR i FROM 1 UPTO stuetzen REP
+ cout (i);
+ IF graph[i] <> luecke
+ THEN IF zuletzt luecke
+ THEN move (funktionsgraph, x, graph[i])
+ ELSE draw (funktionsgraph, x, graph[i])
+ FI
+ FI;
+ x INCR x schrittweite
+ UNTIL abbruch PER;
+ drei zeilen ab eingpos loeschen.
+
+ abbruch:
+ IF incharety = ""27""
+ THEN errorstop("Abgebrochen");
+ TRUE
+ ELSE FALSE
+ FI.
+
+ zuletzt luecke:
+ i = 1 COR graph[i-1] = luecke.
+
+pictures ins picfile:
+ setze graphenfarbe;
+ to first pic(funktionen);
+ IF altes picfile
+ THEN down (funktionen); (* Skip *)
+ down (funktionen)
+ ELSE put picture (funktionen, dummy picture); (* Zusaetzliche Beschr.*)
+ put picture (funktionen, dummy picture)
+ FI;
+ formatpic := nilpicture;
+ move (formatpic, xx min, yy min);
+ move (formatpic, xx max, yy max);
+ IF altes picfile
+ THEN write picture (funktionen, formatpic)
+ ELSE put picture (funktionen, formatpic)
+ FI;
+ put picture (funktionen, funktionsgraph).
+
+setze graphenfarbe:
+ cursor (1,eingpos);
+ put("Farbe des Graphen :");
+ pen (funktionsgraph, farbe).
+
+farbe :
+ TEXT VAR ff;
+ put(farbstr);
+ inchar (ff,farbchars);
+ out(ff);
+ pos (farbchars,ff).
+
+END PROC graph erstellen;
+
+PROC interactive change of format (REAL VAR x mi,x ma,y mi,y ma):
+ TEXT VAR tt;
+ REP
+ cursor (1,eingpos + 2);
+ put ("Geben Sie die neuen Koordinaten ein");
+ out (""5"");
+ pause (20);
+ loesche zeile (eingpos + 2);
+ cursor (1,eingpos + 2);
+ put ("xmin:");
+ tt := text (xmi);
+ editget (tt);
+ xmi := real (tt);
+ cursor (1,eingpos + 2);
+ put ("xmax:");
+ out (""5"");
+ tt := text (xma);
+ editget (tt);
+ xma := real (tt);
+ cursor (1,eingpos + 2);
+ put ("ymin:");
+ out (""5"");
+ tt := text (ymi);
+ editget (tt);
+ ymi := real (tt);
+ cursor (1,eingpos + 2);
+ put ("ymax:");
+ out (""5"");
+ tt := text (yma);
+ editget (tt);
+ yma := real (tt);
+ UNTIL format ok PER.
+
+ format ok:
+ IF xma <= xmi OR yma <= ymi
+ THEN fehlersetzen ("Format falsch");
+ FALSE
+ ELSE TRUE
+ FI
+END PROC interactive change of format;
+
+PROC geraet waehlen:
+END PROC geraet waehlen;
+
+PROC zeichnung beschriften:
+ namen holen;
+ PICFILE VAR funktionen :: picture file(picfilename);
+ PICTURE VAR beschr;
+ to pic(funktionen,2);
+ read picture(funktionen,beschr);
+ cursor(1,eingpos);
+ put("Beschriftung (e) rgaenzen , (l) oeschen oder (a) bbruch");
+ TEXT VAR t;
+ inchar(t,"ela");
+ IF t = "l"
+ THEN to pic(funktionen,2);
+ beschr := nilpicture;
+ write picture(funktionen,beschr)
+ ELIF t = "e"
+ THEN beschrifte
+ FI;
+ cursor(1,eingpos);
+ drei zeilen ab eingpos loeschen.
+
+ beschrifte:
+ farbe holen;
+ REAL VAR rx,ry,hx,bx;
+ to pic(funktionen,3);
+ PICTURE VAR format;
+ read picture(funktionen,format);
+ extrema(format,rx,ry,hx,bx);
+ drei zeilen ab eingpos loeschen;
+ put format (eingpos,rx,ry,hx,bx);
+ pause;
+ REP
+ drei zeilen ab eingpos loeschen;
+ cursor(1,eingpos);
+ put("Text :");
+ TEXT VAR btext;
+ getline(btext);
+ put("Koordinaten in (c)m oder in (r)eal ");
+ inchar(t,"cra");
+ drei zeilen ab eingpos loeschen;
+ cursor(1,eingpos);
+ put("X-Koordinate:");
+ get(rx);
+ put("Y-Koordinate:");
+ get(ry);
+ IF t = "c"
+ THEN move cm(beschr,rx,ry)
+ ELSE move (beschr,rx,ry)
+ FI;
+ drei zeilen ab eingpos loeschen;
+ cursor(1,eingpos);
+ put("Hoehe der Zeichen in mm :");
+ get(hx);
+ put("Breite der Zeichen in mm:");
+ get(bx);
+ draw(beschr,btext,0.0,hx,bx);
+ drei zeilen ab eingpos loeschen;
+ cursor(1,eingpos)
+ UNTIL no("Weitere Beschriftungen") PER;
+ to pic(funktionen,2);
+ write picture(funktionen,beschr).
+
+ farbe holen:
+ drei zeilen ab eingpos loeschen;
+ cursor(1,eingpos);
+ put("Farbe der Beschriftungen: ");
+ TEXT VAR ff;
+ put(farbstr);
+ inchar (ff,farbchars);
+ out(ff);
+ pen(beschr,pos (farbchars,ff)).
+
+ namen holen:
+ cursor(1,eingpos);
+ put("Wie heisst die Zeichnung:");
+ out(prefix);
+ editget(postfix);
+ picfilename := prefix + postfix;
+ IF (postfix SUB 1) = "?"
+ THEN picfilename := one(all LIKE (prefix + "*"));
+ auswahlbild;
+ bild
+ FI;
+ IF NOT exists(picfilename)
+ THEN fehlersetzen("Zeichnung gibt es nicht");
+ LEAVE zeichnung beschriften
+ FI
+
+END PROC zeichnung beschriften;
+
+PROC graph zeigen:
+ REAL VAR xx max,xx min,yy max,yy min;
+
+ cursor (1,eingpos);
+ put ("Wie heisst die Zeichnung :");
+ out(prefix);
+ editget(postfix);
+ picfilename := prefix+postfix;
+ IF (postfix SUB 1) = "?"
+ THEN picfilename := one(all LIKE (prefix+"*"));
+ postfix := subtext(picfilename,length(prefix)+1);
+ auswahlbild;
+ bild
+ ELIF NOT exists (picfilename)
+ THEN fehlersetzen ("Zeichnung gibt es nicht");
+ LEAVE graph zeigen
+ FI;
+ drei zeilen ab eingpos loeschen;
+ PICFILE VAR funktionen :: picture file (picfilename);
+ PICTURE VAR rahmen :: nilpicture;
+ hole ausschnitt;
+ hole headline;
+ erzeuge rahmen;
+ gib bild aus.
+
+ gib bild aus:
+ REAL VAR x cm,y cm; INT VAR i,j;
+ drawing area (x cm,y cm,i,j);
+ viewport (funktionen, 0.0, x cm/y cm, 0.0, 1.0);
+ erweitere bereich; (* Rundungsfehler beim clippen vermeiden !!! *)
+ window (funktionen, xx min, xx max, yy min, yy max);
+ plot (picfilename);
+ auswahlbild.
+
+ erweitere bereich:
+ xx max := xx max + (xx max - xx min) / real(i).
+
+ erzeuge rahmen:
+ to pic (funktionen,1);
+ waehle achsenart;
+ IF achsenart = "r"
+ THEN rahmen := frame (xx min,xx max,yy min,yy max)
+ ELSE rahmen := axis (xx min,xx max,yy min,yy max)
+ FI;
+ rahmen CAT beschriftung (xx min,xx max,yy min,yy max,headline,
+ achsenart = "r");
+ cursor (1,eingpos);
+ put ("Farbe des");
+ IF achsenart = "k"
+ THEN put("Koordinatensystems :")
+ ELSE put("Rahmens :")
+ FI;
+ pen (rahmen,farbe);
+ drei zeilen ab eingpos loeschen;
+ write picture (funktionen,rahmen).
+
+ farbe :
+ TEXT VAR ff;
+ put(farbstr);
+ inchar (ff,farbchars);
+ out(ff);
+ pos (farbchars,ff).
+
+ waehle achsenart:
+ TEXT VAR achsenart :: "r";
+ IF koord moeglich
+ THEN frage nach achsenart
+ FI.
+
+ frage nach achsenart:
+ cursor (1,eingpos);
+ put("<k>oordinatensystem oder <r>ahmen zeichnen ?");
+ inchar (achsenart,"kr");
+ putline(achsenart);
+ drei zeilen ab eingpos loeschen.
+
+ koord moeglich:
+ NOT (xmin >= 0.0 OR xx max <= 0.0 OR yy min >= 0.0 OR yy max <= 0.0).
+
+ hole ausschnitt:
+ PICTURE VAR format;
+ to pic (funktionen,3);
+ read picture (funktionen,format);
+ extrema (format, xx min, xx max, yy min, yy max);
+ cursor (1,eingpos);
+ put format (eingpos, xx min, xx max, yy min, yy max);
+ pause;
+ drei zeilen ab eingpos loeschen;
+ cursor (1,eingpos);
+ IF yes ("Wollen Sie den Ausschnitt veraendern")
+ THEN interactive change of format (xx min,xx max,yy min,yy max)
+ FI;
+ drei zeilen ab eingpos loeschen.
+
+ hole headline:
+ cursor (1,eingpos);
+ TEXT VAR headline :: rohterm;
+ put ("Ueberschrift :");
+ editget (headline);
+ drei zeilen ab eingpos loeschen
+END PROC graph zeigen;
+
+PICTURE PROC frame (REAL CONST xx min,xx max,yy min,yy max):
+
+ PICTURE VAR rahmen :: nilpicture;
+ zeichne achsen;
+ zeichne restrahmen;
+ rahmen.
+
+ zeichne restrahmen:
+ move (rahmen,xx min,yy max);
+ draw (rahmen,xx max,yy max);
+ draw (rahmen,xx max,yy min).
+
+ zeichne achsen:
+ rahmen := axis (xx min,xx max,yy min,(yy max - yy min) / 90.0,0,0);
+ rahmen CAT axis (yy min,yy max,xx min,(xx max - xx min) / 90.0,1,0)
+
+END PROC frame;
+
+PICTURE PROC axis (REAL VAR xx min,xx max,yy min,yy max):
+ PICTURE VAR rahmen :: nilpicture;
+ rahmen := axis (xx min,xx max,0.0,(yy max - yy min) / 180.0,0,1);
+ rahmen CAT axis (yy min,yy max,0.0,(xx max - xx min) / 180.0,1,1);
+ rahmen
+END PROC axis;
+
+PICTURE PROC axis (REAL CONST min, max, pos,strich,
+ INT CONST dir,mode):
+ PICTURE VAR achse :: nilpicture;
+ REAL VAR step,
+ feinstep,
+ wert;
+ INT VAR type;
+ berechnung (min,max,step,type);
+ feinstep := step / real(zwischenstriche);
+ IF min MOD feinstep <> 0.0
+ THEN wert := runde auf (min,feinstep);
+ ELSE wert := min
+ FI;
+ INT VAR zaehler :: int( wert MOD step / feinstep + 0.5);
+ WHILE wert <= max REP
+ IF wert = 0.0
+ THEN ziehe nullstrich
+ ELIF zaehler MOD zwischenstriche = 0
+ THEN ziehe normstrich
+ ELSE ziehe feinstrich
+ FI;
+ wert INCR feinstep;
+ zaehler INCR 1
+ PER;
+ zeichne achse;
+ achse.
+
+ zwischenstriche:
+ IF type = 2
+ THEN 4
+ ELSE 5
+ FI.
+
+ ziehe nullstrich:
+ REAL VAR p0 :: pos + real (mode) * strich * 3.0,
+ p1 :: pos - strich * 3.0;
+ ziehe linie.
+
+ ziehe normstrich:
+ p0 := pos + real (mode) * strich * 2.0;
+ p1 := pos - strich * 2.0;
+ ziehe linie.
+
+ ziehe feinstrich:
+ p0 := pos + real (mode) * strich;
+ p1 := pos - strich;
+ ziehe linie.
+
+ zeichne achse:
+ IF dir = 0
+ THEN move (achse,min,pos);
+ draw (achse,max,pos)
+ ELSE move (achse,pos,min);
+ draw (achse,pos,max)
+ FI.
+
+ ziehe linie:
+ IF dir = 0
+ THEN move (achse,wert,p0);
+ draw (achse,wert,p1)
+ ELSE move (achse,p0,wert);
+ draw (achse,p1,wert)
+ FI
+END PROC axis;
+
+PICTURE PROC beschriftung (REAL VAR xx min,xx max,yy min,yy max,
+ TEXT CONST ueberschrift,
+ BOOL CONST mode):
+ PICTURE VAR rahmen :: nilpicture;
+ beschrifte;
+ rahmen.
+
+ beschrifte :
+ REAL VAR x cm,y cm;
+ INT VAR dummy;
+ drawing area (x cm,y cm,dummy,dummy);
+ erweitere;
+ zeichne x achse;
+ zeichne y achse;
+ zeichne ueberschrift;
+ xx max := xn max;
+ xx min := xn min;
+ yy max := yn max;
+ yy min := yn min.
+
+ erweitere:
+ REAL VAR hoehe :: din a4 hoehe / 23.5 * y cm, { der Zeichen }
+ breite :: din a4 breite / 30.5 * x cm;
+ INT CONST anzahl y stellen :: max (stellen (yy min),stellen (yy max)),
+ anzahl x stellen :: max (stellen (xx min),stellen (xx max));
+ REAL VAR xn min :: xx min,
+ xn max :: xx max,
+ yn min :: yy min;
+ IF mode { rahmen wg clipping }
+ THEN xn min DECR (xx max - xx min) / 30.0;
+ yn min DECR (yy max - yy min) / 30.0
+ FI;
+ REAL VAR xx dif :: xx max - xn min,
+ yy dif :: yy max - yn min,
+ yn dif :: y cm / (y cm - 2.0 * hoehe / 10.0 - 0.4) * yy dif,
+ xn dif :: x cm / (x cm - x erweiterung) * xx dif,
+ y 1 mm :: yn dif / y cm / 10.0,
+ r hoch :: hoehe / y cm / 10.0 * yn dif,
+ r breit:: breite / x cm / 10.0 * xn dif,
+ yn max :: yy max + r hoch + 3.0 * y 1 mm;
+ yn min := yn min - r hoch - 2.0 * y 1 mm;
+ IF mode
+ THEN xn min := xn min - real(anzahl y stellen) * r breit
+ FI.
+
+ x erweiterung:
+ IF mode
+ THEN real(anzahl y stellen) * breite / 10.0
+ ELSE 0.0
+ FI.
+
+ zeichne x achse:
+ TEXT VAR zahl :: text (xx min, anzahl x stellen, nachkomma);
+ ersetze zahl;
+ move (rahmen, max(xn min, xx min - real(length(zahl)) * r breit / 2.0),
+ yn min);
+ draw (rahmen, zahl, 0.0, breite, hoehe);
+ zahl := text (xx max, anzahl x stellen, nachkomma);
+ ersetze zahl;
+ move (rahmen, xx max - real(length(zahl)) * r breit, yn min);
+ draw (rahmen, zahl, 0.0, breite, hoehe).
+
+ zeichne y achse:
+ zahl := text (yy min, anzahl y stellen, nachkomma);
+ ersetze zahl;
+ move (rahmen, max (xn min, xx min - real(length(zahl)) * r breit -
+ (xx max - xx min) / 30.0),yy min - r hoch / 2.0);
+ draw (rahmen, zahl, 0.0, breite, hoehe);
+ zahl := text (yy max,anzahl y stellen,nachkomma);
+ ersetze zahl;
+ move (rahmen, max (xn min, xx min - real(length(zahl)) * r breit -
+ (xx max - xx min) / 30.0),yy max - r hoch / 2.0);
+ draw (rahmen, zahl, 0.0, breite, hoehe).
+
+ zeichne ueberschrift:
+ move (rahmen, (xx max + xx min - real(length(ueberschrift)) * r breit)
+ / 2.0, yy max + y 1 mm);
+ draw (rahmen, ueberschrift, 0.0, breite, hoehe).
+
+ ersetze zahl:
+ change all (zahl, ".", ",")
+
+END PROC beschriftung;
+
+INT PROC stellen (REAL CONST r):
+ IF r = 0.0
+ THEN nachkomma + 2
+ ELSE nachkomma + 3 + max (0, int ( round(log10 (abs(r)),nachkomma)))
+ FI
+END PROC stellen
+
+END PACKET funktionen;
+
+PACKET fkt manager DEFINES fkt manager:
+
+LET continue code = 100,
+ ack = 0,
+ nack = 1;
+
+DATASPACE VAR dummy space;
+INT VAR order;
+TASK VAR order task;
+
+PROC fkt manager:
+ set autonom;
+ disable stop;
+ break (quiet);
+ REP
+ forget (dummy space);
+ wait (dummy space, order, order task);
+ IF order >= continue code AND order task = supervisor
+ THEN call (supervisor, order, dummy space, order);
+ IF order = ack
+ THEN fkt online
+ FI;
+ set autonom;
+ command dialogue (FALSE);
+ forget (ALL myself)
+ ELSE send (order task, nack, dummy space)
+ FI
+ PER.
+
+ fkt online:
+ command dialogue (TRUE);
+ fktplot;
+ IF online
+ THEN eumel must advertise;
+ break (quiet)
+ FI
+END PROC fktmanager
+
+END PACKET fktmanager
+
diff --git a/app/mpg/2.2/src/GRAPHIK.Install b/app/mpg/2.2/src/GRAPHIK.Install
new file mode 100644
index 0000000..acd1d38
--- /dev/null
+++ b/app/mpg/2.2/src/GRAPHIK.Install
@@ -0,0 +1,84 @@
+(**************************************************************************)
+(* *)
+(* MPG - Graphik - System *)
+(* *)
+(* Version 2.1 vom 10.09.1987 *)
+(* *)
+(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *)
+(* unter Verwendung der Standard-Graphik *)
+(* "Graphik-Installation" geschrieben von C.Weinholz *)
+(* *)
+(**************************************************************************)
+(* *)
+(* Dieses Programm wird in eine neueingerichtete Task *)
+(* GRAPHIK vom Archiv geladen, und sorgt nach 'run' *)
+(* fuer die volstaendige Installation des Graphik-Systems *)
+(* *)
+(**************************************************************************)
+(* Urversion : 10.09.87 *)
+(* Aenderungen: 23.09.87, Carsten Weinholz *)
+(* global manager aequivalent ersetzt *)
+(* 'family password' wird nun erfragt und gesetzt *)
+(* *)
+(**************************************************************************)
+LET packet 1 = "GRAPHIK.Basis",
+ packet 2 = "GRAPHIK.Plot",
+ config = "GRAPHIK.Configurator",
+ install = "GRAPHIK.Configuration",
+ fkt = "GRAPHIK.Fkt",
+ fkthelp = "FKT.help",
+ turtle = "GRAPHIK.Turtle";
+
+FILE VAR f;
+TEXT VAR l;
+INT VAR x;
+
+check off;
+warnings off;
+archiv;
+fetch (ALLarchive- all,archive);
+BOOL VAR new conf :: NOT exists (install);
+IF new conf
+ THEN mess ("GRAPHIK muss neu konfiguriert werden")
+ ELSE new conf := yes ("GRAPHIK neu konfigurieren")
+FI;
+release;
+ins (packet 1);
+IF new conf
+ THEN run (config)
+ ELSE ins (install)
+FI;
+ins (packet 2);
+ins (fkt);
+ins (turtle);
+do ("generate plot manager");
+mess (""15" Fertig "14"");
+IF yes ("Alles loeschen")
+ THEN command dialogue (FALSE);
+ forget (all-fkthelp);
+ command dialogue (TRUE)
+FI;
+TEXT VAR geheim;
+put ("GRAPHIK-Password: ");
+get secret line (geheim);
+family password (geheim);
+global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) std manager);
+
+PROC ins (TEXT CONST name):
+ page;
+ f := sequential file (input, name);
+ FOR x FROM 1 UPTO 11 REP
+ getline (f,l);
+ putline (l);
+ PER;
+ mess ("""" + name + """ wird insertiert"13""10"");
+ insert (name)
+END PROC ins;
+
+PROC mess (TEXT CONST msg):
+ line;
+ putline (msg);
+END PROC mess;
+
+
+
diff --git a/app/mpg/2.2/src/GRAPHIK.Manager b/app/mpg/2.2/src/GRAPHIK.Manager
new file mode 100644
index 0000000..df9df6b
--- /dev/null
+++ b/app/mpg/2.2/src/GRAPHIK.Manager
@@ -0,0 +1,925 @@
+(**************************************************************************)
+(* *)
+(* MPG - Graphik - System *)
+(* *)
+(* Version 2.2 vom 23.09.1987 *)
+(* *)
+(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *)
+(* unter Verwendung der Standard-Graphik *)
+(* "Graphik-Plotmanager" geschrieben von C.Weinholz *)
+(* *)
+(**************************************************************************)
+(* *)
+(* Dieses Paket stellt den Multispool-Ausgabemanager *)
+(* zur Verfuegung. *)
+(* Er wird in der Regel durch Aufruf von *)
+(* 'generate plot manager' in GRAPHIK in einer neuerzeugten *)
+(* Sohntask 'PLOT' installiert. *)
+(* *)
+(**************************************************************************)
+(* Urversion : 10.09.87 *)
+(* Aenderungen: 23.09.87, Carsten Weinholz *)
+(* Kommando 'spool control ("TEXT")' im Plot-Monitor *)
+(* Anzeige von 'order tasks' anderer Stationen *)
+(* 11.1.88, Thomas Clermont *)
+(* Fehler 'Zu viele DATASPACEs' und *)
+(* Spooling von zwei gleichnamigen JOBs behoben. *)
+(* Fehler : Keine bekannt. *)
+(**************************************************************************)
+PACKET plot manager DEFINES plot manager ,
+ plot server :
+
+LET max spools = 14, (* Hinweis: max spools + dataspaces + *)
+ max entries = 14, (* max spools * max entries < 250 *)
+
+ ack = 0,
+ second phase ack = 5,
+ false code = 6,
+ fetch code = 11,
+ save code = 12,
+ existscode = 13,
+ erase code = 14,
+ list code = 15,
+ all code = 17,
+ first code = 25,
+ start code = 26,
+ stop code = 27,
+ halt code = 28,
+ wait for halt code = 29,
+ continue code = 100,
+ picfiletype = 1102,
+
+ trenn = "/",
+
+ MSG = STRUCT (TEXT ds name, dev name, passwd, INT dev no),
+
+ JOB = STRUCT (DATASPACE ds, TEXT ds name, TASK order task),
+
+ ENTRY = STRUCT (JOB job, INT link),
+
+ CHAIN = STRUCT (ROW max entries ENTRY entry, INT first, last, empty),
+
+ SERVER = STRUCT (TASK task, wait for halt, REAL time,
+ JOB current job, BOOL stopped, INT link);
+
+ROW max spools STRUCT (SERVER server, CHAIN chain) VAR device;
+
+MSG VAR msg;
+
+INT VAR entry to erase, last created server, reply, current plotter;
+FILE VAR chain info;
+THESAURUS VAR managed plotter;
+BOUND THESAURUS VAR thesaurus msg;
+DATASPACE VAR reply ds;
+TASK VAR control task;
+
+(********************************* SPOOL ***********************************)
+
+PROC plot manager :
+ INT VAR act dev;
+ managed plotter := plotters LIKE (text (station (myself)) + any);
+ FOR act dev FROM 1 UPTO max devices REP
+ init device (act dev)
+ PER;
+ control task := niltask;
+ end global manager (FALSE);
+ global manager (PROC (DATASPACE VAR,INT CONST,INT CONST,TASK CONST)plot manager)
+END PROC plot manager;
+
+PROC plot manager (DATASPACE VAR ds, INT CONST order, phase, TASK CONST order task):
+ enable stop;
+ INT VAR act dev;
+ SELECT order OF
+ CASE fetch code : y fetch
+ CASE save code : y save
+ CASE exists code: y exists
+ CASE erase code : y erase
+ CASE list code : y list
+ CASE all code : y all
+ OTHERWISE IF order >= continue code AND order task = supervisor
+ THEN forget (ds);
+ continue (order - continue code);
+ spool monitor
+ ELIF priv control op
+ THEN SELECT order OF
+ CASE first code : y first
+ CASE start code : y start
+ CASE stop code : y stop
+ CASE halt code : y halt
+ CASE wait for halt code : y halt
+ OTHERWISE order error
+ ENDSELECT
+ ELSE order error
+ FI;
+ END SELECT;
+ BOOL VAR test;
+ FOR act dev FROM 1 UPTO max devices REP
+ test := server is active (act dev)
+ PER;
+ forget (ds).
+
+ priv control op:
+ (order task = father) OR (order task < supervisor) OR
+ spool control task.
+
+ spool control task:
+ NOT (order task = niltask) CAND
+ ((order task = control task) OR (order task < control task)).
+
+ y fetch:
+ FOR act dev FROM 1 UPTO max devices REP
+ UNTIL act server.task = order task PER;
+ IF act dev > max devices
+ THEN order error
+ ELIF chain is empty (act dev) OR act server.stopped
+ THEN end server (act dev);
+ IF exists (act server.wait for halt)
+ THEN send (act server.wait for halt, ack);
+ act server.wait for halt := niltask
+ FI
+ ELSE transfer next job (act dev);
+ send current job (act dev)
+ FI.
+
+ y save:
+ IF phase = 1
+ THEN y save pre
+ ELSE y save post
+ FI.
+
+ y save pre:
+ link dev;
+ IF act dev = 0
+ THEN device error
+ ELIF chain is full (act dev)
+ THEN errorstop ("SPOOL ist voll")
+ ELSE send (order task, second phase ack)
+ FI.
+
+ y save post:
+ act dev := msg.dev no;
+ IF type (ds) <> picfile type
+ THEN errorstop ("Datenraum hat falschen Typ")
+ ELSE entry into chain (act dev, new job);
+ forget (ds);
+ IF NOT (server is active (act dev) OR act server.stopped)
+ THEN create server (act dev)
+ FI;
+ send ack
+ FI.
+
+ new job:
+ JOB : (ds, msg.ds name, order task).
+
+ y exists:
+ link dev;
+ IF find entry (msg.ds name,act dev,order task, priv control op) = 0
+ THEN send (order task, false code, ds)
+ ELSE send ack
+ FI.
+
+ y erase:
+ IF phase = 1
+ THEN link dev;
+ IF act dev > 0
+ THEN y erase pre
+ ELSE device error
+ FI
+ ELSE erase entry (act dev, entry to erase);
+ send ack
+ FI.
+
+ y erase pre:
+ entry to erase := find entry (msg.ds name,act dev, order task, priv control op);
+ IF order not from job order task AND NOT priv control op
+ THEN errorstop ("Kein Zugriffsrecht auf Auftrag """ + msg.ds name + """")
+ ELIF entry to erase = 0
+ THEN manager message ("""" + msg.ds name + """ existiert nicht")
+ ELSE manager question (erase msg)
+ FI.
+
+ erase msg:
+ TASK VAR owner ::act chain.entry [entry to erase].job.order task;
+ owner id (owner) + "/ """ + msg.ds name +
+ """ in Spool """ + name (managed plotter, act dev) +
+ """ loeschen".
+
+ order not from job order task:
+ NOT (act chain.entry [entry to erase].job.order task = order task).
+
+ y list:
+ link dev;
+ create chain list (act dev);
+ send (order task, ack, reply ds).
+
+ y all:
+ link dev;
+ forget (reply ds);
+ reply ds := nilspace;
+ thesaurus msg := reply ds;
+ thesaurus msg := chain thesaurus (act dev, owner or priv task, FALSE);
+ send (order task, ack, reply ds).
+
+ owner or priv task:
+ IF priv control op
+ THEN niltask
+ ELSE order task
+ FI.
+
+ y start:
+ link dev;
+ IF act dev = 0
+ THEN FOR act dev FROM 1 UPTO max devices REP
+ start (act dev)
+ PER
+ ELSE start (act dev)
+ FI;
+ send ack.
+
+ y stop:
+ IF phase = 1
+ THEN y stop pre
+ ELSE y stop post
+ FI.
+
+ y stop pre:
+ link dev;
+ IF act dev > 0
+ THEN stop (act dev);
+ IF NOT is no job (act server.current job)
+ THEN manager question ("""" + act server.current job.ds name
+ + """ neu eintragen")
+ ELSE send ack
+ FI
+ ELSE FOR act dev FROM 1 UPTO max devices REP
+ stop (act dev)
+ PER;
+ send ack
+ FI.
+
+ y stop post:
+ act dev := msg.dev no;
+ entry into chain (act dev, act server.current job);
+ IF act chain.last > 1
+ THEN make new first (act dev, act chain.last)
+ FI;
+ send ack.
+
+ y halt:
+ link dev;
+ IF act dev = 0
+ THEN IF order <> halt code
+ THEN device error
+ ELSE FOR act dev FROM 1 UPTO max devices REP
+ halt (act dev)
+ PER;
+ send ack
+ FI
+ ELSE halt (act dev);
+ IF order = halt code
+ THEN send ack;
+ act server.wait for halt := niltask
+ ELSE act server.wait for halt := order task
+ FI
+ FI.
+
+ y first:
+ link dev;
+ IF act dev = 0
+ THEN device error
+ ELSE INT VAR new first entry :: find entry (msg.ds name,act dev,order task,TRUE);
+ IF new first entry = 0
+ THEN manager message ("""" + msg.ds name + """ existiert nicht")
+ ELSE make new first (act dev,new first entry);
+ send ack
+ FI
+ FI.
+
+ act server:
+ device [act dev].server.
+
+ act chain:
+ device [act dev].chain.
+
+ send ack:
+ send (order task, ack).
+
+ link dev:
+ msg := ds;
+ act dev := msg.dev no.
+
+ order error:
+ errorstop ("Falscher Auftrag fuer Task """ + name (myself) + """").
+
+ device error:
+ disable stop;
+ IF plotter (msg.dev name) = no plotter
+ THEN clear error; (* 'plotter(TEXT)' liefert evtl. bereits error *)
+ errorstop ("Kein Endgeraet eingestellt")
+ ELSE clear error;
+ errorstop ("Unbekanntes Endgeraet: """ + msg.dev name + """")
+ FI;
+ enable stop.
+END PROC plot manager;
+
+(****************************** Spool Monitor ******************************)
+
+INT VAR command index , params ;
+TEXT VAR command line, param 1, param 2 ;
+BOOL VAR is break;
+
+LET spool command list =
+"break:1.0start:2.0stop:3.0halt:4.0first:5.0killer:6.0listspool:7.0
+ clearspool:8.0selectplotter:9.0spoolcontrol:10.1";
+
+PROC spool monitor:
+ disable stop ;
+ current plotter := 0;
+ is break := FALSE;
+ select plotter ("");
+ REP command dialogue (TRUE) ;
+ get command (gib kommando, command line);
+ analyze command (spool command list, command line, 3, command index,
+ params, param1, param2);
+ execute command;
+ UNTIL is break PER;
+ command dialogue (FALSE);
+ eumel must advertise;
+ break (quiet);
+ set autonom.
+
+ gib kommando:
+ IF actual plotter > 0
+ THEN plotter info (name(plotters,actual plotter),50)
+ ELSE "ALL-Plotter: "
+ FI
+END PROC spool monitor;
+
+PROC execute command:
+ enable stop;
+ SELECT command index OF
+ CASE 1 : is break := TRUE
+ CASE 2 : start cmd
+ CASE 3 : stop cmd
+ CASE 4 : halt cmd
+ CASE 5 : first cmd
+ CASE 6 : killer cmd
+ CASE 7 : show spool list
+ CASE 8 : clear spool
+ CASE 9 : select plotter cmd
+ CASE 10 : set spool control
+ OTHERWISE do (command line);
+ set current plotter
+ END SELECT.
+
+ set current plotter:
+ current plotter := link(managed plotter, name (plotters,actual plotter));
+ IF actual plotter > 0 AND current plotter = 0
+ THEN select plotter ("");
+ current plotter := 0;
+ errorstop ("Auf dieser Station unbekannt: """+name(plotter)+"""")
+ FI.
+
+ start cmd:
+ FOR act dev FROM curr dev UPTO top dev REP
+ start (act dev)
+ PER.
+
+ stop cmd:
+ FOR act dev FROM curr dev UPTO top dev REP
+ IF device [act dev].server.current job.ds name <> "" CAND
+ yes ("""" + device [act dev].server.current job.ds name +
+ """ neu eintragen")
+ THEN entry into chain (act dev, device [act dev].server.current job);
+ IF device [act dev].chain.last > 1
+ THEN make new first (act dev, device [act dev].chain.last)
+ FI
+ FI;
+ stop (act dev)
+ PER.
+
+ halt cmd:
+ FOR act dev FROM curr dev UPTO top dev REP
+ halt (act dev)
+ PER.
+
+ first cmd:
+ IF current plotter = 0
+ THEN device error
+ FI;
+ TEXT VAR make to first :: one (chain thesaurus (current plotter,niltask,TRUE)
+ -first chain entry)
+ IF make to first <> ""
+ THEN INT VAR new first entry :: find entry (make to first,
+ current plotter, niltask, FALSE);
+ IF new first entry > 1
+ THEN make new first (current plotter, new first entry)
+ FI
+ FI.
+
+ first chain entry:
+ INT VAR first entry id :: device [current plotter].chain.first;
+ IF first entry id > 0
+ THEN device [current plotter].chain.entry[first entry id].job.ds name
+ ELSE ""
+ FI.
+
+ killer cmd:
+ IF current plotter = 0
+ THEN device error
+ FI;
+ THESAURUS VAR to erase :: chain thesaurus (current plotter,niltask,FALSE);
+ INT VAR index, act dev;
+ TEXT VAR name to erase;
+ FOR act dev FROM curr dev UPTO top dev REP
+ index := 0;
+ get (to erase, name to erase, index);
+ WHILE index > 0 REP
+ INT VAR entry to erase := find entry (name to erase, current plotter, niltask, TRUE);
+ IF (entry to erase > 0) CAND
+ yes ("""" + name to erase + """ loeschen")
+ THEN erase entry (current plotter, entry to erase)
+ FI;
+ get (to erase, name to erase, index)
+ PER
+ PER.
+
+ show spool list :
+ create chain list (current plotter);
+ show (chain info);
+ forget (reply ds).
+
+ clear spool:
+ FOR act dev FROM curr dev UPTO top dev REP
+ IF yes ("Spool """ + name (managed plotter, act dev) + """ initialisieren")
+ THEN BOOL VAR stopped :: device [act dev].server.stopped;
+ stop (act dev);
+ init device (act dev);
+ IF stopped
+ THEN device [act dev].server.stopped := TRUE
+ ELSE start (act dev)
+ FI
+ FI
+ PER.
+
+ set spool control:
+ control task := task (param 1).
+
+ select plotter cmd:
+ THESAURUS VAR plotter list :: empty thesaurus;
+ TEXT VAR plotter name;
+ get (managed plotter, plotter name, index);
+ WHILE index > 0 REP
+ insert (plotter list, plotter info (plotter name, 60));
+ get (managed plotter, plotter name, index)
+ PER;
+ select plotter (name (managed plotter,
+ link (plotter list,one (plotter list))));
+ set current plotter.
+
+ curr dev:
+ IF current plotter = 0
+ THEN 1
+ ELSE current plotter
+ FI.
+
+ top dev:
+ IF current plotter = 0
+ THEN max devices
+ ELSE current plotter
+ FI.
+
+ device error:
+ errorstop ("Kein Endgeraet eingestellt")
+
+ENDPROC execute command ;
+
+(************************** SPOOL - Verwaltung *****************************)
+
+PROC entry into chain (INT CONST dev no, JOB CONST new job):
+ INT VAR act entry := act chain.empty;
+ act chain.empty := act chain.entry [act entry].link;
+ IF act chain.last > 0
+ THEN act chain.entry [act chain.last].link := act entry
+ FI;
+ act chain.last := act entry;
+ IF act chain.first = 0
+ THEN act chain.first := act entry
+ FI;
+ init job (act chain.entry [act entry].job);
+ act chain.entry [act entry] := ENTRY : (new job,0);
+ forget (new job.ds).
+
+ act chain :
+ device [dev no].chain
+END PROC entry into chain;
+
+PROC erase entry (INT CONST dev no, to erase):
+ INT VAR act entry;
+ to forward entry;
+ IF act entry > 0
+ THEN act chain.entry [act entry].link := act chain.entry [to erase].link
+ FI;
+ IF act chain.last = to erase
+ THEN act chain.last := act entry
+ FI;
+ IF act chain.first = to erase
+ THEN act chain.first := act chain.entry [to erase].link
+ FI;
+ init job (act chain.entry [to erase].job);
+ act chain.entry [to erase].link := act chain.empty;
+ act chain.empty := to erase.
+
+ to forward entry:
+ FOR act entry FROM 1 UPTO max entries REP
+ UNTIL act chain.entry [act entry].link = to erase PER;
+ IF act entry > max entries
+ THEN act entry := 0
+ FI.
+
+ act chain:
+ device [dev no].chain
+END PROC erase entry;
+
+INT PROC find entry (TEXT CONST ds name, INT CONST dev, TASK CONST order task,BOOL CONST priviledged):
+ INT VAR act dev :: dev,act entry,last found :: 0;
+ IF act dev = 0
+ THEN FOR act dev FROM 1 UPTO max devices REP
+ find entry of order task
+ UNTIL act entry > 0 PER
+ ELSE find entry of order task
+ FI;
+ IF act entry = 0
+ THEN last found
+ ELSE act entry
+ FI.
+
+ find entry of order task:
+ BOOL VAR entry found;
+ act entry := act chain.first;
+ WHILE act entry > 0 REP
+ entry found := (act chain.entry [act entry].job.ds name = ds name);
+ IF entry found
+ THEN last found := act entry;
+ entry found := (index (act chain.entry [act entry].job.order task) =
+ index (order task)) OR priviledged
+ FI;
+ IF NOT entry found
+ THEN act entry := act chain.entry [act entry].link
+ FI
+ UNTIL entry found PER.
+
+ act chain:
+ device [act dev].chain
+
+END PROC find entry;
+
+PROC make new first (INT CONST dev no, new first):
+ JOB VAR new first job :: act chain.entry [new first].job;
+ erase entry (dev no, new first);
+ INT VAR act entry := act chain.empty;
+ act chain.empty := act chain.entry [act entry].link;
+ act chain.entry [act entry] := ENTRY : (new first job, act chain.first);
+ init job (new first job);
+ act chain.first := act entry;
+ IF act chain.last = 0
+ THEN act chain.last := act entry
+ FI.
+
+ act chain:
+ device [dev no].chain
+
+END PROC make new first;
+
+THESAURUS PROC chain thesaurus (INT CONST dev no, TASK CONST order task,
+ BOOL CONST double):
+ THESAURUS VAR list :: empty thesaurus;
+ INT VAR act dev := dev no,act entry;
+ IF act dev = 0
+ THEN FOR act dev FROM 1 UPTO max devices REP
+ list chain
+ PER
+ ELSE list chain
+ FI;
+ list.
+
+ list chain:
+ act entry := act chain.first;
+ WHILE act entry > 0 REP
+ IF (order task = niltask) OR
+ (act chain.entry [act entry].job.order task = order task)
+ THEN insert job name
+ FI;
+ act entry := act chain.entry [act entry].link
+ PER.
+
+ insert job name:
+ TEXT VAR this job :: act chain.entry [act entry].job.ds name
+ IF double OR (NOT (list CONTAINS this job))
+ THEN insert (list, this job)
+ FI.
+
+ act chain:
+ device [act dev].chain
+
+END PROC chain thesaurus;
+
+
+PROC create chain list (INT CONST dev no):
+ INT VAR act dev :: dev no, act entry;
+ init chain info;
+ IF act dev = 0
+ THEN FOR act dev FROM 1 UPTO max devices REP
+ list chain
+ PER
+ ELSE list chain
+ FI.
+
+ init chain info:
+ forget (reply ds);
+ reply ds := nilspace;
+ chain info := sequential file (output, reply ds);
+ headline (chain info,"GRAPHIK - Ausgabe um "+ time of day (clock (1)) + " Uhr :").
+
+
+ list chain:
+ server head;
+ IF NOT server is active (act dev) OR is no job (act server.current job)
+ THEN put (chain info, "- Kein Auftrag in Bearbeitung") ;
+ IF act server.stopped
+ THEN put (chain info, " ( SERVER deaktiviert )")
+ FI;
+ line (chain info)
+ ELSE put (chain info, "- In Bearbeitung seit "+time of day (act server.time)+" Uhr :");
+ IF act server.stopped
+ THEN put (chain info, " ( SERVER wird deaktiviert !)")
+ FI;
+ line (chain info, 2);
+ putline (chain info, job note (act server.current job))
+ FI;
+ line (chain info);
+ IF act chain.last = 0
+ THEN putline (chain info, "- Keine Auftraege im SPOOL")
+ ELSE putline (chain info, "- Weitere Auftraege im SPOOL :");
+ line (chain info);
+ act entry := act chain.first;
+ WHILE act entry > 0 REP
+ putline (chain info, job note (act chain.entry [act entry].job));
+ act entry := act chain.entry [act entry].link
+ PER
+ FI;
+ line (chain info, 2).
+
+ server head:
+ TEXT VAR plotter name :: name (managed plotter,act dev);
+ INT VAR station :: int (plottername),
+ tp :: pos (plottername,trenn)+1,
+ channel :: int (subtext (plottername,tp));
+ plotter name := subtext (plotter name, pos (plotter name, trenn, tp)+1);
+ putline (chain info, 77 * "-");
+ putline (chain info,
+ center (plotter name + (30-length(plotter name))*"." +
+ "Kanal " + text (channel) +
+ "/Station " + text (station)));
+ putline (chain info, 77 * "-");
+ line (chain info).
+
+ act chain:
+ device [act dev].chain.
+
+ act server:
+ device [act dev].server
+
+END PROC create chain list;
+
+BOOL PROC chain is empty (INT CONST dev no):
+ device [dev no].chain.first = 0 OR device [dev no].chain.last = 0
+END PROC chain is empty;
+
+BOOL PROC chain is full (INT CONST dev no):
+ device [dev no].chain.empty = 0
+END PROC chain is full;
+
+PROC transfer next job (INT CONST dev no):
+ INT VAR next chain entry := device [dev no].chain.first;
+ next server job (dev no, device [dev no].chain.entry [next chain entry].job);
+ erase entry (dev no,next chain entry)
+END PROC transfer next job;
+
+(*************************** SERVER - Verwaltung ***************************)
+
+PROC next server job (INT CONST dev no,JOB CONST next job):
+ act server.time := clock (1);
+ init job (act server.current job);
+ act server.current job := next job.
+
+ act server:
+ device [dev no].server
+END PROC next server job;
+
+BOOL PROC server is active (INT CONST dev no):
+ exists (act server.task) CAND server alive or restarted.
+
+ server alive or restarted:
+ SELECT status (act server.task) OF
+ CASE 0 (* busy *) ,
+ 4 (* busy-blocked *),
+ 2 (* wait *),
+ 6 (* wait-blocked *) : TRUE
+ CASE 1 (* i/o *),
+ 5 (* i/o -blocked *): IF channel (act server.task) = 0
+ THEN restart
+ ELSE TRUE
+ FI
+ OTHERWISE restart
+ END SELECT.
+
+ restart:
+ end server (dev no);
+ IF NOT act server.stopped AND NOT chain is empty (dev no)
+ THEN create server (dev no)
+ FI;
+ NOT is niltask (act server.task).
+
+ act server:
+ device [dev no].server
+
+END PROC server is active;
+
+PROC create server (INT CONST dev no):
+ init job (act server.current job);
+ act server.wait for halt := niltask;
+ act server.time := 0.0;
+ act server.stopped := FALSE;
+ last created server := dev no;
+ begin (PROC plot server, act server.task).
+
+ act server:
+ device [dev no].server
+END PROC create server;
+
+PROC end server (INT CONST dev no):
+ end (act server.task);
+ init job (act server.current job);
+ act server.task := niltask.
+
+ act server:
+ device [dev no].server
+
+END PROC end server;
+
+PROC start (INT CONST dev no):
+ IF server is active (dev no)
+ THEN end server (dev no)
+ FI;
+ IF NOT chain is empty (dev no)
+ THEN create server (dev no)
+ FI;
+ device [dev no].server.stopped := FALSE
+END PROC start;
+
+PROC stop (INT CONST dev no):
+ device [dev no].server.stopped := TRUE;
+ IF exists (device [dev no].server.wait for halt)
+ THEN send (device [dev no].server.wait for halt,ack)
+ FI;
+ device [dev no].server.wait for halt := niltask;
+ IF server is active (dev no)
+ THEN end server (dev no)
+ FI
+END PROC stop;
+
+PROC halt (INT CONST dev no):
+ device [dev no].server.stopped := TRUE
+END PROC halt;
+
+PROC send current job (INT CONST dev no):
+ forget (reply ds);
+ reply ds := device [dev no].server.current job.ds;
+ send (device [dev no].server.task, ack,reply ds);
+END PROC send current job;
+
+(****************************** Hilfsprozeduren ****************************)
+
+PROC init device (INT CONST dev no):
+ INT VAR act entry;
+ act server.task := niltask;
+ act server.time := 0.0;
+ init job (act server.current job);
+ act server.stopped := FALSE;
+ act chain.first := 0;
+ act chain.last := 0;
+ act chain.empty := 1;
+ FOR act entry FROM 1 UPTO max entries-1 REP
+ init job (act chain.entry [act entry].job);
+ act chain.entry [act entry].link := act entry + 1
+ PER;
+ init job (act chain.entry [act entry].job);
+ act chain.entry [act entry].link := 0.
+
+ act server :
+ device [dev no].server.
+
+ act chain :
+ device [dev no].chain
+
+END PROC init device;
+
+INT PROC max devices:
+ highest entry (managed plotter)
+END PROC max devices;
+
+OP := (MSG VAR dest, DATASPACE VAR source):
+ TEXT VAR ds name :: "", dev name :: "";
+ BOUND STRUCT (TEXT ds name, dev name, passwd) VAR msg in := source;
+ divide names;
+ dest := MSG : (ds name, dev name, msg in .passwd,
+ link (managed plotter,dev name));
+ forget (source).
+
+ divide names:
+ INT VAR pps :: pos (msg in.ds name, ""0"");
+ WHILE pos (msg in.ds name, ""0"", pps+1) > 0 REP
+ pps := pos (msg in.ds name,""0"", pps+1)
+ PER;
+ IF pps > 0
+ THEN ds name := subtext (msg in.ds name, 1, pps-1);
+ FI;
+ dev name := subtext (msg in.ds name, pps+1).
+
+END OP :=;
+
+TEXT PROC job note (JOB CONST job):
+ " - " + owner id (job.order task) + " : " + qrline (job.ds name, 30) +
+ " (" + text (storage (job.ds)) + " K)".
+END PROC job note;
+
+TEXT PROC owner id (TASK CONST owner):
+ TEXT VAR test :: name (owner);
+ IF test <> ""
+ THEN text (station (owner)) + "/" + qrline (test,15)
+ ELSE "?????"
+ FI
+END PROC owner id;
+
+PROC init job (JOB VAR to initialize):
+ forget (to initialize.ds);
+ to initialize.ds name := "";
+ to initialize.order task := niltask
+END PROC init job;
+
+TEXT PROC qrline (TEXT CONST t,INT CONST len):
+ IF length (t) > len-2
+ THEN """" + text (t, len-5) + "..."""
+ ELSE text ("""" + t + """", len)
+ FI
+END PROC qrline;
+
+TEXT PROC center (TEXT CONST chars,INT CONST len):
+ len DIV 2 * " " + chars
+END PROC center;
+
+BOOL PROC is no job (JOB CONST job):
+ job.ds name = ""
+END PROC is no job;
+
+PROC send (TASK CONST task, INT CONST code):
+ DATASPACE VAR ds :: nilspace;
+ send (task, code, ds);
+ forget (ds)
+END PROC send;
+
+(**************************** Plot - Server ********************************)
+
+PROC plot server:
+ disable stop;
+ select plotter (name (managed plotter,last created server));
+ REP
+ error handling;
+ TEXT VAR dummy;
+ catinput (dummy, dummy); (* evtl. Zeichen im Tastaturpuffer *)
+ PICFILE VAR pic :: next server job;
+ prepare;
+ plot (pic);
+ PER.
+
+ next server job:
+ forget (reply ds);
+ reply ds := nilspace;
+ REP
+ error handling;
+ call (father, fetch code, reply ds, reply)
+ UNTIL reply = ack PER;
+ reply ds.
+
+ error handling:
+ IF is error
+ THEN rename myself (error message);
+ clear error;
+ pause
+ FI.
+
+END PROC plot server;
+
+END PACKET plot manager
+
diff --git a/app/mpg/2.2/src/GRAPHIK.Plot b/app/mpg/2.2/src/GRAPHIK.Plot
new file mode 100644
index 0000000..0479d75
--- /dev/null
+++ b/app/mpg/2.2/src/GRAPHIK.Plot
@@ -0,0 +1,1237 @@
+(**************************************************************************)
+(* *)
+(* MPG - Graphik - System *)
+(* *)
+(* Version 2.2 vom 23.09.1987 *)
+(* *)
+(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *)
+(* unter Verwendung der Standard-Graphik *)
+(* "Graphik-Plot" geschrieben von C.Weinholz *)
+(* *)
+(**************************************************************************)
+(* *)
+(* Paket II: Endgeraet-abhaengige Graphikroutinen *)
+(* (koennen erst nach 'Interface.Conf' insertiert werden) *)
+(* *)
+(* 1. Plot (Grundlegende Graphik-Operationen *)
+(* *)
+(* 2. Plot Input/Output (Routinen zum *)
+(* Ansprechen des PLOT-Spoolers *)
+(* zur indirekten Graphik-Ausgabe) *)
+(* *)
+(* 3. Plot Picture/Picfile *)
+(* (Ausgabe von PICTURES/ PICFILES) *)
+(* *)
+(**************************************************************************)
+(* Urversion : 10.09.87 *)
+(* Aenderungen: 23.09.87, Carsten Weinholz *)
+(* PROC save (PICFILE CONST, TEXT CONST, PLOTTER CONST) *)
+(* hinzugefuegt *)
+(* PROC plot (PICFILE CONST) auch indirekt *)
+(* Fehlermeldung bei indirektem 'plot (PICTURE)' *)
+(* 20.11.87, Beat Jegerlehner *)
+(* Clipping bei move eingefuehrt. Gibt sonst bei Watanabe *)
+(* Probleme *)
+(* Textgenerator korrigiert *)
+(* *)
+(**************************************************************************)
+
+(************************************ Plot ********************************)
+
+PACKET basis plot DEFINES
+
+ beginplot,
+ pen ,
+
+ move ,
+ move r ,
+ move cm ,
+ move cm r,
+
+ draw ,
+ draw r ,
+ draw cm ,
+ draw cm r,
+
+ hidden lines,
+ reset ,
+
+ zeichensatz,
+ reset zeichensatz,
+
+ linetype,
+ reset linetypes,
+
+ where,
+ bar,
+ circle,
+ box:
+
+LET empty = 0, (* Punktmuster *)
+ half = 1,
+ full = 2,
+ horizontal = 3,
+ vertical = 4,
+ cross = 5,
+ diagonal right = 6,
+ diagonal left = 7,
+ diagonal both = 8,
+ std zeichenname = "ZEICHENSATZ";
+
+INT VAR ltype :: 1,
+ thick :: 0,
+ xpixel :: 0,
+ ypixel :: 0,
+ old x :: 0,
+ old y :: 0,
+ real old x :: 0,
+ real old y :: 0;
+
+REAL VAR x cm, ycm,hor relation, vert relation,x to y,y to x;
+
+ROW 5 TEXT VAR linetypes;
+
+INT VAR cnt :: 0;
+TEXT VAR muster :: "0";
+INT VAR lentxt :: length(muster);
+
+LET POS = STRUCT (REAL x, y, z);
+POS VAR pos :: POS : (0.0, 0.0, 0.0);
+
+LET ZEICHENSATZ = ROW 255 TEXT;
+ZEICHENSATZ VAR zeichen;
+REAL CONST char x :: 6.0, char y :: 6.0,y base :: 2.0;
+
+BOUND ZEICHENSATZ VAR std zeichen :: old (std zeichenname);
+reset zeichensatz;
+reset linetypes;
+
+INT VAR h :: 0, v :: 0, new h :: 0, new v :: 0;
+
+BOOL VAR hidden :: FALSE;
+
+DATASPACE VAR ds :: nilspace;
+BOUND STRUCT (ROW 32764 INT akt, last) VAR maxima :: ds;
+
+(*************************** Initialisierung *******************************)
+
+PROC beginplot:
+ init plot;
+ drawing area (x cm, y cm, x pixel, y pixel);
+ hor relation := real (x pixel)/x cm;
+ vert relation:= real (y pixel)/y cm;
+ x to y := x cm / real(x pixel) / (y cm / real (y pixel)); (*umrechnung:*)
+ y to x := 1.0 / x to y; (* x pixel in y pixel u andersherum*)
+END PROC beginplot;
+
+PROC pen (INT CONST backgr,colour,thickn,linetype):
+ background(backgr);
+ foreground(colour);
+ thick := thickn;
+ ltype := selected linetype;
+ IF ltype > 1
+ THEN muster := linetypes[ltype];
+ lentxt := length (muster);
+ cnt := 0
+ FI.
+
+ selected linetype:
+ IF linetype < 0 OR linetype > 5
+ THEN 1
+ ELSE linetype
+ FI
+END PROC pen;
+
+(************************** MOVE - Prozeduren ******************************)
+
+PROC move (INT CONST x,y):
+ old x := x;
+ old y := y
+END PROC move;
+
+PROC do move (INT CONST x,y):
+ IF x <> real old x OR
+ y <> real old y
+ THEN real old x := x;
+ real old y := y;
+ move to (x,y)
+ FI;
+ old x := x;
+ old y := y
+END PROC do move;
+
+PROC move (REAL CONST x, y) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (x, y, 0.0, h, v);
+ move (h, v);
+ pos := POS : (x, y, 0.0)
+END PROC move;
+
+PROC move (REAL CONST x, y, z) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (x, y, z, h, v);
+ move (h, v);
+ pos := POS : (x, y, z)
+END PROC move;
+
+PROC move r (REAL CONST x, y) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (pos.x+x, pos.y+y, pos.z, h, v);
+ move (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z)
+END PROC move r;
+
+PROC move r (REAL CONST x, y, z) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ move (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z+z)
+END PROC move r;
+
+PROC move cm (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ h := int (x cm*hor relation+0.5);
+ v := int (y cm*vert relation+0.5);
+ move (h, v)
+END PROC move cm;
+
+PROC move cm r (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ h INCR int (x cm*hor relation+0.5);
+ v INCR int (y cm*vert relation+0.5);
+ move (h, v)
+END PROC move cm r;
+
+(************************** DRAW - Prozeduren ******************************)
+
+PROC draw (INT CONST x,y):
+ draw (old x,old y,x,y)
+END PROC draw;
+
+PROC draw (INT CONST x0,y0,x1,y1):
+ IF thick = 0
+ THEN line (x0, y0,x1,y1)
+ ELSE old x := x0;
+ old y := y0;
+ draw thick line (x1,y1)
+ FI;
+ old x := x1;
+ old y := y1
+END PROC draw;
+
+PROC draw (REAL CONST x, y) :
+ IF hidden
+ THEN transform (x, y, 0.0, new h, new v);
+ vector (new h-h, new v-v)
+ ELSE transform (x, y, 0.0, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (x, y, 0.0)
+END PROC draw;
+
+PROC draw (REAL CONST x, y, z) :
+ IF hidden
+ THEN transform (x, y, z, new h, new v);
+ vector (new h-h, new v-v)
+ ELSE transform (x, y, z, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (x, y, z)
+END PROC draw;
+
+PROC draw r (REAL CONST x, y) :
+ IF hidden
+ THEN transform (pos.x+x, pos.y+y, pos.z, h, v);
+ vector (new h-h, new v-v)
+ ELSE transform (pos.x+x, pos.y+y, pos.z, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (pos.x+x, pos.y+y, pos.z)
+END PROC draw r;
+
+PROC draw r (REAL CONST x, y, z) :
+ IF hidden
+ THEN transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ vector (new h-h, new v-v)
+ ELSE transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (pos.x+x, pos.y+y, pos.z+z)
+END PROC draw r;
+
+PROC draw cm (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN vector (int (x cm*hor relation+0.5)-h, int (y cm*vert relation+0.5)-v)
+ ELSE h := int (x cm*hor relation+0.5);
+ v := int (y cm*vert relation+0.5);
+ draw (h, v)
+ FI
+END PROC draw cm;
+
+PROC draw cm r (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN vector (int (x cm*hor relation+0.5), int (y cm*vert relation+0.5))
+ ELSE h INCR int (x cm*hor relation+0.5);
+ v INCR int (y cm*vert relation+0.5);
+ draw (h, v)
+ FI
+END PROC draw cm r;
+
+(*************************** LINIEN zeichnen *******************************)
+
+PROC line (INT CONST x0,y0,x1,y1):
+ REAL VAR x0r :: real (x0),
+ y0r :: real (y0),
+ x1r :: real (x1),
+ y1r :: real (y1);
+ IF clipped line (x0r,y0r,x1r,y1r)
+ THEN IF ltype > 1
+ THEN draw special line(int(x0r),int(y0r),int(x1r),int(y1r))
+ ELIF ltype = 1
+ THEN do move (int(x0r),int(y0r));
+ draw std line (int(x1r),int(y1r))
+ FI
+ FI
+END PROC line;
+
+PROC draw std line (INT CONST x,y):
+ old x := x;
+ old y := y;
+ real old x := x;
+ real old y := y;
+ draw to (x,y)
+END PROC draw std line;
+
+PROC draw special line (INT CONST x0,y0,x1,y1):
+ IF x0 = x1
+ THEN vertical line
+ ELIF y0 = y1
+ THEN horizontal line
+ ELIF abs(x1-x0) > abs(y1 - y0)
+ THEN steile linie
+ ELSE flache linie
+ FI.
+
+ vertical line:
+ INT VAR steps :: abs(y1 - y0),
+ sig :: sign(y1-y0),
+ i;
+ FOR i FROM 0 UPTO steps REP
+ IF next pixel
+ THEN set pixel(x0,y0+i*sig)
+ FI
+ PER.
+
+ horizontal line:
+ steps := abs(x1 - x0);
+ sig := sign(x1 - x0);
+ FOR i FROM 0 UPTO steps REP
+ IF next pixel
+ THEN set pixel(x0+i*sig,y0)
+ FI
+ PER.
+
+ steile linie:
+ steps := abs(x1 - x0);
+ sig := sign(x1 - x0);
+ REAL VAR m :: real(y1 - y0) / real(x1 - x0);
+ FOR i FROM 0 UPTO steps REP
+ IF next pixel
+ THEN set pixel(x0+sig*i,y0+int(m*real(sig*i) + 0.5))
+ FI
+ PER.
+
+ flache linie:
+ steps := abs(y1 - y0);
+ sig := sign(y1 - y0);
+ m := real(x1 - x0) / real(y1 - y0);
+ FOR i FROM 0 UPTO steps REP
+ IF next pixel
+ THEN set pixel(x0+int(m*real(sig*i) + 0.5),y0+sig*i)
+ FI
+ PER.
+
+ next pixel:
+ BOOL VAR is set :: (muster SUB cnt) <> "0";
+ cnt INCR 1;
+ IF cnt > lentxt THEN cnt := 1 FI;
+ is set
+END PROC drawspecialline;
+
+PROC draw thick line (INT CONST xe,ye):
+
+ INT VAR x0 :: old x,
+ y0 :: old y,
+ x1 :: xe,
+ y1 :: ye;
+
+ IF x0 = x1 AND y0 = y1
+ THEN draw point (x0,y0)
+ ELIF abs(x0-x1) >= abs(y0-y1)
+ THEN IF x0 > x1
+ THEN draw thick2(x1,y1,x0,y0)
+ ELSE draw thick2(x0,y0,x1,y1)
+ FI
+ ELSE IF y0 > y1
+ THEN draw thick1(x1,y1,x0,y0)
+ ELSE draw thick1(x0,y0,x1,y1)
+ FI
+ FI
+END PROC draw thick line;
+
+PROC draw point (INT CONST x,y):
+ INT VAR i,k,d :: int(0.5 + real(thick) / (x cm / real(x pixel)) / 10.0 /
+ 2.0);
+ FOR i FROM 0 UPTO d REP
+ k := int (0.5 + sqrt(real(d)**2 - real(i)**2)* x to y);
+ line (x+i, y-k, x+i, y+k);
+ line (x-i, y-k, x-i, y+k)
+ PER
+END PROC draw point;
+
+PROC draw thick 1 (INT CONST x0,y0,x1,y1):
+ REAL VAR dxx :: real(x1 - x0),
+ dyx :: real(y1 - y0) * y to x,
+ d3 :: real(thick) / (x cm / real(x pixel)) / 10.0,
+ d1 :: sqrt (d3**2 + (d3 * dxx / dyx)**2),
+ d2 :: d3 * dxx / dyx,
+ dh :: (d3**2 - d2**2 + d1**2) / 2.0 / d1,
+ d4 :: sqrt(max(0.0,d3 ** 2 - dh ** 2)) * x to y;
+ INT VAR l :: int (0.5 + d1 / 2.0),
+ dy :: abs(y0 - y1),
+ dx :: abs(x0 - x1),
+ x :: x0 - int(0.5 + d3 / 2.0 * dxx / dyx),
+ y :: y0 - int(d3 / 2.0 * x to y),
+ z :: y1 + int (d3 / 2.0 * x to y),
+ dp :: dx + dx,
+ d :: dp - dy,
+ dq :: dp - dy - dy,
+ a :: sign (y1 - y0),
+ b :: sign (x1 - x0);
+ do line;
+ WHILE y <> z REP
+ y INCR a;
+ IF d < 0
+ THEN d INCR dp
+ ELSE x INCR b;
+ d INCR dq
+ FI;
+ do line
+ PER.
+
+ do line:
+ INT VAR s1 :: l,
+ s2 :: l,
+ s3 :: x,
+ sh;
+ IF y < y0 - int (0.5 + d4 / 2.0)
+ THEN s1 := int (0.5 + sqrt (d3 ** 2 / 4.0 - (real(y - y0) * y to
+ x)**2));
+ s2 := s1;
+ s3 := x0
+ ELIF y < y0 + int (0.5 + d4 / 2.0)
+ THEN sh := int (0.5 + sqrt (d3 ** 2 / 4.0 - (real(y-y0) * y to
+ x)**2));
+ IF x0 > x1
+ THEN s2 := sh + x0 - x
+ ELSE s1 := sh + x - x0
+ FI;
+ s3 := x
+ ELIF y > y1 + int (0.5 + d4/2.0)
+ THEN s1 := int (0.5 + sqrt (d3 ** 2 / 4.0 - (real(y-y1)*y to x)**2));
+ s2 := s1;
+ s3 := x1
+ ELIF y > y1 - int(0.5 + d4 / 2.0)
+ THEN sh := int(0.5 + sqrt(d3**2/4.0 - (real(y-y1)*y to x)**2));
+ IF x0 > x1
+ THEN s1 := sh + x - x1
+ ELSE s2 := sh + x1 - x
+ FI;
+ s3 := x
+ FI;
+ line (s3 - s1,y,s3 + s2, y)
+END PROC draw thick 1;
+
+PROC draw thick 2 (INT CONST x0,y0,x1,y1):
+ REAL VAR dxx :: real(x1 - x0) * x to y,
+ dyx :: real(y1 - y0),
+ d3 :: real(thick) / (y cm / real(y pixel)) / 10.0,
+ d1 :: sqrt (d3**2 + (d3 * dyx / dxx)**2),
+ d2 :: d3 * dyx / dxx,
+ dh :: (d3**2 - d2**2 + d1**2) / 2.0 / d1,
+ d4 :: sqrt(max(0.0,d3 ** 2 - dh ** 2)) * y to x;
+ INT VAR l :: int (0.5 + d1 / 2.0),
+ dy :: abs(y0 - y1),
+ dx :: abs(x0 - x1),
+ y :: y0 - int(0.5 + d3 / 2.0 * dyx / dxx),
+ x :: x0 - int(d3 / 2.0 * y to x),
+ z :: x1 + int (d3 / 2.0 * y to x),
+ dp :: dy + dy,
+ d :: dp - dx,
+ dq :: dp - dx - dx,
+ a :: sign (x1 - x0),
+ b :: sign (y1 - y0);
+ do line;
+ WHILE x <> z REP
+ x INCR a;
+ IF d < 0
+ THEN d INCR dp
+ ELSE y INCR b;
+ d INCR dq
+ FI;
+ do line
+ PER.
+
+ do line:
+ INT VAR s1 :: l,
+ s2 :: l,
+ s3 :: y,
+ sh;
+ IF x < x0 - int (0.5 + d4 / 2.0)
+ THEN s1 := int (0.5 + sqrt (d3 ** 2 / 4.0 - (real(x - x0) * x to y)**2));
+ s2 := s1;
+ s3 := y0
+ ELIF x < x0 + int (0.5 + d4 / 2.0)
+ THEN sh := int (0.5 + sqrt (d3 ** 2 / 4.0 - (real(x-x0) * x to y)**2));
+ IF y0 > y1
+ THEN s2 := sh + y0 - y
+ ELSE s1 := sh + y - y0
+ FI;
+ s3 := y
+ ELIF x > x1 + int (0.5 + d4/2.0)
+ THEN s1 := int (0.5 + sqrt (d3 ** 2 / 4.0 - (real(x-x1)*x to y)**2));
+ s2 := s1;
+ s3 := y1
+ ELIF x > x1 - int(0.5 + d4 / 2.0)
+ THEN sh := int(0.5 + sqrt(d3**2/4.0 - (real(x-x1)*x to y)**2));
+ IF y0 > y1
+ THEN s1 := sh + y - y1
+ ELSE s2 := sh + y1 - y
+ FI;
+ s3 := y
+ FI;
+ line (x, s3-s1, x, s3+s2)
+END PROC draw thick 2;
+
+(*************************** HIDDEN LINES **********************************)
+
+PROC hidden lines (BOOL CONST dev):
+ hidden := NOT dev;
+END PROC hidden lines;
+
+PROC vector (INT CONST dx, dy):
+ IF dx >= 0
+ THEN IF dy > dx THEN vector (v, h, dy, dx, 1, 1)
+ ELIF dy > 0 THEN vector (h, v, dx, dy, 1, 1)
+
+ ELIF dy > -dx THEN vector (h, v, dx, -dy, 1,-1)
+ ELSE vector (v, h, -dy, dx,-1, 1) FI
+
+ ELSE IF dy > -dx THEN vector (v, h, dy, -dx, 1,-1)
+ ELIF dy > 0 THEN vector (h, v, -dx, dy,-1, 1)
+
+ ELIF dy > dx THEN vector (h, v, -dx, -dy,-1,-1)
+ ELSE vector (v, h, -dy, -dx,-1,-1) FI
+ FI .
+
+ENDPROC vector ;
+
+PROC vector (INT VAR x pos, y pos, INT CONST dx, dy, right, up) :
+ INT VAR i;
+ prepare first step ;
+ draw point;
+ FOR i FROM 1 UPTO dx
+ REP do one step PER;
+
+ IF was visible
+ THEN draw (h, v) FI .
+
+
+prepare first step :
+ INT VAR up right error := dy - dx,
+ right error := dy,
+ old error := 0,
+ last h :: h, last v :: v;
+ BOOL VAR was visible :: visible .
+
+
+do one step:
+ IF right is better
+ THEN do right step
+ ELSE do up right step
+ FI .
+
+right is better :
+ abs (old error + right error) < abs (old error + up right error) .
+
+do upright step :
+ x pos INCR right ;
+ y pos INCR up ;
+ draw point ;
+ old error INCR upright error .
+
+do right step :
+ x pos INCR right ;
+ draw point ;
+ old error INCR right error .
+
+draw point :
+ IF was visible
+ THEN IF NOT visible
+ THEN draw (last h, last v);
+ was visible := FALSE
+ FI;
+ last h := h;
+ last v := v
+ ELSE IF visible
+ THEN move (h, v);
+ was visible := TRUE;
+ last h := h;
+ last v := v
+ FI
+ FI .
+
+visible:
+ IF h < 1 OR h > x pixel
+ THEN FALSE
+ ELSE IF maxima.akt [h] < v
+ THEN maxima.akt [h] := v FI;
+ v > maxima.last [h]
+ FI
+END PROC vector;
+
+PROC reset:
+ forget (ds);
+ ds := nilspace;
+ maxima := ds
+END PROC reset;
+
+(**************************** TEXT - Ausgabe *******************************)
+
+PROC zeichensatz (TEXT CONST name):
+ IF exists (name)
+ THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name);
+ zeichen := new zeichen;
+ ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI
+END PROC zeichensatz;
+
+PROC reset zeichensatz:
+ zeichen := std zeichen
+END PROC reset zeichensatz;
+
+PROC draw char (INT CONST char no,REAL CONST x, y,REAL CONST y size,
+ x size, direction):
+ TEXT CONST character :: zeichen [char no];
+ INT VAR n :: 1, x0, y0, x1, y1;
+ INT CONST len :: length (character);
+ REAL CONST sindir :: sind(direction),
+ cosdir :: cosd(direction);
+ WHILE n < len
+ REP value (character, n, x0, y0, x1, y1);
+ REAL VAR xr0 :: real(x0),
+ yr0 :: real(y0),
+ xr1 :: real(x1),
+ yr1 :: real(y1);
+ transform (xr0, yr0, x, y, x size, y size, sindir,cosdir);
+ transform (xr1, yr1, x, y, x size, y size, sindir,cosdir);
+ draw (int(xr0), int (yr0 * x to y),
+ int(xr1),int(yr1 * x to y));
+ n INCR 4
+ PER .
+
+END PROC draw char;
+
+PROC value (TEXT CONST char, INT CONST n, INT VAR x0, y0, x1, y1):
+ x0 := val (code (char SUB n)); y0 := val (code (char SUB n+1));
+ x1 := val (code (char SUB n+2)); y1 := val (code (char SUB n+3));
+END PROC value;
+
+INT PROC val (INT CONST n):
+ IF n > 127
+ THEN -256 OR n
+ ELSE n FI
+END PROC val;
+
+PROC transform (REAL VAR x, y,REAL CONST x0, y0,REAL CONST x size, y size,
+ sindir,cosdir):
+ REAL CONST old x :: x, old y :: y;
+ REAL CONST dx :: x size / char x * old x * cosdir -
+ (y size-y base) / char y * old y * sindir,
+ dy :: (y size-y base) / char y * old y * cosdir +
+ x size / char x * old x * sindir;
+ x := x0 + dx;
+ y := y0 + dy
+END PROC transform;
+
+PROC draw text (REAL CONST x pos, y pos,TEXT CONST msg, REAL CONST angle,
+ REAL CONST height, width):
+ INT VAR i;
+ REAL VAR x :: x pos, y :: y pos,
+ x step :: cosd (angle)*width,
+ y step :: sind (angle)*width;
+ FOR i FROM 1 UPTO length (msg)
+ REP IF control char
+ THEN execute control char
+ ELSE execute normal char FI
+ PER .
+
+control char:
+ akt char < ""32"" .
+
+execute control char:
+ SELECT code (akt char) OF
+ CASE 1: home
+ CASE 2: right
+ CASE 3: up
+ CASE 7: out (""7"")
+ CASE 8: left
+ CASE 10: down
+ CASE 13: return
+ ENDSELECT .
+
+home:
+ x := x pos;
+ y := y pos .
+
+right:
+ x INCR x step; y INCR y step .
+
+up:
+ x INCR y step; y INCR x step .
+
+left:
+ x DECR x step; y DECR y step .
+
+down:
+ x DECR y step; y DECR x step .
+
+return:
+ x := x pos .
+
+execute normal char:
+ draw char (code (akt char), x, y, height, width,
+ angle);
+ x INCR x step;
+ y INCR y step .
+
+akt char:
+ msg SUB i .
+
+END PROC draw text;
+
+PROC draw (TEXT CONST msg):
+ draw (msg,0.0,5.0,5.0)
+END PROC draw;
+
+PROC draw (TEXT CONST msg,REAL CONST angle,REAL CONST heigth,width):
+ REAL CONST xr :: real(old x),
+ yr :: real(old y) * y to x;
+ draw text (xr,yr,msg,angle,heigth * real(x pixel) / x cm / 10.0,
+ width * real(x pixel) / x cm / 10.0)
+ (* heigth mm --> x punkte *)
+END PROC draw;
+
+(***************************** LINETYPES ***********************************)
+
+PROC linetype (INT CONST nummer,TEXT CONST lt):
+ IF nummer > 5 OR nummer < 2
+ THEN errorstop ("number out of range")
+ ELSE linetypes [nummer] := lt
+ FI
+END PROC linetype ;
+
+PROC reset linetypes :
+ linetype (2,"1100");
+ linetype (3,"11110000");
+ linetype (4,"1111111100000000");
+ linetype (5,"1111111100011000");
+END PROC reset linetypes ;
+
+(***************************** UTILIES *************************************)
+
+PROC where (REAL VAR x, y) :
+ x := pos.x; y := pos.y
+END PROC where;
+
+PROC where (REAL VAR x, y, z) :
+ x := pos.x; y := pos.y; z := pos.z
+END PROC where;
+
+PROC bar (REAL CONST hight, width, INT CONST pattern):
+ INT VAR zero x, zero y, end x, end y;
+ transform (0.0, 0.0, 0.0, zero x, zero y);
+ transform (width, hight, 0.0, end x, end y);
+ bar (h-(end x-zero x) DIV 2, v, end x-zero x, end y-zero y, pattern)
+END PROC bar;
+
+PROC bar (INT CONST from x, from y, width, hight, pattern):
+ INT CONST to x :: from x+width, to y :: from y+hight;
+ INT VAR x, y;
+ draw frame;
+ SELECT pattern OF
+ CASE empty: (* nothing to do *)
+ CASE half: half bar
+ CASE full: full bar
+ CASE horizontal: horizontal bar
+ CASE vertical: vertical bar
+ CASE cross: horizontal bar;
+ vertical bar
+ CASE diagonal right: diagonal right bar
+ CASE diagonal left: diagonal left bar
+ CASE diagonal both: diagonal both bar
+ OTHERWISE errorstop ("Unknown pattern") ENDSELECT .
+
+draw frame:
+ move (from x, from y);
+ draw (from x, to y);
+ draw (to x, to y);
+ draw (to x, from y);
+ draw (from x, from y).
+
+full bar:
+ FOR y FROM from y UPTO to y
+ REP move (from x, y);
+ draw (to x, y)
+ PER .
+
+half bar:
+ FOR y FROM from y UPTO to y
+ REP x := from x + 1 + (y AND 1);
+ WHILE x < to x
+ REP move (x, y);
+ draw (x, y);
+ x INCR 2
+ PER
+ PER .
+
+horizontal bar:
+ y := from y;
+ WHILE y < to y
+ REP move (from x, y);
+ draw (to x, y);
+ y INCR 5
+ PER .
+
+vertical bar:
+ x := from x + 5;
+ WHILE x < to x
+ REP move (x, from y);
+ draw (x, to y);
+ x INCR 5
+ PER .
+
+diagonal right bar:
+ y := from y-width+5;
+ WHILE y < to y
+ REP move (max (from x, to x-y-width+from y), max (from y, y));
+ draw (min (to x, from x+to y-y), min (to y, y+width));
+ y INCR 5
+ PER .
+
+diagonal left bar:
+ y := from y-width+5;
+ WHILE y < to y
+ REP move (min (to x, to x-from y+y), max (from y, y));
+ draw (max (from x, from x+y+width-to y), min (to y, y+width));
+ y INCR 5
+ PER .
+
+diagonal both bar:
+ y := from y-width+5;
+ WHILE y < to y
+ REP move (max (from x, to x-y-width+from y), max (from y, y));
+ draw (min (to x, from x+to y-y), min (to y, y+width));
+ move (min (to x, to x-from y+y), max (from y, y));
+ draw (max (from x, from x+y+width-to y), min (to y, y+width));
+ y INCR 5
+ PER .
+
+END PROC bar;
+
+PROC circle (REAL CONST r, from, to, INT CONST pattern):
+ REAL VAR t :: from; INT VAR i; i := pattern; (* sonst WARNUNG *)
+ WHILE t < to
+ REP transform (pos.x + r*cosd (t), pos.y + r*sind (t), 0.0, h, v);
+ draw (h, v);
+ t INCR 1.0
+ PER;
+ transform (pos.x, pos.y, 0.0, h, v);
+ draw (h, v) .
+
+END PROC circle;
+
+PROC box :
+ move (0,0);
+ draw (0,y pixel-1);
+ draw (x pixel-1, y pixel-1);
+ draw (x pixel-1, 0);
+ draw (0,0)
+END PROC box;
+
+END PACKET basis plot;
+
+(************************* Plot Spool Input/ Output ***********************)
+
+PACKET plot interface DEFINES (* Carsten Weinholz *)
+ (* V 1.1 02.07.87 *)
+ save ,
+ exists ,
+ erase ,
+ ALL ,
+ first ,
+ start ,
+ stop ,
+ halt ,
+ wait for halt ,
+ list ,
+ picfiles ,
+ generate plot manager:
+
+LET initfile = "GRAPHIK.Manager",
+ plot manager name= "PLOT" ,
+
+ picfiletype = 1102,
+
+ ack = 0,
+ false code = 6,
+ fetch code = 11,
+ save code = 12,
+ exists code = 13,
+ erase code = 14,
+ list code = 15,
+ all code = 17,
+ first code = 25,
+ start code = 26,
+ stop code = 27,
+ halt code = 28,
+ wait for halt code = 29;
+
+BOUND STRUCT (TEXT tname,user id,pass) VAR msg;
+
+DATASPACE VAR ds;
+
+INT VAR reply;
+THESAURUS VAR all myself picfiles;
+
+PROC first (TEXT CONST ds name, PLOTTER CONST plotter id):
+ call (first code, ds name + ""0"" + id name (plotter id), plot id (plotter id))
+END PROC first;
+
+PROC start (PLOTTER CONST plotter id):
+ call (start code, id name (plotter id), plot id (plotter id))
+END PROC start;
+
+PROC stop (PLOTTER CONST plotter id):
+ call (stop code, id name (plotter id), plot id (plotter id))
+END PROC stop;
+
+PROC halt (PLOTTER CONST plotter id):
+ call (halt code, id name (plotter id), plot id (plotter id))
+END PROC halt;
+
+PROC wait for halt (PLOTTER CONST plotter id):
+ call (wait for halt code, id name (plotter id), plot id (plotter id))
+END PROC wait for halt;
+
+PROC save (TEXT CONST ds name, PLOTTER CONST plotter id):
+ enable stop;
+ last param (ds name);
+ call (save code, ds name + ""0"" + id name (plotter id),
+ old (ds name), plot id (plotter id))
+END PROC save;
+
+PROC save (PICFILE CONST p, TEXT CONST pname, PLOTTER CONST plotter id):
+ enable stop;
+ DATASPACE VAR ds;
+ ds BECOMES p;
+ call (save code, pname + ""0"" + id name (plotter id), ds,
+ plot id (plotter id));
+END PROC save;
+
+OP BECOMES (DATASPACE VAR ds, PICFILE CONST p):
+ EXTERNAL 260
+END OP BECOMES;
+
+PROC save (THESAURUS CONST nameset, PLOTTER CONST plotter id):
+ TEXT VAR name;
+ INT VAR i :: 0;
+ get (nameset, name, i);
+ WHILE i > 0 REP
+ save (name, plotter id);
+ cout (i);
+ get (nameset, name, i)
+ PER
+END PROC save;
+
+BOOL PROC exists (TEXT CONST ds name, PLOTTER CONST plotter id):
+ INT VAR reply;
+ DATASPACE VAR ds :: nilspace;
+ BOUND TEXT VAR qname :: ds;
+ qname := ds name + ""0"" + id name (plotter id);
+ REP
+ call (plot id (plotter id), exists code, ds, reply)
+ UNTIL reply = false code OR reply = ack PER;
+ forget (ds);
+ reply = ack
+END PROC exists;
+
+PROC erase (TEXT CONST ds name,PLOTTER CONST plotter id):
+ call (erase code, ds name + ""0"" + id name (plotter id), plot id (plotter id))
+END PROC erase;
+
+PROC erase (THESAURUS CONST nameset, PLOTTER CONST plotter id):
+ TEXT VAR name;
+ INT VAR i :: 0;
+ get (nameset, name, i);
+ WHILE i > 0 REP
+ erase (name, plotter id);
+ cout (i);
+ get (nameset, name, i)
+ PER
+END PROC erase;
+
+THESAURUS OP ALL (PLOTTER CONST plotter id):
+ REP
+ forget (ds);
+ ds := nilspace;
+ msg := ds;
+ msg.tname := id name (plotter id);
+ msg.user id := "";
+ msg.pass := "";
+ call (plot id (plotter id), all code, ds, reply)
+ UNTIL reply = ack PER;
+ BOUND THESAURUS VAR result ds :: ds;
+ THESAURUS VAR result :: result ds;
+ forget (ds);
+ result
+END OP ALL;
+
+PROC list (FILE VAR f,PLOTTER CONST plotter id):
+ REP
+ forget (ds);
+ ds := nilspace;
+ msg := ds;
+ msg.tname := id name (plotter id);
+ msg.user id := "";
+ msg.pass := "";
+ call (plot id (plotter id), list code, ds, reply)
+ UNTIL reply = ack PER;
+ f := sequential file (modify, ds)
+END PROC list;
+
+PROC list (PLOTTER CONST plotter id):
+ FILE VAR list file;
+ list (list file, plotter id);
+ show (list file)
+END PROC list;
+
+THESAURUS PROC picfiles:
+ all myself picfiles := empty thesaurus;
+ do (PROC (TEXT CONST) insert if picfile,ALL myself);
+ all myself picfiles
+END PROC picfiles;
+
+PROC insert if picfile (TEXT CONST filename):
+ IF type (old (filename)) = picfiletype
+ THEN insert (all myself picfiles,filename)
+ FI
+END PROC insert if picfile;
+
+PROC generate plot manager:
+ TASK VAR plot manager;
+ IF exists (initfile)
+ THEN generate in background
+ ELSE errorstop ("""" + init file + """ existiert nicht")
+ FI.
+
+ generate in background:
+ begin (plot manager name,PROC init plot manager, plot manager);
+ INT VAR manager call;
+ DATASPACE VAR initspace;
+ TASK VAR order task;
+ REP
+ wait (initspace, manager call, order task)
+ UNTIL order task = plot manager PER;
+ initspace := old (initfile);
+ send (plot manager, ack, initspace);
+ say ("Plot-Manager wird generiert"13""10"");
+ say ("Bitte etwas Geduld..."13""10"");
+ REP
+ wait (initspace, manager call, order task)
+ UNTIL order task = plot manager PER;
+ forget (initspace);
+ say ("Plotmanager generiert !"13""10"")
+END PROC generate plot manager;
+
+PROC init plot manager:
+ DATASPACE VAR initspace :: nilspace;
+ INT VAR dummy;
+ call (father, fetch code, initspace, dummy);
+ copy (init space,init file);
+ insert (init file);
+ send (father,ack,initspace);
+ do ("plot manager");
+END PROC init plot manager;
+
+TASK PROC plot id (PLOTTER CONST plotter id):
+ IF plotter id = no plotter
+ THEN task (plot manager name)
+ ELSE station (plotter id)/plot manager name
+ FI
+END PROC plot id;
+
+TEXT PROC id name (PLOTTER CONST plotter id):
+ text (station (plotter id)) + "/" + text (channel (plotter id)) + "/" +
+ name (plotter id)
+END PROC id name;
+
+END PACKET plot interface;
+
+(************************* Plot Picture / Picfile *************************)
+
+PACKET plot DEFINES plot :
+
+LET draw key = 1,
+ move key = 2,
+ text key = 3,
+ move r key = 4,
+ draw r key = 5,
+ move cm key = 6,
+ draw cm key = 7,
+ move cm r key = 8,
+ draw cm r key = 9,
+ bar key = 10,
+ circle key = 11;
+
+LET postfix = ".PICFILE"
+
+INT VAR read pos;
+
+PROC plot (TEXT CONST name) :
+ PICFILE VAR p :: old (name);
+ IF channel <> channel (plotter) OR station (myself) <> station (plotter)
+ THEN save (name, plotter)
+ ELSE plot (p)
+ FI
+END PROC plot;
+
+PROC plot (PICFILE VAR p) :
+ IF channel <> channel (plotter) OR station(myself) <> station(plotter)
+ THEN save (p, name (myself) + "." + text (highest entry (ALL plotter))
+ + postfix, plotter)
+ ELSE direct plot
+ FI.
+
+ direct plot:
+ ROW 3 ROW 2 REAL VAR sizes;
+ ROW 2 ROW 2 REAL VAR limits;
+ ROW 4 REAL VAR angles;
+ ROW 2 REAL VAR obliques;
+ ROW 3 REAL VAR perspectives;
+ get values (p,sizes,limits,angles,obliques,perspectives);
+ set values (sizes,limits,angles,obliques,perspectives);
+ begin plot;
+ clear;
+ INT VAR i;
+ FOR i FROM 1 UPTO pictures (p)
+ REP PICTURE VAR act pic :: nilpicture;
+ to pic (p,i);
+ read picture (p,act pic);
+ IF pen (act pic) <> 0
+ THEN plot pic FI
+ PER;
+ end plot .
+
+ plot pic:
+ INT VAR colour, thickness, linetype;
+ BOOL VAR hidden;
+ selected pen (p,pen (act pic),colour,thickness,linetype,hidden);
+ pen (background (p),colour,thickness,linetype);
+ hidden lines (hidden);
+ plot (act pic).
+
+END PROC plot;
+
+PROC plot (PICTURE CONST p) :
+ IF channel <> channel (plotter) OR station (myself) <> station (plotter)
+ THEN errorstop ("PICTURES koennen nur direkt ausgegeben werden")
+ ELSE plot pic
+ FI.
+
+plot pic:
+ INT CONST pic length :: length (p);
+ TEXT CONST points :: subtext (text(p),5);
+ read pos := 0;
+ IF dim (p) = 2
+ THEN plot two dim pic
+ ELSE plot three dim pic FI .
+
+plot two dim pic:
+ WHILE read pos < pic length
+ REP plot two dim position PER .
+
+plot two dim position :
+ read pos INCR 1;
+ SELECT code (points SUB read pos) OF
+ CASE draw key : draw (next real, next real)
+ CASE move key : move (next real, next real)
+ CASE move r key : move r (next real, next real)
+ CASE draw r key : draw r (next real, next real)
+ CASE move cm key : move cm (next real, next real)
+ CASE draw cm key : draw cm (next real, next real)
+ CASE move cm r key : move cm r (next real, next real)
+ CASE draw cm r key : draw cm r (next real, next real)
+ CASE text key : draw (next text, next real, next real, next real)
+ CASE bar key : bar (next real, next real, next int)
+ CASE circle key : circle (next real, next real, next real, next int)
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+plot three dim pic:
+ WHILE read pos < pic length
+ REP plot three dim position PER .
+
+plot three dim position :
+ read pos INCR 1;
+ SELECT code (points SUB read pos) OF
+ CASE draw key : draw (next real, next real, next real)
+ CASE move key : move (next real, next real, next real)
+ CASE move r key : move r (next real, next real, next real)
+ CASE draw r key : draw r (next real, next real, next real)
+ CASE move cm key : move cm (next real, next real)
+ CASE draw cm key : draw cm (next real, next real)
+ CASE move cm r key : move cm r (next real, next real)
+ CASE draw cm r key : draw cm r (next real, next real)
+ CASE text key : draw (next text, next real, next real, next real)
+ CASE bar key : bar (next real, next real, next int)
+ CASE circle key : circle (next real, next real, next real, next int)
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+next real :
+ read pos INCR 8;
+ subtext (points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (points, read pos-1, read pos) ISUB 1 .
+
+next text :
+ INT CONST text length :: next int;
+ read pos INCR text length;
+ subtext (points, read pos-text length+1, read pos) .
+
+END PROC plot;
+
+END PACKET plot
+
diff --git a/app/mpg/2.2/src/GRAPHIK.Turtle b/app/mpg/2.2/src/GRAPHIK.Turtle
new file mode 100644
index 0000000..efdacc7
--- /dev/null
+++ b/app/mpg/2.2/src/GRAPHIK.Turtle
@@ -0,0 +1,139 @@
+(**************************************************************************)
+(* *)
+(* MPG - Graphik - System *)
+(* *)
+(* Version 2.1 vom 10.09.1987 *)
+(* *)
+(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *)
+(* unter Verwendung der Standard-Graphik *)
+(* "Turtle-Graphik" geschrieben von B.Jegerlehner *)
+(* *)
+(**************************************************************************)
+(* *)
+(* Dieses Paket stellt eine LOGO-aehnliche *)
+(* 'Schildkroetengraphik' zur Verfuegung *)
+(* *)
+(**************************************************************************)
+PACKET turtle graphics DEFINES begin turtle,
+ end turtle,
+ forward ,
+ forward to ,
+ turn ,
+ turn to ,
+ pen up ,
+ pen down ,
+ pen ,
+ angle ,
+ get turtle :
+
+REAL VAR x pos,
+ y pos,
+ winkel;
+
+PICFILE VAR bild;
+PICTURE VAR pic;
+
+BOOL VAR direct,
+ pen status;
+
+PROC begin turtle:
+ direct := TRUE;
+ x pos := 0.0;
+ y pos := 0.0;
+ winkel := 0.0;
+ begin plot;
+ clear;
+ viewport (0.0, 1.0, 0.0, 1.0);
+ window (-500.0, 500.0, -500.0, 500.0);
+ pen up;
+ forward to (0.0, 0.0)
+END PROC begin turtle;
+
+PROC begin turtle (TEXT CONST picfile):
+ direct := FALSE;
+ bild := picture file (picfile);
+ pic := nilpicture;
+ x pos := 0.0;
+ y pos := 0.0;
+ winkel := 0.0;
+ pen up;
+ forward to (0.0,0.0)
+END PROC begin turtle;
+
+PROC end turtle:
+ IF direct
+ THEN end plot
+ ELSE ausgabe
+ FI.
+
+ ausgabe:
+ REAL VAR x cm,y cm;
+ INT VAR dummy;
+ put picture (bild,pic);
+ drawing area (x cm,y cm,dummy,dummy);
+ viewport (bild, 0.0, 1.0, 0.0, 1.0);
+ window (bild, -500.0,500.0,-500.0,500.0);
+ plot(bild)
+END PROC end turtle;
+
+PROC turn (REAL CONST w):
+ winkel := (winkel + w) MOD 360.0
+END PROC turn;
+
+PROC turn to (REAL CONST w):
+ winkel := w MOD 360.0
+END PROC turn to;
+
+REAL PROC angle:
+ winkel
+END PROC angle;
+
+PROC forward (REAL CONST len):
+ forward to (x pos + cosd (winkel) * len,
+ y pos + sind (winkel) * len)
+END PROC forward;
+
+PROC pen up:
+ pen status := FALSE
+END PROC pen up;
+
+PROC pen down:
+ pen status := TRUE
+END PROC pen down;
+
+BOOL PROC pen:
+ pen status
+END PROC pen;
+
+PROC forward to (REAL CONST x,y):
+ IF direct
+ THEN dir plot
+ ELSE pic plot
+ FI;
+ x pos := x;
+ y pos := y.
+
+ dir plot:
+ IF pen status
+ THEN draw (x,y)
+ ELSE move (x,y)
+ FI.
+
+ pic plot:
+ IF length (pic) > 1923
+ THEN put picture (bild,pic);
+ pic := nilpicture
+ FI;
+ IF pen status
+ THEN draw (pic,x,y)
+ ELSE move (pic,x,y)
+ FI
+END PROC forward to;
+
+PROC get turtle (REAL VAR x,y):
+ x := x pos;
+ y := y pos
+END PROC get turtle
+
+END PACKET turtle graphics
+
diff --git a/app/mpg/2.2/src/GRAPHIK.list b/app/mpg/2.2/src/GRAPHIK.list
new file mode 100644
index 0000000..09f6002
--- /dev/null
+++ b/app/mpg/2.2/src/GRAPHIK.list
@@ -0,0 +1,28 @@
+GRAPHIK.list
+GRAPHIK.Install
+GRAPHIK.Basis
+GRAPHIK.Configurator
+GRAPHIK.Plot
+GRAPHIK.Manager
+GRAPHIK.Fkt
+GRAPHIK.Turtle
+ZEICHENSATZ
+FKT.help
+Muster
+std primitives
+matrix printer
+terminal plot
+DATAGRAPH 3/7.GCONF
+VIDEOSTAR 3/6.GCONF
+AMPEX 2/1-6.GCONF
+NEC P-3 3/15.GCONF
+WATANABE 3/8.GCONF
+VC 404 2/7.GCONF
+NEC P-9 2/15.HD.GCONF
+NEC P-9 2/15.MD.GCONF
+Atari 3/9.GCONF
+AMPEX 3/1-4.GCONF
+ENVIRONMENT2.GCONF
+ENVIRONMENT3.GCONF
+
+
diff --git a/app/mpg/2.2/src/HERCULES XT.GCONF b/app/mpg/2.2/src/HERCULES XT.GCONF
new file mode 100644
index 0000000..a77a50e
--- /dev/null
+++ b/app/mpg/2.2/src/HERCULES XT.GCONF
@@ -0,0 +1,105 @@
+INCLUDE "std primitives";
+INCLUDE "terminal plot" ;
+
+PLOTTER "HERCULES XT",1,1,720,348,24.5,18.5;
+
+COLORS "000999";
+
+PROC clear:
+ INT VAR return;
+ REP
+ control(-5,512+0,0,return);
+ UNTIL return <> -1
+ PER;
+ IF return <> 0
+ THEN errorstop("Graphik nicht ansprechbar!")
+ FI;
+END PROC clear;
+
+PROC prepare:
+ break(quiet);
+ REP disable stop;
+ continue (channel(plotter));
+ clear error;
+ enable stop;
+ IF NOT online
+ THEN pause(100)
+ FI
+ UNTIL online PER;
+END PROC prepare;
+
+PROC initplot:
+END PROC initplot;
+
+PROC endplot:
+ INT VAR dummy;
+ pause;
+ control (-5,2,0, dummy);
+END PROC endplot;
+
+PROC home:
+ moveto(0,347);
+END PROC home;
+
+PROC moveto(INT CONST x,y):
+ INT VAR dummy;
+ control (-7,x,(347-y),dummy); (* move nach SHARD-AT *)
+END PROC moveto;
+
+PROC set pixel(INT CONST x,y):
+ moveto(x,(347-y));
+ point;
+END PROC set pixel;
+
+PROC drawto(INT CONST x,y):
+ INT VAR dummy;
+ control(-6,x,(347-y),dummy); (* draw nach SHARD-AT *)
+END PROC drawto;
+
+PROC foreground (INT VAR type):
+ ROW 5 ROW 4 INT CONST nibble :: ROW 5 ROW 4 INT:
+ (ROW 4 INT : ( 4369, 4369, 4369, 4369), (* durhgezogene Linie *)
+ ROW 4 INT : ( 17, 17, 17, 17), (* gepunktete Linie *)
+ ROW 4 INT : ( 4369, 0, 4369, 0), (* kurz gestrichelt *)
+ ROW 4 INT : ( 4369, 4369, 0, 0), (* lang gestrichelt *)
+ ROW 4 INT : ( 4369, 4369, 4369, 0)); (* gestrichpunktet *);
+ INT VAR dummy;
+ IF type > 5 OR type < 0
+ THEN type := 0
+ FI;
+ IF type = 0
+ THEN control( -9, 0, 0, dummy);
+ control(-10, 0, 0, dummy); (* loeschen *)
+ ELSE control( -9, nibble[type][2], nibble[type][1], dummy);
+ control(-10, nibble[type][4], nibble[type][3], dummy)
+ FI;
+END PROC foreground;
+
+PROC background(INT VAR type):
+ type := 0
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ std circle (x,y,rad,from,to)
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1,y1,x2,y2,pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+END PROC fill;
+
+
+
+
+
+
+
+
+
+
+
diff --git a/app/mpg/2.2/src/Muster b/app/mpg/2.2/src/Muster
new file mode 100644
index 0000000..cebb35c
--- /dev/null
+++ b/app/mpg/2.2/src/Muster
@@ -0,0 +1,75 @@
+INCLUDE "Name der Include-Datei";
+
+PLOTTER "Plottername",<Station>,<Kanal>,<Xpixel>,<Ypixel>,<Xcm>,<Ycm>;
+
+LINK <Station>/<Kanal>,<Station>/<Kanal>....;
+
+COLORS "<RGB-Kombinationen als 3-Byte Codefolge>";
+
+ .
+ .
+ .
+<Hier koennen Endgeraetspezifische Prozeduren/Variablen (globalebene)
+ eingefuegt werden. Achtung! um Namenskonflikte mit globalobjekten
+ anderer Endgeraete zu vermeiden sollten die Namen dieser Objekte
+ auch stets den Endgeraet-Namen enthalten
+ (z.B. 'TEXT PROC videostar koordinaten (INT CONST x,y)')
+>
+
+PROC initplot:
+ Warnung: Da der Configurator den Prozedur-Rumpf in ein Refinement
+ verwandelt, muessen Namenskonflikte vermieden wrden !
+END PROC initplot;
+
+PROC endplot:
+END PROC endplot;
+
+PROC prepare:
+END PROC prepare;
+
+PROC clear:
+END PROC clear;
+
+PROC home:
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+END PROC setpixel;
+
+PROC foreground (INT CONST type):
+END PROC foreground;
+
+PROC background (INT CONST type):
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette:
+
+PROC circle (INT CONST x,y,rad,from,to):
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+END PROC fill;
+
+EDITOR; (* Durch EDITOR wird das optionale Vorhandensein nachfolgender
+ Editor-Befehle angezeigt *)
+
+PROC get cursor (INT VAR x,y,TEXT VAR exit char):
+END PROC get cursor;
+
+PROC graphik cursor (INT CONST x,y,BOOL CONST on):
+END PROC graphik cursor;
+
+PROC set marker (INT CONST x,y,type):
+END PROC set marker;
+
+
diff --git a/app/mpg/2.2/src/NEC P-3 3-15.GCONF b/app/mpg/2.2/src/NEC P-3 3-15.GCONF
new file mode 100644
index 0000000..ecf052c
--- /dev/null
+++ b/app/mpg/2.2/src/NEC P-3 3-15.GCONF
@@ -0,0 +1,126 @@
+INCLUDE "std primitives";
+INCLUDE "matrix printer";
+
+PLOTTER "NEC P3",3,15,1024,1024,21.68,21.68;
+
+COLORS "000999";
+
+(* Version vom 21.10.87 BJ *)
+
+(******** Hilfsvariablen fuer nec-plot ***************)
+LET nec x pixel = 1024,nec y pixel d 16 = 64;
+LET nec y max = 1023;
+LET BITLINE = ROW nec x pixel INT;
+BOUND ROW nec y pixeld16 BITLINE VAR nec map;
+BITLINE VAR nec nilline;
+DATASPACE VAR nec ds;
+INT VAR nec x,nec y;
+(*****************************************************)
+
+PROC prepare:
+ call (29, "", printer); (* wait for halt *)
+ continue (channel (plotter))
+END PROC prepare;
+
+PROC initplot:
+ INT VAR nec i;
+ FOR nec i FROM 1 UPTO nec x pixel REP
+ nec nilline[nec i] := 0
+ PER;
+ forget(nec ds);
+ nec ds := nilspace;
+ nec map := nec ds;
+ disable stop
+END PROC initplot;
+
+PROC endplot:
+ out(""27"T16");
+ INT VAR nec i;
+ FOR nec i FROM 1 UPTO necypixeld16 REP
+ nec out line (nec i)
+ PER;
+ out(""12"");
+ break(quiet);
+ call (26,"",printer); (* start spool *)
+ enable stop
+END PROC endplot;
+
+PROC nec out line (INT CONST i):
+ INT VAR c,j :: 1,d;
+ WHILE j <= nec x pixel REP
+ c := nec map[i][j];
+ d := 0;
+ WHILE j <= nec x pixel CAND nec map[i][j] = c REP
+ j INCR 1;
+ d INCR 1
+ PER;
+ IF j <= nec x pixel OR c <> 0
+ THEN TEXT VAR t :: text(d,4);
+ change all(t," ","0");
+ INT VAR kk :: c;rotate(kk,8);
+ out(""27"W"+t+code(c AND 255) + code(kk AND 255))
+ FI
+ PER;
+ out(""13""10"")
+END PROC nec out line;
+
+PROC clear:
+ INT VAR nec i;
+ FOR nec i FROM 1 UPTO nec y pixeld16 REP
+ nec map[nec i] := nec nilline
+ PER
+END PROC clear;
+
+PROC home:
+ move to (0,0)
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ nec x := x;
+ nec y := y
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ printer line (nec x+1, nec y max - nec y,x+1,nec y max - y,
+ PROC (INT CONST, INT CONST) nec p3 set pixel);
+ nec x:=x;nec y:=y
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ setbit(nec map[(nec y max-y) DIV 16 + 1][x+1],(nec y max-y) AND 15)
+END PROC setpixel;
+
+PROC nec p3 set pixel (INT CONST x,y):
+ set bit(nec map[y DIV 16 + 1][x],y AND 15)
+END PROC nec p3 set pixel;
+
+BOOL PROC nec p3 is pixel (INT CONST x,y):
+ bit (nec map[y DIV 16 + 1][x],y AND 15)
+END PROC nec p3 is pixel;
+
+PROC foreground (INT VAR type):
+ type := 1; (* Nur Schwarz auf Weiss-Druck moeglich *)
+END PROC foreground;
+
+PROC background (INT VAR type):
+ type := 0;
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ std circle (x,y,rad,from,to)
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1, y1, x2, y2, pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+ printer fill (x,x,nec y max - y,1,
+ BOOL PROC (INT CONST, INT CONST) nec p3 is pixel,
+ PROC (INT CONST, INT CONST) nec p3 set pixel)
+END PROC fill;
+
+
diff --git a/app/mpg/2.2/src/NEC P-6 MD.GCONF b/app/mpg/2.2/src/NEC P-6 MD.GCONF
new file mode 100644
index 0000000..627ec31
--- /dev/null
+++ b/app/mpg/2.2/src/NEC P-6 MD.GCONF
@@ -0,0 +1,221 @@
+INCLUDE "std primitives";
+INCLUDE "matrix printer";
+
+PLOTTER "NEC P6 MD",1,15,1416,1760,20.00,25.00;
+
+COLORS "000999";
+
+(* Version vom 21.10.87 BJ/26.11.SvA *)
+
+(* Globale Daten fuer NEC P6 *)
+
+LET md p9 graf = ""27"*"39"", (* Nec P9 in 24-Nadel 180 Pixel/zoll Modus *)
+ md p9 feed = ""28"3", (* Zeilenabstand in 360 Pixel/Zoll setzen *)
+ md p9 nlq = ""27"x"1"", (* NLQ Modus waehlen *)
+ md p9 pos = ""27"\"; (* in 1/180 Zoll-Schritten rel Positionieren *)
+
+LET md p9 x max = 1416,
+ md p9 y max = 1760,
+ md p9 y lines = 110, (* y pixel / 16 (Punkte pro INT) *)
+ md p9 x per ds= 596, (* Maximale x pixel pro Dataspace ( Darf *)
+ (* Nicht mehr als 256 K sein !!! *)
+ (* x per ds = 256 * 1024 / p9 y lines / 4 *)
+ md p9 x lines = 3; (* x pixel / hd p9 x per ds *)
+
+LET MDPYLINE = ROW md p9 x per ds INT,
+ MDPSMAP = ROW md p9 y lines MDPYLINE,
+ MDPMAP = ROW md p9 x lines BOUND MDPSMAP;
+
+MDPMAP VAR md p9 map;
+
+ROW md p9 x lines DATASPACE VAR md p9 ds;
+
+INT VAR md p9 x pos, md p9 y pos;
+
+(* Globale Daten Ende *)
+
+PROC prepare:
+ REP
+ call (29, "", printer); (* wait for halt *)
+ IF task(channel(plotter)) = niltask (* Es koennte der HD worker dran sein *)
+ THEN continue (channel (plotter)) (* der startet den PRINTER wieder ! *)
+ ELSE pause(300) (* folge : Kanal belegt -> dead *)
+ FI
+ UNTIL channel(myself) = channel(plotter) PER
+END PROC prepare;
+
+PROC initplot:
+ INT VAR md p9 i;
+ FOR md p9 i FROM 1 UPTO md p9 x lines REP
+ md p9 ds[md p9 i] := nilspace;
+ md p9 map[md p9 i] := md p9 ds[md p9 i]
+ PER
+END PROC initplot;
+
+PROC endplot:
+ md p9 put map;
+ break(quiet);
+ call (26, "", printer); (* start spool *)
+ enable stop
+END PROC endplot;
+
+PROC md p9 put map:
+ open graf;
+ put map;
+ close graf;
+ forget dataspaces.
+
+ open graf:
+ out(md p9 feed + ""32""); (* LF auf 16/180 Zoll setzen *)
+ out(md p9 nlq). (* NLQ Modus waehlen, damit Positionierung in 1/180 *)
+ (* Schritten geht (sonst 1/120) *)
+ close graf:
+ out(""12""). (* Form Feed ! Drucker muss auf richtige Seitenlaenge *)
+ (* eingestellt sein (EUMEL-DR macht kein FF) *)
+
+ forget dataspaces:
+ INT VAR i;
+ FOR i FROM 1 UPTO md p9 x lines REP
+ forget(md p9 ds[i])
+ PER.
+
+ put map:
+ INT VAR j;
+ FOR j FROM 1 UPTO md p9 y lines REP
+ put line;
+ PER.
+
+ put line:
+ INT VAR actual pos :: 0, (* actual pos : aktuelle x-position 0..x max*)
+ last pos;
+ WHILE actual pos <= md p9 x max REP
+ put blank cols;
+ put nonblank cols
+ PER;
+ line.
+
+ put blank cols:
+ last pos := actual pos;
+ WHILE actual pos <= md p9 x max CAND actual col is blank REP
+ actual pos INCR 1
+ PER;
+ IF actual pos > last pos AND actual pos <= md p9 x max
+ THEN out blank cols
+ FI.
+
+ put nonblank cols:
+ last pos := actual pos;
+ WHILE actual pos <= md p9 x max CAND NOT actual col is blank REP
+ actual pos INCR 1
+ PER;
+ IF actual pos > last pos
+ THEN out nonblank cols
+ FI.
+
+ out blank cols:
+ TEXT VAR t :: " ";
+ replace(t, 1, actual pos - last pos);
+ out (md p9 pos + t).
+
+ out nonblank cols:
+ t := " ";
+ replace (t,1, actual pos - last pos);
+ out(md p9 graf + t);
+ INT VAR k;
+ FOR k FROM last pos UPTO actual pos - 1 REP
+ INT VAR word :: md p9 map [(k DIV md p9 x per ds) + 1][j]
+ [(k MOD md p9 x per ds) + 1],
+ first byte :: word;
+ rotate (word, 8);
+ out (code (word));
+ out (code (first byte));
+ out (""0"")
+ PER.
+
+ actual col is blank:
+ md p9 map [(actual pos DIV md p9 x per ds) + 1][j]
+ [(actual pos MOD md p9 x per ds) + 1] = 0
+
+END PROC md p9 put map;
+
+PROC clear:
+ md p9 clear
+END PROC clear;
+
+PROC md p9 clear:
+ create initline;
+ initialize all lines.
+
+ create initline:
+ MDPYLINE VAR initline;
+ INT VAR i;
+ FOR i FROM 1 UPTO md p9 x per ds REP
+ initline[i] := 0
+ PER.
+
+ initialize all lines:
+ INT VAR k;
+ FOR i FROM 1 UPTO md p9 x lines REP
+ FOR k FROM 1 UPTO md p9 y lines REP
+ md p9 map[i][k] := initline
+ PER
+ PER
+END PROC md p9 clear;
+
+PROC home:
+ move to (0,0)
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ md p9 x pos := x;
+ md p9 y pos := y
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ printer line (md p9 x pos,md p9 y max - md p9 y pos,
+ x, md p9 y max - y,
+ PROC (INT CONST, INT CONST) md p9 set pixel);
+ md p9 x pos := x;
+ md p9 y pos := y
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ md p9 set pixel (x, md p9 y max - x)
+END PROC setpixel;
+
+PROC md p9 set pixel (INT CONST x,y):
+ setbit (md p9 map [(x DIV md p9 x per ds) + 1][(y DIV 16) + 1]
+ [(x MOD md p9 x per ds) + 1],15 - (y AND 15))
+END PROC md p9 set pixel;
+
+BOOL PROC md p9 is pixel (INT CONST x,y):
+ bit (md p9 map [(x DIV md p9 x per ds) + 1][(y DIV 16) + 1]
+ [(x MOD md p9 x per ds) + 1],15 - (y AND 15))
+END PROC md p9 is pixel;
+
+PROC foreground (INT VAR type):
+ type := 1
+END PROC foreground;
+
+PROC background (INT VAR type):
+ type := 0
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ std circle (x,y,rad,from,to)
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1, y1, x2, y2, pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+ printer fill (x,x,md p9 y max - y,1,
+ BOOL PROC (INT CONST, INT CONST) md p9 is pixel,
+ PROC (INT CONST, INT CONST) md p9 set pixel)
+END PROC fill;
+
+
diff --git a/app/mpg/2.2/src/NEC P-9 2-15.HD.GCONF b/app/mpg/2.2/src/NEC P-9 2-15.HD.GCONF
new file mode 100644
index 0000000..552e298
--- /dev/null
+++ b/app/mpg/2.2/src/NEC P-9 2-15.HD.GCONF
@@ -0,0 +1,244 @@
+INCLUDE "std primitives";
+INCLUDE "matrix printer";
+
+PLOTTER "NEC P9 HD",2,15,2880,2880,20.32,20.32;
+
+COLORS "000999";
+
+(* Version vom 21.10.87 BJ *)
+
+(* Globale Daten fuer NEC P9 *)
+
+LET hd p9 graf = ""27"*"40"", (* Nec P9 in 24-Nadel 360 Pixel/zoll Modus *)
+ hd p9 feed = ""28"3", (* Zeilenabstand in 360 Pixel/Zoll setzen *)
+ hd p9 nlq = ""27"x"1"", (* NLQ Modus waehlen *)
+ hd p9 pos = ""27"\"; (* in 1/180 Zoll-Schritten rel Positionieren *)
+
+LET hd p9 x max = 2879,
+ hd p9 y max = 2879,
+ hd p9 y lines = 90, (* y pixel / 16 (Punkte pro INT) / 2 (Maps) *)
+ hd p9 x per ds= 1440, (* Maximale x pixel pro Dataspace ( Darf *)
+ (* Nicht mehr als 256 K sein !!! *)
+ (* x per ds = 256 * 1024 / p9 y lines / 4 *)
+ hd p9 x lines = 2; (* x pixel / hd p9 x per ds *)
+
+LET HDPYLINE = ROW hd p9 x per ds INT,
+ HDPSMAP = ROW hd p9 y lines HDPYLINE,
+ HDPMAP = ROW hd p9 x lines ROW 2 BOUND HDPSMAP;
+
+HDPMAP VAR hd p9 map;
+
+ROW hd p9 x lines ROW 2 DATASPACE VAR hd p9 ds;
+
+INT VAR hd p9 x pos, hd p9 y pos;
+
+(* Globale Daten Ende *)
+
+PROC prepare:
+ REP
+ call (29, "", printer); (* wait for halt *)
+ IF task(channel(plotter)) = niltask (* Es koennte der MD worker dran sein *)
+ THEN continue (channel (plotter)) (* Der startet den PRINTER wieder ! *)
+ ELSE pause(300) (* folge : Kanal belegt -> dead *)
+ FI
+ UNTIL channel(myself) = channel(plotter) PER
+END PROC prepare;
+
+PROC initplot:
+ INT VAR hd p9 i,hd p9 j;
+ FOR hd p9 i FROM 1 UPTO hd p9 x lines REP
+ FOR hd p9 j FROM 1 UPTO 2 REP
+ hd p9 ds[hd p9 i][hd p9 j] := nilspace;
+ hd p9 map[hd p9 i][hd p9 j] := hd p9 ds[hd p9 i][hd p9 j]
+ PER
+ PER
+END PROC initplot;
+
+PROC endplot:
+ hd p9 put map;
+ break(quiet);
+ call (26, "", printer); (* start spool *)
+ enable stop
+END PROC endplot;
+
+PROC hd p9 put map:
+ open graf;
+ put map;
+ close graf;
+ forget dataspaces.
+
+ open graf:
+ out(hd p9 nlq). (* NLQ Modus waehlen, damit Positionierung in 1/180 *)
+ (* Schritten geht (sonst 1/120) *)
+ close graf:
+ out(""12""). (* Form Feed ! Drucker muss auf richtige Seitenlaenge *)
+ (* eingestellt sein (EUMEL-DR macht kein FF) *)
+
+ forget dataspaces:
+ INT VAR i;
+ FOR i FROM 1 UPTO hd p9 x lines REP
+ FOR j FROM 1 UPTO 2 REP
+ forget(hd p9 ds[i][j])
+ PER
+ PER.
+
+ put map:
+ INT VAR j,half;
+ FOR j FROM 1 UPTO hd p9 y lines REP
+ FOR half FROM 1 UPTO 2 REP
+ open line;
+ put half line;
+ close line
+ PER
+ PER.
+
+ open line:
+ INT VAR actual pos :: 0, (* aktuelle x-pos 0..x max *)
+ last pos.
+
+ close line:
+ out(hd p9 feed);
+ IF half = 1
+ THEN out (""1"") (* LF 1/360 Zoll *)
+ ELSE out (""31"")
+ FI;
+ line.
+
+ put half line:
+ WHILE actual pos <= hd p9 x max REP
+ put blank cols;
+ put nonblank cols
+ PER.
+
+ put blank cols:
+ last pos := actual pos;
+ WHILE actual pos <= hd p9 x max CAND actual col is blank REP
+ actual pos INCR 1
+ PER;
+ IF actual pos > last pos AND actual pos <= hd p9 x max
+ THEN out blank cols
+ FI.
+
+ put nonblank cols:
+ last pos := actual pos;
+ WHILE actual pos <= hd p9 x max CAND NOT actual col is blank REP
+ actual pos INCR 1
+ PER;
+ IF actual pos > last pos
+ THEN out nonblank cols
+ FI.
+
+ out blank cols:
+ IF actual pos - last pos > 1
+ THEN TEXT VAR t :: " ";
+ replace(t, 1, (actual pos - last pos) DIV 2);
+ out (hd p9 pos + t)
+ FI;
+ IF (actual pos - last pos) MOD 2 = 1
+ THEN out (hd p9 graf + ""1""0"" + 3 * ""0"")
+ FI.
+
+ out nonblank cols:
+ t := " ";
+ replace (t,1, actual pos - last pos);
+ out(hd p9 graf + t);
+ INT VAR k;
+ FOR k FROM last pos UPTO actual pos - 1 REP
+ INT VAR word :: hd p9 map [(k DIV hd p9 x per ds) + 1][half][j]
+ [(k MOD hd p9 x per ds) + 1],
+ first byte :: word;
+ rotate (word, 8);
+ out (code (word));
+ out (code (first byte));
+ out (""0"")
+ PER.
+
+ actual col is blank:
+ hd p9 map [(actual pos DIV hd p9 x per ds) + 1][half][j]
+ [(actual pos MOD hd p9 x per ds) + 1] = 0
+
+END PROC hd p9 put map;
+
+PROC clear:
+ hd p9 clear
+END PROC clear;
+
+PROC hd p9 clear:
+ create initline;
+ initialize all lines.
+
+ create initline:
+ HDPYLINE VAR initline;
+ INT VAR i;
+ FOR i FROM 1 UPTO hd p9 x per ds REP
+ initline[i] := 0
+ PER.
+
+ initialize all lines:
+ INT VAR j,k;
+ FOR i FROM 1 UPTO hd p9 x lines REP
+ FOR j FROM 1 UPTO 2 REP
+ FOR k FROM 1 UPTO hd p9 y lines REP
+ hd p9 map[i][j][k] := initline
+ PER
+ PER
+ PER
+END PROC hd p9 clear;
+
+PROC home:
+ move to (0,0)
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ hd p9 x pos := x;
+ hd p9 y pos := y
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ printer line (hd p9 x pos,hd p9 y max - hd p9 y pos,
+ x, hd p9 y max - y,
+ PROC (INT CONST, INT CONST) hd p9 set pixel);
+ hd p9 x pos := x;
+ hd p9 y pos := y
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ hd p9 set pixel (x, hd p9 y max - x)
+END PROC setpixel;
+
+PROC hd p9 set pixel (INT CONST x,y):
+ setbit (hd p9 map [(x DIV hd p9 x per ds) + 1][(y AND 1) + 1][(y DIV 32) + 1]
+ [(x MOD hd p9 x per ds) + 1],15 - ((y DIV 2) AND 15))
+END PROC hd p9 set pixel;
+
+BOOL PROC hd p9 is pixel (INT CONST x,y):
+ bit (hd p9 map [(x DIV hd p9 x per ds) + 1][(y AND 1) + 1][(y DIV 32) + 1]
+ [(x MOD hd p9 x per ds) + 1],15 - ((y DIV 2) AND 15))
+END PROC hd p9 is pixel;
+
+PROC foreground (INT VAR type):
+ type := 1
+END PROC foreground;
+
+PROC background (INT VAR type):
+ type := 0
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ std circle (x,y,rad,from,to)
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1, y1, x2, y2, pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+ printer fill (x,x, hd p9 y max - y, 1,
+ BOOL PROC (INT CONST, INT CONST) hd p9 is pixel,
+ PROC (INT CONST, INT CONST) hd p9 set pixel)
+END PROC fill;
+
+
diff --git a/app/mpg/2.2/src/NEC P-9 2-15.MD.GCONF b/app/mpg/2.2/src/NEC P-9 2-15.MD.GCONF
new file mode 100644
index 0000000..5a5fa03
--- /dev/null
+++ b/app/mpg/2.2/src/NEC P-9 2-15.MD.GCONF
@@ -0,0 +1,221 @@
+INCLUDE "std primitives";
+INCLUDE "matrix printer";
+
+PLOTTER "NEC P9 MD",2,15,2340,1984,33.02,27.99644;
+
+COLORS "000999";
+
+(* Version vom 21.10.87 BJ *)
+
+(* Globale Daten fuer NEC P9 *)
+
+LET md p9 graf = ""27"*"39"", (* Nec P9 in 24-Nadel 180 Pixel/zoll Modus *)
+ md p9 feed = ""28"3", (* Zeilenabstand in 360 Pixel/Zoll setzen *)
+ md p9 nlq = ""27"x"1"", (* NLQ Modus waehlen *)
+ md p9 pos = ""27"\"; (* in 1/180 Zoll-Schritten rel Positionieren *)
+
+LET md p9 x max = 2339,
+ md p9 y max = 1979,
+ md p9 y lines = 124, (* y pixel / 16 (Punkte pro INT) *)
+ md p9 x per ds= 780, (* Maximale x pixel pro Dataspace ( Darf *)
+ (* Nicht mehr als 256 K sein !!! *)
+ (* x per ds = 256 * 1024 / p9 y lines / 4 *)
+ md p9 x lines = 3; (* x pixel / hd p9 x per ds *)
+
+LET MDPYLINE = ROW md p9 x per ds INT,
+ MDPSMAP = ROW md p9 y lines MDPYLINE,
+ MDPMAP = ROW md p9 x lines BOUND MDPSMAP;
+
+MDPMAP VAR md p9 map;
+
+ROW md p9 x lines DATASPACE VAR md p9 ds;
+
+INT VAR md p9 x pos, md p9 y pos;
+
+(* Globale Daten Ende *)
+
+PROC prepare:
+ REP
+ call (29, "", printer); (* wait for halt *)
+ IF task(channel(plotter)) = niltask (* Es koennte der HD worker dran sein *)
+ THEN continue (channel (plotter)) (* der startet den PRINTER wieder ! *)
+ ELSE pause(300) (* folge : Kanal belegt -> dead *)
+ FI
+ UNTIL channel(myself) = channel(plotter) PER
+END PROC prepare;
+
+PROC initplot:
+ INT VAR md p9 i;
+ FOR md p9 i FROM 1 UPTO md p9 x lines REP
+ md p9 ds[md p9 i] := nilspace;
+ md p9 map[md p9 i] := md p9 ds[md p9 i]
+ PER
+END PROC initplot;
+
+PROC endplot:
+ md p9 put map;
+ break(quiet);
+ call (26, "", printer); (* start spool *)
+ enable stop
+END PROC endplot;
+
+PROC md p9 put map:
+ open graf;
+ put map;
+ close graf;
+ forget dataspaces.
+
+ open graf:
+ out(md p9 feed + ""32""); (* LF auf 16/180 Zoll setzen *)
+ out(md p9 nlq). (* NLQ Modus waehlen, damit Positionierung in 1/180 *)
+ (* Schritten geht (sonst 1/120) *)
+ close graf:
+ out(""12""). (* Form Feed ! Drucker muss auf richtige Seitenlaenge *)
+ (* eingestellt sein (EUMEL-DR macht kein FF) *)
+
+ forget dataspaces:
+ INT VAR i;
+ FOR i FROM 1 UPTO md p9 x lines REP
+ forget(md p9 ds[i])
+ PER.
+
+ put map:
+ INT VAR j;
+ FOR j FROM 1 UPTO md p9 y lines REP
+ put line;
+ PER.
+
+ put line:
+ INT VAR actual pos :: 0, (* actual pos : aktuelle x-position 0..x max*)
+ last pos;
+ WHILE actual pos <= md p9 x max REP
+ put blank cols;
+ put nonblank cols
+ PER;
+ line.
+
+ put blank cols:
+ last pos := actual pos;
+ WHILE actual pos <= md p9 x max CAND actual col is blank REP
+ actual pos INCR 1
+ PER;
+ IF actual pos > last pos AND actual pos <= md p9 x max
+ THEN out blank cols
+ FI.
+
+ put nonblank cols:
+ last pos := actual pos;
+ WHILE actual pos <= md p9 x max CAND NOT actual col is blank REP
+ actual pos INCR 1
+ PER;
+ IF actual pos > last pos
+ THEN out nonblank cols
+ FI.
+
+ out blank cols:
+ TEXT VAR t :: " ";
+ replace(t, 1, actual pos - last pos);
+ out (md p9 pos + t).
+
+ out nonblank cols:
+ t := " ";
+ replace (t,1, actual pos - last pos);
+ out(md p9 graf + t);
+ INT VAR k;
+ FOR k FROM last pos UPTO actual pos - 1 REP
+ INT VAR word :: md p9 map [(k DIV md p9 x per ds) + 1][j]
+ [(k MOD md p9 x per ds) + 1],
+ first byte :: word;
+ rotate (word, 8);
+ out (code (word));
+ out (code (first byte));
+ out (""0"")
+ PER.
+
+ actual col is blank:
+ md p9 map [(actual pos DIV md p9 x per ds) + 1][j]
+ [(actual pos MOD md p9 x per ds) + 1] = 0
+
+END PROC md p9 put map;
+
+PROC clear:
+ md p9 clear
+END PROC clear;
+
+PROC md p9 clear:
+ create initline;
+ initialize all lines.
+
+ create initline:
+ MDPYLINE VAR initline;
+ INT VAR i;
+ FOR i FROM 1 UPTO md p9 x per ds REP
+ initline[i] := 0
+ PER.
+
+ initialize all lines:
+ INT VAR k;
+ FOR i FROM 1 UPTO md p9 x lines REP
+ FOR k FROM 1 UPTO md p9 y lines REP
+ md p9 map[i][k] := initline
+ PER
+ PER
+END PROC md p9 clear;
+
+PROC home:
+ move to (0,0)
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ md p9 x pos := x;
+ md p9 y pos := y
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ printer line (md p9 x pos,md p9 y max - md p9 y pos,
+ x, md p9 y max - y,
+ PROC (INT CONST, INT CONST) md p9 set pixel);
+ md p9 x pos := x;
+ md p9 y pos := y
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ md p9 set pixel (x, md p9 y max - x)
+END PROC setpixel;
+
+PROC md p9 set pixel (INT CONST x,y):
+ setbit (md p9 map [(x DIV md p9 x per ds) + 1][(y DIV 16) + 1]
+ [(x MOD md p9 x per ds) + 1],15 - (y AND 15))
+END PROC md p9 set pixel;
+
+BOOL PROC md p9 is pixel (INT CONST x,y):
+ bit (md p9 map [(x DIV md p9 x per ds) + 1][(y DIV 16) + 1]
+ [(x MOD md p9 x per ds) + 1],15 - (y AND 15))
+END PROC md p9 is pixel;
+
+PROC foreground (INT VAR type):
+ type := 1
+END PROC foreground;
+
+PROC background (INT VAR type):
+ type := 0
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ std circle (x,y,rad,from,to)
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1, y1, x2, y2, pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+ printer fill (x,x,md p9 y max - y,1,
+ BOOL PROC (INT CONST, INT CONST) md p9 is pixel,
+ PROC (INT CONST, INT CONST) md p9 set pixel)
+END PROC fill;
+
+
diff --git a/app/mpg/2.2/src/PUBLIC.insert b/app/mpg/2.2/src/PUBLIC.insert
new file mode 100644
index 0000000..9fb98a6
--- /dev/null
+++ b/app/mpg/2.2/src/PUBLIC.insert
@@ -0,0 +1,3412 @@
+(* Rainer Kottmann *)
+(* Klaus Bovermann *)
+(* Lutz Prechelt *)
+(* Carsten Weinholz *)
+(* 19.06.87 *)
+
+(* Pakete : 1. mpg test elan programs
+ 2. mpg archive system <--- **************************
+ 3. mpg some <--- Sind für seperaten Hamster
+ 4. mpg dm <--- notwendig.
+ 5. mpg tools <--- **************************
+ 6. mpg target handling
+ 7. mpg print cmd
+ 8. edit monitor
+ 9. mpg global manager *)
+
+(************************* ELAN TEST ****************************)
+
+PACKET mpg test elan programs DEFINES elan test :
+
+LET scan end = 7,
+ in comment = 8,
+ in text = 9,
+ bold = 2,
+ char = 4,
+ delimiter = 6,
+ limit = 77,
+ max denoter length = 255,
+ end bolds = "ENDIFIENDSELECTENDREPEATPERENDPROCEDURENDPACKETENDOP",
+ w = "WARNING: ",
+ e = "ERROR : ";
+
+INT VAR zeile;
+FILE VAR err;
+TEXT VAR last error;
+
+
+PROC elan test :
+ elan test (last param)
+END PROC elan test;
+
+PROC elan test (TEXT CONST datei) :
+ INT VAR byte :: 0, kbyte :: 0, (* Byte/Kilobyte der EUMEL Datei *)
+ sbyte:: 0, skbyte:: 0, (* Byte/Kilobyte des Elan Quelltextes *)
+ denoter length :: 0, units :: 0, typ, scan operations :: 0,
+ round brackets :: 0, square brackets :: 0; (* Klammerzaehler *)
+ TEXT VAR in, symbol;
+ FILE VAR inputfile :: sequential file (input , datei);
+ err := note file;
+ zeile := 0;
+ last error := "";
+ scan (""); next symbol (in);
+ WHILE NOT eof (inputfile) REP
+ naechste zeile;
+ analyse;
+ in := incharety
+ UNTIL in <> "" PER;
+ IF in <> ""
+ THEN putline (err, "*** ELAN TEST VORZEITIG ABGEBROCHEN ***") FI;
+ last error := "";
+ ausgabe der enddaten;
+ modify (inputfile);
+ note edit (inputfile);
+ line.
+
+naechste zeile :
+ getline (inputfile , in);
+ continue scan (in);
+ byte INCR LENGTH in;
+ kbyte INCR byte DIV 1000;
+ byte := byte MOD 1000;
+ zeile INCR 1; cout (zeile);
+ IF LENGTH in > limit
+ THEN error (w + "line exceeding screen")
+ FI.
+
+analyse :
+ REPEAT
+ next symbol (symbol, typ);
+ scan operations INCR 1;
+ analysiere symbol
+ UNTIL typ >= scan end
+ PER;
+ IF typ = in comment
+ THEN error (w + "comment exceeding line")
+ FI;
+ IF typ = in text
+ THEN denoter length INCR LENGTH symbol;
+ IF denoter length > max denoter length
+ THEN error (e + "text denoter too long (" + text (denoter length) +
+ " characters)")
+ ELSE error (w + "text denoter exceeding source line")
+ FI
+ ELSE denoter length := 0
+ FI;
+ skbyte INCR sbyte DIV 1000;
+ sbyte := sbyte MOD 1000.
+
+analysiere symbol :
+ IF typ = scan end THEN test brackets
+ ELIF typ = delimiter THEN delimiters
+ ELIF typ = char
+ THEN denoter length INCR LENGTH symbol;
+ IF denoter length > max denoter length
+ THEN error (e + "text denoter too long (" + text (denoter length) +
+ " characters)")
+ FI
+ ELIF typ = bold CAND pos (endbolds, symbol) <> 0
+ THEN unitend
+ FI;
+ sbyte INCR LENGTH symbol.
+
+test brackets :
+ IF round brackets <> 0
+ THEN error (w + text (round brackets) + " ""("" open")
+ FI;
+ IF square brackets <> 0
+ THEN error (w + text (square brackets) + " ""["" open")
+ FI.
+
+delimiters :
+ IF symbol = ";" OR (symbol = "." AND is refinement)
+ THEN unitend
+ ELIF symbol = "(" THEN round brackets INCR 1
+ ELIF symbol = ")" THEN round brackets DECR 1
+ ELIF symbol = "[" THEN square brackets INCR 1
+ ELIF symbol = "]" THEN square brackets DECR 1
+ FI.
+
+unitend :
+ units INCR 1;
+ IF round brackets <> 0
+ THEN error (e + text (round brackets) + " ""("" open at end of unit");
+ round brackets := 0
+ FI;
+ IF square brackets <> 0
+ THEN error (e + text (square brackets) + " ""["" open at end of unit");
+ square brackets := 0
+ FI.
+
+is refinement : FALSE. (* vorlaeufig *)
+
+ausgabe der enddaten :
+ line (err);
+ putline (err, 77 * "=");
+ putline (err, "EUMEL - Datei : " + text (zeile) + " Zeilen , " +
+ bytes (kbyte, byte));
+ putline (err, "Elan - Quelltext : " + text (units) + " Units , " +
+ bytes (skbyte, sbyte));
+ putline (err, text (scan operations) +
+ " Scanner - Operationen durchgefuehrt.");
+ putline (err, 77 * "=").
+END PROC elan test;
+
+PROC error (TEXT CONST error message) :
+ IF error message = last error
+ THEN putline (err, "dito " + text (zeile));
+ IF online THEN put (zeile); putline ("dito") FI;
+ LEAVE error FI;
+ last error := error message;
+ putline (err, "EOLN " + text (zeile) + " " + error message);
+ IF online THEN put (zeile); putline (error message) FI
+END PROC error;
+
+TEXT PROC bytes (INT CONST kilobytes, bytes) :
+ TEXT VAR t :: text (kilobytes);
+ IF bytes < 10 THEN t CAT "00"
+ ELIF bytes < 100 THEN t CAT "0"
+ FI;
+ t CAT text (bytes);
+ t CAT " Byte";
+ t
+END PROC bytes
+
+END PACKET mpg test elan programs;
+
+(************************* ARCHIV **********************************)
+
+PACKET mpg archive system DEFINES reserve, archive, release,
+ archiv, archiv name,archiv error,
+ archiv angemeldet,
+ from, to,
+ pla :
+
+
+LET archive 0 code = 90,
+ archive 1 code = 91,
+ altos archive 0 = 0,
+ altos archive 1 = 1,
+ bicos archive 0 = 2,
+ altos station = 1,
+ free code = 20,
+ reserve code = 19,
+ type = "#type (""micron"")#",
+ configurator = "configurator";
+
+BOOL VAR angemeldet;
+TEXT VAR err :: "";
+
+(************************ Standard - Prozeduren ****************************)
+(* Erlaubt jedoch nur eine ARCHIVE-Task *)
+
+PROC reserve (TASK CONST task):
+ reserve ("", task)
+END PROC reserve;
+
+PROC reserve (TEXT CONST msg, TASK CONST task):
+ IF task = archive
+ THEN angemeldet := TRUE
+ FI;
+ call (reserve code, msg, task)
+END PROC reserve;
+
+PROC archive (TEXT CONST name):
+ reserve (name, archive)
+END PROC archive;
+
+PROC archive (TEXT CONST name, INT CONST station):
+ reserve (name,station/archive)
+END PROC archive;
+
+PROC archive (TEXT CONST name, TASK CONST task):
+ reserve (name, task)
+END PROC archive;
+
+PROC release (TASK CONST task):
+ call (free code, "", task);
+ IF task = archive
+ THEN angemeldet := FALSE
+ FI
+END PROC release;
+
+PROC release :
+ release (archive);
+END PROC release;
+
+PROC archiv (INT CONST nr):
+ SELECT nr OF
+ CASE altos archive 0, altos archive 1: altos anmelden
+ CASE bicos archive 0 : archiv
+ OTHERWISE unbekannte laufwerksnummer
+ END SELECT.
+
+ altos anmelden:
+ IF station (myself) <> altos station
+ THEN unbekannte laufwerksnummer
+ ELSE reserve (archive);
+ SELECT nr OF
+ CASE altos archive 0: call (archive 0 code, "",task(configurator))
+ CASE altos archive 1: call (archive 1 code, "",task(configurator))
+ END SELECT;
+ archiv
+ FI.
+
+ unbekannte laufwerksnummer:
+ errorstop ("Unbekannte Laufwerksnummer")
+END PROC archiv;
+
+PROC archiv :
+ angemeldet := TRUE;
+ TEXT CONST name :: archiv name;
+ IF err = ""
+ THEN display ("Gefundenes Archiv: """ + name + """");
+ ELSE errorstop (err)
+ FI;
+ display (""13""10"").
+
+END PROC archiv;
+
+BOOL PROC archiv angemeldet:
+ angemeldet
+END PROC archiv angemeldet;
+
+TEXT PROC archiv name:
+ TEXT VAR name :: "";
+ THESAURUS VAR th;
+ IF NOT angemeldet
+ THEN errorstop ("Archiv nicht angemeldet");""
+ ELSE angemeldet := FALSE;
+ err := "";
+ disable stop;
+ archive ("");
+ IF is error
+ THEN err := errormessage;
+ LEAVE archiv name WITH ""
+ FI;
+ th := ALL archive;
+ richtigen namen suchen;
+ clear error;
+ enable stop;
+ archive (name);
+ angemeldet := TRUE;
+ name
+ FI.
+
+richtigen namen suchen:
+ IF subtext (error message, 1, 13) = "Archiv heisst"
+ THEN name := subtext (error message, 16, LENGTH error message - 1)
+ ELSE err := error message
+ FI
+END PROC archiv name;
+
+TEXT PROC archiv error:
+ err
+END PROC archiv error;
+
+PROC from (TEXT CONST name) :
+ fetch (name, archive)
+END PROC from;
+
+PROC to (TEXT CONST name) :
+ BOOL CONST cd :: command dialogue;
+ command dialogue (FALSE);
+ save (name, archive);
+ command dialogue (cd)
+END PROC to;
+
+PROC to :
+ to (last param)
+END PROC to;
+
+PROC from (THESAURUS CONST nameset):
+ fetch (nameset, archive)
+END PROC from;
+
+PROC to (THESAURUS CONST nameset):
+ BOOL CONST cd :: command dialogue;
+ command dialogue (FALSE);
+ save (nameset, archive);
+ command dialogue (cd)
+END PROC to;
+
+PROC pla:
+ LET dummy name pos = 18;
+
+ FILE VAR listfile;
+ INT VAR i;
+ TEXT CONST head :: 70 * "=",
+ end :: 70 * "_";
+ TEXT VAR record;
+ WHILE yes ("Archiv eingelegt") REP
+ print archive listing
+ PER;
+ release.
+
+print archive listing:
+ archiv;
+ listfile := sequential file (output , "PLA");
+ list (listfile, archive);
+ print head;
+ erase dummy names;
+ print bottom;
+ print and erase listing.
+
+print head :
+ modify (listfile);
+ to line (listfile, 1);
+ FOR i FROM 1 UPTO 6 REP
+ insert record (listfile)
+ PER;
+ to line (listfile, 1);
+ write record (listfile, type); down (listfile);
+ write record (listfile, head); down (listfile);
+ write record (listfile, "ARCHIVNAME: "+headline (listfile) + " " +
+ time of day +" " + date ); down (listfile);
+ write record (listfile, head); down (listfile);
+ write record (listfile, " "); down (listfile);
+ write record (listfile, "Date Store Contents").
+
+erase dummy names :
+ to line (listfile, 6);
+ WHILE NOT eof (listfile) REP
+ read record (listfile, record);
+ IF (record SUB dummy name pos) = "-"
+ THEN delete record (listfile)
+ ELSE down (listfile)
+ FI
+ PER.
+
+print bottom :
+ output (listfile);
+ putline (listfile, end).
+
+print and erase listing :
+ modify (listfile);
+ edit (listfile);
+ line (3);
+ IF yes ("Archivlisting drucken")
+ THEN print ("PLA")
+ FI;
+ forget ("PLA", quiet)
+END PROC pla
+
+END PACKET mpg archive system;
+
+(************************ MPG SOME TOOLS *********************)
+
+PACKET mpg some (*************************)
+ (* Klaus Bovermann *)
+ (* Andreas Dieckmann *)
+ (* Thomas Clermont *)
+ (* Version 3.2 *)
+ (* EUMEL 1.8.1 *)
+ (* Datum: 21.10.87 *)
+ (*************************)
+
+DEFINES some, SOME, (* in mehreren Versionen *)
+ one, (* in mehreren Versionen *)
+ inchar, (* *)
+ center, (* Hilfsroutinen *)
+ invers , (* *)
+ edit some, (* fuer Anfaenger *)
+ edit one, (* fuer Anfaenger *)
+
+ reorganize: (* auf Thesaurus *)
+
+LET max bild laenge = 80;
+
+TEXT PROC center (TEXT CONST n):
+ center (n," ",max bild laenge - 1)
+END PROC center;
+
+TEXT PROC center (TEXT CONST n,fuell zeichen,INT CONST max text laenge):
+ TEXT VAR fuell text ::
+ ((max text laenge - length (n)) DIV 2) * fuell zeichen;
+ fuelltext CAT (n + fuelltext);
+ IF (LENGTH fuelltext) - max text laenge = 0
+ THEN fuelltext
+ ELSE fuelltext + fuellzeichen
+ FI
+END PROC center;
+
+TEXT PROC invers (TEXT CONST n):
+ mark ein + n + " " + mark aus
+END PROC invers;
+
+PROC inchar (TEXT VAR t, TEXT CONST allowed chars):
+ enable stop;
+ REP getchar (t); (* Auslesen nur aus virtuellem Puffer *)
+ IF pos (allowed chars,t) = 0
+ THEN out (""7"")
+ FI
+ UNTIL pos (allowed chars,t) <> 0 PER
+END PROC inchar;
+
+(*********************************************************************)
+
+LET min zeilen = 3,
+ bildschirm = 24,
+ min x size = 30,
+ max entries = 200;
+
+LET trennzeichen = ""222"", (* ESC # *)
+ zeichenstring = ""1""27""3""10""13"x"12"o?"11"",
+ oben unten rubout o return x = ""3""10""12"o"13"x",
+ q eins neun a return x rubout o s = "q19a"13"x"12"os";
+
+LET mark ein = ""15"",
+ mark aus = ""14"";
+
+LET stdtext1 = "Auswahl einer Datei ",
+ stdtext2 = "Auswahl mehrerer Dateien ",
+ stdhelp = "( Bei Unklarheiten bitte <?> )";
+
+LET hop = 1,
+ esc = 2,
+ obe = 3,
+ unt = 4,
+ ank = 5,
+ ank 1 = 6,
+ aus = 7,
+ aus 1 = 8,
+ fra = 9,
+ ins = 10;
+
+LET filetype = 1003;
+
+INT VAR anzahl, begin x,begin y,
+ kopf zeilen , size x,size y,
+ max eintraege,
+ realc,
+ virtc;
+
+TEXT VAR string,
+ weitertext,
+ niltext,
+ kopfzeilen text,
+ kz1,
+ kz2;
+
+BOOL VAR raender,
+ auswahlende,
+ abbruch;
+
+ROW max entries TEXT VAR eintrag;
+
+THESAURUS VAR gesamt liste;
+FILE VAR tools info;
+DATASPACE VAR tools info ds;
+
+INITFLAG VAR init tools info;
+
+(******************* Grundlegende Prozedur *************************)
+
+THESAURUS PROC einzelne (THESAURUS CONST t, BOOL CONST viele,
+ TEXT CONST k1,
+ INT CONST x begin,y begin,
+ x size ,y size):
+ begin x := x begin;
+ begin y := y begin;
+ size x := x size;
+ size y := y size;
+ kz1 := k1;
+ string := "";
+ raender := FALSE;
+ gen kopf zeilen;
+ IF groesster editor > 0
+ THEN INT VAR x,y;
+ get edit cursor (x,y) ;
+ IF bildschirm - kopfzeilen - min zeilen + 1 < y
+ THEN begin y := 1;
+ size y := 24;
+ begin x := 1;
+ size x := 79
+ ELSE begin y := y;
+ size y := bildschirm - y + 1;
+ max eintraege := size y - min zeilen - kopfzeilen;
+ IF (80 - x) < min x size OR col = 1
+ THEN begin x := 1;
+ size x := 79
+ ELSE raender := TRUE;
+ begin x := x;
+ size x := 80 - x - 2
+ FI
+ FI;
+ gen kopfzeilen
+ FI;
+ IF (size y - kopf zeilen) < min zeilen OR
+ begin y < 0 OR
+ (begin y + size y - 1) > bildschirm OR
+ (begin x + size x - 1) > 79
+ THEN errorstop ("Fenster zu klein")
+ FI;
+ init weitertext;
+ init niltext;
+ THESAURUS VAR ausgabe :: empty thesaurus;
+ gesamt liste := t;
+ INT VAR i;
+ anzahl := 0;
+ FOR i FROM 1 UPTO highest entry (t) REP
+ IF name (t,i) <> ""
+ THEN anzahl INCR 1;
+ eintrag [anzahl] := name (t,i)
+ FI
+ PER;
+ IF anzahl = 0 THEN LEAVE einzelne WITH ausgabe FI;
+ bild aufbauen;
+ abbruch := FALSE;
+ kreuze an (viele);
+ IF abbruch
+ THEN LEAVE einzelne WITH ausgabe
+ FI;
+ cursor (begin x,begin y + size y - 1);
+ out (niltext); (* Folgende Ausgaben werden sonst unleserlich *)
+ ausgabe erzeugen;
+ ausgabe.
+
+ausgabe erzeugen:
+ TEXT VAR nam;
+ WHILE string <> "" REP
+ nam := subtext (string,1,3);
+ string := subtext (string,5);
+ insert (ausgabe, eintrag [int (nam)])
+ PER
+END PROC einzelne;
+
+PROC realcursor setzen:
+ cursor (begin x,kopf zeilen + realc + begin y);
+ IF raender
+ THEN out ("|")
+ FI;
+ out (marke (virtc, TRUE) + 6 * ""8"")
+END PROC real cursor setzen;
+
+TEXT PROC marke (INT CONST zeiger, BOOL CONST mit cursor):
+ INT VAR pl :: nr (zeiger);
+ IF pl = 0
+ THEN leer
+ ELSE mit zahl
+ FI.
+
+mit zahl:
+ IF mit cursor
+ THEN (3-length(text(pl))) * "-" + text (pl) + "-> "
+ ELSE text (pl,3) + " > "
+ FI.
+
+leer:
+ IF mit cursor
+ THEN "----> "
+ ELSE 6 * " "
+ FI
+END PROC marke;
+
+PROC init weitertext:
+ weitertext := "----> " + mark ein + "weitere Eintraege " + mark aus
+ + ((size x - 27) * "-")
+END PROC init weitertext;
+
+PROC init niltext:
+ IF size x > 78
+ THEN niltext := ""5""
+ ELSE IF raender
+ THEN niltext := ((size x + 2) * " " + (size x + 2) * ""8"")
+ ELSE niltext := (size x * " " + size x * ""8"")
+ FI
+ FI
+END PROC init niltext;
+
+PROC bild (INT CONST anfang):
+ INT VAR i;
+ gib oberlinie aus;
+ FOR i FROM anfang UPTO grenze REP
+ cursor (begin x,kopfzeilen + begin y + i - anfang + 1);
+ rand;
+ out (marke (i, FALSE));
+ IF LENGTH ("""" + eintrag [i] + """") <= (size x - 6)
+ THEN out (text ("""" + eintrag [i] + """",size x - 6))
+ ELSE out (text ("""" + eintrag [i],size x - 10) + " ...")
+ FI;
+ rand
+ PER;
+ gib unterlinie aus;
+ IF grenze < (anfang + max eintraege)
+ THEN FOR i FROM 0 UPTO (anfang + max eintraege - anzahl - 1) REP
+ cursor (begin x,begin y + kopfzeilen + i +
+ grenze - anfang + min zeilen);
+ out (niltext)
+ PER
+ FI.
+
+gib oberlinie aus:
+ cursor (begin x,kopfzeilen + begin y);
+ rand;
+ IF realc = virtc
+ THEN out (size x * "-")
+ ELSE out (weitertext)
+ FI;
+ rand.
+
+gib unterlinie aus:
+ cursor (begin x,begin y + grenze - anfang + kopfzeilen + min zeilen - 1);
+ rand;
+ IF anzahl <= (anfang + max eintraege)
+ THEN out (size x * "-")
+ ELSE out (weitertext)
+ FI;
+ rand.
+
+grenze:
+ min (anzahl,anfang + max eintraege).
+
+END PROC bild;
+
+PROC gen kopfzeilen:
+ kopfzeilen := 0;
+ kopfzeilen text := "";
+ kopfzeilen text CAT code (0);
+ IF pos (kz1,trenn zeichen) > 0
+ THEN analysiere kopfzeile
+ ELIF kz1 <> "" AND length (kz1) <= size x
+ THEN kopfzeilen text := kz1 + code (1);
+ kopf zeilen := 1
+ ELIF kz1 <> ""
+ THEN analysiere kopfzeile
+ FI;
+ IF kopfzeilen > size y - min zeilen
+ THEN kopfzeilen := size y - min zeilen
+ FI;
+ max eintraege := size y - kopfzeilen - min zeilen.
+
+analysiere kopfzeile:
+ kz2 := compress (kz1);
+ BOOL VAR mark is on :: FALSE;
+ TEXT VAR einschub;
+ REP kopf zeilen INCR 1;
+ kontrolliere pos;
+ einschub := subtext(kz2,1,pos (kz2,trennzeichen)-1);
+ kontrolliere auf markiert;
+ kopfzeilen text CAT einschub;
+ kopfzeilen text CAT code (kopf zeilen);
+ kz2 := compress (subtext(kz2,pos (kz2,trennzeichen) + 1));
+ UNTIL NOT (length (kz2) > size x OR pos (kz2,trennzeichen) > 0 )PER;
+ IF kz2 <> ""
+ THEN einschub := kz2;
+ kontrolliere auf markiert;
+ kopfzeilen text CAT einschub;
+ kopf zeilen INCR 1
+ FI;
+ kopfzeilentext CAT code (kopfzeilen).
+
+muss noch getrennt werden:
+ (pos (kz2,trennzeichen) > size x OR pos (kz2,trennzeichen) = 0)
+ AND length (kz2) > size x.
+
+kontrolliere pos:
+ IF muss noch getrennt werden
+ THEN trenne kopfzeile
+ FI.
+
+trenne kopfzeile:
+ INT VAR i;
+ FOR i FROM size x DOWNTO (size x DIV 2) REP
+ UNTIL (kz2 SUB i) = " " PER;
+ kz2 := subtext (kz2,1,i) + trennzeichen + subtext (kz2,i+1).
+
+kontrolliere auf markiert:
+ IF mark is on
+ THEN kopfzeilen text CAT mark ein;
+ IF pos (einschub,mark aus) > 0 AND pos (einschub,mark ein) = 0
+ THEN mark is on := FALSE
+ FI
+ ELSE IF pos (einschub,mark ein) > 0
+ THEN IF pos (einschub,mark aus) = 0
+ THEN einschub CAT mark aus;
+ mark is on := TRUE
+ FI
+ FI
+ FI.
+
+END PROC gen kopfzeilen;
+
+PROC zeige kopfzeilen:
+ INT VAR i;
+ FOR i FROM 1 UPTO kopfzeilen REP
+ cursor (begin x,begin y + i - 1);
+ rand;
+ out (niltext);
+ out (center (subtext (kopfzeilen text,pre code + 1,post code - 1)
+ ," ",size x));
+ rand
+ PER.
+
+ post code:
+ pos (kopfzeilen text,code (i)).
+
+ pre code:
+ pos (kopfzeilen text,code (i - 1)).
+
+END PROC zeige kopfzeilen;
+
+PROC bild aufbauen:
+ zeige kopfzeilen;
+ virtc := 1;
+ realc := 1;
+ bild (1);
+ realcursor setzen
+END PROC bild aufbauen;
+
+PROC kreuze an (BOOL CONST viele):
+ auswahlende := FALSE;
+ REP zeichen lesen;
+ zeichen interpretieren
+ UNTIL auswahlende
+ PER.
+
+zeichen lesen:
+ TEXT VAR zeichen;
+ inchar (zeichen, zeichenstring).
+
+zeichen interpretieren:
+ SELECT pos (zeichenstring, zeichen) OF
+ CASE hop : hoppen (viele)
+ CASE esc : esc kommandos (viele)
+ CASE obe : nach oben
+ CASE unt : nach unten
+ CASE ank : ankreuzen (viele,FALSE); evtl aufhoeren
+ CASE ank 1 : ankreuzen (viele,TRUE ); evtl aufhoeren
+ CASE aus : auskreuzen
+ CASE aus 1 : auskreuzen
+ CASE fra : info (viele)
+ CASE ins : eintrag einfuegen;
+ IF string <> ""
+ THEN evtl aufhoeren
+ FI
+ END SELECT.
+
+evtl aufhoeren:
+ IF NOT viele
+ THEN LEAVE kreuze an
+ FI
+END PROC kreuze an;
+
+PROC hoppen (BOOL CONST viele):
+ zweites zeichen lesen;
+ zeichen interpretieren.
+
+zweites zeichen lesen:
+ TEXT VAR zz;
+ getchar (zz).
+
+zeichen interpretieren:
+ SELECT pos (oben unten rubout o return x , zz) OF
+ CASE 0 : out (""7"")
+ CASE 1 : hop nach oben
+ CASE 2 : hop nach unten
+ CASE 3,4 : alles loeschen
+ CASE 5 : bild nach oben
+ CASE 6 : IF viele THEN rest ankreuzen ELSE out (""7"") FI
+ END SELECT.
+
+bild nach oben:
+ realc := 1;
+ bild (virtc);
+ realcursor setzen.
+
+rest ankreuzen:
+ INT VAR i;
+ FOR i FROM 1 UPTO anzahl REP
+ IF nr (i) = 0
+ THEN string CAT textstr (i)
+ FI
+ PER;
+ bild aktualisieren;
+ realcursor setzen.
+
+alles loeschen:
+ string := "";
+ bild aktualisieren;
+ realcursor setzen.
+
+hop nach oben:
+ IF ganz oben
+ THEN out (""7"")
+ ELIF oben auf der seite
+ THEN raufblaettern
+ ELSE top of page
+ FI.
+
+ganz oben:
+ virtc = 1.
+
+oben auf der seite:
+ realc = 1.
+
+raufblaettern:
+ virtc DECR (max eintraege + 1);
+ virtc := max (virtc, 1);
+ bild (virtc);
+ realcursor setzen.
+
+top of page:
+ loesche marke;
+ virtc DECR (realc - 1);
+ realc := 1;
+ realcursor setzen.
+
+hop nach unten:
+ IF ganz unten
+ THEN out (""7"")
+ ELIF unten auf der seite
+ THEN runterblaettern
+ ELSE bottom of page
+ FI.
+
+ganz unten:
+ virtc = anzahl.
+
+unten auf der seite:
+ realc > maxeintraege .
+
+runterblaettern:
+ INT VAR alter virtc :: virtc;
+ virtc INCR (max eintraege + 1);
+ virtc := min (virtc, anzahl);
+ realc := virtc - alter virtc;
+ bild (alter virtc + 1);
+ realcursor setzen.
+
+bottom of page:
+ loesche marke;
+ alter virtc := virtc;
+ virtc INCR (max eintraege + 1 - realc);
+ virtc := min (anzahl, virtc);
+ realc INCR (virtc - alter virtc);
+ realcursor setzen
+END PROC hoppen;
+
+PROC esc kommandos (BOOL CONST viele):
+ TEXT VAR zz;
+ getchar (zz);
+ SELECT pos(q eins neun a return x rubout o s, zz) OF
+ CASE 0 : out (""7"")
+ CASE 1 : auswahlende := TRUE
+ CASE 2 : zeige anfang
+ CASE 3 : zeige ende
+ CASE 4 : abbruch := TRUE; auswahlende := TRUE
+ CASE 5,6 : IF viele
+ THEN ankreuzen bis ende
+ ELSE out (""7"")
+ FI
+ CASE 7,8 : IF viele
+ THEN loeschen bis ende
+ ELSE out (""7"")
+ FI
+ CASE 9 : liste nach nummern ordnen
+ END SELECT.
+
+liste nach nummern ordnen :
+ THESAURUS VAR dummy thesaurus :: empty thesaurus;
+ TEXT VAR nam,dummy string :: "";
+ cursor (begin x,begin y + screen ende + kopfzeilen + minzeilen - 1);
+ rand;
+ out (center(invers("Bitte warten !"),"-",size x));
+ rand;
+ i := 0;
+ WHILE string <> "" REP
+ i INCR 1;
+ nam := subtext (string,1,3);
+ string := subtext (string,5);
+ insert (dummy thesaurus, eintrag [int (nam)]);
+ dummy string CAT textstr (i)
+ PER;
+ anzahl := 0;
+ string := dummy string;
+ gesamt liste := dummy thesaurus + gesamt liste;
+ FOR i FROM 1 UPTO highest entry (gesamt liste) REP
+ IF name (gesamt liste,i) <> ""
+ THEN anzahl INCR 1;
+ eintrag [anzahl] := name (gesamt liste,i)
+ FI
+ PER;
+ bild aufbauen.
+
+loeschen bis ende:
+ INT VAR j;
+ FOR j FROM virtc UPTO anzahl REP
+ INT VAR posi :: nr (j);
+ IF posi <> 0
+ THEN rausschmeissen
+ FI
+ PER;
+ bild aktualisieren;
+ realcursor setzen.
+
+rausschmeissen:
+ string := subtext (string,1, 4*posi-4) + subtext (string,4*posi+1).
+
+ankreuzen bis ende:
+ INT VAR i;
+ FOR i FROM virtc UPTO anzahl REP
+ IF nr (i) = 0
+ THEN string CAT textstr (i)
+ FI
+ PER;
+ bild aktualisieren;
+ realcursor setzen.
+
+zeige anfang:
+ IF virtc = 1
+ THEN out (""7"")
+ ELIF virtc = realc
+ THEN loesche marke;
+ virtc := 1;
+ realc := 1;
+ realcursor setzen
+ ELSE virtc := 1;
+ realc := 1;
+ bild (1);
+ realcursor setzen
+ FI.
+
+zeige ende:
+ IF virtc = anzahl
+ THEN out (""7"")
+ ELIF ende auf screen
+ THEN loesche marke;
+ realc INCR (anzahl - virtc);
+ virtc := anzahl;
+ realcursor setzen
+ ELSE virtc := anzahl;
+ realc := max eintraege + 1;
+ bild (anzahl - maxeintraege);
+ realcursor setzen
+ FI.
+
+ende auf screen:
+ (realc + anzahl - virtc) < maxeintraege + 1.
+
+screen ende:
+ min (realc + anzahl - virtc - 1,max eintraege).
+
+END PROC esc kommandos;
+
+PROC ankreuzen (BOOL CONST viele,xo):
+ INT VAR pl :: nr (virtc);
+ IF pl <> 0
+ THEN out (""7"");
+ cursor setzen;
+ LEAVE ankreuzen
+ FI;
+ string CAT textstr (virtc);
+ IF viele
+ THEN cursor setzen
+ FI.
+
+ cursor setzen:
+ IF xo
+ THEN realcursor setzen
+ ELSE IF virtc < anzahl
+ THEN nach unten
+ FI;
+ IF virtc = anzahl
+ THEN realcursor setzen
+ FI
+ FI
+END PROC ankreuzen;
+
+PROC auskreuzen :
+ INT VAR posi :: nr (virtc);
+ IF posi = 0
+ THEN out (""7""); LEAVE auskreuzen
+ FI;
+ rausschmeissen;
+ loesche marke;
+ bild aktualisieren;
+ realcursor setzen.
+
+rausschmeissen:
+ string := subtext (string,1, 4*posi-4) + subtext (string,4*posi+1)
+END PROC auskreuzen;
+
+PROC eintrag einfuegen :
+ IF anzahl = max entries
+ THEN out (""7"");
+ LEAVE eintrag einfuegen
+ FI;
+ mache platz frei;
+ trage ein;
+ baue richtiges bild auf.
+
+mache platz frei:
+ INT VAR i;
+ FOR i FROM anzahl DOWNTO virtc REP
+ eintrag [i+1] := eintrag [i]
+ PER;
+ eintrag [virtc] := """";
+ ruecke kreuze einen weiter;
+ anzahl INCR 1;
+ string CAT textstr (virtc);
+ baue richtiges bild auf.
+
+trage ein:
+ TEXT VAR exit char;
+ realcursor setzen;
+ out (marke (virtc,TRUE));
+ out ("""");
+ push (""11"");
+ editget (ein,max text length,size x - 7,"","",exit char);
+ IF (ein SUB length (ein)) = """"
+ THEN ein := subtext (ein,1,length (ein) - 1)
+ FI;
+ IF ein = ""
+ THEN auskreuzen;
+ setze eintraege zurueck
+ ELSE realcursor setzen;
+ out (6 * ""2"" + text ("""" + ein + """",size x - 7))
+ FI.
+
+ein:
+ eintrag [virtc].
+
+setze eintraege zurueck:
+ FOR i FROM virtc UPTO anzahl-1 REP
+ eintrag [i] := eintrag [i+1];
+ change (string,textstr (i+1),textstr (i))
+ PER;
+ anzahl DECR 1.
+
+ruecke kreuze einen weiter:
+ FOR i FROM anzahl DOWNTO virtc REP
+ change (string,textstr (i),textstr (i+1))
+ PER.
+
+baue richtiges bild auf:
+ bild (virtc - (realc - 1));
+ realcursor setzen
+END PROC eintrag einfuegen;
+
+PROC bild aktualisieren:
+ INT VAR ob, un, i;
+ ob := virtc - (realc - 1);
+ un := min (ob + max eintraege, anzahl);
+ FOR i FROM ob UPTO un REP
+ cursor (begin x,kopfzeilen + begin y + i - ob + 1);
+ rand;
+ out (marke (i, FALSE))
+ PER
+END PROC bild aktualisieren;
+
+PROC nach oben:
+ IF noch nicht oben (* virtuell *)
+ THEN gehe nach oben
+ ELSE out (""7"")
+ FI.
+
+noch nicht oben:
+ virtc > 1.
+
+gehe nach oben:
+ IF realc = 1
+ THEN scroll down
+ ELSE cursor up
+ FI.
+
+scroll down:
+ virtc DECR 1;
+ bild (virtc);
+ realcursor setzen.
+
+cursor up:
+ loesche marke;
+ virtc DECR 1;
+ realc DECR 1;
+ realcursor setzen
+END PROC nach oben;
+
+PROC nach unten:
+ IF noch nicht unten (* virtuell *)
+ THEN gehe nach unten
+ ELSE out (""7"")
+ FI.
+
+noch nicht unten:
+ virtc < anzahl.
+
+gehe nach unten:
+ IF realc > maxeintraege
+ THEN scroll up
+ ELSE cursor down
+ FI.
+
+scroll up:
+ virtc INCR 1;
+ bild (virtc - maxeintraege);
+ realcursor setzen.
+
+cursor down:
+ loesche marke;
+ virtc INCR 1;
+ realc INCR 1;
+ realcursor setzen
+END PROC nach unten;
+
+PROC loesche marke:
+ cursor (begin x,kopf zeilen + realc + begin y);
+ rand;
+ out (marke (virtc, FALSE))
+END PROC loesche marke;
+
+TEXT PROC textstr (INT CONST nr):
+ text (nr,3) + "!"
+END PROC textstr;
+
+INT PROC nr (INT CONST zeiger):
+ IF pos (string, textstr (zeiger)) = 0
+ THEN 0
+ ELSE (pos (string,textstr (zeiger)) DIV 4) + 1
+ FI
+END PROC nr;
+
+PROC rand:
+ IF raender
+ THEN out ("|")
+ FI
+END PROC rand;
+
+PROC info (BOOL CONST mehrere moeglich):
+ IF NOT initialized (init tools info)
+ THEN initialisiere tools info
+ FI;
+ modify (tools info);
+ IF mehrere moeglich
+ THEN head line (tools info," INFO : Auswahl mehrerer Dateien ");
+ ELSE head line (tools info," INFO : Auswahl einer Datei ");
+ FI;
+ to line (tools info,1);
+ col (tools info,1);
+ IF raender
+ THEN open editor (groesster editor + 1,tools info,FALSE,
+ begin x,begin y,size x + 2,size y)
+ ELSE open editor (groesster editor + 1,tools info,FALSE,
+ begin x,begin y,size x,size y)
+ FI;
+ edit (groesster editor,"q19",PROC (TEXT CONST) std kommando interpreter);
+ zeige kopfzeilen;
+ bild (virtc - (realc - 1));
+ realcursor setzen
+END PROC info;
+
+(******************** Herausgereichte, abgeleitete Prozeduren ***********)
+
+THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile,
+ INT CONST start x,start y,x size,y size):
+ einzelne (t,TRUE,kopf zeile,start x,start y,x size,y size)
+END PROC some;
+
+THESAURUS PROC some (THESAURUS CONST t,
+ INT CONST start x,start y,x size,y size):
+ some (t,invers (std text 2 + std help),start x,start y,x size,y size)
+END PROC some;
+
+THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile,
+ INT CONST start y,ende y):
+ einzelne (t,TRUE,kopf zeile,1,start y,79,ende y - start y + 1)
+END PROC some;
+
+THESAURUS PROC some (THESAURUS CONST t,INT CONST start y,ende y):
+ some (t,invers(stdtext 2 + std help),1,start y,79,ende y - start y + 1)
+END PROC some;
+
+THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile):
+ some (t,kopf zeile,1,bildschirm)
+END PROC some;
+
+THESAURUS PROC some (THESAURUS CONST t):
+ some (t,invers(stdtext 2 + std help),1,bildschirm)
+END PROC some;
+
+THESAURUS PROC some:
+ some (all,invers(stdtext 2 + std help),1,bildschirm)
+END PROC some;
+
+THESAURUS PROC some (TEXT CONST te):
+ some (ALL te)
+END PROC some;
+
+THESAURUS PROC some (TASK CONST quelle):
+ some (ALL quelle)
+END PROC some;
+
+THESAURUS OP SOME (THESAURUS CONST th):
+ some (th)
+END OP SOME;
+
+THESAURUS OP SOME (TASK CONST ta):
+ some (ALL ta)
+END OP SOME;
+
+THESAURUS OP SOME (TEXT CONST te):
+ some (ALL te)
+END OP SOME;
+
+TEXT PROC one (THESAURUS CONST t,TEXT CONST kopf zeile,
+ INT CONST start x,start y,x size,y size):
+ name(einzelne (t,FALSE,kopf zeile,start x,start y,x size,y size),1)
+END PROC one;
+
+TEXT PROC one (THESAURUS CONST t,
+ INT CONST start x,start y,x size,y size):
+ one (t,invers (std text 1 + std help),start x,start y,x size,y size)
+END PROC one;
+
+TEXT PROC one (THESAURUS CONST t, TEXT CONST t1,
+ INT CONST start y,ende y):
+ name (einzelne (t,FALSE, t1,1,start y,79,ende y - start y + 1), 1)
+END PROC one;
+
+TEXT PROC one (THESAURUS CONST t,
+ INT CONST start y,ende y):
+ one (t,invers (std text 1+ std help),1,start y,79,ende y - start y + 1)
+END PROC one;
+
+TEXT PROC one (THESAURUS CONST t,TEXT CONST kopf zeile):
+ one (t,kopf zeile,1,bildschirm)
+END PROC one;
+
+TEXT PROC one (THESAURUS CONST t):
+ one (t,invers(stdtext 1 + std help),1,bildschirm)
+END PROC one;
+
+TEXT PROC one (TASK CONST quelle):
+ one (ALL quelle)
+END PROC one;
+
+TEXT PROC one:
+ one (all)
+END PROC one;
+
+TEXT PROC one (TEXT CONST te):
+ one (ALL te)
+END PROC one;
+
+PROC edit one :
+ TEXT CONST datei :: one (all,invers(stdtext 1 + "zum Editieren")
+ + trennzeichen + stdhelp,
+ 1,bildschirm);
+ IF datei <> "" CAND (NOT exists (datei)
+ COR type (old (datei)) = filetype)
+ THEN IF groesster editor > 0
+ THEN ueberschrift neu;
+ bild neu
+ FI;
+ edit (datei)
+ FI
+END PROC edit one;
+
+PROC edit some:
+ THESAURUS CONST tt :: some (all,invers(stdtext 2 + "zum Editieren")
+ + trennzeichen + stdhelp,
+ 1,bildschirm); INT VAR i;
+ FOR i FROM 1 UPTO highest entry (tt) REP
+ TEXT VAR datei :: name (tt,i);
+ IF datei <> "" CAND (NOT exists (datei)
+ COR type (old (datei)) = filetype)
+ THEN IF groesster editor > 0
+ THEN ueberschrift neu;
+ bild neu
+ FI;
+ edit (datei)
+ FI
+ PER
+END PROC edit some;
+
+PROC reorganize (THESAURUS CONST t):
+ page;
+ do (PROC (TEXT CONST) do reorganize,t)
+END PROC reorganize;
+
+PROC do reorganize (TEXT CONST name):
+ IF type (old(name)) = file type
+ THEN put ("Datei " + center (invers("""" + name + """")," ",30)
+ + " wird reorganisiert :");
+ FILE VAR file :: sequential file (modify,name);
+ IF segments (file) = 1
+ THEN put (lines (file))
+ ELSE reorganize (name)
+ FI
+ ELSE put (" " + center (invers("""" + name + """")," ",30)
+ + " ist keine Datei.")
+ FI;
+ line
+END PROC do reorganize ;
+
+PROC initialisiere tools info :
+ tools info ds := nilspace;
+ tools info := sequential file (output, tools info ds);
+ putline (tools info,""15" Mit den angekreuzten Namen wird die gewaehlte Operation ausgefuehrt "14"");
+ line (tools info);
+ putline (tools info," "15" Positionierungen: "14" ");
+ line (tools info);
+ putline (tools info," Oben : zum vorausgehenden Namen");
+ putline (tools info," Unten : zum folgenden Namen ");
+ putline (tools info," HOP Oben : zum ersten Namen der (vorigen) Seite");
+ putline (tools info," HOP Unten : zum letzten Namen der (vorigen) Seite");
+ putline (tools info," HOP RETURN : aktuelle Zeile wird erste Zeile");
+ putline (tools info," ESC 1 : zum ersten Namen der Liste");
+ putline (tools info," ESC 9 : zum letzten Namen der Liste");
+ putline (tools info," ESC s : Liste nach Nummern ordnen");
+ line (tools info);
+ putline (tools info," "15" Auswahl treffen: "14" ");
+ line (tools info);
+ putline (tools info," ( Folgende Befehle sind nur bei einer )");
+ putline (tools info," ( Auswahl von mehreren Namen Möglich. )");
+ line (tools info);
+ putline (tools info," RETURN bzw. x: diesen Namen ankreuzen ");
+ putline (tools info," RUBOUT bzw. o: Kreuz vor dem Namen loeschen");
+ putline (tools info," HOP x : alle Namen ankreuzen ");
+ putline (tools info," HOP o : alle Kreuze loeschen ");
+ putline (tools info," ESC x : alle folgenden Namen ankreuzen");
+ putline (tools info," ESC o : alle folgenden Kreuze loeschen");
+ putline (tools info," RUBIN : einen neuen Namen eintragen");
+ line (tools info);
+ putline (tools info," ( Nur dieser Befehl kann benutzt werden , wenn )");
+ putline (tools info," ( die Auswahl eines ! Namens möglich ist. )");
+ line (tools info);
+ putline (tools info," RETURN bzw. x: diesen Namen auswaehlen");
+ line (tools info);
+ putline (tools info," "15" Auswahl verlassen: "14"");
+ line (tools info);
+ putline (tools info," ESC q : Auswaehlen beenden ");
+ putline (tools info," ESC a : Auswahl abbrechen (ohne Kreuze !)");
+ line (tools info);
+ putline (tools info,""15" Zum Verlassen des Infos bitte 'ESC q' tippen! "14"");
+END PROC initialisiere tools info;
+
+END PACKET mpg some;
+
+(****************** DATEI MONITOR ********************************)
+
+PACKET mpg dm DEFINES dm: (* Klaus Bovermann *)
+ (* Andreas Dieckmann *)
+ (* Thomas Clermont *)
+ (* Version 2.1 *)
+ (* EUMEL 1.7.5 *)
+ (* Datum 06.05.87 *)
+LET mark ein = ""15"",
+ mark aus = ""14"",
+ trennzeichen = ""222"",
+ type = "#type (""micron"")#",
+ dummy name pos = 18,
+ disk zeichenfolge = "alnfiqushcvd",
+ mana zeichenfolge = "al qush v";
+
+TASK CONST std manager :: task ("PUBLIC");
+TASK VAR manager;
+
+BOOL VAR archive ist meins :: archiv angemeldet,
+ disk ,
+ diskette im schacht :: FALSE;
+
+TEXT VAR aktueller archivename,
+ manager name,
+ t1;
+
+PROC dm:
+ TEXT VAR zeichen, alte lernsequenz :: lernsequenz auf taste ("k");
+ REP aktion
+ UNTIL zeichen = "q" PER;
+ lernsequenz auf taste legen ("k",alte lernsequenz).
+
+aktion:
+ manager := std manager;
+ vormonitor;
+ IF zeichen <> "q" AND managername <> ""
+ THEN hauptmonitor
+ FI.
+
+zeige vormonitor:
+ managername := name (manager);
+ page;
+ write(27 * " "); write(mark ein);
+ write("V O R M O N I T O R "); write(mark aus);
+ line(4);
+ zeile ("t","Task einstellen, mit der kommuniziert werden soll");
+ zeile ("p","Es soll mit 'PUBLIC' kommuniziert werden");
+ zeile ("v","Es soll mit der Vatertask kommuniziert werden");
+ zeile ("a","Es soll mit dem Archiv kommuniziert werden");
+ zeile ("q","Programm beenden").
+
+vormonitor:
+ IF NOT eingabe von erlaubtem zeichen ("tvapq")
+ THEN zeige vormonitor
+ FI;
+ line;
+ write ("Bitte Eingabe : ");
+ inchar (zeichen, "tvapq");
+ out (zeichen); line;
+ IF pos ("a",zeichen) = 0 CAND manager = archive
+ THEN automatische freigabe des archives
+ FI;
+ ausfuehren der vorwahl.
+
+ausfuehren der vorwahl:
+ IF pos ("tvap", zeichen) <> 0
+ THEN neue task einstellen
+ FI.
+
+neue task einstellen:
+ managername := "";
+ IF zeichen = "a" THEN managername := "ARCHIVE"
+ ELIF zeichen = "p" THEN managername := "PUBLIC"
+ ELIF zeichen = "v" THEN managername := name (father)
+ ELSE namen holen
+ FI;
+ TEXT VAR mess;
+ BOOL VAR ok :: managername = "" COR
+ managername = "PUBLIC" COR
+ task ist kommunikativ (managername, mess);
+ IF NOT ok
+ THEN cursor (1,20); putline (""7""15"FEHLER: " + mess + ""14"");
+ pause;
+ managername := "";
+ FI;
+ IF managername = "" THEN manager := std manager
+ ELIF managername = "ARCHIVE" THEN manager := archive
+ ELSE manager := task (managername)
+ FI.
+
+namen holen:
+ REP
+ cursor (1,14);
+ put ("Neue Task:");
+ editget (managername); line;
+ IF managername = name (myself)
+ THEN putline ("Mit der eigenen Task kann nicht kommuniziert werden.")
+ FI;
+ UNTIL managername <> name (myself) PER;
+ lernsequenz auf taste legen ("k",managername).
+
+END PROC dm;
+
+BOOL PROC task ist kommunikativ (TEXT CONST taskname, TEXT VAR message):
+ disable stop;
+ TASK VAR t :: task (taskname);
+ IF is error
+ THEN message := errormessage;
+ clear error;
+ enable stop;
+ FALSE
+ ELSE task behandlung
+ FI.
+
+ task behandlung:
+ IF taskname <> "ARCHIVE"
+ THEN task kommunikation
+ ELSE archive behandlung
+ FI.
+
+ task kommunikation:
+ IF status (t) <> 2
+ THEN message := "Task ist nicht im Wartezustand";
+ enable stop;
+ FALSE
+ ELSE versuchen zuzugreifen
+ FI.
+
+ versuchen zuzugreifen:
+ INT CONST listcode :: 15;
+ DATASPACE VAR dummy :: nilspace;
+ call (listcode, "", dummy, t);
+ forget (dummy);
+ IF is error
+ THEN message := errormessage;
+ clear error;
+ enable stop;
+ FALSE
+ ELSE message := "";
+ enable stop;
+ TRUE
+ FI.
+
+ archive behandlung:
+ IF status (archive) <> 2
+ THEN message := "ARCHIVE ist nicht im Wartezustand";
+ LEAVE archive behandlung WITH FALSE
+ FI;
+ archive ("");
+ IF is error
+ THEN message := errormessage;
+ clear error;
+ enable stop;
+ FALSE
+ ELSE enable stop;
+ archive ist meins := TRUE;
+ diskette im schacht := FALSE;
+ message := "";
+ TRUE
+ FI
+END PROC task ist kommunikativ;
+
+PROC hauptmonitor:
+ disk := (manager = archive);
+ TEXT VAR zeichenfolge;
+ IF disk
+ THEN zeichenfolge := disk zeichenfolge
+ ELSE zeichenfolge := mana zeichenfolge
+ FI;
+ TEXT VAR taste;
+ INT VAR stelle;
+ diskette im schacht := FALSE;
+ IF disk
+ THEN reservieren des archives
+ FI;
+ disable stop;
+ REP
+ IF NOT eingabe von erlaubtem zeichen (zeichenfolge)
+ THEN zeige menue
+ FI;
+ line;
+ write ("Bitte Eingabe : ");
+ inchar (taste,zeichenfolge);
+ out (taste + " Bitte warten...");
+ stelle := pos (disk zeichenfolge, taste); (*!! ACHTUNG !!*)
+ IF stelle > 6
+ AND NOT diskette im schacht
+ AND disk
+ THEN line;
+ putline (" Erst Diskette einlegen !");pause (100)
+ ELIF taste <> " "
+ THEN menue auswerten (stelle)
+ FI;
+ IF is error
+ THEN IF disk
+ THEN melde archiveerror (errormessage)
+ ELSE melde error (errormessage)
+ FI;
+ clear error
+ FI
+ UNTIL taste = "q" PER;
+ IF archiv angemeldet
+ THEN automatische freigabe des archives
+ FI.
+
+ zeige menue:
+ page;
+ write(24 * " "); write(mark ein);
+ write("D A T E I M O N I T O R "); write(mark aus);
+ line(3);
+ zeile ("a","Auflisten aller Dateien in dieser Task");
+ zeile ("l","Loeschen von Dateien in dieser Task");
+ line(2);
+ write( 15 * " ");
+ IF disk
+ THEN write("Archiv: ")
+ ELSE write("Task : ")
+ FI;
+ IF disk
+ THEN IF diskette im schacht
+ THEN IF length(aktueller archivename) > 40
+ THEN write ("'" + subtext (aktueller archivename,1,40) + " ...")
+ ELSE write (invers(""""+ aktueller archivename + """"))
+ FI
+ FI
+ ELSE write (invers("""" + managername + """"))
+ FI;
+ line(2);
+ TEXT VAR zielname 1, zielname 2, zielname 3;
+ IF disk
+ THEN zielname 1 := "des Archivs";
+ zielname 2 := "zum Archiv";
+ zielname 3 := "vom Archiv"
+ ELSE zielname 1 := "in " + managername;
+ zielname 2 := "zu " + managername;
+ zielname 3 := "von " + managername
+ FI;
+ zeile ("u","Uebersicht ueber alle Dateien " + zielname 1);
+ zeile ("s","Senden von Dateien " + zielname 2);
+ zeile ("h","Holen von Dateien " + zielname 3);
+ IF disk
+ THEN zeile ("c","'Checken' von Dateien " + zielname 1)
+ FI;
+ zeile ("v","Vernichten von Dateien " + zielname 1);
+ IF disk THEN
+ zeile ("d","Drucken einer Liste der Dateien des Archivs");
+ zeile ("f","Formatieren einer Diskette");
+ zeile ("i","Initialisieren/vollstaendiges Loeschen des Archivs");
+ zeile ("n","Neue Diskette anmelden");
+ FI;
+ line(1);
+ zeile ("q","Zurueck zum Vormonitor").
+
+END PROC hauptmonitor;
+
+PROC menue auswerten (INT CONST stelle):
+ enable stop;
+ SELECT stelle OF
+ CASE 1 : auflisten der taskdateien
+ CASE 2 : loeschen von dateien in der task
+ CASE 3 : neue diskette anmelden
+ CASE 4 : formatieren einer diskette
+ CASE 5 : initialisieren des archives
+ CASE 6 : (* nichts *)
+ CASE 7 : auflisten der archivedateinamen
+ CASE 8 : schreiben von dateien aufs archive
+ CASE 9 : holen von dateien vom archive
+ CASE 10 : checken von dateien auf dem archive
+ CASE 11 : loeschen von dateien auf dem archive
+ CASE 12 : ausdruck archivelisting
+ END SELECT
+END PROC menue auswerten;
+
+BOOL PROC eingabe von erlaubtem zeichen (TEXT CONST erlaubte zeichen):
+ TEXT VAR char in;
+ char in := getcharety;
+ IF pos (erlaubte zeichen,char in) > 0 AND char in <> " "
+ THEN push (char in);TRUE
+ ELSE FALSE
+ FI.
+END PROC eingabe von erlaubtem zeichen;
+
+PROC zeile (TEXT CONST t,tt):
+ putline (8*" " + ""15"" + t + " "14"" + " ... " + tt)
+END PROC zeile;
+
+PROC formatieren einer diskette:
+ page;
+ putline ("Formatieren einer Diskette.");
+ putline ("===========================");
+ putline (""15"Achtung: Alle Disketten-Informationen werden gelöscht!"14"");
+ line;
+ putline ("Dies sind die moeglichen Formate:");
+ zeile ("o","... Ohne Format-Angabe");
+ zeile ("0","... Standard-Format");
+ zeile ("1","... 40 Spur - 360 KB");
+ zeile ("2","... 80 Spur - 720 KB");
+ zeile ("3","... IBM Std - 1200 KB");
+ zeile ("q","... Es wird nicht formatiert.");
+ TEXT VAR art;
+ put ("Ihre Wahl:");
+ inchar (art, "o01234q");
+ IF art = "q"
+ THEN LEAVE formatieren einer diskette
+ FI;
+ out (art); line;
+ put ("zukünftiger Name des Archives :");
+ editget (aktueller archivename);line;
+ archive (aktueller archivename);
+ diskette im schacht := TRUE;
+ disable stop;
+ IF art = "o" THEN format (archive)
+ ELSE format (int (art), archive)
+ FI;
+ IF is error
+ THEN diskette im schacht := FALSE
+ ELSE aktueller archivename := archiv name
+ FI
+END PROC formatieren einer diskette;
+
+PROC auflisten der taskdateien:
+ DATASPACE VAR dummy ds :: nilspace;
+ FILE VAR f :: sequential file (output,dummy ds);
+ list (f);
+ headline (f,"Liste der eigenen Task");
+ modify (f);
+ to line (f,1);
+ show (f);
+ forget (dummy ds)
+END PROC auflisten der taskdateien;
+
+PROC loeschen von dateien in der task:
+ t1 := invers ("Loeschen von Dateien ") + " Info mit <?>" + trennzeichen +
+ "Bitte alle zu loeschenden Dateien ankreuzen" + trennzeichen +
+ invers ("(Ankreuzen mit <RETURN> )");
+ forget (some (all,t1))
+END PROC loeschen von dateien in der task;
+
+PROC reservieren des archives:
+ TEXT VAR meldung;
+ page;
+ cursor(1,1); write("Bitte warten...");
+ line (2);
+ versuche archive zu reservieren (meldung);
+ IF meldung <> ""
+ THEN page;
+ line(10);
+ write (""15"" + meldung + " "14"");
+ weitermachen;
+ diskette im schacht := FALSE;
+ archive ist meins := FALSE;
+ LEAVE reservieren des archives
+ FI;
+ archive anmelden (aktueller archive name, meldung);
+ IF meldung <> ""
+ THEN melde archiveerror (meldung)
+ FI.
+
+END PROC reservieren des archives;
+
+PROC versuche archive zu reservieren (TEXT VAR fehlermeldung):
+ fehlermeldung := "";
+ IF archive ist meins
+ THEN LEAVE versuche archive zu reservieren
+ FI;
+ disable stop;
+ archive ("");
+ IF is error
+ THEN fehlermeldung := errormessage;
+ archive ist meins := FALSE;
+ clear error;
+ enable stop;
+ ELSE archive ist meins := TRUE;
+ fehlermeldung := "";
+ enable stop
+ FI
+END PROC versuche archive zu reservieren;
+
+PROC archive anmelden (TEXT VAR archivename, fehlermeldung):
+ page;
+ line(3);
+ fehlermeldung := "";
+ IF NOT archive ist meins
+ THEN archivename := "";
+ diskette im schacht := FALSE;
+ fehlermeldung := "nicht reserviert";
+ LEAVE archive anmelden
+ FI;
+ IF yes ("Haben Sie die Diskette eingelegt und das Laufwerk geschlossen")
+ THEN line;
+ write ("Bitte warten...");
+ archive name := archiv name;
+ IF archiv error <> ""
+ THEN fehlermeldung := archiv error;
+ diskette im schacht := FALSE
+ ELSE diskette im schacht := TRUE
+ FI
+ ELSE diskette im schacht := FALSE;
+ archivename := ""
+ FI
+END PROC archive anmelden;
+
+PROC verlange reservierung des archives:
+ page;
+ line(7);
+ write (""15"Sie muessen unbedingt erst das Archiv reservieren, "14"");
+ line(2);
+ write (""15"sonst kann ich nicht darauf zugreifen! "14"");
+ line(2);
+ weitermachen
+END PROC verlange reservierung des archives;
+
+PROC auflisten der archivedateinamen:
+ forget ("Dateiliste", quiet);
+ ueberpruefe reservierung;
+ liste dateien des archivs auf;
+ liste ausgeben;
+ forget ("Dateiliste", quiet).
+
+ ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE auflisten der archivedateinamen
+ FI.
+
+ liste dateien des archivs auf:
+ FILE VAR f :: sequential file (output,"Dateiliste");
+ disable stop;
+ list(f,manager);
+ IF is error
+ THEN LEAVE auflisten der archivedateinamen;
+ ELSE enable stop
+ FI.
+
+ liste ausgeben:
+ show (f)
+END PROC auflisten der archivedateinamen;
+
+PROC checken von dateien auf dem archive:
+ ueberpruefe reservierung;
+ lasse dateien auswaehlen und checke.
+
+ ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE checken von dateien auf dem archive
+ FI.
+
+ lasse dateien auswaehlen und checke:
+ t1 := invers ("'Checken' von Dateien (auf dem Archiv) ")
+ + trennzeichen + "Bitte alle zu 'checkenden' Dateien ankreuzen";
+ disable stop;
+ check (some (ALL manager, t1), manager);
+ weitermachen;
+ IF is error
+ THEN LEAVE checken von dateien auf dem archive
+ ELSE enable stop;
+ FI
+END PROC checken von dateien auf dem archive;
+
+PROC schreiben von dateien aufs archive:
+ ueberpruefe reservierung;
+ lasse dateien auswaehlen und schreibe aufs archive.
+
+ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE schreiben von dateien aufs archive
+ FI.
+
+lasse dateien auswaehlen und schreibe aufs archive:
+ t1 := invers ("Schreiben von Dateien ") + " Info mit <?>" + trennzeichen +
+ "Bitte alle zu schreibenden Dateien ankreuzen." + trennzeichen +
+ invers ("(Ankreuzen mit <RETURN> )");
+ THESAURUS VAR angekreuzte :: some (ALL myself, t1);
+ disable stop;
+ zuerst loeschen;
+ INT VAR zaehler;
+ TEXT VAR dname;
+ page;
+ FOR zaehler FROM 1 UPTO highest entry (angekreuzte) REP
+ IF is error
+ THEN LEAVE schreiben von dateien aufs archive
+ FI;
+ dname := name (angekreuzte, zaehler);
+ IF dname <> ""
+ THEN putline (managername + " <--- """ + dname + """");
+ save (dname, manager)
+ FI;
+ PER.
+
+ zuerst loeschen:
+ IF disk CAND (not empty (angekreuzte))
+ THEN out (center(invers("Bitte Warten"),"-",80));
+ THESAURUS CONST zu loe :: angekreuzte / ALL manager;
+ IF not empty (zu loe) AND NOT is error
+ THEN page;
+ putline ("Zuerst Dateien auf der Diskette loeschen?");
+ erase (zu loe, manager)
+ FI
+ FI
+END PROC schreiben von dateien aufs archive;
+
+BOOL PROC not empty (THESAURUS CONST t):
+ INT VAR i;
+ FOR i FROM 1 UPTO highest entry (t) REP
+ IF name (t,i) <> ""
+ THEN LEAVE not empty WITH TRUE
+ FI
+ PER;
+ FALSE
+END PROC not empty;
+
+PROC holen von dateien vom archive:
+ ueberpruefe reservierung;
+ lasse dateien auswaehlen und hole vom archive.
+
+ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE holen von dateien vom archive
+ FI.
+
+lasse dateien auswaehlen und hole vom archive:
+ t1 := invers ("Holen von Dateien ") + " Info mit <?>" +
+ trennzeichen +
+ "Bitte alle zu holenden Dateien ankreuzen.";
+ THESAURUS VAR angekreuzte :: some (ALL manager,t1);
+ INT VAR zaehler;
+ TEXT VAR dname;
+ page;
+ FOR zaehler FROM 1 UPTO highest entry (angekreuzte) REP
+ dname := name (angekreuzte, zaehler);
+ disable stop;
+ IF dname <> ""
+ THEN putline (managername + " --> """ + dname + """");
+ fetch (dname, manager)
+ FI;
+ IF is error
+ THEN LEAVE holen von dateien vom archive
+ ELSE enable stop
+ FI
+ PER
+END PROC holen von dateien vom archive;
+
+PROC loeschen von dateien auf dem archive:
+ ueberpruefe reservierung;
+ lasse dateien auswaehlen und loesche.
+
+ ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE loeschen von dateien auf dem archive
+ FI.
+
+lasse dateien auswaehlen und loesche:
+ t1 := invers ("Vernichten (Loeschen) von Dateien") + " Info mit <?>" +
+ trennzeichen + "Bitte alle zu loeschenden Dateien ankreuzen.";
+ disable stop;
+ erase (some (ALL manager, t1), manager);
+ IF is error
+ THEN LEAVE loeschen von dateien auf dem archive
+ ELSE enable stop;
+ FI
+END PROC loeschen von dateien auf dem archive;
+
+PROC initialisieren des archives:
+ TEXT VAR neuer archivename;
+ page;
+ line(2);
+ write(center (""15"Vollstaendiges Loeschen des Archivs "14""));
+ line(2);
+ IF archive ist meins AND diskette im schacht
+ THEN write("Eingestellter Archivname: " +
+ invers ("""" + aktueller archivename + """"));
+ line(2);
+ IF yes ("Moechten Sie einen anderen Namen fuer das Archiv")
+ THEN line(2);
+ stelle frage nach neuem namen
+ ELSE neuer archivename := aktueller archivename
+ FI
+ ELSE stelle frage nach neuem namen
+ FI;
+ fuehre initialisierung durch.
+
+ stelle frage nach neuem namen:
+ write("Bitte den Namen fuer das Archiv (maximal 30 Buchstaben):");
+ line;
+ getline(neuer archivename);
+ neuer archivename := compress(neuer archivename);
+ IF length (neuer archivename) > 40
+ THEN line(2);
+ write ("Der neue Archivname ist zu lang!");
+ weitermachen;
+ LEAVE initialisieren des archives
+ FI.
+
+ fuehre initialisierung durch:
+ disable stop;
+ aktueller archivename := neuer archivename;
+ archive (neuer archivename);
+ IF is error
+ THEN diskette im schacht := FALSE;
+ archive ist meins := FALSE;
+ LEAVE initialisieren des archives
+ ELSE clear(archive);
+ IF is error
+ THEN diskette im schacht := FALSE;
+ LEAVE initialisieren des archives
+ ELSE aktueller archivename := archiv name;
+ diskette im schacht := archiv error = ""
+ FI
+ FI
+END PROC initialisieren des archives;
+
+PROC ausdruck archivelisting:
+ ueberpruefe reservierung;
+ print archive listing;
+ weitermachen.
+
+ueberpruefe reservierung:
+ IF disk AND diskette im schacht
+ AND NOT archive ist meins
+ THEN verlange reservierung des archives;
+ LEAVE ausdruck archivelisting
+ FI.
+
+print archive listing:
+ FILE VAR listfile := sequential file (output , "PLA");
+ INT VAR i;
+ TEXT CONST head :: 70 * "=",
+ end :: 70 * "_";
+ TEXT VAR record;
+ disable stop;
+ list (listfile, archive);
+ IF is error
+ THEN diskette im schacht := FALSE;
+ LEAVE ausdruck archivelisting
+ FI;
+ print head;
+ erase dummy names;
+ print bottom;
+ print and erase listing.
+
+print head :
+ modify (listfile);
+ to line (listfile, 1);
+ FOR i FROM 1 UPTO 6 REP
+ insert record (listfile)
+ PER;
+ to line (listfile, 1);
+ write record (listfile, type); down (listfile);
+ write record (listfile, head); down (listfile);
+ write record (listfile, "ARCHIVNAME: "+headline (listfile) + " " +
+ time of day +" " + date ); down (listfile);
+ write record (listfile, head); down (listfile);
+ write record (listfile, " "); down (listfile);
+ write record (listfile, "Date Store Contents").
+
+erase dummy names :
+ to line (listfile, 6);
+ WHILE NOT eof (listfile) REP
+ read record (listfile, record);
+ IF (record SUB dummy name pos) = "-"
+ THEN delete record (listfile)
+ ELSE down (listfile)
+ FI
+ PER.
+
+print bottom :
+ output (listfile);
+ putline (listfile, end).
+
+print and erase listing :
+ modify (listfile);
+ edit (listfile);
+ line (3);
+ IF yes ("Archivlisting drucken")
+ THEN print ("PLA")
+ FI;
+ forget ("PLA", quiet).
+
+END PROC ausdruck archivelisting;
+
+PROC neue diskette anmelden:
+ ueberpruefe reservierung;
+ melde neue diskette an.
+
+ ueberpruefe reservierung:
+ IF NOT archive ist meins
+ THEN reservieren des archives;
+ LEAVE neue diskette anmelden
+ FI.
+
+ melde neue diskette an:
+ TEXT VAR meldung;
+ page;
+ cursor(1,1); write("Bitte warten...");
+ line (2);
+ archive anmelden (aktueller archive name,meldung);
+ IF meldung <> ""
+ THEN melde archiveerror (meldung)
+ FI.
+
+END PROC neue diskette anmelden;
+
+PROC automatische freigabe des archives:
+ archive ist meins := FALSE;
+ diskette im schacht := FALSE;
+ command dialogue (FALSE);
+ release(archive);
+ command dialogue (TRUE)
+END PROC automatische freigabe des archives;
+
+PROC melde archiveerror (TEXT CONST meldung):
+ line(2);
+ IF meldung = "nicht reserviert"
+ THEN verlange reservierung des archives;
+ ELIF meldung = "keine diskette"
+ THEN write (""15"Ich mache die Reservierung rueckgaengig! "14"");
+ neu reservieren
+ ELIF pos (meldung,"inkonsistent") > 0
+ THEN write(""15"Diskette ist nicht formatiert / initialisiert "14"");
+ neu reservieren;
+ ELIF pos(meldung,"Lesen unmoeglich") > 0
+ COR pos(meldung, "Schreiben unmoeglich") > 0
+ THEN write(""15"Die Diskette ist falsch eingelegt "14"");line (2);
+ write(""15"oder das Laufwerk ist nicht geschlossen "14"");line (2);
+ write(""15"oder die Diskette ist nicht formatiert !"14"");
+ neu reservieren;
+ ELIF pos (meldung, "Archiv heisst") > 0 AND pos(meldung, "?????") > 0
+ THEN write(""15"Diskette nicht lesbar ! (Name: '?????') "14"");line(2);
+ write(""15"Moeglicherweise ist die Diskette defekt ! "14"");
+ neu reservieren;
+ ELIF pos(meldung, "Archiv heisst") > 0
+ THEN write (invers(meldung));
+ line(2);
+ write (""15"Diskette wurde mit anderem Namen angemeldet!"14"");line(2);
+ write("Bitte neu reservieren!");
+ weitermachen
+ ELSE write(invers(meldung));
+ neu reservieren
+ FI
+END PROC melde archiveerror;
+
+PROC neu reservieren:
+ line (2);
+ write ("Bitte den Fehler beseitigen und das Archiv neu reservieren !");
+ weitermachen;
+ diskette im schacht := FALSE
+END PROC neu reservieren;
+
+PROC weitermachen:
+ line (2);
+ write("Zum Weitermachen bitte irgendeine Taste tippen!");
+ pause
+END PROC weitermachen;
+
+PROC melde error (TEXT CONST meldung):
+ page;
+ line(10);
+ write (invers(meldung));
+ weitermachen
+END PROC melde error
+
+END PACKET mpg dm;
+
+(**************************** TOOLS *******************************)
+
+PACKET mpg tools DEFINES put,
+ th,
+ gen :
+
+
+lernsequenz auf taste legen ("E", ""27""2""27"p"27"qedit ("27"g)"13"");
+
+PROC put (BOOL CONST b) :
+ IF b THEN put ("TRUE") ELSE put ("FALSE") FI
+END PROC put;
+
+PROC th (THESAURUS CONST thes) :
+ THESAURUS VAR help :: SOME thes;help := empty thesaurus
+END PROC th;
+
+(************************ Task - Generierung *******************************)
+
+(* Zum Generieren einer TASK ist folgendes zu beachten:
+
+a) Es muss ein Archiv zur Verfuegung stehen, das einen beliebigen Namen hat.
+b) Auf diesem Archiv muss es eine Datei namens <"gen." + taskname> geben.
+c) Diese Datei muss folgendermassen aufgebaut sein:
+ In jeder Zeile steht genau ein Name einer fuer diese TASK wichtigen Datei.
+ Die ersten Namen sind Namen von zu insertierenden Dateien.
+ Es folgt "gen." + taskname.
+ Alle folgenden Dateinamen werden vom Archiv geholt und bleiben in der
+ TASK erhalten. *)
+
+BOOL VAR archive access :: FALSE;
+
+PROC hole (TEXT CONST dateiname):
+ IF exists (dateiname)
+ THEN display ("***")
+ ELSE IF NOT archive access
+ THEN archiv; (* geaendert BV 10.07.86 *)
+ archive access := TRUE
+ FI;
+ display ("-->");
+ from (dateiname)
+ FI;
+ display (dateiname + ""13""10"")
+END PROC hole;
+
+PROC ins (TEXT CONST dateiname):
+ line;
+ out (77 * "=" + ""13""10"");
+ out (dateiname + " wird insertiert"13""10"");
+ insert (dateiname);
+ forget (dateiname, quiet)
+END PROC ins;
+
+LET anzahl dateien = 50;
+
+ROW anzahl dateien TEXT VAR datei;
+
+INT VAR anzahl zu insertierender,
+ gesamtzahl;
+
+PROC gen:
+ TEXT CONST taskname :: name (myself),
+ gendateiname :: "gen." + taskname;
+ TEXT VAR record;
+ BOOL VAR zu insertieren :: TRUE;
+
+ archive access := FALSE;
+ anzahl zu insertierender := 0;
+ gesamtzahl := 0;
+ page;
+ putline ("GENERIERUNG VON " + taskname);
+ putline ((16 + length (taskname)) * "=");
+ hole (gendateiname);
+
+ FILE VAR gendatei := sequential file (input, gendateiname);
+ WHILE NOT eof (gendatei) AND gesamtzahl < anzahl dateien REP
+ getline (gendatei, record);
+ record := compress (record);
+ IF record = gendateiname
+ THEN zu insertieren := FALSE
+ FI;
+ IF zu insertieren
+ THEN anzahl zu insertierender INCR 1
+ FI;
+ gesamtzahl INCR 1;
+ hole (record);
+ datei [gesamtzahl] := record
+ PER;
+ forget (gendateiname, quiet);
+ IF archive access
+ THEN release;
+ line (2);
+ put ("Bitte entfernen Sie Ihre Diskette aus dem Laufwerk!");
+ line
+ FI;
+ INT VAR i;
+ FOR i FROM 1 UPTO anzahl zu insertierender REP
+ ins (datei [i])
+ PER;
+ IF yes ("global manager")
+ THEN do ("global manager")
+ FI.
+END PROC gen
+
+END PACKET mpg tools;
+
+(********************* MPG TARGET HANDLING *******************)
+
+PACKET target handling DEFINES TARGET,
+ initialize target,
+ complete target,
+ delete in target,
+ select target,
+ actual target name,
+ actual target set,
+ target names:
+
+
+TYPE TARGET = STRUCT (INT ind, THESAURUS target name, target set);
+
+LET no target = 0;
+
+PROC initialize target (TARGET VAR tar):
+ tar.target set := empty thesaurus;
+ tar.target name := empty thesaurus;
+ tar.ind := no target
+END PROC initialize target;
+
+PROC complete target (TARGET VAR tar, TEXT CONST nam, set):
+ IF NOT (tar.target name CONTAINS nam)
+ THEN insert (tar.target name, nam);
+ insert (tar.target set , set)
+ ELSE errorstop ("Bezeichner bereits vorhanden")
+ FI
+END PROC complete target;
+
+PROC delete in target (TARGET VAR tar, TEXT CONST nam):
+ INT CONST ind :: link (tar.target name, nam);
+ delete (tar.target name, ind);
+ delete (tar.target set , ind);
+ tar.ind := no target
+END PROC delete in target;
+
+PROC select target (TARGET VAR tar, TEXT CONST nam, TEXT VAR set):
+ INT VAR ind :: link (tar.target name, nam);
+ IF ind <> 0
+ THEN set := name (tar.target set , ind);
+ tar.ind := ind
+ ELSE set := ""
+ FI
+END PROC select target;
+
+TEXT PROC actual target name (TARGET CONST tar):
+ IF tar.ind = no target
+ THEN ""
+ ELSE name (tar.target name, tar.ind)
+ FI
+END PROC actual target name;
+
+TEXT PROC actual target set (TARGET CONST tar):
+ IF tar.ind = no target
+ THEN ""
+ ELSE name (tar.target set, tar.ind)
+ FI
+END PROC actual target set;
+
+THESAURUS PROC target names (TARGET CONST tar):
+ tar.target name
+END PROC target names
+
+END PACKET target handling;
+
+(*********************** MPG PRINT CMD ***********************)
+
+PACKET mpg print cmd DEFINES print, select printer,
+ install printers,
+ list printers,
+ printer, printers:
+
+
+TARGET VAR printer list;
+
+LET std printer name = "PRINTER",
+ titel = "PRINTER AUSWAHL";
+
+LET trenner = "\#";
+
+TARGET PROC printers:
+ printer list
+END PROC printers;
+
+PROC install printers (FILE VAR f):
+ initialize target (printer list);
+ TEXT VAR nam, set;
+ TEXT VAR std nam :: "", std set :: "";
+ WHILE NOT eof (f) REP
+ TEXT VAR zeile;
+ getline (f, zeile);
+ IF zeile <> ""
+ THEN INT CONST po :: pos (zeile, trenner);
+ nam := subtext (zeile, 1, po - 1);
+ set := subtext (zeile, po + 1);
+ complete target (printer list, nam, set);
+ IF int (nam) = station (myself)
+ THEN std nam := nam;
+ std set := set
+ FI
+ FI
+ PER;
+ select target (printer list, std nam, std set);
+ IF std set <> ""
+ THEN fonttable (std set)
+ FI
+END PROC install printers;
+
+PROC select printer:
+ TEXT VAR font;
+ select target (printer list,
+ one (target names (printer list), titel,1,24), font);
+ IF font <> ""
+ THEN fonttable (font)
+ FI
+END PROC select printer;
+
+PROC list printers:
+ th (target names (printer list))
+END PROC list printers;
+
+PROC print :
+ print (last param)
+END PROC print;
+
+PROC print (TEXT CONST file) :
+ save (file, printer)
+END PROC print;
+
+PROC print (THESAURUS CONST thes) :
+ save (thes, printer)
+END PROC print;
+
+TASK PROC printer:
+ INT VAR stat :: int (actual target name (printer list));
+ IF stat = 0
+ THEN niltask
+ ELSE stat/std printer name
+ FI
+END PROC printer
+
+END PACKET mpg print cmd;
+
+(************************ EDIT MONITOR *************************)
+
+PACKET edit monitor DEFINES edit monitor, (* Lutz Prechelt *)
+ F, (* Carsten Weinholz *)
+ table: (* Thomas Clermont *)
+ (* EUMEL 1.8 *)
+ (* Version 4.4.1 *)
+ (* Multimonitor *)
+ (* Alphaeditor *)
+ (* 06.07.1987 *)
+
+LET command handling line = 18, (* muss > max file + 1 und < 23 sein *)
+ max file = 15, (* max. 20 *)
+ file type = 1003,
+ min lines per segment = 24, (* darunter wird reorganisiert *)
+ integer is allowed = 3,
+ no command = 4711,
+ gib kommando 1 = "Gib Edit-Monitor ",
+ gib kommando 2 = " Kommando :";
+
+TEXT CONST command list ::"quitmonitor:1.0edit:2.1run:3.1insert:4.1" +
+ "forget:5.1rename:6.2copy:7.2fetch:8.1" +
+ "save:9.1close:10.1fileinfo:11.0reorganize:12.1";
+
+LET EDITTABLE = ROW max file STRUCT (THESAURUS line table,
+ TEXT name,
+ FILE file );
+
+LET nil code = 0,
+ edit code= 1,
+ do code = 2;
+
+INT VAR command index, number of params, command indices,
+ aufruftiefe :: 0,zeile;
+
+TEXT VAR param 1, param 2, old command :: "", command line :: "";
+BOOL VAR short command, info :: FALSE,verlasse monitor :: FALSE;
+INITFLAG VAR this monitor;
+
+EDITTABLE VAR etb;
+
+PROC edit monitor :
+ TEXT VAR ch, old lernsequenz :: lernsequenz auf taste ("Q");
+ INT VAR i, previous heap size :: heap size;
+ disable stop;
+ initialize;
+ get new table;
+ REP
+ prepare screen;
+ perhaps reorganize and get command;
+ execute command;
+ collect heap garbage if necessary
+ UNTIL verlasse monitor PER;
+ lernsequenz auf taste legen ("Q",old lernsequenz);
+ close all files if not nested.
+
+initialize :
+ lernsequenz auf taste legen ("Q",""1""8""1""12"quitmonitor"13"");
+ verlasse monitor := FALSE;
+ aufruftiefe INCR 1;
+ IF aufruftiefe > max file
+ THEN aufruftiefe DECR 1;
+ errorstop ("Editmonitor overflow: Bereits " + text (max file ) + "Monitore geoeffnet")
+ ELSE IF NOT initialized (this monitor)
+ THEN FOR i FROM 1 UPTO max file REP
+ etb [i].line table := empty thesaurus;
+ etb [i].name := ""
+ PER
+ FI;
+ FOR i FROM 1 UPTO max file REP
+ etb [i].name := name (etb [aufruftiefe].line table,i)
+ PER
+ FI.
+
+prepare screen :
+ calc command handling line;
+ put file info.
+
+calc command handling line:
+ out (""10""); (* down *)
+ INT VAR dummy, y;
+ get cursor (dummy, y);
+ FOR dummy FROM 1 UPTO y-22 REP
+ out (""10"")
+ PER;
+ zeile := max (command handling line, min (y + 1, 22)).
+
+perhaps reorganize and get command :
+ BOOL VAR anything reorganized :: FALSE,
+ was error :: FALSE ;
+ IF is error
+ THEN command line := old command;
+ out (""3""); (* up *)
+ put error; clear error; was error := TRUE
+ ELSE command line := ""
+ FI;
+ out ( " ");
+ out (gib kommando);
+ out (""13""10" ");
+ IF NOT was error THEN perhaps reorganize FI;
+ IF anything reorganized
+ THEN command index := no command;
+ LEAVE perhaps reorganize and get command
+ FI;
+ editget (command line, "", "fk", ch);
+ IF ch = ""27"k"
+ THEN out (""13""5"");
+ command line := old command;
+ out (" ");
+ editget (command line, "", "f", ch)
+ FI;
+ line;
+ old command := command line;
+ command index := cmd index (command line);
+ param position (LENGTH command line + 7);
+ IF (command index > 0 AND command index <= max file)
+ AND command indices > 0
+ THEN short command := TRUE
+ ELSE short command := FALSE;
+ analyze command (command list, command line, integer is allowed,
+ command index, number of params,param 1, param 2)
+ FI.
+
+perhaps reorganize :
+ BOOL VAR interrupt;
+ ch := getcharety;
+ IF ch <> ""
+ THEN push (ch); LEAVE perhaps reorganize
+ FI;
+ ch := incharety (50);
+ IF ch <> ""
+ THEN type (ch); LEAVE perhaps reorganize
+ FI;
+ FOR i FROM 1 UPTO max file REP
+ reorganize (etb [i].name, anything reorganized, interrupt, i);
+ UNTIL interrupt OR anything reorganized PER.
+
+close all files if not nested :
+ aufruftiefe DECR 1;
+ command index := 0; (* Um die verschachtelten Aufrufe zu schuetzen *)
+ verlasse monitor := aufruftiefe = 0;
+ IF aufruftiefe > 0
+ THEN FOR i FROM 1 UPTO max file REP
+ etb [i].name := name (etb [aufruftiefe].line table,i)
+ PER;
+ ELSE param 1 := "";
+ param 2 := "";
+ command line := "";
+ old command := ""
+ FI.
+
+collect heap garbage if necessary :
+ IF heap size > previous heap size + 4
+ THEN collect heap garbage;
+ previous heap size := heap size
+ FI
+ENDPROC edit monitor;
+
+PROC put file info:
+ INT VAR i;
+ out (""1""); (* home *)
+ FOR i FROM 1 UPTO max file WHILE NOT is incharety REP
+ out (text (i, 2));
+ out (" : ");
+ IF info
+ THEN show file info
+ FI;
+ IF etb [i].name <> ""
+ THEN out ("""" + etb [i].name + """")
+ FI;
+ out (""5""10""13"")
+ PER;
+ out(""5"");
+ cursor (1, zeile).
+
+show file info :
+ (* Falls fileinfo an, werden vor den Dateinamen bei FILEs die Anzahl von
+ Zeilen , Segmenten und Speicher angezeigt. *)
+ IF exists (etb [i].name)
+ THEN IF type (old (etb [i].name)) = file type
+ THEN out (text (lines (etb [i].file), 5));
+ out (" ");
+ out (text (segments (etb [i].file), 4));
+ out (" ")
+ ELSE out ( 11 * "=")
+ FI;
+ out (text (storage (old (etb [i].name)),5))
+ ELIF etb [i].name <> ""
+ THEN out ( 16 * "=")
+ FI;
+ out (" ").
+
+END PROC put file info;
+
+PROC execute command :
+ enable stop;
+ IF command index = no command THEN LEAVE execute command FI;
+ IF short command THEN do edit monitor command (command index)
+ ELSE case selection FI.
+
+case selection :
+ SELECT command index OF
+ CASE 1 : (* quit *) verlasse monitor := TRUE
+ CASE 2 : edit (name from list (param 1))
+ CASE 3 : run (name from list (param 1))
+ CASE 4 : insert (name from list (param 1))
+ CASE 5 : forget (name from list (param 1)); close (int (param1))
+ CASE 6 : rename (name from list (param 1) , name from list (param 2))
+ CASE 7 : copy (name from list (param 1), name from list (param 2))
+ CASE 8 : fetch (name from list (param 1))
+ CASE 9 : save (name from list (param 1))
+ CASE 10: close (int (param 1))
+ CASE 11: info := NOT info
+ CASE 12: reorganize (name from list (param 1))
+ OTHERWISE do (command line)
+ END SELECT
+END PROC execute command;
+
+PROC close (INT CONST n) :
+ IF (n > 0 AND n <= max file) CAND etb [n].name <> ""
+ THEN IF exists (etb [n].name) CAND type (old (etb [n].name)) = file type
+ THEN close (etb [n].file)
+ FI;
+ INT VAR id;
+ delete (etb [aufruftiefe].line table,etb [n].name,id);
+ etb [n].name := ""
+ FI
+END PROC close;
+
+TEXT OP F (INT CONST nr) :
+ IF nr > 0 AND nr <= max file
+ THEN etb [nr].name
+ ELSE out (""7""); ""
+ FI
+END OP F;
+
+OP F (INT CONST nr, TEXT CONST datei) :
+ IF nr > 0 AND nr <= max file
+ THEN etb [nr].name := datei;
+ insert (etb [aufruftiefe].line table,datei);
+ IF exists (datei) CAND type (old (datei)) = file type
+ THEN etb [nr].file := sequential file(modify, datei)
+ FI
+ ELSE out (""7"")
+ FI
+END OP F;
+
+PROC get new table:
+ table (some (all + etb [aufruftiefe].line table + vorgaenger)).
+
+ vorgaenger:
+ IF aufruftiefe = 1
+ THEN empty thesaurus
+ ELSE etb [aufruftiefe - 1].line table
+ FI
+END PROC get new table;
+
+THESAURUS PROC table :
+ THESAURUS VAR result :: emptythesaurus;
+ INT VAR i;
+ FOR i FROM 1 UPTO max file REP
+ IF exists (etb [i].name) AND NOT (result CONTAINS etb [i].name)
+ THEN insert (result, etb [i].name)
+ FI
+ PER;
+ result
+END PROC table;
+
+PROC table (THESAURUS CONST new) :
+ INT VAR i, nr :: 1, dummy;
+ TEXT VAR t;
+ etb [aufruftiefe].line table := empty thesaurus;
+ FOR i FROM 1 UPTO max file REP
+ etb [i].name := ""
+ PER;
+ FOR i FROM 1 UPTO highest entry (new) REP
+ get (new, t, dummy);
+ IF t <> ""
+ THEN nr F t;nr INCR 1
+ FI
+ UNTIL nr > max file PER
+END PROC table;
+
+PROC do edit monitor command (INT CONST file nr) :
+ enable stop;
+ IF command indices = 1
+ THEN try to edit or to execute
+ ELSE try alpha editor
+ FI.
+
+try to edit or to execute:
+ SELECT prepare edit (file nr) OF
+ CASE edit code: last param (etb [file nr].name);
+ edit (etb [file nr].file);
+ page
+ CASE do code : do (etb[file nr].name)
+ END SELECT.
+
+try alpha editor:
+ IF command indices <= 10
+ THEN open sub editors;
+ IF groesster editor > 0
+ THEN edit (1);
+ WHILE groesster editor > 0 REP
+ quit
+ PER;
+ page
+ FI
+ ELSE errorstop ("Maximal 10 Parallel-Editoren")
+ FI.
+
+open sub editors:
+ TEXT VAR num, edit cmd :: "";
+ INT VAR ye :: 1, sub :: file nr, pass;
+ WHILE groesster editor > 0 REP
+ quit
+ PER;
+ FOR pass FROM 1 UPTO 2 REP
+ IF pass = 2
+ THEN command line := edit cmd
+ FI;
+ scan (command line);
+ next symbol (num); (* skip ersten index *)
+ REP
+ INT VAR op code := prepare edit (sub);
+ IF pass = 1
+ THEN SELECT op code OF
+ CASE nil code : command indices DECR 1
+ CASE editcode : edit cmd CAT (num + " ")
+ CASE do code : edit cmd CAT (num + " ");
+ command indices DECR 1
+ END SELECT
+ ELSE SELECT op code OF
+ CASE edit code: neuer editor
+ CASE do code: do (etb [sub].name);
+ IF groesster editor > 0
+ THEN bild zeigen;
+ ueberschrift zeigen
+ FI
+ END SELECT
+ FI;
+ next symbol (num);
+ sub := int (num)
+ UNTIL num = "" PER;
+ sub := file nr;
+ PER.
+
+ neuer editor:
+ open editor (groesster editor+1,etb [sub].file, TRUE, 1,ye,79,25-ye);
+ ye INCR (24 DIV command indices)
+
+END PROC do edit monitor command;
+
+INT PROC prepare edit (INT CONST file nr):
+ IF file nr > 0 AND file nr <= max file
+ THEN IF etb [file nr].name = ""
+ THEN get file name and open;
+ IF etb [file nr].name <> ""
+ THEN IF exists (etb [file nr].name)
+ THEN IF type (old (etb [file nr].name)) = file type
+ THEN edit code
+ ELSE nil code
+ FI
+ ELSE do code
+ FI
+ ELSE nil code
+ FI
+ ELIF NOT exists (etb [file nr].name)
+ THEN do code
+ ELIF type (old (etb [file nr].name)) <> file type
+ THEN nil code
+ ELSE modify (etb [file nr].file);
+ edit code
+ FI
+ ELSE errorstop ("Undefinierter Index [1;15]");nil code
+ FI.
+
+get file name and open :
+ cursor (4, file nr);
+ out (""5"? ");
+ editget (etb [file nr].name);
+ IF etb [file nr].name <> ""
+ THEN file nr F etb [file nr].name;
+ IF NOT exists (etb [file nr].name)
+ THEN out (""13""10"");
+ IF no (5 * ""2"" +"Datei neu einrichten")
+ THEN LEAVE prepare edit WITH nil code
+ ELSE kopple file an
+ FI
+ ELIF type (old (etb [file nr].name)) = file type
+ THEN kopple file an
+ FI
+ FI.
+
+ kopple file an:
+ etb [file nr].file := sequential file (output, etb [file nr].name).
+
+END PROC prepare edit;
+
+(***************** Hilfsprozeduren *********************************)
+
+BOOL PROC is incharety :
+ TEXT VAR ch :: getcharety;
+ IF ch = ""
+ THEN FALSE
+ ELSE push (ch);
+ TRUE
+ FI
+END PROC is incharety;
+
+TEXT PROC name from list (TEXT CONST name):
+ INT VAR i :: int (name);
+ IF (i > 0 AND i <= max file)
+ THEN etb [i].name
+ ELSE name
+ FI.
+END PROC name from list;
+
+PROC reorganize (TEXT CONST datei, BOOL VAR reorganization processed,
+ interrupted,
+ INT CONST file nummer):
+ (* Reorganisiert nur , falls :
+ 1. Datei ein FILE ist
+ 2. FILE mindestens "min lines to reorganize" Zeilen hat
+ 3. FILE nicht im Schnitt "min lines per segment" Zeilen pro Segment hat
+ 4. kein Tastendruck erfolgt
+ *)
+ DATASPACE VAR ds;
+ FILE VAR in, out;
+ TEXT VAR t;
+ INT VAR actual line,i,x,y;
+ get cursor (x,y);
+ interrupted := FALSE;
+ IF NOT exists (datei) COR type (old (datei)) <> file type
+ THEN LEAVE reorganize
+ FI;
+ in := sequential file (modify, datei);
+ actual line := line no (in);
+ input (in);
+ IF (lines (in) < 120 CAND segments (in) < 6) COR
+ lines (in) DIV segments (in) >= min lines per segment
+ THEN modify (in);
+ to line (in,actual line);
+ LEAVE reorganize
+ FI;
+ disable stop;
+ ds := nilspace;
+ out := sequential file (output, ds);
+ IF info
+ THEN FOR i FROM 1 UPTO lines (in) REP
+ cursor (4, file nummer);
+ put (i);
+ getline (in, t);
+ putline (out, t);
+ IF is error COR is incharety THEN interrupt FI
+ PER
+ ELSE FOR i FROM 1 UPTO lines (in) REP
+ getline (in, t);
+ putline (out, t);
+ IF is error COR is incharety THEN interrupt FI
+ PER
+ FI;
+ copy attributes (in,out);
+ modify (out);
+ to line (out,actual line);
+ forget (datei, quiet);
+ copy (ds, datei);
+ forget (ds);
+ reorganization processed := TRUE.
+
+interrupt :
+ cursor (4, lines (in));
+ forget (ds);
+ interrupted := TRUE;
+ cursor (x,y);
+ enable stop;
+ LEAVE reorganize.
+
+END PROC reorganize;
+
+INT PROC cmd index (TEXT CONST command line):
+ INT VAR type, result :: 0;
+ TEXT VAR num;
+ command indices := 0;
+ scan (command line);
+ REP
+ next symbol (num, type);
+ IF type = 3 (* Ziffernfolge *)
+ THEN IF command indices = 0
+ THEN result := int (num)
+ FI;
+ command indices INCR 1
+ ELIF type <> 7
+ THEN command indices := 0
+ FI
+ UNTIL type = 7 OR command indices = 0 PER;
+ result
+END PROC cmd index;
+
+TEXT PROC gib kommando:
+ gib kommando 1 + text (aufruftiefe) + gib kommando 2
+END PROC gib kommando;
+
+END PACKET edit monitor;
+
+(******************************** MANAGER ******************************)
+
+PACKET mpg global manager DEFINES monitor,
+ break,
+ end global manager,
+ begin,
+ begin password,
+ manager message,
+ manager question,
+ free manager,
+ std manager,
+ mpg manager,
+ free global manager,
+ global manager :
+
+
+LET ack = 0,
+ nak = 1,
+ error nak = 2,
+ message ack = 3,
+ question ack = 4,
+ second phase ack = 5,
+ false code = 6,
+
+ begin code = 4,
+ password code = 9,
+ fetch code = 11,
+ save code = 12,
+ exists code = 13,
+ erase code = 14,
+ list code = 15,
+ all code = 17,
+
+ killer code = 24,
+
+ continue code = 100,
+
+ error pre = ""7""13""10""5"Fehler : ",
+ cr lf = ""13""10"";
+
+
+DATASPACE VAR ds := nilspace;
+
+BOUND STRUCT (TEXT fnam, write pass, read pass) VAR msg;
+BOUND TEXT VAR reply msg;
+
+TASK VAR order task, last order task;
+
+FILE VAR list file;
+INT VAR reply, order, last order, phase no;
+TEXT VAR error message buffer :: "",
+ record,
+ fnam,
+ create son password :: "",
+ save write password,
+ save read password,
+ save file fnam;
+
+TEXT VAR std begin proc :: "checkoff;endglobalmanager(TRUE);" +
+ "warnings off;sysout("""");sysin("""");" +
+ "monitor";
+BOOL VAR is global manager, is break manager;
+
+PROC mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ manager) :
+ IF online
+ THEN TEXT VAR dummy;
+ put ("Task-Passwort :");
+ getsecretline (dummy);
+ IF dummy <> "" THEN taskpassword (dummy) FI;
+ put ("Beginn-Passwort:");
+ getsecretline (dummy);
+ IF dummy <> "" THEN begin password (dummy) FI
+ FI;
+ is break manager := FALSE;
+ global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ manager)
+END PROC mpg manager;
+
+PROC global manager :
+ mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ std manager)
+END PROC global manager;
+
+PROC global manager (PROC (DATASPACE VAR, INT CONST, INT CONST,
+ TASK CONST) manager) :
+ is global manager := TRUE;
+ internal manager (PROC (DATASPACE VAR,INT CONST,INT CONST,
+ TASK CONST) manager)
+END PROC global manager;
+
+PROC internal manager (PROC (DATASPACE VAR, INT CONST, INT CONST,
+ TASK CONST) manager) :
+ old break;
+ set autonom;
+ disable stop;
+ command dialogue (FALSE);
+ last order task := niltask;
+ remember heap size;
+ REP
+ wait (ds, order, order task);
+ IF order <> second phase ack
+ THEN prepare first phase;
+ manager (ds, order, phase no, order task)
+ ELIF order task = last order task
+ THEN prepare second phase;
+ manager (ds, order, phase no, order task)
+ ELSE send nak FI;
+ send error if necessary;
+ collect heap garbage if necessary
+ UNTIL (NOT is global manager) AND (NOT is break manager)
+ PER;
+ command dialogue (TRUE);
+ reset autonom.
+
+send error if necessary :
+ IF is error
+ THEN forget (ds);
+ ds := nilspace;
+ reply msg := ds;
+ CONCR (reply msg) := error message;
+ clear error;
+ send (order task, error nak, ds)
+ FI .
+
+remember heap size :
+ INT VAR old heap size := heap size .
+
+collect heap garbage if necessary :
+ IF heap size > old heap size + 2
+ THEN collect heap garbage;
+ old heap size := heap size
+ FI .
+
+prepare first phase :
+ phase no := 1;
+ last order := order;
+ last order task := order task.
+
+prepare second phase :
+ phase no INCR 1;
+ order := last order.
+
+send nak :
+ forget (ds);
+ ds := nilspace;
+ send (order task, nak, ds)
+END PROC internal manager;
+
+PROC free global manager :
+ mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ free manager)
+END PROC free global manager;
+
+PROC std manager (DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task) :
+ IF (order = begin code AND task darf beginnen) COR
+ task darf senden
+ THEN free manager (ds, order, phase, order task)
+ ELSE errorstop ("Kein Zugriffsrecht auf Task """ + name (myself) + """")
+ FI.
+
+ task darf beginnen:
+ (task ist systemtask OR task ist sohn) AND is global manager.
+
+ task darf senden:
+ task ist systemtask OR task ist sohn.
+
+ task ist systemtask:
+ ordertask < supervisor OR ordertask = supervisor.
+
+ task ist sohn:
+ order task < myself
+END PROC std manager;
+
+PROC free manager (DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task) :
+ enable stop;
+ IF order > continue code AND
+ order task = supervisor THEN y maintenance
+ ELIF order = begin code AND is global manager
+ THEN y begin
+ ELSE file manager order
+ FI .
+
+file manager order :
+ get message text if there is one;
+ SELECT order OF
+ CASE fetch code : y fetch
+ CASE save code : y save
+ CASE exists code : y exists
+ CASE erase code : y erase
+ CASE list code : y list
+ CASE all code : y all
+ CASE killer code : y killer
+ OTHERWISE errorstop ("Falscher Auftrag fuer Task """ + name (myself) + """")
+ ENDSELECT .
+
+get message text if there is one :
+ IF order >= fetch code AND order <= erase code AND phase = 1 (* 28.6.'86 *)
+ THEN msg := ds;
+ fnam := msg.fnam
+ FI .
+
+y begin :
+ BOUND STRUCT (TEXT tname, tpass, TASK task, PROCA start proc) VAR sv msg := ds;
+ IF create son password = sv msg.tpass AND create son password <> "-"
+ THEN create son task
+ ELIF sv msg.tpass = ""
+ THEN ask for password
+ ELSE errorstop ("Passwort falsch")
+ FI .
+
+create son task :
+ begin (ds, PROC std begin, reply);
+ send (order task, reply, ds) .
+
+ask for password :
+ send (order task, password code, ds) .
+
+y fetch :
+ IF read permission (fnam, msg.read pass) COR order task < supervisor
+ THEN forget (ds);
+ ds := old (fnam);
+ send (order task, ack, ds)
+ ELSE errorstop ("Passwort falsch")
+ FI .
+
+y erase :
+ msg := ds;
+ fnam := msg.fnam;
+ IF NOT exists (fnam)
+ THEN manager message ("""" + fnam + """ existiert nicht", order task)
+ ELIF phase no = 1
+ THEN manager question ("""" + fnam + """ loeschen", order task)
+ ELIF write permission (fnam, msg.write pass) COR order task < supervisor
+ THEN forget (fnam, quiet);
+ send (order task, ack, ds)
+ ELSE errorstop ("Passwort falsch") FI .
+
+y save :
+ IF phase no = 1
+ THEN ysave pre
+ ELSE y save post FI.
+
+y save pre :
+ IF write permission (fnam, msg.write pass) COR order task < supervisor
+ THEN save file fnam := fnam;
+ save write password := msg.write pass;
+ save read password := msg.read pass;
+ IF exists (fnam)
+ THEN manager question (""""+fnam+""" ueberschreiben", order task)
+ ELSE send (order task, second phase ack, ds)
+ FI;
+ ELSE errorstop ("Passwort falsch")
+ FI .
+
+y save post :
+ forget (save file fnam, quiet);
+ copy (ds, save file fnam);
+ enter password (save file fnam,
+ save write password, save read password);
+ forget (ds);
+ ds := nilspace;
+ send (order task, ack, ds);
+ cover tracks of save passwords.
+
+cover tracks of save passwords :
+ replace (save write password, 1, LENGTH save write password * " ");
+ replace (save read password, 1, LENGTH save read password * " ") .
+
+y exists :
+ IF exists (fnam)
+ THEN send (order task, ack, ds)
+ ELSE send (order task, false code, ds)
+ FI.
+
+y list :
+ forget (ds);
+ ds := nilspace;
+ list file := sequential file (output, ds);
+ list (list file);
+ send (order task, ack, ds) .
+
+y all :
+ BOUND THESAURUS VAR all fnams := ds;
+ all fnams := all;
+ send (order task, ack, ds) .
+
+y maintenance :
+ TEXT VAR param 1, param 2;
+ INT VAR c index, nr of params;
+ TEXT CONST c list :: "break:1.0end:2.0monitor:3.0stdbeginproc:4.1";
+ disable stop;
+ call (supervisor, order, ds, reply);
+ forget (ds);
+ IF reply = ack
+ THEN IF is break manager
+ THEN end global manager (TRUE);
+ LEAVE y maintenance
+ FI;
+ put error message if there is one;
+ REP
+ command dialogue (TRUE);
+ get command ("Gib " + name (myself) + "-Kommando :");
+ analyze command (c list,0,c index,nr of params,param 1,param 2);
+ SELECT c index OF
+ CASE 1 : old break
+ CASE 2, 3 : is global manager := FALSE;
+ is break manager := FALSE;
+ LEAVE y maintenance
+ CASE 4 : std begin proc := param 1
+ OTHERWISE do command
+ END SELECT
+ UNTIL NOT on line PER;
+ command dialogue (FALSE);
+ old break;
+ set autonom;
+ save error message if there is one
+ FI;
+ enable stop .
+
+put error message if there is one :
+ IF error message buffer <> ""
+ THEN out (error pre);
+ out (error message buffer);
+ out (cr lf);
+ error message buffer := ""
+ FI.
+
+save error message if there is one :
+ IF is error
+ THEN error message buffer := error message;
+ clear error
+ FI.
+
+y killer :
+ FILE VAR f :: sequential file (input, ds);
+ WHILE NOT eof (f) REP
+ getline (f, record);
+ IF exists (record) THEN forget (record, quiet) FI
+ PER;
+ send (order task, ack, ds).
+ENDPROC free manager;
+
+PROC manager question (TEXT CONST question) :
+ forget (ds);
+ ds := nilspace;
+ reply msg := ds;
+ reply msg := question;
+ send (order task, question ack, ds)
+END PROC manager question;
+
+PROC manager question (TEXT CONST question, TASK CONST receiver) :
+ forget (ds);
+ ds := nilspace;
+ reply msg := ds;
+ reply msg := question;
+ send (receiver, question ack, ds)
+END PROC manager question;
+
+PROC manager message (TEXT CONST message) :
+ forget (ds);
+ ds := nilspace;
+ reply msg := ds;
+ reply msg := message;
+ send (order task, message ack, ds)
+END PROC manager message;
+
+PROC manager message (TEXT CONST message, TASK CONST receiver) :
+ forget (ds);
+ ds := nilspace;
+ reply msg := ds;
+ reply msg := message;
+ send (receiver, message ack, ds)
+END PROC manager message;
+
+PROC std begin :
+ do (std begin proc)
+ENDPROC std begin;
+
+PROC begin (TEXT CONST task name) :
+ TASK VAR sohn;
+ begin (task name, PROC monitor, sohn)
+END PROC begin;
+
+PROC begin password (TEXT CONST password) :
+ cover tracks of old create son password;
+ create son password := password;
+ display (""3""13""5"");
+ cover tracks.
+
+cover tracks of old create son password:
+ replace (create son password,1,LENGTH create son password * " ")
+END PROC begin password;
+
+PROC end global manager (BOOL CONST ende) :
+ is global manager := NOT ende;
+ is break manager := NOT ende
+ENDPROC end global manager;
+
+PROC old break :
+ eumel must advertise;
+ supervisor call (6)
+END PROC old break;
+
+PROC break :
+ IF is global manager
+ THEN old break; LEAVE break
+ FI;
+ is break manager := TRUE;
+ is global manager := FALSE;
+ internal manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ std manager)
+END PROC break;
+
+PROC supervisor call (INT CONST nr) :
+ DATASPACE VAR sv space :: nilspace;
+ INT VAR answer;
+ call (supervisor, nr, sv space, answer);
+ IF answer = error nak
+ THEN BOUND TEXT VAR err msg :: sv space;
+ forget (sv space); errorstop (err msg)
+ FI;
+ forget (sv space)
+END PROC supervisor call;
+
+
+
+LET cmd list =
+
+"edit:1.01end:3.0run:4.01runagain:6.0insert:7.01forget:9.01rename:11.2copy:12.2
+list:13.0storageinfo:14.0taskinfo:15.0fetch:16.1save:17.01saveall:19.0";
+
+
+INT VAR cmd index , params , previous heap size ;
+TEXT VAR param1, param2 ;
+
+
+PROC monitor :
+ disable stop ;
+ previous heap size := heap size ;
+ REP
+ command dialogue (TRUE);
+ sysin ("");
+ sysout ("");
+ cry if not enough storage;
+ get command ("gib kommando :");
+ analyze command (cmd list, 4, cmd index, params, param1, param2);
+ execute command ;
+ collect heap garbage if necessary
+ PER .
+
+collect heap garbage if necessary :
+ IF heap size > previous heap size + 4
+ THEN collect heap garbage ;
+ previous heap size := heap size
+ FI.
+
+cry if not enough storage :
+ INT VAR size, used;
+ storage (size, used);
+ IF used > size
+ THEN out (""7"Speicher Engpass! Dateien loeschen!"13""10"")
+ FI.
+ENDPROC monitor ;
+
+PROC execute command :
+ enable stop ;
+ SELECT cmd index OF
+ CASE 1 : edit
+ CASE 2 : edit (param1)
+ CASE 3 : end
+ CASE 4 : run
+ CASE 5 : run (param1)
+ CASE 6 : run again
+ CASE 7 : insert
+ CASE 8 : insert (param1)
+ CASE 9 : forget
+ CASE 10: forget (param1)
+ CASE 11: rename (param1, param2)
+ CASE 12: copy (param1, param2)
+ CASE 13: list
+ CASE 14: storage info
+ CASE 15: task info
+ CASE 16: fetch (param1)
+ CASE 17: save
+ CASE 18: save (param1)
+ CASE 19: save all
+ OTHERWISE do command
+ ENDSELECT .
+
+ENDPROC execute command ;
+
+END PACKET mpg global manager
+
diff --git a/app/mpg/2.2/src/VC 404 2-7.GCONF b/app/mpg/2.2/src/VC 404 2-7.GCONF
new file mode 100644
index 0000000..b70c9e5
--- /dev/null
+++ b/app/mpg/2.2/src/VC 404 2-7.GCONF
@@ -0,0 +1,93 @@
+INCLUDE "terminal plot";
+INCLUDE "std primitives";
+
+PLOTTER "VC 404",2,7,78,47,21.5,16.0;
+
+COLORS "000999";
+
+PROC clear:
+ IF plot
+ THEN INT VAR vc i;
+ FOR vc i FROM 1 UPTO 24
+ REP display [vc i] := empty line PER;
+ page
+ ELSE errorstop ("PROC clear : clear without plotmodus") FI
+END PROC clear;
+
+PROC prepare:
+ break(quiet);
+ REP
+ disable stop;
+ continue (channel(plotter));
+ clear error;
+ enable stop;
+ IF NOT online
+ THEN pause (300)
+ FI
+ UNTIL online PER
+END PROC prepare;
+
+PROC initplot:
+ plot := TRUE;
+ cursor (x pos + 1, 24 - (y pos) DIV 2)
+END PROC initplot;
+
+PROC endplot:
+ pause;
+ plot := FALSE
+END PROC endplot;
+
+PROC home:
+ move to (0,0)
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ x pos := x ;
+ y pos := y
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ new x pos := x;
+ new y pos := y;
+ plot vector (new x pos - x pos, new y pos - y pos) ;
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ move to (x,y);
+ point
+END PROC setpixel;
+
+PROC foreground (INT VAR type):
+ type := 1
+END PROC foreground;
+
+PROC background (INT VAR type):
+ type := 0
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ std circle (x,y,rad,from,to)
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1,y1,x2,y2,pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+END PROC fill;
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/app/mpg/2.2/src/VIDEOSTAR 3-6.GCONF b/app/mpg/2.2/src/VIDEOSTAR 3-6.GCONF
new file mode 100644
index 0000000..9accb3f
--- /dev/null
+++ b/app/mpg/2.2/src/VIDEOSTAR 3-6.GCONF
@@ -0,0 +1,92 @@
+INCLUDE "std primitives";
+
+PLOTTER "VIDEOSTAR",3,6,640,480,27.0,19.5;
+
+COLORS "000999";
+
+TEXT PROC koordinaten (INT CONST x,y):
+ code(32+((y DIV 32) AND 31)) + code(96+(y MOD 32)) +
+ code(32+((x DIV 32) AND 31)) + code(64+(x MOD 32))
+END PROC koordinaten;
+
+PROC clear:
+ out (""29""27""140""27"/0d");
+ moveto(0,0)
+END PROC clear;
+
+PROC prepare:
+ break(quiet);
+ REP
+ disable stop;
+ continue (channel(plotter));
+ clear error;
+ enable stop;
+ IF NOT online
+ THEN pause (300)
+ FI
+ UNTIL online PER
+END PROC prepare;
+
+PROC initplot:
+END PROC initplot;
+
+PROC endplot:
+ pause;
+ out(""24"")
+END PROC endplot;
+
+PROC home:
+ moveto (0,0)
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ out (""29""29"");
+ out (koordinaten (x,y))
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ out (koordinaten(x,y))
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ out (""28"");
+ out (koordinaten (x,y))
+END PROC setpixel;
+
+PROC foreground (INT VAR type):
+ IF type = 0 THEN out (""27"/1d") (* loeschend *)
+ ELIF type < 0 THEN out (""27"/2d");type := -1 (* XOR *)
+ ELSE out (""27"/0");type := 1 (* normal *)
+ FI
+END PROC foreground;
+
+PROC background (INT VAR type):
+ type := 0
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ IF full circle inside screen
+ THEN out (""29"" + koordinaten(x, y) + ""27"C" +
+ subtext (koordinaten(0,rad),1,3) + ""28"");
+ ELSE std circle (x,y,rad,from,to)
+ FI.
+
+ full circle inside screen:
+ (from = 0 AND to = 360) AND
+ (x + rad) < 640 AND (x - rad >= 0) AND
+ (y + rad) < 480 AND (y - rad >= 0)
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1, y1, x2, y2, pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+ moveto (x,y);
+ out (""27"F");
+END PROC fill;
+
+
diff --git a/app/mpg/2.2/src/WATANABE 3-8.GCONF b/app/mpg/2.2/src/WATANABE 3-8.GCONF
new file mode 100644
index 0000000..66e4856
--- /dev/null
+++ b/app/mpg/2.2/src/WATANABE 3-8.GCONF
@@ -0,0 +1,94 @@
+INCLUDE "std primitives";
+PLOTTER "WATANABE",3,8,3449,2599,34.5,26.0;
+
+COLORS "999000900009090000990";
+
+LET terminator = ""13"";
+TEXT VAR watanabe polygon :: "";
+
+PROC watanabe pen (INT CONST nummer):
+ draw watanabe polygon;
+ INT VAR pen no := nummer;
+ IF pen no > 6 OR pen no < 0
+ THEN pen no := 1
+ FI;
+ out ("J" + text(pen no) + terminator)
+END PROC watanabe pen;
+
+PROC draw watanabe polygon:
+ IF watanabe polygon <> ""
+ THEN out ("D" + subtext (watanabe polygon,2) + terminator)
+ FI;
+ watanabe polygon := ""
+END PROC draw watanabe polygon;
+
+PROC prepare:
+ continue (channel (plotter))
+END PROC prepare;
+
+PROC initplot:
+ watanabe polygon := "";
+ TEXT VAR watanabe wait;
+ REP
+ UNTIL incharety = "" PER;
+ out("M1500,1500"13""); (* Signal ! *)
+ inchar(watanabe wait);
+ disable stop
+END PROC initplot;
+
+PROC endplot:
+ watanabe pen (0);
+ home;
+ IF is error
+ THEN break (quiet)
+ FI;
+ enable stop
+END PROC endplot;
+
+PROC clear:
+ watanabe pen (1)
+END PROC clear;
+
+PROC home:
+ draw watanabe polygon;
+ out ("H" + terminator)
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ draw watanabe polygon;
+ out ( "M" + text(x) + "," + text(y) + terminator)
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ watanabe polygon CAT "," + text (x) + "," + text (y)
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ move to (x,y);
+ out ("N1" + terminator)
+END PROC setpixel;
+
+PROC foreground (INT VAR type):
+ type := min (max (type, 0), 6);
+ watanabe pen (type)
+END PROC foreground;
+
+PROC background (INT VAR type):
+ type := 0
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ std circle (x,y,rad,from,to)
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1,y1,x2,y2,pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+END PROC fill;
+
+
diff --git a/app/mpg/2.2/src/ZEICHENSATZ b/app/mpg/2.2/src/ZEICHENSATZ
new file mode 100644
index 0000000..0414682
--- /dev/null
+++ b/app/mpg/2.2/src/ZEICHENSATZ
Binary files differ
diff --git a/app/mpg/2.2/src/matrix printer b/app/mpg/2.2/src/matrix printer
new file mode 100644
index 0000000..66157cf
--- /dev/null
+++ b/app/mpg/2.2/src/matrix printer
@@ -0,0 +1,130 @@
+(* Version vom 21.10.87 BJ *)
+(* Standardoperationen *)
+(* printer line - Linienalgorithmus *)
+(* printer fill - Fuellalgorithmus *)
+
+PROC printer line (INT CONST x1,y1,x2,y2,
+ PROC (INT CONST, INT CONST) p set pixel):
+ INT VAR x,y,z,
+ a,b,d,
+ dx :: abs(x2-x1),
+ dy :: abs(y2-y1),
+ dp,dq;
+ IF dx <> 0 AND dy <> 0
+ THEN IF dy <= dx
+ THEN draw line 1
+ ELSE draw line 2
+ FI
+ ELSE IF dx = 0 AND dy <> 0
+ THEN draw vertical line
+ ELSE draw horizontal line
+ FI
+ FI.
+
+ draw line 1:
+ x := x1;
+ y := y1;
+ z := x2;
+ a := sign(x2-x1);
+ b := sign(y2-y1);
+ dp := dy * 2;
+ d := dp - dx;
+ dq := dp - 2 * dx;
+ setpoint;
+ WHILE x <> z REP
+ x := x + a;
+ IF d < 0
+ THEN d := d + dp
+ ELSE y := y + b;
+ d := d + dq
+ FI;
+ setpoint
+ PER.
+
+ draw line 2:
+ x := x1;
+ y := y1;
+ z := y2;
+ b := sign(x2-x1);
+ a := sign(y2-y1);
+ dp := dx * 2;
+ d := dp - dy;
+ dq := dp - 2 * dy;
+ setpoint;
+ WHILE y <> z REP
+ y := y + a;
+ IF d < 0
+ THEN d := d + dp
+ ELSE x := x + b;
+ d := d + dq
+ FI;
+ setpoint
+ PER.
+
+ draw vertical line:
+ a := sign(y2-y1);
+ x := x1;
+ y := y1;
+ z := y2;
+ setpoint;
+ WHILE y <> z REP
+ y := y + a;
+ setpoint
+ PER.
+
+ draw horizontal line:
+ a := sign(x2-x1);
+ x := x1;
+ y := y1;
+ z := x2;
+ setpoint;
+ WHILE x <> z REP
+ x := x + a;
+ setpoint
+ PER.
+
+ setpoint:
+ p set pixel (x,y)
+END PROC printer line;
+
+PROC printer fill (INT CONST xl, xr, y, dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset):
+ INT VAR xl1 :: xl;
+ WHILE point(xl1,y) REP
+ xl1 INCR 1;
+ IF xl1 >= xr
+ THEN LEAVE printer fill
+ FI
+ PER;
+ INT VAR xrn :: xl1+1,
+ xln :: xl1;
+ WHILE NOT point(xrn,y) REP
+ pset(xrn,y);
+ xrn INCR 1
+ PER;
+ WHILE NOT point(xln,y) REP
+ pset(xln,y);
+ xln DECR 1
+ PER;
+ IF xrn > xr
+ THEN printer fill (xr, xrn-1,y-dir,-dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset)
+ ELSE printer fill (xrn, xr, y, dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset)
+ FI;
+ IF xln < xl
+ THEN printer fill (xln+1,xl, y-dir,-dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset)
+ ELSE printer fill (xl,xln, y, dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset)
+ FI;
+ printer fill(xln+1, xrn-1, y+dir, dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset)
+END PROC printer fill;
+
diff --git a/app/mpg/2.2/src/printer.targets b/app/mpg/2.2/src/printer.targets
new file mode 100644
index 0000000..c4e4e53
--- /dev/null
+++ b/app/mpg/2.2/src/printer.targets
@@ -0,0 +1,3 @@
+2/NEC P 9\#fonttab.nec.p9
+3/NEC P 3\#fonttab.nec.p3-2
+
diff --git a/app/mpg/2.2/src/std primitives b/app/mpg/2.2/src/std primitives
new file mode 100644
index 0000000..ab3877c
--- /dev/null
+++ b/app/mpg/2.2/src/std primitives
@@ -0,0 +1,80 @@
+PROC std circle (INT CONST xp,yp,r,from,to):
+ moveto (xp,yp);
+ REAL VAR ang :: real (from MOD 360),
+ rad :: real(r),
+ max :: endwinkel,
+ cx :: real (xp),
+ cy :: real (yp),
+ ax0 :: cx,
+ ay0 :: cy,
+ ax1, ay1;
+
+ BOOL VAR fullcircle :: ang = 0.0 AND max = 360.0;
+ IF fullcircle
+ THEN move to (int (cx + rad * cosd (ang)+0.5),
+ int (cy + rad * -sind (ang)+0.5));
+ ang INCR 1.0
+ FI;
+ WHILE ang <= max REP
+ ax1 := cx + rad * cosd (ang);
+ ay1 := cy + rad * -sind (ang);
+ draw arc;
+ ang INCR 1.0
+ PER;
+ IF NOT fullcircle
+ THEN ax0 := cx;
+ ay0 := cy;
+ draw arc;
+ draw to (xp,yp)
+ ELSE move to (xp,yp)
+ FI.
+
+ draw arc:
+ IF clipped line (ax0,ay0,ax1,ay1)
+ THEN draw to (int (ax1+0.5), int (ay1+0.5))
+ FI;
+ ax0 := ax1;
+ ay0 := ay1.
+
+ endwinkel:
+ IF (to MOD 360) = 0
+ THEN 360.0
+ ELSE real (to MOD 360)
+ FI
+END PROC std circle;
+
+PROC std box (INT CONST x0, y0, x1, y1, pattern):
+ REAL VAR xx0 :: real (x0),
+ yy0 :: real (y0),
+ xx1 :: real (x0),
+ yy1 :: real (y1);
+ IF clipped line (xx0,yy0,xx1,yy1)
+ THEN moveto (int (xx0), int (yy0));
+ drawto (int (xx1), int (yy1))
+ FI;
+ xx0 := real (x0);
+ yy0 := real (y1);
+ xx1 := real (x1);
+ yy1 := real (y1);
+ IF clipped line (xx0,yy0,xx1,yy1)
+ THEN moveto (int (xx0), int (yy0));
+ drawto (int (xx1), int (yy1))
+ FI;
+ xx0 := real (x1);
+ yy0 := real (y1);
+ xx1 := real (x1);
+ yy1 := real (y0);
+ IF clipped line (xx0,yy0,xx1,yy1)
+ THEN moveto (int (xx0), int (yy0));
+ drawto (int (xx1), int (yy1))
+ FI;
+ xx0 := real (x1);
+ yy0 := real (y0);
+ xx1 := real (x0);
+ yy1 := real (y0);
+ IF clipped line (xx0,yy0,xx1,yy1)
+ THEN moveto (int (xx0), int (yy0));
+ drawto (int (xx1), int (yy1))
+ FI
+END PROC std box;
+
diff --git a/app/mpg/2.2/src/terminal plot b/app/mpg/2.2/src/terminal plot
new file mode 100644
index 0000000..21a17ff
--- /dev/null
+++ b/app/mpg/2.2/src/terminal plot
@@ -0,0 +1,114 @@
+(* Prozeduren zur Ausgabe auf ASCII-Terminals *)
+INT CONST up := 1 ,
+ right := 1 ,
+ down := -1 ,
+ left := -1 ;
+
+INT VAR x pos := 0 ,
+ y pos := 0 ,
+ new x pos ,
+ new y pos ;
+
+BOOL VAR plot := FALSE;
+TEXT CONST empty line :: 79 * " ";
+ROW 24 TEXT VAR display;
+
+
+PROC plot vector (INT CONST dx , dy) :
+
+ IF dx >= 0
+ THEN IF dy > dx THEN vector (y pos, x pos, dy, dx, up, right)
+ ELIF dy > 0 THEN vector (x pos, y pos, dx, dy, right, up)
+
+ ELIF dy > -dx THEN vector (x pos, y pos, dx, -dy, right, down)
+ ELSE vector (y pos, x pos, -dy, dx, down, right)
+ FI
+ ELSE IF dy > -dx THEN vector (y pos, x pos, dy, -dx, up, left)
+ ELIF dy > 0 THEN vector (x pos, y pos, -dx, dy, left, up)
+
+ ELIF dy > dx THEN vector (x pos, y pos, -dx, -dy, left, down)
+ ELSE vector (y pos, x pos, -dy, -dx, down, left)
+ FI
+ FI .
+
+ENDPROC plot vector ;
+
+PROC vector (INT VAR x pos, y pos, INT CONST dx, dy, right, up) :
+
+ prepare first step ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO dx REP
+ do one step
+ PER .
+
+prepare first step :
+ point;
+ INT VAR old error := 0 ,
+ up right error := dy - dx ,
+ right error := dy .
+
+do one step :
+ IF right is better
+ THEN do right step
+ ELSE do up right step
+ FI .
+
+right is better :
+ abs (old error + right error) < abs (old error + up right error) .
+
+do upright step :
+ x pos INCR right ;
+ y pos INCR up ;
+ point ;
+ old error INCR upright error .
+
+do right step :
+ x pos INCR right ;
+ point ;
+ old error INCR right error .
+
+ENDPROC vector ;
+
+
+PROC point :
+ IF x pos < 1
+ THEN x pos := 1
+ ELIF x pos > 78
+ THEN x pos := 78 FI;
+
+ IF y pos < 1
+ THEN y pos := 1
+ ELIF y pos > 47
+ THEN y pos := 47 FI;
+
+ INT CONST line :: y pos DIV 2;
+ BOOL CONST above :: (y pos MOD 2) = 1;
+ TEXT CONST point :: display [line+1] SUB (x pos+1),
+ new point :: calculated point;
+
+ replace (display [line+1], x pos+1, new point);
+ cursor (x pos, 24-line);
+ out (new point) .
+
+calculated point :
+ IF above
+ THEN IF point = "," OR point = "|"
+ THEN "|"
+ ELSE "'" FI
+ ELSE IF point = "'" OR point = "|"
+ THEN "|"
+ ELSE "," FI
+ FI
+
+END PROC point;
+
+REAL CONST real max int := real (max int);
+INT PROC round (REAL CONST x) :
+ IF x > real max int
+ THEN max int
+ ELIF x < 0.0
+ THEN 0
+ ELSE int (x + 0.5) FI
+
+END PROC round;
+