home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / h / htmix20.zip / MISC.ZIP / TCD.PAS < prev    next >
Pascal/Delphi Source File  |  1992-07-13  |  15KB  |  534 lines
  1. program TCD;
  2. {┌──────────────────────────────── INFO ────────────────────────────────────┐}
  3. {│ File    : TCD.PAS                                                        │}
  4. {│ Author  : Harald Thunem                                                  │}
  5. {│ Purpose : Graphically change directory.                                  │}
  6. {│ Updated : July 10 1992                                                   │}
  7. {└──────────────────────────────────────────────────────────────────────────┘}
  8.  
  9. {────────────────────────── Compiler directives ─────────────────────────────}
  10. {$A+   Word align data                                                       }
  11. {$B-   Short-circuit Boolean expression evaluation                           }
  12. {$E-   Disable linking with 8087-emulating run-time library                  }
  13. {$G+   Enable 80286 code generation                                          }
  14. {$R-   Disable generation of range-checking code                             }
  15. {$S-   Disable generation of stack-overflow checking code                    }
  16. {$V-   String variable checking                                              }
  17. {$X-   Disable Turbo Pascal's extended syntax                                }
  18. {$N+   80x87 code generation                                                 }
  19. {$D-   Disable generation of debug information                               }
  20. {────────────────────────────────────────────────────────────────────────────}
  21.  
  22. uses  Dos,
  23.       Screen,
  24.       Common,
  25.       Keyboard;
  26.  
  27. const MaxDirs    = 1000;
  28.       MainAttr   = White+BlueBG;
  29.       TopAttr    = Blue+LightWhiteBG;
  30.       BottomAttr1= Yellow+CyanBG;
  31.       BottomAttr2= White+CyanBG;
  32.       ScanAttr   = White+CyanBG;
  33.  
  34. type  PDirItem   = ^TDirItem;
  35.       TDirItem   = record
  36.                      ShortName: String[14];
  37.                      LongName : DirStr;
  38.                      Level    : byte;
  39.                    end;
  40.  
  41. var   DirList    : array[1..MaxDirs] of PDirItem;
  42.       LastList   : array[1..MaxDirs] of boolean;
  43.       DriveList  : array[1..26] of char;
  44.       DriveNum,
  45.       NumDrives  : byte;
  46.       NumDirs    : 0..MaxDirs;
  47.       MainDir    : DirStr;
  48.       MainSize   : word;
  49.       MainScr    : pointer;
  50.       SearchStr  : string;
  51.       MaxLevel,
  52.       ScanRow,
  53.       ScanCol,
  54.       CDRow,
  55.       CDCol,
  56.       CDRows,
  57.       CDCols     : byte;
  58.       CDFile     : File of TDirItem;
  59.  
  60.  
  61. procedure GetDrives;
  62. var i,w: byte;
  63. begin
  64.   NumDrives := 1;
  65.   Port[$70] := $14;
  66.   w := Port[$71];
  67.   w := w and $C0;
  68.   DriveList[NumDrives] := 'A';
  69.   if w=$40 then
  70.   begin
  71.     Inc(NumDrives);
  72.     DriveList[NumDrives] := 'B';
  73.   end;
  74.   for i := 3 to 26 do
  75.   if DiskSize(i)>-1 then
  76.   begin
  77.     Inc(NumDrives);
  78.     DriveList[NumDrives] := Chr(i+64);
  79.   end;
  80. end;
  81.  
  82.  
  83. procedure GetFirst(MainDir: DirStr);
  84. begin
  85.   NumDirs := 1;
  86.   GetMem(DirList[1],SizeOf(TDirItem));
  87.   DirList[1]^.ShortName := MainDir+'\';
  88.   DirList[1]^.LongName  := MainDir+'\';
  89.   DirList[1]^.Level     := 0;
  90. end;
  91.  
  92.  
  93. procedure ScanDirs(Dir: DirStr; Level: byte);
  94. var S: SearchRec;
  95. begin
  96.   FindFirst(Dir+'\*.*',AnyFile,S);
  97.   while DosError=0 do
  98.     if ((S.Attr and Directory)=Directory) and (S.Name<>'.') and (S.Name<>'..') then
  99.     begin
  100.       Inc(NumDirs);
  101.       GetMem(DirList[NumDirs],SizeOf(TDirItem));
  102.       DirList[NumDirs]^.ShortName := ' '+S.Name+'           ';
  103.       DirList[NumDirs]^.LongName  := Dir+'\'+S.Name;
  104.       DirList[NumDirs]^.Level     := Level;
  105.       WriteStr(ScanRow,ScanCol,ScanAttr,'            ');
  106.       WriteC(ScanRow,ScanCol+6,ScanAttr,S.Name);
  107.       ScanDirs(Dir+'\'+S.Name,Level+1);
  108.       FindNext(S);
  109.     end
  110.     else FindNext(S);
  111. end;
  112.  
  113.  
  114. procedure SaveToFile(MainDir: DirStr);
  115. var i: word;
  116. begin
  117.   {$I-}
  118.   Assign(CDFile,MainDir+'\TREEINFO.TCD');
  119.   ReWrite(CDFile);
  120.   {$I+}
  121.   if IOResult = 0 then
  122.   begin
  123.     for i := 1 to NumDirs do
  124.       Write(CDFile,DirList[i]^);
  125.     Close(CDFile);
  126.   end
  127.   else MessageBox('Error saving info to file!');
  128. end;
  129.  
  130.  
  131. function ReadFromFile(MainDir: DirStr): boolean;
  132. var i: word;
  133. begin
  134.   {$I-}
  135.   Assign(CDFile,MainDir+'\TREEINFO.TCD');
  136.   ReSet(CDFile);
  137.   {$I+}
  138.   if IOResult=0 then
  139.   begin
  140.     NumDirs := 0;
  141.     while not Eof(CDFile) do
  142.     begin
  143.       Inc(NumDirs);
  144.       GetMem(DirList[NumDirs],SizeOf(TDirItem));
  145.       Read(CDFile,DirList[NumDirs]^);
  146.     end;
  147.     Close(CDFile);
  148.     ReadFromFile := true;
  149.     Exit;
  150.   end;
  151.   ReadFromFile := false;
  152. end;
  153.  
  154.  
  155. procedure FindLast;
  156. var i,j: word;
  157. begin
  158.   MaxLevel := 0;
  159.   for i := 1 to NumDirs do
  160.     if DirList[i]^.Level > MaxLevel then
  161.       MaxLevel := DirList[i]^.Level;
  162.  
  163.   for i := 1 to NumDirs do
  164.     LastList[i] := true;
  165.  
  166.   for i := 1 to NumDirs-1 do
  167.   begin
  168.     for j := i+1 to NumDirs do
  169.       if DirList[j]^.Level = DirList[i]^.Level then LastList[i] := false;
  170.   end;
  171.   LastList[NumDirs] := true;
  172. end;
  173.  
  174.  
  175. procedure BackGround;
  176. var i: byte;
  177. begin
  178.   CDRow := 3;
  179.   CDRows := CRTRows-5;
  180.   CDCols := 19+5*MaxLevel;
  181.   CDCol := 40-(CDCols div 2);
  182.   Fill(CDRow,CDCol,CDRows,CDCols,MainAttr,' ');
  183.   AddShadow(CDRow,CDCol,CDRows,CDCols);
  184.   for i := 1 to CDRows-1 do
  185.   begin
  186.     WriteStr(CDRow+i,CDCol,MainAttr,'█');
  187.     WriteStr(CDRow+i,CDCol+CDCols-1,MainAttr,'█');
  188.   end;
  189.   Fill(CDRow+CDRows-1,CDCol,1,CDCols,MainAttr,'█');
  190.   WriteStr(CDRow+1,CDCol+CDCols-2,White+BlackBG,#24);
  191.   WriteStr(CDRow+CDRows-2,CDCol+CDCols-2,White+BlackBG,#25);
  192.   for i := CDRow+2 to (CDRow+CDRows-3) do
  193.     WriteStr(i,CDCol+CDCols-2,White+BlackBG,'░');
  194.   Fill(CDRow,CDCol,1,CDCols,TopAttr,' ');
  195.   WriteC(CDRow,CDCol+(CDCols div 2),TopAttr,'TCDir 2.0');
  196.   Fill(CRTRows,1,1,80,BottomAttr2,' ');
  197.   WriteStr(CRTRows,3,BottomAttr1,'F2');
  198.   WriteEos(BottomAttr2,' - ReScan   ');
  199.   WriteEos(BottomAttr1,'F3');
  200.   WriteEos(BottomAttr2,' - Drive   ');
  201.   WriteEos(BottomAttr1,'Return');
  202.   WriteEos(BottomAttr2,' - Goto   ');
  203.   WriteEos(BottomAttr1,'Esc');
  204.   WriteEos(BottomAttr2,' - Quit');
  205. end;
  206.  
  207.  
  208. procedure EraseDirs;
  209. var i: word;
  210. begin
  211.   for i := 1 to NumDirs do
  212.     FreeMem(DirList[i],SizeOf(TDirItem));
  213. end;
  214.  
  215.  
  216. procedure ReScan(ForceScan: boolean);
  217. begin
  218.   SearchStr := '';
  219.   if ForceScan then
  220.   begin
  221.     Box(ScanRow-3,ScanCol-12,6,38,ScanAttr,SingleBorder,' ');
  222.     AddShadow(ScanRow-3,ScanCol-12,6,38);
  223.     WriteC(ScanRow-1,ScanCol+6,ScanAttr,'Scanning directory-structure');
  224.     GetFirst(MainDir);
  225.     ScanDirs(MainDir,1);
  226.     SaveToFile(MainDir);
  227.   end
  228.   else
  229.     if not ReadFromFile(MainDir) then
  230.     begin
  231.       Box(ScanRow-3,ScanCol-12,6,38,ScanAttr,SingleBorder,' ');
  232.       AddShadow(ScanRow-3,ScanCol-12,6,38);
  233.       WriteC(ScanRow-1,ScanCol+6,ScanAttr,'Scanning directory-structure');
  234.       GetFirst(MainDir);
  235.       ScanDirs(MainDir,1);
  236.       SaveToFile(MainDir);
  237.     end;
  238.   StoreToScr(1,1,CRTRows,80,MainScr^);
  239.   FindLast;
  240. end;
  241.  
  242.  
  243. procedure ChangeDrive(var DriveNum: byte; var MainDir: DirStr);
  244. var
  245.     i,
  246.     Current,
  247.     DN,
  248.     Start,
  249.     Row,
  250.     Col,
  251.     Rows,
  252.     Cols: byte;
  253. begin
  254.   GetDrives;
  255.   Cols := 11;
  256.   Rows := 8;
  257.   Row := (CRTRows div 2)-4;
  258.   Col := 38-(Cols div 2);
  259.   Box(Row+1,Col,Rows-2,Cols-2,White+LightBlackBG,SingleBorder,' ');
  260.   AddShadow(Row,Col,Rows-1,Cols-2);
  261.   Fill(Row,Col,1,Cols-2,Magenta+LightWhiteBG,' ');
  262.   WriteC(Row,Col+4,SameAttr,'Drive');
  263.   for i := 1 to NumDrives do
  264.   if i < 5 then
  265.     WriteStr(Row+1+i,Col+4,SameAttr,DriveList[i]);
  266.   Start := 1;
  267.   while DriveNum>(Start+3) do
  268.   begin
  269.     Inc(Start);
  270.     ScrollUp(Row+2,Col+2,Rows-4,Cols-6,White+LightBlackBG);
  271.     WriteStr(Row+5,Col+4,SameAttr,DriveList[Start+3]);
  272.   end;
  273.   Current:=0;
  274.   repeat
  275.     Inc(Current)
  276.   until DriveList[Current] = MainDir[1];
  277.   WriteStr(Row+2+Current-Start,Col+2,Blue+LightWhiteBG,'  '+DriveList[Current]+'  ');
  278.   repeat
  279.     Inkey(Ch,Key);
  280.     WriteStr(Row+2+Current-Start,Col+2,White+LightBlackBG,'  '+DriveList[Current]+'  ');
  281.     case Key of
  282.       UpArrow  : if Current>1 then Dec(Current);
  283.       DownArrow: if Current<NumDrives then Inc(Current);
  284.     end;
  285.     if Current<Start then
  286.     begin
  287.       ScrollDown(Row+2,Col+2,Rows-4,Cols-6,White+LightBlackBG);
  288.       Dec(Start);
  289.     end;
  290.     if Current>(Start+3) then
  291.     begin
  292.       ScrollUp(Row+2,Col+2,Rows-4,Cols-6,White+LightBlackBG);
  293.       Inc(Start);
  294.     end;
  295.     WriteStr(Row+2+Current-Start,Col+2,Blue+LightWhiteBG,'  '+DriveList[Current]+'  ');
  296.   until Key in [Return,Escape];
  297.   if (Key=Return) then
  298.   begin
  299.     DN := Ord(DriveList[Current])-64;
  300.     if DiskSize(DN)>-1 then
  301.     begin
  302.       MainDir := DriveList[Current]+':';
  303.       DriveNum := Ord(MainDir[1])-64;
  304.     end
  305.     else MessageBox('No disk in drive!');
  306.   end;
  307.   Key := NullKey;
  308. end;
  309.  
  310.  
  311. procedure ScrollDirs;
  312. const  CurrentAttr = White+RedBG;
  313. var Start,Current: integer;
  314.     OldDriveNum: byte;
  315.     OldMainDir: DirStr;
  316.     s: string;
  317.  
  318.   procedure WriteLine(Current,Start,Attr: word);
  319.   var i,j,OldL,NewL: integer;
  320.       Last: boolean;
  321.       s: string;
  322.       C: char;
  323.   begin
  324.     Last := true;
  325.     s := '';
  326.     if Current=NumDirs then
  327.     begin
  328.       s:='└────';
  329.       with DirList[Current]^ do
  330.       if Level>1 then
  331.       for i := 2 to Level do
  332.         s := '     '+s;
  333.     end
  334.     else
  335.     begin
  336.       OldL := DirList[Current]^.Level;
  337.       i := Current;
  338.       repeat
  339.         Inc(i);
  340.         NewL := DirList[i]^.Level;
  341.       until (NewL<=OldL) or (i=NumDirs);
  342.       if NewL>=OldL then
  343.         s := '├────'
  344.       else s:='└────';
  345.       OldL := DirList[Current]^.Level;
  346.       i := Current;
  347.       repeat
  348.         Inc(i);
  349.         NewL := DirList[i]^.Level;
  350.         if NewL=DirList[Current]^.Level then
  351.           Last := false;
  352.         if OldL > NewL then
  353.         begin
  354.           if OldL-NewL>1 then
  355.           for j := 2 to (OldL-NewL) do
  356.             s := '     ' + s;
  357.           s := '│    ' + s;
  358.           OldL := NewL;
  359.         end;
  360.       until (i=NumDirs) or (NewL=1);
  361.       if NewL>1 then
  362.         for i :=  2 to NewL do
  363.         s := '     ' + s;
  364.       if DirList[Current]^.Level=1 then
  365.       if Last then
  366.         s := '└────'
  367.       else s := '├────';
  368.     end;
  369.     if DirList[Current]^.Level=0 then
  370.       s:='';
  371.     with DirList[Current]^ do
  372.     begin
  373.       WriteStr(CDRow+Current-Start+1,CDCol+2,MainAttr,s);
  374.       WriteStr(CDRow+Current-Start+1,CDCol+2+5*Level,Attr,ShortName);
  375.     end;
  376.   end;
  377.  
  378.   procedure WritePage(Start: word);
  379.   var i: word;
  380.   begin
  381.     Fill(CDRow+1,CDCol+1,CDRows-2,CDCols-3,MainAttr,' ');
  382.     for i := 1 to CDRows-2 do
  383.     if (i+Start-1)<=NumDirs then
  384.       WriteLine(i+Start-1,Start,MainAttr);
  385.   end;
  386.  
  387.   procedure WriteFraction(Current: word);
  388.   var i,Fraction: byte;
  389.   begin
  390.     for i := CDRow+2 to (CDRow+CDRows-3) do
  391.       WriteStr(i,CDCol+CDCols-2,White+BlackBG,'░');
  392.     Fraction := Trunc((CDRows-5)*(Current/NumDirs));
  393.     i := CDRow+2+Fraction;
  394.     WriteStr(i,CDCol+CDCols-2,White+BlackBG,'█');
  395.   end;
  396.  
  397.   procedure CheckPosition;
  398.   begin
  399.     Start := 1;
  400.     Current := 1;
  401.     GetDir(DriveNum,OldMainDir);
  402.     repeat
  403.       Inc(Current);
  404.     until (DirList[Current]^.LongName=OldMainDir) or (Current>=NumDirs);
  405.     if DirList[Current]^.LongName<>OldMainDir then
  406.       Current := 1;
  407.   end;
  408.  
  409. begin
  410.   CheckPosition;
  411.   BackGround;
  412.   Start := Current-(CDRows div 2)+2;
  413.   if Start<1 then Start:=1;
  414.   WritePage(Start);
  415.   WriteLine(Current,Start,CurrentAttr);
  416.   WriteFraction(Current);
  417.   repeat
  418.     InKey(Ch,Key);
  419.     WriteLine(Current,Start,MainAttr);
  420.     case Key of
  421.       UpArrow   : Dec(Current);
  422.       DownArrow : Inc(Current);
  423.       PgUp      : begin
  424.                     Dec(Current,CDRows-3);
  425.                     Dec(Start,CDRows-3);
  426.                     if Start<1 then Start:=1;
  427.                     if Current<1 then Current:=1;
  428.                     WritePage(Start);
  429.                     WriteLine(Current,Start,CurrentAttr);
  430.                     WriteFraction(Current);
  431.                   end;
  432.       PgDn      : begin
  433.                     Inc(Current,CDRows-3);
  434.                     Inc(Start,CDRows-3);
  435.                     if Start>(NumDirs-CDRows+3) then Start:=NumDirs-CDRows+3;
  436.                     if Current>NumDirs then Current:=NumDirs;
  437.                     WritePage(Start);
  438.                     WriteLine(Current,Start,CurrentAttr);
  439.                     WriteFraction(Current);
  440.                   end;
  441.       F2        : if Confirm('Re-scan drive '+MainDir,true) then
  442.                   begin
  443.                     EraseDirs;
  444.                     ReScan(true);
  445.                     CheckPosition;
  446.                     BackGround;
  447.                     Start := Current-(CDRows div 2)+2;
  448.                     if Start<1 then Start:=1;
  449.                     WritePage(Start);
  450.                     WriteLine(Current,Start,CurrentAttr);
  451.                     WriteFraction(Current);
  452.                   end;
  453.       F3        : begin
  454.                     OldDriveNum := DriveNum;
  455.                     ChangeDrive(DriveNum,MainDir);
  456.                     if DriveNum<>OldDriveNum then
  457.                     begin
  458.                       EraseDirs;
  459.                       ReScan(false);
  460.                       CheckPosition;
  461.                       BackGround;
  462.                       Start := Current-(CDRows div 2)+2;
  463.                       WritePage(Start);
  464.                       WriteLine(Current,Start,CurrentAttr);
  465.                       WriteFraction(Current);
  466.                     end
  467.                     else begin
  468.                       BackGround;
  469.                       WritePage(Start);
  470.                       WriteLine(Current,Start,CurrentAttr);
  471.                       WriteFraction(Current);
  472.                     end;
  473.                   end;
  474.     end;
  475.     if Current < 1 then Current := 1;
  476.     if Current > NumDirs then Current := NumDirs;
  477.     if Current < Start then
  478.     begin
  479.       ScrollDown(CDRow+1,CDCol+1,CDRows-2,CDCols-3,MainAttr);
  480.       Dec(Start);
  481.     end;
  482.     if Current >= Start+(CDRows-2) then
  483.     begin
  484.       ScrollUp(CDRow+1,CDCol+1,CDRows-2,CDCols-3,MainAttr);
  485.       Inc(Start);
  486.     end;
  487.     WriteLine(Current,Start,CurrentAttr);
  488.     WriteFraction(Current);
  489.   until Key in [Return,Escape];
  490.   if Key=Return then
  491.   begin
  492.     {$I-}
  493.     ChDir(DirList[Current]^.LongName);
  494.     {$I+}
  495.     if IOResult<>0 then
  496.       MessageBox('Could not find directory '+DirList[Current]^.LongName+'. Quitting...');
  497.   end;
  498. end;
  499.  
  500.  
  501. begin
  502.   Write('TCD 2.0                                                      Written by H.Thunem');
  503.   GetDir(0,MainDir);
  504.   MainDir := Copy(MainDir,1,2);
  505.   DriveNum := Ord(MainDir[1])-64;
  506.   if ParamCount=1 then
  507.   begin
  508.     MainDir := ParamStr(1);
  509.     MainDir[1] := Upcase(MainDir[1]);
  510.     DriveNum := Ord(MainDir[1])-64;
  511.     if Pos(':',MainDir)=0 then
  512.       MainDir := MainDir+':';
  513.     if DiskSize(DriveNum)=-1 then
  514.     begin
  515.       WriteLn('Drive ',MainDir,' does not respond !');
  516.       Halt(1);
  517.     end;
  518.   end;
  519.   MainSize := 2*CRTRows*80;
  520.   GetMem(MainScr,MainSize);
  521.   StoreToMem(1,1,CRTRows,80,MainScr^);
  522.   SetCursor(CursorOff);
  523.   SetIntens;
  524.   ScanRow := (CRTRows div 2);
  525.   ScanCol := 34;
  526.   ReScan(false);
  527.   ScrollDirs;
  528.   EraseDirs;
  529.   SetBlink;
  530.   StoreToScr(1,1,CRTRows,80,MainScr^);
  531.   FreeMem(MainScr,MainSize);
  532.   SetCursor(CursorUnderline);
  533. end.
  534.