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.