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.