Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/HTMIX20.ZIP/MISC.ZIP/TCD.PAS

Pascal/Delphi Source File | 1992-07-13 | 15.0 KB | 534 lines

program TCD;
{┌──────────────────────────────── INFO ────────────────────────────────────┐}
{│ File    : TCD.PAS                                                        │}
{│ Author  : Harald Thunem                                                  │}
{│ Purpose : Graphically change directory.                                  │}
{│ Updated : July 10 1992                                                   │}
{└──────────────────────────────────────────────────────────────────────────┘}

{────────────────────────── Compiler directives ─────────────────────────────}
{$A+   Word align data                                                       }
{$B-   Short-circuit Boolean expression evaluation                           }
{$E-   Disable linking with 8087-emulating run-time library                  }
{$G+   Enable 80286 code generation                                          }
{$R-   Disable generation of range-checking code                             }
{$S-   Disable generation of stack-overflow checking code                    }
{$V-   String variable checking                                              }
{$X-   Disable Turbo Pascal's extended syntax                                }
{$N+   80x87 code generation                                                 }
{$D-   Disable generation of debug information                               }
{────────────────────────────────────────────────────────────────────────────}

uses  Dos,
      Screen,
      Common,
      Keyboard;

const MaxDirs    = 1000;
      MainAttr   = White+BlueBG;
      TopAttr    = Blue+LightWhiteBG;
      BottomAttr1= Yellow+CyanBG;
      BottomAttr2= White+CyanBG;
      ScanAttr   = White+CyanBG;

type  PDirItem   = ^TDirItem;
      TDirItem   = record
                     ShortName: String[14];
                     LongName : DirStr;
                     Level    : byte;
                   end;

var   DirList    : array[1..MaxDirs] of PDirItem;
      LastList   : array[1..MaxDirs] of boolean;
      DriveList  : array[1..26] of char;
      DriveNum,
      NumDrives  : byte;
      NumDirs    : 0..MaxDirs;
      MainDir    : DirStr;
      MainSize   : word;
      MainScr    : pointer;
      SearchStr  : string;
      MaxLevel,
      ScanRow,
      ScanCol,
      CDRow,
      CDCol,
      CDRows,
      CDCols     : byte;
      CDFile     : File of TDirItem;


procedure GetDrives;
var i,w: byte;
begin
  NumDrives := 1;
  Port[$70] := $14;
  w := Port[$71];
  w := w and $C0;
  DriveList[NumDrives] := 'A';
  if w=$40 then
  begin
    Inc(NumDrives);
    DriveList[NumDrives] := 'B';
  end;
  for i := 3 to 26 do
  if DiskSize(i)>-1 then
  begin
    Inc(NumDrives);
    DriveList[NumDrives] := Chr(i+64);
  end;
end;


procedure GetFirst(MainDir: DirStr);
begin
  NumDirs := 1;
  GetMem(DirList[1],SizeOf(TDirItem));
  DirList[1]^.ShortName := MainDir+'\';
  DirList[1]^.LongName  := MainDir+'\';
  DirList[1]^.Level     := 0;
end;


procedure ScanDirs(Dir: DirStr; Level: byte);
var S: SearchRec;
begin
  FindFirst(Dir+'\*.*',AnyFile,S);
  while DosError=0 do
    if ((S.Attr and Directory)=Directory) and (S.Name<>'.') and (S.Name<>'..') then
    begin
      Inc(NumDirs);
      GetMem(DirList[NumDirs],SizeOf(TDirItem));
      DirList[NumDirs]^.ShortName := ' '+S.Name+'           ';
      DirList[NumDirs]^.LongName  := Dir+'\'+S.Name;
      DirList[NumDirs]^.Level     := Level;
      WriteStr(ScanRow,ScanCol,ScanAttr,'            ');
      WriteC(ScanRow,ScanCol+6,ScanAttr,S.Name);
      ScanDirs(Dir+'\'+S.Name,Level+1);
      FindNext(S);
    end
    else FindNext(S);
end;


procedure SaveToFile(MainDir: DirStr);
var i: word;
begin
  {$I-}
  Assign(CDFile,MainDir+'\TREEINFO.TCD');
  ReWrite(CDFile);
  {$I+}
  if IOResult = 0 then
  begin
    for i := 1 to NumDirs do
      Write(CDFile,DirList[i]^);
    Close(CDFile);
  end
  else MessageBox('Error saving info to file!');
end;


function ReadFromFile(MainDir: DirStr): boolean;
var i: word;
begin
  {$I-}
  Assign(CDFile,MainDir+'\TREEINFO.TCD');
  ReSet(CDFile);
  {$I+}
  if IOResult=0 then
  begin
    NumDirs := 0;
    while not Eof(CDFile) do
    begin
      Inc(NumDirs);
      GetMem(DirList[NumDirs],SizeOf(TDirItem));
      Read(CDFile,DirList[NumDirs]^);
    end;
    Close(CDFile);
    ReadFromFile := true;
    Exit;
  end;
  ReadFromFile := false;
end;


procedure FindLast;
var i,j: word;
begin
  MaxLevel := 0;
  for i := 1 to NumDirs do
    if DirList[i]^.Level > MaxLevel then
      MaxLevel := DirList[i]^.Level;

  for i := 1 to NumDirs do
    LastList[i] := true;

  for i := 1 to NumDirs-1 do
  begin
    for j := i+1 to NumDirs do
      if DirList[j]^.Level = DirList[i]^.Level then LastList[i] := false;
  end;
  LastList[NumDirs] := true;
end;


procedure BackGround;
var i: byte;
begin
  CDRow := 3;
  CDRows := CRTRows-5;
  CDCols := 19+5*MaxLevel;
  CDCol := 40-(CDCols div 2);
  Fill(CDRow,CDCol,CDRows,CDCols,MainAttr,' ');
  AddShadow(CDRow,CDCol,CDRows,CDCols);
  for i := 1 to CDRows-1 do
  begin
    WriteStr(CDRow+i,CDCol,MainAttr,'█');
    WriteStr(CDRow+i,CDCol+CDCols-1,MainAttr,'█');
  end;
  Fill(CDRow+CDRows-1,CDCol,1,CDCols,MainAttr,'█');
  WriteStr(CDRow+1,CDCol+CDCols-2,White+BlackBG,#24);
  WriteStr(CDRow+CDRows-2,CDCol+CDCols-2,White+BlackBG,#25);
  for i := CDRow+2 to (CDRow+CDRows-3) do
    WriteStr(i,CDCol+CDCols-2,White+BlackBG,'░');
  Fill(CDRow,CDCol,1,CDCols,TopAttr,' ');
  WriteC(CDRow,CDCol+(CDCols div 2),TopAttr,'TCDir 2.0');
  Fill(CRTRows,1,1,80,BottomAttr2,' ');
  WriteStr(CRTRows,3,BottomAttr1,'F2');
  WriteEos(BottomAttr2,' - ReScan   ');
  WriteEos(BottomAttr1,'F3');
  WriteEos(BottomAttr2,' - Drive   ');
  WriteEos(BottomAttr1,'Return');
  WriteEos(BottomAttr2,' - Goto   ');
  WriteEos(BottomAttr1,'Esc');
  WriteEos(BottomAttr2,' - Quit');
end;


procedure EraseDirs;
var i: word;
begin
  for i := 1 to NumDirs do
    FreeMem(DirList[i],SizeOf(TDirItem));
end;


procedure ReScan(ForceScan: boolean);
begin
  SearchStr := '';
  if ForceScan then
  begin
    Box(ScanRow-3,ScanCol-12,6,38,ScanAttr,SingleBorder,' ');
    AddShadow(ScanRow-3,ScanCol-12,6,38);
    WriteC(ScanRow-1,ScanCol+6,ScanAttr,'Scanning directory-structure');
    GetFirst(MainDir);
    ScanDirs(MainDir,1);
    SaveToFile(MainDir);
  end
  else
    if not ReadFromFile(MainDir) then
    begin
      Box(ScanRow-3,ScanCol-12,6,38,ScanAttr,SingleBorder,' ');
      AddShadow(ScanRow-3,ScanCol-12,6,38);
      WriteC(ScanRow-1,ScanCol+6,ScanAttr,'Scanning directory-structure');
      GetFirst(MainDir);
      ScanDirs(MainDir,1);
      SaveToFile(MainDir);
    end;
  StoreToScr(1,1,CRTRows,80,MainScr^);
  FindLast;
end;


procedure ChangeDrive(var DriveNum: byte; var MainDir: DirStr);
var
    i,
    Current,
    DN,
    Start,
    Row,
    Col,
    Rows,
    Cols: byte;
begin
  GetDrives;
  Cols := 11;
  Rows := 8;
  Row := (CRTRows div 2)-4;
  Col := 38-(Cols div 2);
  Box(Row+1,Col,Rows-2,Cols-2,White+LightBlackBG,SingleBorder,' ');
  AddShadow(Row,Col,Rows-1,Cols-2);
  Fill(Row,Col,1,Cols-2,Magenta+LightWhiteBG,' ');
  WriteC(Row,Col+4,SameAttr,'Drive');
  for i := 1 to NumDrives do
  if i < 5 then
    WriteStr(Row+1+i,Col+4,SameAttr,DriveList[i]);
  Start := 1;
  while DriveNum>(Start+3) do
  begin
    Inc(Start);
    ScrollUp(Row+2,Col+2,Rows-4,Cols-6,White+LightBlackBG);
    WriteStr(Row+5,Col+4,SameAttr,DriveList[Start+3]);
  end;
  Current:=0;
  repeat
    Inc(Current)
  until DriveList[Current] = MainDir[1];
  WriteStr(Row+2+Current-Start,Col+2,Blue+LightWhiteBG,'  '+DriveList[Current]+'  ');
  repeat
    Inkey(Ch,Key);
    WriteStr(Row+2+Current-Start,Col+2,White+LightBlackBG,'  '+DriveList[Current]+'  ');
    case Key of
      UpArrow  : if Current>1 then Dec(Current);
      DownArrow: if Current<NumDrives then Inc(Current);
    end;
    if Current<Start then
    begin
      ScrollDown(Row+2,Col+2,Rows-4,Cols-6,White+LightBlackBG);
      Dec(Start);
    end;
    if Current>(Start+3) then
    begin
      ScrollUp(Row+2,Col+2,Rows-4,Cols-6,White+LightBlackBG);
      Inc(Start);
    end;
    WriteStr(Row+2+Current-Start,Col+2,Blue+LightWhiteBG,'  '+DriveList[Current]+'  ');
  until Key in [Return,Escape];
  if (Key=Return) then
  begin
    DN := Ord(DriveList[Current])-64;
    if DiskSize(DN)>-1 then
    begin
      MainDir := DriveList[Current]+':';
      DriveNum := Ord(MainDir[1])-64;
    end
    else MessageBox('No disk in drive!');
  end;
  Key := NullKey;
end;


procedure ScrollDirs;
const  CurrentAttr = White+RedBG;
var Start,Current: integer;
    OldDriveNum: byte;
    OldMainDir: DirStr;
    s: string;

  procedure WriteLine(Current,Start,Attr: word);
  var i,j,OldL,NewL: integer;
      Last: boolean;
      s: string;
      C: char;
  begin
    Last := true;
    s := '';
    if Current=NumDirs then
    begin
      s:='└────';
      with DirList[Current]^ do
      if Level>1 then
      for i := 2 to Level do
        s := '     '+s;
    end
    else
    begin
      OldL := DirList[Current]^.Level;
      i := Current;
      repeat
        Inc(i);
        NewL := DirList[i]^.Level;
      until (NewL<=OldL) or (i=NumDirs);
      if NewL>=OldL then
        s := '├────'
      else s:='└────';
      OldL := DirList[Current]^.Level;
      i := Current;
      repeat
        Inc(i);
        NewL := DirList[i]^.Level;
        if NewL=DirList[Current]^.Level then
          Last := false;
        if OldL > NewL then
        begin
          if OldL-NewL>1 then
          for j := 2 to (OldL-NewL) do
            s := '     ' + s;
          s := '│    ' + s;
          OldL := NewL;
        end;
      until (i=NumDirs) or (NewL=1);
      if NewL>1 then
        for i :=  2 to NewL do
        s := '     ' + s;
      if DirList[Current]^.Level=1 then
      if Last then
        s := '└────'
      else s := '├────';
    end;
    if DirList[Current]^.Level=0 then
      s:='';
    with DirList[Current]^ do
    begin
      WriteStr(CDRow+Current-Start+1,CDCol+2,MainAttr,s);
      WriteStr(CDRow+Current-Start+1,CDCol+2+5*Level,Attr,ShortName);
    end;
  end;

  procedure WritePage(Start: word);
  var i: word;
  begin
    Fill(CDRow+1,CDCol+1,CDRows-2,CDCols-3,MainAttr,' ');
    for i := 1 to CDRows-2 do
    if (i+Start-1)<=NumDirs then
      WriteLine(i+Start-1,Start,MainAttr);
  end;

  procedure WriteFraction(Current: word);
  var i,Fraction: byte;
  begin
    for i := CDRow+2 to (CDRow+CDRows-3) do
      WriteStr(i,CDCol+CDCols-2,White+BlackBG,'░');
    Fraction := Trunc((CDRows-5)*(Current/NumDirs));
    i := CDRow+2+Fraction;
    WriteStr(i,CDCol+CDCols-2,White+BlackBG,'█');
  end;

  procedure CheckPosition;
  begin
    Start := 1;
    Current := 1;
    GetDir(DriveNum,OldMainDir);
    repeat
      Inc(Current);
    until (DirList[Current]^.LongName=OldMainDir) or (Current>=NumDirs);
    if DirList[Current]^.LongName<>OldMainDir then
      Current := 1;
  end;

begin
  CheckPosition;
  BackGround;
  Start := Current-(CDRows div 2)+2;
  if Start<1 then Start:=1;
  WritePage(Start);
  WriteLine(Current,Start,CurrentAttr);
  WriteFraction(Current);
  repeat
    InKey(Ch,Key);
    WriteLine(Current,Start,MainAttr);
    case Key of
      UpArrow   : Dec(Current);
      DownArrow : Inc(Current);
      PgUp      : begin
                    Dec(Current,CDRows-3);
                    Dec(Start,CDRows-3);
                    if Start<1 then Start:=1;
                    if Current<1 then Current:=1;
                    WritePage(Start);
                    WriteLine(Current,Start,CurrentAttr);
                    WriteFraction(Current);
                  end;
      PgDn      : begin
                    Inc(Current,CDRows-3);
                    Inc(Start,CDRows-3);
                    if Start>(NumDirs-CDRows+3) then Start:=NumDirs-CDRows+3;
                    if Current>NumDirs then Current:=NumDirs;
                    WritePage(Start);
                    WriteLine(Current,Start,CurrentAttr);
                    WriteFraction(Current);
                  end;
      F2        : if Confirm('Re-scan drive '+MainDir,true) then
                  begin
                    EraseDirs;
                    ReScan(true);
                    CheckPosition;
                    BackGround;
                    Start := Current-(CDRows div 2)+2;
                    if Start<1 then Start:=1;
                    WritePage(Start);
                    WriteLine(Current,Start,CurrentAttr);
                    WriteFraction(Current);
                  end;
      F3        : begin
                    OldDriveNum := DriveNum;
                    ChangeDrive(DriveNum,MainDir);
                    if DriveNum<>OldDriveNum then
                    begin
                      EraseDirs;
                      ReScan(false);
                      CheckPosition;
                      BackGround;
                      Start := Current-(CDRows div 2)+2;
                      WritePage(Start);
                      WriteLine(Current,Start,CurrentAttr);
                      WriteFraction(Current);
                    end
                    else begin
                      BackGround;
                      WritePage(Start);
                      WriteLine(Current,Start,CurrentAttr);
                      WriteFraction(Current);
                    end;
                  end;
    end;
    if Current < 1 then Current := 1;
    if Current > NumDirs then Current := NumDirs;
    if Current < Start then
    begin
      ScrollDown(CDRow+1,CDCol+1,CDRows-2,CDCols-3,MainAttr);
      Dec(Start);
    end;
    if Current >= Start+(CDRows-2) then
    begin
      ScrollUp(CDRow+1,CDCol+1,CDRows-2,CDCols-3,MainAttr);
      Inc(Start);
    end;
    WriteLine(Current,Start,CurrentAttr);
    WriteFraction(Current);
  until Key in [Return,Escape];
  if Key=Return then
  begin
    {$I-}
    ChDir(DirList[Current]^.LongName);
    {$I+}
    if IOResult<>0 then
      MessageBox('Could not find directory '+DirList[Current]^.LongName+'. Quitting...');
  end;
end;


begin
  Write('TCD 2.0                                                      Written by H.Thunem');
  GetDir(0,MainDir);
  MainDir := Copy(MainDir,1,2);
  DriveNum := Ord(MainDir[1])-64;
  if ParamCount=1 then
  begin
    MainDir := ParamStr(1);
    MainDir[1] := Upcase(MainDir[1]);
    DriveNum := Ord(MainDir[1])-64;
    if Pos(':',MainDir)=0 then
      MainDir := MainDir+':';
    if DiskSize(DriveNum)=-1 then
    begin
      WriteLn('Drive ',MainDir,' does not respond !');
      Halt(1);
    end;
  end;
  MainSize := 2*CRTRows*80;
  GetMem(MainScr,MainSize);
  StoreToMem(1,1,CRTRows,80,MainScr^);
  SetCursor(CursorOff);
  SetIntens;
  ScanRow := (CRTRows div 2);
  ScanCol := 34;
  ReScan(false);
  ScrollDirs;
  EraseDirs;
  SetBlink;
  StoreToScr(1,1,CRTRows,80,MainScr^);
  FreeMem(MainScr,MainSize);
  SetCursor(CursorUnderline);
end.