Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/IPM_CODE.ZIP/IPM.PAS

Pascal/Delphi Source File | 1985-12-07 | 38.1 KB | 1,329 lines

{ Author: E. Dong - Version 1.07 - Nov 07, 1984 - 1:15pm }
program ivy_league_project_mgr;
const
  MaxDigits = 6;        {IMPLEMENTATION DEPENDENT}
  CONSOLE   = 'con:';   {IMPLEMENTATION DEPENDENT}
  viewport  = 14;       {IMPLEMENTATION DEPENDENT}
  MaxValue  = 100;
type
  textstring = string[255];
  CharSet    = set of char;
  Values     = 1..MaxValue;
  TaskTable  = RECORD
               TaskName : string[8];
               TaskText : textstring;
               BegNode  : integer;
               EndNode  : integer;
               Duration : real;
               Cost     : real;
               end;
var
  CmdCh, ch      : char;
  Project        : array [Values] of TaskTable;
  Start, Finish  : array [Values] of real;
  Activities     : integer;
  Activity       : integer;
  TotalCost      : real;
  PathLen        : real;
  Filein,Fileout : text;
  InputFile      : textstring;
  OutputFile     : textstring;
  CurrFile       : textstring;
  ProjectName    : textstring;
  OkToGo         : boolean;

procedure debug(instr: textstring);
var
  ch : char;
begin
  writeln(instr);
  read(kbd,ch);
end;

function Lineout(instr: textstring; linelen: integer): textstring;
begin
  if length(instr) <= linelen
     then Lineout := instr
     else Lineout := copy(instr,1,linelen);
end;

function LLIMIT(limit,other : integer): integer;
begin
  if limit <= other
     then LLIMIT := limit
     else LLIMIT := other;
end;

function ToSTRING(num: integer): textstring;
var
  ch1, ch2 : char;
begin
  ch1 := chr(ord('0') + (num div 10));
  ch2 := chr(ord('0') + (num - 10 * (num div 10)));
  ToSTRING := ch1 + ch2;
end;

procedure SortCPM;
var
  i, j     : integer;
  SWITCHED : boolean;
  TempProj : TaskTable;
begin
  SWITCHED := FALSE;
  for i := 1 to Activities-1 do begin
    for j := i+1 to Activities do begin
        if ((Project[i].BegNode > Project[j].BegNode) or
           ((Project[i].BegNode = Project[j].BegNode) and
            (Project[i].EndNode > Project[j].EndNode)))
           then begin
                TempProj    := Project[i];
                Project[i]  := Project[j];
                Project[j]  := TempProj;
                SWITCHED    := TRUE;
                end;
       end;
  end;
  if SWITCHED then SortCPM;
end;

procedure DoNothing;
begin
  ;
end;
procedure Introduction;
begin
  LowVideo;
  writeln('Ivy League Project Manager (IPM) V1.07 - (c) 1984 by Edward V. Dong');
  writeln('---------------------- All Rights Reserved -------------------------');
  HighVideo;
  writeln('Adapted from PRACTICAL PASCAL PROGRAMS, Osborne/McGraw-Hill, by Greg');
  writeln('Davidson, (c) 1982 by  McGraw-Hill, Inc.  Written  in  Turbo  Pascal');
  writeln('with many extensive modifications, including PERT graphics.');
  writeln;
  writeln('Current commands are displayed on line 25 of your screen.  Select  a');
  writeln('command by typing the first letter of the command option.   Pressing');
  writeln('the return key is not necessary.   A BEEP! means an  illegal  entry.');
end;

procedure EraseLine(row : integer);
var
  i : integer;
begin
  if row > 0 then gotoxy(1,row);
  for i := 1 to 79 do write(' ');
  for i := 1 to 79 do write(chr(8));
end;

function AllCaps(instr : textstring): textstring;
var
  i : integer;
begin
  for i := 1 to length(instr) do instr[i] := UpCase(instr[i]);
  AllCaps := instr;
end;

procedure CapLine(row: integer; cmdstring: textstring);
var
  i : integer;
begin
  EraseLine(row); LowVideo;
  for i := 1 to length(cmdstring) do begin
      if cmdstring[i] in ['A'..'Z'] then HighVideo;
      write(cmdstring[i]);
      LowVideo;
      end;
end;

procedure Commands(var ch: char; cmdstring: textstring);
begin
  CapLine(25, 'Commands: '+cmdstring); HighVideo;
  read(kbd,ch); ch := UpCase(ch);
end;

procedure PageTitle(instring : textstring);
var
  i : integer;
begin
  LowVideo; write(Fileout,'PROJECT: ');
  HighVideo; write(Fileout,ProjectName);
  LowVideo; writeln(Fileout,' -- ',instring);
  for i := 1 to 78 do write(Fileout,'-'); HighVideo;
  writeln(Fileout);
end; { PageTitle }

procedure ident(instr: textstring);
var
  i : integer;
begin
  EraseLine(21);
  for i:=length(instr) to 78 do instr := instr + '-';
  write(instr);
end;

procedure Repaint(instr: textstring);
begin
  if OutputFile = CONSOLE
     then clrscr;
  PageTitle(instr);
end;

procedure MainMenu;
var
  filestr : textstring;
begin
  clrscr;
  assign(fileout,CONSOLE); rewrite(fileout);
  if CurrFile <> CONSOLE
     then filestr := 'FILE: ' + AllCaps(CurrFile)
     else filestr := 'FILE: CONSOLE';
  PageTitle(filestr);
  Introduction;
end;

procedure window(instring: textstring);
var
  tempstr : textstring;
  i, j    : integer;
begin
  for i := viewport to 24 do EraseLine(i);
  gotoxy(1,viewport);
  tempstr := instring;
  for i := length(instring) to 78 do tempstr := tempstr + '-';
  writeln(tempstr);
end;

function Read1Char(okchars: CharSet): char;
const
  BEL = 7; { ASCII char for dinging the user }
var
  c : char;
begin
  repeat
    read(kbd,c);
    if not (c in okchars)
       then c := UpCase(c);
    if not (c in okchars)
       then write(chr(BEL));
  until c in okchars;
  writeln;
  read1char := c;
end; { read1char }

function Exist(filename: textstring) : boolean;
var
 fil : file;
begin
 assign(fil,filename);
 {$I-}
 reset(fil);
 {$I+}
 if IOresult <> 0
    then Exist := FALSE
    else Exist := TRUE;
end; { Exist }

procedure GetOutputName;
var
  Fileok : boolean;
begin
  Fileok := FALSE;
  repeat
    EraseLine(0); write('Enter filename: '); readln(OutputFile);
    if Exist(OutputFile)
       then begin
            EraseLine(0);
            write('--> File ',OutputFile,' exists: Overwrite? (Y/N) ');
            if read1char(['Y','N']) = 'Y' then Fileok := TRUE;
            end
       else Fileok := TRUE;
  until Fileok = TRUE;
end;

procedure InitOutput;
begin
  GetOutputName;
  assign(fileout,OutputFile);
  rewrite(fileout);
end;

function ReadInt(var num:integer; low, high : integer): boolean;
var i : char;
begin
  if InputFile = CONSOLE
     then readln(i)
     else readln(filein,i);
  if (((i >= '0') or (i <= '9')) and ((i >= chr(low)) and (i <= chr(high))))
     then begin
         num := ord(i) - ord('0');    { input for valid integers... }
         Readint := TRUE;
         end
     else Readint := FALSE;
end;

function ReadStr(var Instring : textstring): boolean;
begin
  if InputFile = CONSOLE
     then readln(Instring)
     else readln(filein,Instring);
  if length(Instring) = 0
     then ReadStr := FALSE
     else ReadStr := TRUE;
end;

function ReadReal(var x:real): boolean;
begin
  if InputFile = CONSOLE
     then readln(x)
     else readln(filein,x);
  ReadReal := TRUE;
end;

procedure RecordHandler(instr : textstring; var FileOK : boolean);
label
  quit;
var
  ProjectFile   : file of TaskTable;
  TempJob       : TaskTable;
  filename      : textstring;
  i             : integer;
begin
  instr := AllCaps(instr);
  FileOK := FALSE;
  if instr = 'OUTPUT'
     then begin
          EraseLine(0);
          write('Enter filename: '); readln(filename);
            if Exist(filename)
               then begin
                      EraseLine(0);
                      write('File exists. Overwrite? (Y/N) ');
                      if Read1Char(['Y','N']) <> 'Y' then goto quit;
                    end;
            CurrFile := filename;
            assign(ProjectFile,filename);
            rewrite(ProjectFile);
            FileOK := TRUE;
            TempJob.TaskText := ProjectName;
            TempJob.Cost     := (Activities);
            write(ProjectFile,TempJob);
            for i := 1 to Activities do write(ProjectFile,Project[i]);
            close(ProjectFile);
          end
     else begin
            EraseLine(0); write('Enter filename: '); readln(filename);
            if NOT Exist(filename) then goto quit;
            CurrFile := filename;
            assign(ProjectFile,filename);
            reset(ProjectFile);
            FileOK := TRUE;
            seek(ProjectFile,0);
            read(ProjectFile,TempJob);
            ProjectName := TempJob.TaskText;
            Activities   := trunc(TempJob.Cost);
            for i := 1 to Activities do
                begin
                  seek(ProjectFile,i);
                  read(ProjectFile,Project[i]);
                end;
            close(ProjectFile);
          end;
quit:
end;

procedure SaveData;
var
  FileOK   : boolean;
begin
  EraseLine(0);
  write('Save Network Data to Disk File? (Y/N) ');
  if read1char(['Y','N']) = 'Y'
     then RecordHandler('OUTPUT',FileOK);
end; {SaveData}

procedure LotusCPM;
var
  i        : integer;
begin
  if OutputFile <> CONSOLE then begin
     writeln(fileout,'"',ProjectName,'"');              { Project Title  }
     writeln(fileout,'"No. Tasks = ",',Activities);     { # of Activities }
     writeln(fileout,'"TaskNo"','"TaskName"','"BegNode"','"EndNode"',
                     '"Duration"','"Cost"','"Description"');
     for i := 1 to Activities do
         begin
           write(fileout,i,',');                        { index          }
           write(fileout,',"',Project[i].TaskName,'"'); { Task Name      }
           write(fileout,Project[i].BegNode,',');       { Starting Node  }
           write(fileout,Project[i].EndNode,',');       { Finishing Node }
           write(fileout,Project[i].Duration,',');      { Duration       }
           write(fileout,Project[i].Cost,',');          { Cost           }
           writeln(fileout,'"',Project[i].TaskText,'"');{ Task Text      }
         end; { for i := 1 to Activities}
    close(fileout);
    OutputFile := CONSOLE;
    end;
end; { LotusCPM }

procedure Edit(xwindow, ywindow: integer);
var
  EditChar   : char;
  EndOfPage  : integer;
  NextPage   : integer;
  RowOffset  : integer;
  i, j, k    : integer;
  TempStr    : textstring;
procedure EditInt(instr: textstring; var item: integer; low, high: integer);
begin
  repeat
    EraseLine(24); write('Enter ',instr,': ');
  until ReadInt(item,low,high);
end;
procedure EditReal(instr: textstring; var item: real);
begin
  repeat
    EraseLine(24); write('Enter ',instr,': ');
  until ReadReal(item);
end;
procedure EditText(instr: textstring; var item: textstring);
begin
  repeat
    EraseLine(24); write('Enter ',instr,': ');
  until ReadStr(item);
end;
procedure GetNewEndNode;
var
  NewEndNode : integer;
begin
  EditInt('End Node',NewEndNode,0,maxint);
  if ((NewEndNode >= Activities) or (NewEndNode <= Project[Activity].BegNode))
     then begin
          EraseLine(24); write('ILLEGAL ENTRY: Retry...');
          end
     else Project[Activity].EndNode := NewEndNode;
end;
procedure FlipPage(instr: textstring; var NextPage: integer; ywindow: integer);
begin
  instr := AllCaps(instr);
  if instr = 'PGDN'
     then begin {Page Down}
          NextPage := NextPage + (19 - ywindow);
          if NextPage > Activities
             then NextPage := Activities;
          end
     else begin {Page Up}
          NextPage := NextPage - (19 - ywindow);
          if NextPage < 0
             then NextPage := 0;
          end;
end;
procedure KillTask(Activity: integer);
var
  i       : integer;
begin
  EraseLine(23); write('Task '); LowVideo;
  write(Project[Activity].TaskName);
  HighVideo; write(' DELETED.');
  for i := Activity to Activities do Project[i] := Project[i+1];
  Activities := Activities - 1;
  SortCPM;
end;
function IndexTask(instr: textstring): integer;
var
  i,j : integer;
begin
  i := 0; j := 0;
  REPEAT
    i := succ(i);
    if AllCaps(Project[i].TaskName) = AllCaps(instr) then j := i;
  UNTIL ((i = Activities) or (j <> 0));
  IndexTask := j;
end;
procedure ChangeName;
var
  TempStr : textstring;
begin
  CapLine(23,'SELECT: task Name  task Description');
  if Read1Char(['N','D']) = 'N'
     then begin
          EditText('Task Name',TempStr);
          Project[Activity].TaskName := TempStr;
          end
     else begin
          EditText('Task Description',TempStr);
          Project[Activity].TaskText := TempStr;
          end;
   EraseLine(23);
end;
procedure InsertNode;
label
  DoneNewNode;
var
  AfterNode, i : integer;
  instr        : textstring;
begin
  i := 0;
  REPEAT
    EraseLine(23); write('What task goes to this new node? ');
    EraseLine(24); write('Enter existing task name (or return to abort): ');
    readln(instr);
    if length(instr) = 0
       then i := -1
       else i := IndexTask(instr);
  UNTIL (i <> 0);
  EraseLine(23); EraseLine(24); write('Task Index = ',i);
  if length(instr) = 0 then goto DoneNewNode;
  AfterNode := Project[IndexTask(instr)].EndNode;
  for i := IndexTask(instr)+1 to Activities do begin
      with Project[i] do begin
           if BegNode >= AfterNode then BegNode := BegNode + 1;
           if EndNode >= AfterNode then EndNode := EndNode + 1;
           end;
      end;
DoneNewNode:
end;
procedure InsertTask;
var
  NewTask : textstring;
begin
 with Project[Activities+1] do begin
   REPEAT
     EraseLine(24); write('Enter NAME of new task: ');
   UNTIL ReadStr(NewTask);
   if length(NewTask) <= 8
      then TaskName := NewTask
      else TaskName := copy(NewTask,1,8);
   REPEAT
     EraseLine(24); write('Start_node? ');
   UNTIL ReadInt(BegNode,0,Activities);
   REPEAT
     EraseLine(24); write('End_node? ');
   UNTIL ReadInt(EndNode,0,Activities+1);
   EraseLine(24); write('New task ',TaskName);
   write(' from Node ',BegNode:2,' to ',EndNode:2);
   write('--> OK to add new task? (Y/N) ');
   if read1char(['Y','N']) = 'Y'
      then Activities := Activities + 1;
   end;
end;
procedure InsertTaskNode;
var
  ch : char;
begin
  CapLine(24,'Insert: new_Node new_Task Abort');
  ch := Read1Char(['N','T','A']);
  if ch = 'N' then InsertNode
  else if ch = 'T' then InsertTask;
end;
procedure EditWindow(NextPage,ywindow,RowOffset: integer);
begin
  EndOfPage := LLIMIT(Activities,(NextPage - ywindow + 20));
  j := 1;
  for i := 1+NextPage to EndOfPage do begin
      gotoxy(1,j+RowOffset); j := succ(j);
      if i = Activity then LowVideo else HighVideo;
      write(i:5,Project[i].BegNode:5, Project[i].EndNode:5);
      write(Project[i].Duration:8:2, Project[i].Cost:MaxDigits+1:2);
      write(Project[i].TaskName:10);
      writeln(' ',Lineout(Project[i].TaskText,38));
      HighVideo;
      end;
end;
procedure EditGlobal(EditChar: char; var Activity, NextPage, ywindow: integer);
begin
  case EditChar of
    'T': EditInt('Task Number',Activity,1,Activities);
    'U': FlipPage('PGUP',NextPage,ywindow);
    'G': FlipPage('PGDN',NextPage,ywindow);
    'I': InsertTaskNode;
    'P': begin
           EditText('Project Title', TempStr);
           Project[1].TaskText := TempStr;
           ProjectName := Project[1].TaskText;
           if ywindow = 1 then begin
              gotoxy(1,1);
              PageTitle('Editing');
              end;
         end;
    end;
  if ((Activity=0) and (Pos(EditChar,'IP')>0)) then Activity := 1;
end;
procedure EditTask(EditChar: char; Activity: integer);
begin
  case EditChar of
    'S': EditInt('Start Node', Project[Activity].BegNode, 0, maxint);
    'E': GetNewEndNode;
    'D': EditReal('Duration',Project[Activity].Duration);
    'C': EditReal('Cost',Project[Activity].Cost);
    'N': ChangeName;
    'K': KillTask(Activity);
    end;
end;

begin
  if ywindow = 1
     then begin
          Repaint('Editing');
          RowOffset := 4;
          end
     else begin
          for i := ywindow to 20 do EraseLine(i);
          EraseLine(ywindow);
          RowOffset := ywindow + 1;
          end;
  writeln('Task ':5,'Start':5,'End':5);
  writeln('Node':10,'Node':5,'Duration':10,'  Cost',' Name/Description');
  InputFile := CONSOLE;
  Activity := 0;
  NextPage := 0;
  repeat
    EditWindow(NextPage,ywindow,RowOffset);
    CapLine(24,'          Task_no Start_node End_node Name Duration Cost');
    Commands(EditChar,'Insert Kill Get_next_page Up_page Project Quit');
    if Pos(EditChar,'TPUGI') > 0
       then EditGlobal(EditChar, Activity, NextPage, ywindow)
       else if ((Activity<>0) and (Pos(EditChar,'KSEDNC')>0))
            then EditTask(EditChar,Activity);
  until EditChar = 'Q';
  EraseLine(24);    { erase auxiliary command line from display }
  if Activity <> 0
     then begin
           SortCPM;
            EraseLine(23);
            EraseLine(24);
            EraseLine(22);
            SaveData;
          end;
end;

procedure GetData;
var
  i      : integer;
  FileOK : boolean;
begin
  window('Project Setup');
  writeln;
  Fileok := FALSE;
  write('Input from Console? (Y/N) ');
  InputFile := CONSOLE; CurrFile := InputFile;
  if read1char(['Y','N']) = 'Y'
     then begin
            repeat
              writeln('Enter Project Title/Description: ');
            until ReadStr(ProjectName);
            repeat
              write('Enter Number of Tasks on this network: ');
            until ReadInt(Activities,0,maxint);
          for i := 1 to Activities do
            begin
              Project[i].TaskName := 'Task'+ToSTRING(i);
              Project[i].BegNode := 0;
              Project[i].EndNode := 0;
              Project[i].Duration := 0;
              Project[i].Cost := 0;
            end;
          Edit(1,1);
          end
     else RecordHandler('INPUT',FileOK);
  for i := 1 to Activities do begin
      Start[i] := 0.0;
      Finish[i] := 0.0;
      end;
  SortCPM;
end; {GetData}

procedure FindEarlyStart;
var
  i : integer;
begin
  for i := 1 to Activities do
    begin
      with Project[i] do begin
         if Start[EndNode] < Start[BegNode] + Duration
            then Start[EndNode] := Start[BegNode] + Duration;
         end; { with...}
    end; { for i ... do }
  with Project[Activities] do Finish[EndNode] := Start[EndNode];
end; { FindEarlyStart}

procedure FindLateFinish;
var
  i : integer;
begin
  for i := Activities downto 1 do begin
    with Project[i] do begin
         if (Finish[BegNode] = 0) or
            (Finish[BegNode] > Finish[EndNode] - Duration)
            then Finish[BegNode] := Finish[EndNode] - Duration;
         end;
    end;
end; { FindLateFinish }

procedure CalculateSlackTime;
var
  JobLen : real;
  i      : integer;
begin
  Repaint('Calculated Results');
  for i := 1 to Activities do begin
      Start[i] := 0.0;
      Finish[i] := 0.0;
      end;
  FindEarlyStart;
  FindLateFinish;
  writeln(Fileout,'Task ':8,'Start':5,'End':5,'Early':10,'Late':10);
  writeln(Fileout,'Node':13,'Node':5,'Start':10,'Finish':10,
                  'Duration':10,'  Slack    Cost');
  for i := 1 to Activities do begin
    with Project[i] do begin
      write(Fileout,TaskName:8,BegNode:5);
      write(Fileout,EndNode:5, Start[BegNode]:10:2);
      write(Fileout,Finish[EndNode]:10:2, Duration:8:2);
      JobLen := Finish[EndNode]- Start[BegNode] - Duration;
      if JobLen > 0 then write(Fileout,Cost:10:2)
                    else if PathLen < Finish[EndNode]
                            then begin
                                 write(Fileout,'  CRITICAL');
                                 PathLen := PathLen + Duration;
                                 end
                            else write(Fileout,'          ');
     writeln(Fileout,Cost:MaxDigits+1:2);
     TotalCost := TotalCost + Cost;
     end; { with ... }
   end; { for i := 1..do }
  writeln(Fileout);
  writeln(Fileout,'The critical path length is ', PathLen:MaxDigits+1:3);
  writeln(Fileout,'The total cost of this network is ',
          TotalCost:MaxDigits+1:3);
  writeln(Fileout);
  if OutputFile <> CONSOLE
     then begin
          writeln(Fileout);
          writeln(Fileout,'Task Titles & Descriptions------------------');
          writeln(Fileout);
          for i:=1 to Activities do begin
              writeln(Fileout,'TITLE: ',Project[i].TaskName);
              writeln(Fileout,'Description: ',Project[i].TaskText);
              writeln(Fileout);
              end;
          close(Fileout);
          OutputFile := CONSOLE;
          end;
end; { CalculateSlackTime }

procedure Gantt;
label
  endGANTT;
const
  width = 70;
var
  i, j               : integer;
  scale, Slack       : real;
  PlotChar, EndSlack : char;
  SlackChar,CritChar : char;
  DuraChar           : char;
procedure PlotLine(num : real; ch : char);
var
  xnum, k : integer;
begin
  xnum := trunc((num + 0.5) * scale);
  if xnum > 0
     then begin
          if ch <> SlackChar
             then begin
                  for k := 1 to xnum do write(Fileout,ch);
                  end
             else if xnum > 1
                     then begin
                          for k := 1 to xnum-1 do write(Fileout,ch);
                          write(Fileout,EndSlack);
                          end
                     else write(Fileout,EndSlack);
         end;
end; { PlotLine }
procedure ShowChar(ch : char; num : integer);
var
  i : integer;
begin
  if ch <> SlackChar
     then begin
          for i := 1 to num do write(Fileout,ch);
          end
     else begin
          for i := 1 to num-1 do write(Fileout,ch);
          write(Fileout,EndSlack);
          end;
  writeln(Fileout);
end; { ShowChar }
begin
  if OutputFile = CONSOLE
     then begin
            EndSlack  := chr(191);
            SlackChar := chr(196);
            CritChar  := chr(175);
            DuraChar  := chr(220);
          end
     else begin
            EndSlack  := ']';
            SlackChar := '.';
            CritChar  := '>';
            DuraChar  := '=';
          end;
  Repaint('GANTT Chart');
  if PathLen <= 0
     then begin
          gotoxy(1,12);
          write('You must run option '); LowVideo; write('CalcSheet');
          HighVideo; write(' before running '); LowVideo;
          writeln('Gantt.'); HighVideo;
          goto endGANTT;
          end;
  scale := width / PathLen;
  if scale > 1.00 then scale := 1.00;
  write(Fileout,'Task No ':9);
  for i := 1 to 35 do write(Fileout,'+-');
  writeln(Fileout);
  for i := 1 to Activities do begin
      write(Fileout,Project[i].TaskName:8,' ');
      PlotLine(Start[Project[i].BegNode],' ');
      Slack := Finish[Project[i].EndNode]- Start[Project[i].BegNode] - Project[i].Duration;
      if Slack > 0
         then PlotChar := DuraChar
         else PlotChar := CritChar;
      PlotLine(Project[i].Duration,PlotChar);
      PlotLine(Slack,SlackChar);
      writeln(Fileout);
      end;
  writeln(Fileout);
  writeln(Fileout,'Scaling = ',scale:8:2);
  writeln(Fileout,'LEGEND               Graphic Characters Used');
  write(Fileout,'Scheduled Activity   '); ShowChar(DuraChar,20);
  write(Fileout,'Critical  Activity   '); ShowChar(CritChar,20);
  write(Fileout,'Available Slack      '); ShowChar(SlackChar,20);
  if OutputFile <> CONSOLE
     then begin
          close(Fileout);
          OutputFile := CONSOLE;
          end;
endGANTT:
end; { GANTT }

procedure DiagramCPM(AllowEdit: boolean);
const
  rt_arr = 1;  rt_tee = 2;
  lt_tee = 3;  dn_tee = 4;
  d_conn = 5;  x_conn = 6;
  up_tee = 7;
  maxcol = 20; maxrow = 20;
type
  columns = 1..maxcol;
  lines   = 1..maxrow;
  linkages = array [1..20] of char;
  string8  = string[8];
  string10 = string[10];
  string12 = string[12];
var
  FixFlag             : boolean;
  s_link              : linkages;
  NodeData            : array [1..MaxValue,1..2] of integer;
  space8, space10     : string10;
  space12             : string12;
  screen              : array [columns,lines] of string12;
  ScrnUpdate          : array [lines] of boolean;
  col, row, col2      : integer;
  EndPath             : integer;
  ReDoMap             : boolean;
procedure InitLinks;
begin
  s_link[rt_arr] := chr(16);
  s_link[rt_tee] := chr(195);
  s_link[lt_tee] := chr(180);
  s_link[dn_tee] := chr(194);
  s_link[x_conn] := chr(196);
  s_link[d_conn] := chr(179);
  s_link[up_tee] := chr(217);
  space8 := '          ';
  space10 := space8 + '  ';
  space12 := space10 + '  ';
end;
function Xlate(inchr : char): char;
begin
  if inchr = s_link[rt_arr]
     then Xlate := '>'
  else if inchr = s_link[rt_tee]
       then Xlate := '+'
  else if inchr = s_link[lt_tee]
       then Xlate := '+'
  else if inchr = s_link[dn_tee]
       then Xlate := '|'
  else if inchr = s_link[x_conn]
       then Xlate := '-'
  else if inchr = s_link[d_conn]
       then Xlate := '|'
  else if inchr = s_link[up_tee]
       then Xlate := '^'
  else Xlate := inchr;
end;
procedure InitNodes;
var
  i, row, col : integer;
begin
  for row := 1 to maxrow do begin
    ScrnUpdate[row] := FALSE;
    for col := 1 to maxcol do begin
      screen[col,row] := space12;
      end;
    end;
end;
function connect(linechar : char): string12;
var
  i,j     : integer;
  tempstr : string12;
begin
  tempstr := linechar;
  for i := 1 to 11 do tempstr := tempstr + s_link[x_conn];
  connect := tempstr;
end;
function boxpkg(BoxName : string8; ch1, ch2 : char): string12;
var
  i,j     : integer;
  tempstr : string12;
begin
  tempstr := connect(s_link[x_conn]);
  for i := 1 to length(BoxName) do tempstr[i+1] := BoxName[i];
  tempstr[12] := ch2;
  tempstr[1]  := ch1;
  boxpkg := tempstr;
end;
function NodePkg(NodePtr : integer): string12;
begin
  NodePkg := BoxPkg('Node'+ToSTRING(NodePtr)+']','[',s_link[x_conn]);
end;
function TaskPkg(TaskPtr : integer): string12;
begin
  if Project[TaskPtr].TaskName = ' '
     then TaskPkg := BoxPkg('Task'+ToSTRING(TaskPtr),
                            s_link[x_conn],s_link[rt_arr])
     else TaskPkg := BoxPkg(Project[TaskPtr].TaskName,
                            s_link[x_conn],s_link[rt_arr])
end;
function PointUp: string12;
var
  tempstr : string12;
begin
  tempstr    := space12;
  tempstr[1] := s_link[d_conn];
  PointUp    := tempstr;
end;
function XlateStr(instr: textstring): textstring;
var
  i : integer;
  OneWord : textstring;
begin
  for i := 1 to length(instr) do OneWord[i] := Xlate(instr[i]);
  OneWord[0] := instr[0];
  XlateStr := OneWord;
end;
procedure FindNode(NearestNode : string8; var Row, Col : integer);
begin
  ;
end;
procedure PaintScreen(Ywindow1,Ywindow2,xscroll,yscroll : integer);
const
  width = 12;   { width of screen "pixel" }
var
  i, j, row, col : integer;
  nextline       : integer;
  offset         : integer;
  OneWord        : textstring;
function PaintPtr(instr: textstring): integer;
var
  j, jptr  : integer;
begin
  jptr := 0;
  for j := 1 to 2 do begin
      if ((instr[j] = s_link[rt_tee]) or (instr[j] = s_link[d_conn]) or
          (instr[j] = s_link[up_tee]))
        then jptr := j;
      end;
  PaintPtr := jptr;
end;
procedure PaintToFile;
var
  i, j, row, col : integer;
  OneWord        : textstring;
  LastCol1       : integer;
  LastCol2       : integer;
  ScrnCopy1      : array [1..20] of textstring;
  ScrnCopy2      : array [1..20] of textstring;
begin
  for row := 1 to 20 do begin
    if ScrnUpdate[row] = TRUE
       then begin
            for col := 1 to 20 do begin
                ScrnCopy2[col] := screen[col,row];
                OneWord := space12;
                j := PaintPtr(ScrnCopy2[col]);
                if (j > 0) then OneWord[j] := s_link[d_conn];
                ScrnCopy1[col] := OneWord;
                ScrnCopy1[col] := XlateStr(ScrnCopy1[col]);
                ScrnCopy2[col] := XlateStr(ScrnCopy2[col]);
                end;
            LastCol1 := 20; LastCol2 := 20;
            Repeat
              LastCol1 := pred(LastCol1);
            Until ((ScrnCopy1[LastCol1] <> space12) or (LastCol1 =1));
            Repeat
              LastCol2 := pred(LastCol2);
            Until ((ScrnCopy2[LastCol2] <> space12) or (LastCol2 = 1));
            for j := 1 to LastCol1 do write(Fileout,ScrnCopy1[j]);
            writeln(Fileout);
            for j := 1 to LastCol2 do write(Fileout,ScrnCopy2[j]);
            writeln(Fileout);
            end;
    end;
  close(Fileout);
  OutputFile := CONSOLE;
end;
procedure PaintToCRT(Ywindow1,Ywindow2,offset,xscroll,yscroll: integer);
begin
  for row := Ywindow1 to Ywindow2 do begin
    if ScrnUpdate[row] = TRUE
       then begin
            nextline := 2 * (row - 1) + 1;
            for col := 1 to (79 div width) do begin
                gotoxy(width*(col-1)+1,nextline+offset);
                write(screen[col+xscroll,row+yscroll]);
                j := PaintPtr(screen[col+xscroll,row+yscroll]);
                if j > 0
                   then begin
                        gotoxy(width*(col-1)+j,nextline+offset-1);
                        write(s_link[d_conn]);
                        end;
               end;
            end;
    end;
end;

{ --------- main PaintScreen procedure ------------------------------ }
begin
  if OutputFile = CONSOLE
     then begin
            if ((Ywindow1=1) and (Ywindow2>=20))
               then clrscr
               else for i := Ywindow1 to Ywindow2 do EraseLine(i);
           gotoxy(1,Ywindow1);
         end;
  PageTitle('PERT Chart');
  offset := 3 ;
  if OutputFile <> CONSOLE
     then PaintToFile
     else PaintToCRT(Ywindow1,Ywindow2,offset,xscroll,yscroll);
end;

procedure EditMap(var ReDoMap: boolean);
var
  ch              : char;
  i               : integer;
  xscroll,yscroll : integer;
  xwindow,ywindow : integer;
begin
  xscroll := 0;
  yscroll := 0;
  xwindow := 1;
  ywindow := 20;
  REPEAT
    Commands(ch,'Edit Home Up Down Right Left Quit');
    if ch = 'E'
       then begin
            ywindow := 15;
            Edit(xwindow,ywindow+1);
            for i := ywindow to 24 do EraseLine(i);
            ReDoMap := TRUE;
            end;
    if Pos(ch,'HUDRL') > 0
       then begin
              case ch of
                 'H': begin
                        xscroll := 0;
                        yscroll := 0;
                      end;
                 'R': xscroll := xscroll - 2;
                 'L': xscroll := xscroll + 2;
                 'U': yscroll := yscroll - 1;
                 'D': yscroll := yscroll + 1;
                 end;
            end;
    if xscroll < 0 then xscroll := 0;
    if yscroll < 0 then yscroll := 0;
    if xscroll > 20 then xscroll := 20;
    if ch <> 'Q' then PaintScreen(xwindow,ywindow,xscroll,yscroll);
  UNTIL ((ch = 'Q') or ReDoMap);
end;

function FindLastNode: integer;
var
  i, LastNode    : integer;
begin
  LastNode := Project[1].EndNode;
  for i := 1 to Activities do begin
    if Project[i].EndNode <> 0
       then if Project[i].EndNode > LastNode
               then LastNode := Project[i].EndNode;
    end;
  FindLastNode := LastNode;
end;
procedure BuildMap;
label
  quit;
var
  i, StartNode, row, col : integer;
  TaskNo, j              : integer;
  TaskStack, NodesDone   : array [1..MaxValue] of boolean;
function NextBlock(xcol,yrow : integer) : integer;
var
  col2    : integer;
  OneWord : string12;
begin
  col2 := xcol;
  repeat
    OneWord := screen[col2,yrow];
    if OneWord[1] <> ' '
       then col2 := col2 + 1;
  until OneWord[1] = ' ';
  NextBlock := col2;
end;
function MultiTask(StartNode: integer) : boolean;
var
  i, j : integer;
begin
  j := 0;
  for i := 1 to Activities do begin
    if Project[i].BegNode = StartNode
       then j := succ(j);
  end;
  if j > 1
     then MultiTask := TRUE
     else MultiTask := FALSE;
end; {BuildMap: MultiTask subfunction}
procedure InitStacks;
begin
  for i := 1 to Activities do
      begin
        TaskStack[i] := FALSE;
        NodesDone[i] := FALSE;
      end;
end; { BuildMap: InitStacks subprocedure }
procedure MakeNode(ThisNode: integer; xcol,row : integer;
                   var flag: boolean; var newcol : integer);
var
  i, yrow : integer;
  OneWord : string12;
begin
  if NodesDone[ThisNode] = FALSE
     then begin
          flag := FALSE;
          screen[xcol,row] := NodePkg(ThisNode);
          if ThisNode = FindLastNode
             then begin
                  OneWord := screen[xcol,row];
                  i := length(OneWord) + 1;
                  repeat
                    i := pred(i);
                    if OneWord[i] = s_link[x_conn]
                       then OneWord[i] := ' ';
                 until OneWord[i-1] <> s_link[x_conn];
                 screen[xcol,row] := OneWord;
                 end;
          NodesDone[ThisNode] := TRUE;
          NodeData[ThisNode,1] := xcol;
          NodeData[ThisNode,2] := row;
          end
     else begin
          if xcol = NodeData[ThisNode,1]
             then begin
                  flag := FALSE;
                  end
             else begin
                  repeat
                    screen[xcol,row] := connect(s_link[x_conn]);
                    xcol := succ(xcol);
                  until xcol = NodeData[ThisNode,1];
                  flag := TRUE;
                  newcol := xcol;
                  end;
             for yrow := row downto NodeData[ThisNode,2]
                 do begin
                    if screen[xcol,yrow] = space12
                       then screen[xcol,yrow] := PointUp;
                    end;
          end;
end;
procedure InsertBlocks(ThisNode,xcol,row : integer);
var
  i, j, sel_conn : integer;
  OneWord        : string12;
begin
    j := 0;
    if MultiTask(ThisNode) = TRUE
       then sel_conn := dn_tee
       else sel_conn := x_conn;
    for i := 1 to Activities do begin
      if ((Project[i].BegNode = ThisNode) and (TaskStack[i] = FALSE))
         then begin
              TaskStack[i] := TRUE;
              ScrnUpdate[row+j] := TRUE;
              OneWord := screen[NextBlock(xcol,row+j),row+j];
              OneWord := TaskPkg(i);
              OneWord[1] := s_link[sel_conn];
              if sel_conn = dn_tee then sel_conn := rt_tee;
              screen[xcol,row+j] := OneWord;
              {use "box(NodeName[Project[i].EndNode])" for "nodepkg" later}
              MakeNode(Project[i].EndNode,xcol+1,row+j,FixFlag,col2);
              if FixFlag
                 then InsertBlocks(Project[i].EndNode,col2,row+j)
                 else InsertBlocks(Project[i].EndNode,xcol+2,row+j);
              j := succ(j);
              end;
    end;
end; { BuildMap: InsertBlocks subprocedure }
begin
  InitStacks;
  row := 1; col := 1;
  if FindLastNode > 2
     then EndPath := FindLastNode - 1
     else EndPath := FindLastNode;
  for StartNode := 1 to EndPath do begin
      if NodesDone[StartNode] = FALSE
         then begin
              {use "box(NodeName[StartNode])" for "nodepkg" later}
              col := NextBlock(col,row);
              MakeNode(StartNode,col,row,FixFlag,col2);
              ScrnUpdate[row] := TRUE;
              InsertBlocks(StartNode,col+1,row);
              end;
      end;
end;

begin
  REPEAT
    InitLinks;
    InitNodes;
    ReDoMap := FALSE;
    BuildMap;
    PaintScreen(1,20,0,0);
    if ((OutputFile = CONSOLE) and AllowEdit)
       then EditMap(ReDoMap);
  UNTIL ReDoMap = FALSE;
end;


procedure RunCPM;
var
  i : integer;
begin
  for i := 1 to Activities do
    begin
      Start[i]  := 0.0;
      Finish[i] := 0.0;
    end;
  FindEarlyStart;
  FindLateFinish;
end;
procedure CalcCPM;
begin
  TotalCost := 0;
  PathLen := 0;
  CalculateSlackTime;
end; { CalcCPM }

procedure PipeFile;
var
 ch2, ch3 : char;
procedure PipeFile2;
begin
  Commands(ch3,'CalcSheet Gantt Plot Lotus Quit');
  if ch3 <> 'Q'
     then case ch3 of
       'C': ident('Calc  Sheet for Project: '+ProjectName);
       'G': ident('Gantt Chart for Project: '+ProjectName);
       'P': ident('PERT  Chart for Project: '+ProjectName);
       'L': ident('Lotus File  for Project: '+ProjectName);
       end;
  EraseLine(22);
  EraseLine(23);
  gotoxy(1,22);
  InitOutput;
  if OutputFile <> CONSOLE
     then case ch3 of
          'C': CalcCPM;
          'G': Gantt;
          'P': DiagramCPM(FALSE);
          'L': LotusCPM;
         end;
end;
begin  { ------ PipeFile "main" procedure --------------------------------- }
  REPEAT
    Commands(ch2,'NewProject Output-to-file Quit');
    if ch2 = 'N'
       then begin
            GetData;
            RunCPM;
            end
       else if ch2 = 'O' then PipeFile2;
  UNTIL ch2 = 'Q';
end;

procedure SetFiles;
var
  ch2, ch3 : char;
begin
  if NOT OkToGo
     then begin
          OkToGo := TRUE;
          OutputFile := CONSOLE;
          assign(Fileout,OutputFile);
          rewrite(Fileout);
          GetData;
          RunCPM;
          end
     else PipeFile;
end;
procedure Help;
var
  i   : integer;
  ch2 : char;
begin
  window('HELP SCREEN');
  writeln('F(ile)      : (Re)Select project to process.                  ');
  writeln('            : Setup input data entry - File or Console.       ');
  writeln('            : Output results to selected File.                ');
  writeln('E(dit)      : Modify project tasks and milestones.            ');
  writeln('C(alcSheet) : Calculate project Start, End, Slack, Cost, Etc. ');
  writeln('G(antt)     : Display GANTT chart of project.                 ');
  writeln('P(lot)      : Display project tasks and milestones.           ');
  writeln('Q(uit)      : Terminate IPM and Return to DOS.                ');
  for i := 1 to 78 do write('-'); writeln;
end;
begin  { main }
  ProjectName := '--> No Project Selected <-- ';
  InputFile   := CONSOLE; CurrFile := InputFile;
  OutputFile  := CONSOLE;
  CmdCh := '\';
  OkToGo := FALSE;
  repeat
    if Pos(CmdCh,'CGEH') = 0 then MainMenu;
    Commands(CmdCh,'File CalcSheet Gantt Plot Edit Help Quit');
    If Pos(CmdCh,'FCGPEH') > 0
       then begin
            case CmdCh of
                   'F': SetFiles;
                   'C': if OkToGo then CalcCPM;
                   'G': if OkToGo then Gantt;
                   'H': Help;
                   'P': if OkToGo then DiagramCPM(TRUE);
                   'E': Edit(1,1);
                   end;
            end;
 until CmdCh = 'Q';
end. { CriticalPathMethod }