From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 4 Feb 2019 13:09:03 +0100 Subject: Initial import --- app/mpg/2.2/doc/GRAPHIK.dok.e | 2235 +++++++++++++++++++++ app/mpg/2.2/source-disk | 4 + app/mpg/2.2/src/AMPEX 2-1-6.GCONF | 84 + app/mpg/2.2/src/AMPEX 3-1-4.GCONF | 84 + app/mpg/2.2/src/Atari 3-9.GCONF | 119 ++ app/mpg/2.2/src/DATAGRAPH 3-7.GCONF | 119 ++ app/mpg/2.2/src/ENVIRONMENT2.GCONF | 5 + app/mpg/2.2/src/ENVIRONMENT3.GCONF | 7 + app/mpg/2.2/src/FKT.help | 24 + app/mpg/2.2/src/GRAPHIK.Basis | 1574 +++++++++++++++ app/mpg/2.2/src/GRAPHIK.Configurator | 946 +++++++++ app/mpg/2.2/src/GRAPHIK.Fkt | 1379 +++++++++++++ app/mpg/2.2/src/GRAPHIK.Install | 84 + app/mpg/2.2/src/GRAPHIK.Manager | 925 +++++++++ app/mpg/2.2/src/GRAPHIK.Plot | 1237 ++++++++++++ app/mpg/2.2/src/GRAPHIK.Turtle | 139 ++ app/mpg/2.2/src/GRAPHIK.list | 28 + app/mpg/2.2/src/HERCULES XT.GCONF | 105 + app/mpg/2.2/src/Muster | 75 + app/mpg/2.2/src/NEC P-3 3-15.GCONF | 126 ++ app/mpg/2.2/src/NEC P-6 MD.GCONF | 221 +++ app/mpg/2.2/src/NEC P-9 2-15.HD.GCONF | 244 +++ app/mpg/2.2/src/NEC P-9 2-15.MD.GCONF | 221 +++ app/mpg/2.2/src/PUBLIC.insert | 3412 +++++++++++++++++++++++++++++++++ app/mpg/2.2/src/VC 404 2-7.GCONF | 93 + app/mpg/2.2/src/VIDEOSTAR 3-6.GCONF | 92 + app/mpg/2.2/src/WATANABE 3-8.GCONF | 94 + app/mpg/2.2/src/ZEICHENSATZ | Bin 0 -> 9216 bytes app/mpg/2.2/src/matrix printer | 130 ++ app/mpg/2.2/src/printer.targets | 3 + app/mpg/2.2/src/std primitives | 80 + app/mpg/2.2/src/terminal plot | 114 ++ 32 files changed, 14003 insertions(+) create mode 100644 app/mpg/2.2/doc/GRAPHIK.dok.e create mode 100644 app/mpg/2.2/source-disk create mode 100644 app/mpg/2.2/src/AMPEX 2-1-6.GCONF create mode 100644 app/mpg/2.2/src/AMPEX 3-1-4.GCONF create mode 100644 app/mpg/2.2/src/Atari 3-9.GCONF create mode 100644 app/mpg/2.2/src/DATAGRAPH 3-7.GCONF create mode 100644 app/mpg/2.2/src/ENVIRONMENT2.GCONF create mode 100644 app/mpg/2.2/src/ENVIRONMENT3.GCONF create mode 100644 app/mpg/2.2/src/FKT.help create mode 100644 app/mpg/2.2/src/GRAPHIK.Basis create mode 100644 app/mpg/2.2/src/GRAPHIK.Configurator create mode 100644 app/mpg/2.2/src/GRAPHIK.Fkt create mode 100644 app/mpg/2.2/src/GRAPHIK.Install create mode 100644 app/mpg/2.2/src/GRAPHIK.Manager create mode 100644 app/mpg/2.2/src/GRAPHIK.Plot create mode 100644 app/mpg/2.2/src/GRAPHIK.Turtle create mode 100644 app/mpg/2.2/src/GRAPHIK.list create mode 100644 app/mpg/2.2/src/HERCULES XT.GCONF create mode 100644 app/mpg/2.2/src/Muster create mode 100644 app/mpg/2.2/src/NEC P-3 3-15.GCONF create mode 100644 app/mpg/2.2/src/NEC P-6 MD.GCONF create mode 100644 app/mpg/2.2/src/NEC P-9 2-15.HD.GCONF create mode 100644 app/mpg/2.2/src/NEC P-9 2-15.MD.GCONF create mode 100644 app/mpg/2.2/src/PUBLIC.insert create mode 100644 app/mpg/2.2/src/VC 404 2-7.GCONF create mode 100644 app/mpg/2.2/src/VIDEOSTAR 3-6.GCONF create mode 100644 app/mpg/2.2/src/WATANABE 3-8.GCONF create mode 100644 app/mpg/2.2/src/ZEICHENSATZ create mode 100644 app/mpg/2.2/src/matrix printer create mode 100644 app/mpg/2.2/src/printer.targets create mode 100644 app/mpg/2.2/src/std primitives create mode 100644 app/mpg/2.2/src/terminal plot (limited to 'app/mpg') 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: Dimension : 2- oder 3-D + Zeichenstift-Nummer + <...> Objekteinträge + + Die Objekteinträge haben folgendes Format: + Objektcode <...> Parameter. + + Objektcodes für: > Die Parameter entsprechen der + - draw 1 Parameterfolge der Prozeduren. + - move 2 + - text 3 > Vor dem Text wird als 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: + //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: ".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 /, .... ; + - 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. + - : (INT) Stationsnummer des Endgerätes + (eigene Station) + - : (INT) Kanalnummer des Endgerätes + + 1.5 #ib(2," (1.5)")#PLOTTER#ie(2,"")# + Syntax: PLOTTER "Endgerätname",,, + ,,,; + - Dient zur Erkennung als Endgerät-Konfigurationsdatei, und zur + Übergabe der verwaltungsseitig benötigten + Endgerät-Spezifikationen: + - "Endgerätname": (TEXT) Name des Endgerätes + - : (INT) Stationsnummer des Endgerätes + (eigene Station) + - : (INT) Kanalnummer des Endgerätes + Jedes Endgerät wird über diese drei Werte eindeutig identifiziert, + der Endgerätname kann also mehrfach verwendet werden. + - : (INT) X-Rasterkoordinate des letzten + Pixels in X-Richtung (i.d.R + adressierbare Pixel - 1) + - : (INT) Y-Rasterkoordinate des letzten + Pixels in Y-Richtung (s.o.) + - : (REAL) Breite der Zeichenfläche in cm. + - : (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: + + -  : Die alte Zeichnung wird gelöscht. + -  : Der Name wird erneut zur Änderung angeboten. + -  : 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: + + ­ : Die nachfolgenden Texte werden zusätzlich zu den schon + vorhandenen Beschriftungen angefügt. + ­ : Die vorhandenen Beschriftungen werden gelöscht, und es wird + zum Menue zurückgekehrt. + ­ : 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 @@ +* : Funktionsterm waehlen bzw. umwaehlen * +* : Definitionsbereich setzen * +* ACHTUNG : Untergrenze < Obergrenze * +* : Anzahl der Stuetzpunkte waehlen; 2 <= s <= 512 * +* : Wertebereich wird ermittelt * +* ACHTUNG : Anzahl der Stuetzpunkte * +* : Wertetafel wird erstellt * +* ACHTUNG : Nicht mehr als 512 Werte koennen ermittelt werden* +* : Zeichnung wird erstellt * +* ACHTUNG : Erst Funktionsterm einegeben * +* ACHTUNG : Erst Wertebereich ermitteln lassen * +* : Erstellte Zeichnung zeigen lassen * +* ACHTUNG : Auf Endgeraet achten * +* : Liste aller bereits erstellten Zeichnungen wird gezeigt * +* : Nachkommastellen setzen * +* : Sitzung beenden * +* : Auf Kommandoebene zurueck (nicht in der Task FKT) * +* : Diese Anleitung wird gezeigt * +* : Zeichnungen koennen auf Diskette geschrieben werden * +* : Zeichnungen koennen mit beliebigen Texten versehen werden * +* : Es werden alle Zeichnungen zum Loeschen angeboten * +* <<- ->> : Das Endgeraet umwaehlen. * +*****************VERLASSEN DIESER ANLEITUNG MIT ******************* + 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 = "Standard ot lau ruen 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 "); + 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("oordinatensystem oder 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",,,,,,; + +LINK /,/....; + +COLORS ""; + + . + . + . + + +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 )"); + 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 )"); + 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 Binary files /dev/null and b/app/mpg/2.2/src/ZEICHENSATZ 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; + -- cgit v1.2.3