Program AddrMat;

{  Eine kleine Adressdatei.           }
{                                     }
{  Geschrieben von :                  }
{  Jens "Himpel" Gelhar 1989          }
{  als Demo für Himpel-/Kickpascal    }

{ MaxonPascal3-Anpassung / Test:   Falk Zühlsdorff (PackMAN) 1994 }

{ Dieses Programm demonstriert u. a. die Ein-/Ausgabeoperationen.
  Um die Anwendung der Dateibefehle zu zeigen, wird die Datei
  nicht in den Speicher geladen, sondern ausschließlich auf der
  Disk bearbeitet. Dies schränkt die Möglichkeiten des Programms
  natürlich stark ein.                                            }


Label Ende1;
  { Labels sollten nur verwendet werden, wenn der "normale"
    Programmablauf unterbrochen wird. Das Label 'Ende1' steht
    kurz vor dem Ende des Hauptprogramms und wird angesprungen,
    wenn bei der Eingabe des Dateinamens ESC gedrückt wird.     }


Const
  CSI = chr($9b);       { Steuersequenzen-Einleiter }

  CrsrUp   = chr(1);    { Da bei Betätigung der Cursortasten            }
  CrsrDown = chr(2);    { ganze Escape-Sequenzen gesendet werden, die   }
  CrsrLeft = chr(3);    { umständlich zu handhaben sind, werden sie     }
  CrsrRigth= chr(4);    { von der GETKEY-Prozedur in diese Codes gewandelt. }
  BackSpace= chr(8);
  LF       = chr(10);
  CR       = chr(13);
  Esc      = chr(27);
  Del      = chr($7f);

Type
  Anrede = (Herr, Frau, Firma, Ungueltig);

  Person=Record         { der Hauptdatentyp }
           Anr: Anrede;
           VName,NName: String[30]
           Telefon: String[20]
           Strasse: String[30]
           Hausnr:  integer
           Plz:     0..9999
           Ort:     String[12];
         End;

  Datei = File of Person;

  StrTyp = String;      { Für Parameterübergaben. Denn: "String" ist }
                        { kein Typbezeichner, sondern ein Symbol!    }

Var
  fname: StrTyp;        { Dateiname }
  f: Datei;             { die Datei }
  fs: Long;             { Speicher für "filesize(f)" }
  Menu: Char;           { Im Hauptmenü eingegebenes Zeichen }
  Win, Con: Ptr;        { Windowhandle und Console-Device }
  Out: String;          { Ausgabepuffer für "WriteCon" }


Procedure WriteC(s: Str);
  { String "s" über Console.device ausgeben }
  Begin
    WriteCon(con,s)
  End;


Procedure SetXY(x,y: integer);
  { GotoXY-Ersatz für ConDevice }
  Var h: String;
  Begin
    h := CSI + IntStr(y) + ';' + intStr(x) + 'H';
    WriteCon(Con,h)
  End;


Function WaitKey: Char;
  { Auf Tastencode warten und zurückgeben }
  Var c: Char;
      Sig: Long;
  Begin
    Repeat
      c := ReadCon(Con);
      If c = #0 Then Sig := Wait(-1)
    Until c <> chr(0);
    WaitKey := c
  End;


Function GetKey: Char;
  { Taste lesen und Sequenzen wandeln }
  Var c: Char;

    Procedure CSIHandler;
      Var s: String;
      Begin
        s:='';
        Repeat           { Sequenz zeichenweise lesen }
          s:=s+WaitKey
        Until (Length(s)>=50) or ( s[Length(s)] >= '@');
        If s='A' Then GetKey := CrsrUp          Else
        If s='B' Then GetKey := CrsrDown        Else
        If s='C' Then GetKey := CrsrRigth       Else
        If s='D' Then GetKey := CrsrLeft        Else
                      GetKey := chr(0)
      End;

  Begin
    c := WaitKey;
    If c in [ chr(32).. chr(126), chr(160)..chr(255) ] Then
      GetKey := c       { druckbares Zeichen }
    Else
      Case c Of
        chr(8):  GetKey := BackSpace;
        chr(13): GetKey := CR;
        chr(27): GetKey := Esc;
        chr($7f):GetKey := Del;
        CSI:     CSIHandler;
      Otherwise
        Getkey := chr(0)
      End;
  End;


Procedure FindEnd( Var st: StrTyp, i: integer);
  { Ende von s[1] .. s[i] suchen, mit Nullbyte markieren }
  Begin
    While (i>1) and (st[i]=' ') Do
      i:=pred(i);
    st[ i + ord(st[i]<>' ') ] := chr(0)
  End;


Function LinEd( Var s: Strtyp, x0,y0,max: integer, Var x: integer): Char;
  { String "s" mit der Höchstlänge "max" an Position (x0,y0) edieren. }
  { x: Cursorposition innerhalb Zeile. }
  { zurückgeben: letztes eingegebenes Zeichen (CR, Esc oder Up/Down }
  Var i: integer;
      c: Char;
      ende: Boolean;
  Begin
    SetXY(x0, y0);      { an angegebener Position... }
    writec(s);          { String ausgeben und...     }
    writec(#e'K');      { Rest der Zeile löschen.    }
    For i:=Length(s)+1 to max Do
      s[i]:=' ';        { String mit Spaces auffüllen }
    s[max+1] := chr(0); { ...und mit Nullbyte abschließen. }
    SetXY(x0+x-1, y0);
    ende := false;

    Repeat              { Zeileneditor-Hauptschleife }
      c := GetKey;
      If c in [chr(32)..chr(126), chr(160)..chr(255) ] Then
        If x < max Then
          Begin
            For i:=max DownTo x+1 do    { Platz machen }
              s[i] := s[i-1];
            s[x] := c;                  { und Zeichen einfügen. }
            x := x+1;
            writecon(con, #e'@');       { Ein Zeichen auf Bildschirm einfügen }
            writecon(con, c)            { und Zeichen ausgeben. }
          End
        Else
      Else      { kein darstellbares Zeichen }
        Case c Of
         CR, Esc, CrsrUp, CrsrDown:     { mit diesen Tasten wird der }
                   Ende := true;        { Editor verlassen.          }
         BackSpace:If x>1 Then
                      Begin
                        x:=pred(x);
                        For i:=x to max-1 do s[i] := s[i+1];
                        s[max]:=' ';
                        writecon(con, #8\e'P')
                      End;
         CrsrLeft: If x>1 Then
                      Begin
                        x := pred(x);
                        writecon(con, #e'D')
                      End;
         CrsrRigth: If x<max Then
                      Begin
                        x := succ(x);
                        writecon(con, #e'C')
                      End;
         Del:       Begin
                      For i:=x to max-1 do s[i] := s[i+1];
                      s[max]:=' ';
                      writecon(con, #e'P')
                    End;
        Otherwise End;

    Until ende;

    FindEnd( s , max);  { Spaces am zeilenende abschneiden }
    LinEd := c          { Zeichen zurückgeben }
  End;


Procedure Ausgabe1(p: Person);
  { mit Feldnamen ausgeben }
  Var s:String;
  Begin
    With p do
      Begin
        WriteC('Anrede: (HFG)  ');
          Case Anr Of
            Herr: WriteC("Herr");
            Frau: WriteC("Frau");
            Firma: WriteC("Firma")
          Otherwise End;
        WriteC(#e'K'\10'Vorname:       '); If Anr<>Firma Then WriteC(VName);
        WriteC(#e'K'\10'Nachname:      '); writeC(NName);
        WriteC(#e'K'\10'Telefon:       '); writeC(Telefon);
        WriteC(#e'K'\10'Strasse:       '); writeC(Strasse);
        WriteC(#e'K'\10'Nr.:           '); s := IntStr(HausNr); If HausNr>=0 Then writeC(s);
        WriteC(#e'K'\10'Plz.:          '); s := IntStr(Plz); If plz<>0 Then writeC(s);
        WriteC(#e'K'\10'Ort:           '); writeC(Ort);
      End
  End;


Procedure Edit(Var p:Person);
  Var buf: String;
      Zeile: integer;
      z,s,m: integer;
      c: Char;
  Begin
    SetXY(1,4);
    Ausgabe1(p);
    Zeile:=1;

    Repeat
      If Zeile=1 Then
        Repeat
          SetXY(16,4);
          Case p.Anr Of
            Herr:  writeC("Herr");
            Frau:  writeC("Frau");
            Firma: writeC("Firma");
            Otherwise
          End;
          writeC(#e"K");

          Repeat
            c:=GetKey
          Until Upcase(c) in ["H","F","G",CR,CrsrUp,CrsrDown,Esc];

          Case Upcase(c) Of
           "H": p.Anr := Herr;
           "F": p.Anr := Frau;
           "G": p.Anr := Firma;
           Otherwise;
          End;

        Until (c in [CR, CrsrUp, CrsrDown, Esc]) and (p.Anr<>Ungueltig)
      Else
      If (Zeile=2) and (p.Anr=Firma) Then
        Begin p.VName :=""; SetXY(16,5); writeC(#e'K') End
      Else
        Begin
          With p Do
            Case Zeile Of
            2: Begin z:=29; buf:=VName End;
            3: Begin z:=29; buf:=NName End;
            4: Begin z:=19; buf:=Telefon End;
            5: Begin z:=29; buf:=Strasse End;
            6: Begin z:=20;
                     If HausNr<0 Then buf:='' Else buf:=IntStr(HausNr) End;
            7: Begin z:=20;
                     If Plz<=0 Then buf:='' Else buf:=IntStr(plz) End;
            8: Begin z:=11; buf:=Ort End;
            End;
          s:=1;
          Repeat
            c:=LinEd(buf,16,Zeile+3,z,s);
            If (Zeile=6) and (buf<>'') Then
              Begin
                Val(buf,p.HausNr,m);
                If (m<>0) or (p.HausNr<0) Then c:=" "
              End;
            If (Zeile=7) and (buf<>'') Then
              Begin
                Val(buf,p.Plz,m);
                If (m<>0) or (p.Plz<1000) or (p.Plz>9999) Then c:=" "
              End;
          Until c in [CR, CrsrUp, CrsrDown, Esc];
          With p Do
            Case Zeile Of
            2: VName:=buf;
            3: Nname:=buf;
            4: Telefon:=buf;
            5: Strasse:=buf;
            8: Ort:=buf
            Else
            End;
        End;
      If c in [cr, CrsrDown] Then Zeile:=Zeile+1
      Else
        If c=CrsrUp Then Zeile:=Zeile-1;
    Until (Zeile=9) or (Zeile=0) or (c=Esc);
    writeC(LF)
  End;


Procedure Eingabe(Var p: Person);
  Begin
    WriteC(#12#10'Bitte Daten eingeben!'#10#10);
    With p do
      Begin
        Anr := UnGueltig;
        VName := "";
        NName := "";
        Telefon := "";
        Strasse := "";
        HausNr := -1;
        Plz := 0;
        Ort := "";
      End;
    Edit(p)
  End;


Procedure Ausgabe(p: Person);
  Var s: string[1000];
  Begin
    With p DO
      Begin
        Case Anr of
          Herr: s := 'Herr '+VName
          Frau: s := 'Frau '+VName
          Firma:s := 'Firma '
        Otherwise
          error('Datenfehler!!');
        End;
       s := LF + s + " " + NName + LF + 'Tel. ' + Telefon + LF + Strasse
               + ' ' + IntStr(HausNR) + LF + IntStr(plz) + ' ' + Ort;
       writecon(con,s);
      End
  End;


Procedure Ergänzen;
  Var per: Person;
  Begin
    If Filepos(f)<>Filesize(f) Then
      Seek(f,Filesize(f));
    Eingabe(Per);
    write(f,Per)
  End;

Procedure Blättern;
  Var per: Person;
      i: Long;
      c: Char;
  Begin
    i := 0;
    Repeat
      writeC(LF);
      Seek(f,i);
      read(f,per);
      Out := #12#10"Datensatz Nr. " + IntStr(i+1);
      If eof(f) Then Out := Out + " - Dateiende";
      Out := Out + LF + LF;
      WriteC(Out);
      Ausgabe1(per);
      writeC(#10\10'SPACE=weiter BACKSPACE=zurück RETURN=Edit ESC=Ende : ');
      Repeat
        c := GetKey
      Until c in [" ",Esc,BackSpace,CR];
      Case c Of
       " ":       If i<filesize(f) Then i:=i+1;
       BackSpace: If i>0 Then i:=i-1;
       CR:        Begin SetXY(1,2); WriteC("Edit"\e"K"); Edit(per);
                        Seek(f,i); write(f,per)
                  End;
      Otherwise
      End;
    Until (c=Esc) or (i=Filesize(f))
  End;


Procedure DateiAusgeben;
  Var p1,p2: Person; c:Char; i: integer;
  Begin
    Seek(f,0);
    While not eof(f) Do
      Begin
        read(f,p1);    { get(f); p1:=f^ }
        Ausgabe(p1);
        i:=i+1;
        writecon(con,LF)
      End;
    writecon(con,#10'Bitte Taste drücken!  ');
    While ReadCon(con)<>chr(0) do ;   { "Tastenpuffer" leeren }
    c := GetKey
  End;


Procedure Dateiname;
  Var c: Char;
      L: integer;
      x: integer;
      OK: Boolean;
  Begin
    Repeat
      x := 1;
      fname := '';
      SetXY(1,2);
      writecon(con,'Dateiname: ');
      Repeat
        c:=LinEd(fname,12,2,60,x)
      Until ((fname<>'') and (c=CR)) or (c=Esc);
      If c=Esc Then Goto Ende1;
      WriteCon(con,LF);
      L := Length(fname);
      If L > 4 Then
        If fname[L-3]<>'.' Then
          fname:=fname+'.dat';
      reset(f,fname);
      If IOResult=0 Then
        Exit
      Else
        Begin
          Out := (LF+LF+'Datei '+fname+' existiert nicht.'$a$a'Anlegen? ');
          WriteCon(Con, Out);
          Repeat
            c := GetKey
          Until c in ["J","j","N","n"];
          If Upcase(c)="J" Then
            Begin
              Rewrite(f,fname);
              If IOResult<>0 Then
                 WriteCon(Con, #$0a$0a'Datei konnte nicht angelegt werden.')
              Else
                Begin
                  Close(f);
                  Reset(f,fname);
                  Exit
                End
            End
        End
    Until false
  End;



Begin  { Main }
  Win:=Open_Window(0,0,640,200,1,0,$1006,'Himpels very special Database',Nil,640,200,640,255);
  Con:=OpenConsole(Win);
  Dateiname;
  Repeat
    fs := Filesize(f);
    WriteCon(con,chr(12));    { Bildschirm löschen }
    Case fs of
      0: writecon(con, 'Datei ist leer.');
      1: writecon(con, 'Datei enthält einen Datensatz');
    Otherwise
      Out:='Datei enthält '+IntStr(fs)+' Datensätze';
      writecon(con, Out)
    End;
    writecon(con,''\10\10\&
         \e'33mA'\e'31m  Daten hinzufügen'\10\&
         \e'33mB'\e'31m  Blättern'\10\&
         \e'33mL'\e'31m  Adressliste ausgeben'\10\&
         \e'33mQ'\e'31m  Programmende'\10\10'--> ');

    Menu:=GetKey;

    Case Upcase(Menu) Of
      'A': Ergänzen;
      'B': Blättern;
      'L': DateiAusgeben;
    Otherwise ;
    End;
  Until Upcase(Menu) = 'Q';
  writecon(con,#10#10'Tschüß!');
  Close(f);
Ende1:
  CloseConsole(Con);
  Close_Window(Win);
End.