path: root/menugenerator/ls-Menu-Generator 1

(* 
        
          ********************************************************* 
          ********************************************************* 
          **                                                     ** 
          **                 ls-Menu-Generator 1                 ** 
          **                                                     ** 
          **                     Version 1.0                     ** 
          **                                                     ** 
          **                  (Stand: 30.03.88)                  ** 
          **                                                     ** 
          **                                                     ** 
          **         Autor: Wolfgang Weber, Bielefeld            ** 
          **                                                     ** 
          **                                                     ** 
          ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld ** 
          **                                                     ** 
          ** Copyright (C) 1988 ERGOS GmbH, Siegburg             ** 
          **                                                     ** 
          ********************************************************* 
          ********************************************************* 
 
                                                                           *) 
 
PACKET ls menu generator 1 DEFINES
       textprozedur,
       textzeile:
LET maxzeilenzahl     =   14,
    maxzeichenzahl    =   65,
    zentrierkennung   =  "%",
    beginmarkkennung  =  "$",
    endmarkkennung    =  "&",
    unblockkennung    =  "�",
    blank             =  " ",
    dateikennung      = ".a";
LET dateieintrag      = "#type (""10"")##limit (16.5)#",
    stdfonttabelle    = "fonttab.ls-Menu-Generator";
ROW 3 TEXT CONST fehlermeldung :: ROW 3 TEXT : (
"existiert nicht!",

""15"Text ist zu lang - bitte kürzen! "14"",
""15"Zeilenformatierung mit <ESC> abgebrochen! "14""
);
ROW 6 TEXT CONST hinweis :: ROW 6 TEXT : (
"Bitte warten ...",
"Zulässige    Zeilenzahl: ",
"Tatsächliche Zeilenzahl: ",
"Textlänge ist in Ordnung!",
"Textprozedur ist erstellt!",
"Textzeile ist erstellt!"
);
PROC textprozedur (TEXT CONST dateiname, prozedurname):
  BOOL VAR mit fehler;
  formatiere (dateiname, mit fehler);
  IF mit fehler
     THEN errorstop (fehlermeldung [3])
  FI;

  bereite den text auf (dateiname);
  erzeuge textprozedur (dateiname, prozedurname);
  out (""7""); out (hinweis [5]);
  last param (dateiname + dateikennung)
END PROC textprozedur;
PROC textzeile (TEXT CONST dateiname):
  BOOL VAR mit fehler;
  formatiere (dateiname, mit fehler);
  IF mit fehler
     THEN errorstop (fehlermeldung [3])
  FI;
  bereite den text auf (dateiname);
  erzeuge textzeile    (dateiname);
  out (""7""); out (hinweis [6]);
  last param (dateiname + dateikennung)

END PROC textzeile;
PROC gib wartehinweis:
  page;
  out (hinweis [1])
END PROC gib wartehinweis;
PROC formatiere (TEXT CONST dateiname, BOOL VAR mit fehler):
  TEXT VAR fonttabelle, zeileninhalt;
  kontrolliere existenz;
  stelle fonttabelle ein;
  schreibe font in die datei;
  zeilenformatierung;
  entferne ggf font aus der datei;
  stelle fonttabelle zurueck;
  streiche restleerzeilen weg;
  untersuche ggf datei auf korrektheit.
  kontrolliere existenz:
    IF NOT exists (dateiname)

       THEN page; errorstop ("'" + dateiname + "' " + fehlermeldung [1])
    FI.
  stelle fonttabelle ein:
    gib wartehinweis;
    fonttabelle := fonttable;
    fonttable (stdfonttabelle).
  schreibe font in die datei:
    FILE VAR datei :: sequential file (modify, dateiname);
    to line (datei, 1);
    insert record (datei);
    write record (datei, dateieintrag + blank).
  zeilenformatierung:
    disable stop;
    lineform (dateiname);
    IF is error
       THEN clear error;

            mit fehler := TRUE
       ELSE mit fehler := FALSE
    FI;
    enable stop.
  entferne ggf font aus der datei:
    to line (datei, 1);
    read record (datei, zeileninhalt);
    IF pos (zeileninhalt, dateieintrag) > 0
       THEN delete record (datei)
    FI.
  stelle fonttabelle zurueck:
    fonttable (fonttabelle).
  streiche restleerzeilen weg:
    REP
      streiche ggf letzte zeile
    UNTIL zeile ist nicht leer PER.
  streiche ggf letzte zeile:
    to line (datei, lines (datei));

    read record (datei, zeileninhalt);
    IF compress (zeileninhalt) = ""
       THEN delete record (datei)
    FI.
  zeile ist nicht leer:
    compress (zeileninhalt) <> "".
  untersuche ggf datei auf korrektheit:
    IF NOT mit fehler
       THEN untersuche zeilenzahl
    FI.
  untersuche zeilenzahl:
    IF lines (datei) > maxzeilenzahl
       THEN page;
            out (hinweis [2] + text (maxzeilenzahl)); line;
            out (hinweis [3] + text (lines (datei))); line (2);
            errorstop (fehlermeldung [2])

       ELSE page;
            out (hinweis [4])
    FI.
END PROC formatiere;
PROC bereite den text auf (TEXT CONST dateiname):
  INT  VAR zaehler;
  TEXT VAR zeileninhalt;
  FILE VAR f :: sequential file (modify, dateiname);
  gib wartehinweis;
  vernichte ggf aufbereitete datei;
  richte datei neu ein;
  uebertrage die zeilen.
  vernichte ggf aufbereitete datei:
    IF exists (dateiname + dateikennung)
       THEN forget (dateiname + dateikennung, quiet)
    FI.
  richte datei neu ein:

    FILE VAR aus :: sequential file (output, dateiname + dateikennung).
  uebertrage die zeilen:
    FOR zaehler FROM 1 UPTO lines (f) REP
      bereite eine zeile auf
    PER.
  bereite eine zeile auf:
    to line (f, zaehler);
    read record (f, zeileninhalt);
    ersetze alle gaensefuesschen;
    haenge ggf absatzmarke an;
    behandle zeile;
    putline (aus, zeileninhalt).
  ersetze alle gaensefuesschen:
    change all (zeileninhalt, """", "'").
  haenge ggf absatzmarke an:
    IF (zeileninhalt SUB (length (zeileninhalt))) = blank

       THEN IF (zeileninhalt SUB 1) <> zentrierkennung
               THEN zeileninhalt CAT unblockkennung
            FI
    FI.
  behandle zeile:
    IF   zeile soll zentriert werden
         THEN zentriere zeile
    ELIF zeile ist leerzeile
         THEN kennzeichne leerzeile
    ELSE blocke zeile auf stdlaenge
    FI.
  zeile soll zentriert werden:
    (zeileninhalt SUB 1) = zentrierkennung.
  zeile ist leerzeile:
    compress (zeileninhalt) = "".
  zentriere zeile:
    zeileninhalt := subtext (zeileninhalt, 2);

    zeileninhalt := anfangsblanks + zeileninhalt;
    zeilenabschluss.
  anfangsblanks:
    ((maxzeichenzahl - length (zeileninhalt)) DIV 2) * blank.
  zeilenabschluss:
    ersetze markierungszeichen;
    setze 13.
  ersetze markierungszeichen:
    change all (zeileninhalt, beginmarkkennung, """15""");
    change all (zeileninhalt, endmarkkennung,    """14""").
  setze 13:
    zeileninhalt CAT " ""13""".
  kennzeichne leerzeile:
    zeileninhalt := """13""".
  blocke zeile auf stdlaenge:

    IF zeile darf nicht geblockt werden
       THEN ersetze endezeichen
       ELSE fuehre blockung aus
    FI.
  zeile darf nicht geblockt werden:
    (zeileninhalt SUB length (zeileninhalt)) = unblockkennung.
  ersetze endezeichen:
    zeileninhalt := subtext (zeileninhalt, 1, length (zeileninhalt) - 1);
    ersetze markierungszeichen;
    setze 13.
  fuehre blockung aus:
    ROW maxzeichenzahl INT VAR leerzeichen;
    INT VAR gezaehlte blanks, zu verteilende blanks;
    ordne anfangswerte zu;

    verteile blanks gleichmaessig;
    verteile blanks zufaellig;
    baue zeile zusammen;
    ersetze markierungszeichen;
    setze 13.
  ordne anfangswerte zu:
    bestimme blankanzahl in der zeile;
    bestimme zu verteilende blanks;
    initialisiere die reihung.
  bestimme blankanzahl in der zeile:
    gezaehlte blanks := 0;
    INT VAR zeiger;
    FOR zeiger FROM 1 UPTO length (zeileninhalt) REP
      IF (zeileninhalt SUB zeiger) = blank
         THEN gezaehlte blanks INCR 1

      FI
    PER.
  bestimme zu verteilende blanks:
    zu verteilende blanks := maxzeichenzahl - length (zeileninhalt).
  initialisiere die reihung:
    FOR zeiger FROM 1 UPTO gezaehlte blanks REP
      leerzeichen [zeiger] := 1
    PER.
  verteile blanks gleichmaessig:
    WHILE (zu verteilende blanks DIV gezaehlte blanks) > 0 REP
      schlag je ein blank auf;
      zu verteilende blanks DECR gezaehlte blanks
    PER.
  schlag je ein blank auf:
    FOR zeiger FROM 1 UPTO gezaehlte blanks REP

      leerzeichen [zeiger] INCR 1
    PER.
  verteile blanks zufaellig:
    FOR zeiger FROM 1 UPTO zu verteilende blanks REP
      leerzeichen [random (1, gezaehlte blanks)] INCR 1
    PER.
  baue zeile zusammen:
    TEXT VAR zwischen        := zeileninhalt;
    INT  VAR aktuelles blank := 0;
    zeileninhalt             := "";
    FOR zeiger FROM 1 UPTO length (zwischen) REP
      TEXT VAR aktuelles zeichen :: (zwischen SUB zeiger);
      IF aktuelles zeichen = blank
         THEN aktuelles blank INCR 1;

              zeileninhalt CAT (leerzeichen [aktuelles blank] * blank)
         ELSE zeileninhalt CAT aktuelles zeichen
      FI
    PER
END PROC bereite den text auf;
PROC erzeuge textprozedur (TEXT CONST dateiname, prozedurname):
  mache aus den zeilen einzeltexte;
  entferne ueberfluessige restzeilen;
  erstelle eine textprozedur.
  mache aus den zeilen einzeltexte:
    INT  VAR zeiger;
    FILE VAR ausdatei :: sequential file (modify, dateiname + dateikennung);
    FOR zeiger FROM 1 UPTO lines (ausdatei) REP

      bearbeite eine zeile
    PER.
  bearbeite eine zeile:
    TEXT VAR zeileninhalt;
    to line (ausdatei, zeiger);
    read record (ausdatei, zeileninhalt);
    zeileninhalt := """ " + zeileninhalt + """ +";
    change all (zeileninhalt, "­", "-");
    write record (ausdatei, zeileninhalt).
  entferne ueberfluessige restzeilen:
    REP
      entferne ggf eine zeile
    UNTIL zeileninhalt <> """   ""13"""" +" PER;
    entferne return aus letzter zeile.
  entferne ggf eine zeile:

    IF compress (zeileninhalt) = """   ""13"""" +"
       THEN delete record (ausdatei)
    FI.
  entferne return aus letzter zeile:
    to line (ausdatei, lines (ausdatei));
    read record (ausdatei, zeileninhalt);
    zeileninhalt := subtext (zeileninhalt, 1, length (zeileninhalt) - 6);
    write record (ausdatei, zeileninhalt).
  erstelle eine textprozedur:
    schreibe procanfang;
    schreibe procende.
  schreibe procanfang:
    to line (ausdatei, 1);
    insert record (ausdatei);

    write record (ausdatei, "TEXT PROC " + prozedurname + ":").
  schreibe procende:
    to line (ausdatei, lines (ausdatei) + 1);
    insert record (ausdatei);
    write record (ausdatei, "END PROC " + prozedurname + ";").
END PROC erzeuge textprozedur;
PROC erzeuge textzeile (TEXT CONST dateiname):
  entferne ueberfluessige restzeilen;
  entferne return aus letzter zeile;
  erstelle eine textzeile.
  entferne ueberfluessige restzeilen:
    TEXT VAR zeileninhalt;
    INT VAR zeiger;

    FILE VAR ausdatei :: sequential file (modify, dateiname + dateikennung);
    REP
      entferne ggf eine zeile
    UNTIL compress (zeileninhalt) <> """13""" PER.
  entferne ggf eine zeile:
    to line (ausdatei, lines (ausdatei));
    read record (ausdatei, zeileninhalt);
    IF compress (zeileninhalt) = """13"""
       THEN delete record (ausdatei)
    FI.
  entferne return aus letzter zeile:
    to line (ausdatei, lines (ausdatei));
    read record (ausdatei, zeileninhalt);
    change all (zeileninhalt, """13""", "");

    write record (ausdatei, zeileninhalt).
  erstelle eine textzeile:
    haenge die zeilen aneinander;
    fasse zeile in gaensefuesschen;
    schreibe einzelzeile in ausgabedatei.
  haenge die zeilen aneinander:
    TEXT VAR zeile :: "";
    FOR zeiger FROM 1 UPTO lines (ausdatei) REP
      to line (ausdatei, zeiger);
      read record (ausdatei, zeileninhalt);
      zeile CAT (" " + zeileninhalt)
    PER.
  fasse zeile in gaensefuesschen:
    zeile := """" + zeile + """";
    change all (zeile, "­","-").

  schreibe einzelzeile in ausgabedatei:
    forget (dateiname + dateikennung, quiet);
    FILE VAR fertig :: sequential file (modify, dateiname + dateikennung);
    to line (fertig, 1);
    insert record (fertig);
    write record (fertig, zeile)
END PROC erzeuge textzeile;
END PACKET ls menu generator 1;