diff options
Diffstat (limited to 'app/eudas/4.4/src')
| -rw-r--r-- | app/eudas/4.4/src/eudas.dateistruktur | 1690 | ||||
| -rw-r--r-- | app/eudas/4.4/src/eudas.datenverwaltung | 1989 | ||||
| -rw-r--r-- | app/eudas/4.4/src/eudas.drucken | 1891 | ||||
| -rw-r--r-- | app/eudas/4.4/src/eudas.fenster | 238 | ||||
| -rw-r--r-- | app/eudas/4.4/src/eudas.menues | 2616 | ||||
| -rw-r--r-- | app/eudas/4.4/src/eudas.satzanzeige | 993 | ||||
| -rw-r--r-- | app/eudas/4.4/src/eudas.satzzugriffe | 271 | ||||
| -rw-r--r-- | app/eudas/4.4/src/eudas.steuerung | 2761 | ||||
| -rw-r--r-- | app/eudas/4.4/src/eudas.uebersicht | 420 | ||||
| -rw-r--r-- | app/eudas/4.4/src/eudas.verarbeitung | 731 |
10 files changed, 13600 insertions, 0 deletions
diff --git a/app/eudas/4.4/src/eudas.dateistruktur b/app/eudas/4.4/src/eudas.dateistruktur new file mode 100644 index 0000000..b4a57e5 --- /dev/null +++ b/app/eudas/4.4/src/eudas.dateistruktur @@ -0,0 +1,1690 @@ +PACKET eudas dateien + +(*************************************************************************) +(* *) +(* EUDAS-Dateien als indexsequentielle Dateien *) +(* *) +(* Version 05 *) +(* *) +(* Autor: Thomas Berlage *) +(* Stand: 25.04.87 *) +(* *) +(*************************************************************************) + + DEFINES + + EUDAT, +(*dump, Test *) + oeffne, + satznr, + dateiende, + saetze, + auf satz, + weiter, + zurueck, + satz lesen, + satz aendern, + satz loeschen, + satz einfuegen, + feld lesen, + feld aendern, + feld bearbeiten, + felderzahl, + feldnamen lesen, + feldnamen aendern, + notizen lesen, + notizen aendern, + feldinfo, + automatischer schluessel, + dezimalkomma, + wert berechnen, + reorganisiere, + sortiere, + sortierreihenfolge, + unsortierte saetze : + + +LET + maxhash = 531, + maxindex = 121, + maxsatz = 5000, + eudat typ = 3243, + maxeintrag = 64, + dreiviertel maxeintrag = 48; + +LET + INTVEC = TEXT, + + INDEX = STRUCT + (INT vorgaenger, nachfolger, + INT eintraege, stelle, + INTVEC satzindex), + + EINTRAG = STRUCT + (INT vorgaenger, nachfolger, indexblock, attribut, + SATZ satz), + + DATEI = STRUCT + (INT felderzahl, + SATZ feldnamen, + INTVEC feldinfo, + TEXT sortierfelder, + INT letzter index, indexblocks, erster leerindex, + INT erster leersatz, anz satzeintraege, + INT anz saetze, satznr, + INT indexzeiger, indexstelle, satzzeiger, + INT anz unsortierte, schluesselzaehler, + ROW 3 TEXT notizen, + ROW maxhash INT hashliste, + ROW maxindex INDEX index, + ROW maxsatz EINTRAG ablage); + +TYPE EUDAT = BOUND DATEI; + +LET + niltext = ""; + +LET + datei ist keine eudas datei = #201# + "Datei ist keine EUDAS-Datei", + inkonsistente datei = #202# + "inkonsistente EUDAS-Datei", + eudas datei voll = #203# + "EUDAS-Datei voll", + nicht erlaubtes dezimalkomma = #204# + "Nicht erlaubtes Dezimalkomma"; + +TEXT VAR + feldpuffer; + +TEXT VAR + inttext := " "; + +INTVEC CONST + blockreservierung := intvec (maxeintrag, 1); + + +(*************************** Test-Dump ***********************************) +(* +PROC dump (EUDAT CONST datei, TEXT CONST file) : + + FILE VAR f := sequential file (output, file); + idump (CONCR (datei), f) + +END PROC dump; + +PROC idump (DATEI CONST datei, FILE VAR f) : + + put (f, "Felderzahl:"); put (f, datei. felderzahl); line (f); + INT VAR i; putline (f, "feldnamen:"); + FOR i FROM 1 UPTO felderzahl (datei. feldnamen) REP + TEXT VAR feld; feld lesen (datei. feldnamen, i, feld); + write (f, feld); write (f, ",") + END REP; line (f); putline (f, "feldinfo:"); + FOR i FROM 1 UPTO length (datei. feldinfo) DIV 2 REP + put (f, datei. feldinfo ISUB i) + END REP; line (f); + put (f, "letzter index:"); put (f, datei. letzter index); + put (f, "indexblocks:"); put (f, datei. indexblocks); + put (f, "erster leerindex:"); put (f, datei. erster leerindex); line (f); + put (f, "erster leersatz:"); put (f, datei. erster leersatz); + put (f, "anz satzeintraege:"); put (f, datei. anz satzeintraege); line (f); + put (f, "anz saetze:"); put (f, datei. anz saetze); + put (f, "satznr:"); put (f, datei.satznr); line (f); + put (f, "indexzeiger:"); put (f, datei. indexzeiger); + put (f, "indexstelle:"); put (f, datei. indexstelle); + put (f, "satzzeiger:"); put (f, datei. satzzeiger); line (f); + put (f, "anz unsortierte:"); put (f, datei. anz unsortierte); line (f); + ROW 10 INT VAR anzahl ketten; + FOR i FROM 1 UPTO 10 REP anzahl ketten (i) := 0 END REP; + FOR i FROM 1 UPTO maxhash REP + INT VAR laenge := 0; + laenge der hashkette bestimmen; + IF laenge > 10 THEN laenge := 10 END IF; + IF laenge > 0 THEN anzahl ketten (laenge) INCR 1 END IF + END REP; + put (f, "Hash:"); + FOR i FROM 1 UPTO 10 REP put (f, anzahl ketten (i)) END REP; line (f); + FOR i FROM 1 UPTO datei. indexblocks REP + put (f, "INDEX"); put (f, i); put (f, "vor:"); put (f, + datei. index (i). vorgaenger); put (f, "nach:"); put (f, + datei. index (i). nachfolger); put (f, "eintraege:"); put (f, + datei. index (i). eintraege); line (f); INT VAR j; + FOR j FROM 1 UPTO length (datei. index (i). satzindex) DIV 2 REP + put (f, datei. index (i). satzindex ISUB j) + END REP; + line (f) + END REP; + FOR i FROM 1 UPTO datei. anz satzeintraege REP + put (f, "SATZ"); put (f,i); put (f, "vor:"); put (f, + datei. ablage (i). vorgaenger); put (f, "nach:"); put (f, + datei. ablage (i). nachfolger); put (f, "index:"); put (f, + datei. ablage (i). indexblock); put (f, "attr:"); put (f, + datei. ablage (i). attribut); line (f); + FOR j FROM 1 UPTO felderzahl (datei. ablage (i). satz) REP + feld lesen (datei. ablage (i). satz, j, feld); + write (f, feld); write (f, ",") + END REP; cout (i); + line (f) + END REP . + +laenge der hashkette bestimmen : + INT VAR index := datei. hashliste (i); + WHILE index <> 0 REP + index := datei. ablage (index). vorgaenger; + laenge INCR 1 + END REP . + +END PROC i dump; +*) + +(**************************** INTVEC *************************************) + +(* An Stelle von maximal dimensionierten ROW max INT werden an ver- *) +(* schiedenen Stellen TEXTe mit eingeschriebenen Integern verwendet. *) +(* Auf diese Art und Weise werden auch das Einfuegen und Loeschen, sowie *) +(* das Aufsplitten und Zusammenfuegen effizienter realisiert. *) + +LET + empty intvec = ""; + +TEXT VAR + buffer; + +INTVEC PROC intvec (INT CONST length, value) : + + replace (inttext, 1, value); + length * inttext + +END PROC intvec; + +PROC insert (INTVEC VAR vector, INT CONST pos, value) : + + INT CONST begin := pos + pos - 1; + IF begin < 1 THEN + subscript underflow + ELIF begin > length (vector) + 1 THEN + subscript overflow + ELSE + replace (inttext, 1, value); + buffer := subtext (vector, begin); + vector := subtext (vector, 1, begin - 1); + vector CAT inttext; + vector CAT buffer + END IF + +END PROC insert; + +PROC delete (INTVEC VAR vector, INT CONST pos) : + + INT CONST begin := pos + pos - 1; + IF begin < 1 THEN + subscript underflow + ELIF begin >= length (vector) THEN + subscript overflow + ELSE + buffer := subtext (vector, begin + 2); + vector := subtext (vector, 1, begin - 1); + vector CAT buffer + END IF + +END PROC delete; + +INT PROC pos (INTVEC CONST vector, INT CONST value) : + + replace (inttext, 1, value); + INT VAR begin := 1; + REP + begin := pos (vector, inttext, begin) + 1 + UNTIL (begin AND 1) = 0 OR begin = 1 END REP; + begin DIV 2 + +END PROC pos; + +PROC split up (INTVEC VAR source, dest, INT CONST pos) : + + INT CONST begin := pos + pos - 1; + IF begin < 1 THEN + subscript underflow + ELIF begin > length (source) + 1 THEN + subscript overflow + ELSE + dest := subtext (source, begin); + source := subtext (source, 1, begin - 1) + END IF + +END PROC split up; + +PROC split down (INTVEC VAR source, dest, INT CONST pos) : + + INT CONST begin := pos + pos - 1; + IF begin < 1 THEN + subscript underflow + ELIF begin > length (source) + 1 THEN + subscript overflow + ELSE + dest := subtext (source, 1, begin - 1); + source := subtext (source, begin) + END IF + +END PROC split down; + +. +subscript overflow : + errorstop (9, niltext) . + +subscript underflow : + errorstop (10, niltext) . + + +(************************** Datei oeffnen ********************************) + +PROC initialisiere eudat (DATEI VAR datei) : + + datei. felderzahl := 0; + datei. feldinfo := empty intvec; + satz initialisieren (datei. feldnamen); + datei. sortierfelder := niltext; + datei. letzter index := 1; + datei. indexblocks := 1; + datei. erster leersatz := 0; + datei. erster leerindex := 0; + datei. anz saetze := 0; + datei. anz satzeintraege := 1; + datei. anz unsortierte := 0; + datei. notizen (1) := niltext; + datei. notizen (2) := niltext; + datei. notizen (3) := niltext; + datei. satznr := 1; + datei. indexzeiger := 1; + datei. indexstelle := 1; + datei. satzzeiger := 1; + datei. index (1). satzindex := blockreservierung; + datei. index (1) := INDEX : (0, 0, 1, 1, intvec(1, 1)); + INT VAR i; + FOR i FROM 1 UPTO maxhash REP + datei. hashliste (i) := 0 + END REP; + datei. ablage (1) := EINTRAG : (0, 0, 1, 0, leersatz) . + +leersatz : + datei. feldnamen . + +END PROC initialisiere eudat; + +PROC oeffne (EUDAT VAR datei, TEXT CONST dateiname) : + + enable stop; + IF NOT exists (dateiname) THEN + CONCR (datei) := new (dateiname); + initialisiere eudat (CONCR (datei)); + type (old (dateiname), eudat typ) + ELIF type (old (dateiname)) = eudat typ THEN + CONCR (datei) := old (dateiname) + ELSE + errorstop (datei ist keine eudas datei) + ENDIF + +END PROC oeffne; + +PROC oeffne (EUDAT VAR datei, DATASPACE CONST ds) : + + IF type (ds) < 0 THEN + CONCR (datei) := ds; + initialisiere eudat (CONCR (datei)); + type (ds, eudat typ) + ELIF type (ds) = eudat typ THEN + CONCR (datei) := ds + ELSE + errorstop (datei ist keine eudas datei) + END IF + +END PROC oeffne; + + +(************************* Feldzugriffe **********************************) + +PROC feld lesen (EUDAT CONST datei, INT CONST feldnr, TEXT VAR inhalt) : + + feld lesen (aktueller satz, feldnr, inhalt) . + +aktueller satz : + datei. ablage (datei. satzzeiger). satz . + +END PROC feld lesen; + +PROC feld aendern (EUDAT VAR datei, INT CONST feldnr, + TEXT CONST neuer inhalt) : + + IF nicht hinter letztem satz THEN + aktueller satz unsortiert (CONCR (datei)); + moeglicherweise schluessel aendern; + feld aendern (aktueller satz, feldnr, neuer inhalt) + END IF . + +nicht hinter letztem satz : + datei. satzzeiger <> 1 . + +moeglicherweise schluessel aendern : + IF feldnr = 1 THEN + disable stop; + schluessel aendern (CONCR (datei), hashindex (neuer inhalt)) + END IF . + +aktueller satz : + datei. ablage (datei. satzzeiger). satz . + +END PROC feld aendern; + +INT PROC felderzahl (EUDAT CONST datei) : + + datei. felderzahl + +END PROC felderzahl; + +PROC feld bearbeiten (EUDAT CONST datei, INT CONST feldnr, + PROC (TEXT CONST, INT CONST, INT CONST) bearbeite) : + + feld bearbeiten (aktueller satz, feldnr, + PROC (TEXT CONST, INT CONST, INT CONST) bearbeite) . + +aktueller satz : + datei. ablage (datei. satzzeiger). satz . + +END PROC feld bearbeiten; + + +(************************* Feldinformationen *****************************) + +(* Jedes Feld der Datei hat einen Namen und eine Typinformation. Die *) +(* Anzahl der vorhandenen Felder richtet sich nach dem hoechsten ver- *) +(* gebenen Feldnamen. 'feldinfo' kann folgende Werte annehmen : *) +(* -1 : normales Textfeld *) +(* 0 : Textfeld, das nach DIN-Norm verglichen wird *) +(* 1 : Zahlfeld (alle irrelevanten Zeichen werden ignoriert) *) +(* 2 : Datum mit einer Laenge von 8 Zeichen *) +(* Das Feldinfo eines noch nicht eingerichteten Feldes fuehrt zu *) +(* einer Fehlermeldung. *) + +PROC feldnamen lesen (EUDAT CONST datei, SATZ VAR namen) : + + namen := datei. feldnamen + +END PROC feldnamen lesen; + +PROC feldnamen aendern (EUDAT VAR datei, SATZ CONST neue namen) : + + datei. feldnamen := neue namen; + INT CONST neue felder := felderzahl (neue namen); + IF neue felder > datei. felderzahl THEN + feldinfo erweitern; + datei. felderzahl := neue felder + END IF . + +feldinfo erweitern : + datei. feldinfo CAT intvec (fehlende zeilen, - 1) . + +fehlende zeilen : + neue felder - length (datei. feldinfo) DIV 2. + +END PROC feldnamen aendern; + +INT PROC feldinfo (EUDAT CONST datei, INT CONST feldnr) : + + datei. feldinfo ISUB feldnr + +END PROC feldinfo; + +PROC feldinfo (EUDAT VAR datei, INT CONST feldnr, zeilen) : + + replace (datei. feldinfo, feldnr, zeilen); + IF pos (datei. sortierfelder, code (feldnr)) > 0 THEN + datei. anz unsortierte := datei. anz saetze + END IF + +END PROC feldinfo; + + +(*************************** Positionsabfragen ***************************) + +INT PROC satznr (EUDAT CONST datei) : + + datei. satznr + +END PROC satznr; + +BOOL PROC dateiende (EUDAT CONST datei) : + + datei. satznr > datei. anz saetze + +END PROC dateiende; + +INT PROC saetze (EUDAT CONST datei) : + + datei. anz saetze + +END PROC saetze; + + +(***************************** Positionieren *****************************) + +(* Positioniert werden kann nach der Satznummer oder nach dem ersten *) +(* Feld. Das erste Feld kann durch eine Hashtabelle schnell gefunden *) +(* werden. In der Hashtabelle sind die Saetze nach absoluten Positionen *) +(* eingetragen und nicht nach Satznummern. Ueber den Rueckverweis auf *) +(* den Indexblock kann die Satznummer zu einem gegebenen Satz gefunden *) +(* werden. *) + +PROC neue satzposition (DATEI VAR datei, INT CONST indexzeiger, stelle, + satznr) : + + IF indexzeiger < 1 OR indexzeiger > datei. indexblocks COR + stelle < 1 OR stelle > datei. index (indexzeiger). eintraege THEN + errorstop (inkonsistente datei) + END IF; + disable stop; + datei. indexzeiger := indexzeiger; + datei. indexstelle := stelle; + datei. satznr := satznr; + datei. satzzeiger := datei. index (indexzeiger). satzindex ISUB stelle + +END PROC neue satzposition; + +PROC auf satz (EUDAT VAR datei, INT CONST nr) : + + INT VAR satznr; + IF nr < 1 THEN + satznr := 1 + ELIF nr > datei. anz saetze THEN + satznr := datei. anz saetze + 1 + ELSE + satznr := nr + END IF; + auf satz intern (CONCR (datei), satznr) + +END PROC auf satz; + +PROC auf satz (EUDAT VAR datei, TEXT CONST muster) : + + auf satz (datei, 1); + IF nicht auf erstem satz THEN + weiter (datei, muster) + END IF . + +nicht auf erstem satz : + feld lesen (datei, 1, feldpuffer); + feldpuffer <> muster . + +END PROC auf satz; + +PROC auf satz intern (DATEI VAR datei, INT CONST satznr) : + + IF von anfang naeher THEN + neue satzposition (datei, 1, 1, 1) + END IF; + INT VAR + indexzeiger := datei. indexzeiger, + erreichter satz := datei. satznr - datei. indexstelle; + IF satznr > datei. satznr THEN + vorwaerts gehen + ELSE + rueckwaerts gehen + END IF; + neue satzposition (datei, indexzeiger, stelle, satznr) . + +von anfang naeher : + satznr + satznr < datei. satznr . + +vorwaerts gehen : + WHILE noch vor satz REP + erreichter satz INCR eintraege; + indexzeiger := datei. index (indexzeiger). nachfolger + END REP . + +noch vor satz : + INT CONST eintraege := datei. index (indexzeiger). eintraege; + erreichter satz + eintraege < satznr . + +rueckwaerts gehen : + WHILE noch hinter satz REP + indexzeiger := datei. index (indexzeiger). vorgaenger; + erreichter satz DECR datei. index (indexzeiger). eintraege + END REP . + +noch hinter satz : + erreichter satz >= satznr . + +stelle : + satznr - erreichter satz . + +END PROC auf satz intern; + +PROC weiter (EUDAT VAR datei) : + + weiter intern (CONCR (datei)) + +END PROC weiter; + +PROC weiter intern (DATEI VAR datei) : + + IF nicht dateiende THEN + naechster satz + END IF . + +nicht dateiende : + datei. satzzeiger <> 1 . + +naechster satz : + INT VAR + indexzeiger := datei. indexzeiger, + stelle := datei. indexstelle; + + IF stelle = index. eintraege THEN + indexzeiger := index. nachfolger; + stelle := 1 + ELSE + stelle INCR 1 + END IF; + neue satzposition (datei, indexzeiger, stelle, datei. satznr + 1) . + +index : + datei. index (indexzeiger) . + +END PROC weiter intern; + +PROC zurueck (EUDAT VAR datei) : + + zurueck intern (CONCR (datei)) + +END PROC zurueck; + +PROC zurueck intern (DATEI VAR datei) : + + IF nicht am anfang THEN + voriger satz + END IF . + +nicht am anfang : + datei. satznr <> 1 . + +voriger satz : + INT VAR + indexzeiger := datei. indexzeiger, + stelle := datei. indexstelle; + + IF stelle = 1 THEN + indexzeiger := indexblock. vorgaenger; + stelle := indexblock. eintraege + ELSE + stelle DECR 1 + END IF; + neue satzposition (datei, indexzeiger, stelle, datei. satznr - 1) . + +indexblock : + datei. index (indexzeiger) . + +END PROC zurueck intern; + +PROC weiter (EUDAT VAR datei, TEXT CONST muster) : + + weiter intern (CONCR (datei), muster) + +END PROC weiter; + +PROC weiter intern (DATEI VAR datei, TEXT CONST muster) : + + stelle in hashkette bestimmen; + WHILE noch weitere saetze CAND muster nicht gefunden REP + eine stelle weiter + END REP; + IF noch weitere saetze THEN + positioniere intern (datei, stelle) + ELSE + auf satz intern (datei, datei. anz saetze + 1) + END IF . + +stelle in hashkette bestimmen : + INT VAR dummy, stelle := datei. satzzeiger; + IF muster nicht gefunden THEN + stelle in hashkette (datei, hashindex (muster), stelle, dummy) + ELSE + eine stelle weiter + END IF . + +noch weitere saetze : + stelle <> 0 . + +muster nicht gefunden : + feld lesen (aktueller satz, 1, feldpuffer); + feldpuffer <> muster . + +aktueller satz : + datei. ablage (stelle). satz . + +eine stelle weiter : + stelle := datei. ablage (stelle). nachfolger . + +END PROC weiter intern; + +PROC zurueck (EUDAT VAR datei, TEXT CONST muster) : + + zurueck intern (CONCR (datei), muster) + +END PROC zurueck; + +PROC zurueck intern (DATEI VAR datei, TEXT CONST muster) : + + stelle in hashkette bestimmen; + WHILE noch weitere saetze CAND muster nicht gefunden REP + eine stelle zurueck + END REP; + IF noch weitere saetze THEN + positioniere intern (datei, stelle) + ELSE + auf satz intern (datei, 1) + END IF . + +stelle in hashkette bestimmen : + INT VAR stelle := datei. satzzeiger, dummy; + IF stelle = 1 OR schluessel stimmt nicht ueberein THEN + stelle in hashkette (datei, hashindex (muster), dummy, stelle) + END IF . + +noch weitere saetze : + stelle <> 0 . + +muster nicht gefunden : + stelle = datei. satzzeiger OR schluessel stimmt nicht ueberein . + +schluessel stimmt nicht ueberein : + feld lesen (aktueller satz, 1, feldpuffer); + feldpuffer <> muster . + +aktueller satz : + datei. ablage (stelle). satz . + +eine stelle zurueck : + stelle := datei. ablage (stelle). vorgaenger . + +END PROC zurueck intern; + +PROC positioniere intern (DATEI VAR datei, INT CONST stelle) : + + INT CONST zielblock := datei. ablage (stelle). indexblock; + INT VAR + indexstelle := 1, + satznr := 0; + WHILE indexstelle <> zielblock REP + satznr INCR datei. index (indexstelle). eintraege; + indexstelle := datei. index (indexstelle). nachfolger + END REP; + indexstelle := pos (datei. index (zielblock). satzindex, stelle); + satznr INCR indexstelle; + neue satzposition (datei, zielblock, indexstelle, satznr) . + +END PROC positioniere intern; + + +(************************* Hashverwaltung ********************************) + +INT VAR index; + +PROC hashindex berechnen (TEXT CONST feld, INT CONST von, bis) : + + INT VAR + zeiger := von; + index := 0; + IF bis - von < 4 THEN + mit faktor 4 streuen + ELSE + mit faktor 2 streuen + END IF; + index := index MOD maxhash + 1 . + +mit faktor 4 streuen : + WHILE zeiger <= bis REP + index := index * 4; + index INCR code (feld SUB zeiger); + zeiger INCR 1 + END REP . + +mit faktor 2 streuen : + WHILE zeiger <= bis REP + index INCR index; + index INCR code (feld SUB zeiger); + IF index > 16000 THEN index := index MOD maxhash END IF; + zeiger INCR 1 + END REP . + +END PROC hashindex berechnen; + +INT PROC hashindex (TEXT CONST feld) : + + hashindex berechnen (feld, 1, length (feld)); + index + +END PROC hashindex; + +INT PROC hashindex (SATZ CONST satz) : + + feld bearbeiten (satz, 1, + PROC (TEXT CONST, INT CONST, INT CONST) hashindex berechnen); + index + +END PROC hashindex; + +PROC stelle in hashkette (DATEI CONST datei, INT CONST hashindex, + INT VAR stelle, vorher) : + + INT VAR indexzeiger := datei. letzter index; + vorher := datei. hashliste (hashindex); + stelle := 0; + BOOL VAR hinter aktuellem satz := TRUE; + WHILE hinter aktuellem satz AND vorher <> 0 REP + stelle untersuchen; + eine stelle weiter + END REP . + +stelle untersuchen : + IF verweis auf aktuellen block THEN + ueberpruefe innerhalb block + ELSE + teste ob aktueller block in indexkette + END IF . + +verweis auf aktuellen block : + datei. ablage (vorher). indexblock = datei. indexzeiger . + +ueberpruefe innerhalb block : + indexzeiger := datei. indexzeiger; + INT CONST stelle in block := pos (satzindex, vorher); + IF stelle in block = 0 THEN + errorstop (inkonsistente datei) + ELIF stelle in block <= aktuelle stelle THEN + hinter aktuellem satz := FALSE + END IF . + +satzindex : + datei. index (indexzeiger). satzindex . + +aktuelle stelle : + datei. indexstelle . + +teste ob aktueller block in indexkette : + WHILE indexzeiger <> datei. ablage (vorher). indexblock REP + IF indexzeiger = datei. indexzeiger THEN + hinter aktuellem satz := FALSE; + LEAVE stelle untersuchen + ELSE + indexzeiger := datei. index (indexzeiger). vorgaenger + END IF + END REP . + +eine stelle weiter : + IF hinter aktuellem satz THEN + stelle := vorher; + vorher := datei. ablage (stelle). vorgaenger + END IF . + +END PROC stelle in hashkette; + +PROC hash ausketten (DATEI VAR datei, INT CONST hashindex) : + + disable stop; + INT CONST + stelle := datei. satzzeiger, + vorgaenger := datei. ablage (stelle). vorgaenger, + nachfolger := datei. ablage (stelle). nachfolger; + + IF nachfolger <> 0 THEN + datei. ablage (nachfolger). vorgaenger := vorgaenger + ELSE + datei. hashliste (hashindex) := vorgaenger + END IF; + IF vorgaenger <> 0 THEN + datei. ablage (vorgaenger). nachfolger := nachfolger + END IF . + +END PROC hash ausketten; + +PROC hash einketten (DATEI VAR datei, INT CONST hashindex, + nachfolger, vorgaenger) : + + disable stop; + INT CONST stelle := datei. satzzeiger; + datei. ablage (stelle). vorgaenger := vorgaenger; + datei. ablage (stelle). nachfolger := nachfolger; + IF vorgaenger <> 0 THEN + datei. ablage (vorgaenger). nachfolger := stelle + END IF; + IF nachfolger <> 0 THEN + datei. ablage (nachfolger). vorgaenger := stelle + ELSE + datei. hashliste (hashindex) := stelle + END IF + +END PROC hash einketten; + + +(************************** Satzzugriffe *********************************) + +PROC satz lesen (EUDAT CONST datei, SATZ VAR satz) : + + satz := datei. ablage (datei. satzzeiger). satz + +END PROC satz lesen; + +PROC satz aendern (EUDAT VAR datei, SATZ CONST neuer satz) : + + IF NOT dateiende (datei) THEN + satz wirklich aendern + END IF . + +satz wirklich aendern : + aktueller satz unsortiert (CONCR (datei)); + disable stop; + schluessel aendern (CONCR (datei), hashindex (neuer satz)); + aktueller satz := neuer satz . + +aktueller satz : + datei. ablage (datei. satzzeiger). satz . + +END PROC satz aendern; + +PROC schluessel aendern (DATEI VAR datei, INT CONST neuer hashindex) : + + IF anderer hashindex THEN + in neue hashkette + END IF . + +anderer hashindex : + INT CONST alter hashindex := hashindex (aktueller satz); + alter hashindex <> neuer hashindex . + +in neue hashkette : + in alter kette ausketten; + in neuer kette einketten . + +in alter kette ausketten : + hash ausketten (datei, alter hashindex) . + +in neuer kette einketten : + INT VAR vorgaenger, nachfolger; + stelle in hashkette (datei, neuer hashindex, vorgaenger, nachfolger); + hash einketten (datei, neuer hashindex, vorgaenger, nachfolger) . + +aktueller satz : + datei. ablage (datei. satzzeiger). satz . + +END PROC schluessel aendern; + +PROC satz loeschen (EUDAT VAR datei) : + + IF NOT dateiende (datei) THEN + satz wirklich loeschen + END IF . + +satz wirklich loeschen : + disable stop; + satzeintrag loeschen (CONCR (datei)); + indexeintrag loeschen (CONCR (datei)); + datei. anz saetze DECR 1 . + +END PROC satz loeschen; + +PROC satzeintrag loeschen (DATEI VAR datei) : + + aktueller satz sortiert (datei); + INT CONST stelle := datei. satzzeiger; + hash ausketten (datei, hashindex (aktueller satz)); + datei. ablage (stelle). nachfolger := datei. erster leersatz; + datei. erster leersatz := stelle . + +aktueller satz : + datei. ablage (stelle). satz . + +END PROC satzeintrag loeschen; + +PROC satz einfuegen (EUDAT VAR datei, SATZ CONST neuer satz) : + + satz einfuegen intern (CONCR (datei), neuer satz) + +END PROC satz einfuegen; + +PROC satz einfuegen intern (DATEI VAR datei, SATZ CONST neuer satz) : + + INT VAR + stelle, + vorgaenger, + nachfolger; + + enable stop; + satzeintrag belegen; + ggf schluessel einfuegen; + disable stop; + datei. anz saetze INCR 1; + indexeintrag einfuegen (datei, stelle); + INT CONST neuer index := hashindex (feldpuffer); + stelle in hashkette (datei, neuer index, nachfolger, vorgaenger); + hash einketten (datei, neuer index, nachfolger, vorgaenger); + aktueller satz unsortiert (datei) . + +satzeintrag belegen : + IF datei. erster leersatz <> 0 THEN + stelle := datei. erster leersatz; + datei. erster leersatz := datei. ablage (stelle). nachfolger + ELIF datei. anz satzeintraege = maxsatz THEN + errorstop (eudas datei voll) + ELSE + datei. anz satzeintraege INCR 1; + stelle := datei. anz satzeintraege + END IF; + datei. ablage (stelle). attribut := 0; + datei. ablage (stelle). satz := neuer satz . + +ggf schluessel einfuegen : + feld lesen (neuer satz, 1, feldpuffer); + IF datei. schluesselzaehler > 0 THEN + IF feldpuffer = "" THEN + neuen schluessel erzeugen; + feld aendern (datei. ablage (stelle). satz, 1, feldpuffer) + END IF + END IF . + +neuen schluessel erzeugen : + feldpuffer := text (datei. schluesselzaehler); + feldpuffer := fuehrende nullen + feldpuffer; + IF datei. schluesselzaehler > 32000 THEN + datei. schluesselzaehler := 1 + ELSE + datei. schluesselzaehler INCR 1 + END IF . + +fuehrende nullen : + (4 - length (feldpuffer)) * "0" . + +END PROC satz einfuegen intern; + +PROC automatischer schluessel (EUDAT VAR eudat, BOOL CONST automatisch) : + + IF automatisch AND eudat. schluesselzaehler < 0 OR + NOT automatisch AND eudat. schluesselzaehler > 0 THEN + eudat. schluesselzaehler := - eudat. schluesselzaehler + END IF + +END PROC automatischer schluessel; + +BOOL PROC automatischer schluessel (EUDAT CONST eudat) : + + eudat. schluesselzaehler > 0 + +END PROC automatischer schluessel; + + +(************************* Indexverwaltung *******************************) + +(* Die logische Reihenfolge der Saetze wird durch einen Index herge- *) +(* stellt. Dieser besteht aus einer Liste von INTVECs. Ein Listenelement *) +(* nimmt Satzeintraege auf, bis die Maximalgroesse erreicht ist. In *) +(* diesem Fall wird ein neues Listenelement eingefuegt. Beim Loeschen *) +(* von Eintraegen wird ueberprueft, ob zwei benachbarte Eintraege kom- *) +(* biniert werden koennen. Steht fuer eine Anforderung kein Eintrag mehr *) +(* zur Verfuegung, wird der ganze Index reorganisiert. Es ist garantiert,*) +(* dass der Index die maximale Anzahl von Satzeintraegen aufnehmen kann. *) + +INTVEC VAR indexpuffer; + + +PROC indexeintrag loeschen (DATEI VAR datei) : + + INT CONST + indexzeiger := datei. indexzeiger, + vorgaenger := index. vorgaenger, + nachfolger := index. nachfolger; + BOOL VAR moeglich; + delete (index. satzindex, datei. indexstelle); + index. eintraege DECR 1; + indizes zusammenlegen (datei, indexzeiger, nachfolger, moeglich); + IF NOT moeglich THEN + indizes zusammenlegen (datei, vorgaenger, indexzeiger, moeglich) + END IF; + indexzeiger justieren (datei) . + +index : + datei. index (indexzeiger) . + +END PROC indexeintrag loeschen; + +PROC indizes zusammenlegen (DATEI VAR datei, INT CONST zeiger, folgezeiger, + BOOL VAR moeglich) : + + moeglich := FALSE; + IF zeiger <> 0 AND folgezeiger <> 0 THEN + versuche zusammenzulegen + END IF . + +versuche zusammenzulegen : + INT CONST + eintraege a := index. eintraege, + eintraege b := folgeindex. eintraege; + IF zusammenlegbar THEN + wirklich zusammenlegen; + moeglich := TRUE + END IF . + +zusammenlegbar: + eintraege a + eintraege b <= dreiviertel maxeintrag OR + eintraege a = 0 OR eintraege b = 0 . + +wirklich zusammenlegen : + index. eintraege INCR folgeindex. eintraege; + indexverweise aendern (datei, folgeindex. satzindex, zeiger); + index. satzindex CAT folgeindex. satzindex; + folgeindex ausketten . + +folgeindex ausketten : + index. nachfolger := folgeindex. nachfolger; + IF index. nachfolger <> 0 THEN + datei. index (index. nachfolger). vorgaenger := zeiger + ELSE + datei. letzter index := zeiger + END IF; + folgeindex. nachfolger := datei. erster leerindex; + datei. erster leerindex := folgezeiger . + +index : + datei. index (zeiger) . + +folgeindex : + datei. index (folgezeiger) . + +END PROC indizes zusammenlegen; + +PROC indexzeiger justieren (DATEI VAR datei) : + + INT CONST aktueller satz := datei. satznr; + neue satzposition (datei, 1, 1, 1); + auf satz intern (datei, aktueller satz) + +END PROC indexzeiger justieren; + +PROC indexverweise aendern (DATEI VAR datei, INTVEC CONST satzindex, + INT CONST zeiger) : + + INT VAR i; + FOR i FROM 1 UPTO length (satzindex) DIV 2 REP + datei. ablage (satzindex ISUB i). indexblock := zeiger + END REP + +END PROC indexverweise aendern; + +PROC indexeintrag einfuegen (DATEI VAR datei, INT CONST eintrag) : + + INT VAR indexzeiger := datei. indexzeiger; + IF index. eintraege >= maxeintrag THEN + platz schaffen + END IF; + index. eintraege INCR 1; + insert (index. satzindex, datei. indexstelle, eintrag); + datei. satzzeiger := eintrag; + datei. ablage (eintrag). indexblock := indexzeiger . + +platz schaffen : + INT VAR neuer index := 0; + neuen indexblock besorgen; + IF neuer index <> 0 THEN + index aufsplitten + ELSE + index reorganisieren (datei) + END IF; + indexzeiger justieren (datei); + indexzeiger := datei. indexzeiger . + +neuen indexblock besorgen : + IF datei. erster leerindex <> 0 THEN + neuer index := datei. erster leerindex; + datei. erster leerindex := folgeindex. nachfolger + ELIF datei. indexblocks < maxindex THEN + datei. indexblocks INCR 1; + neuer index := datei. indexblocks; + folgeindex. satzindex := blockreservierung + END IF . + +index aufsplitten : + neuen block einketten; + splitpunkt bestimmen; + folgeindex. eintraege := index. eintraege - halbe eintraege; + split up (index. satzindex, folgeindex. satzindex, halbe eintraege + 1); + index. eintraege := halbe eintraege; + indexverweise aendern (datei, folgeindex. satzindex, neuer index) . + +neuen block einketten : + INT CONST alter nachfolger := index. nachfolger; + IF alter nachfolger <> 0 THEN + datei. index (alter nachfolger). vorgaenger := neuer index + ELSE + datei. letzter index := neuer index + END IF; + folgeindex. nachfolger := alter nachfolger; + folgeindex. vorgaenger := indexzeiger; + index. nachfolger := neuer index . + +splitpunkt bestimmen : + INT VAR halbe eintraege; + IF letzter block THEN + halbe eintraege := dreiviertel maxeintrag + ELSE + halbe eintraege := index. eintraege DIV 2 + 1 + END IF . + +letzter block : + alter nachfolger = 0 . + +index : + datei. index (indexzeiger) . + +folgeindex : + datei. index (neuer index) . + +END PROC indexeintrag einfuegen; + +PROC index reorganisieren (DATEI VAR datei) : + + INT VAR indexzeiger := 1; + REP + index auffuellen; + zum naechsten index + END REP . + +index auffuellen : + BOOL VAR moeglich; + REP + INT CONST nachfolger := index. nachfolger; + indizes zusammenlegen (datei, indexzeiger, nachfolger, moeglich) + UNTIL NOT moeglich END REP; + IF nachfolger = 0 THEN + LEAVE index reorganisieren + ELIF noch platz THEN + rest auffuellen + END IF . + +noch platz : + INT CONST platz := dreiviertel maxeintrag - index. eintraege; + platz > 0 . + +rest auffuellen : + split down (folgeindex. satzindex, indexpuffer, platz + 1); + folgeindex. eintraege DECR platz; + indexverweise aendern (datei, indexpuffer, indexzeiger); + index. satzindex CAT indexpuffer; + index. eintraege := dreiviertel maxeintrag . + +zum naechsten index : + indexzeiger := nachfolger . + +index : + datei. index (indexzeiger) . + +folgeindex : + datei. index (nachfolger) . + +END PROC index reorganisieren; + + +(************************* Sortierabfragen *******************************) + +TEXT VAR dez komma := ","; + +LET + sortmask = 1; + +TEXT PROC dezimalkomma : + + dez komma + +END PROC dezimalkomma; + +PROC dezimalkomma (TEXT CONST neues komma) : + + IF length (neues komma) <> 1 THEN + errorstop (nicht erlaubtes dezimalkomma) + ELSE + dez komma := neues komma + ENDIF + +END PROC dezimalkomma; + +INT PROC unsortierte saetze (EUDAT CONST datei) : + + datei. anz unsortierte + +END PROC unsortierte saetze; + +TEXT PROC sortierreihenfolge (EUDAT CONST datei) : + + datei. sortierfelder + +END PROC sortierreihenfolge; + +PROC aktueller satz unsortiert (DATEI VAR datei) : + + IF sortiert (datei) THEN + disable stop; + datei. ablage (datei. satzzeiger). attribut INCR sortmask; + datei. anz unsortierte INCR 1 + END IF + +END PROC aktueller satz unsortiert; + +PROC aktueller satz sortiert (DATEI VAR datei) : + + IF NOT sortiert (datei) THEN + disable stop; + datei. ablage (datei. satzzeiger). attribut DECR sortmask; + datei. anz unsortierte DECR 1 + END IF + +END PROC aktueller satz sortiert; + +BOOL PROC sortiert (DATEI CONST datei, INT CONST stelle) : + + (datei. ablage (stelle). attribut AND sortmask) = 0 + +END PROC sortiert; + +BOOL PROC sortiert (DATEI CONST datei) : + + sortiert (datei, datei. satzzeiger) + +END PROC sortiert; + + +(************************* Sortieren *************************************) + +(* Eine Datei kann in einer beliebigen Feldreihenfolge sortiert werden. *) +(* Dabei wird das Feldinfo beachtet. Wurden seit der letzten Sortierung *) +(* nur wenige Saetze geaendert (deren Plaetze in 'unsortierte' gespei- *) +(* chert sind), werden nur diese Saetze einsortiert. *) + +INTVEC VAR sortierinfo; + +TEXT VAR sortierfelder; + +TEXT VAR l, r; + + +PROC sortiere (EUDAT VAR datei) : + + sortierfelder := datei. sortierfelder; + IF sortierfelder = niltext THEN + standardbelegung + END IF; + sortiere intern (CONCR (datei)) . + +standardbelegung : + INT VAR i; + FOR i FROM 1 UPTO datei. felderzahl REP + sortierfelder CAT code (i) + END REP . + +END PROC sortiere; + +PROC sortiere (EUDAT VAR datei, TEXT CONST felder) : + + sortierfelder := felder; + sortiere intern (CONCR (datei)) + +END PROC sortiere; + +PROC sortiere intern (DATEI VAR datei) : + + IF datei. sortierfelder <> sortierfelder THEN + datei. sortierfelder := sortierfelder; + datei. anz unsortierte := datei. anz saetze + 1 + ELIF datei. anz unsortierte = 0 THEN + LEAVE sortiere intern + END IF; + sortierinfo := datei. feldinfo; + IF mehr als ein drittel THEN + komplett sortieren (datei); + datei. anz unsortierte := 0 + ELSE + einzeln sortieren (datei) + END IF; + auf satz intern (datei, 1) . + +mehr als ein drittel : + datei. anz saetze DIV datei. anz unsortierte < 3 . + +END PROC sortiere intern; + +PROC komplett sortieren (DATEI VAR datei) : + + INT VAR + satzzeiger, + satz := 1, + satz vorher; + + auf satz intern (datei, 1); + aktueller satz sortiert (datei); + satzzeiger := datei. satzzeiger; + WHILE noch satz vorhanden REP + zum naechsten satz; + satz richtig einsortieren; + cout (satz) + END REP; + disable stop; + index reorganisieren (datei); + neue satzposition (datei, 1, 1, 1) . + +noch satz vorhanden : + satz < datei. anz saetze . + +zum naechsten satz : + satz INCR 1; + auf satz intern (datei, satz); + satz vorher := satzzeiger; + satzzeiger := datei. satzzeiger . + +satz richtig einsortieren : + IF satz kleiner als vorgaenger THEN + satz einsortieren (datei, satz, satzzeiger); + satzzeiger := satz vorher + ELSE + aktueller satz sortiert (datei) + END IF . + +satz kleiner als vorgaenger : + datei. ablage (satz vorher). satz GROESSER + datei. ablage (satzzeiger). satz . + +END PROC komplett sortieren; + +PROC einzeln sortieren (DATEI VAR datei) : + + INT VAR i; + FOR i FROM 1 UPTO datei. anz satzeintraege REP + IF NOT sortiert (datei, i) THEN + satz einsortieren (datei, datei. anz saetze + 1, i); + cout (i) + END IF + END REP + +END PROC einzeln sortieren; + +PROC satz einsortieren (DATEI VAR datei, INT CONST satznr, satzzeiger) : + + stelle suchen; + an dieser stelle einfuegen . + +stelle suchen : + INT VAR + anfang := 1, + ende := satznr - 1, + mitte; + WHILE stelle nicht gefunden REP + intervall in der mitte halbieren; + teilintervall auswaehlen + END REP . + +stelle nicht gefunden : + anfang <= ende . + +intervall in der mitte halbieren : + mitte := (anfang + ende) DIV 2; + INT VAR vergleichssatz; + auf satz intern (datei, mitte); + IF NOT sortiert (datei) THEN + passenden vergleichssatz suchen + END IF; + vergleichssatz := datei. satzzeiger . + +passenden vergleichssatz suchen : + WHILE datei. satznr < ende REP + weiter intern (datei); + IF satz richtig THEN LEAVE passenden vergleichssatz suchen END IF + END REP; + WHILE datei. satznr > anfang REP + zurueck intern (datei); + IF satz richtig THEN LEAVE passenden vergleichssatz suchen END IF + END REP; + LEAVE stelle suchen . + +satz richtig : + sortiert (datei) . + +teilintervall auswaehlen : + IF zu vergleichender satz GROESSER datei. ablage (satzzeiger). satz THEN + ende := mitte - 1 + ELSE + anfang := mitte + 1 + END IF . + +zu vergleichender satz : + datei. ablage (vergleichssatz). satz . + +an dieser stelle einfuegen : + positioniere intern (datei, satzzeiger); + IF datei. satznr < anfang THEN anfang DECR 1 END IF; + disable stop; + aktueller satz sortiert (datei); + in hashkette ausketten; + indexeintrag loeschen (datei); + auf satz intern (datei, anfang); + indexeintrag einfuegen (datei, satzzeiger); + in hashkette einketten . + +in hashkette ausketten : + INT CONST h index := hashindex (aktueller satz); + hash ausketten (datei, h index) . + +in hashkette einketten : + INT VAR vorgaenger, nachfolger; + stelle in hashkette (datei, h index, vorgaenger, nachfolger); + hash einketten (datei, h index, vorgaenger, nachfolger) . + +aktueller satz : + datei. ablage (satzzeiger). satz . + +END PROC satz einsortieren; + +BOOL OP GROESSER (SATZ CONST links, rechts) : + + ungleiches feld suchen; + sortierrichtung feststellen; + SELECT sortierinfo ISUB vergleichsfeld OF + CASE 0 : din vergleich + CASE 1 : zahl vergleich + CASE 2 : datum vergleich + OTHERWISE text vergleich + END SELECT . + +ungleiches feld suchen : + INT VAR nr zeiger := 1; + WHILE nr zeiger < length (sortierfelder) REP + INT CONST vergleichsfeld := code (sortierfelder SUB nr zeiger); + feld lesen (links, vergleichsfeld, l); + feld lesen (rechts, vergleichsfeld, r); + SELECT sortierinfo ISUB vergleichsfeld OF + CASE 0 : din gleich + CASE 1 : zahl gleich + OTHERWISE text gleich + END SELECT; + nr zeiger INCR 2 + END REP; + LEAVE GROESSER WITH FALSE . + +sortierrichtung feststellen : + BOOL VAR aufsteigend; + IF (sortierfelder SUB (nr zeiger + 1)) = "-" THEN + aufsteigend := FALSE + ELSE + aufsteigend := TRUE + END IF . + +zahl gleich : + REAL VAR l wert, r wert; + wert berechnen (l, l wert); + wert berechnen (r, r wert); + IF l wert <> r wert THEN + LEAVE ungleiches feld suchen + END IF . + +din gleich : + IF NOT (l LEXEQUAL r) THEN + LEAVE ungleiches feld suchen + END IF . + +text gleich : + IF l <> r THEN + LEAVE ungleiches feld suchen + END IF . + +zahl vergleich : + IF aufsteigend THEN + l wert > r wert + ELSE + l wert < r wert + END IF . + +din vergleich : + IF aufsteigend THEN + l LEXGREATER r + ELSE + r LEXGREATER l + END IF . + +datum vergleich : + datum umdrehen (l); + datum umdrehen (r); + IF aufsteigend THEN + l > r + ELSE + l < r + END IF . + +textvergleich : + IF aufsteigend THEN + l > r + ELSE + l < r + END IF . + +END OP GROESSER; + +PROC wert berechnen (TEXT CONST zahl, REAL VAR wert) : + + LET ziffern = "0123456789"; + TEXT VAR komma := dez komma, text; + INT VAR stelle; + INT CONST laenge := length (zahl); + anfang bestimmen; + WHILE stelle <= laenge REP + zeichen untersuchen; + stelle INCR 1 + END REP; + wert := real (text) . + +anfang bestimmen : + stelle := pos (zahl, "0", "9", 1); + IF stelle = 0 THEN + wert := 0.0; LEAVE wert berechnen + ELIF pos (zahl, "-", 1, stelle) > 0 THEN + text := "-" + ELSE + text := niltext + END IF; . + +zeichen untersuchen: + TEXT CONST char := zahl SUB stelle; + IF pos (ziffern, char) > 0 THEN + text CAT char + ELIF char = komma THEN + text CAT "."; komma := niltext + END IF . + +END PROC wert berechnen; + +PROC datum umdrehen (TEXT VAR datum) : + + IF length (datum) <> 8 THEN + datum := niltext + ELSE + datum := subtext (datum, 7) + subtext (datum, 4, 5) + + subtext (datum, 1, 2) + END IF + +END PROC datum umdrehen; + + +(**************************** Reorganisieren *****************************) + +PROC reorganisiere (TEXT CONST dateiname) : + + EUDAT VAR datei 1, datei 2; + oeffne (datei 1, dateiname); + disable stop; + DATASPACE VAR ds := nilspace; + oeffne (datei 2, ds); + kopiere eudat (CONCR (datei 1), datei 2); + IF NOT is error THEN + forget (dateiname, quiet); + copy (ds, dateiname) + END IF; + forget (ds) + +END PROC reorganisiere; + +PROC kopiere eudat (DATEI VAR datei 1, EUDAT VAR datei 2) : + + enable stop; + kopiere saetze; + kopiere interna (datei 1, CONCR (datei 2)) . + +kopiere saetze : + auf satz intern (datei 1, 1); + auf satz (datei 2, 1); + WHILE NOT dateiende REP + satz einfuegen (datei 2, kopiersatz); + cout (datei 1. satznr); + weiter intern (datei 1); + weiter (datei 2) + END REP . + +dateiende : + datei 1. satznr > datei 1. anz saetze . + +kopiersatz : + datei 1. ablage (datei 1. satzzeiger). satz . + +END PROC kopiere eudat; + +PROC kopiere interna (DATEI VAR datei 1, datei 2) : + + datei 2. felderzahl := datei 1. felderzahl; + datei 2. feldnamen := datei 1. feldnamen; + datei 2. feldinfo := datei 1. feldinfo; + datei 2. sortierfelder := datei 1. sortierfelder; + datei 2. notizen (1) := datei 1. notizen (1); + datei 2. notizen (2) := datei 1. notizen (2); + datei 2. notizen (3) := datei 1. notizen (3) + +END PROC kopiere interna; + + +(************************* Notizen ***************************************) + +PROC notizen lesen (EUDAT CONST datei, INT CONST nr, TEXT VAR notiztext) : + + notiztext := datei. notizen (nr) + +END PROC notizen lesen; + +PROC notizen aendern (EUDAT VAR datei, INT CONST nr, TEXT CONST notiztext) : + + datei. notizen (nr) := notiztext + +END PROC notizen aendern; + +END PACKET eudas dateien; + diff --git a/app/eudas/4.4/src/eudas.datenverwaltung b/app/eudas/4.4/src/eudas.datenverwaltung new file mode 100644 index 0000000..bd4f74f --- /dev/null +++ b/app/eudas/4.4/src/eudas.datenverwaltung @@ -0,0 +1,1989 @@ +PACKET datenverwaltung + +(*************************************************************************) +(* *) +(* Verwaltung der aktuellen EUDAS-Dateien *) +(* *) +(* Version 09 *) +(* *) +(* Autor: Thomas Berlage *) +(* Stand: 01.10.87 *) +(* *) +(*************************************************************************) + + DEFINES + + oeffne, + kopple, + kette, + zugriff, + sichere, + dateien loeschen, + auf koppeldatei, + + anzahl koppeldateien, + anzahl dateien, + aendern erlaubt, + inhalt veraendert, + eudas dateiname, + folgedatei, + + dateiversion, + + anzahl felder, + feldnamen lesen, + feldnamen bearbeiten, + feldnummer, + feldinfo, + notizen lesen, + notizen aendern, + + feld lesen, + feld bearbeiten, + feld aendern, + + satznummer, + satzkombination, + dateiende, + weiter, + zurueck, + auf satz, + + satz einfuegen, + satz loeschen, + aenderungen eintragen, + + suchbedingung, + suchbedingung lesen, + suchbedingung loeschen, + suchversion, + satz ausgewaehlt, + markierung aendern, + satz markiert, + markierungen loeschen, + markierte saetze : + + +LET + INTVEC = TEXT, + + DATEI = STRUCT + (TEXT name, + SATZ feldnamen, + INTVEC koppelfelder, + INT anz koppelfelder, + INT naechste datei, + INT alte koppelposition, + DATASPACE ds, + EUDAT eudat, + SATZ satzpuffer, + BOOL gepuffert, + BOOL veraendert, datei veraendert, koppelfeld veraendert, + TEXT muster, + INTVEC marksaetze, + INT markzeiger), + + VERWEIS = STRUCT (INT datei, feld); + +LET + niltext = "", + empty intvec = ""; + +LET + maxint = 32767, + maxdateien = 10, + maxfelder = 256, + maxkoppeln = 32; + +ROW maxdateien DATEI VAR daten; + +INT VAR + anz dateien := 0, + anz koppeldateien := 0, + hauptdatei, + erste koppeldatei := 0, + felderzahl der ersten datei, + anz felder := 0, + satznummer offset, + kombination, + markierungen, + laufzaehler := 0; + +BOOL VAR + ende der datei := TRUE, + aenderungserlaubnis, + globales muster vorhanden; + +TEXT VAR globales muster; + +ROW maxfelder VERWEIS VAR verweis; + +ROW maxkoppeln VERWEIS VAR koppeln; + +INT VAR koppeleintraege; + +LET + zuviel dateien = #301# + "Zuviel Dateien geoeffnet", + datei existiert nicht = #302# + "Datei existiert nicht", + nicht im umgeschalteten zustand = #303# + "Nicht moeglich, wenn auf Koppeldatei geschaltet", + zu viele felder = #304# + "Zu viele Felder", + zu viele koppelfelder = #305# + "Zu viele Koppelfelder", + keine koppelfelder = #306# + "keine Koppelfelder vorhanden", + kein zugriff bei ketten oder koppeln = #307# + "kein direkter Dateizugriff bei geketteten oder gekoppelten Dateien", + keine datei geoeffnet = #308# + "keine Datei geoeffnet", + datei nicht gesichert = #309# + "Datei nicht gesichert", + suchmuster zu umfangreich = #310# + "Suchmuster zu umfangreich"; + +TEXT VAR feldpuffer; + + +(***************************** INTVEC ************************************) + +TEXT VAR raum fuer ein int := " "; + +INTVEC VAR puffer; + +OP CAT (INTVEC VAR text, INT CONST wert) : + + replace (raum fuer ein int, 1, wert); + text CAT raum fuer ein int + +END OP CAT; + +PROC insert (INTVEC VAR vector, INT CONST stelle, wert) : + + INT CONST trennung := stelle + stelle - 2; + puffer := subtext (vector, trennung + 1); + vector := subtext (vector, 1, trennung); + vector CAT wert; + vector CAT puffer + +END PROC insert; + +PROC delete (INTVEC VAR vector, INT CONST stelle) : + + INT CONST trennung := stelle + stelle - 2; + puffer := subtext (vector, trennung + 3); + vector := subtext (vector, 1, trennung); + vector CAT puffer + +END PROC delete; + +PROC inkrement (INTVEC VAR vector, INT CONST ab, um) : + + INT VAR i; + FOR i FROM ab UPTO length (vector) DIV 2 - 1 REP + replace (vector, i, (vector ISUB i) + um) + END REP + +END PROC inkrement; + + +(***************************** Dateien eintragen *************************) + +EUDAT VAR eudas datei; + +SATZ VAR namen; + +PROC datei testen (TEXT CONST dateiname) : + + IF anz dateien = maxdateien THEN + errorstop (zuviel dateien) + END IF; + IF NOT exists (dateiname) THEN + errorstop (datei existiert nicht) + END IF; + IF umgeschaltet THEN + errorstop (nicht im umgeschalteten zustand) + END IF; + oeffne (eudas datei, dateiname) + +END PROC datei testen; + +PROC datei eintragen (DATEI VAR datei, TEXT CONST dateiname) : + + IF aenderungserlaubnis THEN + datei. ds := old (dateiname); + oeffne (datei. eudat, datei. ds) + ELSE + oeffne (datei. eudat, dateiname) + END IF; + datei. naechste datei := 0; + datei. veraendert := FALSE; + datei. datei veraendert := FALSE; + datei. name := dateiname; + mark loeschen (datei) + +END PROC datei eintragen; + +PROC in dateikette (INT CONST anfang) : + + INT VAR dateiindex := anfang; + WHILE daten (dateiindex). naechste datei <> 0 REP + dateiindex := daten (dateiindex). naechste datei + END REP; + daten (dateiindex). naechste datei := anz dateien + +END PROC in dateikette; + +PROC anfangsposition einnehmen : + + IF dateiende (daten (1). eudat) THEN + auf satz (1) + ELSE + auf satz (satznr (daten (1). eudat)) + END IF + +END PROC anfangsposition einnehmen; + +PROC felder anlegen : + + felderzahl der ersten datei := felderzahl (daten (1). eudat); + anz felder := felderzahl der ersten datei; + feldnamen lesen (daten (1). eudat, daten (1). feldnamen); + koppeleintraege := 0; + INT VAR i; + FOR i FROM 1 UPTO anz felder REP + verweis (i). datei := 0 + END REP + +END PROC felder anlegen; + +PROC laufzaehler erhoehen : + + laufzaehler INCR 1; + IF laufzaehler > 32000 THEN + laufzaehler := - 32000 + END IF + +END PROC laufzaehler erhoehen; + +PROC oeffne (TEXT CONST dateiname, BOOL CONST auch aendern) : + + enable stop; + dateien loeschen (FALSE); + suchbedingung loeschen; + datei testen (dateiname); + aenderungserlaubnis := auch aendern; + status setzen; + datei eintragen (daten (anz dateien), dateiname); + anfangsposition einnehmen; + felder anlegen . + +status setzen : + anz dateien := 1; + laufzaehler erhoehen; + markierungen := 0 . + +END PROC oeffne; + +PROC kopple (TEXT CONST dateiname) : + + enable stop; + IF anz dateien = 0 THEN + errorstop (keine datei geoeffnet) + END IF; + datei testen (dateiname); + koppelfelder bestimmen; + platz in feldtabellen belegen; + in kette der koppeldateien einfuegen; + datei eintragen (daten (anz dateien), dateiname); + koppelstatus setzen . + +koppelfelder bestimmen : + feldnamen lesen (eudas datei, namen); + INT VAR koppelfelder := 0; + INTVEC VAR koppelfeldnr := empty intvec; + WHILE koppelfelder < felderzahl (eudas datei) REP + feld lesen (namen, koppelfelder + 1, feldpuffer); + INT CONST index := feldindex (daten (1). feldnamen, feldpuffer); + IF index > 0 THEN + koppelfelder INCR 1; + koppelfeldnr CAT index + END IF + UNTIL index = 0 END REP . + +platz in feldtabellen belegen : + IF anz felder + felderzahl (eudas datei) - koppelfelder > maxfelder THEN + errorstop (zu viele felder) + ELIF koppeleintraege + koppelfelder > maxkoppeln THEN + errorstop (zu viele koppelfelder) + ELIF koppelfelder = 0 THEN + errorstop (keine koppelfelder) + END IF; + anz dateien INCR 1; + daten (anz dateien). feldnamen := namen; + daten (anz dateien). koppelfelder := koppelfeldnr; + daten (anz dateien). anz koppelfelder := koppelfelder; + INT VAR feldnr := koppelfelder; + WHILE feldnr < felderzahl (eudas datei) REP + anz felder INCR 1; feldnr INCR 1; + verweis (anz felder). datei := anz dateien; + verweis (anz felder). feld := feldnr + END REP; + FOR feldnr FROM 1 UPTO koppelfelder REP + koppelfeld eintragen + END REP . + +koppelfeld eintragen : + INT CONST koppelfeld := koppelfeldnr ISUB feldnr; + IF verweis (koppelfeld). datei = 0 THEN + neues koppelfeld eintragen + ELSE + alten eintrag erweitern + END IF . + +neues koppelfeld eintragen : + koppeleintraege INCR 1; + koppeln (koppeleintraege). datei := anz dateien; + koppeln (koppeleintraege). feld := feldnr; + verweis (koppelfeld). datei := koppeleintraege; + verweis (koppelfeld). feld := 1 . + +alten eintrag erweitern : + INT CONST eintragposition := + verweis (koppelfeld). datei + verweis (koppelfeld). feld; + folgende eintraege hochschieben; + verweis (koppelfeld). feld INCR 1; + koppeln (eintragposition). datei := anz dateien; + koppeln (eintragposition). feld := feldnr . + +folgende eintraege hochschieben : + INT VAR eintrag; + FOR eintrag FROM koppeleintraege DOWNTO eintragposition REP + koppeln (eintrag + 1) := koppeln (eintrag) + END REP; + koppeleintraege INCR 1; + FOR eintrag FROM 1 UPTO felderzahl der ersten datei REP + IF verweis (eintrag). datei >= eintragposition THEN + verweis (eintrag). datei INCR 1 + END IF + END REP . + +in kette der koppeldateien einfuegen : + anz koppeldateien INCR 1; + IF erste koppeldatei = 0 THEN + erste koppeldatei := anz dateien + ELSE + in dateikette (erste koppeldatei) + END IF . + +koppelstatus setzen : + laufzaehler erhoehen; + daten (anz dateien). gepuffert := FALSE; + daten (anz dateien). koppelfeld veraendert := FALSE; + daten (anz dateien). alte koppelposition := satznr (eudas datei); + koppeldatei aktualisieren (daten (anz dateien)) . + +END PROC kopple; + +PROC kette (TEXT CONST dateiname) : + + enable stop; + IF anz dateien = 0 THEN + errorstop (keine datei geoeffnet) + END IF; + datei testen (dateiname); + anz dateien INCR 1; + datei eintragen (daten (anz dateien), dateiname); + in dateikette (1); + IF ende der datei THEN auf satz (satznummer) END IF + +END PROC kette; + +PROC zugriff (PROC (EUDAT VAR) bearbeitung) : + + IF anz dateien > 1 OR umgeschaltet THEN + errorstop (kein zugriff bei ketten oder koppeln) + ELSE + aenderungen eintragen; + bearbeitung (daten (1). eudat); + laufzaehler erhoehen; + anfangsposition einnehmen; + felder anlegen; + daten (1). datei veraendert := TRUE + ENDIF + +END PROC zugriff; + +PROC sichere (INT CONST dateinummer, TEXT CONST dateiname) : + + aenderungen eintragen; + notizen aendern (daten (dateinummer). eudat, 2, date); + IF aenderungserlaubnis THEN + forget (dateiname, quiet); + copy (daten (dateinummer). ds, dateiname) + END IF; + daten (dateinummer). datei veraendert := FALSE + +END PROC sichere; + +PROC dateien loeschen (BOOL CONST auch geaenderte) : + + aenderungen eintragen; + IF umgeschaltet THEN auf koppeldatei (0) END IF; + kontrollvariablen loeschen; + dateien einzeln loeschen . + +kontrollvariablen loeschen : + anz koppeldateien := 0; + erste koppeldatei := 0; + daten (1). naechste datei := 0; + anz felder := 0; + ende der datei := TRUE . + +dateien einzeln loeschen : + WHILE anz dateien > 0 REP + IF wirklich veraendert AND NOT auch geaenderte THEN + errorstop (datei nicht gesichert); + LEAVE dateien loeschen + END IF; + forget (daten (anz dateien). ds); + anz dateien DECR 1 + END REP . + +wirklich veraendert : + aenderungserlaubnis AND daten (anz dateien). datei veraendert . + +END PROC dateien loeschen; + + +(*********************** Umschalten Koppeldatei **************************) + +INT VAR + save hauptdatei, + save felderzahl der ersten datei, + save anz felder, + save satznummer offset, + save kombination, + save markierungen, + save erste koppeldatei, + save naechste koppeldatei; + +BOOL VAR + save globales muster vorhanden; + +INTVEC VAR + save oder anfang; + +SATZ VAR + save muster gespeichert; + + +BOOL VAR + umgeschaltet := FALSE; + +INT VAR + anzahl hauptmuster := 0, + feldnamendatei := 1; + + +BOOL PROC auf koppeldatei : + + umgeschaltet + +END PROC auf koppeldatei; + +PROC auf koppeldatei (INT CONST nr) : + + disable stop; + laufzaehler erhoehen; + IF umgeschaltet THEN + alte variablen wiederherstellen; + umgeschaltet := FALSE; + ggf koppelfelder uebernehmen; + fuer korrekten zustand sorgen + ELSE + alte variablen sichern; + umgeschaltet := TRUE; + neuen zustand herstellen + END IF . + +alte variablen wiederherstellen : + hauptdatei := save hauptdatei; + felderzahl der ersten datei := save felderzahl der ersten datei; + anz felder := save anz felder; + satznummer offset := save satznummer offset; + markierungen := save markierungen; + erste koppeldatei := save erste koppeldatei; + daten (feldnamendatei). naechste datei := save naechste koppeldatei; + anzahl muster := anzahl hauptmuster; + globales muster vorhanden := save globales muster vorhanden; + oder anfang := save oder anfang; + muster gespeichert := save muster gespeichert; + IF anzahl muster > 0 THEN + erster musterindex := 1 + ELSE + erster musterindex := -1 + END IF . + +fuer korrekten zustand sorgen : + anzahl hauptmuster := 0; + feldnamendatei := 1; + enable stop; + auf satz (satznummer); + WHILE kombination <> save kombination REP + weiter (1) + END REP . + +ggf koppelfelder uebernehmen : + daten (feldnamendatei). alte koppelposition := + satznr (daten (feldnamendatei). eudat); + IF nr = 1 AND NOT dateiende (daten (hauptdatei). eudat) THEN + alle koppelfelder in hauptdatei uebernehmen + END IF . + +alle koppelfelder in hauptdatei uebernehmen : + INT VAR koppel nr; + FOR koppel nr FROM 1 UPTO daten (feldnamendatei). anz koppelfelder REP + feld aendern (daten (hauptdatei). eudat, feld nr koppelfeld, + feldinhalt koppelfeld) + END REP; + save kombination := 1 . + +feld nr koppelfeld : + daten (feldnamendatei). koppelfelder ISUB koppel nr . + +feldinhalt koppelfeld : + feld lesen (daten (feldnamendatei). eudat, koppel nr, feldpuffer); + feldpuffer . + +alte variablen sichern : + save hauptdatei := hauptdatei; + save felderzahl der ersten datei := felderzahl der ersten datei; + save anz felder := anz felder; + save satznummer offset := satznummer offset; + save kombination := kombination; + save markierungen := markierungen; + save erste koppeldatei := erste koppeldatei; + save naechste koppeldatei := daten (nr). naechste datei; + save globales muster vorhanden := globales muster vorhanden; + save oder anfang := oder anfang; + save muster gespeichert := muster gespeichert . + +neuen zustand herstellen : + hauptdatei := nr; + anzahl hauptmuster := anzahl muster; + feldnamendatei := nr; + felderzahl der ersten datei := felderzahl (daten (nr). eudat); + anz felder := felderzahl der ersten datei; + satznummer offset := 0; + markierungen := (length (daten (nr). marksaetze) - 1) DIV 2; + erste koppeldatei := 0; + daten (nr). naechste datei := 0; + suchbedingung loeschen; + auf satz (daten (nr). alte koppelposition) . + +END PROC auf koppeldatei; + + +(************************** Dateiabfragen ********************************) + +INT PROC anzahl koppeldateien : + + anz koppeldateien + +END PROC anzahl koppeldateien; + +INT PROC anzahl dateien : + + anz dateien + +END PROC anzahl dateien; + +BOOL PROC aendern erlaubt : + + aenderungserlaubnis + +END PROC aendern erlaubt; + +BOOL PROC inhalt veraendert (INT CONST dateinr) : + + aenderungen eintragen; + daten (dateinr). datei veraendert + +END PROC inhalt veraendert; + +TEXT PROC eudas dateiname (INT CONST dateinr) : + + daten (dateinr). name + +END PROC eudas dateiname; + +INT PROC folgedatei (INT CONST dateinr) : + + IF dateinr = 0 THEN + erste koppeldatei + ELSE + daten (dateinr). naechste datei + END IF + +END PROC folgedatei; + + +(*************************** Dateiversion ********************************) + +(* Die Dateiversion wird bei jedem neuen 'oeffne' hochgezaehlt. Sie *) +(* dient dazu, ein neues 'oeffne' festzustellen, um eventuell als *) +(* Optimierung gespeicherte Daten als ungueltig zu kennzeichnen. *) + +INT PROC dateiversion : + + laufzaehler + +END PROC dateiversion; + + +(******************************* Felder **********************************) + +INT PROC anzahl felder : + + anz felder + +END PROC anzahl felder; + +PROC feldnamen lesen (INT CONST feldnr, TEXT VAR name) : + + IF feldnr <= felderzahl der ersten datei THEN + feld lesen (daten (feldnamendatei). feldnamen, feldnr, name) + ELSE + feld lesen (dateiverweis, feldverweis, name) + END IF . + +dateiverweis : + daten (verweis (feldnr). datei). feldnamen . + +feldverweis : + verweis (feldnr). feld . + +END PROC feldnamen lesen; + +PROC feldnamen bearbeiten (INT CONST feldnr, + PROC (TEXT CONST, INT CONST, INT CONST) bearbeite) : + + IF feldnr <= felderzahl der ersten datei THEN + feld bearbeiten (daten (feldnamendatei). feldnamen, feldnr, + PROC (TEXT CONST, INT CONST, INT CONST) bearbeite) + ELSE + feld bearbeiten (dateiverweis, feldverweis, + PROC (TEXT CONST, INT CONST, INT CONST) bearbeite) + END IF . + +dateiverweis : + daten (verweis (feldnr). datei). feldnamen . + +feldverweis : + verweis (feldnr). feld . + +END PROC feldnamen bearbeiten; + +INT PROC feldnummer (TEXT CONST feldname) : + + INT VAR + offset := felderzahl der ersten datei, + nr := feldindex (daten (feldnamendatei). feldnamen, feldname), + dateiindex := erste koppeldatei; + WHILE nr = 0 AND dateiindex <> 0 REP + nr := feldindex (daten (dateiindex). feldnamen, feldname); + offset oder nr erhoehen; + dateiindex := daten (dateiindex). naechste datei + END REP; + nr . + +offset oder nr erhoehen : + INT CONST zahl der koppelfelder := daten (dateiindex). anz koppelfelder; + IF nr = 0 THEN + offset INCR felderzahl (daten (dateiindex). eudat); + offset DECR zahl der koppelfelder + ELSE + nr INCR offset; + nr DECR zahl der koppelfelder + END IF . + +END PROC feldnummer; + +INT PROC feldinfo (INT CONST feldnr) : + + IF feldnr <= felderzahl der ersten datei THEN + feldinfo (daten (feldnamendatei). eudat, feldnr) + ELSE + feldinfo (daten (dateiverweis). eudat, feldverweis) + END IF . + +dateiverweis : + verweis (feldnr). datei . + +feldverweis : + verweis (feldnr). feld . + +END PROC feldinfo; + +PROC notizen lesen (INT CONST nr, TEXT VAR inhalt) : + + notizen lesen (daten (feldnamendatei). eudat, nr, inhalt) + +END PROC notizen lesen; + +PROC notizen aendern (INT CONST nr, TEXT CONST inhalt) : + + notizen aendern (daten (feldnamendatei). eudat, nr, inhalt) + +END PROC notizen aendern; + + +(*************************** Feldzugriffe ********************************) + +PROC feld lesen (INT CONST feldnr, TEXT VAR inhalt) : + + IF feldnr <= felderzahl der ersten datei THEN + feld lesen (daten (hauptdatei). eudat, feldnr, inhalt) + ELSE + in koppeldatei lesen + END IF . + +in koppeldatei lesen : + INT CONST dateiverweis := verweis (feldnr). datei; + IF daten (dateiverweis). gepuffert THEN + feld lesen (daten (dateiverweis). satzpuffer, feldverweis, inhalt) + ELSE + feld lesen (daten (dateiverweis). eudat, feldverweis, inhalt) + END IF . + +feldverweis : + verweis (feldnr). feld . + +END PROC feld lesen; + +PROC feld bearbeiten (INT CONST feldnr, + PROC (TEXT CONST, INT CONST, INT CONST) bearbeite) : + + IF feldnr <= felderzahl der ersten datei THEN + feld bearbeiten (daten (hauptdatei). eudat, feldnr, + PROC (TEXT CONST, INT CONST, INT CONST) bearbeite) + ELSE + in koppeldatei bearbeiten + END IF . + +in koppeldatei bearbeiten : + INT CONST dateiverweis := verweis (feldnr). datei; + IF daten (dateiverweis). gepuffert THEN + feld bearbeiten (daten (dateiverweis). satzpuffer, feldverweis, + PROC (TEXT CONST, INT CONST, INT CONST) bearbeite) + ELSE + feld bearbeiten (daten (dateiverweis). eudat, feldverweis, + PROC (TEXT CONST, INT CONST, INT CONST) bearbeite) + END IF . + +feldverweis : + verweis (feldnr). feld . + +END PROC feld bearbeiten; + +PROC feld aendern (INT CONST feldnr, TEXT CONST inhalt) : + + INT CONST dateiverweis := verweis (feldnr). datei; + IF feldnr <= felderzahl der ersten datei THEN + in hauptdatei aendern + ELSE + in koppeldatei aendern + END IF . + +in hauptdatei aendern : + daten (hauptdatei). datei veraendert := TRUE; + IF ist koppelfeld CAND wirklich veraenderung THEN + weitere dateien aktualisieren + END IF; + feld aendern (daten (hauptdatei). eudat, feldnr, inhalt) . + +ist koppelfeld : + NOT umgeschaltet CAND dateiverweis > 0 . + +wirklich veraenderung : + feld lesen (daten (hauptdatei). eudat, feldnr, feldpuffer); + feldpuffer <> inhalt . + +weitere dateien aktualisieren : + INT VAR + koppelzaehler := feldverweis, + koppelverweis := dateiverweis; + REP + satzpuffer aktualisieren (daten (koppeldatei)); + daten (koppeldatei). koppelfeld veraendert := TRUE; + feld aendern (daten (koppeldatei). satzpuffer, koppelfeld, inhalt); + koppelverweis INCR 1; + koppelzaehler DECR 1 + UNTIL koppelzaehler = 0 END REP . + +in koppeldatei aendern : + satzpuffer aktualisieren (daten (dateiverweis)); + IF koppeldatei wirklich veraendert THEN + daten (dateiverweis). veraendert := TRUE; + feld aendern (daten (dateiverweis). satzpuffer, feldverweis, inhalt) + END IF . + +koppeldatei wirklich veraendert : + feld lesen (daten (dateiverweis). satzpuffer, feldverweis, feldpuffer); + feldpuffer <> inhalt . + +feldverweis : + verweis (feldnr). feld . + +koppeldatei : + koppeln (koppelverweis). datei . + +koppelfeld : + koppeln (koppelverweis). feld . + +END PROC feld aendern; + +PROC satzpuffer aktualisieren (DATEI VAR datei) : + + IF NOT datei. gepuffert THEN + datei. gepuffert := TRUE; + satzpuffer lesen + END IF . + +satzpuffer lesen : + IF dateiende (datei. eudat) THEN + satz initialisieren (datei. satzpuffer, datei. anz koppelfelder); + koppelfelder in satzpuffer schreiben + ELSE + satz lesen (datei. eudat, datei. satzpuffer) + END IF . + +koppelfelder in satzpuffer schreiben : + INT VAR i; + FOR i FROM 1 UPTO datei. anz koppelfelder REP + feld lesen (datei. koppelfelder ISUB i, feldpuffer); + feld aendern (datei. satzpuffer, i, feldpuffer) + END REP . + +END PROC satzpuffer aktualisieren; + +PROC koppeldatei aktualisieren (DATEI VAR datei) : + + muster lesen; + koppeldatei positionieren . + +muster lesen : + feld lesen (daten (hauptdatei). eudat, musterfeld, muster) . + +musterfeld : + datei. koppelfelder ISUB 1 . + +muster : + datei. muster . + +koppeldatei positionieren : + auf satz (datei. eudat, muster); + WHILE NOT koppelfelder gleich (datei) REP + weiter (datei. eudat, muster) + END REP; + IF dateiende (datei. eudat) THEN + satzpuffer aktualisieren (datei) + ELSE + datei. gepuffert := FALSE + END IF . + +END PROC koppeldatei aktualisieren; + +PROC koppeldateien aktualisieren : + + INT VAR dateiindex := erste koppeldatei; + WHILE dateiindex <> 0 REP + koppeldatei aktualisieren (daten (dateiindex)); + dateiindex := daten (dateiindex). naechste datei + END REP; + kombination := 1 + +END PROC koppeldateien aktualisieren; + +BOOL PROC koppelfelder gleich (DATEI CONST datei) : + + IF NOT dateiende (datei. eudat) THEN + koppelfelder vergleichen + END IF; + TRUE . + +koppelfelder vergleichen : + INT VAR koppelindex; + FOR koppelindex FROM 2 UPTO datei. anz koppelfelder REP + feld lesen (daten (hauptdatei). eudat, koppelfelder ISUB koppelindex, + feldpuffer); + feld bearbeiten (datei. eudat, koppelindex, + PROC (TEXT CONST, INT CONST, INT CONST) feld vergleichen); + IF NOT vergleich erfolgreich THEN + LEAVE koppelfelder gleich WITH FALSE + END IF + END REP . + +koppelfelder : + datei. koppelfelder . + +END PROC koppelfelder gleich; + +BOOL VAR vergleich erfolgreich; + +PROC feld vergleichen (TEXT CONST satz, INT CONST anfang, ende) : + + vergleich erfolgreich := length (feldpuffer) + anfang = ende + 1 CAND + pos (satz, feldpuffer, anfang, ende + 1) = anfang + +END PROC feld vergleichen; + + +(**************************** Anhalten ***********************************) + +LET + halt error = 22101, + halt zeichen = "h", + esc = ""27""; + +BOOL VAR esc zustand; + + +PROC halt abfrage starten : + + TEXT VAR z; + esc zustand := FALSE; + REP + z := incharety; type (z) + UNTIL z = niltext END REP + +END PROC halt abfrage starten; + +PROC halt abfrage beenden : + + IF esc zustand THEN + type (esc) + END IF + +END PROC halt abfrage beenden; + +BOOL PROC angehalten : + + TEXT VAR z; + REP + z := incharety; + IF z = niltext THEN + LEAVE angehalten WITH FALSE + ELSE + zeichen behandeln + END IF + END REP; + FALSE . + +zeichen behandeln : + IF esc zustand THEN + esc zustand := FALSE; + auf halt zeichen testen + ELSE + auf esc testen + END IF . + +auf halt zeichen testen : + IF z = halt zeichen THEN + tastenpuffer loeschen; + errorstop (halt error, niltext); + LEAVE angehalten WITH TRUE + ELSE + type (esc); type (z) + END IF . + +auf esc testen : + IF z = esc THEN + esc zustand := TRUE + ELSE + type (z) + END IF . + +tastenpuffer loeschen : + REP UNTIL getcharety = niltext END REP . + +END PROC angehalten; + + +(************************** Positionieren ********************************) + +PROC weiter (INT CONST modus) : + + IF NOT ende der datei THEN + aenderungen eintragen; + nach modus weiter gehen + END IF . + +nach modus weitergehen : + SELECT modus OF + CASE 1 : einen satz weiter + CASE 2 : weiter bis ausgewaehlt + CASE 3 : weiter bis markiert + END SELECT . + +einen satz weiter : + weiter gehen (FALSE) . + +weiter bis ausgewaehlt : + halt abfrage starten; + REP + weiter gehen (globales muster vorhanden); + cout (satznummer) + UNTIL satz ausgewaehlt OR ende der datei OR angehalten END REP; + halt abfrage beenden . + +weiter bis markiert : + INT VAR satzpos := satznr (daten (hauptdatei). eudat); + WHILE kein markierter satz mehr AND naechste datei <> 0 REP + eine datei weiter; + satzpos := 1 + END REP; + auf satz (daten (hauptdatei). eudat, naechster markierter satz); + cout (satznummer); + koppeldateien aktualisieren; + ende der datei := dateiende (daten (hauptdatei). eudat); + suchbedingung auswerten . + +kein markierter satz mehr : + mark stelle (daten (hauptdatei), satzpos + 1); + INT CONST naechster markierter satz := + daten (hauptdatei). marksaetze ISUB daten (hauptdatei). markzeiger; + naechster markierter satz = maxint . + +naechste datei : + daten (hauptdatei). naechste datei . + +END PROC weiter; + +PROC zurueck (INT CONST modus) : + + IF satznummer > 1 THEN + aenderungen eintragen; + nach modus zurueckgehen + END IF . + +nach modus zurueckgehen : + SELECT modus OF + CASE 1 : einen satz zurueck + CASE 2 : zurueck bis ausgewaehlt + CASE 3 : zurueck bis markiert + END SELECT . + +einen satz zurueck : + zurueck gehen (FALSE) . + +zurueck bis ausgewaehlt : + halt abfrage starten; + REP + zurueck gehen (globales muster vorhanden); + cout (satznummer) + UNTIL satz ausgewaehlt OR satznummer = 1 OR angehalten END REP; + halt abfrage beenden . + +zurueck bis markiert : + INT VAR satzpos := satznr (daten (hauptdatei). eudat); + WHILE kein markierter satz mehr AND hauptdatei <> 1 REP + eine datei zurueck; + satzpos := maxint - 1 + END REP; + auf satz (daten (hauptdatei). eudat, neuer satz); + cout (satznummer); + koppeldateien aktualisieren; + ende der datei := FALSE; + suchbedingung auswerten . + +kein markierter satz mehr : + INT VAR neuer satz; + mark stelle (daten (hauptdatei), satzpos); + IF daten (hauptdatei). markzeiger = 1 THEN + neuer satz := 1; + TRUE + ELSE + neuer satz := daten (hauptdatei). marksaetze ISUB + (daten (hauptdatei). markzeiger - 1); + FALSE + END IF . + +END PROC zurueck; + +PROC weiter gehen (BOOL CONST muster vorgegeben) : + + neue kombination suchen; + IF keine kombination mehr THEN + einen satz weiter; + koppeldateien aktualisieren + ELSE + kombination INCR 1 + END IF; + suchbedingung auswerten . + +neue kombination suchen : + INT VAR dateiindex := erste koppeldatei; + WHILE dateiindex > 0 REP + in koppeldatei weitergehen; + dateiindex := daten (dateiindex). naechste datei + END REP . + +in koppeldatei weitergehen : + BOOL VAR match gefunden; + kombination suchen (daten (dateiindex), match gefunden); + IF match gefunden THEN + LEAVE neue kombination suchen + END IF . + +keine kombination mehr : + dateiindex = 0 . + +einen satz weiter : + IF muster vorgegeben THEN + weiter (daten (hauptdatei). eudat, globales muster) + ELSE + weiter (daten (hauptdatei). eudat) + END IF; + WHILE dateiende (daten (hauptdatei). eudat) REP + auf naechste datei + UNTIL ende der datei END REP . + +auf naechste datei : + IF daten (hauptdatei). naechste datei <> 0 THEN + eine datei weiter; + auf ersten satz der naechsten datei + ELSE + ende der datei := TRUE + END IF . + +auf ersten satz der naechsten datei : + auf satz (daten (hauptdatei). eudat, 1) . + +END PROC weiter gehen; + +PROC kombination suchen (DATEI VAR datei, BOOL VAR match gefunden) : + + IF dateiende (datei. eudat) THEN + match gefunden := FALSE + ELSE + in datei weitergehen + END IF . + +in datei weitergehen : + match gefunden := TRUE; + REP + weiter (datei. eudat, datei. muster); + IF dateiende (datei. eudat) THEN + match gefunden := FALSE; + auf satz (datei. eudat, datei. muster) + END IF + UNTIL koppelfelder gleich (datei) END REP . + +END PROC kombination suchen; + +PROC zurueck gehen (BOOL CONST muster vorgegeben) : + + WHILE satznr (daten (hauptdatei). eudat) = 1 CAND satznummer > 1 REP + eine datei zurueck; + auf dateiende (daten (hauptdatei). eudat) + END REP; + IF muster vorgegeben THEN + zurueck (daten (hauptdatei). eudat, globales muster) + ELSE + zurueck (daten (hauptdatei). eudat) + END IF; + ende der datei := FALSE; + koppeldateien aktualisieren; + suchbedingung auswerten + +END PROC zurueck gehen; + +PROC eine datei weiter : + + satznummer offset INCR saetze (daten (hauptdatei). eudat); + hauptdatei := daten (hauptdatei). naechste datei + +END PROC eine datei weiter; + +PROC eine datei zurueck : + + INT VAR neuer index := 1; + WHILE daten (neuer index). naechste datei <> hauptdatei REP + neuer index := daten (neuer index). naechste datei + END REP; + satznummer offset DECR saetze (daten (neuer index). eudat); + hauptdatei := neuer index + +END PROC eine datei zurueck; + +PROC aenderungen eintragen : + + INT VAR dateiindex := erste koppeldatei; + WHILE dateiindex <> 0 REP + koppeldatei betrachten; + dateiindex := daten (dateiindex). naechste datei + END REP . + +koppeldatei betrachten : + IF daten (dateiindex). gepuffert THEN + datei aktualisieren (daten (dateiindex)) + END IF . + +END PROC aenderungen eintragen; + +PROC datei aktualisieren (DATEI VAR datei) : + + IF alter satz geaendert AND NOT koppelfelder veraendert THEN + satz in koppeldatei aendern + ELIF nicht nur koppelfelder belegt AND irgendwas veraendert THEN + neuen satz in koppeldatei einfuegen + ELIF koppelfelder veraendert THEN + koppeldatei aktualisieren (datei) + END IF; + puffer deaktivieren; + veraendert := FALSE; + koppelfelder veraendert := FALSE . + +alter satz geaendert : + NOT dateiende (datei. eudat) AND veraendert . + +nicht nur koppelfelder belegt : + felderzahl (satzpuffer) > datei. anz koppelfelder . + +irgendwas veraendert : + koppelfelder veraendert OR veraendert . + +neuen satz in koppeldatei einfuegen : + datei veraendert := TRUE; + feld lesen (satzpuffer, 1, datei. muster); + satz einfuegen (datei. eudat, satzpuffer) . + +puffer deaktivieren : + datei. gepuffert := FALSE . + +satz in koppeldatei aendern : + datei veraendert := TRUE; + satz aendern (datei. eudat, satzpuffer) . + +veraendert : + datei. veraendert . + +koppelfelder veraendert : + datei. koppelfeld veraendert . + +satzpuffer : + datei. satzpuffer . + +datei veraendert : + datei. datei veraendert . + +END PROC datei aktualisieren; + +PROC auf dateiende (EUDAT VAR eudat) : + + auf satz (eudat, saetze (eudat) + 1) + +END PROC auf dateiende; + +PROC auf satz (INT CONST satznr) : + + aenderungen eintragen; + hauptdatei := feldnamendatei; + satznummer offset := 0; + WHILE ueber datei hinaus AND noch weitere datei REP + eine datei weiter + END REP; + auf satz (daten (hauptdatei). eudat, satznr - satznummer offset); + koppeldateien aktualisieren; + ende der datei := dateiende (daten (hauptdatei). eudat); + suchbedingung auswerten . + +ueber datei hinaus : + satznr - satznummer offset > saetze (daten (hauptdatei). eudat) . + +noch weitere datei : + daten (hauptdatei). naechste datei <> 0 . + +END PROC auf satz; + +INT PROC satznummer : + + satznummer offset + satznr (daten (hauptdatei). eudat) + +END PROC satznummer; + +INT PROC satzkombination : + + kombination + +END PROC satzkombination; + +BOOL PROC dateiende : + + ende der datei + +END PROC dateiende; + + +(*************************** Satzverwaltung ******************************) + +SATZ VAR leersatz; +satz initialisieren (leersatz); + +PROC satz einfuegen : + + aenderungen eintragen; + mark satz einfuegen; + satz einfuegen (daten (hauptdatei). eudat, leersatz); + daten (hauptdatei). datei veraendert := TRUE; + alle koppeldateien ans ende; + ende der datei := FALSE; + suchbedingung auswerten . + +mark satz einfuegen : + mark stelle (daten (hauptdatei), satznr (daten (hauptdatei). eudat)); + inkrement (daten (hauptdatei). marksaetze, + daten (hauptdatei). markzeiger, 1) . + +alle koppeldateien ans ende : + kombination := 1; + INT VAR dateiindex := erste koppeldatei; + WHILE dateiindex <> 0 REP + auf dateiende (daten (dateiindex). eudat); + dateiindex := daten (dateiindex). naechste datei + END REP . + +END PROC satz einfuegen; + +PROC satz loeschen : + + IF NOT ende der datei THEN + aenderungen eintragen; + mark satz loeschen; + satz loeschen (daten (hauptdatei). eudat); + daten (hauptdatei). datei veraendert := TRUE; + auf satz (satznummer) + END IF . + +mark satz loeschen : + IF satz markiert THEN + delete (daten (hauptdatei). marksaetze, daten (hauptdatei). markzeiger); + markierungen DECR 1 + END IF; + inkrement (daten (hauptdatei). marksaetze, + daten (hauptdatei). markzeiger, -1) . + +END PROC satz loeschen; + + +(*************************** Suchmuster **********************************) + +LET + maxmuster = 100; + +ROW maxmuster STRUCT (INT feld, relator, true exit, false exit, + TEXT muster) + VAR bedingung; + +SATZ VAR muster gespeichert; + +INT VAR + anzahl muster, + erster musterindex, + versionszaehler := 1; + +BOOL VAR + bereits ausgewertet, + erfuellt; + +suchbedingung loeschen; + +INT VAR + muster index; + +LET + gleich test = 1, + beginn test = 2, + endet test = 3, + enthalten test = 4, + kleiner test = 5, + groesser test = 6, + nicht leer test = 7, + markiert test = 8, + true test = 9; + + +PROC suchbedingung auswerten : + + IF ende der datei THEN + erfuellt := FALSE + ELSE + kette verfolgen; + erfuellt := in true exit + END IF . + +kette verfolgen : + musterindex := erster musterindex; + WHILE muster index > 0 REP + gegenfeld bearbeiten; + feld bearbeiten (suchfeld, + PROC (TEXT CONST, INT CONST, INT CONST) bedingung ueberpruefen) + END REP . + +gegenfeld bearbeiten : + INT VAR verwendeter relator := bedingung (musterindex). relator; + IF verwendeter relator >= 256 THEN + gegenfeld lesen; + bei datum umdrehen + END IF . + +gegenfeld lesen : + feld lesen ((verwendeter relator AND 255) + 1, feldpuffer) . + +bei datum umdrehen : + IF jeweiliges feldinfo = 2 THEN + feldpuffer drehen + END IF; + bedingung (musterindex). muster := feldpuffer . + +suchfeld : + bedingung (musterindex). feld . + +in true exit : + musterindex < 0 . + +END PROC suchbedingung auswerten; + +PROC bedingung ueberpruefen (TEXT CONST satz, INT CONST von, bis) : + + INT VAR verwendeter relator := bedingung (musterindex). relator; + IF verwendeter relator >= 256 THEN + verwendeter relator := verwendeter relator DIV 256 + END IF; + IF bedingung trifft zu THEN + musterindex := bedingung (musterindex). true exit + ELSE + musterindex := bedingung (musterindex). false exit + END IF . + +bedingung trifft zu : + SELECT verwendeter relator OF + CASE gleich test : ist gleich + CASE beginn test : beginnt mit + CASE endet test : endet mit + CASE enthalten test : ist enthalten + CASE kleiner test : ist kleiner + CASE groesser test : ist groesser + CASE nicht leer test : ist nicht leer + CASE markiert test : ist markiert + CASE true test : ist true + OTHERWISE FALSE + END SELECT . + +ist gleich : + SELECT jeweiliges feldinfo OF + CASE 0 : feldpuffer als subtext; feldpuffer LEXEQUAL muster + CASE 1 : feldpuffer als subtext; feldwert = musterwert + OTHERWISE length (muster) = bis - von + 1 AND text gleich + END SELECT . + +text gleich : + von > bis COR beginnt mit . + +beginnt mit : + pos (satz, muster, von, bis) = von . + +endet mit : + pos (satz, muster, bis + 1 - length (muster), bis) > 0 . + +ist enthalten : + pos (satz, muster, von, bis) > 0 . + +ist kleiner : + feldpuffer als subtext; + SELECT jeweiliges feldinfo OF + CASE 0 : muster LEXGREATER feldpuffer + CASE 1 : feldwert < musterwert + CASE 2 : feldpuffer drehen; feldpuffer < muster + OTHERWISE feldpuffer < muster + END SELECT . + +ist groesser : + feldpuffer als subtext; + SELECT jeweiliges feldinfo OF + CASE 0 : feldpuffer LEXGREATEREQUAL muster + CASE 1 : feldwert >= musterwert + CASE 2 : feldpuffer drehen; feldpuffer >= muster + OTHERWISE feldpuffer >= muster + END SELECT . + +ist nicht leer : + von <= bis . + +ist markiert : + satz markiert . + +ist true : + TRUE . + +feldpuffer als subtext : + feldpuffer := subtext (satz, von, bis) . + +END PROC bedingung ueberpruefen; + +TEXT PROC muster : + + bedingung (musterindex). muster + +END PROC muster; + +PROC feldpuffer drehen : + + IF length (feldpuffer) = 8 THEN + TEXT CONST jahr := subtext (feldpuffer, 7, 8); + replace (feldpuffer, 7, subtext (feldpuffer, 1, 2)); + replace (feldpuffer, 1, jahr) + ELSE + feldpuffer := niltext + END IF + +END PROC feldpuffer drehen; + +INT PROC jeweiliges feldinfo : + feldinfo (bedingung (musterindex). feld) +END PROC jeweiliges feldinfo; + +REAL PROC feldwert : + + REAL VAR r; + wert berechnen (feldpuffer, r); + r + +END PROC feldwert; + +REAL PROC musterwert : + + REAL VAR r; + wert berechnen (muster, r); + r + +END PROC musterwert; + + +LET + grosses oder = ";", + kleines oder = ",", + intervall symbol = "..", + markierungssymbol = "++", + negation = "--", + stern = "*"; + +BOOL VAR + neue alternative, + neue disjunktion, + verneinung; + +INT VAR + erstes feldmuster, + oder index, + naechster oder anfang, + anfang der disjunktion, + bearbeitetes feld; + +INTVEC VAR oder anfang; + + +PROC suchbedingung (INT CONST feldnr, TEXT CONST bedingung) : + + INT VAR + anfang := 1, + semi pos := 0; + INT CONST + bedingung ende := length (bedingung) + 1; + oder index := 0; + bearbeitetes feld := feldnr; + erstes feldmuster := anzahl muster + 1; + WHILE anfang < bedingung ende REP + feldende feststellen; + bedingung eintragen; + anfang := ende + 2 + END REP; + feld aendern (muster gespeichert, feldnr, bedingung) . + +feldende feststellen : + INT VAR + oder pos := pos (bedingung, kleines oder, anfang); + IF oder pos = 0 THEN oder pos := bedingung ende END IF; + IF semi pos < anfang THEN + neue alternative beginnen + END IF; + INT CONST ende := min (oder pos, semi pos) - 1 . + +neue alternative beginnen : + oder index INCR 1; + neue alternative := TRUE; + IF oder index > 1 THEN globales muster vorhanden := FALSE END IF; + semi pos := pos (bedingung, grosses oder, anfang); + IF semi pos = 0 THEN semi pos := bedingung ende END IF . + +bedingung eintragen : + verneinung testen; + neue disjunktion := TRUE; + INT CONST + intervall pos := pos (bedingung, intervall symbol, anfang, ende + 1); + IF leere bedingung THEN + eintragen (niltext, true test, - oder index) + ELIF intervall pos = 0 THEN + textvergleich + ELSE + groessenvergleich + END IF . + +verneinung testen : + IF subtext (bedingung, anfang, anfang + 1) = negation THEN + anfang INCR 2; verneinung := TRUE + ELSE + verneinung := FALSE + END IF . + +leere bedingung : + anfang > ende . + +text vergleich : + IF test auf markierung THEN + test auf markierung eintragen + ELSE + sterne suchen + END IF . + +test auf markierung : + anfang + 1 = ende CAND + subtext (bedingung, anfang, ende) = markierungssymbol . + +test auf markierung eintragen : + eintragen (niltext, markiert test, - oder index) . + +sterne suchen : + INT VAR stern pos := pos (bedingung, stern, anfang, ende + 1); + IF stern pos = 0 THEN + teste ob feld gleich + ELIF anfang = ende THEN + test auf nichtleeres feld + ELSE + relator bestimmen; + REP + teste auf enthalten sein + END REP + END IF . + +teste ob feld gleich : + IF globales muster moeglich THEN + globales muster vorhanden := TRUE; + globales muster := bedingung + END IF; + eintragen (subtext (bedingung, anfang, ende), gleich test, - oder index) . + +globales muster moeglich : + feldnr = 1 AND anfang = 1 AND ende = bedingung ende - 1 AND + noch keine globalen alternativen AND NOT umgeschaltet AND + (bedingung SUB 1) <> "&" . + +noch keine globalen alternativen : + length (oder anfang) <= 2 . + +test auf nichtleeres feld : + eintragen (niltext, nichtleer test, - oder index) . + +relator bestimmen : + INT VAR relator; + IF stern pos = anfang THEN + relator := gleich test + ELSE + relator := beginn test + END IF . + +teste auf enthalten sein : + IF relator <> gleich test THEN + teilmuster eintragen + END IF; + anfang := stern pos + 1; + stern pos := pos (bedingung, stern, anfang, ende + 1); + IF stern pos = 0 THEN + stern pos := ende + 1; + relator := endet test + ELSE + relator := enthalten test + END IF . + +teilmuster eintragen : + TEXT CONST muster := subtext (bedingung, anfang, stern pos - 1); + IF verneinung OR letztes feld THEN + IF verneinung THEN neue disjunktion := TRUE END IF; + eintragen (muster, relator, - oder index); + IF letztes feld THEN LEAVE sterne suchen END IF + ELSE + eintragen (muster, relator, anzahl muster + 2) + END IF . + +letztes feld : + stern pos >= ende . + +groessenvergleich : + TEXT CONST + muster 1 := subtext (bedingung, anfang, intervall pos - 1), + muster 2 := subtext (bedingung, intervall pos + 2, ende); + IF intervall pos = anfang THEN + eintragen (muster 2, kleiner test, - oder index) + ELIF intervall pos = ende - 1 THEN + eintragen (muster 1, groesser test, - oder index) + ELSE + intervall eintragen + END IF . + +intervall eintragen : + IF verneinung THEN + eintragen (muster 1, groesser test, - oder index); + neue disjunktion := TRUE + ELSE + eintragen (muster 1, groesser test, anzahl muster + 2) + END IF; + eintragen (muster 2, kleiner test, - oder index) . + +END PROC suchbedingung; + +PROC eintragen (TEXT CONST textmuster, INT CONST relator, true exit) : + + musterstatus verwalten; + musterplatz belegen; + IF neue alternative THEN + alte false exits auf neuen anfang setzen; + alte true exits auf diesen platz setzen; + anfang der disjunktion := anzahl muster + ELIF neue disjunktion THEN + false exits der letzten disjunktion anketten + END IF; + vergleichsdaten eintragen; + textmuster eintragen . + +musterstatus verwalten : + bereits ausgewertet := FALSE; + IF anzahl muster = anzahl hauptmuster THEN + versionszaehler INCR 1; + IF versionszaehler > 32000 THEN versionszaehler := 1 END IF + END IF . + +musterplatz belegen : + IF anzahl muster = maxmuster THEN + suchbedingung loeschen; + errorstop (suchmuster zu umfangreich) + ELSE + anzahl muster INCR 1; + erster musterindex := anzahl hauptmuster + 1 + END IF . + +alte false exits auf neuen anfang setzen : + IF oder index > length (oder anfang) DIV 2 THEN + oder anfang CAT anzahl muster; + setze verkettung (erster musterindex, 0, anzahl muster) + END IF; + IF oder index = length (oder anfang) DIV 2 THEN + naechster oder anfang := 0 + ELSE + naechster oder anfang := oder anfang ISUB (oder index + 1) + END IF . + +alte true exits auf diesen platz setzen : + setze verkettung (erster musterindex, - oder index, anzahl muster); + neue alternative := FALSE; + neue disjunktion := FALSE . + +false exits der letzten disjunktion anketten : + setze verkettung (anfang der disjunktion, naechster oder anfang, + anzahl muster); + anfang der disjunktion := anzahl muster; + neue disjunktion := FALSE . + +vergleichsdaten eintragen : + bedingung (anzahl muster). relator := relator; + bedingung (anzahl muster). feld := bearbeitetes feld; + IF verneinung THEN + bedingung (anzahl muster). true exit := naechster oder anfang; + bedingung (anzahl muster). false exit := true exit + ELSE + bedingung (anzahl muster). true exit := true exit; + bedingung (anzahl muster). false exit := naechster oder anfang + END IF . + +textmuster eintragen : + IF textmuster ist gegenfeld THEN + feldnummer des gegenfelds eintragen + ELSE + textmuster original eintragen + END IF . + +textmuster ist gegenfeld : + (textmuster SUB 1) = "&" CAND gueltiges feld . + +gueltiges feld : + INT CONST nr gegenfeld := feldnummer (subtext (textmuster, 2)); + nr gegenfeld > 0 . + +feldnummer des gegenfelds eintragen : + bedingung (anzahl muster). relator := nr gegenfeld - 1 + 256 * relator . + +textmuster original eintragen : + INT CONST info := feldinfo (bearbeitetes feld); + IF info = 2 AND (relator = kleiner test OR relator = groesser test) THEN + feldpuffer := textmuster; + feldpuffer drehen; + bedingung (anzahl muster). muster := feldpuffer + ELSE + bedingung (anzahl muster). muster := textmuster + END IF . + +END PROC eintragen; + +PROC setze verkettung (INT CONST von, wert, durch) : + + INT VAR i; + FOR i FROM von UPTO anzahl muster - 1 REP + IF bedingung (i). true exit = wert THEN + bedingung (i). true exit := durch + ELIF bedingung (i). false exit = wert THEN + bedingung (i). false exit := durch + END IF + END REP + +END PROC setze verkettung; + +PROC suchbedingung lesen (INT CONST feldnr, TEXT VAR bedingung) : + + feld lesen (muster gespeichert, feldnr, bedingung) + +END PROC suchbedingung lesen; + +PROC suchbedingung loeschen : + + disable stop; + IF umgeschaltet THEN + anzahl muster := anzahl hauptmuster + ELSE + anzahl hauptmuster := 0; + anzahl muster := 0 + END IF; + erster musterindex := -1; + oder anfang := empty intvec; + satz initialisieren (muster gespeichert); + globales muster vorhanden := FALSE; + bereits ausgewertet := TRUE; + erfuellt := NOT ende der datei + +END PROC suchbedingung loeschen; + +BOOL PROC satz ausgewaehlt : + + IF NOT bereits ausgewertet THEN + suchbedingung auswerten; + bereits ausgewertet := TRUE + END IF; + erfuellt + +END PROC satz ausgewaehlt; + +INT PROC suchversion : + + IF anzahl muster = anzahl hauptmuster THEN + 0 + ELSE + versionszaehler + END IF + +END PROC suchversion; + + +(*************************** Markierung **********************************) + +PROC mark stelle (DATEI VAR datei, INT CONST satz) : + + IF (datei. marksaetze ISUB datei. markzeiger) < satz THEN + vorwaerts gehen + ELSE + rueckwaerts gehen + END IF . + +vorwaerts gehen : + REP + datei. markzeiger INCR 1 + UNTIL (datei. marksaetze ISUB datei. markzeiger) >= satz END REP . + +rueckwaerts gehen : + WHILE datei. markzeiger > 1 CAND + (datei. marksaetze ISUB (datei. markzeiger - 1)) >= satz REP + datei. markzeiger DECR 1 + END REP . + +END PROC mark stelle; + +PROC markierung aendern : + + disable stop; + IF satz markiert THEN + delete (daten (hauptdatei). marksaetze, daten (hauptdatei). markzeiger); + markierungen DECR 1 + ELSE + insert (daten (hauptdatei). marksaetze, daten (hauptdatei). markzeiger, + satznr (daten (hauptdatei). eudat)); + markierungen INCR 1 + END IF + +END PROC markierung aendern; + +BOOL PROC satz markiert : + + INT CONST satz := satznr (daten (hauptdatei). eudat); + mark stelle (daten (hauptdatei), satz); + satz = + (daten (hauptdatei). marksaetze ISUB daten (hauptdatei). markzeiger) + +END PROC satz markiert; + +INT PROC markierte saetze : + + markierungen + +END PROC markierte saetze; + +PROC markierungen loeschen : + + disable stop; + IF umgeschaltet THEN + mark loeschen (daten (hauptdatei)) + ELSE + in allen geketteten dateien loeschen + END IF; + markierungen := 0 . + +in allen geketteten dateien loeschen : + INT VAR dateiindex := 1; + REP + mark loeschen (daten (dateiindex)); + dateiindex := daten (dateiindex). naechste datei + UNTIL dateiindex = 0 END REP . + +END PROC markierungen loeschen; + +PROC mark loeschen (DATEI VAR datei) : + + datei. marksaetze := niltext; + datei. marksaetze CAT maxint; + datei. markzeiger := 1 + +END PROC mark loeschen; + + +END PACKET datenverwaltung; + diff --git a/app/eudas/4.4/src/eudas.drucken b/app/eudas/4.4/src/eudas.drucken new file mode 100644 index 0000000..3176c23 --- /dev/null +++ b/app/eudas/4.4/src/eudas.drucken @@ -0,0 +1,1891 @@ +PACKET eudas drucken + +(*************************************************************************) +(* *) +(* Drucken von EUDAS-Dateien nach Druckmuster *) +(* *) +(* Version 10 *) +(* *) +(* Autor: Thomas Berlage *) +(* Stand: 01.10.87 *) +(* *) +(*************************************************************************) + + DEFINES + +(*dump, (* Test *) *) + + drucke, + interpretiere, + gruppentest, + + druckdatei, + direkt drucken, + max druckzeilen, + + gruppenwechsel, + lfd nr : + + +(*************************** Musterinterpreter ***************************) + +(* + EXPORTS + + INT max musterspeicher + INT VAR interpretationsmodus + interpretiere (INT CONST erste zeile, erstes muster, + PROC (INT CONST, TEXT VAR) abk) +*) + + +LET + max musterspeicher = 25, + SPEICHER = STRUCT (INT feldanfang, + feldlaenge, + setzmodus, + bearbeitet bis, + TEXT inhalt); + +ROW max musterspeicher SPEICHER VAR musterspeicher; + +INT VAR interpretationsmodus; + +LET + niltext = "", + blank = " ", + zwei blanks = " "; + +TEXT VAR ausgabezeile; + + +PROC interpretiere (INT CONST erste zeile, erstes muster, + PROC (INT CONST, TEXT VAR) abkuerzungen) : + + INT VAR + kommandoindex, + anzahl leerzeilen := 0, + anzahl wiederholungen := 0, + aktuelles muster := erstes muster; + + muster auf zeile (erste zeile); + WHILE NOT druckmusterende REP + musterzeile lesen; + IF leerzeile THEN + anzahl leerzeilen INCR 1 + ELSE + letzte leerzeilen beruecksichtigen; + zeile auswerten + END IF + END REP . + +zeile auswerten : + IF kommandozeile (kommandoindex) THEN + kommando auswerten + ELSE + zeile interpretieren; + anzahl wiederholungen := 0 + END IF . + +kommando auswerten : + SELECT kommandoindex OF + CASE modus index : modus umstellen + CASE mehr index : anzahl wiederholungen setzen + OTHERWISE LEAVE interpretiere + END SELECT . + +letzte leerzeilen beruecksichtigen : + WHILE anzahl leerzeilen > 0 REP + zeile drucken (blank); + anzahl leerzeilen DECR 1 + END REP . + +modus umstellen : + int param (interpretationsmodus) . + +anzahl wiederholungen setzen : + int param (anzahl wiederholungen) . + +leerzeile : + musterzeile = niltext OR musterzeile = blank . + +zeile interpretieren : + INT VAR + zeilenzaehler := 0, + zu bearbeitende inhalte := 0; + BOOL VAR + blanks dazwischen := FALSE; + + REP + einen zeilendurchgang; + zeilenzaehler INCR 1; + IF interpretationsmodus = 3 THEN + blanks dazwischen := TRUE + END IF + UNTIL zeile fertig bearbeitet END REP . + +zeile fertig bearbeitet : + IF interpretationsmodus <= 2 THEN + TRUE + ELIF anzahl wiederholungen <> 0 THEN + zeilenzaehler = anzahl wiederholungen + ELSE + zu bearbeitende inhalte = 0 + END IF . + +einen zeilendurchgang : + INT VAR + letztes feldende := 1, + reservelaenge := 0, + benoetigte reserve := 0, + einzulesendes muster := 1, + einzusetzendes muster := 1; + + ausgabezeile := niltext; + REP + IF musterinhalt abspeichern THEN + musterinhalt besorgen + END IF; + IF festes muster THEN + zeilenabschnitt ausgeben + END IF; + einsetzdaten sammeln; + einzulesendes muster INCR 1 + END REP . + +musterinhalt abspeichern : + zeilenzaehler = 0 . + +musterinhalt besorgen : + naechstes muster (lesespeicher. feldanfang, lesespeicher. feldlaenge, + lesespeicher. setzmodus); + IF NOT zeilenende THEN + musterinhalt lesen + END IF . + +zeilenende : + lesespeicher. feldanfang > length (musterzeile) . + +musterinhalt lesen : + INT CONST musterfunktion := musterindex (aktuelles muster); + IF musterfunktion > 0 THEN + feld lesen (musterfunktion, lesespeicher. inhalt) + ELSE + abkuerzungen (-musterfunktion, lesespeicher. inhalt) + END IF; + aktuelles muster INCR 1; + lesespeicher. bearbeitet bis := 0; + IF lesespeicher. inhalt <> niltext THEN + zu bearbeitende inhalte INCR 1 + END IF . + +festes muster : + lesespeicher. setzmodus >= 4 . + +lesespeicher : + musterspeicher (einzulesendes muster) . + +einsetzdaten sammeln : + INT CONST reserve := setzdifferenz (lesespeicher); + IF reserve > 0 THEN + reserve merken + ELSE + benoetigte reserve DECR reserve + END IF . + +reserve merken : + reservelaenge INCR reserve; + IF linksschieben verboten AND reservelaenge > benoetigte reserve THEN + reservelaenge := benoetigte reserve + END IF; + IF kein inhalt mehr einzusetzen AND variabel THEN + loeschbare blanks zaehlen + END IF . + +linksschieben verboten : + interpretationsmodus = 2 OR interpretationsmodus = 4 . + +kein inhalt mehr einzusetzen : + reserve = lesespeicher. feldlaenge . + +variabel : + (lesespeicher. setzmodus AND 1) = 0 . + +loeschbare blanks zaehlen : + IF lesespeicher. feldanfang = 1 COR + (musterzeile SUB (lesespeicher. feldanfang - 1)) = blank THEN + INT VAR ende := feldende (einzulesendes muster); + WHILE (musterzeile SUB ende) = blank REP + ende INCR 1; + lesespeicher. feldlaenge INCR 1; + reservelaenge INCR 1 + END REP + END IF . + +zeilenabschnitt ausgeben : + IF einzulesendes muster = 1 THEN + IF zeilenende THEN + zeile ganz ausgeben + END IF + ELSE + zeile bis dahin zusammenstellen + END IF . + +zeile ganz ausgeben : + IF blanks dazwischen THEN + zeile drucken (blank) + ELSE + zeile drucken (musterzeile) + END IF; + LEAVE einen zeilendurchgang . + +zeile bis dahin zusammenstellen : + INT VAR + blankluecke := 0, + blankpuffer := lesespeicher. feldanfang; + INT CONST + endeluecke := blankpuffer - length (musterzeile); + blankluecke suchen; + alle zwischenliegenden muster in ausgabedatei kopieren; + letzten zwischenraum kopieren; + zeilenende behandeln . + +blankluecke suchen : + IF endeluecke > 0 THEN + reservelaenge INCR endeluecke; + blankpuffer DECR (endeluecke - 1) + END IF; + rueckwaerts zwei blanks suchen . + +rueckwaerts zwei blanks suchen : + INT CONST + ende voriges feld := feldende (einzulesendes muster - 1), + leerstelle := + pos (musterzeile, zwei blanks, ende voriges feld, blankpuffer); + IF leerstelle > 0 THEN + blankpuffer := leerstelle; + groesse der blankluecke bestimmen + ELIF endeluecke < 0 AND (musterzeile SUB (blankpuffer - 1)) <> blank THEN + blankpuffer := ende voriges feld + END IF . + +groesse der blankluecke bestimmen : + INT VAR ende der luecke := blankpuffer + 1; + REP + blankluecke INCR 1; + ende der luecke INCR 1 + UNTIL (musterzeile SUB ende der luecke) <> blank END REP; + reservelaenge INCR blankluecke . + +alle zwischenliegenden muster in ausgabedatei kopieren : + INT VAR verschiebung := 0; + WHILE einzusetzendes muster < einzulesendes muster REP + setzspeicher in einzelvariablen lesen; + musterzwischenraum kopieren; + muster einsetzen; + einzusetzendes muster INCR 1 + END REP . + +setzspeicher in einzelvariablen lesen : + INT CONST + feldanfang := setzspeicher. feldanfang, + feldlaenge := setzspeicher. feldlaenge, + setzmodus := setzspeicher. setzmodus . + +musterzwischenraum kopieren : + zwischenraum (letztes feldende, feldanfang, blanks dazwischen); + letztes feldende := feldanfang + feldlaenge . + +setzspeicher : + musterspeicher (einzusetzendes muster) . + +muster einsetzen : + INT CONST ueberschuss := - setzdifferenz (setzspeicher); + IF ueberschuss = - feldlaenge THEN + leeres feld behandeln + ELIF ueberschuss <= 0 THEN + in voller laenge einsetzen + ELIF variable laenge AND reserve vorhanden THEN + einsetzen und nach rechts schieben + ELSE + bis zur grenze einsetzen + END IF . + +leeres feld behandeln : + IF variable laenge THEN + verschiebung INCR ueberschuss; + IF linksschieben verboten THEN + verschiebung korrigieren + END IF + ELSE + blanks anfuegen (-ueberschuss) + END IF . + +verschiebung korrigieren : + IF verschiebung < 0 THEN + blanks anfuegen (-verschiebung); + verschiebung := 0 + END IF . + +in voller laenge einsetzen : + IF rechtsbuendig THEN + blanks anfuegen (-ueberschuss) + END IF; + musterspeicher ganz ausgeben (setzspeicher); + zu bearbeitende inhalte DECR 1; + IF feste laenge THEN + ggf mit blanks auffuellen + ELSE + verschiebung INCR ueberschuss; + linksschieben korrigieren + END IF . + +rechtsbuendig : + (setzmodus AND 2) = 2 . + +feste laenge : + (setzmodus AND 1) = 1 . + +ggf mit blanks auffuellen : + IF NOT rechtsbuendig THEN + blanks anfuegen (-ueberschuss) + END IF . + +linksschieben korrigieren : + IF linksschieben verboten AND verschiebung < 0 THEN + blanks anfuegen (-verschiebung); + verschiebung := 0 + END IF . + +variable laenge : + NOT feste laenge . + +reserve vorhanden : + ueberschuss <= reservelaenge . + +einsetzen und nach rechts schieben : + musterspeicher ganz ausgeben (setzspeicher); + zu bearbeitende inhalte DECR 1; + verschiebung INCR ueberschuss; + reservelaenge DECR ueberschuss . + +bis zur grenze einsetzen : + INT VAR + umbruchblanks := 0, + anfang := setzspeicher. bearbeitet bis + 1, + setz ende := anfang + feldlaenge - 1; + IF variable laenge THEN + setz ende INCR reservelaenge + END IF; + IF rechtsbuendig AND keine mehrfachzeilen THEN + rechten teil einsetzen + ELIF mehrfachzeilen erlaubt THEN + umbruch + END IF; + teilfeld ausgeben; + IF variable laenge THEN + verschiebung INCR reservelaenge; + reservelaenge := 0 + END IF . + +rechten teil einsetzen : + INT CONST nach rechts := length (setzspeicher. inhalt) - setz ende; + anfang INCR nach rechts; + setz ende INCR nach rechts . + +mehrfachzeilen erlaubt : + interpretationsmodus >= 3 . + +keine mehrfachzeilen : + NOT mehrfachzeilen erlaubt . + +teilfeld ausgeben : + IF rechtsbuendig THEN + blanks anfuegen (umbruchblanks) + END IF; + druckausgabe (setzspeicher. inhalt, anfang, setz ende); + IF linksbuendig THEN + blanks anfuegen (umbruchblanks) + END IF . + +linksbuendig : + NOT rechtsbuendig . + +umbruch : + IF pos (setzspeicher. inhalt, blank, anfang, setz ende) > 0 THEN + ende zuruecksetzen + END IF; + INT CONST naechstes wort := + pos (setzspeicher. inhalt, ""33"", ""254"", setz ende + 1); + IF naechstes wort = 0 THEN + setzspeicher. bearbeitet bis := length (setzspeicher. inhalt); + zu bearbeitende inhalte DECR 1 + ELSE + setzspeicher. bearbeitet bis := naechstes wort - 1 + END IF . + +ende zuruecksetzen : + setz ende INCR 1; umbruchblanks DECR 1; + WHILE (setzspeicher. inhalt SUB setz ende) <> blank REP + setz ende DECR 1; + umbruchblanks INCR 1 + END REP; + WHILE (setzspeicher. inhalt SUB setz ende) = blank REP + setz ende DECR 1; + umbruchblanks INCR 1 + UNTIL ende < anfang END REP . + +letzten zwischenraum kopieren : + zwischenraum (letztes feldende, blankpuffer, blanks dazwischen); + IF verschiebung < 0 THEN + IF blankpuffer <= length (musterzeile) THEN + blanks anfuegen (-verschiebung) + END IF; + letztes feldende := blankpuffer + ELSE + letztes feldende := blankpuffer + min (verschiebung, blankluecke) + END IF . + +zeilenende behandeln : + IF endeluecke > 0 THEN + rest der musterzeile drucken; + zeile ausgeben; + LEAVE einen zeilendurchgang + ELSE + folgenden abschnitt vorbereiten + END IF . + +rest der musterzeile drucken : + IF NOT blanks dazwischen THEN + druckausgabe (musterzeile, letztes feldende, length (musterzeile)) + END IF . + +zeile ausgeben : + INT VAR neues ende := length (ausgabezeile); + IF (ausgabezeile SUB neues ende) = blank THEN + REP + neues ende DECR 1 + UNTIL (ausgabezeile SUB neues ende) <> blank END REP; + ausgabezeile := subtext (ausgabezeile, 1, neues ende) + END IF; + IF absatzmarkierung noetig THEN + ausgabezeile CAT blank + END IF; + zeile drucken (ausgabezeile) . + +absatzmarkierung noetig : + (musterzeile SUB LENGTH musterzeile) = blank AND + (interpretationsmodus <> 3 OR zu bearbeitende inhalte = 0) . + +folgenden abschnitt vorbereiten : + reservelaenge := 0; + benoetigte reserve := 0 . + +END PROC interpretiere; + +INT PROC feldende (INT CONST speicherindex) : + + musterspeicher (speicherindex). feldanfang + + musterspeicher (speicherindex). feldlaenge + +END PROC feldende; + +INT PROC setzdifferenz (SPEICHER CONST speicher) : + + speicher. feldlaenge - length (speicher. inhalt) + + speicher. bearbeitet bis + +END PROC setzdifferenz; + +LET + zehn blanks = " "; + +PROC blanks anfuegen (INT CONST anzahl) : + + INT VAR zaehler := anzahl; + WHILE zaehler >= 10 REP + ausgabezeile CAT zehn blanks; + zaehler DECR 10 + END REP; + WHILE zaehler > 0 REP + ausgabezeile CAT blank; + zaehler DECR 1 + END REP + +END PROC blanks anfuegen; + +PROC musterspeicher ganz ausgeben (SPEICHER VAR speicher) : + + IF speicher. bearbeitet bis = 0 THEN + ausgabezeile CAT speicher. inhalt + ELSE + druckausgabe (speicher. inhalt, speicher. bearbeitet bis + 1, + length (speicher. inhalt)) + END IF; + speicher. bearbeitet bis := length (speicher. inhalt) + +END PROC musterspeicher ganz ausgeben; + +PROC zwischenraum (INT CONST von, bis, BOOL CONST blanks dazwischen) : + + IF blanks dazwischen THEN + blanks anfuegen (bis - von) + ELSE + druckausgabe (musterzeile, von, bis - 1) + END IF + +END PROC zwischenraum; + +TEXT VAR ausgabepuffer; + +PROC druckausgabe (TEXT CONST context, INT CONST von, bis) : + + ausgabepuffer := subtext (context, von, bis); + ausgabezeile CAT ausgabepuffer + +END PROC druckausgabe; + + +(************************* Musterscanner *********************************) + +(* + EXPORTS + + FILE VAR druckmuster + naechstes muster (TEXT VAR mustername) + naechstes muster (INT VAR musteranfang, musterlaenge, setzmodus) + musterzeile lesen + TEXT musterzeile + INT zeilennr + muster auf zeile (INT CONST neue zeile) + BOOL kommandozeile (INT VAR kommandoindex) + int param (INT VAR param) + INT m pos + BOOL druckmusterende + ueberlesen (TEXT CONST zeichen) + INT musterzeilenbreite + standard musterzeilenbreite +*) + + +FILE VAR druckmuster; + +TEXT VAR musterzeile; + +INT VAR m pos; + +LET + keine schliessende klammer = #401# + "keine schliessende Klammer in Feldmuster", + kein kommando in kommandozeile = #402# + "kein Kommando in Kommandozeile", + unbekanntes kommando = #403# + "unbekanntes Kommando"; + +LET + fix symbol = "&", + var symbol = "%", + com symbol = "%", + klammer auf = "<", + klammer zu = ">"; + +LET + kommandos = #404# + " "1"VOR "1"VORSPANN "2"WDH "2"WIEDERHOLUNG "3"NACH "3"NACHSPANN + "4"ABK "4"ABKUERZUNGEN "5"GRUPPE "6"MODUS "7"MEHR " + + +LET + vor index = 1, + wdh index = 2, + nach index = 3, + abk index = 4, + gruppe index = 5, + modus index = 6, + mehr index = 7, + do index = 100; + +INT VAR + musterzeilenbreite, + name anfang, + name ende; + +BOOL VAR + druckmusterende, + zeile gelesen; + + +. +zeilennr : + line no (druckmuster) . + +standard musterzeilenbreite : + musterzeilenbreite := maxlinelength (druckmuster) . + + +PROC ueberlesen (TEXT CONST zeichen) : + + REP + m pos INCR 1 + UNTIL (musterzeile SUB m pos) <> zeichen END REP + +END PROC ueberlesen; + +PROC naechstes muster (INT VAR anfang, laenge, setzmodus) : + + m pos auf naechsten anfang; + IF zeilenende THEN + anfang := max (musterzeilenbreite, length (musterzeile)) + 1; + laenge := 0; + setzmodus := 5 + ELSE + anfang := m pos; + muster lesen + END IF . + +m pos auf naechsten anfang : + m pos auf zeichen (fix symbol, var symbol) . + +zeilenende : + m pos > length (musterzeile) . + +muster lesen : + TEXT CONST musterzeichen := musterzeile SUB m pos; + IF musterzeichen = var symbol THEN + setzmodus := 0 + ELSE + setzmodus := 4 + END IF; + anfangszeichen ueberlesen; + feldnamen lesen; + endezeichen ueberlesen . + +anfangszeichen ueberlesen : + ueberlesen (musterzeichen); + IF m pos - 1 > anfang THEN + ist rechtsbuendig + END IF . + +ist rechtsbuendig : + setzmodus INCR 3 . + +feldnamen lesen : + IF (musterzeile SUB m pos) = klammer auf THEN + bis klammer zu lesen + ELSE + bis blank oder muster lesen + END IF; + IF leerer feldname THEN + naechstes muster (anfang, laenge, setzmodus); + LEAVE naechstes muster + END IF . + +leerer feldname : + name anfang > name ende . + +bis klammer zu lesen : + name anfang := m pos + 1; + name ende := pos (musterzeile, klammer zu, name anfang); + IF name ende = 0 THEN + fehler (keine schliessende klammer, subtext (musterzeile, m pos)); + name ende := length (musterzeile) + ELSE + name ende DECR 1 + END IF; + m pos := name ende + 2 . + +bis blank oder muster lesen : + name anfang := m pos; + m pos auf zeichen (blank, var symbol); + INT CONST zwischenpos := pos (musterzeile, fix symbol, name anfang, m pos); + IF zwischenpos > 0 THEN + m pos := zwischenpos + END IF; + name ende := m pos - 1 . + +endezeichen ueberlesen : + IF musterzeichen angetroffen THEN + ist fest; + ueberlesen (musterzeichen) + END IF; + laenge := m pos - anfang . + +musterzeichen angetroffen : + (musterzeile SUB m pos) = musterzeichen . + +ist fest : + setzmodus := setzmodus OR 1 . + +END PROC naechstes muster; + +PROC naechstes muster (TEXT VAR name) : + + INT VAR d1, laenge, d3; + naechstes muster (d1, laenge, d3); + IF laenge > 0 THEN + name := subtext (musterzeile, name anfang, name ende) + ELSE + name := niltext + END IF + +END PROC naechstes muster; + +PROC m pos auf zeichen (TEXT CONST zeichen 1, zeichen 2) : + + INT CONST + pos 1 := pos (musterzeile, zeichen 1, m pos), + pos 2 := pos (musterzeile, zeichen 2, m pos); + m pos := length (musterzeile) + 1; + IF pos 1 > 0 THEN + m pos := pos 1 + END IF; + IF pos 2 > 0 AND pos 2 < m pos THEN + m pos := pos 2 + END IF + +END PROC m pos auf zeichen; + +PROC muster auf zeile (INT CONST zeile) : + + to line (druckmuster, zeile); + zeile gelesen := FALSE; + druckmusterende := eof (druckmuster) + +END PROC muster auf zeile; + +PROC musterzeile lesen : + + IF zeile gelesen THEN + down (druckmuster) + ELSE + zeile gelesen := TRUE + END IF; + read record (druckmuster, musterzeile); + m pos := 1; + druckmusterende := line no (druckmuster) >= lines (druckmuster) + +END PROC musterzeile lesen; + +BOOL PROC kommandozeile (INT VAR kommandoindex) : + + m pos := 1; + IF (musterzeile SUB 1) <> com symbol THEN + FALSE + ELIF (musterzeile SUB 2) <> com symbol THEN + kommando abtrennen; + kommandoindex bestimmen; + TRUE + ELSE + kommandoindex := do index; + TRUE + END IF . + +kommando abtrennen : + TEXT VAR kommando; + ueberlesen (blank); + IF m pos > length (musterzeile) THEN + fehler (kein kommando in kommandozeile, musterzeile); + kommandoindex := 0; + LEAVE kommandozeile WITH TRUE + END IF; + INT CONST blank pos := pos (musterzeile, blank, m pos); + IF blank pos = 0 THEN + kommando := subtext (musterzeile, m pos); + kommando CAT blank; + m pos := length (musterzeile) + 1 + ELSE + kommando := subtext (musterzeile, m pos, blank pos); + m pos := blank pos + END IF . + +kommandoindex bestimmen : + INT CONST wo := pos (kommandos, kommando); + IF wo > 0 CAND (kommandos SUB (wo - 2)) = blank THEN + kommandoindex := code (kommandos SUB (wo - 1)) + ELSE + kommandoindex := 0; + fehler (unbekanntes kommando, kommando); + END IF . + +END PROC kommandozeile; + +PROC int param (INT VAR param) : + + ueberlesen (blank); + INT CONST par anfang := m pos; + WHILE ziffer REP + m pos INCR 1 + END REP; + IF m pos > par anfang THEN + param := int (subtext (musterzeile, par anfang, m pos - 1)) + ELSE + param := -1 + END IF . + +ziffer : + pos ("0123456789", musterzeile SUB m pos) > 0 . + +END PROC int param; + + +(**************************** Codegenerierung ****************************) + +(* + EXPORTS + + FILE VAR programm + BOOL wird uebersetzt + proc name (TEXT CONST name) + end proc + anweisung (TEXT CONST text) + anweisung (TEXT CONST pre, mid, post) + anweisung (TEXT CONST pre, INT CONST spalte, TEXT CONST post) + interpret anweisung (INT CONST zeile, muster) +*) + +FILE VAR programm; + +TEXT VAR + aktuelle proc; + +BOOL VAR + wird uebersetzt; + + +PROC proc name (TEXT CONST name) : + + aktuelle proc := name; + programmausgabe ("PROC ", name, " :") + +END PROC proc name; + +PROC end proc : + + programmausgabe ("END PROC ", aktuelle proc, ";") + +END PROC end proc; + +PROC anweisung (TEXT CONST programmtext) : + + wird uebersetzt := TRUE; + putline (programm, programmtext) + +END PROC anweisung; + +PROC anweisung (TEXT CONST pre, mid, post) : + + wird uebersetzt := TRUE; + programmausgabe (pre, mid, post) + +END PROC anweisung; + +PROC programmausgabe (TEXT CONST pre, mid, post) : + + write (programm, pre); + write (programm, mid); + write (programm, post); + line (programm) + +END PROC programmausgabe; + +TEXT VAR textpuffer; + +PROC anweisung (TEXT CONST pre, INT CONST spalte, TEXT CONST post) : + + text puffer := subtext (musterzeile, spalte); + anweisung (pre, textpuffer, post) + +END PROC anweisung; + +PROC interpret anweisung (INT CONST zeile, muster) : + + programmausgabe ("; interpretiere (", + text (zeile) + ", " + text (muster), + ", PROC (INT CONST, TEXT VAR) abk);") + +END PROC interpret anweisung; + + +(************************ Muster uebersetzen *****************************) + +(* + EXPORTS + + druckmuster uebersetzen + ROW 3 ABSCHNITT VAR abschnitte + ROW max muster INT VAR musterindex + fehler (TEXT CONST meldung) + ROW maxgruppen GRUPPE VAR gruppen + +*) + + +LET + vorzeitiges ende = #405# + "kein % WIEDERHOLUNG gefunden", + nur gruppe erlaubt = #406# + "Nur GRUPPE-Anweisung erlaubt", + kein do mehr erlaubt nach gruppen = #407# + "keine ELAN-Anweisung im Initialisierungsteil nach Gruppendefinition", + illegale gruppennummer = #408# + "illegale Gruppennummer", + gruppe schon definiert = #409# + "diese Gruppe wurde schon definiert", + abkuerzung nicht definiert = #410# + "diese Abkuerzung ist nicht definiert", + abschnitt mehrfach definiert = #411# + "dieser Abschnitt wurde schon einmal definiert", + falscher modus = #412# + "falscher Modus", + im musterteil nicht erlaubt = #413# + "diese Anweisung darf im Musterteil nicht vorkommen", + im abkuerzungsteil nicht erlaubt = #414# + "im Abkuerzungsteil darf keine Anweisung auftreten", + zuviele muster pro zeile = #415# + "in dieser Zeile stehen zu viele Feldmuster", + zuviele muster = #416# + "das Druckmuster enthaelt zu viele Feldmuster", + name der abkuerzung fehlt = #417# + "nach dem ""&"" soll direkt der Name einer Abkuerzung folgen", + kein doppelpunkt nach abkuerzung = #418# + "kein Doppelpunkt nach Abkuerzung", + abkuerzung mehrfach definiert = #419# + "Abkuerzung mehrfach definiert", + zu viele abkuerzungen = #420# + "das Druckmuster enthaelt zu viele Abkuerzungen"; + +LET + max muster = 200, + max gruppen = 4, + max abkuerzungen = 250, + + GRUPPE = STRUCT (BOOL wechsel, + definiert, + TEXT inhalt), + + ABSCHNITT = STRUCT (INT erstes muster, + erste zeile, + TEXT proc name); + + +ROW max muster INT VAR musterindex; + +INT VAR anzahl muster; + +ROW maxgruppen GRUPPE VAR gruppen; + +ROW 3 ABSCHNITT VAR abschnitte; + +SATZ VAR abkuerzungen; + +TEXT VAR + abkuerzungszeile; + +INT VAR + anzahl abkuerzungen; + + +OP CAT (TEXT VAR intvec, INT CONST wert) : + + TEXT VAR platz fuer int := " "; + replace (platz fuer int, 1, wert); + intvec CAT platz fuer int + +END OP CAT; + +PROC druckmuster uebersetzen : + + enable stop; + muster auf zeile (1); + uebersetzungsvariablen initialisieren; + initialisierungsteil uebersetzen; + WHILE NOT druckmusterende REP + einen von drei abschnitten uebersetzen + END REP; + abkuerzungen einsetzen . + +uebersetzungsvariablen initialisieren : + INT VAR kommandoindex; + INT VAR i; + anzahl abkuerzungen := 0; + satz initialisieren (abkuerzungen); + abkuerzungszeile := niltext; + anzahl muster := 0; + wird uebersetzt := FALSE; + abschnitte (1) := ABSCHNITT : (0, 0, "vorspann"); + abschnitte (2) := ABSCHNITT : (0, 0, "wdh"); + abschnitte (3) := ABSCHNITT : (0, 0, "nachspann"); + FOR i FROM 1 UPTO max gruppen REP + gruppen (i). definiert := FALSE + END REP . + +initialisierungsteil uebersetzen : + BOOL VAR + schon gruppendefinition := FALSE; + + REP + IF druckmusterende THEN + fehler (vorzeitiges ende); + LEAVE druckmuster uebersetzen + END IF; + musterzeile lesen; + IF kommandozeile (kommandoindex) THEN + initialisierungskommando uebersetzen + END IF + END REP . + +initialisierungskommando uebersetzen : + SELECT kommandoindex OF + + CASE do index : + do kommando kopieren + + CASE gruppe index : + gruppendefinition aufnehmen + + CASE vor index, wdh index, nach index : + IF NOT schon gruppendefinition THEN + proc name ("gruppen") + END IF; + end proc; + LEAVE initialisierungsteil uebersetzen + + OTHERWISE + IF kommandoindex > 0 THEN + fehler (nur gruppe erlaubt) + END IF + + END SELECT . + +do kommando kopieren : + IF schon gruppendefinition THEN + fehler (kein do mehr erlaubt nach gruppen, musterzeile) + ELSE + replace (musterzeile, 1, " "); + anweisung (musterzeile) + END IF . + +gruppendefinition aufnehmen : + IF NOT schon gruppendefinition THEN + proc name ("gruppen"); + schon gruppendefinition := TRUE + END IF; + INT VAR gruppennr; + int param (gruppennr); + IF gruppennr < 1 OR gruppennr > max gruppen THEN + fehler (illegale gruppennummer, musterzeile) + ELIF gruppen (gruppennr). definiert THEN + fehler (gruppe schon definiert, musterzeile) + ELSE + gruppen (gruppennr). definiert := TRUE; + ausdruck uebersetzen + END IF . + +ausdruck uebersetzen : + anweisung ("gruppentest (", text (gruppennr), ", "); + anweisung (" ", m pos, ");") . + +einen von drei abschnitten uebersetzen : + SELECT kommandoindex OF + CASE vor index : vorspann uebersetzen + CASE wdh index : wiederholungsteil uebersetzen + CASE nach index : nachspann uebersetzen + END SELECT . + +vorspann uebersetzen : + abschnitt uebersetzen (abschnitte (1), kommandoindex) . + +wiederholungsteil uebersetzen : + int param (spalten); int param (spaltenbreite); + abschnitt uebersetzen (abschnitte (2), kommandoindex) . + +nachspann uebersetzen : + abschnitt uebersetzen (abschnitte (3), kommandoindex) . + +abkuerzungen einsetzen : + IF wird uebersetzt THEN + fehlende procs definieren; + abk headline + END IF; + abkuerzungen ueberpruefen; + IF wird uebersetzt THEN + abk ende; + druckaufruf + END IF . + +abkuerzungen ueberpruefen : + FOR i FROM 1 UPTO anzahl abkuerzungen REP + IF (abkuerzungszeile ISUB i) > 0 THEN + fehler (abkuerzung nicht definiert, + name der abkuerzung, abkuerzungszeile ISUB i) + ELSE + anweisung in abk proc generieren + END IF + END REP . + +name der abkuerzung : + TEXT VAR puffer; + feld lesen (abkuerzungen, i, puffer); + puffer . + +fehlende procs definieren : + FOR i FROM 1 UPTO 3 REP + IF abschnitte (i). erste zeile = 0 THEN + abschnitt proc definieren + END IF + END REP . + +abschnitt proc definieren : + proc name (abschnitte (i). proc name); + end proc . + +abk headline : + anweisung ("PROC abk (INT CONST nr, TEXT VAR inhalt) :"); + IF anzahl abkuerzungen > 0 THEN + anweisung ("SELECT nr OF") + ELSE + anweisung ("inhalt := text (nr)") + END IF . + +anweisung in abk proc generieren : + TEXT CONST lfd index := text (i); + anweisung ("CASE " + lfd index, " : inhalt := abk", lfd index) . + +abk ende : + IF anzahl abkuerzungen > 0 THEN + anweisung ("END SELECT") + END IF; + anweisung ("END PROC abk;") . + +druckaufruf : + anweisung + ("drucke (PROC gruppen, PROC vorspann, PROC wdh, PROC nachspann)") . + +END PROC druckmuster uebersetzen; + +PROC abschnitt uebersetzen (ABSCHNITT VAR abschnitt, + INT VAR kommandoindex) : + + BOOL VAR war do zeile := TRUE; (* generiert erstes 'interpretiere' *) + proc name (abschnitt. proc name); + abschnitt anfang speichern; + musterteil uebersetzen; + abkuerzungen uebersetzen . + +abschnitt anfang speichern : + IF abschnitt. erste zeile <> 0 THEN + fehler (abschnitt mehrfach definiert, musterzeile) + END IF; + abschnitt. erste zeile := zeilennr + 1; + abschnitt. erstes muster := anzahl muster + 1 . + +musterteil uebersetzen : + WHILE NOT druckmusterende REP + musterzeile lesen; + IF kommandozeile (kommandoindex) THEN + abschnitt kommando uebersetzen + ELSE + interpret anweisung generieren; + musterzeile auf feldmuster untersuchen + END IF + END REP; + abschnitt beenden; + LEAVE abschnitt uebersetzen . + +abschnitt kommando uebersetzen : + SELECT kommandoindex OF + + CASE do index : + replace (musterzeile, 1, " "); + anweisung (musterzeile); + war do zeile := TRUE + + CASE vor index, wdh index, nach index : + abschnitt beenden; + LEAVE abschnitt uebersetzen + + CASE abk index : + abschnitt beenden; + LEAVE musterteil uebersetzen + + CASE modus index : + interpret anweisung generieren; + INT VAR parameter; + int param (parameter); + IF parameter < 1 OR parameter > 4 THEN + fehler (falscher modus, musterzeile) + END IF + + CASE mehr index : + interpret anweisung generieren + + OTHERWISE + IF kommandoindex > 0 THEN + fehler (im musterteil nicht erlaubt) + END IF + + END SELECT . + +interpret anweisung generieren : + IF war do zeile THEN + interpret anweisung (zeilennr, anzahl muster + 1); + war do zeile := FALSE + END IF . + +abschnitt beenden : + end proc . + +musterzeile auf feldmuster untersuchen : + TEXT VAR name; + INT VAR muster pro zeile := 0; + + REP + naechstes muster (name); + IF name = niltext THEN + LEAVE musterzeile auf feldmuster untersuchen + END IF; + muster pro zeile INCR 1; + muster uebersetzen + END REP . + +muster uebersetzen : + IF muster pro zeile >= max musterspeicher THEN + fehler (zu viele muster pro zeile) + END IF; + IF anzahl muster = max muster THEN + fehler (zu viele muster) + ELSE + anzahl muster INCR 1 + END IF; + vorlaeufigen musterindex suchen . + +vorlaeufigen musterindex suchen : + INT VAR feldnr := feldnummer (name); + IF feldnr = 0 THEN + feldnr := feldindex (abkuerzungen, name); + IF feldnr = 0 THEN + abkuerzung eintragen (name, zeilennr); + musterindex (anzahl muster) := -anzahl abkuerzungen + ELSE + musterindex (anzahl muster) := -feldnr + END IF + ELSE + musterindex (anzahl muster) := feldnr + END IF . + +abkuerzungen uebersetzen : + BOOL VAR erste abkuerzungszeile := TRUE; + WHILE NOT druckmusterende REP + musterzeile lesen; + IF kommandozeile (kommandoindex) THEN + auf ende pruefen + ELIF zeile nicht leer THEN + abkuerzung behandeln + END IF + END REP . + +auf ende pruefen : + SELECT kommandoindex OF + CASE vor index, wdh index, nach index : + LEAVE abkuerzungen uebersetzen + OTHERWISE + IF kommandoindex > 0 THEN + fehler (im abkuerzungsteil nicht erlaubt) + END IF + END SELECT . + +abkuerzung behandeln : + IF erste abkuerzungszeile THEN + anweisung ("."); + erste abkuerzungszeile := FALSE + END IF; + IF erste zeile einer abkuerzung THEN + namen isolieren + ELSE + anweisung (musterzeile) + END IF . + +erste zeile einer abkuerzung : + (musterzeile SUB 1) = fix symbol . + +namen isolieren : + TEXT VAR abkuerzungsname; + naechstes muster (abkuerzungsname); + IF abkuerzungsname = niltext THEN + fehler (name der abkuerzung fehlt, musterzeile); + LEAVE namen isolieren + END IF; + doppelpunkt suchen; + an compiler uebergeben . + +doppelpunkt suchen : + LET doppelpunkt = ":"; + m pos DECR 1; (* wegen 'ueberlesen' *) + ueberlesen (blank); + IF (musterzeile SUB m pos) = doppelpunkt THEN + m pos INCR 1 + ELSE + fehler (kein doppelpunkt nach abkuerzung, musterzeile) + END IF . + +an compiler uebergeben : + abkuerzung eintragen (abkuerzungsname, 0); + anweisung (refinement name, m pos - 1, "") . + +refinement name : + "abk" + text (feldindex (abkuerzungen, abkuerzungsname)) . + +zeile nicht leer : + musterzeile <> niltext AND musterzeile <> blank . + +END PROC abschnitt uebersetzen; + +PROC abkuerzung eintragen (TEXT CONST name, INT CONST zeile) : + + INT CONST vorhanden := feldindex (abkuerzungen, name); + IF vorhanden > 0 THEN + alten eintrag ergaenzen + ELSE + neu anlegen + END IF . + +alten eintrag ergaenzen : + IF (abkuerzungszeile ISUB vorhanden) > 0 THEN + replace (abkuerzungszeile, vorhanden, zeile) + ELIF zeile = 0 THEN + fehler (abkuerzung mehrfach definiert, name) + END IF . + +neu anlegen : + IF anzahl abkuerzungen = max abkuerzungen THEN + fehler (zu viele abkuerzungen) + ELSE + anzahl abkuerzungen INCR 1 + END IF; + abkuerzungszeile CAT zeile; + feld aendern (abkuerzungen, anzahl abkuerzungen, name) . + +END PROC abkuerzung eintragen; + +LET + fehler in = #421# + "FEHLER in Zeile ", + fehler bei = #422# + " bei >>", + fehler ende = #423# + "<<"; + +PROC fehler (TEXT CONST fehlermeldung, bei, INT CONST zeile) : + + LET + blanks = " "; + TEXT VAR + meldung := fehler in; + meldung CAT text (zeile); + IF bei <> niltext THEN + meldung CAT fehler bei; + meldung CAT bei; + meldung CAT fehler ende + END IF; + note (meldung); note line; + note (blanks); note (fehlermeldung); note line; + IF online AND command dialogue THEN + line; + putline (meldung); + put (blanks); putline (fehlermeldung) + END IF + +END PROC fehler; + +PROC fehler (TEXT CONST fehlermeldung) : + + fehler (fehlermeldung, niltext, zeilennr) + +END PROC fehler; + +PROC fehler (TEXT CONST fehlermeldung, bei) : + + fehler (fehlermeldung, bei, zeilennr) + +END PROC fehler; + + +(************************** Drucksteuerung *******************************) + +(* + EXPORTS + + drucke (TEXT CONST dateiname) + drucke (PROC gruppen, PROC vor, PROC wdh, PROC nach) + druckdatei (TEXT CONST dateiname) + direkt drucken (BOOL CONST modus) + BOOL direkt drucken + max druckzeilen (INT CONST zeilen) + BOOL gruppenwechsel (INT CONST gruppennr) + gruppentest (INT CONST gruppe, TEXT CONST merkmal) + TEXT lfd nr + zeile drucken (TEXT CONST zeile) + INT spalten + INT spaltenbreite +*) + + +LET + erzeugtes programm = #424# + "erzeugtes Programm", + keine datei geoeffnet = #425# + "keine Datei geoeffnet", + interner fehler = #426# + "interner Fehler", + druckausgabe steht in = #427# + "Druckausgabe steht in", + zum drucker geschickt = #428# + "zum Drucker geschickt.", + direkt drucken nicht moeglich = #429# + "direkt Drucken nicht moeglich", + eudas ausgabe punkt = #430# + ".a$"; + +TEXT VAR + spaltenpuffer, + druckdateiname; + +BOOL VAR + wechsel erfolgt, + wechsel 0, + externer dateiname, + direkt ausdrucken; + +FILE VAR ausgabe; + +INT VAR + spalten, + spaltenbreite, + gedruckte spalten, + gemeinsamer anfang, + gedruckte zeilen, + max zeilen := 4000, + satzzaehler; + + +PROC drucke : + + drucke (last param) + +END PROC drucke; + +PROC drucke (TEXT CONST dateiname) : + + enable stop; + last param (dateiname); + druckmuster := sequential file (input, dateiname); + modify (druckmuster); + IF anzahl dateien = 0 THEN + errorstop (keine datei geoeffnet) + END IF; + disable stop; + programmdatei einrichten; + druckmuster uebersetzen; + IF anything noted THEN + note edit (druckmuster) + ELIF wird uebersetzt THEN + programm uebersetzen + ELSE + drucke (PROC dummy gruppentest, + PROC std vor, PROC std wdh, PROC std nach) + END IF; + forget (programmdatei, quiet) . + +programmdatei einrichten : + TEXT VAR programmdatei; + INT VAR i := 0; + REP + i INCR 1; + programmdatei := text (i) + UNTIL NOT exists (programmdatei) END REP; + programm := sequential file (output, programmdatei); + headline (programm, erzeugtes programm) . + +programm uebersetzen : + run (programmdatei); + last param (dateiname) . + +END PROC drucke; + +PROC dummy gruppentest : END PROC dummy gruppentest; + +PROC std vor : + + abschnitt ausfuehren (1) + +END PROC std vor; + +PROC std wdh : + + abschnitt ausfuehren (2) + +END PROC std wdh; + +PROC std nach : + + abschnitt ausfuehren (3) + +END PROC std nach; + +PROC abschnitt ausfuehren (INT CONST nr) : + + IF abschnitte (nr). erste zeile > 0 THEN + interpretiere (abschnitte (nr). erste zeile, + abschnitte (nr). erstes muster, + PROC (INT CONST, TEXT VAR) std abk) + END IF + +END PROC abschnitt ausfuehren; + +PROC std abk (INT CONST nr, TEXT VAR inhalt) : + + errorstop (interner fehler); + inhalt := code (nr) (* Dummy-Anweisung, damit Parameter benutzt *) + +END PROC std abk; + +PROC drucke (PROC grp test, PROC vorspann, PROC wdh, PROC nachspann) : + + INT VAR + modus, + letzter satz, + letzte kombination; + + enable stop; + druckdatei eroeffnen; + auf ersten satz; + gruppen initialisieren; + satzzaehler := 1; + WHILE NOT dateiende REP + bei gruppenwechsel nachspann und vorspann; + cout (satznummer); + wiederholungsteil interpretieren; + weiter (modus); + ende der druckdatei ueberpruefen + END REP; + letzten nachspann drucken; + datei ausdrucken; + auf satz (1) . + +auf ersten satz : + letzter satz := 0; + auf satz (1); + IF markierte saetze > 0 THEN + modus := 3; + IF NOT satz markiert THEN weiter (modus) END IF + ELSE + modus := 2; + IF NOT satz ausgewaehlt THEN weiter (modus) END IF + END IF . + +gruppen initialisieren : + INT VAR i; + FOR i FROM 1 UPTO maxgruppen REP + gruppen (i). inhalt := niltext + END REP . + +bei gruppenwechsel nachspann und vorspann : + IF letzter satz = 0 THEN + grp test; + alle gruppen wechseln; + abschnitt interpretieren (PROC vorspann) + ELSE + wechsel 0 := FALSE; + gruppenwechsel testen; + gruppenwechsel mit nachspann + END IF; + letzter satz := satznummer; + letzte kombination := satzkombination . + +gruppenwechsel testen : + wechsel erfolgt := FALSE; + grp test . + +gruppenwechsel mit nachspann : + IF wechsel erfolgt THEN + nachspann drucken (letzter satz, letzte kombination, PROC nachspann) + END IF; + satzzaehler INCR 1; + IF wechsel erfolgt THEN + abschnitt interpretieren (PROC vorspann) + END IF . + +wiederholungsteil interpretieren : + IF spaltenbreite < 1 THEN + standard musterzeilenbreite + ELSE + musterzeilenbreite := spaltenbreite + END IF; + IF gedruckte spalten < spalten THEN + to line (ausgabe, gemeinsamer anfang) + ELSE + to line (ausgabe, gedruckte zeilen + 1); + gemeinsamer anfang := gedruckte zeilen + 1; + gedruckte spalten := 0 + END IF; + interpretationsmodus := 1; + wdh; + gedruckte spalten INCR 1 . + +ende der druckdatei ueberpruefen : + IF gedruckte zeilen > maxzeilen THEN + datei ausdrucken; + druckdatei eroeffnen + END IF . + +letzten nachspann drucken : + alle gruppen wechseln; + IF letzter satz = 0 THEN + abschnitt interpretieren (PROC nachspann) + ELSE + nachspann drucken (letzter satz, letzte kombination, PROC nachspann) + END IF; + muster auf zeile (1) . + +END PROC drucke; + +PROC alle gruppen wechseln : + + INT VAR i; + FOR i FROM 1 UPTO max gruppen REP + gruppen (i). wechsel := TRUE + END REP; + wechsel 0 := TRUE; + wechsel erfolgt := TRUE + +END PROC alle gruppen wechseln; + +PROC abschnitt interpretieren (PROC abschnitt) : + + gedruckte spalten := spalten; + to line (ausgabe, gedruckte zeilen + 1); + standard musterzeilenbreite; + interpretationsmodus := 1; + abschnitt + +END PROC abschnitt interpretieren; + +PROC nachspann drucken (INT CONST letzter satz, letzte kombination, + PROC nachspann) : + + INT CONST + aktueller satz := satznummer, + aktuelle kombination := satzkombination; + auf satz (letzter satz); + WHILE satzkombination <> letzte kombination REP weiter (1) END REP; + abschnitt interpretieren (PROC nachspann); + auf satz (aktueller satz); + WHILE satzkombination <> aktuelle kombination REP weiter (1) END REP + +END PROC nachspann drucken; + +PROC druckdatei eroeffnen : + + IF aktueller editor > 0 THEN + in editfile schreiben + ELSE + in ausgabedatei schreiben + END IF; + druckanweisungen uebertragen . + +in editfile schreiben : + ausgabe := edit file; + IF col > 1 THEN + split line (ausgabe, col, FALSE); + down (ausgabe); col (ausgabe, 1) + END IF; + gedruckte zeilen := line no (ausgabe) - 1 . + +in ausgabedatei schreiben : + IF NOT externer dateiname THEN + druckdateinamen generieren + END IF; + ausgabe := sequential file (modify, druckdateiname); + max linelength (ausgabe, max linelength (druckmuster)); + gedruckte zeilen := lines (ausgabe) . + +druckdateinamen generieren : + INT VAR zaehler := 0; + REP + zaehler INCR 1; + druckdateiname := + headline (druckmuster) + eudas ausgabe punkt + text (zaehler); + UNTIL NOT exists (druckdateiname) END REP . + +druckanweisungen uebertragen : + muster auf zeile (1); + WHILE NOT druckmusterende REP + zeile uebertragen + END REP . + +zeile uebertragen : + musterzeile lesen; + INT VAR kommandoindex; + IF kommandozeile (kommandoindex) THEN + auf ende testen + ELSE + zeile drucken (musterzeile) + END IF . + +auf ende testen : + IF kommandoindex <> do index AND kommandoindex <> gruppe index THEN + LEAVE druckanweisungen uebertragen + END IF . + +END PROC druckdatei eroeffnen; + +PROC datei ausdrucken : + + IF aktueller editor > 0 THEN + ELIF externer dateiname THEN + externer dateiname := FALSE; + ELIF direkt ausdrucken THEN + disable stop; + ausdruck versuchen + ELSE + line; put (druckausgabe steht in); + putline (textdarstellung (druckdateiname)); + pause (40) + END IF . + +ausdruck versuchen : + TEXT CONST param := std; + last param (druckdateiname); + do ("print (std)"); + IF is error THEN + clear error; + errorstop (direkt drucken nicht moeglich) + ELSE + line; put (textdarstellung (druckdateiname)); + putline (zum drucker geschickt); + forget (druckdateiname, quiet); + pause (40) + END IF; + last param (param) . + +END PROC datei ausdrucken; + +PROC zeile drucken (TEXT CONST zeile) : + + IF gedruckte spalten >= spalten OR gedruckte spalten = 0 THEN + insert record (ausgabe); + write record (ausgabe, zeile); + gedruckte zeilen INCR 1 + ELSE + an zeile anfuegen + END IF; + down (ausgabe) . + +an zeile anfuegen : + IF eof (ausgabe) THEN + spaltenpuffer := niltext; + insert record (ausgabe); + gedruckte zeilen INCR 1 + ELSE + read record (ausgabe, spaltenpuffer) + END IF; + spaltenpuffer verlaengern; + write record (ausgabe, spaltenpuffer) . + +spaltenpuffer verlaengern : + INT CONST ziellaenge := musterzeilenbreite * gedruckte spalten; + WHILE length (spaltenpuffer) < ziellaenge REP + spaltenpuffer CAT blank + END REP; + spaltenpuffer CAT zeile . + +END PROC zeile drucken; + +PROC direkt drucken (BOOL CONST modus) : + + direkt ausdrucken := modus + +END PROC direkt drucken; + +BOOL PROC direkt drucken : + + direkt ausdrucken + +END PROC direkt drucken; + +PROC druckdatei (TEXT CONST dateiname) : + + druckdateiname := dateiname; + externer dateiname := TRUE + +END PROC druckdatei; + +TEXT PROC druckdatei : + + druckdateiname + +END PROC druckdatei; + +PROC max druckzeilen (INT CONST zeilen) : + + max zeilen := zeilen + +END PROC max druckzeilen; + +PROC gruppentest (INT CONST gruppennr, TEXT CONST merkmal) : + + IF merkmal <> gruppen (gruppennr). inhalt THEN + gruppen (gruppennr). inhalt := merkmal; + gruppen (gruppennr). wechsel := TRUE; + wechsel erfolgt := TRUE + ELSE + gruppen (gruppennr). wechsel := FALSE + END IF + +END PROC gruppentest; + +BOOL PROC gruppenwechsel (INT CONST gruppennr) : + + IF gruppennr > 0 THEN + gruppen (gruppennr). wechsel + ELSE + wechsel 0 + END IF + +END PROC gruppenwechsel; + +TEXT PROC lfd nr : + + text (satzzaehler) + +END PROC lfd nr; + +(* +PROC dump : + + FILE VAR d := sequential file (output, "EUDAS-DUMP"); + put (d, "anzahl muster :"); put (d, anzahl muster); line (d); + INT VAR i; + FOR i FROM 1 UPTO anzahl muster REP + put (d, musterindex (i)); + END REP; + line (d); + put (d, "anzahl abkuerzungen :"); put (d, anzahl abkuerzungen); + line (d); + FOR i FROM 1 UPTO anzahl abkuerzungen REP + TEXT VAR p; feld lesen (abkuerzungen, i, p); + write (d, """"); write (d, p); write (d, """ "); + put (d, abkuerzungsindex ISUB i) + END REP; + line (d); + FOR i FROM 1 UPTO 3 REP + put (d, abschnitte (i). proc name); put (d, abschnitte (i). erste zeile); + put (d, abschnitte (i). erstes muster); line (d) + END REP; + edit ("EUDAS-DUMP"); + forget ("EUDAS-DUMP") + +END PROC dump; *) + +END PACKET eudas drucken; + diff --git a/app/eudas/4.4/src/eudas.fenster b/app/eudas/4.4/src/eudas.fenster new file mode 100644 index 0000000..3281404 --- /dev/null +++ b/app/eudas/4.4/src/eudas.fenster @@ -0,0 +1,238 @@ +PACKET fenster + +(*************************************************************************) +(* *) +(* Bildschirmaufteilung in Fenster *) +(* *) +(* Version 05 *) +(* *) +(* Autor: Thomas Berlage *) +(* Stand: 17.04.87 *) +(* *) +(*************************************************************************) + + DEFINES + + FENSTER, + fenster initialisieren, + fenstergroesse setzen, + fenstergroesse, + fenster veraendert, + fensterzugriff, + bildschirm neu : + + +TYPE FENSTER = STRUCT (INT koordinaten, version); + +LET + maxfenster = 16, + BITVEKTOR = INT, + GROESSE = STRUCT (INT x anf, y anf, x laenge, y laenge); + +ROW maxfenster STRUCT (INT referenzen, aktuelle version, + BITVEKTOR ueberschneidungen, + GROESSE groesse) + VAR fenstergroessen; + +INT VAR naechste version := 1; + +BITVEKTOR VAR veraenderungen; + +INT VAR i; +FOR i FROM 2 UPTO maxfenster REP + fenstergroessen (i). referenzen := 0 +END REP; +fenstergroessen (1). referenzen := 1; +fenstergroessen (1). aktuelle version := 0; +fenstergroessen (1). ueberschneidungen := 0; +fenstergroessen (1). groesse := GROESSE : (1, 1, 79, 24); + + +(************************* fenster anfordern *****************************) + +PROC fenster initialisieren (FENSTER VAR f) : + + f. koordinaten := 1; + fenstergroessen (1). referenzen INCR 1; + f. version := naechste version; + naechste version INCR 1; + IF naechste version >= 32000 THEN naechste version := -32000 END IF + +END PROC fenster initialisieren; + +PROC fenstergroesse setzen (FENSTER VAR f, + INT CONST x anf, y anf, x laenge, y laenge) : + + INT VAR stelle; + passendes fenster suchen; + IF stelle > maxfenster THEN + freie stelle suchen; + neue koordinaten initialisieren; + ueberschneidungen bestimmen + END IF; + auf referenz setzen . + +passendes fenster suchen : + stelle := 1; + WHILE stelle <= maxfenster REP + IF groesse passt THEN + LEAVE passendes fenster suchen + END IF; + stelle INCR 1 + END REP . + +groesse passt : + g. x anf = x anf AND g. y anf = y anf AND g. x laenge = x laenge AND + g. y laenge = y laenge . + +g : + fenstergroessen (stelle). groesse . + +freie stelle suchen : + stelle := 1; + WHILE stelle <= maxfenster REP + IF fenstergroessen (stelle). referenzen = 0 THEN + LEAVE freie stelle suchen + END IF; + stelle INCR 1 + END REP; + errorstop ("zu viele Fenstergroessen"); + LEAVE fenstergroesse setzen . + +neue koordinaten initialisieren : + fenstergroessen (stelle). referenzen := 0; + fenstergroessen (stelle). aktuelle version := 0; + fenstergroessen (stelle). groesse := + GROESSE : (x anf, y anf, x laenge, y laenge); + fenstergroessen (stelle). ueberschneidungen := 0 . + +ueberschneidungen bestimmen : + INT VAR vergleich; + FOR vergleich FROM 1 UPTO maxfenster REP + IF fenstergroessen (vergleich). referenzen > 0 THEN + vergleiche auf ueberschneidung + END IF + END REP . + +vergleiche auf ueberschneidung : + IF ueberschneidung (neues fenster, vergleichsfenster) THEN + set bit (fenstergroessen (stelle). ueberschneidungen, vergleich); + set bit (fenstergroessen (vergleich). ueberschneidungen, stelle) + ELSE + reset bit (fenstergroessen (vergleich). ueberschneidungen, stelle) + END IF . + +neues fenster : + fenstergroessen (stelle). groesse . + +vergleichsfenster : + fenstergroessen (vergleich). groesse . + +auf referenz setzen : + fenstergroessen (f. koordinaten). referenzen DECR 1; + f. koordinaten := stelle; + fenstergroessen (stelle). referenzen INCR 1 . + +END PROC fenstergroesse setzen; + +BOOL PROC ueberschneidung (GROESSE CONST a, b) : + + ueberschneidung in x richtung AND ueberschneidung in y richtung . + +ueberschneidung in x richtung : + IF a. x anf <= b. x anf THEN + b. x anf < a. x anf + a. x laenge + ELSE + a. x anf < b. x anf + b. x laenge + END IF . + +ueberschneidung in y richtung : + IF a. y anf <= b. y anf THEN + b. y anf < a. y anf + a. y laenge + ELSE + a. y anf < b. y anf + b. y laenge + END IF . + +END PROC ueberschneidung; + +PROC fenstergroesse (FENSTER CONST f, + INT VAR x anf, y anf, x laenge, y laenge) : + + x anf := g. x anf; + y anf := g. y anf; + x laenge := g. x laenge; + y laenge := g. y laenge . + +g : + fenstergroessen (f. koordinaten). groesse . + +END PROC fenstergroesse; + + +(************************** fenster veraendert ***************************) + +PROC fenster veraendert (FENSTER CONST f) : + + fenstergroessen (f. koordinaten). aktuelle version := 0; + veraenderungen := veraenderungen OR meine ueberschneidungen . + +meine ueberschneidungen : + fenstergroessen (f. koordinaten). ueberschneidungen . + +END PROC fenster veraendert; + + +(************************** fensterzugriff *******************************) + +PROC fensterzugriff (FENSTER CONST f, BOOL VAR veraendert) : + + veraendert := bit (veraenderungen, f. koordinaten); + IF fenstergroessen (f. koordinaten). aktuelle version <> f. version THEN + fenstergroessen (f. koordinaten). aktuelle version := f. version; + veraendert := TRUE + END IF; + veraenderungen := veraenderungen OR meine ueberschneidungen; + reset bit (veraenderungen, f. koordinaten) . + +meine ueberschneidungen : + fenstergroessen (f. koordinaten). ueberschneidungen . + +END PROC fensterzugriff; + + +(************************ bildschirm neu *********************************) + +PROC bildschirm neu : + + veraenderungen := - 1 + +END PROC bildschirm neu; + + +(**************************** BITVEKTOR **********************************) + +(* Erforderlich, da 'reset bit' im EUMEL nicht richtig funktionierte. *) + +ROW 16 INT VAR bitwert := ROW 16 INT : + (1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,-32767-1); + +PROC set bit (BITVEKTOR VAR vektor, INT CONST stelle) : + + vektor := vektor OR bitwert (stelle) + +END PROC set bit; + +PROC reset bit (BITVEKTOR VAR vektor, INT CONST stelle) : + + vektor := vektor AND (-1 - bitwert (stelle)) + +END PROC reset bit; + +BOOL PROC bit (BITVEKTOR CONST vektor, INT CONST stelle) : + + (vektor AND bitwert (stelle)) <> 0 + +END PROC bit; + +END PACKET fenster; + diff --git a/app/eudas/4.4/src/eudas.menues b/app/eudas/4.4/src/eudas.menues new file mode 100644 index 0000000..6204848 --- /dev/null +++ b/app/eudas/4.4/src/eudas.menues @@ -0,0 +1,2616 @@ +PACKET eudas menues + +(*************************************************************************) +(* *) +(* Menue-Manager *) +(* *) +(* Version 09 *) +(* *) +(* Autor: Thomas Berlage *) +(* Stand: 31.07.87 *) +(* *) +(*************************************************************************) + + DEFINES + +## (* Nur Multi-User *) + global manager, + menue manager, +## + lock, + free, + menuedaten einlesen, + menuenamen, + menue loeschen, + + waehlbar, + ausfuehrtaste, + menue anbieten, + auswahl anbieten, + wahl, + esc hop ausfuehren, + + hilfe anbieten, + status anzeigen, + + dialogfenster, + dialogfenster loeschen, + dialog, + neuer dialog, + ja, + editget, + fehler ausgeben : + + +(***************************** Zeilenanalyse *****************************) + +ROW 8 TEXT VAR kommandotext := + ROW 8 TEXT : ("MENUE", "BILD", "FELD", "ENDE", "AUSWAHL", + "VORSPANN", "HILFE", "SEITE"); + +LET + menue kommando = 1, + bild kommando = 2, + feld kommando = 3, + ende kommando = 4, + auswahl kommando = 5, + vorspann kommando = 6, + hilfe kommando = 7, + seite kommando = 8; + +LET + bold = 2, + integer = 3, + string = 4, + end of line = 7; + +LET + fehler in zeile = #701# + "FEHLER in Zeile "; + +FILE VAR file; + +TEXT VAR + zeile, + kommando; + + +PROC zeile lesen : + + IF eof (file) THEN + zeile := "%DUMMY" + ELSE + read record (file, zeile); + IF zeile = niltext THEN zeile := blank END IF; + cout (line no (file)); + down (file) + END IF + +END PROC zeile lesen; + +BOOL PROC kommandozeile : + + IF (zeile SUB 1) = kommandozeichen THEN + kommando isolieren + ELSE + FALSE + END IF . + +kommando isolieren : + INT VAR typ; + replace (zeile, 1, blank); + scan (zeile); + replace (zeile, 1, kommandozeichen); + next symbol (kommando, typ); + IF typ <> bold THEN + fehler (kein kommando angegeben); + FALSE + ELSE + TRUE + END IF . + +END PROC kommandozeile; + +BOOL PROC kommando ist (INT CONST identifikation) : + + kommandotext (identifikation) = kommando + +END PROC kommando ist; + +INT PROC int parameter : + + TEXT VAR symbol; + INT VAR typ; + next symbol (symbol, typ); + IF typ = integer THEN + int (symbol) + ELSE + IF typ <> end of line THEN fehler (kein int parameter) END IF; + -1 + END IF + +END PROC int parameter; + +TEXT PROC text parameter : + + TEXT VAR symbol; + INT VAR typ; + next symbol (symbol, typ); + IF typ = string THEN + symbol + ELSE + IF typ <> end of line THEN fehler (kein text parameter) END IF; + niltext + END IF + +END PROC text parameter; + +PROC fehler (TEXT CONST meldung) : + + note (fehler in zeile); note (line no (file) - 1); note line; + note (meldung); note line; + line; putline (meldung) + +END PROC fehler; + + +(***************************** Fensterkoordinaten ************************) + +INT VAR + y laenge, + x laenge, + x pos, + y pos; + +PROC f cursor (INT CONST x, y) : + + cursor (x pos + x - 1, y pos + y - 1) + +END PROC f cursor; + + +(**************************** Einlesen zentral ***************************) + +LET + zeile ohne zusammenhang = #702# + "Zeile ist ohne Zusammenhang", + k menuedaten im speicher = #703# + "K Menuedaten im Speicher"; + +PROC menuedaten einlesen (TEXT CONST dateiname) : + + ggf initialisieren; + file := sequential file (input, dateiname); + modify (file); + to line (file, 1); + WHILE NOT eof (file) REP + zeile lesen; + IF kommandozeile THEN + eventuell verteilen + ELIF NOT anything noted THEN + fehler (zeile ohne zusammenhang) + END IF + END REP; + seiten anzeigen; + IF anything noted THEN + note edit (file) + END IF . + +eventuell verteilen : + IF kommando ist (menue kommando) THEN + menue aus datei lesen + ELIF kommando ist (auswahl kommando) THEN + auswahl aus datei lesen + ELIF kommando ist (hilfe kommando) THEN + hilfe aus datei lesen + ELIF NOT anything noted THEN + fehler (zeile ohne zusammenhang) + END IF . + +seiten anzeigen : + IF online THEN + line; put (anzahl ds seiten DIV 2); + putline (k menuedaten im speicher) + END IF . + +anzahl ds seiten : + ds pages (menueds (1)) + ds pages (menueds (2)) + ds pages (menueds (3)) . + +END PROC menuedaten einlesen; + + +(**************************** TYPE MENUE *********************************) + +TYPE MENUE = STRUCT (SATZ + bild, + hilfen, + kommandos, + TEXT + feldtasten, + feldzeilen); + +BOUND ROW 200 MENUE VAR menues; + + +(************************** Menue Einlesen *******************************) + +TEXT VAR + m feldzeilen, + m feldtasten; + +SATZ VAR + m hilfen, + m kommandos; + +LET + niltext = "", + blank = " ", + feldmarkierung = ""223"", + markierungsspalte = 2, + kommandozeichen = "%", + piep = ""7"", + esc = ""27"", + cleol = ""5""; + +LET + bildkommando erwartet = #704# + "% BILD erwartet", + keine feldnr angegeben = #705# + "Feldnummer beim %FELD-Kommando fehlt", + ende fehlt = #706# + "% ENDE erwartet", + kein name angegeben = #707# + "Name fehlt", + kein kommando angegeben = #708# + "Kommandozeile enthaelt kein Kommando", + kein int parameter = #709# + "Parameter soll eine Zahl sein", + kein text parameter = #710# + "Parameter soll ein TEXT sein", + keine wiederholungszeile = #711# + "Wiederholungszeile fehlt"; + + +PROC menue aus datei lesen : + + TEXT VAR name := text parameter; + IF name = niltext THEN + fehler (kein name angegeben) + ELSE + INT VAR index; + neues menue einfuegen; + menue aus datei lesen (menues (index)) + END IF . + +neues menue einfuegen : + index := link (thesaurus (2), name); + IF index = 0 THEN + insert (thesaurus (2), name, index) + END IF . + +END PROC menue aus datei lesen; + +PROC menue aus datei lesen (MENUE VAR m) : + + menue initialisieren; + bild einlesen; + felddefinitionen bearbeiten; + auf ende testen; + ergebnis abspeichern . + +menue initialisieren : + satz initialisieren (m. bild); + satz initialisieren (m hilfen); + satz initialisieren (m kommandos); + m feldtasten := niltext; + m feldzeilen := niltext . + +bild einlesen : + teste auf bild kommando; + INT VAR zeilennr := 1; + REP + zeile lesen; + IF kommandozeile THEN + LEAVE bild einlesen + ELSE + bildzeile bearbeiten; + zeilennr INCR 1 + END IF + END REP . + +teste auf bild kommando : + zeile lesen; + IF NOT (kommandozeile CAND kommando ist (bild kommando)) THEN + fehler (bild kommando erwartet) + END IF . + +bildzeile bearbeiten : + IF (zeile SUB markierungsspalte) = feldmarkierung THEN + m feldzeilen CAT code (zeilennr); + replace (zeile, markierungsspalte, blank) + END IF; + feld aendern (m. bild, zeilennr, zeile) . + +felddefinitionen bearbeiten : + WHILE kommando ist (feld kommando) REP + eine felddefinition bearbeiten + END REP . + +eine felddefinition bearbeiten : + INT VAR feldnr := int parameter; + IF feldnr = -1 THEN + fehler (keine feldnr angegeben); + feldnr := 100 + END IF; + hilfe text einlesen; + feldtasten einlesen; + kommandos einlesen . + +hilfe text einlesen : + feld aendern (m hilfen, feldnr, text parameter) . + +feldtasten einlesen : + TEXT CONST tasten := text parameter; + INT VAR p; + FOR p FROM 1 UPTO length (tasten) REP + m feldtasten CAT code (feldnr); + m feldtasten CAT (tasten SUB p) + END REP . + +kommandos einlesen : + TEXT VAR k := niltext; + zeile lesen; + WHILE NOT kommandozeile REP + k CAT zeile; + zeile lesen + END REP; + feld aendern (m kommandos, feldnr, k) . + +auf ende testen : + IF NOT kommando ist (ende kommando) THEN + fehler (ende fehlt) + END IF . + +ergebnis abspeichern : + m. hilfen := m hilfen; + m. kommandos := m kommandos; + m. feldtasten := m feldtasten; + m. feldzeilen := m feldzeilen . + +END PROC menue aus datei lesen; + + +(************************** Menue in Datei *******************************) +(* +PROC menue in datei schreiben (MENUE CONST m, FILE VAR f, TEXT CONST name) : + + output (f); + put (f, "% MENUE"); + putline (f, textdarstellung (name)); + bild rekonstruieren; + felddefinitionen rekonstruieren; + putline (f, "% ENDE") . + +bild rekonstruieren : + INT VAR zeilennr; + putline (f, "% BILD"); + FOR zeilennr FROM 1 UPTO felderzahl (m. bild) REP + feld lesen (m. bild, zeilennr, zeile); + feldmarkierungen wiederherstellen; + putline (f, zeile) + END REP . + +feldmarkierungen wiederherstellen : + INT VAR zeilenpos := pos (m. feldzeilen, code (zeilennr)); + IF zeilenpos > 0 THEN + REP + replace (zeile, markierungsspalte, feldmarkierung); + zeilenpos INCR 1 + UNTIL (m. feldzeilen SUB zeilenpos) <> code (zeilennr) END REP + END IF . + +felddefinitionen rekonstruieren : + INT VAR feldnr; + FOR feldnr FROM 1 UPTO length (m. feldzeilen) REP + put (f, "% FELD"); + put (f, feldnr); + feld lesen (m. hilfen, feldnr, zeile); + put (f, textdarstellung (zeile)); + feldzeichen sammeln; + kommandos ausgeben + END REP . + +feldzeichen sammeln : + INT VAR stelle := 1; + zeile := niltext; + WHILE stelle < length (m. feldtasten) REP + IF code (m. feldtasten SUB stelle) = feldnr THEN + zeile CAT (m. feldtasten SUB stelle + 1) + END IF; + stelle INCR 1 + END REP; + putline (f, textdarstellung (zeile)) . + +kommandos ausgeben : + INT VAR anfang := 1; + feld lesen (m. kommandos, feldnr, zeile); + REP + stelle := pos (zeile, ";", anfang); + IF stelle = 0 THEN + zeilenrest ausgeben; + LEAVE kommandos ausgeben + ELSE + putline (f, subtext (zeile, anfang, stelle)); + anfang := stelle + 1 + END IF + END REP . + +zeilenrest ausgeben : + IF anfang <= length (zeile) THEN + putline (f, subtext (zeile, anfang)) + END IF . + +END PROC menue in datei schreiben; +*) + +(*************************** Menue anbieten ******************************) + +LET + ausfuehren status = #712# + "Kommando wird ausgeführt ..", + gib kommando = #713# + ""15"Gib Kommando: ", + falsche ausfuehrtaste = #714# + "falsche Ausfuehrtaste", + t existiert nicht = #715# + " existiert nicht."; + +LET + blank 24 = " ", + begin mark = ""15"", + end mark = ""14"", + ausfuehren marke = "*"8""; + +INT VAR + rekursionstiefe := 0, + markenpos, + gezeichnete zeilen; + +BOOL VAR + funktionssperre veraendert, + menue init durchgefuehrt; + +TEXT VAR + balken, + sperrzeichen, + menuefunktionstasten := ""32""1""2""3""8""10""13""27"", + edit kommando, + altes kommando := niltext; + +ROW 6 TEXT VAR + funktionssperre; + +FENSTER VAR balkenfenster; +fenster initialisieren (balkenfenster); +fenstergroesse setzen (balkenfenster, 1, 1, 79, 1); + + +PROC waehlbar (INT CONST menue, funktion, BOOL CONST moeglich) : + + IF moeglich THEN + ggf sperre aufheben + ELSE + sperre setzen + END IF; + funktionssperre veraendert := TRUE . + +ggf sperre aufheben : + IF length (funktionssperre (menue)) >= funktion THEN + replace (funktionssperre (menue), funktion, " ") + END IF . + +sperre setzen : + WHILE length (funktionssperre (menue)) < funktion REP + funktionssperre (menue) CAT " " + END REP; + replace (funktionssperre (menue), funktion, "-") . + +END PROC waehlbar; + +PROC ausfuehrtaste (TEXT CONST taste) : + + IF length (taste) <> 1 COR taste schon belegt THEN + errorstop (falsche ausfuehrtaste) + ELSE + replace (menuefunktionstasten, 1, taste) + END IF . + +taste schon belegt : + taste <> ""13"" AND pos (menuefunktionstasten, taste, 2) > 0 . + +END PROC ausfuehrtaste; + +PROC menue anbieten (ROW 6 TEXT CONST menuenamen, + FENSTER VAR f, BOOL CONST esc erlaubt, + PROC (INT CONST, INT CONST) interpreter) : + + ROW 6 INT VAR + m anfang, + m ende, + m wahl; + + INT VAR + menuenr intern, + leistenindex := 0, + neuer leistenindex := 1, + leave code := 0, + besetzte menues; + + TEXT VAR + menuebalken; + + ROW 6 TEXT VAR + sperre; + + ggf initialisieren; + menuebalken aufbauen; + funktionssperre aufbauen; + disable stop; + REP + menuebalken und sperre aktualisieren; + menue aufrufen; + funktion ausfuehren + END REP . + +menuebalken aufbauen : + rekursionstiefe INCR 1; + INT CONST meine rekursionstiefe := rekursionstiefe; + menuebalken := ""6""0""0""; + identifikation extrahieren; + weitere menues anfuegen; + menuebalken CAT cl eol . + +identifikation extrahieren : + INT VAR ppos := pos (menuenamen (1), "."); + IF ppos > 0 THEN + menuebalken CAT subtext (menuenamen (1), 1, ppos - 1) + END IF; + menuebalken CAT ": " . + +weitere menues anfuegen : + besetzte menues := 0; + WHILE besetzte menues < 6 CAND noch ein menue vorhanden REP + besetzte menues INCR 1; + ein weiteres menue; + m wahl (besetzte menues) := 1 + END REP . + +noch ein menue vorhanden : + menuenamen (besetzte menues + 1) <> niltext . + +ein weiteres menue : + m anfang (besetzte menues) := length (menuebalken); + ppos := pos (menuenamen (besetzte menues), "."); + IF ppos = 0 THEN + menuebalken CAT menuenamen (besetzte menues) + ELSE + menuebalken CAT subtext (menuenamen (besetzte menues), ppos + 1) + END IF; + menuebalken CAT " "; + m ende (besetzte menues) := length (menuebalken) - 1 . + +funktionssperre aufbauen : + INT VAR i; + FOR i FROM 1 UPTO 6 REP + funktionssperre (i) := niltext + END REP; + funktionssperre veraendert := TRUE; + interpreter (0, 0) . + +menuebalken und sperre aktualisieren : + IF neuer leistenindex > 0 THEN + altes menue demarkieren; + neues menue markieren; + leistenindex := neuer leistenindex; + neuer leistenindex := 0; + neues menue auswaehlen + ELIF rekursionstiefe <> meine rekursionstiefe THEN + balken := menuebalken; + funktionssperre := sperre; + rekursionstiefe := meine rekursionstiefe + ELIF funktionssperre veraendert THEN + sperre := funktionssperre + END IF . + +altes menue demarkieren : + IF leistenindex > 0 THEN + replace (menuebalken, m anfang (leistenindex), " "); + replace (menuebalken, m ende (leistenindex), " "); + IF menue init durchgefuehrt THEN + interpreter (leistenindex, -1) + END IF + END IF . + +neues menue markieren : + replace (menuebalken, m anfang (neuer leistenindex), begin mark); + replace (menuebalken, m ende (neuer leistenindex), end mark); + fenster veraendert (balkenfenster); + balken := menuebalken; + menuebalken anzeigen . + +neues menue auswaehlen : + menuenr intern := link (thesaurus (2), menuenamen (leistenindex)); + IF menuenr intern = 0 THEN + existiert nicht (menuenamen (leistenindex)); + LEAVE menue anbieten + END IF; + menue init durchgefuehrt := FALSE; + funktionssperre veraendert := TRUE; + fenster veraendert (f) . + +menue aufrufen : + leave code := leistenindex; + anbieten (menues (menuenr intern), f, leave code, m wahl (leistenindex), + PROC (INT CONST, INT CONST) interpreter) . + +funktion ausfuehren : + SELECT leave code OF + CASE 0 : menue verlassen + CASE 1 : kommandodialog + CASE 2 : menuewechsel nach rechts + CASE 3 : menuewechsel nach links + CASE 4 : wahl behandeln + OTHERWISE direkte menuewahl + END SELECT . + +menuewechsel nach rechts : + IF leistenindex < besetzte menues THEN + neuer leistenindex := leistenindex + 1 + ELSE + neuer leistenindex := 1 + END IF . + +menuewechsel nach links : + IF leistenindex > 1 THEN + neuer leistenindex := leistenindex - 1 + ELSE + neuer leistenindex := besetzte menues + END IF . + +direkte menuewahl : + leave code := leave code - 10; + IF leave code <= besetzte menues THEN + neuer leistenindex := leave code + END IF . + +kommandodialog : + IF esc erlaubt THEN + BOOL VAR bild veraendert := FALSE; + REP + editget kommando; + kommando ausfuehren + UNTIL erfolgreich END REP; + IF bild veraendert THEN + bildschirm neu; + dialogfenster loeschen; + interpreter (leistenindex, -2) + END IF + END IF . + +kommando ausfuehren : + IF echtes kommando THEN + bild veraendert := TRUE; + status anzeigen (ausfuehren status); + cursor (1, 2); out (cl eop); + do (edit kommando) + END IF . + +echtes kommando : + pos (edit kommando, ""33"", ""254"", 1) > 0 . + +erfolgreich : + NOT is error . + +menue verlassen : + IF menue init durchgefuehrt THEN + interpreter (leistenindex, -1) + END IF; + fenster veraendert (f); + LEAVE menue anbieten . + +wahl behandeln : + IF m wahl (leistenindex) > 0 THEN + interpreter (menuenr intern, m wahl (leistenindex)) + ELSE + m wahl (leistenindex) := - m wahl (leistenindex) + END IF . + +END PROC menue anbieten; + +PROC menuebalken anzeigen : + + BOOL VAR veraendert; + fensterzugriff (balkenfenster, veraendert); + IF veraendert THEN out (balken) END IF + +END PROC menuebalken anzeigen; + +PROC anbieten (MENUE CONST m, FENSTER VAR f, INT VAR menuenr, wahl, + PROC (INT CONST, INT CONST) interpreter) : + + INT VAR + tastenzustand := 0; + + fehler behandeln; + neuen fensterzugriff anmelden (f); + IF gezeichnete zeilen = 0 THEN + markenpos := 0 + END IF; + neuer dialog; + geaenderte funktionssperre beruecksichtigen; + REP + menuebalken anzeigen; + auf eingabe warten; + menuefunktion + END REP . + +fehler behandeln : + IF wahl > length (m. feldzeilen) THEN + wahl := markenpos; + ELIF is error THEN + fehler ausgeben; + interpreter (menuenr, -2); + END IF . + +geaenderte funktionssperre beruecksichtigen : + IF funktionssperre veraendert THEN + sperrzeichen setzen; + bereits angezeigte funktionen korrigieren; + funktionssperre veraendert := FALSE + END IF . + +sperrzeichen setzen : + sperrzeichen := blank 24; + INT VAR i; + FOR i FROM 1 UPTO length (funktionssperre (menuenr)) REP + replace (sperrzeichen, code (m. feldzeilen SUB i), + funktionssperre (menuenr) SUB i) + END REP . + +bereits angezeigte funktionen korrigieren : + INT VAR f index; + FOR f index FROM 1 UPTO length (m. feldzeilen) REP + INT CONST funktionszeile := code (m. feldzeilen SUB f index); + IF funktionszeile > gezeichnete zeilen THEN + LEAVE bereits angezeigte funktionen korrigieren + END IF; + erstes zeichen ausgeben (m. bild, funktionszeile) + END REP . + +auf eingabe warten : + REP + ausgabe und zeichen annehmen; + IF is error THEN + halt vom terminal behandeln + ELSE + LEAVE auf eingabe warten + END IF + END REP . + +ausgabe und zeichen annehmen : + TEXT VAR eingabe; + BOOL VAR menue jetzt fertig ausgegeben := FALSE; + WHILE gezeichnete zeilen < y laenge REP + eingabe := getcharety; + eventuell eine zeile ausgeben + END REP; + bildschirm update; + cursor positionieren (m, wahl); + getchar mit enable stop (eingabe) . + +eventuell eine zeile ausgeben : + IF eingabe = niltext THEN + ggf init durchfuehren; + gezeichnete zeilen INCR 1; + menuezeile markiert oder nicht markiert ausgeben + ELSE + LEAVE ausgabe und zeichen annehmen + END IF . + +ggf init durchfuehren : + IF NOT menue init durchgefuehrt AND gezeichnete zeilen = 0 THEN + interpreter (menuenr, 0); + menue init durchgefuehrt := TRUE + END IF . + +menuezeile markiert oder nicht markiert ausgeben : + IF gezeichnete zeilen = code (m. feldzeilen SUB wahl) THEN + menuezeile ausgeben (m. bild, gezeichnete zeilen, TRUE); + markenpos := wahl + ELSE + menuezeile ausgeben (m. bild, gezeichnete zeilen, FALSE) + END IF; + IF gezeichnete zeilen = y laenge THEN + menue jetzt fertig ausgegeben := TRUE + END IF . + +bildschirm update : + IF menue jetzt fertig ausgegeben AND NOT is error THEN + interpreter (menuenr, -2); + IF is error THEN clear error END IF + END IF . + +halt vom terminal behandeln : + fehler ausgeben; + menuebalken anzeigen; + gezeichnete zeilen := 0 . + +menuefunktion : + INT VAR posi; + SELECT tastenzustand OF + CASE 0 : normale funktion + CASE 1 : hop funktion + CASE 2 : esc funktion + END SELECT . + +normale funktion : + SELECT pos (menuefunktionstasten, eingabe) OF + CASE 1 : leerzeichen ausfuehren + CASE 2 : tastenzustand := 1 + CASE 3 : rechts ausfuehren + CASE 4 : oben ausfuehren + CASE 5 : links ausfuehren + CASE 6 : unten ausfuehren + CASE 7 : return ausfuehren + CASE 8 : tastenzustand := 2 + OTHERWISE sondertaste + END SELECT . + +hop funktion : + SELECT pos (""1""3""10"", eingabe) OF + CASE 1 : hop hop ausfuehren + CASE 2 : hop oben ausfuehren + CASE 3 : hop unten ausfuehren + OTHERWISE out (piep) + END SELECT; + tastenzustand := 0 . + +esc funktion : + SELECT pos (""1""27"?qh", eingabe) OF + CASE 1 : esc hop ausfuehren + CASE 2 : esc esc ausfuehren + CASE 3 : esc fragezeichen ausfuehren + CASE 4, 5 : esc q ausfuehren + OTHERWISE belegte taste + END SELECT; + tastenzustand := 0 . + +rechts ausfuehren : + leave code := 2; + LEAVE anbieten . + +oben ausfuehren : + IF wahl > 1 THEN + wahl DECR 1 + ELSE + wahl := length (m. feldzeilen) + END IF . + +links ausfuehren : + leave code := 3; + LEAVE anbieten . + +unten ausfuehren : + IF wahl < length (m. feldzeilen) THEN + wahl INCR 1 + ELSE + wahl := 1 + END IF . + +return ausfuehren : + unten ausfuehren . + +sondertaste : + IF menuewahl THEN + menuewahl bearbeiten + ELIF wahl fuer bestimmtes feld THEN + feld waehlen + ELIF eingabe <= ""32"" THEN + push (esc + eingabe) + END IF . + +menuewahl : + pos ("123456", eingabe) > 0 . + +menuewahl bearbeiten : + leave code := code (eingabe) - 38; + LEAVE anbieten . + +wahl fuer bestimmtes feld : + posi := 0; + REP + posi := pos (m. feldtasten, eingabe, posi + 1) + UNTIL (posi MOD 2) = 0 END REP; + posi > 0 AND feld mit bildschirmposition . + +feld mit bildschirmposition : + code (m. feldtasten SUB posi - 1) <= length (m. feldzeilen) . + +feld waehlen : + wahl := code (m. feldtasten SUB posi - 1); + cursor positionieren (m, wahl); + IF (funktionssperre (menuenr) SUB wahl) <> "-" THEN + wahl getroffen (m, wahl, gezeichnete zeilen); + leave code := 4; + LEAVE anbieten + END IF . + +hop hop ausfuehren : + wahl := 1 . + +hop oben ausfuehren : + wahl := 1 . + +hop unten ausfuehren : + wahl := length (m. feldzeilen) . + +belegte taste : + IF esc sonderfunktion THEN + wahl := code (m. feldtasten SUB posi - 1); + leave code := 4; + LEAVE anbieten + ELSE + push (lernsequenz auf taste (eingabe)) + END IF . + +esc sonderfunktion : + posi := 0; + REP + posi := pos (m. feldtasten, eingabe, posi + 1) + UNTIL (posi MOD 2) = 0 CAND + (posi = 0 COR feld ohne bildschirmposition) END REP; + posi > 0 . + +feld ohne bildschirmposition : + code (m. feldtasten SUB posi - 1) > length (m. feldzeilen) . + +esc esc ausfuehren : + leave code := 1; + LEAVE anbieten . + +esc fragezeichen ausfuehren : + TEXT VAR hilfe name; + feld lesen (m. hilfen, wahl, hilfe name); + hilfe anbieten (hilfe name, d fenster); + IF is error THEN fehler ausgeben END IF; + interpreter (menuenr, -2); + neuen fensterzugriff anmelden (f) . + +esc q ausfuehren : + leave code := 0; + LEAVE anbieten . + +leerzeichen ausfuehren : + IF (funktionssperre (menuenr) SUB wahl) <> "-" THEN + wahl getroffen (m, wahl, gezeichnete zeilen); + leave code := 4; + LEAVE anbieten + END IF . + +leave code : + menuenr . + +END PROC anbieten; + +PROC neuen fensterzugriff anmelden (FENSTER CONST f) : + + BOOL VAR veraendert; + fensterzugriff (f, veraendert); + fenstergroesse (f, x pos, y pos, x laenge, y laenge); + IF veraendert THEN + gezeichnete zeilen := 0; + f cursor (1, 1) + END IF + +END PROC neuen fensterzugriff anmelden; + +PROC cursor positionieren (MENUE CONST m, INT CONST wahl) : + + INT CONST wahlzeile := code (m. feldzeilen SUB wahl); + IF markenpos > 0 THEN + IF markenpos = wahl THEN + erstes zeichen ausgeben (m. bild, wahlzeile) + ELSE + INT CONST markenzeile := code (m. feldzeilen SUB markenpos); + menuezeile ausgeben (m. bild, markenzeile, FALSE); + menuezeile ausgeben (m. bild, wahlzeile, TRUE); + markenpos := wahl + END IF + END IF; + f cursor (1, wahlzeile) + +END PROC cursor positionieren; + +PROC getchar mit enable stop (TEXT VAR z) : + + enable stop; + getchar (z) + +END PROC getchar mit enable stop; + +PROC wahl getroffen (MENUE CONST m, INT VAR wahl, + INT CONST gezeichnete zeilen) : + + INT CONST + y pos := code (m. feldzeilen SUB wahl); + IF zeile bereits gezeichnet THEN + ausfuehrung markieren + END IF; + TEXT VAR k; + feld lesen (m. kommandos, wahl, k); + IF k <> niltext AND k <> blank THEN + do (k); + bildschirm neu; + wahl := - wahl + END IF . + +zeile bereits gezeichnet : + gezeichnete zeilen >= y pos . + +ausfuehrung markieren : + f cursor (1, y pos); + out (ausfuehren marke) . + +END PROC wahl getroffen; + +PROC esc hop ausfuehren : + + TEXT VAR + puffer := niltext, + ausgang; + lernsequenz auf taste legen (""0"", niltext); + push (""27""1""0""0""); + editget (puffer, 32000, 0, ""0"", "", ausgang); + puffer := lernsequenz auf taste (""0""); + IF puffer <> niltext THEN + gelerntes auf richtige taste legen + ELSE + letzten nullcode auslesen + END IF . + +gelerntes auf richtige taste legen : + REP + getchar (ausgang) + UNTIL pos (""1""2""8""11""12"", ausgang) = 0 END REP; + lernsequenz auf taste legen (ausgang, puffer) . + +letzten nullcode auslesen : + getchar (ausgang) . + +END PROC esc hop ausfuehren; + + +INT VAR + anfang, + ende, + mark ende; + +PROC erstes zeichen ausgeben (SATZ CONST bild, INT CONST bildzeile) : + + f cursor (1, bildzeile); + IF (sperrzeichen SUB bildzeile) <> blank THEN + out (sperrzeichen SUB bildzeile) + ELSE + feld bearbeiten (bild, bildzeile, + PROC (TEXT CONST, INT CONST, INT CONST) zeichen 1) + END IF + +END PROC erstes zeichen ausgeben; + +PROC zeichen 1 (TEXT CONST satz, INT CONST anfang, ende) : + + out (satz SUB anfang + ende - ende) + +END PROC zeichen 1; + +PROC menuezeile ausgeben (SATZ CONST bild, + INT CONST zeilennr, BOOL CONST markiert) : + + enable stop; + IF markiert THEN + erstes zeichen ausgeben (bild, zeilennr); + out (begin mark); + anfang := 3; mark ende := 1; + ELSE + f cursor (1, zeilennr); + IF (sperrzeichen SUB zeilennr) = "-" THEN + out ("-"); anfang := 2 + ELSE + anfang := 1 + END IF; + mark ende := 0 + END IF; + bildzeile ausgeben (bild, zeilennr) + +END PROC menuezeile ausgeben; + +PROC menuezeile ausgeben (SATZ CONST bild, INT CONST zeilennr) : + + anfang := 1; mark ende := 0; + bildzeile ausgeben (bild, zeilennr) + +END PROC menuezeile ausgeben; + +PROC bildzeile ausgeben (SATZ CONST bild, INT CONST zeilennr) : + + IF zeilennr <= felderzahl (bild) THEN + zeileninhalt ausgeben + ELSE + ende := 0 + END IF; + zeilenrest loeschen . + +zeileninhalt ausgeben : + feld bearbeiten (bild, zeilennr, + PROC (TEXT CONST, INT CONST, INT CONST) abschnitt ausgeben) . + +zeilenrest loeschen : + IF x pos + x laenge >= 80 AND mark ende = 0 THEN + out (cleol) + ELSE + x laenge - ende - mark ende - 1 TIMESOUT blank; + ggf endemarkierung; + out (":") + END IF . + +ggf endemarkierung : + IF mark ende > 0 THEN + out (end mark) + END IF . + +END PROC bildzeile ausgeben; + +PROC abschnitt ausgeben (TEXT CONST t, INT CONST von, bis) : + + INT CONST offset := von - 1; + anfang INCR offset; + ende := min (bis, x laenge + offset - mark ende - 1); + outsubtext (t, anfang, ende); + ende DECR offset + +END PROC abschnitt ausgeben; + +PROC editget kommando : + + LET esc k = ""27"k"; + TEXT VAR + exit char; + fenster veraendert (balkenfenster); + bei fehler altes kommando wiederholen; + markierte zeile ausgeben; + REP + kommando editieren + UNTIL exit char <> esc k END REP; + IF pos (edit kommando , ""33"", ""254"", 1) > 0 THEN + altes kommando := edit kommando + END IF . + +bei fehler altes kommando wiederholen : + IF is error THEN + fehler ausgeben; + edit kommando := altes kommando + ELSE + edit kommando := niltext + END IF . + +markierte zeile ausgeben : + cursor (1, 1); + out (gib kommando); + x laenge - 15 TIMESOUT blank; + out (end mark) . + +kommando editieren : + cursor (16, 1); + editget (edit kommando, 32000, 62, "", "kh", exit char); + IF is error THEN + clear error + ELIF exit char = esc k THEN + edit kommando := altes kommando + ELIF exit char = esc h THEN + edit kommando := niltext + END IF . + +END PROC edit get kommando; + +PROC existiert nicht (TEXT CONST dateiname) : + + errorstop (textdarstellung (dateiname) + t existiert nicht) + +END PROC existiert nicht; + + +(*************************** Auswahl Einlesen ****************************) + +TYPE AUSWAHL = STRUCT ( + SATZ + kopf, + vorspann, + nachspann, + TEXT + wiederholung, + feldspalten, + feldlaengen); + +BOUND ROW 200 AUSWAHL VAR auswahlen; + + +PROC auswahl aus datei lesen : + + TEXT VAR name := text parameter; + IF name = niltext THEN + fehler (kein name angegeben) + ELSE + INT VAR index := link (thesaurus (3), name); + IF index = 0 THEN + insert (thesaurus (3), name, index) + END IF; + auswahl aus datei lesen (auswahlen (index)) + END IF + +END PROC auswahl aus datei lesen; + +PROC auswahl aus datei lesen (AUSWAHL VAR a) : + + menue initialisieren; + IF kopf vorhanden THEN + kopf einlesen + END IF; + bild einlesen; + teste auf ende . + +menue initialisieren : + satz initialisieren (a. kopf); + satz initialisieren (a. vorspann); + satz initialisieren (a. nachspann); + a. wiederholung := niltext; + a. feldspalten := niltext; + a. feldlaengen := niltext . + +kopf vorhanden : + zeile lesen; + kommandozeile CAND kommando ist (vorspann kommando) . + +kopf einlesen : + INT VAR zeilennr := 1; + REP + zeile lesen; + IF kommandozeile THEN + LEAVE kopf einlesen + ELSE + kopfzeile bearbeiten; + zeilennr INCR 1 + END IF + END REP . + +kopfzeile bearbeiten : + feld aendern (a. kopf, zeilennr, zeile) . + +bild einlesen : + teste auf bildkommando; + zeilennr := 1; + BOOL VAR noch vorspann := TRUE; + REP + zeile lesen; + IF kommandozeile THEN + teste ob wiederholung gewesen; + LEAVE bild einlesen + ELSE + bildzeile bearbeiten; + zeilennr INCR 1 + END IF + END REP . + +teste auf bildkommando : + IF NOT (kommandozeile CAND kommando ist (bild kommando)) THEN + fehler (bild kommando erwartet) + END IF . + +teste ob wiederholung gewesen : + IF noch vorspann THEN + fehler (keine wiederholungszeile) + END IF . + +bildzeile bearbeiten : + IF noch vorspann THEN + teste auf wiederholung + ELSE + nachspannzeile + END IF . + +teste auf wiederholung : + IF pos (zeile, feldmarkierung) > 0 THEN + behandle wiederholungszeile; + zeilennr := 0; + noch vorspann := FALSE + ELSE + feld aendern (a. vorspann, zeilennr, zeile) + END IF . + +behandle wiederholungszeile : + spalten suchen; + a. wiederholung := zeile; + feldlaengen berechnen . + +spalten suchen : + INT VAR feldpos := 0; + REP + feldpos := pos (zeile, feldmarkierung, feldpos + 1); + IF feldpos > 0 THEN + a. feldspalten CAT code (feldpos) + END IF + UNTIL feldpos = 0 END REP . + +feldlaengen berechnen : + FOR feldpos FROM 1 UPTO length (a. feldspalten) - 1 REP + a. feldlaengen CAT code (spaltenabstand - 4) + END REP; + a. feldlaengen CAT ""0"" . + +spaltenabstand : + code (a. feldspalten SUB feldpos + 1) - code (a. feldspalten SUB feldpos) . + +nachspannzeile : + feld aendern (a. nachspann, zeilennr, zeile) . + +teste auf ende : + IF NOT kommando ist (ende kommando) THEN + fehler (ende fehlt) + END IF . + +END PROC auswahl aus datei lesen; + + +(*************************** Auswahl anbieten ****************************) + +LET + hop links unten = ""1""8""10"", + plus esc q = "+"27"q"; + +LET + fenster zu klein = #716# + "Fenster zu klein", + auswahlstatus = #717# +"AUSWAHL: Ankreuzen: 'x' Durchstreichen: 'o' Beenden: ESC q Hilfe: ESC ?"; + +INT VAR + wahlen, + spalten, + kopfzeilen, + bis vorspann, + wiederholungszeilen, + bis wiederholung, + gesamtzeilen, + gerollt; + +LET INTVEC = TEXT; + +INTVEC VAR gewaehlt; + +TEXT VAR spaltenpositionen; + + +PROC auswahl anbieten (TEXT CONST name, FENSTER CONST f, TEXT CONST hilfe, + PROC (TEXT VAR, INT CONST) inhalt) : + + ggf initialisieren; + INT CONST index := link (thesaurus (3), name); + IF index = 0 THEN + existiert nicht (name) + ELSE + anbieten (auswahlen (index), f, hilfe, PROC (TEXT VAR, INT CONST) inhalt) + END IF + +END PROC auswahl anbieten; + +PROC anbieten (AUSWAHL CONST a, FENSTER CONST f, TEXT CONST hilfe, + PROC (TEXT VAR, INT CONST) inhalt) : + + INT VAR + gezeichnete zeilen := 0, + tastenzustand := 0; + enable stop; + fensterzugriff durchfuehren; + status anzeigen (auswahlstatus); + anzahl der wahlen feststellen; + bildparameter berechnen; + auswahl initialisieren; + REP + auf eingabe warten; + auswahlfunktion durchfuehren + END REP . + +fensterzugriff durchfuehren : + BOOL VAR dummy; + fensterzugriff (f, dummy); + fenstergroesse (f, x pos, y pos, x laenge, y laenge) . + +anzahl der wahlen feststellen : + INT VAR + schritt := 1024; + wahlen := schritt; + REP + schritt := schritt DIV 2; + inhalt (zeile, wahlen); + IF zeile = niltext THEN + wahlen DECR schritt + ELSE + wahlen INCR schritt + END IF + UNTIL schritt = 1 END REP; + inhalt (zeile, wahlen); + IF zeile = niltext THEN wahlen DECR 1 END IF . + +auswahl initialisieren : + INT VAR + akt zeile := bis vorspann + 1, + akt spalte := 1, + akt wahl := 1; + gewaehlt := niltext; + spaltenpositionen := a. feldspalten . + +bildparameter berechnen : + kopfzeilen := felderzahl (a. kopf); + bis vorspann := kopfzeilen + felderzahl (a. vorspann); + spalten := length (a. feldspalten); + wiederholungszeilen := (wahlen + spalten - 1) DIV spalten; + bis wiederholung := bis vorspann + wiederholungszeilen; + gesamtzeilen := bis wiederholung + felderzahl (a. nachspann); + gerollt := 0; + IF bis vorspann >= y laenge THEN + errorstop (fenster zu klein) + END IF . + +auf eingabe warten : + REP + ausgabe und zeichen annehmen; + IF is error THEN + clear error; + gezeichnete zeilen := 0 + ELSE + LEAVE auf eingabe warten + END IF + END REP . + +ausgabe und zeichen annehmen : + TEXT VAR eingabe; + WHILE gezeichnete zeilen < y laenge REP + eingabe := getcharety; + eventuell eine zeile ausgeben + END REP; + cursor positionieren; + getchar mit enable stop (eingabe) . + +eventuell eine zeile ausgeben : + IF eingabe = niltext THEN + gezeichnete zeilen INCR 1; + entsprechende zeile ausgeben + ELSE + LEAVE ausgabe und zeichen annehmen + END IF . + +entsprechende zeile ausgeben : + INT CONST tatsaechliche zeile := gezeichnete zeilen + gerollt; + f cursor (1, gezeichnete zeilen); + IF gezeichnete zeilen <= kopfzeilen THEN + menuezeile ausgeben (a. kopf, gezeichnete zeilen) + ELIF tatsaechliche zeile <= bis vorspann THEN + menuezeile ausgeben (a. vorspann, tatsaechliche zeile - kopfzeilen) + ELIF tatsaechliche zeile <= bis wiederholung THEN + wiederholungszeile ausgeben + ELSE + menuezeile ausgeben (a. nachspann, + tatsaechliche zeile - bis wiederholung) + END IF . + +wiederholungszeile ausgeben : + auswahlzeile ausgeben (a, erste wahl, + PROC (TEXT VAR, INT CONST) inhalt) . + +erste wahl : + (tatsaechliche zeile - bis vorspann - 1) * spalten + 1 . + +cursor positionieren : + f cursor (code (spaltenpositionen SUB akt spalte), akt zeile) . + +auswahlfunktion durchfuehren : + SELECT tastenzustand OF + CASE 0 : normale funktion + CASE 1 : hop funktion + CASE 2 : esc funktion + END SELECT . + +normale funktion : + SELECT pos (""1""2""3""8""9""10""13""27" +x-o", eingabe) OF + CASE 1 : tastenzustand := 1 + CASE 2 : rechts ausfuehren + CASE 3 : oben ausfuehren + CASE 4 : links ausfuehren + CASE 5 : tab ausfuehren + CASE 6 : unten ausfuehren + CASE 7 : return ausfuehren + CASE 8 : tastenzustand := 2 + CASE 9 : leertaste ausfuehren + CASE 10, 11 : plus ausfuehren + CASE 12, 13 : minus ausfuehren + OTHERWISE sondertaste + END SELECT . + +hop funktion : + SELECT pos (""1""2""3""8""10""13"+x-o", eingabe) OF + CASE 1 : hop hop ausfuehren + CASE 2 : hop rechts ausfuehren + CASE 3 : hop oben ausfuehren + CASE 4 : hop links ausfuehren + CASE 5 : hop unten ausfuehren + CASE 6 : hop return ausfuehren + CASE 7, 8 : hop plus ausfuehren + CASE 9, 10 : hop minus ausfuehren + OTHERWISE out (piep) + END SELECT; + tastenzustand := 0 . + +esc funktion : + SELECT pos (""1"19?qh", eingabe) OF + CASE 1 : esc hop ausfuehren + CASE 2 : esc 1 ausfuehren + CASE 3 : esc 9 ausfuehren + CASE 4 : esc fragezeichen ausfuehren + CASE 5 : esc q ausfuehren + CASE 6 : errorstop (niltext) + OTHERWISE belegte taste + END SELECT; + tastenzustand := 0 . + +rechts ausfuehren : + IF akt spalte < spalten AND akt wahl < wahlen THEN + akt spalte INCR 1; + akt wahl INCR 1 + END IF . + +oben ausfuehren : + IF akt wahl > spalten THEN + akt zeile DECR 1; + akt wahl DECR spalten; + IF akt zeile <= kopfzeilen THEN + akt zeile INCR 1; + gerollt DECR 1; + gezeichnete zeilen := kopfzeilen + END IF + END IF . + +links ausfuehren : + IF akt spalte > 1 THEN + akt spalte DECR 1; + akt wahl DECR 1 + END IF . + +tab ausfuehren : + IF akt spalte = spalten THEN + push (""13"") (* return *) + ELSE + push (""1""2"") (* hop rechts *) + END IF . + +unten ausfuehren : + IF akt wahl + spalten <= wahlen THEN + akt zeile INCR 1; + akt wahl INCR spalten; + IF akt zeile > y laenge THEN + akt zeile DECR 1; + gerollt INCR 1; + gezeichnete zeilen := kopfzeilen + END IF + END IF . + +return ausfuehren : + IF akt zeile + gerollt < bis wiederholung THEN + push (hop links unten) + END IF . + +leertaste ausfuehren : + push (plus esc q) . + +plus ausfuehren : + IF wahlpos (akt wahl) = 0 AND akt wahl <= wahlen THEN + gewaehlt CAT akt wahl; + IF akt zeile <= gezeichnete zeilen THEN + wahlnummer (akt zeile, akt spalte, length (gewaehlt) DIV 2) + END IF + END IF . + +minus ausfuehren : + INT CONST alte pos := wahlpos (akt wahl); + IF alte pos > 0 THEN + wahl entfernen; + wahlpositionen ausgeben + END IF . + +wahl entfernen : + change (gewaehlt, 2 * alte pos - 1, 2 * alte pos, niltext) . + +sondertaste : + IF eingabe < blank THEN + push (lernsequenz auf taste (eingabe)) + ELSE + out (piep) + END IF . + +hop hop ausfuehren : + hop links ausfuehren; nach oben . + +hop rechts ausfuehren : + WHILE akt wahl < wahlen AND akt spalte < spalten REP + akt wahl INCR 1; akt spalte INCR 1 + END REP . + +hop oben ausfuehren : + IF akt zeile = kopfzeilen + 1 THEN + nach oben rollen + ELSE + nach oben + END IF . + +nach oben rollen : + INT VAR um := min (y laenge - kopfzeilen, gerollt); + gerollt DECR um; + INT CONST runter := noch angezeigter vorspann; + akt zeile INCR runter; + akt wahl DECR (um - runter) * spalten; + IF um > 0 THEN + gezeichnete zeilen := kopfzeilen + END IF . + +noch angezeigter vorspann : + max (0, bis vorspann - kopfzeilen - gerollt) . + +nach oben : + WHILE akt wahl > spalten AND akt zeile > kopfzeilen + 1 REP + akt zeile DECR 1; + akt wahl DECR spalten + END REP . + +hop links ausfuehren : + akt wahl DECR (akt spalte - 1); + akt spalte := 1 . + +hop unten ausfuehren : + IF akt zeile = y laenge THEN + nach unten rollen + ELSE + nach unten + END IF . + +nach unten rollen : + um := min (y laenge - kopfzeilen, gesamtzeilen - akt zeile - gerollt); + gerollt INCR um; + INT CONST rauf := max (0, akt zeile + gerollt - bis wiederholung + + spaltenkorrektur); + akt zeile DECR rauf; + akt wahl INCR (um - rauf) * spalten; + IF um > 0 THEN + gezeichnete zeilen := kopfzeilen + END IF . + +spaltenkorrektur : + IF akt spalte - 1 > wahlen MOD spalten THEN + 1 + ELSE + 0 + END IF . + +nach unten : + WHILE akt zeile < y laenge AND akt wahl + spalten <= wahlen REP + akt zeile INCR 1; + akt wahl INCR spalten + END REP . + +hop return ausfuehren : + gerollt INCR (akt zeile - kopfzeilen - 1); + akt zeile := kopfzeilen + 1; + gezeichnete zeilen := kopfzeilen . + +hop plus ausfuehren : + INT VAR w; + FOR w FROM 1 UPTO wahlen REP + IF wahlpos (w) = 0 THEN + gewaehlt CAT w + END IF + END REP; + wahlpositionen ausgeben . + +hop minus ausfuehren : + gewaehlt := niltext; + wahlpositionen ausgeben . + +esc fragezeichen ausfuehren : + hilfe anbieten (hilfe, f); + status anzeigen (auswahlstatus); + gezeichnete zeilen := 0 . + +esc q ausfuehren : + LEAVE anbieten . + +belegte taste : + push (lernsequenz auf taste (eingabe)) . + +esc 1 ausfuehren : + akt zeile := bis vorspann + 1; + akt wahl := 1; + akt spalte := 1; + gerollt := 0; + gezeichnete zeilen := kopfzeilen . + +esc 9 ausfuehren : + IF bis wiederholung <= y laenge THEN + akt zeile := bis wiederholung + ELSE + akt zeile := max (kopfzeilen + 1, + y laenge + bis wiederholung - gesamtzeilen) + END IF; + gerollt := bis wiederholung - akt zeile; + akt spalte := (wahlen - 1) MOD spalten + 1; + akt wahl := wahlen; + gezeichnete zeilen := kopfzeilen . + +END PROC anbieten; + +PROC wahlpositionen ausgeben : + + INT VAR z, s, w; + w := erste angezeigte wahl; + FOR z FROM erste wahlzeile UPTO letzte wahlzeile REP + FOR s FROM 1 UPTO spalten REP + wahlnummer (z, s, wahlpos (w)); + w INCR 1 + END REP + END REP . + +erste angezeigte wahl : + max (0, gerollt - bis vorspann + kopfzeilen) * spalten + 1 . + +erste wahlzeile : + max (kopfzeilen, bis vorspann - gerollt) + 1 . + +letzte wahlzeile : + min (y laenge, bis wiederholung - gerollt) . + +END PROC wahlpositionen ausgeben; + + +TEXT VAR zwei bytes := "xx"; + +INT PROC wahlpos (INT CONST feld) : + + replace (zwei bytes, 1, feld); + INT VAR p := 0; + REP + p := pos (gewaehlt, zwei bytes, p + 1) + UNTIL p = 0 OR p MOD 2 = 1 END REP; + (p + 1) DIV 2 + +END PROC wahlpos; + +OP CAT (INTVEC VAR intvec, INT CONST wert) : + + replace (zwei bytes, 1, wert); + intvec CAT zwei bytes + +END OP CAT; + +PROC auswahlzeile ausgeben (AUSWAHL CONST a, INT CONST erste wahl, + PROC (TEXT VAR, INT CONST) inhalt) : + + INT VAR + p := 1, + feld, + s := 1; + FOR feld FROM erste wahl UPTO erste wahl + spalten - 1 REP + outsubtext (a. wiederholung, p, spaltenpos - 5); + position ausgeben; + inhalt (zeile, feld); + INT CONST f laenge := min (jeweilige feldlaenge, length (zeile)); + outsubtext (zeile, 1, f laenge); + p := spaltenpos + f laenge + 2; + s INCR 1 + END REP; + zeilenrest loeschen . + +spaltenpos : + code (spaltenpositionen SUB s) . + +position ausgeben : + INT CONST n := wahlpos (feld); + IF n = 0 THEN + out (" o ") + ELSE + out (text (n, 3)); out (" x ") + END IF . + +jeweilige feldlaenge : + IF s = spalten THEN + x laenge - spaltenpos - 1 + ELSE + code (a. feldlaengen SUB s) + END IF . + +zeilenrest loeschen : + outsubtext (a. wiederholung, p, x laenge); + IF x pos + x laenge >= 80 THEN + out (cl eol) + ELSE + x laenge - max (p, length (a. wiederholung)) TIMESOUT blank + END IF . + +END PROC auswahlzeile ausgeben; + +PROC wahlnummer (INT CONST zeile, spalte, wert) : + + f cursor (code (spaltenpositionen SUB spalte) - 4, zeile); + IF wert = 0 THEN + out (" o ") + ELSE + out (text (wert, 3)); out (" x ") + END IF + +END PROC wahlnummer; + +INT PROC wahl (INT CONST stelle) : + + IF stelle + stelle <= length (gewaehlt) THEN + gewaehlt ISUB stelle + ELSE + 0 + END IF + +END PROC wahl; + + +(************************ Hilfen *****************************************) + +LET + maxgebiete = 200, + maxseiten = 5000; + +LET HILFE = STRUCT ( + INT anzahl seiten, + ROW maxgebiete THESAURUS hilfsnamen, + ROW maxgebiete SATZ seitenindex, + ROW maxseiten SATZ seiten); + +BOUND HILFE VAR h; + +INT VAR hx, hy, hxl, hyl; + +BOOL VAR hilfen sparen := FALSE; + + +(************************* Hilfe einlesen ********************************) + +LET + hilfsgebiet existiert bereits = #718# + "Das Hilfsgebiet existiert bereits", + seite existiert nicht = #719# + "Diese Seite ist in der anderen Hilfe nicht vorhanden"; + + +PROC hilfe aus datei lesen : + + TEXT VAR name := text parameter; + BOOL VAR hilfe ueberspringen; + IF name = niltext THEN + fehler (kein name angegeben) + ELSE + eintrag reservieren; + seiten einlesen; + hilfe abspeichern + END IF . + +eintrag reservieren : + INT CONST trennung := pos (name, "/"); + TEXT VAR gebiet; + IF trennung = 0 THEN + gebiet := name + ELSE + gebiet := subtext (name, 1, trennung - 1) + END IF; + gebietsindex bestimmen; + einzelindex bestimmen . + +gebietsindex bestimmen : + INT VAR gebietsindex := link (thesaurus (1), gebiet); + hilfe ueberspringen := FALSE; + IF gebietsindex = 0 THEN + insert (thesaurus (1), gebiet, gebietsindex); + h. hilfsnamen (gebietsindex) := empty thesaurus; + satz initialisieren (h. seitenindex (gebietsindex)); + ELIF trennung = 0 THEN + fehler (hilfsgebiet existiert bereits); + LEAVE hilfe aus datei lesen + ELIF hilfen sparen THEN + hilfe ueberspringen := TRUE + END IF . + +einzelindex bestimmen : + INT VAR einzelindex; + TEXT VAR einzelname := subtext (name, trennung + 1); + IF trennung = 0 THEN + einzelindex := 1 + ELSE + einzelindex := link (h. hilfsnamen (gebietsindex), einzelname); + IF einzelindex = 0 AND NOT hilfe ueberspringen THEN + insert (h. hilfsnamen (gebietsindex), einzelname, einzelindex) + END IF + END IF . + +seiten einlesen : + INT VAR vorlaeufige seiten := h. anzahl seiten; + IF vorlaeufige seiten < 0 THEN + vorlaeufige seiten := 0 + END IF; + TEXT VAR alle seiten := niltext; + zeile lesen; + WHILE kommandozeile CAND kommando ist (seite kommando) REP + eine seite einlesen + END REP . + +eine seite einlesen : + INT CONST seitennr := int parameter; + TEXT CONST referenz := text parameter; + IF referenz <> niltext THEN + seitenreferenz besorgen; + zeile lesen + ELSE + neue seite einlesen + END IF . + +seitenreferenz besorgen : + TEXT VAR referenzseiten; + seiten bestimmen (referenz, referenzseiten); + IF seitennr + seitennr <= length (referenzseiten) THEN + alle seiten CAT (referenzseiten ISUB seitennr) + ELIF NOT (anything noted OR hilfe ueberspringen) THEN + fehler (seite existiert nicht) + END IF . + +neue seite einlesen : + INT VAR zeilennr := 1; + IF NOT hilfe ueberspringen THEN + vorlaeufige seiten INCR 1; + alle seiten CAT vorlaeufige seiten; + satz initialisieren (h. seiten (vorlaeufige seiten)) + END IF; + REP + zeile lesen; + IF kommandozeile THEN + LEAVE neue seite einlesen + ELIF NOT hilfe ueberspringen THEN + feld aendern (h. seiten (vorlaeufige seiten), zeilennr, zeile); + zeilennr INCR 1 + END IF + END REP . + +hilfe abspeichern : + IF NOT kommando ist (ende kommando) THEN + fehler (ende fehlt) + END IF; + IF NOT (anything noted OR hilfe ueberspringen) THEN + feld aendern (h. seitenindex (gebietsindex), einzelindex, alle seiten); + h. anzahl seiten := vorlaeufige seiten + END IF . + +END PROC hilfe aus datei lesen; + +PROC seiten bestimmen (TEXT CONST name, TEXT VAR alle seiten) : + + INT CONST trennung := pos (name, "/"); + INT VAR + gebiet, + einzelindex := 0; + IF trennung = 0 THEN + gebiet := link (thesaurus (1), name) + ELSE + gebiet := link (thesaurus (1), subtext (name, 1, trennung - 1)); + einzelindex suchen + END IF; + IF einzelindex = 0 THEN + einzelindex := 1 + END IF; + IF gebiet = 0 THEN + errorstop (hilfe existiert nicht) + ELSE + feld lesen (h. seitenindex (gebiet), einzelindex, alle seiten) + END IF . + +einzelindex suchen : + IF gebiet > 0 THEN + einzelindex := + link (h. hilfsnamen (gebiet), subtext (name, trennung + 1)) + END IF . + +END PROC seiten bestimmen; + + +(************************* Hilfe anbieten ********************************) + +LET + hilfe existiert nicht = #720# + "Hilfe existiert nicht", + hilfe ist leer = #721# + "Hilfe ist leer", + hilfe status = #722# +"HILFE: Beenden: ESC q Seite weiter: ESC w Seite zurueck: ESC z"; + + +PROC hilfe anbieten (TEXT CONST name, FENSTER CONST f) : + + enable stop; + ggf initialisieren; + TEXT VAR alle seiten; + fensterzugriff anmelden; + seiten bestimmen (name, alle seiten); + IF alle seiten = niltext THEN + errorstop (hilfe ist leer) + ELSE + seiten ausgeben + END IF . + +fensterzugriff anmelden : + fenster veraendert (f); + fenstergroesse (f, hx, hy, hxl, hyl) . + +seiten ausgeben : + tastenpuffer loeschen; + status anzeigen (hilfe status); + INT VAR seitenindex := 1; + REP + eine seite ausgeben; + kommando annehmen + END REP . + +eine seite ausgeben : + INT CONST tatsaechliche seite := alle seiten ISUB seitenindex; + seite ausgeben (h. seiten (tatsaechliche seite)) . + +kommando annehmen : + TEXT VAR eingabe; + REP + getchar (eingabe); + IF eingabe = esc THEN + getchar (eingabe); + kommando ausfuehren; + LEAVE kommando annehmen + ELSE + out (piep) + END IF + END REP . + +kommando ausfuehren : + SELECT pos ("qwz?"1"", eingabe) OF + CASE 1 : LEAVE hilfe anbieten + CASE 2 : eine seite weiter + CASE 3 : eine seite zurueck + CASE 4 : an anfang + CASE 5 : esc hop ausfuehren + OTHERWISE out (piep) + END SELECT . + +eine seite weiter : + IF 2 * seitenindex < length (alle seiten) THEN + seitenindex INCR 1 + END IF . + +eine seite zurueck : + IF seitenindex > 1 THEN + seitenindex DECR 1 + END IF . + +an anfang : + seitenindex := 1 . + +END PROC hilfe anbieten; + +PROC seite ausgeben (SATZ CONST seite) : + + INT VAR zeilennr; + FOR zeilennr FROM 1 UPTO hyl REP + cursor (hx, hy + zeilennr - 1); + feld bearbeiten (seite, zeilennr, + PROC (TEXT CONST, INT CONST, INT CONST) zeile ausgeben) + END REP; + cursor (hx, hy + hyl - 1) + +END PROC seite ausgeben; + +PROC zeile ausgeben (TEXT CONST bild, INT CONST von, bis) : + + IF bis - von + 1 > hxl THEN + ende := von + hxl - 1 + ELSE + ende := bis + END IF; + outsubtext (bild, von, ende); + IF hx + hxl >= 80 THEN + out (cleol) + ELSE + hxl + von - ende - 1 TIMESOUT blank + END IF + +END PROC zeile ausgeben; + + +(*********************** Statuszeile *************************************) + +PROC status anzeigen (TEXT CONST status) : + + cursor (1, 1); + out (status); + out (cl eol); + fenster veraendert (balkenfenster) + +END PROC status anzeigen; + + +(******************************* Dialog **********************************) + +LET + cleop = ""4"", + esc fragezeichen = ""27"?", + esc q = ""27"q", + esc h = ""27"h"; + +LET + ja nein text = #723# + " ? (j/n) ", + ja zeichen = #724# + "jJ", + nein zeichen = #725# + "nN", + ja status = #726# +"FRAGE: Bejahen: j,J Verneinen: n,N Abbrechen: ESC h Hilfe: ESC ?", + editget status ohne esc z = #727# +"EINGABE: Bestätigen: RETURN Abbrechen: ESC h Hilfe: ESC ?", + editget status mit esc z = #728# +"EINGABE: Bestätigen: RETURN Zeigen: ESC z Abbruch: ESC h Hilfe: ESC ?", + fehler status = #729# +""15"!!! FEHLER !!! "14" Quittieren: ESC q Hilfe zur Meldung: ESC ?"; + +FENSTER VAR d fenster; +fenster initialisieren (d fenster); + +INT VAR + dialogzeile, + dx, + dy, + dxl, + dyl; + + +PROC dialogfenster (INT CONST x, y, x l, y l) : + + fenstergroesse setzen (d fenster, x, y, x l, y l); + dx := x; dy := y; dxl := x l; dyl := y l + +END PROC dialogfenster; + +PROC neuer dialog : + + dialogzeile := dyl + +END PROC neuer dialog; + +PROC dialog : + + BOOL VAR veraendert; + fensterzugriff (d fenster, veraendert); + dialogzeile INCR 1; + IF dialogzeile > dyl OR veraendert THEN + dialogfenster loeschen; + dialogzeile := 1 + END IF; + cursor (dx, dy + dialogzeile - 1) . + +END PROC dialog; + +PROC dialogfenster loeschen : + + BOOL CONST bis zeilenende := dx + dxl >= 80; + dialogzeile := 0; + REP + cursor (dx, dy + dialogzeile); + IF bis zeilenende THEN + out (cleol) + ELSE + dxl TIMESOUT blank + END IF; + dialogzeile INCR 1 + UNTIL dialogzeile >= dyl END REP . + +END PROC dialogfenster loeschen; + +BOOL PROC ja (TEXT CONST frage, hilfe) : + + REP + status anzeigen (ja status); + dialog; + out (frage); out (ja nein text); + tastenpuffer loeschen; + zeichen annehmen und auswerten + END REP; + FALSE . + +zeichen annehmen und auswerten : + TEXT VAR eingabe; + REP + getchar (eingabe); + IF pos (ja zeichen, eingabe) > 0 THEN + out (eingabe); LEAVE ja WITH TRUE + ELIF pos (nein zeichen, eingabe) > 0 THEN + out (eingabe); LEAVE ja WITH FALSE + ELIF eingabe = esc THEN + esc funktionen + ELSE + out (piep) + END IF + END REP . + +esc funktionen : + getchar (eingabe); + IF eingabe = "?" THEN + hilfe anbieten (hilfe, d fenster); + neuer dialog; + LEAVE zeichen annehmen und auswerten + ELIF eingabe = "h" THEN + errorstop (niltext); + LEAVE ja WITH FALSE + ELIF eingabe = ""1"" THEN + esc hop ausfuehren + ELSE + out (piep) + END IF . + +END PROC ja; + +PROC editget (TEXT CONST prompt, TEXT VAR eingabe, TEXT CONST res, hilfe) : + + TEXT VAR exit char; + passenden status anzeigen; + dialog; + out (prompt); out (blank); + editget (eingabe, 1000, editlaenge, "", "?hq" + res, exit char); + IF exit char = esc fragezeichen THEN + hilfe anbieten (hilfe, d fenster); + neuer dialog; + editget (prompt, eingabe, res, hilfe) + ELIF exit char = esc h OR exit char = esc q THEN + errorstop (niltext) + ELIF length (exit char) = 2 THEN + eingabe := exit char + END IF . + +passenden status anzeigen : + IF pos (res, "z") > 0 THEN + status anzeigen (editget status mit esc z) + ELSE + status anzeigen (editget status ohne esc z) + END IF . + +editlaenge : + dxl - length (prompt) - 1 . + +END PROC editget; + +PROC fehler ausgeben : + + TEXT CONST meldung := errormessage; + IF error code = 1 THEN + page; bildschirm neu + END IF; + clear error; + tastenpuffer loeschen; + IF meldung <> niltext THEN + status anzeigen (fehler status); + meldung ausgeben; + eingabe abwarten; + neuer dialog + END IF . + +meldung ausgeben : + dialog; + out (piep); out (">>> "); + outsubtext (errormessage, 1, dxl) . + +eingabe abwarten : + TEXT VAR eingabe; + getchar (eingabe); + IF eingabe = esc THEN + esc funktionen + END IF . + +esc funktionen : + getchar (eingabe); + IF eingabe = "?" THEN + hilfe anbieten ("FEHLER/" + text (errorcode), d fenster) + ELIF eingabe = ""1"" THEN + esc hop ausfuehren + END IF . + +END PROC fehler ausgeben; + +PROC tastenpuffer loeschen : + + WHILE getcharety <> niltext REP END REP + +END PROC tastenpuffer loeschen; + + +(************************** Menue Manager ********************************) + +LET + max ds = 3, + save order = 12, + erase order = 14, + fetch order = 1070, + lock order = 1068, + free order = 1069, + ack = 0, + error nak = 2; + +ROW maxds DATASPACE VAR menue ds; + +ROW maxds THESAURUS VAR thesaurus; + +BOOL VAR vater ist menuemanager := FALSE; + +INITFLAG VAR menueinitialisierung; + + +PROC ggf initialisieren : + + IF NOT initialized (menueinitialisierung) THEN + initialisierung durchfuehren + END IF . + +initialisierung durchfuehren : + BOOL VAR erfolgreich := vater ist menuemanager; + datenraeume holen; + IF erfolgreich THEN + ankoppeln + ELSE + menue loeschen (FALSE) + END IF . + +datenraeume holen : + INT VAR nr; + FOR nr FROM 1 UPTO maxds + WHILE erfolgreich REP + versuche zu holen + END REP . + +versuche zu holen : +## (* nur im Multi-User *) + INT VAR + reply, + retries; + FOR retries FROM 1 UPTO 10 REP + forget (menue ds (nr)); + menue ds (nr) := nilspace; + pingpong (father, fetch order + nr, menue ds (nr), reply); + IF reply = ack THEN + LEAVE versuche zu holen + ELIF reply <> error nak THEN + pause (15) + END IF + UNTIL reply = error nak END REP; + forget (menue ds (nr)); + menue ds (nr) := nilspace; +## + erfolgreich := FALSE . + +END PROC ggf initialisieren; + +THESAURUS PROC menuenamen (INT CONST nr) : + + ggf initialisieren; + IF nr < 0 THEN + h. hilfsnamen (- nr) + ELSE + thesaurus (nr) + END IF + +END PROC menuenamen; + +PROC menue loeschen (TEXT CONST name, INT CONST nr) : + + ggf initialisieren; + IF nr < 0 THEN + loeschen (name, h. hilfsnamen (- nr)) + ELSE + loeschen (name, thesaurus (nr)) + END IF + +END PROC menue loeschen; + +PROC loeschen (TEXT CONST name, THESAURUS VAR t) : + + INT CONST index := link (t, name); + IF index > 0 THEN + delete (t, index) + END IF + +END PROC loeschen; + +PROC menue loeschen (BOOL CONST hilfen reduzieren) : + + INT VAR nr; + menueinitialisierung := TRUE; + hilfen sparen := hilfen reduzieren; + FOR nr FROM 1 UPTO max ds REP + forget (menue ds (nr)); + menue ds (nr) := nilspace; + thesaurus (nr) := empty thesaurus + END REP; + ankoppeln + +END PROC menue loeschen; + +PROC ankoppeln : + + h := menue ds (1); + menues := menue ds (2); + auswahlen := menue ds (3) + +END PROC ankoppeln; + +## (* nur im Multi-User *) + +LET + lock aktiv = #730# + "Datei wird von anderer Task geaendert.", + auftrag nur fuer soehne = #731# + "Auftrag nur fuer Soehne erlaubt"; + +THESAURUS VAR locks := empty thesaurus; + +ROW 200 TASK VAR lock owner; + +TEXT VAR save file name; + +BOUND STRUCT (TEXT name, write pass, read pass) VAR msg; + +PROC menue manager (DATASPACE VAR ds, INT CONST order, phase, + TASK CONST order task) : + + enable stop; + vater ist menue manager := TRUE; + IF order >= lock order AND order <= fetch order + max ds THEN + menue auftrag + ELSE + IF order = save order OR order = erase order THEN + save pre + END IF; + free manager (ds, order, phase, order task) + END IF . + +menue auftrag : + IF order = lock order THEN + lock ausfuehren + ELIF order = free order THEN + free ausfuehren + ELSE + menue fetch + END IF . + +lock ausfuehren : + msg := ds; + set lock (msg. name, order task); + send (order task, ack, ds) . + +free ausfuehren : + msg := ds; + reset lock (msg. name); + send (order task, ack, ds) . + +save pre : + IF phase = 1 THEN + lock ueberpruefen + ELSE + reset lock (save file name) + END IF . + +lock ueberpruefen : + msg := ds; + save file name := msg. name; + IF gesperrt und task ungleich THEN + errorstop (lock aktiv) + END IF . + +gesperrt und task ungleich : + INT VAR stelle := link (locks, save file name); + stelle > 0 CAND NOT (lock owner (stelle) = order task) . + +menue fetch : + IF order task < myself THEN + ggf initialisieren; + forget (ds); ds := menue ds (order - fetch order); + send (order task, ack, ds) + ELSE + errorstop (auftrag nur fuer soehne) + END IF . + +END PROC menue manager; + +PROC set lock (TEXT CONST dateiname, TASK CONST owner) : + + INT VAR i := link (locks, dateiname); + IF i = 0 THEN + insert (locks, dateiname, i); + ggf reorganisieren; + lock owner (i) := owner + ELIF exists (lock owner (i)) THEN + IF NOT (lock owner (i) = owner) THEN + errorstop (lock aktiv) + END IF + ELSE + lock owner (i) := owner + END IF . + +ggf reorganisieren : + IF i = 0 THEN + locks reorganisieren; + insert (locks, dateiname, i) + END IF . + +locks reorganisieren : + TEXT VAR eintrag; + i := 0; + REP + get (locks, eintrag, i); + IF i = 0 THEN + LEAVE locks reorganisieren + END IF; + IF NOT exists (eintrag) OR NOT exists (lock owner (i)) THEN + delete (locks, i) + END IF + END REP . + +END PROC set lock; + +PROC reset lock (TEXT CONST dateiname) : + + INT VAR i; + delete (locks, dateiname, i) + +END PROC reset lock; + +PROC global manager : + + global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, + TASK CONST) menue manager) + +END PROC global manager; +## + +PROC lock (TEXT CONST dateiname, TASK CONST manager) : + + call (lock order, dateiname, manager) + +END PROC lock; + +PROC free (TEXT CONST dateiname, TASK CONST manager) : + + call (free order, dateiname, manager) + +END PROC free; + +END PACKET eudas menues; + diff --git a/app/eudas/4.4/src/eudas.satzanzeige b/app/eudas/4.4/src/eudas.satzanzeige new file mode 100644 index 0000000..25afc8e --- /dev/null +++ b/app/eudas/4.4/src/eudas.satzanzeige @@ -0,0 +1,993 @@ +PACKET satzanzeige + +(*************************************************************************) +(* *) +(* Anzeige von EUDAS-Saetzen *) +(* *) +(* Version 09 *) +(* *) +(* Autor: Thomas Berlage *) +(* Stand: 31.07.87 *) +(* *) +(*************************************************************************) + + DEFINES + + anzeigefenster, + bild ausgeben, + aendern, + einfuegen, + suchen, + feldauswahl, + rollen, + exit durch, + exit zeichen : + + +LET + maxfelder = 256; + +LET + blank = " ", + niltext = "", + cleol = ""5"", + begin mark = ""15"", + blank end mark = " "14"", + blank end mark blank = " "14" "; + +ROW maxfelder STRUCT (INT feldnr, anfang) VAR zeilen; + +INT VAR + anzahl zeilen, + erste zeile, + laenge := 24, + breite := 79, + zeilen anf := 1, + spalten anf := 1, + feldnamenlaenge, + inhaltsbreite, + zuletzt angezeigter satz := 0, + letzte kombi := 0, + anzeigeversion := dateiversion - 1, + anzeigedateien := 0; + +BOOL VAR + neues fenster := TRUE, + bis zeilenende := TRUE, + save ds voll := FALSE, + namen ausgeben; + +FENSTER VAR fenster; +fenster initialisieren (fenster); + +DATASPACE VAR + save ds, + edit ds; + +FILE VAR edit file; + +TEXT VAR + ueberschrift, + zeilenpuffer; + +LET + fenster zu klein = #801# + "Anzeigefenster zu klein"; + + +PROC anzeigefenster (INT CONST x anf, y anf, x laenge, y laenge) : + + IF x laenge >= 39 THEN + fenstergroesse setzen (fenster, x anf, y anf, x laenge, y laenge); + bis zeilenende := x anf + x laenge >= 80; + breite := x laenge; laenge := y laenge; + spalten anf := x anf; + zeilen anf := y anf; + neues fenster := TRUE + ELSE + errorstop (fenster zu klein) + END IF + +END PROC anzeigefenster; + +PROC fensterzugriff anmelden : + + BOOL VAR fenster veraendert; + fensterzugriff (fenster, fenster veraendert); + IF fenster veraendert THEN + namen ausgeben := TRUE + END IF + +END PROC fensterzugriff anmelden; + +PROC zeilendeskriptor aktualisieren : + + IF neue datei seit letztem mal OR neues fenster THEN + neue feldnummern uebernehmen; + feldnamenlaenge bestimmen; + ueberschrift generieren; + fuer bildausgabe sorgen; + edit datei loeschen; + veraenderungsstatus merken + END IF . + +neue datei seit letztem mal : + anzeigeversion <> dateiversion . + +neue feldnummern uebernehmen : + anzahl zeilen := 0; + WHILE anzahl zeilen < anzahl felder REP + anzahl zeilen INCR 1; + zeilen (anzahl zeilen). feldnr := anzahl zeilen + END REP; + erste zeile := 1 . + +feldnamenlaenge bestimmen : + INT VAR feldnr; + feldnamenlaenge := 11; + FOR feldnr FROM 1 UPTO anzahl felder REP + feldnamen bearbeiten (feldnr, + PROC (TEXT CONST, INT CONST, INT CONST) namen max) + END REP; + feldnamenlaenge := min (feldnamenlaenge, breite DIV 2); + inhaltsbreite := breite - feldnamenlaenge - 3 . + +fuer bildausgabe sorgen : + namen ausgeben := TRUE . + +edit datei loeschen : + forget (edit ds); + edit ds := nilspace; + IF neue datei seit letztem mal AND save ds voll THEN + forget (save ds); + save ds voll := FALSE + END IF . + +veraenderungsstatus merken : + anzeigeversion := dateiversion; + anzeigedateien := anzahl dateien; + neues fenster := FALSE . + +END PROC zeilendeskriptor aktualisieren; + +PROC namen max (TEXT CONST satz, INT CONST von, bis) : + + feldnamenlaenge INCR length (satz) - length (satz); + (* damit Parameter benutzt *) + feldnamenlaenge := max (feldnamenlaenge, bis - von + 1) + +END PROC namen max; + +PROC rollen (INT CONST vektor) : + + erste zeile := erste zeile + vektor; + IF erste zeile < 1 THEN + erste zeile := 1 + ELIF erste zeile > letzte zeile THEN + erste zeile := max (letzte zeile, 1) + END IF; + namen ausgeben := TRUE . + +letzte zeile : + anzahl zeilen - laenge + 3 . + +END PROC rollen; + +PROC feldauswahl (TEXT CONST wahlvektor) : + + zeilendeskriptor aktualisieren; + feldnummern uebernehmen; + namen ausgeben := TRUE . + +feldnummern uebernehmen : + anzahl zeilen := length (wahlvektor); + INT VAR zeilennr; + FOR zeilennr FROM 1 UPTO anzahl zeilen REP + zeilen (zeilennr). feldnr := code (wahlvektor SUB zeilennr) + END REP; + erste zeile := 1 . + +END PROC feldauswahl; + + +(**************************** editfile ***********************************) + +INT VAR gelesene zeile; + +PROC edit file loeschen : + + type (edit ds, - 1); + edit file := sequential file (modify, edit ds); + edit info (edit file, -1); + to line (editfile, 1); + col (editfile, 1); + maxlinelength (edit file, 10000); + gelesene zeile := 1 + +END PROC edit file loeschen; + +. +noch zeile zu bearbeiten : + gelesene zeile <= anzahl zeilen . + +PROC naechste zeile bearbeiten (PROC (TEXT CONST, INT CONST) bearbeite) : + + zu bearbeitende zeilen bestimmen; + IF eof (editfile) THEN + bearbeite ("", feldnr) + ELIF mehrere zeilen THEN + zeilen verketten; + blanks abschneiden; + bearbeite (zeilenpuffer, feldnr) + ELIF blanks am ende THEN + read record (edit file, zeilenpuffer); + blanks abschneiden; + bearbeite (zeilenpuffer, feldnr); + down (edit file) + ELSE + exec (PROC (TEXT CONST, INT CONST) bearbeite, edit file, feldnr); + down (edit file) + END IF . + +zu bearbeitende zeilen bestimmen : + INT CONST + von := gelesene zeile, + feldnr := zeilen (von). feldnr; + REP + gelesene zeile INCR 1 + UNTIL gelesene zeile > anzahl zeilen COR neues feld END REP . + +neues feld : + zeilen (gelesene zeile). feldnr <> feldnr . + +mehrere zeilen : + gelesene zeile - von > 1 . + +zeilen verketten : + zeilenpuffer := ""; + REP + exec (PROC (TEXT CONST, INT CONST) verkette, + edit file, length (zeilenpuffer)); + down (edit file) + UNTIL eof (edit file) OR line no (edit file) = gelesene zeile END REP . + +blanks am ende : + INT CONST ende := len (edit file); + subtext (edit file, ende, ende) = blank . + +END PROC naechste zeile bearbeiten; + +PROC verkette (TEXT CONST edit zeile, INT CONST pufferlaenge) : + + IF pufferlaenge > 0 CAND (zeilenpuffer SUB pufferlaenge) <> blank + CAND (edit zeile SUB 1) <> blank THEN + zeilenpuffer CAT blank + END IF; + zeilenpuffer CAT edit zeile + +END PROC verkette; + +PROC blanks abschneiden : + + INT VAR ende := length (zeilenpuffer); + WHILE (zeilenpuffer SUB ende) = blank REP + ende DECR 1 + END REP; + zeilenpuffer := subtext (zeilenpuffer, 1, ende) + +END PROC blanks abschneiden; + + +(*************************** Funktionen **********************************) + + +BOOL VAR aus einfuegen; + +PROC einfuegen (PROC hilfe) : + + enable stop; + zeilendeskriptor aktualisieren; + IF anzahl zeilen > 0 THEN + edit file loeschen; + fensterzugriff anmelden; + editieren (PROC hilfe); + satz einfuegen; + aus einfuegen := TRUE; + felder aendern + END IF + +END PROC einfuegen; + +PROC felder aendern : + + WHILE noch zeile zu bearbeiten REP + naechste zeile bearbeiten + (PROC (TEXT CONST, INT CONST) ein feld aendern) + END REP; + aenderungen eintragen + +END PROC felder aendern; + +PROC ein feld aendern (TEXT CONST inhalt, INT CONST feldnr) : + + IF NOT aus einfuegen COR inhalt <> niltext THEN + feld aendern (feldnr, inhalt) + END IF + +END PROC ein feld aendern; + +PROC aendern (PROC hilfe) : + + enable stop; + IF dateiende THEN + einfuegen (PROC hilfe) + ELSE + wirklich aendern + END IF . + +wirklich aendern : + zeilendeskriptor aktualisieren; + IF anzahl zeilen > 0 THEN + edit file loeschen; + fensterzugriff anmelden; + bild aufbauen (namen ausgeben); + feldinhalte eintragen; + editieren (PROC hilfe); + aus einfuegen := FALSE; + felder aendern + END IF . + +feldinhalte eintragen : + kopierzeile := 1; + WHILE kopierzeile <= anzahl zeilen REP + feld bearbeiten (zeilen (kopierzeile). feldnr, + PROC (TEXT CONST, INT CONST, INT CONST) inhalt kopieren); + insert record (edit file); + write record (edit file, zeilenpuffer); + down (edit file); + kopierzeile INCR 1 + END REP; + to line (edit file, 1) . + +END PROC aendern; + +INT VAR kopierzeile; + +PROC inhalt kopieren (TEXT CONST satz, INT CONST von, bis) : + + zeilenpuffer := subtext (satz, feldanfang, feldende) . + +feldanfang : + von + zeilen (kopierzeile). anfang . + +feldende : + IF keine fortsetzung THEN + bis + ELSE + von + zeilen (kopierzeile + 1). anfang - 1 + END IF . + +keine fortsetzung : + kopierzeile = anzahl zeilen COR + zeilen (kopierzeile + 1). feldnr <> zeilen (kopierzeile). feldnr . + +END PROC inhalt kopieren; + +PROC suchen (PROC hilfe) : + + enable stop; + zeilendeskriptor aktualisieren; + IF anzahl zeilen > 0 THEN + edit file loeschen; + fensterzugriff anmelden; + IF such version <> 0 THEN + altes suchmuster eintragen + END IF; + editieren (PROC hilfe); + suchbedingung einstellen + END IF . + +altes suchmuster eintragen : + kopierzeile := 1; + WHILE kopierzeile <= anzahl zeilen REP + insert record (edit file); + suchmusterzeile eintragen; + down (edit file); + kopierzeile INCR 1 + END REP; + to line (edit file, 1) . + +suchmusterzeile eintragen : + IF zeilen (kopierzeile). anfang = 0 THEN + suchbedingung lesen (zeilen (kopierzeile). feldnr, zeilenpuffer); + write record (edit file, zeilenpuffer) + END IF . + +suchbedingung einstellen : + suchbedingung loeschen; + WHILE noch zeile zu bearbeiten REP + naechste zeile bearbeiten (PROC (TEXT CONST, INT CONST) zeilenbedingung) + END REP . + +END PROC suchen; + +PROC zeilenbedingung (TEXT CONST zeile, INT CONST feldnr) : + + suchbedingung (feldnr, zeile) + +END PROC zeilenbedingung; + +PROC bild ausgeben (BOOL CONST datei veraendert) : + + enable stop; + zeilendeskriptor aktualisieren; + fensterzugriff anmelden; + IF datei veraendert OR namen ausgeben OR anderer satz THEN + bild aufbauen (namen ausgeben); + zuletzt angezeigter satz := satznummer; + letzte kombi := satzkombination; + einzelbild ausgeben (TRUE) + ELSE + ueberschrift ausgeben (TRUE) + END IF . + +anderer satz : + satznummer <> zuletzt angezeigter satz OR letzte kombi <> satzkombination . + +END PROC bild ausgeben; + + +(*************************** Bild aufbauen *******************************) + +INT VAR anfang; + +BOOL VAR fertig; + + +PROC bild aufbauen (BOOL CONST kuerzen erlaubt) : + + INT VAR + zeilennr := 1, + alte feldnr := 0; + fertig := TRUE; + WHILE zeilennr <= anzahl zeilen OR NOT fertig REP + eine zeile behandeln + END REP . + +eine zeile behandeln : + IF fertig CAND zeilen (zeilennr). feldnr = alte feldnr THEN + eventuell zusammenruecken + ELSE + IF altes feld beendet THEN + feldwechsel + END IF; + zeilen (zeilennr). anfang := anfang; + feld bearbeiten (zeilen (zeilennr). feldnr, + PROC (TEXT CONST, INT CONST, INT CONST) laenge bestimmen); + zeilennr INCR 1 + END IF . + +eventuell zusammenruecken : + IF kuerzen erlaubt THEN + zeile loeschen (zeilennr) + ELSE + zeilen (zeilennr). anfang := anfang; + zeilennr INCR 1 + END IF . + +altes feld beendet : + zeilennr > anzahl zeilen COR zeilen (zeilennr). feldnr <> alte feldnr . + +feldwechsel : + IF fertig THEN + neues feld anfangen + ELSE + zeile einfuegen (zeilennr); + zeilen (zeilennr). feldnr := alte feldnr + END IF . + +neues feld anfangen : + alte feldnr := zeilen (zeilennr). feldnr; + anfang := 0 . + +END PROC bild aufbauen; + +PROC laenge bestimmen (TEXT CONST satz, INT CONST von, bis) : + + INT CONST restlaenge := bis - von - anfang + 1; + IF restlaenge > inhaltsbreite - 2 THEN + anfang INCR inhaltsbreite - 2; + rueckwaerts blank suchen; + fertig := FALSE + ELSE + anfang INCR restlaenge; + fertig := TRUE + END IF . + +rueckwaerts blank suchen : + INT VAR stelle := von + anfang - 1; + IF trennung im wort AND blanks vorhanden THEN + WHILE (satz SUB stelle) <> blank REP + stelle DECR 1; anfang DECR 1 + END REP + END IF . + +trennung im wort : + (satz SUB stelle) <> blank . + +blanks vorhanden : + pos (satz, blank, stelle - inhaltsbreite, stelle - 1) > 0 . + +END PROC laenge bestimmen; + +PROC zeile einfuegen (INT CONST zeilennr) : + + INT VAR i; + FOR i FROM anzahl zeilen DOWNTO zeilennr REP + zeilen (i+1) := zeilen (i) + END REP; + anzahl zeilen INCR 1; + namen ausgeben := TRUE + +END PROC zeile einfuegen; + +PROC zeile loeschen (INT CONST zeilennr) : + + INT VAR i; + FOR i FROM zeilennr + 1 UPTO anzahl zeilen REP + zeilen (i-1) := zeilen (i) + END REP; + anzahl zeilen DECR 1; + namen ausgeben := TRUE + +END PROC zeile loeschen; + + +(************************** Editieren ************************************) + +INT VAR rueckkehrcode; + +TEXT VAR + zeilenrest, + zeile vorher, + zeile nachher, + quit zeichen := "", + quit durch; + +LET + hinweiszeile = #802# + ""15" Bild verschoben ! ESC 1 druecken ! "14""; + +LET + eudas res = ""3""10"19"11""12"q?hpg"; + +LET + oben = 1, + unten = 2, + eins = 3, + neun = 4, + rubin = 5, + rubout = 6, + edit ende = 7, + frage = 8, + abbruch = 9, + double = 10, + esc get = 11; + + +PROC editieren (PROC hilfe) : + + INT VAR alte zeilennr := erste zeile; + lernsequenz auf taste legen ("D", date); + REP + einzelbild ausgeben (FALSE); + file verlaengern; + erste und letzte zeile markieren; + file editieren; + nachbehandeln + UNTIL wirklich verlassen END REP; + to line (edit file, 1); + col (edit file, 1) . + +file verlaengern : + IF lines (edit file) < anzahl zeilen + 1 THEN + output (edit file); + line (editfile, anzahl zeilen - lines (editfile) + 2); + modify (edit file) + END IF . + +erste und letzte zeile markieren : + IF erste zeile <> 1 THEN + einsetzen (erste zeile - 1, zeile vorher) + END IF; + einsetzen (zeile nach bildschirm, zeile nachher); + to line (edit file, alte zeilennr) . + +zeile nach bildschirm : + min (anzahl zeilen + 1, erste zeile + laenge - 1) . + +file editieren : + open editor (groesster editor + 1, edit file, TRUE, + spalten anf + feldnamenlaenge + 3, zeilen anf, + inhaltsbreite, editlaenge); + edit (groesster editor, eudas res + quit zeichen, + PROC (TEXT CONST) eudas interpreter) . + +editlaenge : + min (anzahl zeilen - erste zeile + 2, laenge) . + +nachbehandeln : + alte zeilennr := line no (edit file); + hinweiszeilen entfernen; + SELECT rueckkehrcode OF + CASE oben : nach oben rollen + CASE unten : nach unten rollen + CASE eins : auf erste zeile + CASE neun : auf letzte zeile + CASE rubin : zeile umbrechen + CASE rubout : zeile entfernen + CASE frage : hilfe; namen ausgeben := TRUE + CASE abbruch : errorstop (niltext) + CASE double : in save ds kopieren + CASE esc get : aus save ds holen + END SELECT . + +hinweiszeilen entfernen : + INT CONST spalte := col (edit file); + col (edit file, 1); + IF erste zeile <> 1 THEN + entfernen (erste zeile - 1, zeile vorher) + END IF; + entfernen (zeile nach bildschirm, zeile nachher); + col (edit file, spalte) . + +nach oben rollen : + INT VAR abstand; + abstand := alte zeilennr - erste zeile; + rollen (-laenge + 1); + alte zeilennr := erste zeile + abstand . + +nach unten rollen : + abstand := alte zeilennr - erste zeile; + rollen (laenge - 1); + alte zeilennr := min (erste zeile + abstand, anzahl zeilen) . + +auf erste zeile : + rollen (-999); + alte zeilennr := 1 . + +auf letzte zeile : + abstand := alte zeilennr - erste zeile; + rollen (999); + alte zeilennr := min (erste zeile + abstand, anzahl zeilen) . + +zeile umbrechen : + to line (edit file, alte zeilennr); + aktuelle zeile aufsplitten; + zeile einfuegen (alte zeilennr) . + +aktuelle zeile aufsplitten : + read record (edit file, zeilenpuffer); + zeilenrest := subtext (zeilenpuffer, spalte); + zeilenpuffer := subtext (zeilenpuffer, 1, spalte - 1); + write record (edit file, zeilenpuffer); + down (edit file); + insert record (edit file); + write record (edit file, zeilenrest) . + +zeile entfernen : + to line (edit file, alte zeilennr); + IF spalte = 1 AND + (nicht letzte zeile CAND noch gleiche dahinter OR + nicht erste zeile CAND noch gleiche davor) THEN + ganz loeschen + ELSE + nur ueberschreiben + END IF . + +nicht letzte zeile : + alte zeilennr <> anzahl zeilen . + +noch gleiche dahinter : + zeilen (alte zeilennr + 1). feldnr = zeilen (alte zeilennr). feldnr . + +nicht erste zeile : + alte zeilennr <> 1 . + +noch gleiche davor : + zeilen (alte zeilennr - 1). feldnr = zeilen (alte zeilennr). feldnr . + +ganz loeschen : + delete record (edit file); + zeile loeschen (alte zeilennr) . + +nur ueberschreiben : + read record (edit file, zeilenpuffer); + zeilenpuffer := subtext (zeilenpuffer, 1, spalte - 1); + write record (edit file, zeilenpuffer) . + +in save ds kopieren : + forget (save ds); + save ds := edit ds; + save ds voll := TRUE . + +aus save ds holen : + IF save ds voll THEN + forget (edit ds); + edit ds := save ds; + edit file := sequential file (modify, edit ds) + END IF . + +wirklich verlassen : + rueckkehrcode = edit ende . + +END PROC editieren; + +PROC eudas interpreter (TEXT CONST zeichen) : + + enable stop; + set busy indicator; + rueckkehrcode := pos (eudas res, zeichen); + IF rueckkehrcode > 0 THEN + quit durch := zeichen; + quit + ELIF pos (quit zeichen, zeichen) > 0 THEN + rueckkehrcode := edit ende; + quit durch := zeichen; + quit + ELIF kommando auf taste (zeichen) <> niltext THEN + std kommando interpreter (zeichen) + ELSE + nichts neu + END IF + +END PROC eudas interpreter; + +PROC einsetzen (INT CONST zeilennr, TEXT VAR speicher) : + + to line (edit file, zeilennr); + read record (edit file, speicher); + write record (edit file, hinweiszeile) + +END PROC einsetzen; + +PROC entfernen (INT CONST zeilennr, TEXT CONST speicher) : + + to line (edit file, zeilennr); + IF eof (edit file) COR pos (edit file, hinweiszeile, 1) = 0 THEN + to line (edit file, 1); + down (edit file, hinweiszeile); + IF eof (edit file) THEN + to line (edit file, zeilennr); + insert record (edit file) + END IF + END IF; + write record (edit file, speicher) + +END PROC entfernen; + +PROC exit zeichen (TEXT CONST zeichenkette) : + + quit zeichen := zeichenkette + +END PROC exit zeichen; + +TEXT PROC exit durch : + + quit durch + +END PROC exit durch; + + +(****************************** Ausgabe **********************************) + +INT VAR ausgabezeile; + +LET + t ende = #803# + "ENDE.", + t such plus = #804# + "SUCH+", + t such minus = #805# + "SUCH-", + t mark plus = #806# + "MARK+", + t mark minus = #807# + "MARK-", + t feld = #808# + " Feld "14" ", + t satz = #809# + " Satz ", + t koppel = #810# + "< KOPPEL >"; + +LET + fuenf punkte = ".....", + sieben blanks = " "; + + +PROC einzelbild ausgeben (BOOL CONST auch inhalte) : + + INT VAR + bildschirmzeile := zeilen anf + 1, + aktuelles feld := 0; + INT CONST letzte ausgabezeile := erste zeile + laenge - 2; + ueberschrift ausgeben (auch inhalte); + ausgabezeile := erste zeile; + WHILE ausgabezeile <= letzte ausgabezeile REP + feldnamen ausgeben; + feldinhalt ausgeben; + evtl unterbrechung; + bildschirmzeile INCR 1; + ausgabezeile INCR 1 + END REP; + namen ausgeben := FALSE . + +feldnamen ausgeben : + IF namen ausgeben THEN + cursor (spalten anf, bildschirmzeile); + IF ausgabezeile <= anzahl zeilen THEN + namen tatsaechlich ausgeben + ELIF ausgabezeile = anzahl zeilen + 1 THEN + endebalken ausgeben + ELSE + bildschirmzeile loeschen + END IF + END IF . + +namen tatsaechlich ausgeben : + out (begin mark); + IF zeilen (ausgabezeile). feldnr = aktuelles feld THEN + feldnamenlaenge TIMESOUT blank + ELSE + aktuelles feld := zeilen (ausgabezeile). feldnr; + feldnamen bearbeiten (aktuelles feld, + PROC (TEXT CONST, INT CONST, INT CONST) randanzeige) + END IF; + out (blank end mark) . + +endebalken ausgeben : + out (begin mark); + breite - 4 TIMESOUT "."; + out (blank end mark blank) . + +bildschirmzeile loeschen : + IF bis zeilenende THEN + out (cleol) + ELSE + breite TIMESOUT blank + END IF . + +feldinhalt ausgeben : + IF auch inhalte AND ausgabezeile <= anzahl zeilen THEN + cursor (spalten anf + feldnamenlaenge + 3, bildschirmzeile); + feld bearbeiten (zeilen (ausgabezeile). feldnr, + PROC (TEXT CONST, INT CONST, INT CONST) feldteil ausgeben) + END IF . + +evtl unterbrechung : + IF NOT namen ausgeben THEN + TEXT CONST input := getcharety; + IF input <> niltext THEN + push (input); + IF pos (quit zeichen, input) > 0 THEN + zuletzt angezeigter satz := 0; + LEAVE einzelbild ausgeben + END IF + END IF + END IF . + +END PROC einzelbild ausgeben; + +PROC ueberschrift ausgeben (BOOL CONST auch inhalte) : + + satznummer bestimmen; + satznummer in ueberschrift; + cursor (spalten anf, zeilen anf); + IF NOT auch inhalte THEN + outsubtext (ueberschrift, 1, feldnamenlaenge + 3); + LEAVE ueberschrift ausgeben + END IF; + replace (ueberschrift, feldnamenlaenge + 7, auswahlzeichen); + replace (ueberschrift, feldnamenlaenge + 14, markzeichen); + out (ueberschrift); + cursor (spalten anf + breite - 5, zeilen anf); + out (text (erste zeile)) . + +satznummer bestimmen : + TEXT VAR satznr; + satznr := text (satznummer); + IF anzahl koppeldateien > 0 AND NOT auf koppeldatei THEN + satznr CAT "-"; + satznr CAT text (satzkombination) + END IF . + +satznummer in ueberschrift : + replace (ueberschrift, 7, sieben blanks); + replace (ueberschrift, 7, satznr) . + +auswahlzeichen : + IF such version = 0 THEN + fuenf punkte + ELIF satz ausgewaehlt THEN + t such plus + ELSE + t such minus + END IF . + +markzeichen : + IF dateiende THEN + t ende + ELIF markierte saetze = 0 THEN + fuenf punkte + ELIF satz markiert THEN + t mark plus + ELSE + t mark minus + END IF . + +END PROC ueberschrift ausgeben; + +PROC randanzeige (TEXT CONST satz, INT CONST von, bis) : + + IF bis - von >= feldnamenlaenge THEN + outsubtext (satz, von, von + feldnamenlaenge - 1) + ELSE + outsubtext (satz, von, bis); + feldnamenlaenge - bis + von - 1 TIMESOUT blank + END IF + +END PROC randanzeige; + +PROC feldteil ausgeben (TEXT CONST satz, INT CONST von, bis) : + + INT VAR ende; + IF ausgabezeile = anzahl zeilen COR letzte feldzeile THEN + ende := bis + ELSE + ende := von + zeilen (ausgabezeile + 1). anfang - 1 + END IF; + outsubtext (satz, von + zeilen (ausgabezeile). anfang, ende); + IF bis zeilenende THEN + out (cleol) + ELSE + laenge bis zum rand TIMESOUT blank + END IF . + +letzte feldzeile : + zeilen (ausgabezeile + 1). feldnr <> zeilen (ausgabezeile). feldnr . + +laenge bis zum rand : + inhaltsbreite - ende + von + zeilen (ausgabezeile). anfang - 1 . + +END PROC feldteil ausgeben; + +PROC ueberschrift generieren : + + ueberschrift := text (t satz, feldnamenlaenge + 3); + ueberschrift CAT begin mark; + INT VAR i; + INT CONST punktlaenge := breite - length (ueberschrift) - 11; + FOR i FROM 1 UPTO punktlaenge REP + ueberschrift CAT "." + END REP; + ueberschrift CAT t feld; + dateiname in ueberschrift . + +dateiname in ueberschrift : + TEXT VAR dateiname; + IF auf koppeldatei THEN + dateiname := t koppel + ELSE + dateiname := eudas dateiname (1) + END IF; + dateiname := subtext (dateiname, 1, punktlaenge - 20); + dateiname CAT blank; + replace (ueberschrift, feldnamenlaenge + 21, blank); + replace (ueberschrift, feldnamenlaenge + 22, dateiname) . + +END PROC ueberschrift generieren; + + +END PACKET satzanzeige; + diff --git a/app/eudas/4.4/src/eudas.satzzugriffe b/app/eudas/4.4/src/eudas.satzzugriffe new file mode 100644 index 0000000..d3f53f1 --- /dev/null +++ b/app/eudas/4.4/src/eudas.satzzugriffe @@ -0,0 +1,271 @@ +PACKET eudas satzzugriffe + +(*************************************************************************) +(* *) +(* Feldstrukturierung von Texten *) +(* *) +(* Version 03 *) +(* *) +(* Autor: Thomas Berlage *) +(* Stand: 17.04.87 *) +(* *) +(*************************************************************************) + + DEFINES + + SATZ, + := , + satz initialisieren, + felderzahl, + feld lesen, + feld bearbeiten, + feld aendern, + feldindex : + + +LET + maximale felderzahl = 256, + zeigerlaenge = 2; + +LET + blank = " ", + niltext = ""; + +LET + illegale feldnummer = #101# + " ist keine Feldnummer"; + +TEXT VAR + raum fuer ein int := zeigerlaenge * blank; + + +(**************************** Typ SATZ ***********************************) + +TYPE SATZ = TEXT; + +OP := (SATZ VAR links, SATZ CONST rechts) : + + CONCR (links) := CONCR (rechts) + +END OP := ; + + +(************************ Satz initialisieren ****************************) + +PROC satz initialisieren (SATZ VAR satz) : + + satz initialisieren (satz, 0) + +END PROC satz initialisieren; + +PROC satz initialisieren (SATZ VAR satz, INT CONST felder) : + + replace (raum fuer ein int, 1, 2 * felder + 3); + INT VAR i; + CONCR (satz) := niltext; + FOR i FROM 1 UPTO felder + 1 REP + CONCR (satz) CAT raum fuer ein int + END REP + +END PROC satz initialisieren; + + +(*************************** Felderzahl **********************************) + +INT PROC felderzahl (SATZ CONST satz) : + + INT VAR letzter zeiger := (CONCR (satz) ISUB 1) DIV 2; + INT CONST satzende := CONCR (satz) ISUB letzter zeiger; + REP + letzter zeiger DECR 1 + UNTIL letzter zeiger <= 0 COR kein leeres feld END REP; + letzter zeiger . + +kein leeres feld : + (CONCR (satz) ISUB letzter zeiger) <> satzende . + +END PROC felderzahl; + + +(************************** Feld lesen ***********************************) + +PROC feld lesen (SATZ CONST satz, INT CONST feldnr, TEXT VAR inhalt) : + + feldgrenzen bestimmen (CONCR (satz), feldnr); + IF NOT is error THEN + inhalt := subtext (CONCR (satz), feldanfang, feldende) + END IF + +END PROC feld lesen; + +PROC feld bearbeiten (SATZ CONST satz, INT CONST feldnr, + PROC (TEXT CONST, INT CONST, INT CONST) bearbeite) : + + feldgrenzen bestimmen (CONCR (satz), feldnr); + IF NOT is error THEN + bearbeite (CONCR (satz), feldanfang, feldende) + END IF + +END PROC feld bearbeiten; + + +(************************ Feldgrenzen bestimmen **************************) + +INT VAR + feldanfang, + feldende; + +PROC feldgrenzen bestimmen (TEXT CONST satz, INT CONST feldnr) : + + IF illegales feld THEN + errorstop (text (feldnr) + illegale feldnummer) + ELIF vorhandenes feld THEN + feldanfang := satz ISUB feldnr; + feldende := (satz ISUB feldnr + 1) - 1 + ELSE + feldanfang := 1; feldende := 0 + END IF . + +illegales feld : + feldnr <= 0 OR feldnr > maximale felderzahl . + +vorhandenes feld : + feldnr + feldnr < (satz ISUB 1) - 1 . + +END PROC feldgrenzen bestimmen; + + +(*************************** Feld aendern ********************************) + +TEXT VAR puffer; + +PROC feld aendern (SATZ VAR satz, INT CONST feldnr, TEXT CONST inhalt) : + + INT VAR zeigerstelle; + INT CONST satzfelder := ((CONCR (satz) ISUB 1) - 2) DIV 2; + IF normales feld THEN + normal ersetzen + ELSE + errorstop (text (feldnr) + illegale feldnummer) + END IF . + +normales feld : + feldnr > 0 AND feldnr <= maximale felderzahl . + +normal ersetzen : + INT CONST fehlende zeiger := feldnr - satzfelder; + IF fehlende zeiger <= 0 THEN + vorhandenes feld ersetzen + ELIF inhalt <> niltext THEN + neues feld anfuegen + END IF . + +neues feld anfuegen : + INT CONST endezeiger := CONCR (satz) ISUB (satzfelder + 1); + puffer := subtext (CONCR (satz), erstes feld, endezeiger - 1); + CONCR (satz) := subtext (CONCR (satz), 1, satzfelder + satzfelder); + korrigiere zeiger (CONCR (satz), 1, satzfelder, platz fuer zeiger); + neue zeiger anfuegen; + endezeiger anfuegen; + CONCR (satz) CAT puffer; + CONCR (satz) CAT inhalt . + +platz fuer zeiger : + fehlende zeiger + fehlende zeiger . + +neue zeiger anfuegen : + INT CONST neuer zeiger := endezeiger + platz fuer zeiger; + FOR zeigerstelle FROM satzfelder + 1 UPTO feldnr REP + zeiger anfuegen (CONCR (satz), neuer zeiger) + END REP . + +endezeiger anfuegen : + zeiger anfuegen (CONCR (satz), neuer zeiger + length (inhalt)) . + +erstes feld: + CONCR (satz) ISUB 1 . + +vorhandenes feld ersetzen : + INT CONST + feldanfang := CONCR (satz) ISUB feldnr, + naechster feldanfang := CONCR (satz) ISUB (feldnr + 1); + IF feldanfang > length (CONCR (satz)) THEN + optimiere leerfelder + ELSE + ersetze beliebig + END IF . + +optimiere leerfelder : + korrigiere zeiger (CONCR (satz), feldnr + 1, satzfelder + 1, + length (inhalt)); + CONCR (satz) CAT inhalt . + +ersetze beliebig : + puffer := subtext (CONCR (satz), naechster feldanfang); + CONCR (satz) := subtext (CONCR (satz), 1, feldanfang - 1); + korrigiere zeiger (CONCR (satz), feldnr + 1, satzfelder + 1, + laengendifferenz); + CONCR (satz) CAT inhalt; + CONCR (satz) CAT puffer . + +laengendifferenz : + length (inhalt) - feldlaenge . + +feldlaenge : + naechster feldanfang - feldanfang . + +END PROC feld aendern; + +PROC zeiger anfuegen (TEXT VAR satz, INT CONST zeigerwert) : + + replace (raum fuer ein int, 1, zeigerwert); + satz CAT raum fuer ein int + +END PROC zeiger anfuegen; + +PROC korrigiere zeiger (TEXT VAR satz, INT CONST anfang, ende, differenz) : + + INT VAR zeigerstelle; + FOR zeigerstelle FROM anfang UPTO ende REP + replace (satz, zeigerstelle, alter zeiger + differenz) + END REP . + +alter zeiger : + satz ISUB zeigerstelle . + +END PROC korrigiere zeiger; + + +(*************************** 'feldindex' *********************************) + +INT PROC feldindex (SATZ CONST satz, TEXT CONST muster) : + + INT VAR + anfang := (CONCR (satz) ISUB 1) - 1, + zeigerstelle := 1; + + REP + anfang := pos (CONCR (satz), muster, anfang + 1); + IF anfang = 0 THEN + LEAVE feldindex WITH 0 + END IF; + durchsuche zeiger ob feldanfang + UNTIL zeiger zeigt auf anfang CAND naechster zeiger hinter ende END REP; + zeigerstelle . + +durchsuche zeiger ob feldanfang : + WHILE (CONCR (satz) ISUB zeigerstelle) < anfang REP + zeigerstelle INCR 1 + END REP . + +zeiger zeigt auf anfang : + (CONCR (satz) ISUB zeigerstelle) = anfang . + +naechster zeiger hinter ende : + (CONCR (satz) ISUB (zeigerstelle + 1)) = anfang + length (muster) . + +END PROC feldindex; + + +END PACKET eudas satzzugriffe; + diff --git a/app/eudas/4.4/src/eudas.steuerung b/app/eudas/4.4/src/eudas.steuerung new file mode 100644 index 0000000..817a8e7 --- /dev/null +++ b/app/eudas/4.4/src/eudas.steuerung @@ -0,0 +1,2761 @@ +PACKET eudas steuerung + +(*************************************************************************) +(* *) +(* Menuesteuerung von EUDAS *) +(* *) +(* Version 09 *) +(* *) +(* Autor: Thomas Berlage *) +(* Stand: 01.10.87 *) +(* *) +(*************************************************************************) + + DEFINES + + eudas, + + einzelsicherung, + suchen, + aendern, + einfuegen, + prueffehler editieren, + feldstruktur, + + dateiverwaltung, + archivverwaltung, + + edit, + dateinamen anfordern, + ausfuehrung, + einzelausfuehrung : + + +(**************************** Variablen ***********************************) + +LET + file typ = 1003, + eudas typ = 3243; + +LET + niltext = "", + blank = " ", + esc z = ""27"z", + cleop = ""4"", + cleol = ""5""; + + +FILE VAR test file; + +DATASPACE VAR test ds; + +INT VAR + belegter heap, + test version := dateiversion - 1; + +FENSTER VAR + ganz, + links, + rechts, + fuss; + +TEXT VAR + feldpuffer; + +fenster initialisieren (ganz); +fenster initialisieren (links); +fenster initialisieren (rechts); +fenster initialisieren (fuss); +fenstergroesse setzen (ganz, 1, 2, 79, 23); +fenstergroesse setzen (links, 1, 2, 15, 22); +fenstergroesse setzen (rechts, 16, 2, 64, 22); +fenstergroesse setzen (fuss, 1, 24, 79, 1); +dialogfenster (16, 2, 64, 22); +anzeigefenster (16, 2, 64, 23); +uebersichtsfenster (1, 2, 79, 23); + + +(*************************** EUDAS ***************************************) + +TEXT VAR + fusszeile; + +BOOL VAR + eudas schon aktiv := FALSE; + +LET + menue 1 = #1001# + "EUDAS.Öffnen", + menue 2 = #1002# + "EUDAS.Einzelsatz", + menue 3 = #1003# + "EUDAS.Gesamtdatei", + menue 4 = #1004# + "EUDAS.Drucken", + menue 5 = #1005# + "EUDAS.Dateien", + menue 6 = #1006# + "EUDAS.Archiv"; + +LET + kein rekursiver aufruf = #1007# + "EUDAS kann nicht unter EUDAS aufgerufen werden", + suchmuster eingeben = #1008# + "Suchbedingung einstellen", + alle saetze drucken = #1009# + "Alle Saetze drucken", + alle markierten saetze drucken = #1010# + "Alle markierten Satze drucken", + einzelsatz drucken = #1011# + "Aktuellen Satz drucken", + uebersicht wiederholen = #1012# + "Mit neuer Auswahl noch einmal", + akt datei = #1013# + "Akt.Datei: ", + datum doppelpunkt = #1014# + " Datum: "; + + +PROC version ausgeben : + + cursor (30, 6); + out ("EEEEE U U DDDD A SSSS"); + cursor (30, 7); + out ("E U U D D A A S"); + cursor (30, 8); + out ("EEE U U D D AAAAA SSS"); + cursor (30, 9); + out ("E U U D D A A S"); + cursor (30, 10); + out ("EEEEE UUU DDDD A A SSSS"); + cursor (30, 12); + out ("Version 4.4"); + cursor (30, 13); + out ("Stand: 01.10.87"); + cursor (30, 15); + out ("(C) COPYRIGHT:"); + cursor (30, 16); + out ("Thomas Berlage"); + cursor (30, 17); + out ("Software-Systeme") + +END PROC version ausgeben; + +PROC eudas : + + IF aktueller editor > 0 THEN + eudas kurzabfrage + ELIF eudas schon aktiv THEN + errorstop (kein rekursiver aufruf) + ELSE + eudas aufrufen + END IF . + +eudas aufrufen : + page; bildschirm neu; + version ausgeben; + belegter heap := heap size; + fusszeile aufbauen; + disable stop; + eudas schon aktiv := TRUE; + menue anbieten (ROW 6 TEXT : (menue 1, menue 2, menue 3, + menue 4, menue 5, menue 6), + links, TRUE, + PROC (INT CONST, INT CONST) eudas interpreter); + eudas schon aktiv := FALSE; + enable stop; + auf sicherung ueberpruefen; + page; bildschirm neu + +END PROC eudas; + +PROC eudas kurzabfrage : + + TEXT VAR gewaehlte feldnamen; + bild frei; + auf sicherung ueberpruefen; + IF nicht alle gesichert THEN + LEAVE eudas kurzabfrage + END IF; + oeffnen im menue (FALSE); + auf satz (1); + feldauswahl fuer uebersicht (gewaehlte feldnamen); + REP + ggf suchmuster eingeben; + uebersicht (gewaehlte feldnamen, PROC uebersicht hilfe); + bild frei; + saetze drucken + UNTIL nicht noch einmal END REP; + dateien loeschen (FALSE) . + +nicht alle gesichert : + INT VAR datei nr; + FOR datei nr FROM 1 UPTO anzahl dateien REP + IF inhalt veraendert (datei nr) THEN + LEAVE nicht alle gesichert WITH TRUE + END IF + END REP; + FALSE . + +ggf suchmuster eingeben : + IF ja (suchmuster eingeben, "JA/Suchmuster") THEN + suchen; alles neu + END IF . + +saetze drucken : + IF markierte saetze = 0 CAND alle drucken THEN + dateinamen anfordern (name des druckmusters); + einzelausfuehrung (PROC (TEXT CONST) drucke uebersicht, file typ); + ELIF markierte saetze > 0 CAND alle markierten drucken THEN + dateinamen anfordern (name des druckmusters); + einzelausfuehrung (PROC (TEXT CONST) drucke uebersicht, file typ); + markierungen loeschen + ELIF einzelsatz THEN + markierungen loeschen; markierung aendern; + dateinamen anfordern (name des druckmusters); + einzelausfuehrung (PROC (TEXT CONST) drucke uebersicht, file typ); + markierungen loeschen + END IF . + +alle drucken : + ja (alle saetze drucken, "JA/alle Satze") . + +alle markierten drucken : + ja (alle markierten saetze drucken, "JA/alle markierten") . + +einzelsatz : + ja (einzelsatz drucken, "JA/Einzelsatz drucken") . + +nicht noch einmal : + NOT ja (uebersicht wiederholen, "JA/noch einmal") . + +END PROC eudas kurzabfrage; + +PROC bild frei : + + bildschirm neu; + cursor (1, 1); + out (cleop); + cursor (15, 1); + 23 TIMESOUT (""10":"8"") + +END PROC bild frei; + +PROC drucke uebersicht (TEXT CONST dateiname) : + + bild frei fuer uebersetzung; + disable stop; + drucke (dateiname); + uebersetzungsfehler behandeln; + bild frei + +END PROC drucke uebersicht; + +PROC eudas interpreter (INT CONST menuenr, wahl nr) : + + enable stop; + SELECT menuenr OF + CASE 0 : waehlbarkeit setzen + CASE 1 : oeffnen interpreter (wahl nr) + CASE 2 : anzeigen interpreter (wahl nr) + CASE 3 : bearbeiten interpreter (wahl nr) + CASE 4 : drucken interpreter (wahl nr) + CASE 5 : dateiverwaltung (wahl nr) + CASE 6 : archivverwaltung (wahl nr) + END SELECT . + +waehlbarkeit setzen : + IF anzahl dateien = 0 THEN + oeffnen sperre (FALSE); + aendern sperre (FALSE) + ELIF NOT aendern erlaubt THEN + aendern sperre (FALSE) + END IF; + ketten koppeln sperre; + waehlbar (6, 6, ziel ist manager); + waehlbar (6, 9, NOT ziel ist manager); + IF single user THEN + waehlbar (1, 8, FALSE); (* Manager *) + waehlbar (6, 7, FALSE) (* Zielarchiv *) + END IF . + +single user : + FALSE . + +END PROC eudas interpreter; + +PROC oeffnen sperre (BOOL CONST wie) : + + INT VAR i; + waehlbar (1, 4, wie); + waehlbar (1, 5, wie); + waehlbar (1, 7, wie); + FOR i FROM 1 UPTO 11 REP + waehlbar (2, i, wie) + END REP; + waehlbar (3, 1, wie); + waehlbar (3, 4, wie); + waehlbar (3, 6, wie); + waehlbar (4, 1, wie) + +END PROC oeffnen sperre; + +PROC ketten koppeln sperre : + + BOOL VAR wie := anzahl dateien = 1 AND aendern erlaubt; + waehlbar (1, 6, wie); + waehlbar (3, 5, wie); + wie := anzahl dateien > 0 AND anzahl dateien < 10 AND NOT auf koppeldatei; + waehlbar (1, 2, wie); + waehlbar (1, 3, wie) + +END PROC ketten koppeln sperre; + +PROC aendern sperre (BOOL CONST wie) : + + INT VAR i; + FOR i FROM 7 UPTO 10 REP + waehlbar (2, i, wie) + END REP; + waehlbar (3, 2, wie); + waehlbar (3, 3, wie) + +END PROC aendern sperre; + +PROC fusszeile aufbauen : + + fenster veraendert (fuss); + fusszeile := ""6""23""0""; + fusszeile CAT akt datei; + IF anzahl dateien > 0 THEN + fusszeile CAT """"; + fusszeile CAT eudas dateiname (1); + fusszeile CAT """" + END IF; + IF anzahl dateien > 1 THEN + fusszeile CAT " .. " + END IF; + fusszeile CAT ""5""6""23""; + fusszeile CAT code (79 - length (date) - length (datum doppelpunkt)); + fusszeile CAT datum doppelpunkt; + fusszeile CAT date + +END PROC fusszeile aufbauen; + +PROC fusszeile ausgeben (TEXT CONST prompt, inhalt) : + + BOOL VAR fuss veraendert; + fensterzugriff (fuss, fuss veraendert); + IF fuss veraendert THEN + out (fusszeile); + cursor (35, 24); + out (prompt); + IF inhalt <> niltext THEN + out (""""); outsubtext (inhalt, 1, 22 - length (prompt)); out (""" ") + END IF + END IF + +END PROC fusszeile ausgeben; + + +(**************************** Menue 'Oeffnen' *****************************) + +THESAURUS VAR zusaetzliche namen := empty thesaurus; + +BOOL VAR + nach aendern fragen, + multi user manager eingestellt := FALSE; + +TASK VAR multi user manager; + +TEXT VAR + manager taskname := niltext, + herkunftszeichen := niltext; + +LET + p manager = #1015# + " Manager: ", + keine sicherung noetig = #1017# + "Keine Sicherung noetig.", + arbeitskopien loeschen = #1018# + "Interne Arbeitskopien loeschen", + t arbeitskopie = #1019# + "Arbeitskopie ", + t unveraendert = #1020# + " unveraendert.", + t veraendert = #1021# + " veraendert! Sichern", + alte version ueberschreiben = #1022# + "Alte Version ueberschreiben", + unter dem namen = #1023# + "Sondern unter dem Namen:", + ueberschreiben = #1024# + " ueberschreiben", + sortierung wiederherstellen = #1025# + "Datei wieder sortieren", + t notizen ansehen = #1026# + "Notizen", + name task = #1027# + "Name Managertask:", + task existiert nicht = #1028# + "Task existiert nicht !", + wollen sie etwas veraendern = #1029# + "Wollen Sie etwas veraendern (eine Arbeitskopie anlegen)", + markierungen geloescht = #1030# + "Alle Markierungen gelöscht.", + t pruefbedingungen = #1032# + "Pruefbedingungen", + felder aendern = #1033# + "Feldnamen oder Feldtypen aendern", + t feldnamen anfuegen = #1034# + "Feldnamen anfuegen", + neuer feldname = #1035# + "Neuer Feldname:", + neuer typ = #1036# + "Neuer Typ (TEXT,DIN,ZAHL,DATUM):", + neue feldnamen eingeben = #1037# + "Neue Feldnamen", + id text = #1038# + "TEXT", + id din = #1039# + "DIN", + id zahl = #1040# + "ZAHL", + id datum = #1041# + "DATUM", + alte feldreihenfolge aendern = #1042# + "Alte Feldreihenfolge aendern", + speicherengpass = #1043# + ""7"ACHTUNG: System voll, Dateien loeschen!"; + + +PROC oeffnen interpreter (INT CONST wahl nr) : + + SELECT wahl nr OF + CASE 0 : auf geschlossene datei pruefen + CASE 1 : neue datei oeffnen + CASE 2 : datei ketten + CASE 3 : datei koppeln + CASE 4 : aktuelle datei sichern + CASE 5 : notizen editieren + CASE 6 : feldstruktur aendern + CASE 7 : pruefbedingungen aendern + CASE 8 : multi user manager einstellen + OTHERWISE ggf dialogfenster loeschen + END SELECT; + fusszeile ausgeben (p manager, manager taskname); + storage kontrollieren; + heap kontrollieren . + +auf geschlossene datei pruefen : + IF anzahl dateien = 0 THEN + eudas interpreter (0, 0) + END IF . + +neue datei oeffnen : + auf sicherung ueberpruefen; + oeffnen im menue (TRUE); + push (2) . + +datei ketten : + disable stop; + manager pre; + ausfuehrung (PROC (TEXT CONST) ketten, eudas typ); + manager post; + enable stop; + ketten koppeln sperre . + +datei koppeln : + disable stop; + manager pre; + ausfuehrung (PROC (TEXT CONST) koppeln, eudas typ); + manager post; + enable stop; + ketten koppeln sperre . + +aktuelle datei sichern : + IF aendern erlaubt THEN + einzeldateien abfragen + ELSE + dialog; out (keine sicherung noetig); + dateien aus manager loeschen + END IF; + sperre setzen . + +einzeldateien abfragen : + INT VAR datei nr; + FOR datei nr FROM 1 UPTO anzahl dateien REP + einzelsicherung (datei nr) + END REP; + IF ja (arbeitskopien loeschen, "JA/Dateien loeschen") THEN + dateien aus manager zuruecksichern; + dateien loeschen (TRUE) + END IF . + +sperre setzen : + IF anzahl dateien = 0 THEN + oeffnen sperre (FALSE); + aendern sperre (FALSE) + END IF; + ketten koppeln sperre; + fusszeile aufbauen . + +dateien aus manager loeschen : + INT CONST vorhandene dateien := anzahl dateien; + dateien loeschen (FALSE); + FOR datei nr FROM 1 UPTO vorhandene dateien REP + IF manager herkunft (datei nr) THEN + loeschen (eudas dateiname (datei nr)) + END IF + END REP . + +notizen editieren : + notizen ansehen; + dialogfenster loeschen . + +feldstruktur aendern : + zugriff (PROC (EUDAT VAR) feldstruktur) . + +pruefbedingungen aendern : + pruefbedingungen; + dialogfenster loeschen . + +multi user manager einstellen : + manager taskname := ""; + fenster veraendert (fuss); + editget (name task, manager taskname, "", "GET/multi task"); + IF manager taskname = "" THEN + multi user manager eingestellt := FALSE + ELIF exists (/manager taskname) THEN + multi user manager := task (manager taskname); + multi user manager eingestellt := TRUE + ELSE + multi user manager eingestellt := FALSE; + manager taskname := ""; + errorstop (task existiert nicht) + END IF . + +heap kontrollieren : + IF heap size - belegter heap > 4 THEN + collect heap garbage; + belegter heap := heap size + END IF . + +ggf dialogfenster loeschen : + IF wahl nr = -1 THEN + dialogfenster loeschen; + fenster veraendert (fuss); + LEAVE oeffnen interpreter + END IF . + +END PROC oeffnen interpreter; + +PROC auf sicherung ueberpruefen : + + BOOL VAR notwendig := FALSE; + IF aendern erlaubt THEN + wirklich pruefen + END IF; + IF notwendig THEN dialog (* Leerzeile *) END IF . + +wirklich pruefen : + INT VAR datei nr; + FOR datei nr FROM 1 UPTO anzahl dateien REP + IF inhalt veraendert (datei nr) THEN + einzelsicherung (datei nr); + notwendig := TRUE; + ggf last param korrigieren + END IF + END REP . + +ggf last param korrigieren : + IF datei nr = 1 CAND std = eudas dateiname (1) THEN + last param (niltext) + END IF . + +END PROC auf sicherung ueberpruefen; + +PROC einzelsicherung (INT CONST datei nr) : + + frage zusammenbauen; + IF inhalt veraendert (datei nr) THEN + IF ja (frage, "JA/sichere") THEN + sicherung durchfuehren + END IF + ELSE + dialog; out (frage) + END IF . + +frage zusammenbauen : + TEXT VAR frage := t arbeitskopie; + frage CAT textdarstellung (eudas dateiname (datei nr)); + IF inhalt veraendert (datei nr) THEN + frage CAT t veraendert + ELSE + frage CAT t unveraendert + END IF . + +sicherung durchfuehren : + TEXT VAR name := eudas dateiname (datei nr); + IF ja (alte version ueberschreiben, "JA/alte version") THEN + forget (name, quiet) + ELIF manager herkunft (datei nr) THEN + errorstop (niltext) + ELSE + neuen namen erfragen + END IF; + sichere (datei nr, name); + eventuell sortierung wiederherstellen . + +neuen namen erfragen : + edit get (unter dem namen, name, "", "GET/Sicherungsname"); + IF exists (name) THEN + eventuell ueberschreiben + END IF . + +eventuell ueberschreiben : + IF ja (textdarstellung (name) + ueberschreiben, "JA/ueber") THEN + forget (name, quiet) + ELSE + einzelsicherung (datei nr); + LEAVE einzelsicherung + END IF . + +eventuell sortierung wiederherstellen : + EUDAT VAR eudat; + oeffne (eudat, name); + IF war sortiert CAND soll sortiert werden THEN + bitte warten; + sortiere (eudat) + END IF . + +war sortiert : + sortierreihenfolge (eudat) <> niltext CAND unsortierte saetze (eudat) > 0 . + +soll sortiert werden : + ja (sortierung wiederherstellen, "JA/Sicherungssortierung") . + +END PROC einzelsicherung; + +PROC oeffnen im menue (BOOL CONST aendern fragen) : + + IF aendern erlaubt THEN + dateien aus manager zuruecksichern + END IF; + dateien loeschen (TRUE); + oeffnen sperre (FALSE); + aendern sperre (FALSE); + forget (test ds); + disable stop; + manager pre; + nach aendern fragen := aendern fragen; + einzelausfuehrung (PROC (TEXT CONST) oeffnen, eudas typ); + manager post; + ketten koppeln sperre; + enable stop; + IF anzahl dateien > 0 THEN + oeffnen sperre (TRUE); + aendern sperre (aendern erlaubt) + END IF + +END PROC oeffnen im menue; + +PROC manager pre : + + IF multi user manager eingestellt THEN + zusaetzliche namen := ALL multi user manager + END IF + +END PROC manager pre; + +PROC manager post : + + zusaetzliche namen := empty thesaurus; + fusszeile aufbauen + +END PROC manager post; + +PROC dateien aus manager zuruecksichern : + + INT VAR datei nr; + FOR datei nr FROM 1 UPTO anzahl dateien REP + IF manager herkunft (datei nr) THEN + save oder free an manager + END IF + END REP . + +save oder free an manager : + IF in manager ueberschreiben THEN + disable stop; + set command dialogue false; + save (eudas dateiname (datei nr), multi user manager); + reset command dialogue; + enable stop; + forget (eudas dateiname (datei nr), quiet) + ELSE + free (eudas dateiname (datei nr), multi user manager) + END IF; + herkunft eintragen (datei nr, FALSE) . + +in manager ueberschreiben : + exists (eudas dateiname (datei nr)) . + +END PROC dateien aus manager zuruecksichern; + +PROC multi datei loeschen : + + IF manager herkunft (anzahl dateien) AND aendern erlaubt THEN + forget (eudas dateiname (anzahl dateien), quiet) + END IF + +END PROC multi datei loeschen; + +PROC oeffnen (TEXT CONST dateiname) : + + BOOL VAR auch aendern; + eventuell neu einrichten; + oeffne (dateiname, auch aendern); + multi datei loeschen . + +eventuell neu einrichten : + IF datei existiert nicht AND nach aendern fragen THEN + frage ob einrichten (dateiname); + EUDAT VAR eudat; + oeffne (eudat, dateiname); + feldstruktur (eudat); + auch aendern := TRUE + ELSE + auch aendern := + nach aendern fragen CAND ja (wollen sie etwas veraendern, "JA/oeffne"); + aus manager besorgen (dateiname, auch aendern) + END IF . + +datei existiert nicht : + NOT exists (dateiname) AND NOT (zusaetzliche namen CONTAINS dateiname) . + +END PROC oeffnen; + +PROC ketten (TEXT CONST dateiname) : + + aus manager besorgen (dateiname, aendern erlaubt); + kette (dateiname); + multi datei loeschen + +END PROC ketten; + +PROC koppeln (TEXT CONST dateiname) : + + aus manager besorgen (dateiname, aendern erlaubt); + kopple (dateiname); + multi datei loeschen + +END PROC koppeln; + +PROC aus manager besorgen (TEXT CONST dateiname, BOOL CONST mit lock) : + + BOOL VAR herkunft := FALSE; + IF multi user manager eingestellt THEN + manager abfragen + END IF; + herkunft eintragen (anzahl dateien + 1, herkunft) . + +manager abfragen : + IF (zusaetzliche namen CONTAINS dateiname) CAND + (NOT exists (dateiname) COR eigene datei ueberschreiben) THEN + IF mit lock THEN + lock (dateiname, multi user manager) + END IF; + forget (dateiname, quiet); + fetch (dateiname, multi user manager); + herkunft := TRUE + END IF . + +eigene datei ueberschreiben : + ja (textdarstellung (dateiname) + t im system ueberschreiben, "JA/fetch") . + +END PROC aus manager besorgen; + +PROC herkunft eintragen (INT CONST dateiindex, BOOL CONST herkunft) : + + WHILE length (herkunftszeichen) < dateiindex REP + herkunftszeichen CAT blank + END REP; + replace (herkunftszeichen, dateiindex, entsprechendes zeichen) . + +entsprechendes zeichen : + IF herkunft THEN + "-" + ELSE + blank + END IF . + +END PROC herkunft eintragen; + +BOOL PROC manager herkunft (INT CONST dateiindex) : + + IF length (herkunftszeichen) < dateiindex THEN + FALSE + ELSE + (herkunftszeichen SUB dateiindex) <> blank + END IF + +END PROC manager herkunft; + +PROC notizen ansehen : + + notizen lesen (3, feldpuffer); + DATASPACE VAR ds := nilspace; + FILE VAR f := sequential file (output, ds); + disable stop; + headline (f, t notizen ansehen); + notizen anbieten (f, feldpuffer, ganz, "EDIT/Notizen"); + forget (ds); + enable stop; + IF aendern erlaubt THEN + notizen aendern (3, feldpuffer) + END IF + +END PROC notizen ansehen; + +PROC notizen anbieten (FILE VAR f, TEXT VAR puffer, + FENSTER CONST edit fenster, TEXT CONST hilfsname) : + + LET trennzeichen = "#-#"; + enable stop; + notizen in datei; + datei editieren; + notizen aus datei . + +notizen in datei : + INT VAR + von := 1, + bis; + REP + bis := pos (puffer, trennzeichen, von); + IF bis = 0 THEN + putline (f, subtext (puffer, von)) + ELSE + putline (f, subtext (puffer, von, bis - 1)) + END IF; + von := bis + 3 + UNTIL bis = 0 OR von > length (puffer) END REP . + +datei editieren : + modify (f); + edit (f, edit fenster, hilfsname, TRUE) . + +notizen aus datei : + TEXT VAR zeile; + puffer := niltext; + input (f); + WHILE NOT eof (f) REP + getline (f, zeile); + blank entfernen; + puffer CAT zeile; + puffer CAT trennzeichen + END REP . + +blank entfernen : + IF (zeile SUB length (zeile)) = blank THEN + zeile := subtext (zeile, 1, length (zeile) - 1) + END IF . + +END PROC notizen anbieten; + +PROC feldstruktur (EUDAT VAR eudat) : + + SATZ VAR satz; + feldnamen lesen (eudat, satz); + IF feldnamen anfuegen THEN + feldnamen editieren + END IF; + IF ja (felder aendern, "JA/Feldaendern") THEN + auswahl zu aendernder felder + END IF . + +feldnamen anfuegen : + IF felderzahl (satz) > 0 THEN + ja (t feldnamen anfuegen, "JA/feldnamen") + ELSE + TRUE + END IF . + +feldnamen editieren : + DATASPACE VAR ds := nilspace; + FILE VAR f := sequential file (output, ds); + disable stop; + feldnamen anbieten (f, satz); + forget (ds); + enable stop; + feldnamen aendern (eudat, satz) . + +auswahl zu aendernder felder : + feldtypen dazuschreiben; + auswahl anbieten ("EUDAS-Felder", rechts, "AUSWAHL/Felder", + PROC (TEXT VAR, INT CONST) aus sammel); + INT VAR feldnr := 1; + WHILE wahl (feldnr) > 0 REP + ein feld aendern; + feldnr INCR 1 + END REP; + feldnamen aendern (eudat, satz) . + +feldtypen dazuschreiben : + satz initialisieren (sammel); + FOR feldnr FROM 1 UPTO felderzahl (satz) REP + feld lesen (satz, feldnr, feldpuffer); + feld aendern (sammel, feldnr, info + textdarstellung (feldpuffer)) + END REP . + +info : + "(" + typtext (feldinfo (eudat, feldnr)) + ") " . + +ein feld aendern : + TEXT VAR feldname; + feld lesen (satz, wahl (feldnr), feldname); + editget (neuer feldname, feldname, "", "GET/feldname"); + feld aendern (satz, wahl (feldnr), feldname); + TEXT VAR typ := typtext (feldinfo (eudat, wahl (feldnr))); + REP + editget (neuer typ, typ, "", "GET/feldtyp") + UNTIL texttyp (typ) >= -1 END REP; + feldinfo (eudat, wahl (feldnr), texttyp (typ)) . + +END PROC feldstruktur; + +PROC pruefbedingungen : + + enable stop; + DATASPACE VAR ds := nilspace; + FILE VAR f := sequential file (output, ds); + headline (f, t pruefbedingungen); + notizen lesen (1, feldpuffer); + disable stop; + notizen anbieten (f, feldpuffer, ganz, "EDIT/Pruefbed"); + forget (ds); + enable stop; + IF aendern erlaubt THEN + notizen aendern (1, feldpuffer) + END IF . + +END PROC pruefbedingungen; + +PROC feldnamen anbieten (FILE VAR f, SATZ VAR satz) : + + enable stop; + neue namen editieren; + neue namen zurueckschreiben . + +neue namen editieren : + modify (f); + headline (f, neue feldnamen eingeben); + edit (f, rechts, "EDIT/Feldnamen", TRUE) . + +neue namen zurueckschreiben : + INT VAR feldnr := felderzahl (satz); + input (f); + WHILE NOT eof (f) REP + getline (f, feldpuffer); + blank entfernen; + feldnr INCR 1; + feld aendern (satz, feldnr, feldpuffer) + END REP . + +blank entfernen : + IF (feldpuffer SUB length (feldpuffer)) = blank THEN + feldpuffer := subtext (feldpuffer, 1, length (feldpuffer) - 1) + END IF . + +END PROC feldnamen anbieten; + +TEXT PROC typtext (INT CONST typ) : + + SELECT typ + 1 OF + CASE 0 : id text + CASE 1 : id din + CASE 2 : id zahl + CASE 3 : id datum + OTHERWISE niltext + END SELECT + +END PROC typtext; + +INT PROC texttyp (TEXT CONST t) : + + IF t = id text THEN -1 + ELIF t = id din THEN 0 + ELIF t = id zahl THEN 1 + ELIF t = id datum THEN 2 + ELSE -2 + END IF + +END PROC texttyp; + +PROC storage kontrollieren : + + INT VAR size, used; + storage (size, used); + IF used > size THEN + neuer dialog; dialog; + out (speicherengpass) + END IF + +END PROC storage kontrollieren; + + +(************************* Menue 'Einzelsatz' *****************************) + +BOOL VAR + satz leer, + umgeschaltet aus einfuegen := FALSE, + umgeschaltet aus aendern := FALSE; + +LET + aendern status = #1044# +"SATZ AENDERN: Abbruch: ESC h Beenden: ESC q Hilfe: ESC ?", + einfuegen status = #1045# +"SATZ EINFUEGEN: Abbruch: ESC h Beenden: ESC q Hilfe: ESC ?", + suchen status = #1046# +"SUCHMUSTER EINGEBEN: Abbruch: ESC h Beenden: ESC q Hilfe: ESC ?", + umschalten auf = #1047# + "Umschalten auf Koppeldatei ", + koppelfelder uebernehmen = #1048# + "Koppelfelder uebernehmen", + ungueltige satznummer = #1049# + "Ungueltige Satznummer", + neue satznummer = #1050# + "Neue Satznummer:", + t bitte warten = #1051# + " Bitte warten.. ", + wzk = #1052# + "wzK", + wz = #1053# + "wz"; + +LET + blanks unten links = ""6""23""0" :", + blanks unten ganz = ""6""23""0" :"5""; + + +PROC anzeigen interpreter (INT CONST wahl nr) : + + SELECT wahl nr OF + CASE 0 : anzeige einschalten + CASE 1 : einen satz weiter + CASE 2 : einen satz zurueck + CASE 3 : direkt auf satz + CASE 4 : saetze auswaehlen + CASE 5 : auswahlbedingung loeschen + CASE 6 : aktuelle markierung aendern + CASE 7 : neuen satz einfuegen + CASE 8 : aktuellen satz aendern + CASE 9 : einzelsatz tragen + CASE 10: einzelsatz holen + CASE 11: felder auswaehlen + CASE 12: esc oben + CASE 13: esc unten + CASE 14: esc 1 + CASE 15: esc 9 + CASE 16: esc k + OTHERWISE anzeige update + END SELECT; + storage kontrollieren . + +anzeige einschalten : + exit zeichen (wz) . + +einen satz weiter : + bitte warten; + weiter (2); + bild ausgeben (FALSE) . + +einen satz zurueck : + bitte warten; + zurueck (2); + bild ausgeben (FALSE) . + +saetze auswaehlen : + suchen; + bild ausgeben (TRUE) . + +auswahlbedingung loeschen : + suchbedingung loeschen; + bild ausgeben (FALSE) . + +direkt auf satz : + TEXT VAR nr := niltext; + fusszeile ganz loeschen; + editget (neue satznummer, nr, "", "GET/auf satz"); + INT CONST ziel := int (nr); + IF nr = niltext THEN + bild ausgeben (FALSE) + ELIF last conversion ok THEN + auf satz (ziel); + bild ausgeben (FALSE) + ELSE + errorstop (ungueltige satznummer) + END IF . + +neuen satz einfuegen : + einfuegen; + bild ausgeben (TRUE) . + +aktuellen satz aendern : + aendern; + bild ausgeben (TRUE) . + +aktuelle markierung aendern : + markierung aendern; + bild ausgeben (FALSE) . + +einzelsatz tragen : + last param darf nicht geoeffnet sein; + fusszeile ganz loeschen; + dateinamen anfordern (name der zieldatei); + einzelausfuehrung (PROC (TEXT CONST) trage satz und frage, eudas typ); + bild ausgeben (TRUE) . + +einzelsatz holen : + last param darf nicht geoeffnet sein; + fusszeile ganz loeschen; + dateinamen anfordern (name der quelldatei); + einzelausfuehrung (PROC (TEXT CONST) hole satz, eudas typ); + bild ausgeben (TRUE) . + +felder auswaehlen : + TEXT VAR wahlvektor; + fusszeile ganz loeschen; + felder waehlen lassen (wahlvektor); + IF wahlvektor <> niltext THEN + feldauswahl (wahlvektor) + END IF; + bild ausgeben (TRUE) . + +esc oben : + rollcursor; + rollen (-23); + IF anzahl dateien > 0 THEN + bild ausgeben (FALSE) + END IF . + +esc unten : + rollcursor; + rollen (23); + IF anzahl dateien > 0 THEN + bild ausgeben (FALSE) + END IF . + +esc 1 : + rollcursor; + rollen (-9999); + IF anzahl dateien > 0 THEN + bild ausgeben (FALSE) + END IF . + +esc 9 : + rollcursor; + rollen (9999); + IF anzahl dateien > 0 THEN + bild ausgeben (FALSE) + END IF . + +esc k : + IF auf koppeldatei THEN + zurueckschalten + ELSE + auf koppeldatei umschalten + END IF; + IF anzahl dateien > 0 THEN + bild ausgeben (TRUE) + END IF . + +zurueckschalten : + IF (umgeschaltet aus aendern OR umgeschaltet aus einfuegen) THEN + fragen ob koppelfelder uebernehmen; + wieder in alte operation + ELSE + auf koppeldatei (0) + END IF; + ketten koppeln sperre . + +fragen ob koppelfelder uebernehmen : + fusszeile ganz loeschen; + IF NOT dateiende CAND ja (koppelfelder uebernehmen, "JA/uebernehmen") THEN + auf koppeldatei (1) + ELSE + auf koppeldatei (0) + END IF . + +wieder in alte operation : + umgeschaltet aus einfuegen := FALSE; + IF umgeschaltet aus aendern THEN + umgeschaltet aus aendern := FALSE; + aendern + ELSE + einfuegen intern (TRUE) + END IF . + +anzeige update : + IF wahl nr = -2 THEN + IF anzahl dateien > 0 THEN + fusszeile links loeschen; + bild ausgeben (FALSE) + ELSE + fusszeile ganz loeschen + END IF + ELSE + dialogfenster loeschen; + fenster veraendert (fuss) + END IF . + +fusszeile links loeschen : + out (blanks unten links) . + +fusszeile ganz loeschen : + out (blanks unten ganz) . + +END PROC anzeigen interpreter; + +PROC suchen : + + disable stop; + exit zeichen (""); + status anzeigen (suchen status); + suchen (PROC suchen hilfe); + exit zeichen (wz) + +END PROC suchen; + +PROC suchen hilfe : + + hilfe anbieten ("EDIT/Suchen", rechts) + +END PROC suchen hilfe; + +PROC bitte warten : + + status anzeigen (t bitte warten) + +END PROC bitte warten; + +PROC einfuegen : + + einfuegen intern (FALSE) + +END PROC einfuegen; + +PROC einfuegen intern (BOOL CONST nach umschalten) : + + BOOL VAR weiter aendern := nach umschalten; + exit zeichen setzen; + REP + status anzeigen (einfuegen status); + IF weiter aendern THEN + aendern (PROC einfuegen hilfe); + weiter aendern := FALSE + ELSE + einfuegen (PROC einfuegen hilfe) + END IF; + satz untersuchen; + exit zeichen bei einfuegen behandeln + END REP . + +exit zeichen bei einfuegen behandeln : + SELECT pos (wzk, exit durch) OF + CASE 0 : IF satz leer THEN + satz loeschen + END IF; + LEAVE einfuegen intern + CASE 1 : IF satz leer THEN + satz loeschen + ELSE + bitte warten; weiter (2) + END IF + CASE 2 : IF satz leer THEN + satz loeschen + ELSE + bitte warten; zurueck (2) + END IF + CASE 3 : auf koppeldatei umschalten; + IF auf koppeldatei THEN + umgeschaltet aus einfuegen := TRUE; + LEAVE einfuegen intern + END IF; + weiter aendern := TRUE + END SELECT . + +END PROC einfuegen intern; + +PROC einfuegen hilfe : + + hilfe anbieten ("EDIT/Einfuegen", rechts) + +END PROC einfuegen hilfe; + +PROC exit zeichen setzen : + + IF anzahl koppeldateien > 0 AND NOT auf koppeldatei THEN + exit zeichen (wzk) + ELSE + exit zeichen (wz) + END IF + +END PROC exit zeichen setzen; + +PROC aendern : + + exit zeichen setzen; + kommando auf taste legen ("F", "prueffehler editieren"); + REP + status anzeigen (aendern status); + aendern (PROC aendern hilfe); + satz untersuchen; + exit zeichen bei aendern behandeln + END REP . + +exit zeichen bei aendern behandeln : + SELECT pos (wzk, exit durch) OF + CASE 0 : IF satz leer THEN + satz loeschen + END IF; + LEAVE aendern + CASE 1 : IF satz leer THEN + satz loeschen + ELSE + bitte warten; weiter (2) + END IF + CASE 2 : IF satz leer THEN + satz loeschen + ELSE + bitte warten; zurueck (2) + END IF + CASE 3 : auf koppeldatei umschalten; + IF auf koppeldatei THEN + umgeschaltet aus aendern := TRUE; + LEAVE aendern + END IF + END SELECT . + +END PROC aendern; + +PROC aendern hilfe : + + hilfe anbieten ("EDIT/Aendern", rechts) + +END PROC aendern hilfe; + +PROC prueffehler editieren : + + IF test version = datei version THEN + modify (test file); + edit (test file) + END IF + +END PROC prueffehler editieren; + +PROC auf koppeldatei umschalten : + + INT VAR datei nr := folgedatei (0); + WHILE datei nr > 0 REP + out (blanks unten ganz); + IF auf diese datei schalten THEN + auf koppeldatei (datei nr); + ketten koppeln sperre; + LEAVE auf koppeldatei umschalten + END IF; + datei nr := folgedatei (datei nr) + END REP . + +auf diese datei schalten : + ja (umschalten auf + textdarstellung (eudas dateiname (datei nr)), + "JA/umschalten") . + +END PROC auf koppeldatei umschalten; + +PROC zeilenrest ausgeben (TEXT CONST zeile, INT CONST dummy) : + + outsubtext (zeile, anfang); out (cleol) . + +anfang : + pos (zeile, blank, 6) + 1 + dummy - dummy . + +END PROC zeilenrest ausgeben; + +PROC satz untersuchen : + + feld bearbeiten (1, PROC (TEXT CONST, INT CONST, INT CONST) ob leer) + +END PROC satz untersuchen; + +PROC ob leer (TEXT CONST satz, INT CONST von, bis) : + + satz leer := von < 3 OR von > length (satz) + bis - bis + +END PROC ob leer; + +PROC rollcursor : + + cursor (15, 24) + +END PROC rollcursor; + +PROC trage satz und frage (TEXT CONST dateiname) : + + IF exists (dateiname) THEN + teste auf offen + ELSE + frage ob einrichten (dateiname) + END IF; + bitte warten; + trage satz (dateiname) . + +teste auf offen : + IF index der arbeitskopie (dateiname) <> 0 THEN + errorstop (nicht in offene datei) + END IF . + +END PROC trage satz und frage; + +PROC felder waehlen lassen (TEXT VAR wahlvektor) : + + auswahl anbieten ("EUDAS-Anzeigefelder", rechts, "AUSWAHL/Anzeigefelder", + PROC (TEXT VAR, INT CONST) gib namen); + wahlvektor := niltext; + INT VAR nr := 1; + WHILE wahl (nr) > 0 REP + wahlvektor CAT code (wahl (nr)); + nr INCR 1 + END REP + +END PROC felder waehlen lassen; + + +(************************* Menue 'Gesamtdatei' ***************************) + +LET + felder auswaehlen = #1054# + "Angezeigte Felder auswaehlen", + aufsteigend sortieren = #1055# + " aufsteigend sortieren"; + +DATASPACE VAR + kopier ds; + + +PROC bearbeiten interpreter (INT CONST wahl nr) : + + SELECT wahl nr OF + CASE 1 : saetze kopieren + CASE 2 : saetze tragen + CASE 3 : nach vorschrift aendern + CASE 4 : uebersicht ausgeben + CASE 5 : datei sortieren + CASE 6 : alle markierungen loeschen + OTHERWISE ggf dialogfenster loeschen + END SELECT; + storage kontrollieren . + +saetze tragen : + last param darf nicht geoeffnet sein; + dateinamen anfordern (name der zieldatei); + einzelausfuehrung (PROC (TEXT CONST) trage saetze, eudas typ) . + +saetze kopieren : + last param darf nicht geoeffnet sein; + dateinamen anfordern (name der zieldatei); + einzelausfuehrung (PROC (TEXT CONST) kopiere saetze, eudas typ); + dialogfenster loeschen; + fusszeile ausgeben ("", "") . + +nach vorschrift aendern : + dateinamen anfordern (name der verarbeitungsvorschrift); + ausfuehrung (PROC (TEXT CONST) verarbeite mit edit, file typ); + dialogfenster loeschen; + fusszeile ausgeben ("", "") . + +uebersicht ausgeben : + TEXT VAR uebersichtsauswahl; + feldauswahl fuer uebersicht (uebersichtsauswahl); + uebersicht (uebersichtsauswahl, PROC uebersicht hilfe); + dialogfenster loeschen; + fusszeile ausgeben ("", "") . + +datei sortieren : + zugriff (PROC (EUDAT VAR) einzelsortiere) . + +alle markierungen loeschen : + markierungen loeschen; + dialog; out (markierungen geloescht) . + +ggf dialogfenster loeschen : + IF wahl nr = -1 THEN + dialogfenster loeschen; + fenster veraendert (fuss) + ELIF wahl nr = -2 THEN + fusszeile ausgeben ("", "") + END IF . + +END PROC bearbeiten interpreter; + +PROC last param darf nicht geoeffnet sein : + + IF index der arbeitskopie (std) <> 0 THEN + last param (niltext) + END IF + +END PROC last param darf nicht geoeffnet sein; + +PROC trage saetze (TEXT CONST dateiname) : + + BOOL VAR mit test; + IF exists (dateiname) THEN + teste auf offen; + frage ob testen + ELSE + frage ob einrichten (dateiname); + mit test := FALSE + END IF; + BOOL CONST mit sortieren := ja (sortierfrage, "JA/sortieren"); + bitte warten; + ggf datei initialisieren; + trage (dateiname, test file, mit test); + fehlerzahl ausgeben; + IF mit sortieren THEN + EUDAT VAR eudat; + oeffne (eudat, dateiname); + sortiere (eudat) + END IF . + +teste auf offen : + IF index der arbeitskopie (dateiname) <> 0 THEN + errorstop (nicht in offene datei) + END IF . + +frage ob testen : + mit test := ja (pruefbedingungen testen, "JA/testen") . + +ggf datei initialisieren : + IF mit test THEN + forget (test ds); + test ds := nilspace; + test file := sequential file (output, test ds); + test version := datei version + ELSE + forget (test ds); + test version := datei version - 1 + END IF . + +fehlerzahl ausgeben : + IF mit test CAND lines (test file) > 0 THEN + dialog; put (lines (test file)); + put (prueffehler festgestellt) + END IF . + +END PROC trage saetze; + +PROC verarbeite mit edit (TEXT CONST dateiname) : + + IF NOT exists (dateiname) THEN + edit unten (dateiname, "EDIT/Verarbeite") + END IF; + bild frei fuer uebersetzung; + FILE VAR f := sequential file (input, dateiname); + disable stop; + verarbeite (f); + uebersetzungsfehler behandeln . + +END PROC verarbeite mit edit; + +PROC feldauswahl fuer uebersicht (TEXT VAR uebersichtsauswahl) : + + uebersichtsauswahl := niltext; + IF ja (felder auswaehlen, "JA/Ub.Felder") THEN + felder waehlen lassen (uebersichtsauswahl) + END IF + +END PROC feldauswahl fuer uebersicht; + +PROC uebersicht hilfe : + + hilfe anbieten ("UEBERSICHT", ganz) + +END PROC uebersicht hilfe; + +PROC kopiere saetze (TEXT CONST dateiname) : + + disable stop; + kopier ds := nilspace; + kopiere saetze intern (dateiname); + forget (kopier ds) + +END PROC kopiere saetze; + +PROC kopiere saetze intern (TEXT CONST dateiname) : + + TEXT VAR mustername := ""; + FILE VAR f; + EUDAT VAR eudat; + BOOL VAR mit sortieren := FALSE; + + enable stop; + IF exists (dateiname) THEN + teste auf offen und sortieren + ELSE + frage ob einrichten (dateiname) + END IF; + editget (name kopiermuster, mustername, "", "GET/kopiermuster"); + IF exists (mustername) THEN + f := sequential file (input, mustername) + ELSE + ggf kopiermuster einrichten; + std kopiermuster (dateiname, f) + END IF; + modify (f); + wirklich kopieren; + ggf sortieren . + +teste auf offen und sortieren : + IF index der arbeitskopie (dateiname) <> 0 THEN + errorstop (nicht in offene datei) + END IF; + oeffne (eudat, dateiname); + IF sortierreihenfolge (eudat) <> niltext THEN + mit sortieren := ja (sortierfrage, "JA/sortieren") + END IF . + +ggf kopiermuster einrichten : + IF mustername = niltext THEN + f := sequential file (output, kopier ds) + ELSE + frage ob einrichten (mustername); + f := sequential file (output, mustername) + END IF . + +wirklich kopieren : + edit (f, ganz, "EDIT/Kopiermuster", TRUE); + bild frei fuer uebersetzung; + kopiere (dateiname, f) . + +ggf sortieren : + IF mit sortieren THEN + oeffne (eudat, dateiname); + sortiere (eudat) + END IF . + +END PROC kopiere saetze intern; + +INT PROC index der arbeitskopie (TEXT CONST dateiname) : + + INT VAR dateinr; + FOR dateinr FROM 1 UPTO anzahl dateien REP + IF eudas dateiname (dateinr) = dateiname THEN + LEAVE index der arbeitskopie WITH dateinr + END IF + END REP; + 0 + +END PROC index der arbeitskopie; + +PROC edit unten (TEXT CONST dateiname, hilfe) : + + IF NOT exists (dateiname) THEN + frage ob einrichten (dateiname) + END IF; + FILE VAR f := sequential file (modify, dateiname); + edit (f, ganz, hilfe, TRUE) + +END PROC edit unten; + +PROC bild frei fuer uebersetzung : + + bitte warten; + cursor (1, 2); + out (cl eop); + bildschirm neu + +END PROC bild frei fuer uebersetzung; + +PROC einzelsortiere (EUDAT VAR eudat) : + + TEXT VAR reihenfolge := sortierreihenfolge (eudat); + IF reihenfolge = niltext COR alte reihenfolge aendern THEN + sortierreihenfolge aendern; + bitte warten; + sortiere (eudat, reihenfolge) + ELSE + bitte warten; + sortiere (eudat) + END IF . + +alte reihenfolge aendern : + ja (alte feldreihenfolge aendern, "JA/Sortierfelder") . + +sortierreihenfolge aendern : + feldnamen lesen (eudat, sammel); + auswahl anbieten ("EUDAS-Sortierfelder", rechts, "AUSWAHL/Sortierfelder", + PROC (TEXT VAR, INT CONST) aus sammel); + INT VAR feldnr := 1; + reihenfolge := niltext; + WHILE wahl (feldnr) <> 0 REP + reihenfolge CAT code (wahl (feldnr)); + nach richtung fragen; + feldnr INCR 1 + END REP . + +nach richtung fragen : + feld lesen (sammel, wahl (feldnr), feldpuffer); + IF ja (textdarstellung (feldpuffer) + aufsteigend sortieren, + "JA/Sortierrichtung") THEN + reihenfolge CAT "+" + ELSE + reihenfolge CAT "-" + END IF . + +END PROC einzelsortiere; + +PROC gib namen (TEXT VAR name, INT CONST nr) : + + IF nr <= anzahl felder THEN + feldnamen lesen (nr, name) + ELSE + name := niltext + END IF + +END PROC gib namen; + + +(************************* Menue 'Drucken' ********************************) + +LET + direkt ausgabe = #1056# + "Ausgabe automatisch zum Drucker", + in bestimmte datei = #1057# + "Ausgabe in bestimmte Datei", + name druckzieldatei = #1058# + "Name Ausgabedatei:", + sortierfrage = #1059# + "Zieldatei anschliessend sortieren", + pruefbedingungen testen = #1060# + "Pruefbedingungen testen", + prueffehler festgestellt = #1061# + "Prueffehler festgestellt", + nicht in offene datei = #1062# + "Zieldatei darf nicht geoeffnet sein", + name kopiermuster = #1063# + "Name Kopiermuster (RET=Std):"; + +LET + z form = #1093# + " zeilenweise formatieren", + s form = #1094# + " seitenweise formatieren"; + +BOOL VAR + zeilen automatisch := FALSE, + seiten automatisch := FALSE; + + +PROC drucken interpreter (INT CONST wahl nr) : + + SELECT wahl nr OF + CASE 1 : nach muster drucken + CASE 2 : ausgaberichtung umschalten + CASE 3 : musterdatei aendern + CASE 4 : textdatei drucken + CASE 5 : nachbearbeiten + OTHERWISE ggf dialogfenster loeschen + END SELECT; + storage kontrollieren . + +nach muster drucken : + dateinamen anfordern (name des druckmusters); + ausfuehrung (PROC (TEXT CONST) drucke mit edit, file typ); + dialogfenster loeschen; + fusszeile ausgeben ("", "") . + +ausgaberichtung umschalten : + direkt drucken (ja (direktausgabe, "JA/direkt drucken")); + IF NOT direkt drucken CAND ja (in bestimmte datei, "JA/Druckdatei") THEN + TEXT VAR dateiname := niltext; + editget (name druckzieldatei, dateiname, "", "GET/Druckdatei"); + IF dateiname <> niltext THEN + druckdatei (dateiname) + END IF + END IF . + +musterdatei aendern : + ausfuehrung (PROC (TEXT CONST) muster edit, file typ); + dialogfenster loeschen; + fusszeile ausgeben ("", "") . + +textdatei drucken : + ausfuehrung (PROC (TEXT CONST) print, file typ) . + +nachbearbeiten : + ausfuehrung (PROC (TEXT CONST) nachbearbeitung, file typ); + dialogfenster loeschen; + fusszeile ausgeben ("", "") . + +ggf dialogfenster loeschen : + IF wahl nr = -1 THEN + dialogfenster loeschen; + fenster veraendert (fuss) + ELIF wahl nr = -2 THEN + fusszeile ausgeben ("", "") + END IF . + +END PROC drucken interpreter; + +PROC uebersetzungsfehler behandeln : + + IF uebersetzungsfehler THEN + clear error + END IF . + +uebersetzungsfehler : + is error CAND errormessage = niltext . + +END PROC uebersetzungsfehler behandeln; + +PROC drucke mit edit (TEXT CONST dateiname) : + + IF NOT exists (dateiname) THEN + muster edit (dateiname) + END IF; + bild frei fuer uebersetzung; + disable stop; + drucke (dateiname); + uebersetzungsfehler behandeln + +END PROC drucke mit edit; + +PROC muster edit (TEXT CONST dateiname) : + + edit unten (dateiname, "EDIT/Druckmuster") + +END PROC muster edit; + +PROC print (TEXT CONST dateiname) : + + do ("print (" + textdarstellung (dateiname) + ")") + +END PROC print; + +PROC nachbearbeitung (TEXT CONST dateiname) : + + IF ja (textdarstellung (dateiname) + z form, "JA/zeilenform") THEN + zeilen formatieren + END IF; + IF ja (textdarstellung (dateiname) + s form, "JA/seitenform") THEN + seiten formatieren + END IF . + +zeilen formatieren : + IF zeilen automatisch THEN + autoform (dateiname) + ELSE + lineform (dateiname) + END IF; + page; + bildschirm neu . + +seiten formatieren : + IF seiten automatisch THEN + autopageform (dateiname) + ELSE + pageform (dateiname) + END IF; + bildschirm neu . + +END PROC nachbearbeitung; + +PROC formatieren automatisch (BOOL CONST za, sa) : + + zeilen automatisch := za; + seiten automatisch := sa + +END PROC formatieren automatisch; + + +(********************** Menue 'Dateien' ***********************************) + +TEXT VAR arbeitsbereich; + +LET + p task = #1064# + " Task: ", + t neuer name = #1065# + "Neuer Name:", + t zieldatei = #1066# + "Zieldatei:", + t belegt = #1067# + " belegt ", + t kb = #1068# + "KB.", + t existiert nicht = #1069# + " existiert nicht.", + t loeschen = #1070# + " im dieser Task loeschen", + t neu einrichten = #1071# + " neu einrichten"; + + +PROC dateiverwaltung (INT CONST wahl nr) : + + enable stop; + SELECT wahl nr OF + CASE 0 : arbeitsbereich bestimmen + CASE 1 : dateiuebersicht + CASE 2 : datei loeschen + CASE 3 : datei umbenennen + CASE 4 : datei kopieren + CASE 5 : speicherbelegung datei + CASE 6 : datei reorganisieren + OTHERWISE ggf dialogfenster loeschen + END SELECT; + storage kontrollieren . + +arbeitsbereich bestimmen : + arbeitsbereich := name (myself) . + +datei reorganisieren : + ausfuehrung (PROC (TEXT CONST) aufraeumen, 0) . + +datei umbenennen : + ausfuehrung (PROC (TEXT CONST) umbenennen, 0) . + +datei loeschen : + ausfuehrung (PROC (TEXT CONST) loeschen, 0) . + +dateiuebersicht : + disable stop; + DATASPACE VAR list ds := nilspace; + FILE VAR f := sequential file (output, list ds); + list (f); + IF NOT is error THEN + edit (f, rechts, "SHOW/Uebersicht", FALSE) + END IF; + forget (list ds); + enable stop; + tastenpuffer loeschen . + +datei kopieren : + ausfuehrung (PROC (TEXT CONST) ds kopieren, 0) . + +speicherbelegung datei : + ausfuehrung (PROC (TEXT CONST) speicherbelegung, 0) . + +ggf dialogfenster loeschen : + IF wahl nr = -1 THEN + dialogfenster loeschen; + fenster veraendert (fuss) + ELIF wahl nr = -2 THEN + fusszeile ausgeben (p task, arbeitsbereich) + END IF . + +END PROC dateiverwaltung; + +PROC tastenpuffer loeschen : + + WHILE getcharety <> niltext REP END REP + +END PROC tastenpuffer loeschen; + +PROC aufraeumen (TEXT CONST dateiname) : + + IF type (old (dateiname)) = eudas typ THEN + reorganisiere (dateiname) + ELSE + reorganize (dateiname) + END IF + +END PROC aufraeumen; + +PROC umbenennen (TEXT CONST dateiname) : + + TEXT VAR neuer name := dateiname; + IF exists (dateiname) THEN + editget (t neuer name, neuer name, "", "GET/rename") + END IF; + rename (dateiname, neuer name) + +END PROC umbenennen; + +PROC loeschen (TEXT CONST dateiname) : + + IF offene datei THEN + errorstop (nicht in offene datei) + ELIF exists (dateiname) CAND frage bejaht THEN + forget (dateiname, quiet) + END IF . + +offene datei : + index der arbeitskopie (dateiname) <> 0 . + +frage bejaht : + ja (textdarstellung (dateiname) + t loeschen, "JA/forget") . + +END PROC loeschen; + +PROC ds kopieren (TEXT CONST dateiname) : + + TEXT VAR zieldatei := niltext; + editget (t zieldatei, zieldatei, "", "GET/copy"); + copy (dateiname, zieldatei) + +END PROC ds kopieren; + +PROC speicherbelegung (TEXT CONST dateiname) : + + dialog; + out (textdarstellung (dateiname)); + IF exists (dateiname) THEN + out (t belegt); + put (ds pages (old (dateiname)) DIV 2); + out (t kb) + ELSE + out (t existiert nicht) + END IF + +END PROC speicherbelegung; + + +(*********************** Menue 'Archiv' ***********************************) + +TEXT VAR + letzter archivname := niltext, + zielarchiv := "ARCHIVE"; + +INT VAR zielstation := 0; + +THESAURUS VAR archivinhalt; + +BOOL VAR + archivzugriff, + ziel ist manager := TRUE, + dialogue state; + +LET + p zielarchiv = #1072# + " Ziel: ", + archiv heisst = #1073# + "Archiv heisst ", + name des archivs = #1074# + "Name des Archivs:", + name zielarchiv = #1075# + "Name Zielarchiv:", + nr zielstation = #1076# + "Nr. der Zielstation (od. RETURN):", + ist ziel archivmanager = #1077# + "Ist das Zielarchiv ein Archivmanager", + diskette formatieren = #1078# + "Archivdiskette vorher formatieren", + neuer archivname = #1079# + "Neuer Archivname:", + t im system ueberschreiben = #1080# + " im System ueberschreiben", + t auf archiv loeschen = #1081# + " auf Archiv loeschen", + t archiv = #1082# + "Archiv ", + t ueberschreiben = #1083# + " ueberschreiben", + frage archiv initialisieren = #1084# + "Archiv initialisieren", + t auf archiv ueberschreiben = #1085# + " auf Archiv ueberschreiben"; + +LET + t passwort = #1095# + "Passwort: ", + passwortwiederholung falsch = #1096# + "Passwort stimmt nicht mit der ersten Eingabe überein", + bitte passwort wiederholen = #1097# + "Passwort zur Kontrolle bitte nochmal eingeben.", + passwort loeschen = #1098# + "Passwort loeschen", + falsche stationsnr = #1099# + "Unzlaessige Stationsnummer", + task ist kein manager = #1100# + "Angegebene Task ist kein Manager"; + + +PROC archivverwaltung (INT CONST wahl nr) : + + enable stop; + SELECT wahl nr OF + CASE 0 : eintritt + CASE 1 : archivuebersicht + CASE 2 : uebersicht drucken + CASE 3 : datei vom archiv holen + CASE 4 : datei auf archiv sichern + CASE 5 : auf archiv loeschen + CASE 6 : archiv initialisieren + CASE 7 : zielarchiv einstellen + CASE 8 : passwort einstellen + CASE 9 : reservieren + OTHERWISE verlassen + END SELECT; + storage kontrollieren . + +eintritt : + archivzugriff := FALSE . + +datei auf archiv sichern : + IF ziel ist manager THEN + archivnamen holen + END IF; + bitte warten; + archivinhalt := ALL eudas archiv; + ausfuehrung (PROC (TEXT CONST) archivieren, 0) . + +datei vom archiv holen : + disable stop; + archiv anmelden; + bitte warten; + archivinhalt := ALL eudas archiv; + IF falscher name THEN archivinhalt := ALL eudas archiv END IF; + enable stop; + auf archiv (PROC (TEXT CONST) holen) . + +auf archiv loeschen : + IF ziel ist manager THEN + archivnamen holen + END IF; + bitte warten; + archivinhalt := ALL eudas archiv; + auf archiv (PROC (TEXT CONST) auf archiv loeschen) . + +archivuebersicht : + archiv anmelden; + disable stop; + bitte warten; + DATASPACE VAR list ds := nilspace; + f :=sequential file (output, list ds); + list (f, eudas archiv); + IF falscher name THEN list (f, eudas archiv) END IF; + IF NOT is error THEN + modify (f); to line (f, 1); + write record (f, headline (f)); + headline (f, niltext); + edit (f, rechts, "SHOW/Uebersicht", FALSE) + END IF; + forget (list ds); + tastenpuffer loeschen; + enable stop . + +uebersicht drucken : + archiv anmelden; + namen generieren; + FILE VAR f := sequential file (output, list name); + disable stop; + bitte warten; + list (f, eudas archiv); + IF falscher name THEN list (f, eudas archiv) END IF; + enable stop; + modify (f); + insert record (f); + write record (f, headline (f)); + print (list name); + forget (list name, quiet) . + +namen generieren : + INT VAR i := 0; + TEXT VAR list name; + REP + i INCR 1; + list name := "Archivliste " + text (i) + UNTIL NOT exists (list name) END REP . + +archiv initialisieren : + archiv anmelden; + IF ja (diskette formatieren, "JA/format") THEN + archiv formatieren + ELIF benanntes archiv THEN + IF loeschen verneint THEN LEAVE archiv initialisieren END IF + ELSE + IF initialisieren verneint THEN LEAVE archiv initialisieren END IF + END IF; + neuen namen erfragen; + tatsaechlich initialisieren . + +archiv formatieren : + bitte warten; + disable stop; + set command dialogue false; + format (eudas archiv); + reset command dialogue; + enable stop . + +benanntes archiv : + reserve ("", eudas archiv); + bitte warten; + disable stop; + archivinhalt := ALL eudas archiv; + BOOL CONST ergebnis := falscher name; + clear error; + enable stop; + ergebnis . + +loeschen verneint : + NOT ja (t archiv + textdarstellung (letzter archivname) + t ueberschreiben, + "JA/archiv loeschen") . + +initialisieren verneint : + NOT ja (frage archiv initialisieren, "JA/archiv init") . + +neuen namen erfragen : + editget (neuer archivname, letzter archivname, "", "GET/Archivname"); + reserve (letzter archivname, eudas archiv) . + +tatsaechlich initialisieren : + bitte warten; + disable stop; + set command dialogue false; + clear (eudas archiv); + reset command dialogue . + +zielarchiv einstellen : + TEXT VAR zieltaskname := zielarchiv; + IF archivzugriff THEN + release (eudas archiv); archivzugriff := FALSE + END IF; + editget (name zielarchiv, zieltaskname, "", "GET/Zielarchiv"); + IF zieltaskname = niltext THEN + LEAVE zielarchiv einstellen + END IF; + zielstation einlesen; + ziel ist manager := ja (ist ziel archivmanager, "JA/Zielmanager"); + werte uebertragen; + waehlbar (6, 6, ziel ist manager); + waehlbar (6, 9, NOT ziel ist manager); + bildschirm neu; + fusszeile ausgeben (p zielarchiv, stationsnr + zielarchiv) . + +zielstation einlesen : + TEXT VAR rechner := text (station (myself)); + IF station (myself) <> 0 THEN + editget (nr zielstation, rechner, "", "GET/Zielstation") + END IF . + +werte uebertragen : + zielstation := int (rechner); + IF NOT last conversion ok THEN + errorstop (falsche stationsnr) + END IF; + zielarchiv := zieltaskname; + teste auf manager (eudas archiv) . + +stationsnr : + IF zielstation = 0 THEN + niltext + ELSE + text (zielstation) + "/" + END IF . + +reservieren : + TEXT VAR parameter := niltext; + editget (name des archivs, parameter, "", "GET/Archivname"); + reserve (parameter, eudas archiv); + archivzugriff := TRUE . + +verlassen : + IF wahl nr = -1 THEN + IF archivzugriff THEN + release (eudas archiv) + END IF; + dialogfenster loeschen; + fenster veraendert (fuss) + ELIF wahl nr = -2 THEN + fusszeile ausgeben (p zielarchiv, stationsnr + zielarchiv) + END IF . + +END PROC archivverwaltung; + +TASK PROC eudas archiv : + + IF zielstation = 0 THEN + task (zielarchiv) + ELSE + zielstation / zielarchiv + END IF + +END PROC eudas archiv; + +PROC teste auf manager (TASK CONST t) : + + INT VAR i; + IF station (t) = station (myself) THEN + FOR i FROM 1 UPTO 5 REP + IF status (t) = 2 OR status (t) = 6 THEN + LEAVE teste auf manager + END IF; + pause (10) + END REP; + errorstop (task ist kein manager) + END IF + +END PROC teste auf manager; + +PROC archivnamen holen : + + TEXT VAR neuer archivname := letzter archivname; + editget (name des archivs, neuer archivname, "", "GET/Archivname"); + IF NOT archivzugriff OR neuer archivname <> letzter archivname THEN + reserve (neuer archivname, eudas archiv); + archivzugriff := TRUE + END IF; + letzter archivname := neuer archivname + +END PROC archivnamen holen; + +PROC archiv anmelden : + + IF NOT archivzugriff AND ziel ist manager THEN + reserve (letzter archivname, eudas archiv); + archivzugriff := TRUE + END IF + +END PROC archiv anmelden; + +BOOL PROC falscher name : + + IF ziel ist manager AND is error THEN + TEXT CONST meldung := errormessage; + IF subtext (meldung, 1, 14) = archiv heisst CAND + subtext (meldung, 16, 20) <> "?????" THEN + clear error; + nochmal anmelden; + LEAVE falscher name WITH TRUE + END IF + END IF; + FALSE . + +nochmal anmelden : + letzter archivname := subtext (meldung, 16, length (meldung) - 1); + reserve (letzter archivname, eudas archiv) . + +END PROC falscher name; + +PROC archivieren (TEXT CONST dateiname) : + + disable stop; + IF NOT (archivinhalt CONTAINS dateiname) COR auf archiv ueberschreiben THEN + vorher eventuell sichern; + bitte warten; + set command dialogue false; + save (dateiname, eudas archiv); + reset command dialogue + END IF . + +auf archiv ueberschreiben : + ja (textdarstellung (dateiname) + t auf archiv ueberschreiben, "JA/save") . + +vorher eventuell sichern : + INT CONST nr := index der arbeitskopie (dateiname); + IF nr > 0 CAND aendern erlaubt CAND inhalt veraendert (nr) THEN + einzelsicherung (nr) + END IF . + +END PROC archivieren; + +PROC holen (TEXT CONST dateiname) : + + disable stop; + IF NOT exists (dateiname) COR eigene datei ueberschreiben THEN + bitte warten; + set command dialogue false; + fetch (dateiname, eudas archiv); + reset command dialogue + END IF . + +eigene datei ueberschreiben : + ja (textdarstellung (dateiname) + t im system ueberschreiben, "JA/fetch") . + +END PROC holen; + +PROC auf archiv loeschen (TEXT CONST dateiname) : + + disable stop; + IF NOT (archivinhalt CONTAINS dateiname) COR auf archiv loeschen THEN + bitte warten; + set command dialogue false; + erase (dateiname, eudas archiv); + reset command dialogue + END IF . + +auf archiv loeschen : + ja (textdarstellung (dateiname) + t auf archiv loeschen, "JA/erase") . + +END PROC auf archiv loeschen; + +PROC set command dialogue false : + + dialogue state := command dialogue; + command dialogue (FALSE) + +END PROC set command dialogue false; + +PROC reset command dialogue : + + command dialogue (dialogue state) + +END PROC reset command dialogue; + +PROC auf archiv (PROC (TEXT CONST) operation) : + + TEXT VAR dateiname := niltext; + editget (name der datei, dateiname, "z", "GET/Dateiname"); + IF dateiname = esc z THEN + uebersicht zeigen + ELSE + last param (dateiname); + operation (dateiname) + END IF . + +uebersicht zeigen : + dateinamen sammeln (archivinhalt, 0); + auswahl anbieten ("EUDAS-Archivauswahl", rechts, "AUSWAHL/Archiv", + PROC (TEXT VAR, INT CONST) als text); + operation ausfuehren (PROC (TEXT CONST) operation) . + +END PROC auf archiv; + +PROC passwort einstellen : + + BOUND ROW 2 TEXT VAR pw; + DATASPACE VAR ds := nilspace; + pw := ds; + disable stop; + passwort holen (pw (1)); + IF pw (1) = niltext THEN + fragen ob loeschen + ELSE + doppelt eingeben + END IF; + forget (ds) . + +fragen ob loeschen : + IF ja (passwort loeschen, "JA/pw loeschen") THEN + dialog; dialog; + enter password (niltext) + END IF . + +doppelt eingeben : + dialog; out (bitte passwort wiederholen); + passwort holen (pw (2)); + IF pw (1) <> pw (2) THEN + errorstop (passwortwiederholung falsch) + ELSE + dialog; dialog; + enter password (pw (1)) + END IF . + +END PROC passwort einstellen; + +PROC passwort holen (TEXT VAR wort) : + + enable stop; + dialog; out (t passwort); + get secret line (wort) + +END PROC passwort holen; + + +(******************** Parameter-Auswahl ***********************************) + +SATZ VAR sammel; + +LET + name der datei = #1086# + "Name der Datei:", + name der zieldatei = #1087# + "Name der Zieldatei:", + name der verarbeitungsvorschrift = #1088# + "Name der Verarbeitungsvorschrift:", + name des druckmusters = #1089# + "Name des Druckmusters:", + name der quelldatei = #1090# + "Name der Quelldatei:"; + +LET + keine datei zur auswahl = #1101# + "Keine Datei zur Auswahl vorhanden."; + +TEXT VAR + aktueller prompt := name der datei, + offene; + + +PROC dateinamen sammeln (THESAURUS CONST t, INT CONST typ) : + + uebergebene namen sammeln; + offene dateien merken; + zusaetzliche namen dazu; + meldung falls keine datei . + +offene dateien merken : + offene := niltext; + INT VAR i; + FOR i FROM 1 UPTO anzahl dateien REP + INT CONST t link := feldindex (sammel, eudas dateiname (i)); + IF t link > 0 THEN + offene CAT code (t link) + END IF + END REP . + +uebergebene namen sammeln : + INT VAR + stelle := 1, + von := 0; + satz initialisieren (sammel); + REP + get (t, feldpuffer, von); + IF feldpuffer = niltext THEN + LEAVE uebergebene namen sammeln + ELIF typ = 0 COR type (old (feldpuffer)) = typ THEN + feld aendern (sammel, stelle, feldpuffer); + stelle INCR 1 + END IF + END REP . + +zusaetzliche namen dazu : + von := 0; + REP + get (zusaetzliche namen, feldpuffer, von); + IF feldpuffer = niltext THEN + LEAVE zusaetzliche namen dazu + ELIF NOT (t CONTAINS feldpuffer) THEN + feld aendern (sammel, stelle, feldpuffer); + stelle INCR 1 + END IF + END REP . + +meldung falls keine datei : + IF stelle = 1 THEN + dialog; out (keine datei zur auswahl); + errorstop (niltext) + END IF . + +END PROC dateinamen sammeln; + +PROC als text (TEXT VAR inhalt, INT CONST stelle) : + + IF stelle < 256 THEN + feld lesen (sammel, stelle, inhalt); + IF pos (offene, code (stelle)) > 0 THEN + inhalt := "<!> " + textdarstellung (inhalt) + ELIF inhalt <> niltext THEN + inhalt := textdarstellung (inhalt) + END IF + ELSE + inhalt := niltext + END IF + +END PROC als text; + +PROC operation ausfuehren (PROC (TEXT CONST) operation) : + + INT VAR + stelle := 1; + REP + IF wahl (stelle) = 0 THEN + LEAVE operation ausfuehren + ELSE + feld lesen (sammel, wahl (stelle), feldpuffer); + dialog; out (text (stelle, 3)); out (". "); + out (textdarstellung (feldpuffer)); + last param (feldpuffer); + operation (feldpuffer) + END IF; + stelle INCR 1 + END REP + +END PROC operation ausfuehren; + +PROC ausfuehrung (PROC (TEXT CONST) operation, INT CONST typ) : + + enable stop; + TEXT VAR dateiname; + dateinamen anfordern (dateiname, typ); + IF dateiname = esc z THEN + operation ausfuehren (PROC (TEXT CONST) operation) + ELSE + last param (dateiname); + operation (dateiname) + END IF + +END PROC ausfuehrung; + +PROC einzelausfuehrung (PROC (TEXT CONST) operation, INT CONST typ) : + + enable stop; + TEXT VAR dateiname; + dateinamen anfordern (dateiname, typ); + IF dateiname = esc z THEN + IF wahl (1) = 0 THEN + errorstop (niltext) + ELSE + feld lesen (sammel, wahl (1), dateiname) + END IF + END IF; + last param (dateiname); + operation (dateiname) + +END PROC einzelausfuehrung; + +PROC dateinamen anfordern (TEXT CONST prompt) : + + aktueller prompt := prompt + +END PROC dateinamen anfordern; + +PROC dateinamen anfordern (TEXT VAR dateiname, INT CONST typ) : + + IF exists (std) AND (typ = 0 COR type (old (std)) = typ) THEN + dateiname := std + ELSE + dateiname := niltext + END IF; + disable stop; + editget (aktueller prompt, dateiname, "z", "GET/Dateiname"); + aktueller prompt := name der datei; + enable stop; + IF dateiname = niltext THEN + errorstop (niltext) + ELIF dateiname = esc z THEN + dateinamen sammeln (all, typ); + auswahl anbieten ("EUDAS-Dateiauswahl", rechts, "AUSWAHL/Datei", + PROC (TEXT VAR, INT CONST) als text); + bitte warten + END IF + +END PROC dateinamen anfordern; + +PROC aus sammel (TEXT VAR inhalt, INT CONST stelle) : + + IF stelle <= 256 THEN + feld lesen (sammel, stelle, inhalt) + ELSE + inhalt := niltext + END IF + +END PROC aus sammel; + +PROC frage ob einrichten (TEXT CONST dateiname) : + + IF NOT ja (textdarstellung (dateiname) + t neu einrichten, + "JA/einrichten") THEN + errorstop (niltext) + END IF + +END PROC frage ob einrichten; + + +(************************** Editor ****************************************) + +LET + edit status = #1091# +"EDITIEREN: Abbruch: ESC h Verlassen: ESC q Hilfe: ESC ?", + show status = #1092# +"ZEIGEN: Blättern: HOP OBEN, HOP UNTEN Ende: ESC q Hilfe: ESC ?"; + +INT VAR return code; + +BOOL VAR + zeige edit status, + feldanzeige erlaubt; + + +PROC edit (FILE VAR f, FENSTER CONST fenster, TEXT CONST hilfe, + BOOL CONST aendern) : + + INT VAR x, y, x l, y l; + fenstergroesse (fenster, x, y, x l, y l); + fenster veraendert (fenster); + enable stop; + feldanzeige erlauben; + zeige edit status := aendern; + REP + edit status anzeigen; + open editor (groesster editor + 1, f, aendern, x, y, x l, y l); + edit (groesster editor, "eqvw19dpgn"9"?hF", PROC (TEXT CONST) kdo); + return code behandeln + END REP . + +feldanzeige erlauben : + IF aendern AND y < 3 AND y l > 22 AND x < 14 AND x l > 75 THEN + feldanzeige erlaubt := TRUE + ELSE + feldanzeige erlaubt := FALSE + END IF . + +return code behandeln : + SELECT return code OF + CASE 0 : LEAVE edit + CASE 1 : hilfe anbieten (hilfe, fenster) + CASE 2 : errorstop (niltext) + END SELECT . + +END PROC edit; + +PROC edit status anzeigen : + + IF zeige edit status THEN + status anzeigen (edit status) + ELSE + status anzeigen (show status) + END IF + +END PROC edit status anzeigen; + +PROC kdo (TEXT CONST zeichen) : + + return code := pos ("q?h", zeichen); + IF return code > 0 THEN + return code DECR 1; + quit + ELIF feldanzeige erlaubt CAND zeichen = "F" THEN + feldnamen anzeigen; + edit status anzeigen + ELSE + std kommando interpreter (zeichen); + edit status anzeigen; + bildschirm neu + END IF + +END PROC kdo; + +PROC feldnamen anzeigen : + + IF anzahl felder > 0 THEN + feldnamen sammeln; + sammlung zur auswahl anbieten; + ergebnis in editor uebernehmen + END IF . + +feldnamen sammeln : + INT VAR feldnr; + satz initialisieren (sammel, anzahl felder); + FOR feldnr FROM 1 UPTO anzahl felder REP + feldnamen lesen (feldnr, feldpuffer); + feld aendern (sammel, feldnr, feldpuffer) + END REP . + +sammlung zur auswahl anbieten : + auswahl anbieten ("EUDAS-Editfelder", rechts, "AUSWAHL/Feldnamen", + PROC (TEXT VAR, INT CONST) aus sammel) . + +ergebnis in editor uebernehmen : + INT VAR stelle := 1; + WHILE wahl (stelle) > 0 REP + IF stelle > 1 THEN push (blank) END IF; + feldnamen lesen (wahl (stelle), feldpuffer); + push (""""); push (feldpuffer); push (""""); + stelle INCR 1 + END REP . + +END PROC feldnamen anzeigen; + +END PACKET eudas steuerung; + diff --git a/app/eudas/4.4/src/eudas.uebersicht b/app/eudas/4.4/src/eudas.uebersicht new file mode 100644 index 0000000..4029956 --- /dev/null +++ b/app/eudas/4.4/src/eudas.uebersicht @@ -0,0 +1,420 @@ +PACKET uebersichtsanzeige + +(*************************************************************************) +(* *) +(* Anzeige von EUDAS-Dateien als Übersicht *) +(* *) +(* Version 02 *) +(* *) +(* Autor: Thomas Berlage *) +(* Stand: 08.07.87 *) +(* *) +(*************************************************************************) + + DEFINES + + uebersicht, + uebersichtsfenster : + + +ROW 24 INT VAR zeilensatz; + +ROW 24 INT VAR zeilenkombi; + +FENSTER VAR fenster; +fenster initialisieren (fenster); + +INT VAR + laenge := 24, + breite := 79, + zeilen anf := 1, + spalten anf := 1, + freier rest, + feldversion := -1; + +BOOL VAR + bis zeilenende, + satznummer markieren; + +TEXT VAR + feldnummern; + +LET + niltext = "", + begin mark = ""15"", + end mark = ""14"", + blank = " ", + piep = ""7"", + cleol = ""5""; + +LET + t satznr = #901# + ""15"Satznr. ", + t dateiende = #902# + " << DATEIENDE >>", + uebersicht status = #903# +"UEBERSICHT: Rollen: HOP OBEN, HOP UNTEN Beenden: ESC q Hilfe: ESC ?"; + + +PROC uebersichtsfenster (INT CONST x anf, y anf, x laenge, y laenge) : + + fenstergroesse setzen (fenster, x anf, y anf, x laenge, y laenge); + bis zeilenende := x anf + x laenge >= 80; + laenge := y laenge; + breite := x laenge; + zeilen anf := y anf; + spalten anf := x anf + +END PROC uebersichtsfenster; + +PROC uebersicht (TEXT CONST nummern, PROC hilfe) : + + TEXT VAR eingabezeichen; + BOOL VAR dummy; + INT VAR + angezeigter satz := 1, + ausgegebene zeilen := 0, + eingabezustand := 1; + + fensterzugriff (fenster, dummy); + status anzeigen (uebersicht status); + feldnummern bestimmen; + satznummer markieren := FALSE; + aktueller satz wird erster; + REP + kommando annehmen und zeile ausgeben; + alte markierung entfernen; + kommando interpretieren + END REP . + +feldnummern bestimmen : + IF nummern = niltext THEN + ggf alte auswahl uebernehmen + ELSE + feldnummern := nummern; + feldversion := dateiversion + END IF . + +ggf alte auswahl uebernehmen : + IF feldversion <> dateiversion THEN + alle felder anzeigen; + feldversion := dateiversion + END IF . + +alle felder anzeigen : + INT VAR i; + feldnummern := niltext; + FOR i FROM 1 UPTO anzahl felder REP + feldnummern CAT code (i) + END REP . + +kommando annehmen und zeile ausgeben : + WHILE ausgegebene zeilen < laenge REP + eingabezeichen := getcharety; + IF eingabezeichen <> "" THEN + LEAVE kommando annehmen und zeile ausgeben + END IF; + eine zeile ausgeben; + ausgegebene zeilen INCR 1 + END REP; + aktuellen satz markieren und einnehmen; + getchar (eingabezeichen) . + +eine zeile ausgeben : + IF ausgegebene zeilen = 0 THEN + ueberschrift ausgeben + ELIF ausgegebene zeilen = 1 THEN + erste zeile ausgeben + ELSE + weitere zeile ausgeben + END IF . + +ueberschrift ausgeben : + cursor (spalten anf, zeilen anf); + out (t satznr); + freier rest := breite - 10; + INT VAR feldindex; + FOR feldindex FROM 1 UPTO length (feldnummern) + WHILE freier rest > 0 REP + feldnamen bearbeiten (code (feldnummern SUB feldindex), + PROC (TEXT CONST, INT CONST, INT CONST) feld bis rest) + END REP; + zeilenrest loeschen; + cursor (spalten anf + breite - 1, zeilen anf); + out (end mark) . + +erste zeile ausgeben : + auf uebersichtssatz (1); + satznummer in zeile (1); + satz als zeile ausgeben . + +weitere zeile ausgeben : + cursor (spalten anf, zeilen anf + ausgegebene zeilen); + IF dateiende THEN + zeilensatz (ausgegebene zeilen) := 0; + freier rest := breite; + zeilenrest loeschen + ELSE + naechsten satz einnehmen; + satznummer in zeile (ausgegebene zeilen); + satz als zeile ausgeben + END IF . + +naechsten satz einnehmen : + weiter (2); + auf abbruch testen; + zeilensatz (ausgegebene zeilen) := satznummer; + zeilenkombi (ausgegebene zeilen) := satzkombination . + +auf abbruch testen : + IF NOT (satz ausgewaehlt OR dateiende) THEN + LEAVE uebersicht + END IF . + +alte markierung entfernen : + IF angezeigter satz < ausgegebene zeilen THEN + satznummer in zeile (angezeigter satz) + END IF; + cursor (spalten anf, zeilen anf + angezeigter satz) . + +aktuellen satz markieren und einnehmen : + satznummer markieren := TRUE; + WHILE zeilensatz (angezeigter satz) = 0 REP + angezeigter satz DECR 1 + END REP; + satznummer in zeile (angezeigter satz); + auf uebersichtssatz (angezeigter satz); + markierung ausgeben; + satznummer markieren := FALSE . + +kommando interpretieren : + SELECT eingabezustand OF + CASE 1 : normales kommando interpretieren + CASE 2 : hop kommando interpretieren + CASE 3 : esc kommando interpretieren + END SELECT . + +normales kommando interpretieren : + SELECT pos (""3""10""1""27"+-", eingabezeichen) OF + CASE 1 : zeile nach oben + CASE 2 : zeile nach unten + CASE 3 : eingabezustand := 2 + CASE 4 : eingabezustand := 3 + CASE 5 : markieren + CASE 6 : demarkieren + OTHERWISE out (piep) + END SELECT . + +hop kommando interpretieren : + SELECT pos (""3""10""13"", eingabezeichen) OF + CASE 1 : seite nach oben + CASE 2 : seite nach unten + CASE 3 : hop return + OTHERWISE out (piep) + END SELECT; + eingabezustand := 1 . + +esc kommando interpretieren : + SELECT pos ("19qh?", eingabezeichen) OF + CASE 1 : esc 1 + CASE 2 : esc 9 + CASE 3, 4 : esc q + CASE 5 : hilfestellung + OTHERWISE out (piep) + END SELECT; + eingabezustand := 1 . + +zeile nach oben : + IF angezeigter satz > 1 THEN + angezeigter satz DECR 1; + ELSE + nach oben rollen (1); + ausgegebene zeilen := 1 + END IF . + +zeile nach unten : + IF NOT dateiende THEN + IF angezeigter satz < laenge - 1 THEN + angezeigter satz INCR 1 + ELSE + zeilensatz (1) := zeilensatz (2); + zeilenkombi (1) := zeilenkombi (2); + ausgegebene zeilen := 1 + END IF + END IF . + +markieren : + IF NOT satz markiert THEN + markierung aendern + END IF . + +demarkieren : + IF satz markiert THEN + markierung aendern + END IF . + +seite nach oben : + IF angezeigter satz > 1 THEN + angezeigter satz := 1 + ELSE + nach oben rollen (laenge - 1); + ausgegebene zeilen := 1 + END IF . + +seite nach unten : + IF angezeigter satz = laenge - 1 AND NOT dateiende THEN + weiter (2); + aktueller satz wird erster; + ausgegebene zeilen := 1 + ELSE + angezeigter satz := laenge - 1 + END IF . + +hop return : + IF angezeigter satz <> 1 THEN + zeilensatz (1) := zeilensatz (angezeigter satz); + zeilenkombi (1) := zeilenkombi (angezeigter satz); + angezeigter satz := 1; + ausgegebene zeilen := 1 + END IF . + +esc 1 : + auf satz (1); + IF NOT satz ausgewaehlt THEN + weiter (2) + END IF; + aktueller satz wird erster; + angezeigter satz := 1; + ausgegebene zeilen := 1 . + +esc 9 : + auf satz (32767); + aktueller satz wird erster; + nach oben rollen (laenge - 2); + ausgegebene zeilen := 1 . + +esc q : + satznummer markieren := true; + satznummer in zeile (angezeigter satz); + LEAVE uebersicht . + +hilfestellung : + hilfe; + status anzeigen (uebersicht status); + ausgegebene zeilen := 0 . + +END PROC uebersicht; + +PROC nach oben rollen (INT CONST gerollt) : + + INT VAR i; + auf uebersichtssatz (1); + FOR i FROM 1 UPTO gerollt + WHILE satznummer > 1 REP + zurueck (2) + END REP; + aktueller satz wird erster + +END PROC nach oben rollen; + +PROC auf uebersichtssatz (INT CONST zeile) : + + auf satz (zeilensatz (zeile)); + WHILE satzkombination <> zeilenkombi (zeile) REP + weiter (1) + END REP + +END PROC auf uebersichtssatz; + +PROC aktueller satz wird erster : + + zeilensatz (1) := satznummer; + zeilenkombi (1) := satzkombination + +END PROC aktueller satz wird erster; + +BOOL PROC uebereinstimmung (INT CONST zeile) : + + satznummer = zeilensatz (zeile) CAND satzkombination = zeilenkombi (zeile) + +END PROC uebereinstimmung; + +PROC feld bis rest (TEXT CONST satz, INT CONST von, bis) : + + INT CONST laenge := min (freier rest, bis - von + 1); + outsubtext (satz, von, von + laenge - 1); + freier rest DECR laenge; + IF freier rest >= 2 THEN + out (", "); freier rest DECR 2 + ELIF freier rest = 1 THEN + out (","); freier rest := 0 + END IF + +END PROC feld bis rest; + +PROC satznummer in zeile (INT CONST zeile) : + + cursor (spalten anf, zeilen anf + zeile); + IF satznummer markieren THEN + out (begin mark) + ELSE + out (blank) + END IF; + outtext (text (zeilensatz (zeile)), 1, 5); + IF satznummer markieren THEN + out (end mark) + ELSE + out (blank) + END IF; + freier rest := breite - 7 + +END PROC satznummer in zeile; + +PROC zeilenrest loeschen : + + IF bis zeilenende THEN + out (cleol) + ELSE + freier rest TIMESOUT blank + END IF + +END PROC zeilenrest loeschen; + +PROC satz als zeile ausgeben : + + IF satz ausgewaehlt THEN + markierung ausgeben; + felder ausgeben + ELIF dateiende THEN + out (t dateiende); + freier rest DECR 17 + ELSE + markierung ausgeben; + out ("<< >>"); + freier rest DECR 5 + END IF; + zeilenrest loeschen . + +felder ausgeben : + INT VAR feldindex; + FOR feldindex FROM 1 UPTO length (feldnummern) + WHILE freier rest > 0 REP + feld bearbeiten (code (feldnummern SUB feldindex), + PROC (TEXT CONST, INT CONST, INT CONST) feld bis rest) + END REP . + +END PROC satz als zeile ausgeben; + +PROC markierung ausgeben : + + IF satz markiert THEN + out ("+ ") + ELSE + out ("- ") + END IF; + freier rest DECR 2 + +END PROC markierung ausgeben; + +END PACKET uebersichtsanzeige; + diff --git a/app/eudas/4.4/src/eudas.verarbeitung b/app/eudas/4.4/src/eudas.verarbeitung new file mode 100644 index 0000000..95af7cc --- /dev/null +++ b/app/eudas/4.4/src/eudas.verarbeitung @@ -0,0 +1,731 @@ +PACKET verarbeitung + +(*************************************************************************) +(* *) +(* Automatische Verarbeitung von EUDAS-Dateien *) +(* *) +(* Version 05 *) +(* *) +(* Autor: Thomas Berlage *) +(* Stand: 17.04.87 *) +(* *) +(*************************************************************************) + + DEFINES + + kopiere, + std kopiermuster, + verarbeite, + trage, + eindeutige felder, + pruefe, + wertemenge, + feldmaske, + trage satz, + hole satz, + K, + V, + f, + wert, + zahltext, + textdarstellung : + + +SATZ VAR + zielfeldnamen, + kopierfeldnamen, + kopiersatz; + +INT VAR kopierindex; + +BOOL VAR erstes mal; + +LET + niltext = "", + INTVEC = TEXT; + +INTVEC VAR kopiervektor; + +TEXT VAR zwei bytes := " "; + + +OP CAT (INTVEC VAR intvec, INT CONST zahl) : + + replace (zwei bytes, 1, zahl); + intvec CAT zwei bytes + +END OP CAT; + +PROC std kopiermuster (TEXT CONST dateiname, FILE VAR kopiermuster) : + + teste ob datei vorhanden; + INT VAR zielfelder; + dateien oeffnen; + feldnamen bestimmen; + INT VAR feldnr; + FOR feldnr FROM 1 UPTO zielfelder REP + feldnamen auslesen; + IF feld vorhanden THEN + direkt kopieren + ELSE + leer kopieren + END IF + END REP . + +dateien oeffnen : + output (kopiermuster); + EUDAT VAR eudas datei; + IF exists (dateiname) THEN + oeffne (eudas datei, dateiname) + END IF . + +feldnamen bestimmen : + IF exists (dateiname) CAND felderzahl (eudas datei) > 0 THEN + feldnamen lesen (eudas datei, zielfeldnamen); + zielfelder := felderzahl (eudas datei) + ELSE + quellfeldnamen kopieren; + zielfelder := anzahl felder + END IF . + +quellfeldnamen kopieren : + TEXT VAR feldname; + satz initialisieren (zielfeldnamen); + FOR feldnr FROM 1 UPTO anzahl felder REP + feldnamen lesen (feldnr, feldname); + feld aendern (zielfeldnamen, feldnr, feldname) + END REP . + +feld vorhanden : + feldnummer (feldname) > 0 . + +feldnamen auslesen : + feld lesen (zielfeldnamen, feldnr, feldname); + put (kopiermuster, textdarstellung (feldname)) . + +direkt kopieren : + write (kopiermuster, "K f("); + write (kopiermuster, textdarstellung (feldname)); + putline (kopiermuster, ");") . + +leer kopieren : + putline (kopiermuster, "K """";") . + +END PROC std kopiermuster; + +PROC kopiere (TEXT CONST dateiname, FILE VAR kopiermuster) : + + programmfunktion (kopieraufruf, kopiermuster) . + +kopieraufruf : + "kopiere (" + textdarstellung (dateiname) + ", " . + +END PROC kopiere; + +PROC programmfunktion (TEXT CONST aufruf, FILE VAR muster) : + + programmdatei einrichten; + write (programm, aufruf); + putline (programm, "PROC programmfunktion);"); + putline (programm, "PROC programmfunktion:"); + muster kopieren; + putline (programm, "END PROC programmfunktion"); + programm ausfuehren; + forget (programm datei, quiet) . + +programmdatei einrichten : + TEXT VAR programmdatei; + INT VAR i := 0; + REP + i INCR 1; + programmdatei := text (i) + UNTIL NOT exists (programmdatei) END REP; + disable stop; + FILE VAR programm := sequential file (output, programm datei); + headline (programm, erzeugtes programm) . + +muster kopieren : + TEXT VAR zeile; + input (muster); + WHILE NOT eof (muster) REP + getline (muster, zeile); + putline (programm, zeile) + END REP . + +programm ausfuehren : + TEXT CONST alter last param := std; + run (programmdatei); + last param (alter last param) . + +END PROC programm funktion; + +PROC kopiere (TEXT CONST dateiname, PROC kopierfunktion) : + + enable stop; + INT VAR modus; + auf ersten satz (modus); + IF dateiende THEN + auf satz (1); + LEAVE kopiere + ELSE + zieldatei einrichten + END IF; + + WHILE NOT dateiende REP + satz initialisieren (kopiersatz); + kopierindex := 1; + kopierfunktion; + evtl feldnamen einrichten; + satz einfuegen (eudas datei, kopiersatz); + weiter (eudas datei); + weiter (modus) + END REP; + auf satz (1) . + +zieldatei einrichten : + erstes mal := TRUE; + EUDAT VAR eudas datei; + oeffne (eudas datei, dateiname); + auf satz (eudas datei, saetze (eudas datei) + 1); + feldnamen lesen (eudas datei, kopierfeldnamen); + kopiervektor := niltext . + +evtl feldnamen einrichten : + IF erstes mal THEN + feldnamen aendern (eudas datei, kopierfeldnamen); + erstes mal := FALSE + END IF + +END PROC kopiere; + +OP K (TEXT CONST feldname, ausdruck) : + + IF erstes mal THEN + kopiervektor erstellen; + END IF; + feld aendern (kopiersatz, kopiervektor ISUB kopierindex, ausdruck); + kopierindex INCR 1 . + +kopiervektor erstellen : + INT VAR aktueller index := feldindex (kopierfeldnamen, feldname); + IF aktueller index = 0 THEN + aktueller index := felderzahl (kopierfeldnamen) + 1; + feld aendern (kopierfeldnamen, aktueller index, feldname); + END IF; + kopiervektor CAT aktueller index . + +END OP K; + +PROC verarbeite (FILE VAR verarbeitungsmuster) : + + programmfunktion ("verarbeite (", verarbeitungsmuster) + +END PROC verarbeite; + +PROC verarbeite (PROC verarbeitungsfunktion) : + + enable stop; + INT VAR modus; + auf ersten satz (modus); + + WHILE NOT dateiende REP + verarbeitungsfunktion; + weiter (modus) + END REP; + auf satz (1) + +END PROC verarbeite; + +OP V (TEXT CONST feldname, ausdruck) : + + INT CONST nr := feldnummer (feldname); + IF nr = 0 THEN + unbekannt (feldname) + ELSE + feld aendern (nr, ausdruck) + END IF + +END OP V; + +PROC auf ersten satz (INT VAR modus) : + + teste ob datei vorhanden; + auf satz (1); + IF markierte saetze > 0 THEN + modus := 3; + IF NOT satz markiert THEN weiter (modus) END IF + ELSE + modus := 2; + IF NOT satz ausgewaehlt THEN weiter (modus) END IF + END IF + +END PROC auf ersten satz; + +PROC teste ob datei vorhanden : + + IF anzahl dateien = 0 THEN + errorstop (keine datei geoeffnet) + END IF . + +END PROC teste ob datei vorhanden; + + +(******************************** Zugriffe *******************************) + +TEXT VAR + feldpuffer, + werttext; + +LET quote = """"; + + +TEXT PROC f (TEXT CONST feldname) : + + INT CONST nr := feldnummer (feldname); + IF nr = 0 THEN + unbekannt (feldname); + feldpuffer := niltext + ELSE + feld lesen (nr, feldpuffer) + END IF; + feldpuffer + +END PROC f; + +REAL PROC wert (TEXT CONST feldname) : + + INT CONST nr := feldnummer (feldname); + IF nr = 0 THEN + unbekannt (feldname); + 0.0 + ELSE + feld lesen (nr, feldpuffer); + REAL VAR ergebnis; + wert berechnen (feldpuffer, ergebnis); + ergebnis + END IF + +END PROC wert; + +REAL PROC wert (TEXT CONST feldname, INT CONST kommastellen) : + + round (wert (feldname), kommastellen) + +END PROC wert; + +TEXT PROC zahltext (REAL CONST feldwert, INT CONST kommastellen) : + + REAL CONST w := round (abs (feldwert), kommastellen); + INT VAR stellen := exponent der zahl + kommastellen + 2; + IF feldwert < 0.0 THEN + werttext := "-" + ELSE + werttext := niltext + END IF; + IF w < 1.0 AND w <> 0.0 THEN + werttext CAT "0"; + stellen DECR 1 + ENDIF; + werttext CAT text (w, stellen, kommastellen); + IF kommastellen > 0 THEN + change (werttext, ".", dezimalkomma) + ELSE + change (werttext, ".", niltext) + END IF; + werttext . + +exponent der zahl : + max (0, decimal exponent (w)) . + +END PROC zahltext; + +TEXT PROC zahltext (TEXT CONST feldname, INT CONST kommastellen) : + + zahltext (wert (feldname), kommastellen) + +END PROC zahltext; + +TEXT PROC textdarstellung (TEXT CONST anzeigetext) : + + feldpuffer := anzeigetext; + change all (feldpuffer, quote, quote + quote); + steuerzeichen umwandeln; + insert char (feldpuffer, quote, 1); + feldpuffer CAT quote; + feldpuffer . + +steuerzeichen umwandeln : + INT VAR stelle := 1; + WHILE steuerzeichen vorhanden REP + change (feldpuffer, stelle, stelle, steuertext) + END REP . + +steuerzeichen vorhanden : + stelle := pos (feldpuffer, ""0"", ""31"", stelle); + stelle > 0 . + +steuertext : + quote + text (code (feldpuffer SUB stelle)) + quote . + +END PROC textdarstellung; + +PROC unbekannt (TEXT CONST feldname) : + + errorstop (t das feld + textdarstellung (feldname) + + nicht definiert) + +END PROC unbekannt; + + +(****************************** Tragen ***********************************) + +SATZ VAR tragsatz; + +EUDAT VAR zieldatei; + +LET + erzeugtes programm = #501# + "erzeugtes Programm", + keine datei geoeffnet = #502# + "keine Datei geoeffnet", + kein satz vorhanden = #503# + "Kein Satz zum Tragen vorhanden", + falsche felderzahl = #504# + "Zieldatei hat falsche Felderzahl", + existiert nicht = #505# + " existiert nicht", + verletzt die pruefbedingung = #506# + " verletzt die Pruefbedingung.", + bereits vorhanden = #507# + " ist in der Zieldatei bereits vorhanden.", + nicht definiert = #508# + " ist nicht definiert.", + nicht in wertemenge = #509# + " ist nicht in der Wertemenge.", + passt nicht zu maske = #510# + " stimmt nicht mit der Maske ueberein.", + t satz = #511# + "Satz ", + t das feld = #512# + "Das Feld "; + +INT VAR + anzahl eindeutiger felder; + +FILE VAR protokoll; + +BOOL VAR + testen := FALSE, + test erfolgreich, + uebereinstimmung; + +TEXT VAR testprogramm; + + +PROC trage (TEXT CONST dateiname, FILE VAR protokoll file, BOOL CONST test) : + + disable stop; + testen := test; + IF testen THEN + protokoll := protokoll file; + output (protokoll) + END IF; + trage intern (dateiname); + testen := FALSE + +END PROC trage; + +PROC trage intern (TEXT CONST dateiname) : + + enable stop; + INT VAR modus; + auf ersten satz (modus); + tragen vorbereiten (dateiname); + + INT VAR satzzaehler := 0; + REP + IF NOT ausgewaehlt THEN + weiter (modus) + ELSE + cout (satznummer + satzzaehler) + END IF; + IF dateiende THEN auf satz (1); LEAVE trage intern END IF; + satz testen und tragen + END REP . + +ausgewaehlt : + IF modus = 3 THEN satz markiert ELSE satz ausgewaehlt END IF . + +satz testen und tragen : + test erfolgreich := TRUE; + IF testen THEN + notizen lesen (zieldatei, 1, testprogramm); + do (testprogramm) + END IF; + IF test erfolgreich THEN + trage einzelsatz; + IF test erfolgreich THEN + satz loeschen; + satzzaehler INCR 1 + END IF + END IF; + IF NOT test erfolgreich THEN + weiter (modus) + END IF . + +END PROC trage intern; + +PROC tragen vorbereiten (TEXT CONST dateiname) : + + IF dateiende THEN + errorstop (kein satz vorhanden) + END IF; + oeffne (zieldatei, dateiname); + anzahl eindeutiger felder := 0; + IF felderzahl (zieldatei) = 0 THEN + zieldatei einrichten + ELIF felderzahl (zieldatei) <> anzahl felder THEN + errorstop (falsche felderzahl) + END IF; + auf satz (zieldatei, saetze (zieldatei) + 1) . + +zieldatei einrichten : + satz initialisieren (tragsatz, anzahl felder); + INT VAR feldnr; + FOR feldnr FROM 1 UPTO anzahl felder REP + feldnamen lesen (feldnr, feldpuffer); + feld aendern (tragsatz, feldnr, feldpuffer) + END REP; + feldnamen aendern (zieldatei, tragsatz) . + +END PROC tragen vorbereiten; + +PROC trage einzelsatz : + + IF anzahl eindeutiger felder > 0 CAND schon vorhanden THEN + protokolliere ("", bereits vorhanden) + ELSE + tragsatz aufbauen; + satz einfuegen (zieldatei, tragsatz); + weiter (zieldatei) + END IF . + +tragsatz aufbauen : + satz initialisieren (tragsatz, anzahl felder); + INT VAR feldnr; + FOR feldnr FROM 1 UPTO anzahl felder REP + feld lesen (feldnr, feldpuffer); + feld aendern (tragsatz, feldnr, feldpuffer) + END REP . + +schon vorhanden : + TEXT VAR muster; + INT CONST alte satznummer := satznr (zieldatei); + feld lesen (1, muster); + uebereinstimmung := FALSE; + auf satz (zieldatei, muster); + WHILE NOT dateiende (zieldatei) REP + teste auf uebereinstimmung; + weiter (zieldatei, muster) + UNTIL uebereinstimmung END REP; + auf satz (zieldatei, alte satznummer); + uebereinstimmung . + +teste auf uebereinstimmung : + INT VAR i; + uebereinstimmung := TRUE; + FOR i FROM 2 UPTO anzahl eindeutiger felder REP + feld lesen (zieldatei, i, feldpuffer); + feld bearbeiten (i, + PROC (TEXT CONST, INT CONST, INT CONST) felduebereinstimmung); + IF NOT uebereinstimmung THEN + LEAVE teste auf uebereinstimmung + END IF + END REP . + +END PROC trage einzelsatz; + +PROC felduebereinstimmung (TEXT CONST satz, INT CONST von, bis) : + + IF laengen ungleich COR + (length (feldpuffer) > 0 CAND text ungleich) THEN + uebereinstimmung := FALSE + END IF . + +laengen ungleich : + (bis - von + 1) <> length (feldpuffer) . + +text ungleich : + pos (satz, feldpuffer, von, bis + 1) <> von . + +END PROC felduebereinstimmung; + +PROC protokolliere (TEXT CONST feld, meldung) : + + IF testen THEN + in protokoll + ELSE + errorstop (meldung) + END IF . + +in protokoll : + put (protokoll, t satz); put (protokoll, satznummer); + IF feld <> "" THEN + write (protokoll, t das feld); + write (protokoll, textdarstellung (feld)) + END IF; + putline (protokoll, meldung); + test erfolgreich := FALSE . + +END PROC protokolliere; + +PROC eindeutige felder (INT CONST anzahl) : + + anzahl eindeutiger felder := anzahl + +END PROC eindeutige felder; + +PROC pruefe (TEXT CONST feld, BOOL CONST bedingung) : + + IF NOT bedingung THEN + protokolliere (feld, verletzt die pruefbedingung) + END IF + +END PROC pruefe; + +PROC wertemenge (TEXT CONST feld, menge) : + + INT CONST nr := feldnummer (feld); + IF nr = 0 THEN + protokolliere (feld, nicht definiert) + ELSE + pruefe ob enthalten + END IF . + +pruefe ob enthalten : + INT VAR stelle := 0; + LET komma = ","; + feld lesen (nr, feldpuffer); + IF ist letztes element THEN + LEAVE pruefe ob enthalten + END IF; + feldpuffer CAT komma; + REP + stelle := pos (menge, feldpuffer, stelle + 1); + IF stelle = 1 OR + stelle > 1 CAND (menge SUB stelle - 1) = komma THEN + LEAVE pruefe ob enthalten + END IF + UNTIL stelle = 0 END REP; + protokolliere (feld, nicht in wertemenge) . + +ist letztes element : + INT CONST letzter anfang := length (menge) - length (feldpuffer); + (menge SUB letzter anfang) = komma AND + pos (menge, feldpuffer, letzter anfang + 1) > 0 . + +END PROC wertemenge; + +PROC feldmaske (TEXT CONST feld, maske) : + + INT CONST nr := feldnummer (feld); + IF nr = 0 THEN + protokolliere (feld, nicht definiert) + ELSE + feld lesen (nr, feldpuffer); + mit maske vergleichen + END IF . + +mit maske vergleichen : + INT VAR stelle; + TEXT CONST ende := code (length (maske) + 1); + TEXT VAR moegliche positionen := ""1""; + FOR stelle FROM 1 UPTO length (feldpuffer) REP + TEXT CONST zeichen := feldpuffer SUB stelle; + zeichen vergleichen + UNTIL moegliche positionen = "" END REP; + IF nicht erfolgreich THEN + protokolliere (feld, passt nicht zu maske) + END IF . + +zeichen vergleichen : + INT VAR moeglich := 1; + WHILE moeglich <= length (moegliche positionen) REP + INT CONST position := code (moegliche positionen SUB moeglich); + IF (maske SUB position) = "*" THEN + stern behandeln + ELIF vergleich trifft zu THEN + replace (moegliche positionen, moeglich, code (position + 1)); + moeglich INCR 1 + ELSE + delete char (moegliche positionen, moeglich) + END IF + END REP . + +stern behandeln : + IF position = length (maske) THEN + LEAVE feldmaske + END IF; + moeglich INCR 1; + IF pos (moegliche positionen, code (position + 1)) = 0 THEN + insert char (moegliche positionen, code (position + 1), moeglich) + END IF . + +vergleich trifft zu : + SELECT pos ("9XAa", maske SUB position) OF + CASE 1 : pos ("0123456789", zeichen) > 0 + CASE 2 : TRUE + CASE 3 : pos ("ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜ", zeichen) > 0 + CASE 4 : pos ("abcdefghijklmnopqrstuvwxyzäöüß", zeichen) > 0 + OTHERWISE (maske SUB position) = zeichen + END SELECT . + +nicht erfolgreich : + (moegliche positionen = "" COR pos (moegliche positionen, ende) = 0) + AND nicht gerade stern am ende . + +nicht gerade stern am ende : + (maske SUB length (maske)) <> "*" OR + pos (moegliche positionen, code (length (maske))) = 0 . + +END PROC feldmaske; + +PROC trage satz (TEXT CONST dateiname) : + + tragen vorbereiten (dateiname); + INT CONST alter satz := satznr (zieldatei); + trage einzelsatz; + satz loeschen; + auf satz (zieldatei, alter satz) + +END PROC trage satz; + +PROC hole satz (TEXT CONST dateiname) : + + teste ob datei vorhanden; + IF NOT exists (dateiname) THEN + errorstop (textdarstellung (dateiname) + existiert nicht) + END IF; + oeffne (zieldatei, dateiname); + IF felderzahl (zieldatei) <> anzahl felder THEN + errorstop (falsche felderzahl) + ELIF saetze (zieldatei) = 0 THEN + errorstop (kein satz vorhanden) + END IF; + auf satz (zieldatei, saetze (zieldatei)); + satz lesen (zieldatei, tragsatz); + tragsatz einfuegen; + satz loeschen (zieldatei) . + +tragsatz einfuegen : + satz einfuegen; + INT VAR feldnr; + FOR feldnr FROM 1 UPTO felderzahl (tragsatz) REP + feld lesen (tragsatz, feldnr, feldpuffer); + feld aendern (feldnr, feldpuffer) + END REP . + +END PROC hole satz; + +END PACKET verarbeitung; + |