PROGRAM av; { Adress-Verwaltung }

CONST kapazitaet = 1000;

TYPE adresse = RECORD
                 name,
                 vorname,
                 strasse  : STRING [20];
                 plz      : STRING [4];
                 wohnort  : STRING [20];
                 geb      : STRING [8];
                 beruf    : STRING [20];
                 telefon  : STRING [12]
               END;
      index  = RECORD
                 indexname   : STRING [12];
                 indexnummer : integer
               END;
      zeile  = STRING [255];
      zeichenmenge = SET OF char;

CONST reczahl = 8;
      maske   : ARRAY [1..reczahl] OF RECORD
                                        xp, yp : byte;
                                        m      : STRING [80];
                                        l      : byte
                                      END
      =((xp :  1; yp : 3; m : 'Name : ';         l : 20),
        (xp : 40; yp : 3; m : 'Vorname : ';      l : 20),
        (xp :  1; yp : 5; m : 'Strasse : ';      l : 20),
        (xp : 35; yp : 5; m : 'PLZ : ';          l :  4),
        (xp : 50; yp : 5; m : 'Wohnort : ';      l : 20),
        (xp :  1; yp : 7; m : 'Geburtsdatum : '; l :  8),
        (xp :  1; yp : 9; m : 'Beruf : ';        l : 20),
        (xp : 40; yp : 9; m : 'Telefon : ';      l : 12));

VAR  adr1          : adresse;
     ind1          : index;
     indexfeld     : ARRAY [1..kapazitaet] OF index;
     indexfile     : FILE OF index;
     indexgroesse,
     indexzeiger,
     filegroesse   : integer;
     adrfile       : FILE OF adresse;
     wahl          : char;

{$I maske.inc  Masken-Ein/Aus-gabe von Records }

{====================================================================}

PROCEDURE status (meldung : zeile; auswahl : zeichenmenge;
                  VAR gewaehlt : char);

BEGIN { status }
  gotoxy (1,23);
  clreol;
  write (meldung, ': ');
  REPEAT
    read (kbd, gewaehlt);
    gewaehlt := upcase (gewaehlt)
  UNTIL gewaehlt IN auswahl;
  write (gewaehlt)
END;  { status }

{====================================================================}
PROCEDURE schreibadr (adr : adresse; num : integer);

BEGIN { schreibadr }
  assign (adrfile, 'adr.dat');
  {$I-}
  reset (adrfile);
  {$I+}
  IF ioresult <> 0
    THEN
      rewrite (adrfile);
  seek (adrfile, num-1);
  write (adrfile, adr);
  close (adrfile)
END;  { schreibadr }

{====================================================================}

PROCEDURE liesadr (num : integer; VAR adr : adresse);

BEGIN { liesadr }
  assign (adrfile, 'adr.dat');
  {$I-}
  reset (adrfile);
  IF ioresult = 0
    THEN
      BEGIN
        seek (adrfile, num-1);
        IF ioresult = 0
         THEN
           read (adrfile, adr)
      END;
  {$I+}
  close (adrfile)
END;  { liesradr }

{====================================================================}

PROCEDURE liesfilegroesse (VAR groesse : integer);

BEGIN { liesfilegroesse }
  groesse := 0;
  assign (adrfile, 'adr.dat');
  {$I-}
  reset (adrfile);
  {$i+}
  IF ioresult = 0
    THEN
      groesse := filesize (adrfile);
  close (adrfile)
END;  { liesfilegroesse }

{====================================================================}

PROCEDURE liesindexfile (VAR groesse : integer);

BEGIN { liesindexfile }
  groesse := 0;
  assign (indexfile, 'adr.ind');
  {$I-}
  reset (indexfile);
  {$I+}
  IF ioresult = 0
    THEN
      WHILE NOT eof (indexfile) DO
        BEGIN
          groesse := succ (groesse);
          read (indexfile, indexfeld [groesse])
        END;
  close (indexfile)
END;  { liesindexfile }

{====================================================================}

PROCEDURE schreibindexfile (groesse : integer);

VAR zaehler : integer;

BEGIN { schreibindexfile }
  assign (indexfile, 'adr.ind');
  rewrite (indexfile);
  FOR zaehler := 1 TO groesse DO
    write (indexfile, indexfeld [zaehler]);
  close (indexfile)
END;  { schreibindexfile }

{====================================================================}

PROCEDURE machindex (adr : adresse; num : integer; VAR ind : index);

BEGIN { machindex }
  ind.indexname := copy (adr.name+'          ', 1, 10)+
                   copy (adr.vorname+'  ',1 ,2);
  ind.indexnummer := num
END;  { machindex }

{====================================================================}

PROCEDURE suchindex (ind : index; VAR zeiger : integer);

VAR i, j, m : integer;

BEGIN { suchindex }
  i := 1;
  j := indexgroesse;
  REPEAT
    m := (i+j) DIV 2;
    IF ind.indexname <= indexfeld [m].indexname
      THEN
        j := m
      ELSE
        i := m+1
  UNTIL i =j;
  zeiger := i
END;  { suchindex }

{====================================================================}

PROCEDURE sortindex (von, bis : integer);

{ Modifizeirter, nichtrekursiver Quicksort mit eigenem Stack. }

TYPE lifo      = ^lifoliste;
     lifoliste = RECORD
                   v, b : integer;
                   last : lifo
                 END;

VAR  m         : index;
     i, j      : integer;
     stack     : lifo;

{--------------------------------------------------------------------}

PROCEDURE push (von, bis : integer);

VAR  p : lifo;

BEGIN { push }
  new (p);
  p^.v := von;
  p^.b := bis;
  p^.last := stack;
  stack := p
END;  { push }

{--------------------------------------------------------------------}

PROCEDURE pop (VAR von, bis : integer);

VAR  p : lifo;

BEGIN { pop }
  p := stack;
  von := p^.v;
  bis := p^.b;
  stack := p^.last;
  dispose (p)
END;  { pop }

{--------------------------------------------------------------------}

PROCEDURE vertausche (d1, d2 : integer);

VAR  temp : index;

BEGIN { vertausche }
  temp := indexfeld [d1];
  indexfeld [d1] := indexfeld [d2];
  indexfeld [d2] := temp
END;  { vertausche }

{--------------------------------------------------------------------}

FUNCTION kleiner (x, y : index) : boolean;

BEGIN { kleiner }
  kleiner := x.indexname < y.indexname
END;  { kleiner }

{--------------------------------------------------------------------}

PROCEDURE esort (von, bis : integer);
{ Einfuege-Sort fuer kleine Listen. }

VAR  i, j, m : integer;

BEGIN { esort }
  FOR i := von TO bis-1 DO
    BEGIN
      m := i;
      FOR j := i+1 TO bis DO
        IF kleiner (indexfeld [j], indexfeld [m])
          THEN
            m := j;
      IF m <> i
        THEN
          vertausche (i, m)
    END
END;  { esort }

{--------------------------------------------------------------------}

BEGIN { sortindex }
  stack := NIL;
  push (von, bis);
  REPEAT
    pop (von, bis);
    IF bis-von < 7
      THEN
        esort (von, bis)
      ELSE
        BEGIN
          i := von; j := bis;
          m := indexfeld [(i+j) DIV 2];
          REPEAT
            WHILE kleiner (indexfeld [i], m) DO
              i := succ (i);
            WHILE kleiner (m, indexfeld [j]) DO
              j := pred (j);
            IF i <= j
              THEN
                BEGIN
                  vertausche (i, j);
                  i := succ (i);
                  j := pred (j)
                END
          UNTIL i > j;
          IF i < bis
            THEN push (i, bis);
          IF j > von
            THEN push (von, j)
        END
  UNTIL stack = NIL
END;  { sortindex }

{====================================================================}

PROCEDURE neueingabe;

VAR wahl : char;

BEGIN { neueingabe }
  clrscr;
  REPEAT
    status ('E)ingabe, Q)uit ', ['E', 'Q'], wahl);
    IF wahl = 'E'
      THEN
        BEGIN
          fillchar (adr1, sizeof (adr1), 0);
          liesrecord (adr1, maske, reczahl);
          filegroesse := succ (filegroesse);
          indexgroesse := succ (indexgroesse);
          machindex (adr1, filegroesse, ind1);
          indexfeld [indexgroesse] := ind1;
          schreibadr (adr1, filegroesse)
        END
  UNTIL wahl = 'Q';
  sortindex (1, indexgroesse)
END;  { neueingabe }

{====================================================================}

PROCEDURE update;

VAR indexzeiger  : integer;
    wahl, janein : char;
    veraendert   : boolean;

{--------------------------------------------------------------------}

PROCEDURE kill (ind : index; VAR groesse : integer);

VAR i : integer;

BEGIN { kill }
  i := 1;
  WHILE i <= groesse DO
    IF indexfeld [i].indexname = ind.indexname
      THEN
        BEGIN
          indexfeld [i] := indexfeld [groesse];
          groesse := pred (groesse)
        END
      ELSE
        i := succ (i)
END;  { kill }

{--------------------------------------------------------------------}

BEGIN { update }
  clrscr;
  veraendert := true;
  indexzeiger := indexgroesse;
  REPEAT
    IF veraendert
      THEN
        BEGIN
          liesadr (indexfeld [indexzeiger].indexnummer, adr1);
          schreibrecord (adr1, maske, reczahl);
          veraendert := false
        END;
    status ('S)uchen, V)or, Z)urueck, E)ditieren, L)oeschen, Q)uit ',
            ['S','V', 'Z', 'E', 'L', 'Q'], wahl);
    CASE wahl OF
      'Z' : IF indexzeiger > 1
              THEN
                BEGIN
                  indexzeiger := pred (indexzeiger);
                  veraendert := true
                END
              ELSE
                write (#7);
      'V' : IF indexzeiger < indexgroesse
              THEN
                BEGIN
                  indexzeiger := succ (indexzeiger);
                  veraendert := true
                END
              ELSE
                write (#7);
      'S' : BEGIN
              gotoxy (1, 21);
              write ('Name : ');
              read (adr1.name);
              write (', Vorname : ');
              read (adr1.vorname);
              gotoxy (1, 21);
              clreol;
              machindex (adr1, 0, ind1);
              suchindex (ind1, indexzeiger);
              veraendert := true
            END;
      'E' : BEGIN
              liesrecord (adr1, maske, reczahl);
              machindex(adr1,indexfeld[indexzeiger].indexnummer,ind1);
              indexfeld [indexzeiger] := ind1;
              schreibadr (adr1, ind1.indexnummer);
              sortindex (1, indexgroesse);
              veraendert := true
            END;
      'L' : BEGIN
              gotoxy (1, 21);
              write ('Wirklich loeschen (J/N) ?');
              REPEAT read (kbd, janein)
              UNTIL upcase (janein) IN ['J', 'N'];
              IF upcase (janein) = 'J'
                THEN
                  BEGIN
                    machindex (adr1,
                          indexfeld [indexzeiger].indexnummer, ind1);
                    kill (ind1, indexgroesse);
                    sortindex (1, indexgroesse);
                    veraendert := true
                  END;
              gotoxy (1, 21);
              clreol
            END
    END
  UNTIL wahl = 'Q'
END;  { update }

{====================================================================}

PROCEDURE ausgabe;

VAR i    : integer;
    f    : text;
    wahl : char;

BEGIN { ausgabe }
  clrscr;
  status ('B)ildschirm, D)rucker ', ['B', 'D'], wahl);
  IF wahl = 'B'
    THEN
      assign (f, 'CON:')
    ELSE
      assign (f, 'LST:');
  rewrite (f);
  writeln;
  IF wahl = 'B'
    THEN
      clrscr;
  FOR i := 1 TO indexgroesse DO
    BEGIN
      liesadr (indexfeld [i].indexnummer, adr1);
      WITH adr1 DO
        BEGIN
          writeln (f, name, ', ', vorname, ', ', beruf);
          writeln (f, strasse, ', ', plz, ' ', wohnort, ', Tel: ',
                      telefon);
          writeln (f)
        END
    END;
  write ('RETURN ');
  readln;
  close (f)
END;  { ausgabe }

{====================================================================}

BEGIN { av }
  liesindexfile (indexgroesse);
  liesfilegroesse (filegroesse);
  writeln (indexgroesse:6, filegroesse:6);
  REPEAT
    clrscr;
    writeln ('Adressen-Verwaltung');
    writeln ('-------------------');
    writeln;
    writeln (kapazitaet-indexgroesse, ' Eintraege frei.');
    status ('N)eueingabe, U)pdate, A)usgabe, Q)uit ',
            ['N', 'U', 'A', 'Q'], wahl);
    CASE wahl OF
      'N' : IF indexgroesse < kapazitaet
              THEN
                neueingabe
              ELSE
                write (#7);
      'U' : IF indexgroesse > 0
              THEN
                update
              ELSE
                write (#7);
      'A' : ausgabe
    END
  UNTIL wahl = 'Q';
  schreibindexfile (indexgroesse)
END.  { av }