Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TRAVER.ZIP/TRAVERSE.PAS

Pascal/Delphi Source File | 1988-09-04 | 41.7 KB | 1,256 lines

PROGRAM TRAVERSE;

{$B-,D+,R-,S-,T+,V-}
{$DEFINE nSelfConfigure}               { Set to "SelfConfigure" to make   }
                                       { self-configuring EXE file        }
USES Crt, Dos;

{  ┌────────────────────────────────────────────────────┐
   │ Define data types                                  │
   └────────────────────────────────────────────────────┘
}

TYPE

  Fptr      = ^Dir_Rec;

  Dir_Rec   = RECORD                   { Dble ptr. record for dir. entries }
                DirChr  : char;
                DirName : string[12];
                Next    : Fptr;
                Prev    : Fptr;
              END;

  str_type  = string[12];

  panel     = array [1..4000] of byte;           { For saving screen image }

  DriveList = 'A'..'Z';

  ConfigType =
    RECORD
      Cnt_CurFlag : boolean;
      LoopDirFlag : boolean;
      AutoSize    : boolean;
      Row_BEGIN   : integer;          { Absolute screen Row/Col for        }
      Col_BEGIN   : integer;          { Location of Upper Left Corner      }
                                      { of dir. selection window           }
                                      { Absolute screen Col for            }
      Act_Attr    : integer;          { Active (highlighted) dir. vid attr }
      IAct_Attr   : integer;          { Inactive dir. video attribute      }
      Wndw_Bdr    : integer;          { Dir. selection window border type  }
    END;

{
   ┌────────────────────────────────────────────────────┐
   │ Define Global Constants                            │
   └────────────────────────────────────────────────────┘
}

CONST
  NL   = #13#10;
  Bell = #7;

  Alphabet : string[26]
           = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';       { Set up alphabet string    }

  Config   : ConfigType
            = (Cnt_CurFlag : False;              { Don't cnt current dir.    }
               LoopDirFlag : False;              { No looping is default     }
               AutoSize    : True;               { Flag re autosizing wndw   }
               Row_BEGIN   : 5;                  { Row to place window       }
               Col_BEGIN   : 22;                 { Col to place window       }
               Act_Attr    : 112;                { Normal color of window    }
               IAct_Attr   : 31;                 { Highlight color           }
               Wndw_Bdr    : 1);                 { Deflt border = sngle line }
                                                 { Border types are:
                                                     0  = No Border
                                                     1  = Single line
                                                     2  = Double Line        }


{
   ┌────────────────────────────────────────────────────┐
   │ Define Global Variables                            │
   └────────────────────────────────────────────────────┘
}

VAR
  LoopDirs    : boolean;              { Looping flag                       }
  Cnt_Cur     : boolean;              { Flag for cnt'g curr. dir. or not   }
  DirName     : str_type;             { Found directory name               }
  Dir_Ptr     : Fptr;                 { Ptr. to directory name list        }
  Num_Dirs    : integer;              { Total # of dirs. found             }

  Cur_Dir     : string[65];           { Current directory                  }
  Orig_Dir    : string[65];           { Dir. you started in                }
  Drive       : DriveList;            { Contains drive designation         }
  To_A_Drv    : Boolean;              { Shows direction of drive changes   }

  ColBEGIN    : integer;
  Row_Quan    : integer;              { Number of rows                     }
  Col_Quan    : integer;              { Number of cols                     }

  Save_Attr   : integer;              { Save current text attribute        }

  Col_Max     : integer;              { Max Col to put dir. name at        }
  Row_Max     : integer;              { Max Row to put dir. name at        }
  Cur_Col     : integer;              { Current column                     }
  Cur_Row     : integer;              { Current Row                        }
  Row_Beg     : integer;              { Beginning row of window            }
  Col_Beg     : integer;              { Beginning col of window            }

  Save_WMin   : word;                 { Save area for WindMin & WindMax    }
  Save_WMax   : word;
  Save_X      : integer;              { Cursor x,y save area               }
  Save_Y      : integer;

  OrigMode    : byte;                        { Original video mode         }
  Vidcolor    : panel absolute $B800:0000;   { Storage for color video mem }
  Vidmono     : panel absolute $B000:0000;   { Storage for b/w video mem   }
  Screen      : panel;

  HeapPtr     : pointer;              { Pointer to heap for mark/release   }
  ExitSave    : pointer;              { Pointer for exit procedure         }

{
 ┌────────────────────────────────────────────────────┐
 │ BEGIN TRAVERSE Procedures                          │
 └────────────────────────────────────────────────────┘
}

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Usage                                    │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Usage;

VAR
  Ch : char;

BEGIN
  WRITELN (Bell,
'A directory tree traverser.  If only one child directory exists, then',NL,
'TRAVERSE automatically changes to that subdirectory.  If you are at the',NL,
'"bottom" level of a directory tree, TRAVERSE will automatically "bounce"',NL,
'you up to the parent directory level.  Otherwise, TRAVERSE gives you a 1',NL,
'character choice (A-Z) to change to one of up to 26 displayed',NL,
'subdirectories.  You can also use the arrow keys to traverse the displayed',NL,
'list, then press ENTER.  ESC drops you back in the directory you started',NL,
'from; / or \ take you to the root directory; PgUp takes your to the',NL,
'PREVIOUS DRIVE, and PgDn takes you to the NEXT DRIVE.  ',NL,
'',NL,
'USAGE:     TRAVERSE {U} {D} {O} {L} {N} {X}',NL,
'U -- UP: Immediately moves up one level.',NL,
'D -- DOWN: Immediately moves down one level if only one subdirectory',NL,
'     exists, otherwise displays directory list.',NL,
'O -- OVER: Immediately moves up one level AND displays directory list',NL,
'     (useful to move Over to a sibling directory).',NL,
'L -- LOOP: Loops through the program, displaying each list of directories',NL,
'     until you hit either (1) the RETURN key while highlighting a directory',NL,
'     entry, or (2) select the current directory (.) while in a sub-',NL,
'     directory, or (3) press ESC.  / or \ takes you to the root directory',NL,
'N -- NO LOOPING: used when configured to loop as the default. ',NL,
'X -- XCHANGE: self-configuration, to select colors, options.',NL,
'                      (press any key to continue)');
  Ch := Readkey;
  Halt;
END;


{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Beepit                                   │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Beepit (Tone : integer; Duration : integer);

BEGIN
  SOUND (Tone);                                         { Beep the speaker }
  DELAY (Duration);
  NOSOUND;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ FUNCTION VideoMode                                 │
   └────────────────────────────────────────────────────┘
}

FUNCTION VideoMode : Byte;

VAR
  reg        : registers;

BEGIN
  reg.ah     := 15;                                 { Determine video type }
  INTR ($10,reg);                                   { by polling BIOS int. }
  VideoMode  := reg.al;                             { 10                   }
END;

{
   ┌────────────────────────────────────────────────────┐
   │ FUNCTION ISColor                                   │
   └────────────────────────────────────────────────────┘
}

FUNCTION ISColor : Boolean;
  BEGIN;
    IF VideoMode = 7 THEN
      ISColor  := False
    ELSE
      ISColor  := True;
  END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Highlight                                │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Highlight (ptr : Fptr);

BEGIN
  TextAttr := Config.Act_Attr;                  { Highlight a dir. name    }
  GOTOXY (Cur_Col,Cur_Row);
  WRITE ('',ptr^.DirChr,' ',ptr^.DirName,'');
  TextAttr := Config.IAct_Attr;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Un_Highlight                             │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Un_Highlight (ptr : Fptr);

BEGIN
  TextAttr := Config.IAct_Attr;                 { Un─Highlight a dir. name }
  GOTOXY (Cur_Col,Cur_Row);
  WRITE (' ',ptr^.DirChr,' ',ptr^.DirName,' ');
END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Save_Screen                              │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Save_Screen;

BEGIN
  Save_X    := WhereX;                           { Save current cursor     }
  Save_Y    := WhereY;                           { x,y coordinates         }
  Save_WMin := WindMin;                          { Save the current window }
  Save_WMax := WindMax;                          { min/max coordinates     }
  Save_Attr := TextAttr;

  IF (ISColor) THEN                              { Move screen image to    }
    Screen  := Vidcolor                          { storage depending on    }
  ELSE                                           { video card type         }
    Screen  := Vidmono;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Restore_Screen                           │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Restore_Screen;

BEGIN
  IF (ISColor) THEN                              { Restore original screen }
    Vidcolor := Screen                           { image                   }
  ELSE
    Vidmono  := Screen;

  TextAttr   := Save_Attr;

  WINDOW (LO(Save_WMin)+1,HI(Save_WMin)+1,
          LO(Save_WMax)+1,HI(Save_WMax)+1);
                                                 { Restore original window }
  GOTOXY (Save_X,Save_Y);                        { min/max coord.'s & cur. }

END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Cursor                                   │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Cursor (Cur_Off : Boolean);

VAR
  reg  : registers;

BEGIN
  IF (NOT Cur_Off) THEN
    BEGIN                                                { Turn cursor off }
      reg.ah := 1;
      reg.cl := 7;
      reg.ch := 32;
      INTR ($10,reg);
    END
  ELSE
    BEGIN                                                { Turn cursor on  }
      INTR ($11,reg);
      IF ((reg.al AND $10) <> 0) THEN
        reg.cx := $0B0C
      ELSE
        reg.cx := $0607;
      reg.ah := 1;
      INTR ($10,reg);
    END;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Draw_Border                              │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Draw_Border;

VAR
  TLC, TRC   : char;
  BLC, BRC   : char;
  HLINE      : char;
  VLINE      : char;
  TLFT, TRHT : char;
  i          : integer;

BEGIN
  CASE (Config.Wndw_Bdr) OF                     { Define border elements   }
                                                { based on global Wndw_Bdr }
    1  :  BEGIN
            TRC   := '┐';
            BRC   := '┘';
            TLC   := '┌';
            BLC   := '└';
            HLINE := '─';
            VLINE := '│';
            TLFT  := '┤';
            TRHT  := '├';
          END;

    2  :  BEGIN
            TRC   := '╗';
            BRC   := '╝';
            TLC   := '╔';
            BLC   := '╚';
            HLINE := '═';
            VLINE := '║';
            TLFT  := '╡';
            TRHT  := '╞';
          END;

  END; {case}

  GOTOXY (1,1);                                 { Start to draw the border }

  WRITE (TLC);                                  { Top line with corners    }
  FOR i := 1 to (Col_Quan*16 + 2) DO WRITE (HLINE);
  WRITE (TRC);

  FOR i := 2 to Row_Quan - 1 DO                 { Vertical lines           }
    BEGIN
      GOTOXY (1,i);
      WRITE (VLINE);
      GOTOXY ((Col_Quan*16 + 4),i);
      WRITE (VLINE);
    END;

  GOTOXY (1,Row_Quan);                          { Bottom line with corners }
  WRITE (BLC);
  FOR i:=1 to (Col_Quan*16 + 2) DO WRITE (HLINE);
  WRITE (BRC);                                  { End draw of border       }

  IF ((LENGTH (Cur_Dir) + 2) < (Col_Quan*16 + 1)) THEN
    BEGIN
      GOTOXY (2,1);                             { If dir. name fits,       }
      WRITE (TLFT,' ',Cur_Dir,' ',TRHT);        { insert it in the top row }
    END;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE WindowX                                  │
   └────────────────────────────────────────────────────┘
}

PROCEDURE WindowX;

VAR
  x1,y1,x2,y2 : byte;

BEGIN
  TextAttr := Config.IAct_Attr;               { Define text color          }

  x1 := ColBEGIN;                             { Define dirs. window        }
  y1 := Config.Row_BEGIN;
  x2 := ColBEGIN + (Col_Quan * 16) + 3;       { Width = 20 or 36 cols.     }
  y2 := Config.Row_BEGIN + Row_Quan;
  WINDOW (x1,y1,x2,y2);                       { Activate the window        }
  ClrScr;                                     { Clear window               }

  IF (Config.Wndw_Bdr <> 0) THEN
    BEGIN
      Draw_Border;                            { Draw the window border     }
      INC (x1);                               { Redefine window so don't   }
      INC (y1);                               { scroll the border if there }
      DEC (x2);                               { is one.                    }
      DEC (y2,2);                             { Wndw 2 rows < than border  }
      WINDOW (x1,y1,x2,y2);                   { Activate new window        }
      ClrScr;                                 { Clear window               }
    END;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE SizeWindow                               │
   └────────────────────────────────────────────────────┘
}

PROCEDURE SizeWindow;

BEGIN
  IF (Num_Dirs < 14) AND (NOT LoopDirs) THEN
    BEGIN                                      { Calc. small window size   }
      Row_Quan  := Num_Dirs + 2;
      Col_Quan  := 1;
      ColBEGIN  := Config.Col_BEGIN + 8;       { Col to place window       }
    END
  ELSE
    BEGIN                                      { Calc. large window size   }
      IF (Num_Dirs > 26) OR (LoopDirs) OR (NOT Config.AutoSize) THEN
        Row_Quan := 13 + 2                     { 1/2 dir. entries + 2 for  }
      ELSE                                     { border                    }
        Row_Quan := (((Num_Dirs+1) DIV 2)+2);  { Balance dirs. betw 2 cols }

      Col_Quan := 2;
      ColBEGIN := Config.Col_BEGIN;             { Col to place window       }
    END;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ FUNCTION Get_Dirs                                  │
   └────────────────────────────────────────────────────┘
}

FUNCTION Get_Dirs (VAR First : Fptr) : integer;

VAR
  p1, p2   : Fptr;
  numdirs  : integer;
  DirInfo  : SearchRec;
  Placed   : boolean;
  FirstDir : boolean;

BEGIN
  Get_Dirs := 0;
  numdirs  := 0;
  FirstDir := True;
  First    := nil;

  FindFirst ('*.*',Directory,DirInfo);       { Find 1st matching file/dir. }

  IF DosError = 0 THEN                       { If found file/dir., cont.   }
    BEGIN
      IF (DirInfo.name = '.') AND (Cnt_Cur = False) THEN FindNext (DirInfo);

      WHILE DosError = 0 DO
        BEGIN
          IF (DirInfo.attr = Directory) THEN
            BEGIN                            { If there are more, continue }
              INC (numdirs);                 { Incr. number dirs. counter  }
              NEW (p1);                      { Allocate new pointer        }
              p1^.DirName := DirInfo.name;               { Copy dir. name  }

              IF FirstDir = True THEN
                BEGIN
                  First    := p1;
                  p1^.Prev := nil;
                  p1^.Next := nil;
                  FirstDir := False;
                END
              ELSE
                BEGIN
                  IF (p1^.DirName < First^.DirName) THEN { Sort dir. names }
                    BEGIN
                      p1^.Next    := First;
                      p1^.Prev    := nil;
                      First^.Prev := p1;
                      First       := p1;
                    END
                  ELSE
                    BEGIN
                      p2     := First;
                      Placed := False;
                      WHILE ((p2^.Next <> nil) AND (Placed = False)) DO
                        BEGIN
                          IF (p1^.DirName >= p2^.Next^.DirName) THEN
                            p2 := p2^.Next
                          ELSE
                           Placed := True;
                        END;
                      p1^.Next := p2^.Next;
                      p1^.Prev := p2;
                      p2^.Next^.Prev := p1;
                      p2^.Next := p1;
                    END;
                END;
            END;                                        { End sort       }

          FindNext (DirInfo);              { Find next matching dir.     }

        END;

      IF LENGTH (Cur_Dir) = 3 THEN         { If at root, add record      }
        BEGIN
          NEW (p1);
          p1^.DirName := '>ROOT';          { Copy in dir.name            }
          p1^.Prev    := nil;              { Set up prev pointer         }

          IF First <> nil THEN
            BEGIN
              p1^.Next    := First;
              First^.Prev := p1;
            END
          ELSE
            p1^.Next    := nil;

          First       := p1;
          INC (numdirs);
        END;

      Get_Dirs := numdirs;                 { Return num. of dirs. found  }
    END;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Put_Dirs                                 │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Put_Dirs (var_ptr : Fptr; Maxdirs : integer);

VAR
  i,irow,icol : integer;

BEGIN                                           { Put the dirs. found into }
  irow := Row_Beg;                              { the dirs. window by      }
  icol := Col_Beg;                              { traversing the dir. ptr  }
                                                { linked list              }
  FOR i := 1 to Maxdirs DO
    BEGIN
      GOTOXY (icol,irow);
      var_ptr^.DirChr := Alphabet[i];
      WRITE (' ',var_ptr^.DirChr,' ',var_ptr^.DirName,' ');
      INC (irow);
      IF (irow > Row_Max) THEN
        BEGIN
          irow := Row_Beg;
          icol := Col_Beg + 16;
        END;
      IF (var_ptr^.Next <> nil) THEN
        var_ptr := var_ptr^.Next
      ELSE
        i := Maxdirs;
    END;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ FUNCTION Srch_Dir                                  │
   └────────────────────────────────────────────────────┘
}

FUNCTION Srch_Dir (var_ptr : Fptr; var_str : char) : Fptr;

VAR
  Found      :  boolean;
  var_str2   :  char;

BEGIN
  Found    := False;
  Srch_Dir := nil;

  WHILE ((var_ptr <> nil) AND (NOT Found)) DO       { Search list for list }
    BEGIN                                           { entry that matches   }
      var_str2 := var_ptr^.DirChr;                  { keyboard entry       }
      IF var_str = var_str2 THEN
        BEGIN
          Srch_Dir := var_ptr;
          Found    := True;
        END
      ELSE
        var_ptr := var_ptr^.Next;
        IF (var_ptr = nil) THEN
          BEGIN
            Srch_Dir := nil;                    { If key entry not on list }
            Beepit (760, 80);                   { set Srch_Dir to nil &    }
            Found    := True;                   { beep                     }
          END;
     END;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ FUNCTION Next_Dir                                  │
   └────────────────────────────────────────────────────┘
}

FUNCTION Next_Dir (var_ptr : Fptr; count : integer) : Fptr;

VAR
  i    : integer;

BEGIN
  IF (var_ptr^.Next <> nil) THEN                { Move up one dir.         }
    BEGIN                                       { Is there a next dir.?    }
      Un_Highlight(var_ptr);                    { Unhighlight current dir. }
      FOR i := 1 to count DO                    { Traverse dir. list while }
        BEGIN                                   { updating the current row }
          IF (var_ptr^.Next <> nil) THEN        { and col location         }
            BEGIN
              var_ptr := var_ptr^.Next;
              INC (Cur_row);
              IF (Cur_row > Row_Max) THEN
                BEGIN
                  Cur_Row := Row_Beg;
                  INC (Cur_Col,16);
                  IF (Cur_Col > Col_Max) THEN   { If off edge, stay put,   }
                    BEGIN                       { beep, and stop           }
                      var_ptr := var_ptr^.Prev;
                      Cur_Col := Col_Beg - 16;
                      Beepit (760, 80);
                      i := count;
                    END;
                END;
            END
         ELSE
            i := count;
        END;

      Highlight(var_ptr);                        { All done, highlight     }
    END                                          { new current dir. name   }
  ELSE
    Beepit (760, 80);
    Next_Dir := var_ptr;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ FUNCTION Prev_Dir                                  │
   └────────────────────────────────────────────────────┘
}

FUNCTION Prev_Dir (var_ptr : Fptr; count : integer) : Fptr;

VAR
  i    : integer;

BEGIN
  IF (var_ptr^.Prev <> nil) THEN                { Back up one dir.         }
    BEGIN                                       { Is there a prev dir.?    }
      Un_Highlight(var_ptr);                    { Unhighlight current dir. }
      FOR i := 1 to count DO                    { Traverse dir. list while }
        BEGIN                                   { updating the current row }
          IF (var_ptr^.Prev <> nil) THEN        { and col location         }
            BEGIN
              var_ptr := var_ptr^.Prev;
              DEC (Cur_Row);
              IF (Cur_Row < Row_Beg) THEN
                BEGIN
                  Cur_Row := Row_Max;
                  DEC (Cur_Col,16);
                  IF (Cur_Col < Col_Beg) THEN
                    BEGIN
                      var_ptr := var_ptr^.Next; { If off edge, stay put,   }
                      Cur_Col := Col_Beg + 16;  { beep, and stop           }
                      Beepit (760, 80);
                      i := count;
                    END;
                END;
            END
          ELSE
            i := count;
        END;

      Highlight(var_ptr);                       { All done, highlight      }
    END                                         { new current dir. name    }
  ELSE
    Beepit (760, 80);
    Prev_Dir := var_ptr;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Sel_Dir                                  │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Sel_Dir (VAR Dir_Name : str_type;
                   NumDirs : integer; var_ptr : Fptr;
                   VAR To_A_Drv : Boolean);

VAR
  ptr1, ptr2  : Fptr;
  Max_Scrn    : integer;
  Ch          : char;
  done        : boolean;

BEGIN
  Dir_Name  := '';                         { Init. Dir_Name                }
  To_A_Drv  := False;                      { Init. direction of drv changes}

  IF (NumDirs <> 0) THEN                   { Proceed if dirs. found        }
    BEGIN
      ptr1 := var_ptr;

      Col_Beg := 2;                        { Define some window limits     }
      Row_Beg := 1;
      Col_Max := (Col_Beg + ((Col_Quan - 1) * 16));

      IF (Config.Wndw_Bdr = 0) THEN        { Compute Max rows of dirs.     }
        Row_Max := Row_Quan
      ELSE
        Row_Max := Row_Quan - 2;

      Max_Scrn := Col_Quan * Row_Max;      { Compute Max dirs. w/in window }
      IF (Max_Scrn > NumDirs) THEN Max_Scrn := NumDirs;

      WindowX;                             { Draw the dirs. window         }

      Put_Dirs (ptr1, Max_Scrn);           { Fill window w/ avail dirs.    }

      Cur_Row := Row_Beg;                  { Initialize cur row/col        }
      Cur_Col := Col_Beg;
      Highlight (ptr1);                    { Highlight first dir.          }

      Done := False;                       { Continue till user selects a  }
      WHILE (Done = False) DO              { dir. or quits                 }
        BEGIN
          Ch := ReadKey;
          IF (Ch = #0) THEN
            BEGIN
              Ch := ReadKey;
              CASE Ch OF
                #75 : ptr1 := Prev_Dir(ptr1,13);      { Left Arrow         }
                #77 : ptr1 := Next_Dir(ptr1,13);      { Right Arrow        }
                #72 : ptr1 := Prev_Dir(ptr1,1);       { Up Arrow           }
                #80 : ptr1 := Next_Dir(ptr1,1);       { Down Arrow         }

                #73: BEGIN
                       Drive    := PRED (Drive);      { If PgUp, go to     }
                       Dir_Name := Drive + ':\';      { prev. drive;       }
                       Done     := True;              { redraw scrn.       }
                       To_A_Drv := True;              { Towards A:         }
                      END;
                #81: BEGIN
                       Drive    := SUCC (Drive);      { If PgDn, go to     }
                       Dir_Name := Drive + ':\';      { next drive;        }
                       Done     := True;              { redraw scrn.       }
                       To_A_Drv := False;             { Away from A:       }
                      END;
              END;  {case}
            END

          ELSE
            BEGIN
              CASE Ch OF

                #13 : BEGIN                           { Return Key;        }
                        Dir_Name := ptr1^.DirName;    { Return highlighted }
                                                      { dir. to caller     }
                        IF Dir_Name = '>ROOT' THEN Dir_Name := '.';
                        LoopDirs := False;
                        Done     := True;
                      END;

                #27 : BEGIN                           { Escape Key         }
                        Dir_Name := Orig_Dir;         { Retrn to orig. dir }
                        LoopDirs := False;
                        Done     := True;
                      END;

               '\','/' : BEGIN
                           Dir_Name := '\';           { If \ or /, go to   }
                           Done     := True;          { root; redraw scrn  }
                         END;                         { if looping         }

              ELSE
                BEGIN
                  Ch := UPCASE (Ch);                  { Cap letter inputs  }
                  IF ((Ch >= 'A') and (Ch <= 'Z')) THEN
                    BEGIN
                      ptr2 := ptr1;
                      ptr1 := Srch_Dir (Dir_Ptr,Ch);  { See if input is on }
                      IF ptr1 <> nil THEN             { dir. listing       }
                        BEGIN
                          Dir_Name := ptr1^.DirName;  { If so, return      }
                                                      { selected dir. name }

                          IF (Dir_Name = '.') OR (Dir_Name = '>ROOT') THEN
                            BEGIN                     { If sel. cur. dir., }
                              Dir_Name := '.';        { or root, then      }
                              LoopDirs := False;
                            END;
                          Done     := True;           { all done           }
                        END
                      ELSE
                        ptr1 := ptr2;                 { Else, set ptr1 to  }
                    END                               { prev. value        }
                  ELSE
                   Beepit (760, 80);
                END;
              END; {case}

            END;
        END;

    END
  ELSE
    BEGIN
      Dir_Name := '.';                      { No dirs. found - return cur. }
    END;

END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE ChangeDir                                │
   └────────────────────────────────────────────────────┘
}

PROCEDURE ChangeDir (To_A_Drv : Boolean);

BEGIN

{$I-}
  CHDIR (DirName);                             { Go to selected dir.       }
{$I+}
  IF IOResult = 0 THEN
    BEEPIT (1000, 5)                           { Chirp on change of dir.   }
  ELSE
    BEGIN                                      { If error, such as disk not}
      ClrScr;                                  { in drive, show error mess.}
      WRITELN ('I/O Error -- cannot change');  { and try next drive        }
      WRITELN ('to drive or directory specified');
      BEEPIT (760,80);
      BEGIN
        CASE Drive OF
          'A' : BEGIN
                  Drive    := SUCC (Drive);
                  To_A_Drv := false;
                END;
          'B' : BEGIN
                  IF To_A_Drv THEN
                    BEGIN
                      Drive    := 'A';
                      To_A_Drv := false;
                    END
                  ELSE
                    Drive      := SUCC (Drive);
                END
        ELSE                                 { change back to prev. valid  }
          Drive   := PRED (Drive);           { drive otherwise             }
        END {case};
        WRITELN;
        WRITELN ('Trying drive ', Drive,':');
        DELAY (1000);
        DirName := Drive + ':\';
        ChangeDir (To_A_Drv);                { Try to change to new drv.   }
      END;
      EXIT;
    END;

END;

{$IFDEF SelfConfigure}                      {******************************}

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Configure                                │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Configure;

   {
      ┌────────────────────────────────────────────────────┐
      │ SUBPROCEDURE InputError                            │
      └────────────────────────────────────────────────────┘
   }

   PROCEDURE InputError;

   BEGIN
     WRITELN (NL,NL,'INPUT VALUE INCORRECT -- MUST START OVER');
     Beepit (560,80);
     DELAY (2500);
     HALT;
   END;

   {
      ┌────────────────────────────────────────────────────┐
      │ SUBPROCEDURE Yes_No                                │
      └────────────────────────────────────────────────────┘
   }

   PROCEDURE Yes_No (message : string; VAR ReturnVar : Boolean);

   VAR
    in_char : char;

   BEGIN
     WRITE (message);
     in_char := ReadKey;
     WRITELN (in_char);
     CASE in_char OF
       'Y','y' : ReturnVar := true;
       'N','n' : ReturnVar := false;
       #13     : ;
     ELSE
       InputError;
     END; {case}
   END;

   {
      ┌────────────────────────────────────────────────────┐
      │ SUBPROCEDURE Ask_for_input                         │
      └────────────────────────────────────────────────────┘
   }

   PROCEDURE Ask_for_input (message : string;
                            VAR ReturnVar : integer;
                            error : integer);

   VAR
     in_string : string;
     in_char   : char;
     code      : integer;

   BEGIN
     in_string := '';
     WRITE (message);
     REPEAT
       in_char := ReadKey;
       WRITE (in_char);
       in_string := in_string + in_char;
     UNTIL in_char = #13;
     IF LENGTH (in_string) > 1 THEN
       VAL (COPY(in_string,1,LENGTH(in_string)-1), ReturnVar, code);
     IF (ReturnVar > error) THEN InputError;
     WRITELN;
   END;

   {
      ┌────────────────────────────────────────────────────┐
      │ SUBFUNCTION DosVersion                             │
      └────────────────────────────────────────────────────┘
   }


   FUNCTION DosVersion : REAL;                { Return DOS version number }

   VAR
     Regs : registers;

   BEGIN
     WITH Regs DO
       BEGIN
         AX := $3000;
         MSDOS(Regs);
         IF AL <> 0 THEN
           DosVersion := AL + AH/100
         ELSE
           DosVersion := 1.0;
       END;
   END;

   {
      ┌────────────────────────────────────────────────────┐
      │ SUBFUNCTION PgmName                                │
      └────────────────────────────────────────────────────┘
   }

   FUNCTION PgmName : STRING;               { Returns name & path of pgm.  }
                                            { A null string is returned if }
   VAR                                      { DOS version is < 3.00.       }
     EnvSeg : word;
     i      : integer;
     Temp   : string;

   BEGIN
     IF TRUNC (DosVersion) > 2.0 THEN
       BEGIN
         EnvSeg := MEMW[PREFIXSEG : $2C];   {Start loc of the environ. str }
         i      := 0;
         Temp   := '';

         WHILE MEMW[EnvSeg:i] <> 0 DO
           INC(i);
         INC(i,4);

         WHILE MEM[EnvSeg:i] <> 0 DO
           BEGIN
             Temp := Temp + UPCASE(CHR(MEM[EnvSeg:i]));
             INC(i);
           END;  {while}
         PgmName := Temp;
       END  {if}
     ELSE
       PgmName := '';                       { Null string if DOS < 3.00    }
   END;

{────────────────────────────────────────────────────}

VAR
  ExeFile    : file;
  FileAttr   : word;
  HeaderSize : word;

BEGIN

  ASSIGN (ExeFile, PgmName);                    { Test for existence of   }
  GetFAttr (ExeFile, FileAttr);                 { file w/ PGMNAME func.   }

  IF (FileAttr = 0) THEN
    BEGIN
      WRITELN (PgmName, ' missing -- aborting configure routine');
      Beepit (560,80);
      DELAY (5000);
      HALT;
    END;

  WITH Config DO
    BEGIN
      Yes_No ('DEFAULT = LOOP? (y or N) ', LoopDirFlag);

      Yes_No ('COUNT CURRENT DIRECTORY? (y or N) ', Cnt_CurFlag);

      Yes_No ('AUTOMATICALLY SIZE WINDOW? (Y or n) ', AutoSize);

      Ask_for_input ('TOP ROW FOR WINDOW? (1 to 10 -- preset to 5) ',
        Row_BEGIN, 10);

      Ask_for_input ('COLUMN FOR WINDOW? (1 to 44 -- preset to 22) ',
        Col_BEGIN, 44);

      Ask_for_input ('HIGHLIGHT COLOR? (1 to 256 -- preset to 112) ',
        Act_Attr, 256);

      Ask_for_input ('BACKGROUND COLOR? (1 to 256 -- preset to 31) ',
        IAct_Attr, 256);

      Ask_for_input ('BORDER TYPE? (0 for none, 1 for single [preset], 2 for double) ',
         Wndw_Bdr, 2);
    END;

  RESET (ExeFile, 1);                           { change Typed Constant   }
  SEEK (ExeFile, 8);
  BLOCKREAD (ExeFile, HeaderSize, SIZEOF (HeaderSize));
  SEEK (ExeFile, 16 * (SEG (Config) - PREFIXSEG + HeaderSize)
                    + OFS (Config) - 256);
  BLOCKWRITE (ExeFile, Config, SIZEOF (Config));
  CLOSE (ExeFile);

  WRITELN;
  WRITELN ('CONFIGURATION CHANGES MADE -- RE-START ', PgmName);
  Beepit (1000,80);
  DELAY (2000);
  HALT;
END;

{$ENDIF}                                    {******************************}

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Read_Parm                                │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Read_Parm;

VAR
  Param : String[1];

BEGIN
  Param := ParamStr(1);

  CASE (Param[1]) OF

    'U','u': BEGIN
               IF LENGTH (Cur_Dir) > 3 THEN CHDIR ('..');
               HALT;                           { If "u" for "up", go up    }
             END;                              { and stop, unless at root  }

    'D','d': CHDIR ('.');                      { Just to be symetric:      }
                                               { If "d" for "down",        }
                                               { just continue             }

    'L','l': LoopDirs := True;                 { Set flag if looping       }

    'N','n': LoopDirs := False;                { Set flag if NOT looping   }

    'O','o': IF LENGTH (Cur_Dir) > 3 THEN      { If "o" for "over", go up  }
               BEGIN                           { 1 dir., (unless at root)  }
                 CHDIR ('..');                 { disp. lst, & continue     }
                 GETDIR (0,Cur_Dir);
               END;

     '?'   : Usage;

{$IFDEF SelfConfigure}                         {***************************}
    'X','x': Configure                         { Go to configuration proc. }
{$ELSE}
    'X','x': BEGIN
               WRITELN ('THIS VERSION NOT SELF-CONFIGURING');
               BEEPIT (760,80);
               DELAY (3000);
               HALT;
             END
{$ENDIF}                                       {***************************}

  ELSE
    BEEPIT (760,80);                           { If improper parameter,    }
    Usage;                                     { beep & show usage         }
  END; {case}

END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Go_Direct                                │
   └────────────────────────────────────────────────────┘
}

PROCEDURE Go_Direct (Ptr1 : Fptr);

BEGIN
  IF (Ptr1^.DirName = '>ROOT') AND (Ptr1^.Next = nil) THEN
    CHDIR ('\')
  ELSE
    BEGIN
      WHILE (Ptr1^.Next <> nil) DO
        Ptr1 := Ptr1^.Next;
      CHDIR (Ptr1^.DirName);
    END;

  BEEPIT (1000,5);                           { Chirp on change of dir.   }
  HALT;
END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE TestDirect                               │
   └────────────────────────────────────────────────────┘
}

PROCEDURE TestDirect;

BEGIN
  IF LoopDirs = False THEN                     { Do if NOT looping         }
    CASE Num_Dirs OF                           { Test for direct movement  }
                                               { to single subdir. or to   }
      1 : Go_Direct (Dir_Ptr);                 { parent dir.               }
      2 : Go_Direct (Dir_Ptr);
      3 : IF ((LENGTH (Cur_Dir) > 3) AND (Cnt_Cur = True)) THEN
          Go_Direct (Dir_Ptr);
    END;  {case}
END;

{
   ┌────────────────────────────────────────────────────┐
   │ PROCEDURE Program Exit                             │
   └────────────────────────────────────────────────────┘
}

{$F+}
PROCEDURE PgmExit;

BEGIN
  TextMode (OrigMode);                         { Return to orig. vid. mode }
  Restore_Screen;
  Cursor (True);                               { Turn cursor back on       }
  Release (HeapPtr);                           { Restore all mem allocated }
  ExitProc := ExitSave;                        { Restore orig. exit proc.  }
END;
{$F-}

{
   ┌────────────────────────────────────────────────────┐
   │ BEGIN MAIN PROGRAM                                 │
   └────────────────────────────────────────────────────┘
}

VAR
  Version : string;

BEGIN

  ExitSave := ExitProc;                    { Save last exit proc. in chain }
  ExitProc := @PgmExit;                    { Install PgmExit in exit proc. }
                                           { chain.                        }

  Version  := 'Version 1.9 -- 6-19-88 -- Public Domain by John Land';
                                               { Version; sticks in .EXE   }

  Cnt_Cur  := Config.Cnt_CurFlag;              { False means don't cnt cur.}
                                               { dir., True means cnt. it  }

  LoopDirs := Config.LoopDirFlag;              { Init. looping flag        }

                       { START DIR. PROCESSING }

  NEW  (HeapPtr);                              { Save the current heap ptr }
  MARK (HeapPtr);

  OrigMode := VideoMode;                       { Save video mode           }

  Save_Screen;                                 { Save the current screen   }

  Cursor (False);                              { Turn off the cursor       }

  GETDIR (0,Cur_Dir);                          { Get current directory     }
  Orig_Dir := Cur_Dir;                         { Save copy of cur. dir.    }
  Drive    := Cur_Dir[1];                      { Save drive designation    }

  IF ParamCount > 0 THEN Read_Parm;            { Do command line parms     }
  IF LoopDirs THEN Cnt_Cur := True;            { Cnt. cur. dir if looping  }


                       {    LOOPING ROUTINE    }

  REPEAT                                       { Do routines at least once }

    Num_Dirs := Get_Dirs (Dir_Ptr);            { Get matching dirs. & cnt  }

    TestDirect;                                { Test if can CD directly   }

             { Windowed list of directories procedures and routines follows}

    ClrScr;                                    { Use if want clr. scrn     }
                                               { while disp'g dir. list    }

    SizeWindow;                                { Auto. sizing of window    }

    Sel_Dir (DirName,Num_Dirs,Dir_Ptr,To_A_Drv); { Select directory        }

    ChangeDir (To_A_Drv);                      { Change to selected dir.   }

    GETDIR (0,Cur_Dir)                         { Get current directory     }

  UNTIL LoopDirs = False;                      { Looping test              }

END.