---------------------------------------------------
TRUEDIR (program)
---------------------------------------------------
{
  TDIR.EXE
  Version   :  V0.DOS.16.R3.B8
  int.code  :  VD&T971512094630TDIR
  Author    :  Bas S.Th. Verdult
  Copyright :  (c) 1997  Virtal Development & Trade, www.virtal.nl.
               All Rights Reserved.

  Remark    :  TESTapp., incl. 4DOS description support
}

PROGRAM True_DIR;

USES
  DOS, CRT, SORT;   {Unit SORT komt uit de SWAG}

TYPE
  AttrStr          =string[4];
  DescSTR          =string[60];

CONST
  AttrMask         :AttrStr = 'תתתת';

VAR
  DirIn, DirInfo   :SearchRec;
  LineCount        :byte;                        {telt aantal regels op
beeld}
  Ch               :char;                        {keyb. afvanging}
  BekijkPad        :string;                      {Dummy}
  Omsch            :array[1..1000] of DescSTR;   {houdt de omschrijvingen
vast}
  OmschCount       :word;                        {aantal bestanden
omschreven}
  count, count2    :word;                        {Dummy Counters}
  Described        :Boolean;                     {Description file
aanwezig?}
  DirCnt           :word;                        {Directories tellen}
    T     : string;                                  { swap variable }
    GUESS : array[1..1000] of ^string;    { pointer array of strings }
    DirBuf,
    DirDum: array[1..1000] of ^SearchRec;


procedure L_HSORT (LEFT,RIGHT : word);             { Lo-Hi QuickSort }
var LOWER,UPPER,MIDDLE : word;
    PIVOT              : string;
begin
  LOWER := LEFT; UPPER := RIGHT; MIDDLE := (LEFT+RIGHT) div 2;
  PIVOT := GUESS[MIDDLE]^;
  repeat
    while GUESS[LOWER]^ < PIVOT do Inc(LOWER);
    while PIVOT < GUESS[UPPER]^ do Dec(UPPER);
    if LOWER <= UPPER then
      begin
        T := GUESS[LOWER]^; GUESS[LOWER]^ := GUESS[UPPER]^;
        GUESS[UPPER]^ := T; Inc (LOWER); Dec (UPPER);
      end;
  until LOWER > UPPER;
  if LEFT < UPPER then L_HSORT (LEFT, UPPER);
  if LOWER < RIGHT then L_HSORT (LOWER, RIGHT)
end; { L_HSORT }


PROCEDURE CheckScreenFull;
Begin
  if LineCount=24 then
  begin
    Write('       ----------------- Press Any Key to
Continue ------------------');
    repeat until KeyPressed;
    while Keypressed do Ch:=Readkey;
    GotoXY(1, WhereY); Write('
');
    GotoXY(1, WhereY);
    LineCount:=0;
  end;
End; {ScreenFull}

PROCEDURE LoadDescriptions;
var infofile :text;
Begin
  Described := FALSE;
  FillChar(Omsch, SizeOf(Omsch), #0);
  {$I-}
  Assign(infofile, 'DESCRIPT.ION');
  Reset(infofile);
  {$I+}
  if IOresult = 0 then
  begin
    Described := TRUE;
    OmschCount := 0;
    while not EOF(infofile) do
    begin
      inc(OmschCount);
      FillChar(Omsch[OmschCount], SizeOf(Omsch[OmschCount]), #0);
      ReadLn(infofile, Omsch[OmschCount]);
    end;
    Close(infofile);
  end;
End; {LoadDescriptions}


FUNCTION FixedName :string;
Var dum, dum2 :string;
Begin
  FixedName := '                          ';
  If POS('.', DirInfo.name) <> 0 then
  begin
    Dum2 := Copy(DirInfo.Name, 1, Pos('.', DirInfo.name)-1);
    Dum := Copy(DirInfo.Name, Pos('.', DirInfo.name), 4);
    Dum2:=Dum2+'            ';
    Insert(Dum, Dum2, 9);
    FixedName := Dum2;
  end
  else
    FixedName := DirInfo.name;
End; {fixedname}


FUNCTION FixedAttr :AttrStr;
Var Dumske :AttrStr;
Begin
  Dumske := AttrMask;
{ If DirInfo.attr = 0         then DUMske := '------';}
  If DirInfo.attr AND  1 =  1 then DUMske[1] := 'R';
  If DirInfo.attr AND  2 =  2 then DUMske[3] := 'H';
  if DirInfo.attr AND  4 =  4 then DUMske[2] := 'S';
{  if DirInfo.attr AND  8 =  8 then DUMske[2] := 'V';}
{  if DirInfo.attr AND 16 = 16 then DUMske[1] := 'D';}
  if DirInfo.attr AND 32 = 32 then DUMske[4] := 'A';
  FixedAttr := Dumske;
End; {FixedAttr}


PROCEDURE FixedSize;
Begin
  if (DirInfo.attr and 8 =8) then Write('VOL ')
  else
  if (DirInfo.attr and 16 =16) then Write('DIR ')
  else
    if DirInfo.Size >= 1073741824 then
                           begin
                             Write(DirInfo.Size / 1073741824 :3:0, 'G');
                           end
    else
    if DirInfo.Size >= 1048576 then
                           begin
                             Write(DirInfo.Size / 1048576 :3:0, 'M');
                           end
    else
    if DirInfo.Size >= 1024 then
                           begin
                             Write(DirInfo.Size / 1024 :3:0, 'k');
                           end
    else
    if DirInfo.Size >= 0 then
                           begin
                             Write(DirInfo.Size /1 :3:0, ' ');
                           end
                           else Write('<><>');
End; {FixedSize}


PROCEDURE FixedDate;
Var datum :datetime;
  function LZero(w : Word) : String;
  var
    s : String;
  begin
    Str(w:0,s);
    if Length(s) = 1 then
      s := '0' + s;
    LZero := s;
  end;
Begin
  UnpackTime(DirInfo.time, datum);
  Write(Lzero(datum.day),'-',Lzero(datum.month),'-',Lzero(datum.year));
End; {FixedDate}


PROCEDURE FixedTime;
Var tijd :datetime;
  function LZero(w : Word) : String;
  var
    s : String;
  begin
    Str(w:0,s);
    if Length(s) = 1 then
      s := '0' + s;
    LZero := s;
  end;
Begin
  UnpackTime(DirInfo.time, tijd);
  Write(Lzero(tijd.hour),':',Lzero(tijd.min){,':',Lzero(tijd.sec)});
End; {FixedTime}


PROCEDURE WhatLine;
Begin
  if (DirInfo.attr and 8 = 8) or (DirInfo.attr and 16 = 16) then
     Write(#186) else Write(#179);
End; {WhatLine}


PROCEDURE FixDescription;
var teller :word;
    vlag   :Boolean;
  function UpCaseStr(invoer :string) :string;
  var cnt :byte;
      dum :string;
  begin
    dum := '';
    for CNT := 1 to ORD(invoer[0]) do
                dum := dum + Upcase(invoer[cnt]);
    UpCaseStr := Dum;
  end;

Begin
  teller :=0;
  vlag   := FALSE;
  IF Described THEN
  begin
    repeat
      Inc(teller,1);
      IF (POS(DirInfo.Name, UpcaseStr(Omsch[teller])) = 1) then Vlag :=
TRUE;
    until (Vlag = TRUE) or (Teller = OmschCount);
    if (Vlag = TRUE) then
    begin
      Delete(Omsch[teller], 1, POS(' ', Omsch[teller]));
      if Length(omsch[teller]) > 40 then Delete(omsch[teller], 40+1,
Length(omsch[teller])-40);
      if Length(omsch[teller]) = 40 then Write(Omsch[teller])
                                    else WriteLN(Omsch[teller]);
    end else WriteLN(DirInfo.Name);
  end {if described}
  else WriteLN(DirInfo.Name);
End; {FixDescription}


PROCEDURE Sorteer;
Begin
  for count := 1 to DirCnt do
  begin
    New(Guess[count]);
    Guess[count]^ := DirBuf[count]^.name;
  end;
  L_HSORT(1,DirCnt);
  for count := 1 to DirCnt do
  begin
    count2 := 0;
    New(DirDum[count]);
    repeat
      inc(count2,1);
    until (Guess[count]^ = DirBuf[count2]^.name);
    DirDum[count]^ := DirBuf[count2]^;
  end;
  for count := 1 to DirCnt do
  begin
    Dispose(Guess[count]);
    Dispose(DirBuf[count]);
  end;
End; {Sorteer}


PROCEDURE ShowFiles;
Begin
    GotoXY(27, WhereY); WhatLine; Write(FixedName);
    GotoXY(17, WhereY); Whatline; Write(FixedAttr);
    GotoXY(22, WhereY); WhatLine; FixedSize;
    GotoXY( 1, WhereY); FixedDate;
    GotoXY(11, WhereY); WhatLine; FixedTime;
    GotoXY(40, WhereY); WhatLine; FixDescription;
End; {ShowFiles}



{ ==========================================================================
 }

BEGIN
  ClrScr;
  DirCnt := 0;
  BekijkPad := '*.*';
{  ChDir('D:\bp\project');}
  LineCount:=0;
  LoadDescriptions;
  FindFirst(BekijkPad, 255, DirIn);
  While DOSerror=0 do
  begin
    if (DirIn.attr and 16 =16) or
       (DirIn.attr and  8 = 8) then
    begin
      Inc(DirCnt);
      New(DirBuf[DirCnt]);
      DirBuf[DirCnt]^ := DirIn;
    end;
    FindNext(DirIn);
  end;
  Sorteer;
  for count := 1 to DirCnt do
  begin
    DirInfo := DirDum[count]^;
    Inc(LineCount);
    ShowFiles;
    CheckScreenFull;
    Dispose(DirDum[count]);
  end;
  DirCnt := 0;

  FindFirst(BekijkPad, 39, DirIn);
  While DOSerror=0 do
  begin
    FindNext(DirIn);
      Inc(DirCnt);
      New(DirBuf[DirCnt]);
      DirBuf[DirCnt]^ := DirIn;
  end;
  Sorteer;
  for count := 1 to DirCnt do
  begin
    DirInfo := DirDum[count]^;
    Inc(LineCount);
    ShowFiles;
    CheckScreenFull;
    Dispose(DirDum[count]);
  end;
END.


---------------------------------------------------
SORT UNIT (Needed to compile above program)
---------------------------------------------------
UNIT Sort;

  { These sort routines are for arrays of Integers.  Count is the maximum }
  { number of items in the array.                                         }

{***************************************************************************
*}
                             INTERFACE
{***************************************************************************
*}
FUNCTION  BinarySearch (VAR A; X : Integer; Count : Integer) : Integer;
PROCEDURE BubbleSort (VAR A; Count : Integer); {slow}
PROCEDURE CombSort (VAR A; Count : Integer);
PROCEDURE QuickSort (VAR A; Count : Integer);  {fast}
FUNCTION  SequentialSearch (VAR A; X : Integer; Count : Integer) : Integer;
PROCEDURE ShellSort (VAR A; Count : Integer);  {moderate}
{***************************************************************************
*}
                             IMPLEMENTATION
{***************************************************************************
*}
TYPE
  SortArray = ARRAY[0..0] OF Integer;
{***************************************************************************
*}
{                                                                           
 }
{                   Local Procedures and
          }
{                                                                           
 }
{***************************************************************************
*}
PROCEDURE Swap (VAR A, B : Integer);
VAR C : Integer;
BEGIN
   C := A;
   A := B;
   B := C;
END;
{***************************************************************************
*}
{                                                                           
 }
{                   Global Procedures and
          }
{                                                                           
 }
{***************************************************************************
*}
FUNCTION BinarySearch (VAR A; X : Integer; Count : Integer) : Integer;
VAR High, Low, Mid : Integer;
BEGIN
  Low := 1;
  High := Count;
      WHILE High >= Low DO
         BEGIN
            Mid := Trunc(High + Low) DIV 2;
            IF X > SortArray(A)[mid]
               THEN Low := Mid + 1
               ELSE IF X < SortArray(A)[Mid]
                       THEN High := Mid - 1
                       ELSE High := -1;
         END;
      IF High = -1
         THEN BinarySearch := Mid
         ELSE BinarySearch := 0;
   END;
{***************************************************************************
*}
PROCEDURE BubbleSort (VAR A; Count : Integer);
VAR i, j : Integer;
BEGIN
   FOR i := 2 TO Count DO
     FOR j := Count DOWNTO i DO
       IF SortArray(A)[j-1] > SortArray(A)[j]
          THEN Swap(SortArray(A)[j],SortArray(A)[j-1]);
END;
{***************************************************************************
*}
PROCEDURE CombSort (VAR A; Count : Integer);
  { The combsort is an optimised version of the bubble sort. It uses a     }
  { decreasing gap in order to compare values of more than one element     }
  { apart.  By decreasing the gap the array is gradually "combed" into     }
  { order ... like combing your hair. First you get rid of the large       }
  { tangles, then the smaller ones ...                                     }
  { There are a few particular things about the combsort.                  }
  { Firstly, the optimal shrink factor is 1.3 (worked out through a        }
  { process of exhaustion by the guys at BYTE magazine). Secondly, by      }
  { never having a gap of 9 or 10, but always using 11, the sort is        }
  { faster.                                                                }
  { This sort approximates an n log n sort - it's faster than any other    }
  { sort I've seen except the quicksort (and it beats that too sometimes). }
  { The combsort does not slow down under *any* circumstances. In fact, on }
  { partially sorted lists (including *reverse* sorted lists) it speeds up.}
CONST ShrinkFactor = 1.3;  { Optimal shrink factor ...       }
VAR
  Gap, i, Temp : Integer;
  Finished : Boolean;
BEGIN
  Gap := Trunc(ShrinkFactor);
  REPEAT
    Finished := TRUE;
    Gap := Trunc(Gap/ShrinkFactor);
    IF Gap < 1
       THEN { Gap must *never* be less than 1 } Gap := 1
       ELSE IF Gap IN [9,10]
               THEN { Optimises the sort ... } Gap := 11;
    FOR i := 1 TO (Count - Gap) DO
      IF SortArray(A)[i] < SortArray(A)[i+gap]
         THEN BEGIN
                Swap(SortArray(A)[i],SortArray(A)[i + Gap]);
                Finished := FALSE;
              END;
  UNTIL (Gap = 1) AND Finished;
END;
{***************************************************************************
*}
PROCEDURE QuickSort (VAR A; Count : Integer);

{**************************************************************************}
  PROCEDURE PartialSort(LowerBoundary, UpperBoundary : Integer; VAR A);
  VAR ii, l1, r1, i, j, k : Integer;
  BEGIN
    k := (SortArray(A)[LowerBoundary] + SortArray(A)[UpperBoundary]) DIV 2;
    i := LowerBoundary;
    j := UpperBoundary;
    REPEAT
      WHILE SortArray(A)[i] < k DO Inc(i);
      WHILE k < SortArray(A)[j] DO Dec(j);
      IF i <= j
         THEN BEGIN
                Swap(SortArray(A)[i],SortArray(A)[j]);
                Inc(i);
                Dec(j);
              END;
    UNTIL i > j;
    IF LowerBoundary < j
       THEN PartialSort(LowerBoundary,j,A);
    IF i < UpperBoundary
       THEN PartialSort(UpperBoundary,i,A);
  END;

{*************************************************************************}
BEGIN
  PartialSort(1,Count,A);
END;
{***************************************************************************
*}
FUNCTION SequentialSearch (VAR A; X : Integer; Count : Integer) : Integer;
VAR i : Integer;
BEGIN
  FOR i := 1 TO Count DO
    IF X = Sortarray(A)[i]
       THEN BEGIN
              SequentialSearch := i;
              Exit;
            END;
  SequentialSearch := 0;
END;
{***************************************************************************
*}
PROCEDURE ShellSort (VAR A; Count : Integer);
VAR Gap, i, j, k : Integer;
BEGIN
  Gap := Count DIV 2;
  WHILE (gap > 0) DO
    BEGIN
      FOR i := (Gap + 1) TO Count DO
        BEGIN
          j := i - Gap;
          WHILE (j > 0) DO
            BEGIN
              k := j + gap;
              IF (SortArray(A)[j] <= SortArray(A)[k])
                 THEN j := 0
                 ELSE Swap(SortArray(A)[j],SortArray(A)[k]);
              j := j - Gap;
            END;
        END;
      Gap := Gap DIV 2;
    END;
END;
{***************************************************************************
**}
END.

