Delphi Programming Unleashed/Delphi_Programming_Unleashed_SAMS_Publishing_1995.iso/chap16/linklst3/linklst3.dpr

Text File | 1995-03-21 | 6.1 KB | 323 lines

program LinkLst3;

{ Program copyright (c) 1995 by Charles Calvert }
{ Project Name: LINKLST3 }

uses
  WinCrt;

const
  FileName = 'LinkExp.dta';

type
  PMyNode = ^TMyNode;
  TMyNode = record
    Name  : String;
    Flight: integer;
    Day   : String;
    Next  : PMyNode;  {Used to link each field}
  end;

procedure CreateNew(var Item: PMyNode);
begin
  New(Item);
  Item^.Next := nil;
  Item^.Name := '';
  Item^.Flight := 0;
  Item^.Day := '';
end;

procedure GetData(var Item: PMyNode);
begin
  ClrScr;
  repeat
    GotoXY(1, 1);
    Write('Enter Name: ');
    Read(Item^.Name);
  until (Item^.Name <> '');
  GotoXY(1, 2);
  Write('Enter Flight number: ');
  ReadLn(Item^.Flight);
  GotoXY(1, 3);
  Write('Enter Day: ');
  ReadLn(Item^.Day);
end;

procedure DoFirst(var First, Current: PMyNode);
begin
  CreateNew(Current);
  GetData(Current);
  First := Current;
end;

procedure Add(Current: PMyNode);
var
  Prev: PMyNode;
begin
  Prev := Current;
  CreateNew(Current);
  GetData(Current);
  Prev^.Next := Current;
end;

procedure DeleteNode(var Head, Node, Current: PMyNode);
var
  Temp: PMyNode;
begin
  Temp := Head;
  while Temp^.Next <> Node do
    Temp := Temp^.Next;
  if Temp^.Next^.Next <> nil then
    Temp^.Next := Temp^.Next^.Next
  else begin
    Temp^.Next := nil;
    Current := Temp;
  end;
  Dispose(Node);
end;

function Find(Head: PMyNode; S: String): PMyNode;
var
  Temp: PMyNode;
begin
  Temp := nil;
  while Head^.Next <> nil do begin
    if Head^.Name = S then begin
      Temp := Head;
      break;
    end;
    Head := Head^.Next;
  end;
  if Head^.Name = S then Temp := Head;
  Find := Temp;
end;

procedure DoDelete(var Head, Current: PMyNode);
var
  S: String;
  Temp: PMyNode;
begin
  ClrScr;
  Write('Enter name from record to delete: ');
  ReadLn(S);
  Temp := Find(Head, S);
  if Temp <> nil then
    DeleteNode(Head, Temp, Current);
end;

function AtPosition(Head: PMyNode; Num2Find: Integer): PMyNode;
var
  i: Integer;
begin
  i := 1;
  while Head^.Next <> nil do begin
    if i = Num2Find then Break;
    Head := Head^.Next;
    Inc(i);
  end;
  AtPosition := Head;
end;

procedure ShowRec(Item: PMyNode);
begin
  Write('Name: ', Item^.Name);
  Write('     Flight: ', Item^.Flight);
  WriteLn('       Day: ', Item^.Day);
end;

procedure ShowRec2(Item: PMyNode);
begin
  GotoXY(1, 1); ClrEol;
  GotoXY(1, 1); Write('Name: ', Item^.Name);
  GotoXY(25, 1); Write('Flight: ', Item^.Flight);
  GotoXY(45, 1); Write('Day: ', Item^.Day);
end;

function GetTotal(Head: PMyNode): Integer;
var
  i: Integer;
begin
  i := 1;
  while Head^.Next <> nil do begin
    Head := Head^.Next;
    Inc(i);
  end;
  GetTotal := i;
end;

procedure Explain;
begin
  GotoXY(1, 3); WriteLn('T) Top');
  GotoXY(1, 4); WriteLn('B) Bottom');
  GotoXY(1, 5); WriteLn('U) Up One');
  GotoXY(1, 6); WriteLn('D) Down One');
  GotoXY(1, 7); WriteLn('X) Exit View');
end;

procedure ShowOneByOne(Head: PMyNode);
var
  Total, i: Integer;
  Temp: PMyNode;
  Ch: Char;
begin
  ClrScr;
  Explain;
  Total := GetTotal(Head);
  i := 1;
  repeat
    Temp := AtPosition(Head, i);
    ShowRec2(Temp);
    repeat
      Ch := UpCase(ReadKey);
    until Ch in ['U', 'D', 'T', 'B', 'X'];
    if Ch = 'U' then begin
      Dec(i);
      if i < 1 then i := 1;
    end;
    if Ch = 'D' then Inc(i);
    if Ch = 'T' then i := 1;
    if Ch = 'B' then i := Total;
  until Ch = 'X';
end;

procedure Show(Head: PMyNode);
var
  i: Integer;
begin
  i := 1;
  ClrScr;
  while Head^.Next <> nil do begin
    Head := Head^.Next;
    ShowRec(Head);
    Inc(i);
  end;
  WriteLn;
  WriteLn('==========================================================');
  WriteLn(i, ' records shown');
  ReadLn;
end;

procedure FreeAll(var Head: PMyNode);
var
  Temp: PMyNode;
begin
  while Head^.Next <> nil do begin
    Temp := Head^.Next;
    Dispose(Head);
    Head := Temp;
  end;
  Dispose(Head);
end;

procedure CreateNewFile(Head: PMyNode);
var
  F: File of TMyNode;
begin
  Assign(F, FileName);
  ReWrite(F);
  while Head^.Next <> nil do begin
    Write(F, Head^);
    Head := Head^.Next;
  end;
  Write(F, Head^);
  Close(F);
end;

{ Read a binary file. Prefered method }
function ReadFile(var First, Current: PMyNode): Boolean;
var
  F: File of TMyNode;
  Prev: PMyNode;
begin
  ReadFile := False;
  Assign(F, FileName);
  {$I-} Reset(F); {$I+}
  if IOResult <> 0 then Exit;
  CreateNew(Current);
  Read(F, Current^);
  First := Current;
  while not Eof(F) do begin
    Prev := Current;
    CreateNew(Current);
    Read(F, Current^);
    Prev^.Next := Current;
  end;
  Close(F);
  ReadFile := True;
end;

{ Read a Text File }
procedure ReadTextFile(var First, Current: PMyNode);
var
  F: Text;
  i: Integer;
  Prev: PMyNode;
begin
  Assign (F, 'data.txt');
  {$I-} Reset(F); {$I+}
  if (IOResult <> 0) then begin
    WriteLn('error Reading File');
    Halt;
  end;
  CreateNew(Current);
  ReadLn(F, Current^.Name);
  ReadLn(F, Current^.Flight);
  ReadLn(F, Current^.Day);
  First := Current;
  i := 0;
  while not Eof(F) do begin
    Prev := Current;
    CreateNew(Current);
    ReadLn(F, Current^.Name);
    ReadLn(F, Current^.Flight);
    ReadLn(F, Current^.Day);
    Prev^.Next := Current;
    Inc(i);
    WriteLn(i);
  end;
  Close(F);
  CreateNewFile(First);
end;

function WriteMenu: Char;
var
  Ch: Char;
begin
  ClrScr;
  GotoXY(1, 1);
  WriteLn('A) Add');
  WriteLn('D) Delete');
  WriteLn('S) Show');
  WriteLn('W) Write File');
  WriteLn('O) One by One');
  WriteLn('X) Exit');
  repeat
    Ch := UpCase(ReadKey);
  until Ch in ['A', 'D', 'S', 'W', 'O', 'X'];
  WriteMenu := Ch;
end;

var
  Ch: Char;
  First,
  Current: PMyNode;

begin
  ClrScr;
  if not ReadFile(First, Current) then
    ReadTextFile(First, Current);
  repeat
    Ch := WriteMenu;
    case Ch of
      'A': Add(Current);
      'D': DoDelete(First, Current);
      'S': Show(First);
      'W': CreateNewFile(First);
      'O': ShowOneByOne(First);
    end;
  until Ch = 'X';
end.