Uses
Crt;
Type
tChain = ^tSection;
tSection = record
ln : string[20];
fn : string[10];
pn : string[7];
pos : integer;
next : tChain;
prev : tChain;
end;
tTemp = record
ln : string[20];
fn : string[10];
pn : string[7];
end;
Const
validSymbols : set of char = ['y','n','Y','N'];
ySymbols : set of char = ['y','Y'];
nSymbols : set of char = ['n','N'];
sSymbols : set of char = [#27,#13,#32];
count : integer = 0;
Var
First, Current, Last, PointUp, PointDown : tChain;
pMark : pointer;
f : file of tTemp;
temp : tTemp;
ch : char;
fileName : string[12];
changeFlag : boolean;
y : byte;
{----------------------------------------------------------------------------}
Procedure Save; forward;
{----------------------------------------------------------------------------}
Function ReadInt(x, y : integer) : integer;
var
subString : string;
temp, code : integer;
begin
subString := '';
repeat
ch := readkey;
case ch of
'0' : if length(subString) <> 0 then begin
subString := subString + ch;
write(ch);
end;
'1'..'9' : begin
subString := subString + ch;
write(ch);
end;
#8 : begin
gotoxy(x,y);
textcolor(0);
write(subString);
delete(subString,length(subString),1);
gotoxy(x,y);
textcolor(15);
write(subString);
end;
end;
until (ch = #13) AND (length(subString) > 0);
val(subString, temp, code);
if (code <> 0) OR (temp > 32767) OR (temp <= 0) then temp := 0;
ReadInt := temp;
writeln;
end;
{----------------------------------------------------------------------------}
Procedure SaveChange;
begin
if changeFlag = TRUE then begin
writeln('The running project isn''t saved.');
write('Do you want to save it (Y/N) ?');
repeat
ch := readkey;
until ch in validSymbols;
if ch in ySymbols then begin
Save;
end else begin
clrscr;
end;
end;
end;
{----------------------------------------------------------------------------}
Procedure DeleteAll;
begin
release(pMark);
mark(pMark);
Last := nil;
First := nil;
Current := nil;
PointUp := nil;
PointDown := nil;
count := 0;
end;
{----------------------------------------------------------------------------}
Procedure CreateChain;
begin
if count = 0 then begin
new(First);
Current := First;
Current^.prev := nil;
end else begin
new(Current^.next);
(Current^.next)^.prev := Current;
Current := Current^.next;
end;
Current^.next := nil;
Last := Current;
inc(count);
Current^.pos := count;
end;
{----------------------------------------------------------------------------}
Procedure Open;
label
Finish;
begin
clrscr;
SaveChange;
DeleteAll;
write('Enter the file name to open -> ');
readln(fileName);
if fileName = '' then goto Finish;
assign(f,fileName);
{$I-}
reset(f);
{$I+}
if IOResult = 0 then begin
while not EOF(f) do begin
read(f,temp);
CreateChain;
Current^.ln := temp.ln;
Current^.fn := temp.fn;
Current^.pn := temp.pn;
end;
close(f);
changeFlag := FALSE;
write('File has beeb read successfully.');
end else begin
Finish :
write('File read error.');
end;
readkey;
clrscr;
end;
{----------------------------------------------------------------------------}
Procedure Close;
begin
clrscr;
if count <> 0 then begin
SaveChange;
DeleteAll;
write('Database has been successfully closed.');
end else begin
write('Database is empty.');
end;
changeFlag := FALSE;
readkey;
clrscr;
end;
{----------------------------------------------------------------------------}
Procedure Save;
label
Finish;
begin
clrscr;
if count <> 0 then begin
write('Enter the file name to save -> ');
readln(fileName);
if fileName = '' then begin
write('File write error.');
goto Finish;
end;
assign(f,fileName);
rewrite(f);
Current := First;
while Current <> nil do begin
temp.ln := Current^.ln;
temp.fn := Current^.fn;
temp.pn := Current^.pn ;
write(f,temp);
Current := Current^.next;
end;
Current := Last;
changeFlag := FALSE;
write('File has been writen successfully.')
end else begin
write('Database is empty.');
end;
Finish :
readkey;
clrscr;
end;
{----------------------------------------------------------------------------}
Procedure ViewUp;
label
Finish;
begin
if PointUp = First then begin
goto Finish;
end else begin
Current := PointUp^.prev;
end;
clrscr;
PointDown := Current;
y := 10;
while (Current <> nil) AND (y <> 0) do begin
gotoxy(1,y);
write(Current^.pos,' ');
gotoxy(8,y);
write(Current^.ln,' ');
gotoxy(29,y);
write(Current^.fn,' ');
gotoxy(41,y);
write(Current^.pn,' ');
if y = 1 then PointUp := Current;
Current := Current^.prev;
dec(y);
end;
Finish :
end;
{----------------------------------------------------------------------------}
Procedure ViewDown;
label
Finish;
begin
if PointDown = First then begin
Current := PointDown;
end else begin
if PointDown = Last then begin
goto Finish;
end else begin
Current := PointDown^.next;
end;
end;
clrscr;
PointUp := Current;
y := 1;
while (Current <> nil) AND (y <> 11) do begin
gotoxy(1,y);
write(Current^.pos,' ');
gotoxy(8,y);
write(Current^.ln,' ');
gotoxy(29,y);
write(Current^.fn,' ');
gotoxy(41,y);
write(Current^.pn,' ');
if (y = 10) OR (Current^.next = nil) then PointDown := Current;
Current := Current^.next;
inc(y);
end;
Finish :
end;
{----------------------------------------------------------------------------}
Procedure View;
begin
if count <> 0 then begin
PointDown := First;
ViewDown;
repeat
ch := readkey;
case ch of
#72 : ViewUp;
#80 : ViewDown;
end;
until ch in sSymbols;
Current := Last;
end else begin
clrscr;
write('Database is empty.');
readkey;
end;
clrscr;
end;
{----------------------------------------------------------------------------}
Procedure Add;
label
Finish;
begin
clrscr;
if count < 32767 then begin
CreateChain;
repeat
write('Last name -> ');
readln(Current^.ln);
write('First name -> ');
readln(Current^.fn);
write('Phone number -> ');
readln(Current^.pn);
if count < 32767 then begin
writeln('Do you want to stop (Y/N) ? ');
repeat
ch := readkey;
until ch in validSymbols;
if ch in nSymbols then begin
writeln;
CreateChain;
end;
end else begin
clrscr;
goto Finish;
end;
until ch in ySymbols;
changeFlag := TRUE;
end else begin
Finish :
write('Database is full.');
readkey;
end;
clrscr;
end;
{----------------------------------------------------------------------------}
Procedure Delete;
label
Finish;
var
n : integer;
Temp : tChain;
begin
clrscr;
if count <> 0 then begin
write('Enter the number of element to delete -> ');
n := ReadInt(42,1);
if (n > count) OR (n = 0) then begin
write('Element delete error.');
goto Finish;
end;
Current := First;
while Current <> nil do begin
if Current^.pos = n then break;
Current := Current^.next;
end;
Temp := Current^.next;
while Temp <> nil do begin
dec(Temp^.pos);
Temp := Temp^.next;
end;
if Current = First then begin
First := Current^.next;
First^.prev := nil;
end;
if Current = Last then begin
Last := Current^.prev;
Last^.next := nil;
end;
if (Current <> First) AND (Current <> Last) then begin
(Current^.prev)^.next := Current^.next;
(Current^.next)^.prev := Current^.prev;
end;
if (Current = First) AND (Current = Last) then begin
First := nil;
Last := nil;
end;
dispose(Current);
dec(count);
Current := Last;
changeFlag := TRUE;
write('Element has been deleted successfully.');
end else begin
write('Database is empty.');
end;
Finish :
readkey;
clrscr;
end;
{----------------------------------------------------------------------------}
Procedure Sort;
var
flag : boolean;
i, m : integer;
begin
clrscr;
if count > 1 then begin
m := count - 1;
repeat
flag := TRUE;
Current := First;
for i := 1 to m do begin
if Current^.ln > (Current^.next)^.ln then begin
temp.ln := Current^.ln;
temp.fn := Current^.fn;
temp.pn := Current^.pn;
Current^.ln := (Current^.next)^.ln;
Current^.fn := (Current^.next)^.fn;
Current^.pn := (Current^.next)^.pn;
(Current^.next)^.ln := temp.ln;
(Current^.next)^.fn := temp.fn;
(Current^.next)^.pn := temp.pn;
flag := FALSE;
changeFlag := TRUE;
end;
Current := Current^.next;
end;
dec(m);
until flag;
Current := Last;
write('Database has been sorted successfully.');
end else begin
case count of
0 : write('Database is empty.');
1 : write('Database contains only one element.');
end;
end;
readkey;
clrscr;
end;
{----------------------------------------------------------------------------}
Procedure Search;
var
ln : string[20];
searchFlag : boolean;
begin
clrscr;
if count <> 0 then begin
write('Last name -> ');
readln(ln);
clrscr;
y := 1;
searchFlag := FALSE;
Current := First;
while Current <> nil do begin
if Current^.ln = ln then begin
searchFlag := TRUE;
gotoxy(1,y);
write(Current^.pos,' ');
gotoxy(8,y);
write(Current^.ln,' ');
gotoxy(29,y);
write(Current^.fn,' ');
gotoxy(41,y);
write(Current^.pn,' ');
inc(y);
end;
Current := Current^.next;
end;
if NOT searchFlag then write('0 items found.');
searchFlag := FALSE;
Current := Last;
end else begin
write('Database is empty.');
end;
readkey;
clrscr;
end;
{----------------------------------------------------------------------------}
Procedure Exit;
begin
clrscr;
SaveChange;
ch := '9';
end;
{----------------------------------------------------------------------------}
Procedure Menu;
begin
textcolor(15);
repeat
writeln('1. Open');
writeln('2. Close');
writeln('3. Save');
writeln('4. View');
writeln('5. Add');
writeln('6. Delete');
writeln('7. Sort');
writeln('8. Search');
write('9. Exit');
ch := readkey;
case ch of
'1' : Open;
'2' : Close;
'3' : Save;
'4' : View;
'5' : Add;
'6' : Delete;
'7' : Sort;
'8' : Search;
'9' : Exit;
else gotoxy(1,1);
end;
until ch = '9';
end;
{----------------------------------------------------------------------------}
Begin
clrscr;
mark(pMark);
Menu;
release(pMark);
clrscr;
End.