Program vytvoří oboustranně zrětezený seznam kontaktu

{ ADRESAR.PAS                             Copyright (c) Pavel Patak }
{ Program vytvori oboustranne zretezeny seznam kontaktu,            }
{ je to jen ukazka, chybi vyhledavani, import/export kontaktu,      }
{ v abeceda rozhoduji velka/mala pismena... Nejsou osetreny pripady }
{ blbeho uzivatele - zadani neexistujiciho jmena souboru,           } 
{ ulozeni prazdneho adresare ...                                    }
{                                                                   }
{ Datum:28.10.2004                             http://www.trsek.com }
 
program Adresar;
 
type PSeznam = ^TSeznam;
     TData   = record
                    Jmeno : string[50];
		   Telefon: string[12];
		    Email : string[50];
		   end;
     TSeznam = record
                Data  : TData;
            Predchozi : PSeznam;
                Dalsi : PSeznam;
               end;
const UData : TData = (Jmeno:'nikdo';Telefon:'nema';Email:'zadny'); {Data hlavicky}
var Hlavicka,Soucasny : PSeznam;
    Seznam : TSeznam;
    ZData   : TData;
    r       : char;
 
procedure Inicializace; {Drzadlo}
begin
 New(Hlavicka);
 Hlavicka^.Dalsi:=Hlavicka;
 Hlavicka^.Predchozi:=Hlavicka;
 Hlavicka^.Data:=UData;
 Soucasny:=Hlavicka;
end;
 
procedure Zadej; {Vytvori kruhovy oboustranne zretezeny seznam}
begin
 repeat
 Write('Jmeno : ');
 Readln(ZData.Jmeno);
 if ZData.Jmeno <> '' then
  begin
   Write('Telefon : ');
   Readln(ZData.Telefon);
   Write('Email : ');
   Readln(ZData.Email);
 
   New(Soucasny^.Dalsi);
   Soucasny^.Dalsi^.Predchozi:=Soucasny;
   Soucasny:=Soucasny^.Dalsi;
   Soucasny^.Data:=ZData;
   Soucasny^.Dalsi:=Hlavicka;
   Writeln;
  end;
 until ZData.Jmeno='';
end;
 
procedure Vypis; {Vypise cely seznam}
var Zobrazeno : Byte; {Aby se vse veslo na obrazovku}
begin
 Zobrazeno:=0;
 Writeln('Cely seznam :');
 Soucasny:=Hlavicka;
 Writeln;
 
 repeat
 Inc(Zobrazeno);
 Soucasny:=Soucasny^.Dalsi;
 Writeln(Soucasny^.Data.Jmeno);
 Writeln('Telefon :',Soucasny^.Data.Telefon:12,'    Email : ',Soucasny^.Data.Email);
 Writeln; {Pro prehlednost}
 if Zobrazeno = 7 then
  begin
   Writeln;
   Writeln('Press ENTER to continue');
   Readln;
  end;
 until Soucasny^.Dalsi=Hlavicka;
 Writeln('To je vse - Press ENTER to continue');
 Readln;
end;
 
procedure Zmen; {Vypise vsechny prvky a zepta se na moznost zmeny}
var c:char;
begin
 Writeln('Cely seznam :');
 Soucasny:=Hlavicka;
 repeat
 Soucasny:=Soucasny^.Dalsi;
 Writeln(Soucasny^.Data.Jmeno,Soucasny^.Data.Telefon:15,Soucasny^.Data.Email:30, ' Zmenit(A/N):');
 Readln(c);
 c:=UpCase(c);
 if C='A' then
  begin
   Write('Nove jmeno :');
   Readln(ZData.Jmeno);
   Write('Novy telefon :');
   Readln(ZData.Telefon);
   Write('Novy email :');
   Readln(ZData.Email);
   Soucasny^.Data:=ZData;
  end;
 until Soucasny^.Dalsi=Hlavicka;
 Writeln('To je vse');
end;
 
procedure Odstran; {Odstrani vybrane prvky ze seznamu}
var Smaz:PSeznam;
    c   :char;
begin
 Writeln('Cely seznam :');
 Soucasny:=Hlavicka;
 repeat
 Soucasny:=Soucasny^.Dalsi;
 Writeln(Soucasny^.Data.Jmeno,Soucasny^.Data.Telefon:15,Soucasny^.Data.Email:30,' Odstranit(A/N)');
 Readln(c);
 c:=UpCase(c);
 if C='A' then
  begin
   Smaz:=Soucasny;
   Soucasny^.Predchozi^.Dalsi:=Soucasny^.Dalsi;
   Smaz^.Dalsi^.Predchozi:=Smaz^.Predchozi;
   Soucasny:=Smaz^.Predchozi;
   Dispose(Smaz); {Mazeme az ted!!}
  end;
  until Soucasny^.Dalsi=Hlavicka;
 Writeln('To je vse');
end;
 
procedure Pridej; {Prida novy prvke}
var Novy:PSeznam;
    c   :char;
begin
 Writeln('Cely seznam :');
 Soucasny:=Hlavicka;
 repeat
 Soucasny:=Soucasny^.Dalsi;
 Writeln(Soucasny^.Data.Jmeno:20,Soucasny^.Data.Telefon:15,Soucasny^.Data.Email,' Pridat pred(A/N)');
 Readln(c);
 c:=UpCase(c);
 if C='A' then
  begin
   Write('Nove jmeno : ');
   Readln(ZData.Jmeno);
   Write('telefon : ');
   Readln(ZData.telefon);
   Write('email : ');
   Readln(ZData.Email);
   New(Novy);
   Novy^.Data:=ZData;
 
   Novy^.Dalsi:=Soucasny;
   Novy^.Predchozi:=Soucasny^.Predchozi;
   Soucasny^.Predchozi:=Novy;
   Novy^.Predchozi^.Dalsi:=Novy; {To jsou snad cary, ale je to tak, ukazatele ted sedi}
 
  end;
  until Soucasny^.Dalsi=Hlavicka;
 Writeln('To je vse');
end;
 
procedure Serad; {Seradi data podle abecedy}
var Zmen : LongInt; {Pocet dvojic prehozenych pri jednom pruchodu}
    Konec: Boolean;
begin
 Zmen:=0;
 Soucasny:=Hlavicka;
 repeat
 if Konec then
  begin
   Zmen:=0;
   Konec:=false;
  end;
 Konec:=Soucasny^.Dalsi=Hlavicka;
 if (Soucasny=Hlavicka) or (Soucasny^.Dalsi=Hlavicka) then {if then else lze takto pouzit}
  else
   if Soucasny^.Data.Jmeno > Soucasny^.Dalsi^.Data.Jmeno then
   Begin
    Inc(Zmen);
    Zdata:=Soucasny^.Data;
    Soucasny^.Data:=Soucasny^.Dalsi^.Data;
    Soucasny^.Dalsi^.Data:=ZData;
   End;
 Soucasny:=Soucasny^.Dalsi;
 until Konec and (Zmen=0);
end;
 
procedure Nahraj; {Nacte oboustranne zretezeny seznam}
var JmenoSouboru : string;
    fData        : file of TData;
begin
 Write('Nacist ze souboru (udavejte bez pripony) : ');
 Readln(JmenoSouboru);
 JmenoSouboru:=JmenoSouboru+'.adr';
 Assign(fData,JmenoSouboru);
 Reset(fData);
 repeat
  New(Soucasny^.Dalsi);
  Read(fData,Soucasny^.Dalsi^.Data);
  Soucasny^.Dalsi^.Predchozi:=Soucasny;
  Soucasny:=Soucasny^.Dalsi;
  Soucasny^.Dalsi:=Hlavicka;
 until Eof(fData);
 Close(fData);
end;
 
procedure Uloz; {Ulozi oboustranne zretezeny seznam}
var JmenoSouboru : string;
    fData        : file of TData;
begin
 Write('Ulozit do souboru (jmeno udavejte bez pripony) : ');
 Readln(JmenoSouboru);
 JmenoSouboru:=JmenoSouboru+'.adr';
 Assign(fData,JmenoSouboru);
 Rewrite(fData);
 Soucasny:=Hlavicka;
 repeat
 Soucasny:=Soucasny^.Dalsi;
 Write(fData,Soucasny^.Data);
 until Soucasny^.Dalsi=Hlavicka;
 Close(fData); {Jinak by se ani neulozil na disk}
 
end;
 
 
begin
 Inicializace;
 repeat
 writeln('Co chcete delat : ');
 writeln;
 writeln('V - Vytvorit novy adresar');
 writeln('Z - Zobrazit seznam');
 writeln('O - Opravit udaje');
 writeln('S - Smazat nektera data');
 writeln('P - Pridat nove prvky');
 writeln('E - Seradit podle abecedy');
 writeln('N - Nahrat ze souboru');
 writeln('U - Ulozit do souboru');
 writeln('K - Koncit');
 Readln(R);
 R:=UpCase(R);
 case R of
  'V': Zadej;
  'Z': Vypis;
  'O': Zmen;
  'S': Odstran;
  'P': Pridej;
  'E': Serad;
  'N': Nahraj;
  'U': Uloz;
 end;
 until R='K';
end.