{ -------------------        Boosters       ------------------- }
       {                              v1.0                             }
       {                                                               }
       {                  Utilities for Turbo Pascal (tm)              }
       {                                                               }
       {                       Copyright (C) 1985                      }
       {                       All Rights Reserved                     }
       {                                                               }
       {                              by                               }
       {                                                               }
       {                         George Smith                          }
       {                      609 Candlewick Lane                      }
       {                       Lilburn, GA 30247                       }
       {                        (404) 923-6879                         }
       {                                                               }
       {                                                               }
       {                                                               }
       {    Boosters users:  A $25 contribution would be appreciated   }
       {                     if you find these utilities of value.     }
       {                                                               }
       {                     Or if you prefer, become a registered     }
       {                     user for $35 and receive a printed users  }
       {                     guide, update notices, and the latest     }
       {                     version of Boosters.                      }
       {                                                               }
       {    Turbo Pascal is a Registered Trademark of Borland, Inc.    }
       {                                                               }
       {---------------------------------------------------------------}

{ ----------------------------------------------
  EXEC invokes compiled programs and batch files
  then returns control to caller.
  ---------------------------------------------- }
Procedure Exec  ( VAR FileDesc, CommandLine  : AnyString;
                  VAR Code                   : Integer);
                                               external 'TBX.COM';

{ ------------------------
  FILLHEAP fills heap page
  character/attribute
  block
  ------------------------ }
Procedure FillHeap ( Page : HeapBuf;
                       X1 : RowType;
                       Y1 : ColumnType;
                       X2 : RowType;
                       Y2 : ColumnType;
                        C : Char;
                      Att : Byte); external 'FillHeap.com';
          { Fill Page from (X1,Y1) to (X2,Y2)
            with C character and Att byte }

{ ---------------
  CENTER a string
  --------------- }

Function CENTER ( A : AnyString;
                  N : Integer;
                  Pad : Char )  : AnyString;
                  { AnyString is type String[255] }

begin
   InLine ($1E/ $8D/$9E/$08/$01/ $8B/$46/$06/ $36/$88/$07/ $43/
           $8A/$4E/$08/ $30/$ED/ $29/$C8/ $77/$05/ $31/$C0/ $EB/$12/$90/
           $D1/$E8/ $50/ $8B/$FB/ $8B/$46/$04/ $8B/$4E/$06/ $16/ $07/
           $FC/ $F3/$AA/ $58/ $01/$C3/ $8B/$FB/ $8D/$76/$09/ $16/ $1F/
           $8A/$4E/$08/ $30/$ED/ $FC/ $F3/$A4/ $1F);
end { Center };


{ ---------------------------------------------------
  PUTSTR  - Write a string directly to display memory
  --------------------------------------------------- }

Procedure PutStr ( HV : Char;
                    S : AnyString;
                    X : ColumnType;
                    Y : RowType;
                  Att : Byte );

begin
   InLine ($1E/ $BB/$49/$04/ $31/$C0/ $8E/$D8/ $8A/$07/ $3C/$07/ $75/$06/
           $BA/$00/$B0/ $EB/$0C/$90/ $BA/$DA/$03/ $EC/ $24/$08/ $74/$FB/ 
           $BA/$00/$B8/ $8E/$C2/ $8B/$5E/$08/ $09/$DB/ $74/$0C/ $4B/
           $8B/$46/$06/ $48/ $8A/$F0/ $8A/$D3/ $EB/$05/$90/ $B4/$03/
           $CD/$10/ $8A/$DE/ $30/$FF/ $8B/$C3/ $B1/$07/ $D3/$E0/ $B1/$05/
           $D3/$E3/ $01/$C3/ $8A/$C2/ $30/$E4/ $D1/$E0/ $01/$C3/ $8B/$FB/
           $8A/$4E/$0A/ $30/$ED/ $8D/$76/$0B/ $16/ $1F/ $8A/$66/$04/
           $8B/$96/$0A/$01/ $80/$FA/$76/ $74/$0A/ $80/$FA/$56/ $74/$05/
           $31/$D2/ $EB/$04/$90/ $BA/$9E/$00/ $FC/ $8A/$04/ $AB/ $01/$D7/
           $46/ $E2/$F8/ $09/$D2/ $74/$04/ $81/$EF/$9E/$00/ $8B/$C7/
           $31/$D2/ $BB/$A0/$00/ $F7/$F3/ $D0/$EA/ $8A/$F0/ $B4/$02/
           $CD/$10/ $1F/$5D);
end { PutStr };

{ -------------------------------------------------
  PUTHEAP  - Write a string to Page [n] of the heap
  ------------------------------------------------- }

Procedure PutHeap ( PAGE : HeapBuf;
                      HV : Char;
                       S : AnyString;
                       X : ColumnType;
                       Y : RowType;
                     Att : Byte );
                     external 'PutHeap.com';

{ -------------------------------
  COPIES characters into a string
  ------------------------------- }
Function COPIES (C : Char;
                 N : Integer ): AnyString;
                { AnyString is Type string[255] }
begin
   InLine ($16/ $07/ $8B/$4E/$04/ $88/$4E/$08/ $8B/$46/$06/ $8D/$7E/$09/
           $FC/ $F3/$AA );
end { Copies };


{ ------------------------------------------
  COPYSTR returns N concatenated copies of S
  ------------------------------------------ }
Function CopyStr ( S : AnyString;
                   N : Integer ) : AnyString;

Begin
   InLine ($1E/ $8B/$4E/$04/ $83/$F9/$00/ $7F/$09/
           $C7/$86/$06/$01/$00/$00/ $EB/$46/$90/ $8A/$56/$06/ $30/$F6/
           $51/ $8B/$C2/ $49/ $83/$F9/$00/ $74/$04/ $01/$D0/ $E2/$FC/
           $8B/$CA/ $5A/ $3D/$FF/$00/ $76/$06/ $B8/$FF/$00/ $EB/$07/$90/
           $3C/$00/ $73/$02/ $31/$C0/ $88/$86/$06/$01/ $3C/$00/ $74/$17/
           $8C/$D3/ $8E/$C3/ $8E/$DB/ $8D/$BE/$07/$01/ $8D/$76/$07/ $FC/
           $51/ $56/ $F3/$A4/ $5E/ $59/ $4A/ $75/$F7/ $1F );
end { CopyStr };



{ --------------------------------
  LEFT justify a string in a field
  -------------------------------- }
Function LEFT ( S : AnyString;
                N : Integer;
                Pad : Char ) : AnyString;
                { AnyString is Type string[255] }
begin
   InLine ($1E/ $8D/$76/$09/ $8D/$9E/$08/$01/ $8B/$46/$06/ $36/$88/$07/
           $43/ $8A/$4E/$08/ $30/$ED/ $29/$C8/ $77/$05/ $31/$C0/
           $EB/$0F/$90/ $8B/$FB/ $01/$CF/ $8B/$C8/ $8B/$46/$04/ $16/ $07/
           $FC/ $F3/$AA/ $8B/$FB/ $16/ $1F/ $8A/$4E/$08/ $30/$ED/ $FC/
           $F3/$A4/ $1F );
end { Left };

{ --------------------------------
  RIGHT justify a string in a field
  -------------------------------- }
Function RIGHT ( S : AnyString;
                 N : Integer;
                 Pad : Char ) : AnyString;
                 { AnyString is Type string[255] }
begin
   InLine ($1E/ $8C/$D0/ $8E/$C0/ $8E/$D8/ $8D/$BE/$09/$01/ $8B/$46/$06/
           $88/$86/$08/$01/ $8A/$4E/$08/ $30/$ED/ $8D/$76/$09/ $01/$CE/
           $4E/ $29/$C8/ $77/$06/ $8B/$4E/$06/ $EB/$0C/$90/ $8B/$C8/
           $8B/$46/$04/ $FC/ $F3/$AA/ $8A/$4E/$08/ $01/$CF/ $4F/ $FD/
           $F3/$A4/ $1F/$5D);
end { Right };

{ ------------------------------------------------
  COPYBLK copies one part of the screen to another
  ------------------------------------------------ }
  Procedure COPYBLK (  X1 : ColumnType;
                       Y1 : RowType;
                       X2 : ColumnType;
                       Y2 : RowType;
                       X3 : ColumnType;
                       Y3 : RowType );

{           Copies block defined by upper left and lower right
            coordinates (X1,Y1),(X2,Y2) to a block beginning
            at upper left coordinates (X3,Y3).                }

begin
   InLine ($1E/ $BB/$49/$04/ $31/$C0/ $8E/$D8/ $8A/$07/ $3C/$07/ $75/$06/
           $BA/$00/$B0/ $EB/$0C/$90/ $BA/$DA/$03/ $EC/ $24/$08/ $74/$FB/
           $BA/$00/$B8/ $52/ $8B/$5E/$0C/ $4B/ $8B/$D3/ $B1/$07/ $D3/$E2/
           $B1/$05/ $D3/$E3/ $01/$D3/ $8B/$46/$0E/ $48/ $D1/$E0/ $01/$C3/
           $8B/$F3/ $1F/ $1E/ $8B/$5E/$04/ $4B/ $8B/$D3/ $B1/$07/
           $D3/$E2/ $B1/$05/ $D3/$E3/ $01/$D3/ $8B/$46/$06/ $48/ $D1/$E0/
           $01/$C3/ $8B/$FB/ $07/ $8B/$46/$0C/ $8B/$56/$08/ $29/$C2/ $42/
           $8B/$46/$0E/ $8B/$4E/$0A/ $29/$C1/ $41/  $51/ $FC/ $F3/$A5/
           $59/ $4A/ $74/$0F/ $8B/$D9/ $D1/$E3/ $B8/$A0/$00/ $29/$D8/
           $01/$C6/ $01/$C7/ $EB/$E9/  $1F);
end { CopyBlk };

Procedure CblkHeap ( Page : HeapBuf;
                       X1 : ColumnType;
                       Y1 : RowType;
                       X2 : ColumnType;
                       Y2 : RowType;
                       X3 : ColumnType;
                       Y3 : RowType ); external 'CblkHeap.Com';

{ ------------------------------------------------
  MOVEBLK moves one part of the screen to another
  ------------------------------------------------ }
  Procedure MOVEBLK (  X1 : ColumnType;
                       Y1 : RowType;
                       X2 : ColumnType;
                       Y2 : RowType;
                       X3 : ColumnType;
                       Y3 : RowType );

{           Moves block defined by upper left and lower right
            coordinates (X1,Y1),(X2,Y2) to a block beginning
            at upper left coordinates (X3,Y3).  The orginal block
            is erased. }

begin
   InLine ($1E/ $8B/$46/$0C/ $8B/$4E/$08/ $29/$C1/ $41/ $8B/$46/$0E/
           $8B/$56/$0A/ $29/$C2/ $42/ $D1/$E2/ $8B/$D9/ $29/$D4/ $E2/$FC/
           $8C/$D0/ $8E/$C0/ $8B/$FC/ $52/ $53/ $BB/$49/$04/ $31/$C0/
           $8E/$D8/ $8A/$07/ $3C/$07/ $75/$06/ $BA/$00/$B0/ $EB/$0C/$90/
           $BA/$DA/$03/ $EC/ $24/$08/ $74/$FB/  $BA/$00/$B8/  $8E/$DA/
           $8B/$76/$0C/ $4E/ $8B/$D6/ $B1/$07/ $D3/$E2/ $B1/$05/ $D3/$E6/
           $01/$D6/ $8B/$46/$0E/ $48/ $D1/$E0/ $01/$C6/ $5A/ $59/
           $D1/$E9/ $1E/ $56/ $52/ $51/ $B8/$A0/$00/ $29/$C8/ $29/$C8/
           $FC/ $51/ $F3/$A5/ $59/ $4A/ $74/$04/ $01/$C6/ $EB/$F5/ $59/
           $5A/ $5F/ $07/ $52/ $51/ $BB/$A0/$00/ $29/$CB/ $29/$CB/
           $B8/$20/$0E/ $FC/ $51/ $F3/$AB/ $59/ $4A/ $74/$04/ $01/$DF/
           $EB/$F5/ $8B/$7E/$04/ $4F/ $8B/$D7/ $B1/$07/ $D3/$E2/ $B1/$05/
           $D3/$E7/ $01/$D7/ $8B/$46/$06/ $48/ $D1/$E0/ $01/$C7/ $59/
           $5A/ $8B/$F4/ $8C/$D0/ $8E/$D8/ $B8/$A0/$00/ $29/$C8/ $29/$C8/
           $FC/ $51/ $F3/$A5/ $59/ $4A/ $74/$04/ $01/$C7/ $EB/$F5/
           $8B/$E5/ $83/$EC/$04/ $1F/$5D);
end { MoveBlk };

Procedure MBLKHEAP ( Page : HeapBuf;
                       X1 : ColumnType;
                       Y1 : RowType;
                       X2 : ColumnType;
                       Y2 : RowType;
                       X3 : ColumnType;
                       Y3 : RowType); external 'MblkHeap.Com';

{ ---------------------------------------------
  REMBLK blanks a specified area of the display
  --------------------------------------------- }
Procedure REMBLK ( X1,Y1,X2,Y2 : Integer);
begin
   InLine ($1E/ $8B/$46/$08/ $8B/$56/$04/ $29/$C2/ $42/ $52/ $8B/$46/$0A/
           $8B/$4E/$06/ $29/$C1/ $41/ $51/ $BB/$49/$04/ $31/$C0/ $8E/$D8/
           $8A/$07/ $3C/$07/ $75/$06/ $BA/$00/$B0/ $EB/$0C/$90/
           $BA/$DA/$03/ $EC/ $24/$08/ $74/$FB/  $BA/$00/$B8/ $8E/$C2/
           $8B/$7E/$08/ $4F/ $8B/$D7/ $B1/$07/ $D3/$E2/ $B1/$05/ $D3/$E7/
           $01/$D7/ $8B/$46/$0A/ $48/ $D1/$E0/ $01/$C7/ $59/ $5A/
           $B8/$20/$0E/ $FC/ $51/ $F3/$AB/ $59/ $4A/ $74/$0A/
           $81/$C7/$A0/$00/ $29/$CF/ $29/$CF/ $EB/$EF/ $1F);
end { RemBlk };

{ ---------------------------------------------
  SETATT sets attribute byte for specified area
  --------------------------------------------- }
Procedure SETATT ( X1,Y1,X2,Y2 : Integer;
                   Attribute   : Byte);
begin
   InLine ($1E/ $8B/$46/$0A/ $8B/$56/$06/ $29/$C2/ $42/ $52/ $8B/$46/$0C/
           $8B/$4E/$08/ $29/$C1/ $41/ $51/ $BB/$49/$04/ $31/$C0/ $8E/$D8/
           $8A/$07/ $3C/$07/ $75/$06/ $BA/$00/$B0/ $EB/$0C/$90/
           $BA/$DA/$03/ $EC/ $24/$08/ $74/$FB/  $BA/$00/$B8/ $8E/$C2/
           $8B/$7E/$0A/ $4F/ $8B/$D7/ $B1/$07/ $D3/$E2/ $B1/$05/ $D3/$E7/
           $01/$D7/ $8B/$46/$0C/ $48/ $D1/$E0/ $01/$C7/ $47/ $59/ $5A/
           $8B/$46/$04/ $FC/ $51/ $AA/ $47/ $E2/$FC/ $59/ $4A/ $74/$0A/
           $81/$C7/$A0/$00/ $29/$CF/ $29/$CF/ $EB/$ED/ $1F/$5D);
end { SetAtt };


{ ----------------------------------------------
  HEAPAT sets attribute byte on Page [n] of heap
  ---------------------------------------------- }
Procedure HEAPAT ( Page : HeapBuf;
                   X1,Y1,X2,Y2 : Integer;
                   Attribute   : Byte);
                   external 'Heapat.com';

{ ------------------------------------------------
  MOVEBG moves one part of the screen to another,
         while preserving the background.
  ------------------------------------------------ }
  Procedure MOVEBG ( Page : HeapBuf;
                       X1 : ColumnType;
                       Y1 : RowType;
                       X2 : ColumnType;
                       Y2 : RowType;
                       X3 : ColumnType;
                       Y3 : RowType );
     external 'Movebg.com';

 {          Type HeapBuf = ^AnyBuf;
                  AnyBuf = record
                              Screen : array[1..4000] of byte;
                           end;

            Moves block defined by upper left and lower right
            coordinates (X1,Y1),(X2,Y2) to a block beginning
            at upper left coordinates (X3,Y3).  The orginal
            block is saved, the background 'Page' refreshed,
            then the block is redisplayed at its new position. }


{ ----------------------------------------------
  FINDSTR searches for the first occurrence of S
  in video memory beginning from X,Y.
  ---------------------------------------------- }
Procedure FindStr ( X : ColumnType;
                    Y : RowType;
                    S : AnyString;
                    N : Integer;
            var Ecode : Integer ); external 'FindStr.com';
{
           Ecode = 0 if S is found on screen
           Ecode = 1 if S not found
            if N = 0, cursor placed at S[1]
            if N < 0, cursor placed at Nth position from left end of S
            if N > 0, cursor placed at Nth position from right end of S }

{ -----------------------------------------
  FSTRHEAP searches Page on the heap for
  the first occurrence of S.  If S found,
  FstrHeap sets X,Y to the address of S[1].
  If not found, X = 0.
  ----------------------------------------- }
Procedure FstrHeap ( Page : HeapBuf;
                        S : AnyString;
                    var X : ColumnType;
                    var Y : RowType ); external 'FstrHeap.com';


{ ------------------------------------------------
  GETSTR reads string at X,Y into S for length LEN
  ------------------------------------------------ }
  Procedure GETSTR (    HV : Char;
                     VAR S : AnyString;
                         X : ColumnType;
                         Y : RowType;
                       LEN : Integer);
                       external 'GetStr.com';

{                    If X=Y=0, then read begins at current cursor
                     position.  Otherwise read begins at (X,Y).
                     HV = 'V' or 'v', read is top-to-bottom.
                     Otherwise read is left-to-right.
                     On exit, cursor points to one beyond last
                     byte read.   }

  Procedure GETHEAP ( Page : HeapBuf;
                        HV : Char;
                     VAR S : AnyString;
                         X : ColumnType;
                         Y : RowType;
                       LEN : Integer ); external 'GetHeap.com';

{     GetHeap gets strings from the heap.  X,Y must be valid
      coordinates--zero not allowed.  GetHeap is useful for
      getting small portions of the heap }

{ ------------------------------------------------
  UPPER function converts alphabetics to uppercase
  ------------------------------------------------ }
Function UPPER  ( S : AnyString) : AnyString;
begin
   InLine ($1E/ $8A/$4E/$04/ $30/$ED/ $8D/$76/$05/ $8D/$BE/$04/$01/
           $36/$88/$0D/ $80/$F9/$00/ $76/$18/ $47/ $8C/$D0/ $8E/$D8/
           $8E/$C0/ $FC/ $8A/$04/ $3C/$61/ $72/$06/ $3C/$7A/ $77/$02/
           $2C/$20/ $AA/ $46/ $E2/$F0/ $1F);
end { Upper };

{ --------------------------------------------
  OVERSTR overlays and pads target string with
  new string
  -------------------------------------------- }
  Function OVERSTR ( NEW, TARGET : AnyString;
                          N, LEN : Integer;
                             PAD : Char) : AnyString;

{                    NEW overlays TARGET beginning at position N of
                     TARGET, for a length of LEN.  If LEN exceeds the
                     length of NEW, NEW is padded on the right with
                     PAD.   If N exceeds the length of TARGET, left-
                     padding occurs before NEW is written. }
begin
   InLine ($1E/ $8C/$D0/ $8E/$C0/ $8E/$D8/ $8A/$4E/$0A/ $30/$ED/
           $8D/$76/$0B/ $8D/$BE/$0B/$02/ $FC/ $F3/$A4/ $8A/$5E/$0A/
           $30/$FF/ $8B/$4E/$06/ $83/$F9/$00/ $7C/$71/ $8B/$56/$08/
           $83/$FA/$00/ $7C/$69/ $8D/$BE/$0B/$02/ $39/$DA/ $76/$30/
           $81/$FA/$00/$FF/ $76/$03/ $BA/$00/$01/ $8B/$CA/ $29/$D9/ $49/
           $8B/$46/$04/ $01/$DF/ $F3/$AA/ $8D/$BE/$0B/$02/ $8B/$4E/$06/
           $01/$D1/ $81/$F9/$FF/$00/ $77/$06/ $8B/$4E/$06/ $EB/$07/$90/
           $B9/$FF/$00/ $29/$D1/ $41/ $8A/$86/$0A/$01/ $30/$E4/ $51/
           $39/$C1/ $72/$02/ $8B/$C8/ $8D/$B6/$0B/$01/ $01/$D7/ $4F/
           $F3/$A4/ $59/ $39/$C1/ $76/$16/ $01/$D0/ $3D/$FF/$00/ $73/$0F/
           $51/ $8A/$86/$0A/$01/ $30/$E4/ $29/$C1/ $8B/$46/$04/ $F3/$AA/
           $59/ $8D/$8E/$0B/$02/ $29/$CF/ $39/$DF/ $77/$02/ $8B/$FB/
           $8B/$C7/ $88/$86/$0A/$02/ $1F/$5D);
end { OverStr };

{ --------------------------------------
  DOWS returns day of week for any valid
  Gregorian Date
  -------------------------------------- }
Function DOWS( MM, DD, CCYY : Integer) : AnyString;

begin
   InLine ($1E/ $E8/$A8/$00/ $EB/$0D/$90/ $00/$03/$02/$05/$00/$03/
           $05/$01/$04/$06/$02/$04/ $83/$C3/$03/ $8B/$FB/ $8B/$5E/$08/
           $8B/$4E/$06/ $8B/$56/$04/ $83/$FB/$03/ $73/$01/ $4A/ $01/$DF/
           $4F/ $2E/$02/$0D/ $8B/$C2/ $BB/$64/$00/ $30/$FF/ $F6/$F3/ $51/
           $50/ $B1/$02/ $D2/$CC/ $B1/$06/ $D2/$EC/ $8A/$DC/ $58/
           $B1/$02/ $D2/$C8/ $B1/$06/ $D2/$E8/ $B1/$02/ $8A/$D4/ $D2/$EA/
           $59/ $00/$D0/ $B7/$05/ $F6/$E7/ $30/$FF/ $01/$D8/ $01/$C8/
           $BA/$07/$00/ $F6/$F2/ $8A/$C4/ $30/$E4/ $E8/$42/$00/
           $EB/$46/$90/ $53/$75/$6E/$64/$61/$79/$20/$20/$20/
           $4D/$6F/$6E/$64/$61/$79/$20/$20/$20/
           $54/$75/$65/$73/$64/$61/$79/$20/$20/
           $57/$65/$64/$6E/$65/$73/$64/$61/$79/
           $54/$68/$75/$72/$73/$64/$61/$79/$20/
           $46/$72/$69/$64/$61/$79/$20/$20/$20/
           $53/$61/$74/$75/$72/$64/$61/$79/$20/ $8B/$DC/ $36/$8B/$1F/
           $C3/ $83/$C3/$03/ $8B/$F3/ $B9/$09/$00/ $F6/$E1/ $01/$C6/ $0E/
           $1F/ $16/ $07/ $88/$4E/$0A/ $8D/$7E/$0B/ $FC/ $F3/$A4/
           $1F/$5D);
end { Dows };

{ -------------------------------------------
  STRIP function removes leading and trailing
  characters from a string.
  ------------------------------------------- }
Function STRIP ( S : AnyString;
                 C : Char) : AnyString;
                 { Removes all leading and trailing
                   C characters from S }
begin
   InLine ($1E/ $8D/$7E/$07/ $8A/$4E/$06/ $30/$ED/ $8C/$D0/ $8E/$C0/
           $8B/$46/$04/ $83/$F9/$01/ $77/$0E/ $8A/$5E/$07/ $30/$FF/
           $39/$D8/ $74/$35/ $8B/$D7/ $EB/$1D/$90/ $FC/ $F3/$AE/ $E3/$2B/
           $4F/ $8B/$D7/ $8A/$4E/$06/ $30/$ED/ $8D/$7E/$07/ $01/$CF/ $4F/
           $FD/ $F3/$AE/ $47/ $8B/$CF/ $29/$D1/ $41/ $88/$8E/$06/$01/
           $8B/$F2/ $8D/$BE/$07/$01/ $8C/$D0/ $8E/$D8/ $FC/ $F3/$A4/
           $EB/$07/$90/ $C7/$86/$06/$01/$00/$00/ $1F/$5D);
end { Strip };

{ ---------------------
  Upper Left Box
  --------------------- }
Procedure BOXUL ( Start_Col, Start_Row,
                  End_Col,   End_Row,   Style   : Integer;
                  Attribute  : Byte);

Var
   Ver_Adj, Hor_Adj, Num_Col, Num_Row : Integer;

Const
                                  { DOWN  LL  OVER  LR   UR   UL }
   s : array[1..4,1..6] of char = ((#179,#192,#196,#217,#191,#218),
                                   (#186,#200,#205,#188,#187,#201),
                                   (#186,#211,#196,#189,#183,#214),
                                   (#179,#212,#205,#190,#184,#213));

begin
   if (style < 1) or (style > 4) then
      style := 1;
   Num_Col := End_Col - Start_Col + 1;
   Num_Row := End_Row - Start_Row + 1;
   if Num_Col <= 2 then
      Num_Col := 3;
   if Num_Row <= 2 then
      Num_Row := 3;
   Ver_Adj := Num_Row - 2;
   Hor_Adj := Num_Col - 2;

   PUTSTR ( V, s[style,6],
               Start_Col, Start_Row, Attribute);             { UL Corner  }

   PUTSTR ( V, COPIES( s[style,1], Ver_Adj),
               Start_Col,  Start_Row + 1, Attribute);        { Left Side  }

   PUTSTR ( V, s[style,2],
               Start_Col, End_Row, Attribute);               { LL Corner  }

   PUTSTR ( H, COPIES( s[style,3], Hor_Adj),
               Start_Col + 1, End_Row, Attribute);           { Bottom     }

   PUTSTR ( V, s[style,4],
               End_Col, End_Row, Attribute);                 { LR Corner  }

   PUTSTR ( V, COPIES( s[style,1],Ver_Adj),
               End_Col, Start_Row + 1, Attribute);           { Right Side }

   PUTSTR ( V, s[style,5],
               End_Col, Start_Row, Attribute);               { UR Corner  }

   PUTSTR ( H, COPIES( s[style,3],Hor_Adj),
               Start_Col + 1, Start_Row, Attribute);         { Top        }

end { Boxul };

{ --------------------------------
  BOXHEAP builds a box on the heap
  at Page [n]
  -------------------------------- }
Procedure BoxHeap ( Page  :  HeapBuf;
                    Start_Col, Start_Row,
                    End_Col,   End_Row,   Style   : Integer;
                    Attribute  : Byte);

Var
   Ver_Adj, Hor_Adj, Num_Col, Num_Row : Integer;

Const
                                  { DOWN  LL  OVER  LR   UR   UL }
   s : array[1..4,1..6] of char = ((#179,#192,#196,#217,#191,#218),
                                   (#186,#200,#205,#188,#187,#201),
                                   (#186,#211,#196,#189,#183,#214),
                                   (#179,#212,#205,#190,#184,#213));

begin
   if (style < 1) or (style > 4) then
      style := 1;
   Num_Col := End_Col - Start_Col + 1;
   Num_Row := End_Row - Start_Row + 1;
   if Num_Col <= 2 then
      Num_Col := 3;
   if Num_Row <= 2 then
      Num_Row := 3;
   Ver_Adj := Num_Row - 2;
   Hor_Adj := Num_Col - 2;

   PutHeap ( Page, V, s[style,6],
                   Start_Col, Start_Row, Attribute);         { UL Corner  }

   PutHeap ( Page, V, COPIES( s[style,1], Ver_Adj),
                   Start_Col,  Start_Row + 1, Attribute);    { Left Side  }

   PutHeap ( Page, V, s[style,2],
                   Start_Col, End_Row, Attribute);           { LL Corner  }

   PutHeap ( Page, H, COPIES( s[style,3], Hor_Adj),
                   Start_Col + 1, End_Row, Attribute);       { Bottom     }

   PutHeap ( Page, V, s[style,4],
                   End_Col, End_Row, Attribute);             { LR Corner  }

   PutHeap ( Page, V, COPIES( s[style,1],Ver_Adj),
                   End_Col, Start_Row + 1, Attribute);       { Right Side }

   PutHeap ( Page, V, s[style,5],
                   End_Col, Start_Row, Attribute);           { UR Corner  }

   PutHeap ( Page, H, COPIES( s[style,3],Hor_Adj),
                   Start_Col + 1, Start_Row, Attribute);     { Top        }

end { BoxHeap };


{ ----------------------
  TIMER Boolean Function
  ---------------------- }
Function Timer ( Limit : integer) : Boolean;

{ Note: Globals are:
                 Type
                    Result  = record
                                AX, BX, CX, DX, BP,
                                SI, DI, DS, ES, Flags : Integer;
                              end;
                 var
                    regs : result;
                    TimeElapsed,
                    SaveElapsed   : Integer;
                    StartElapsed  : Boolean = FALSE;
}
var
   SecondsReading : Integer;

begin
   with regs do
   begin
      if Limit <= 0 then
         Timer := TRUE
      else
      begin
         Timer := FALSE;
         ax := $2C00;
         intr($21,regs);

         if StartElapsed = FALSE then
         begin
            SaveElapsed  := hi(dx);
            TimeElapsed  := 0;
            StartElapsed := TRUE;
            ax := $2D00;                { Set time . . .            }
            dx := Swap(SaveElapsed);    { With hundredths = 0 . . . }
            intr($21,regs);             { so that we start from 0   }
            delay(70);                  { Helps DOS 3.1 work right  }
         end
         else
         if SaveElapsed <> hi(dx) then
         begin
            SecondsReading := hi(dx);
            if SaveElapsed > SecondsReading then
               SecondsReading := SecondsReading + 60;
            TimeElapsed := TimeElapsed + SecondsReading - SaveElapsed;
            SaveElapsed := hi(dx);

            if TimeElapsed >= Limit then
            begin
               Timer := TRUE;
               StartElapsed := FALSE;
            end;
         end;
      end;
   end;
end { Timer };

{ --------------------------
  Display TIME of day at X,Y
  -------------------------- }
Procedure TimeXY (X : ColumnType;
                  Y : RowType ) ;
var
   hour     : integer;
   hr,
   min, sec : string[2];

begin
   with regs do
   begin
      ax := $2C00;
      intr($21,regs);
      hour := hi(cx);
      if hour < 1 then
         hour := 12
      else
      if hour > 12 then
         hour := hour - 12;
      str ( hour, hr );
      str ( lo(cx), min );
      str ( hi(dx), sec );
      if length(min) < 2 then
         min := '0'+min;
      if length(sec) < 2 then
         sec := '0'+sec;
      PutStr( h,hr+':'+min+':'+sec, x,y,14);
   end
end { TimeXY };

{ ---------------
  SET TIME of day
  --------------- }
Procedure Stime ( hh, mm, ss : integer );
begin
   with regs do
   begin
      cx := swap(hh);
      cx := cx or mm;
      dx := swap(ss);
      ax := $2D00;
      intr($21,regs);
   end;
end { Stime };

{ -----------------------------------
  SAVESCREEN saves the current screen
  ----------------------------------- }
Procedure SaveScreen ( Page : HeapBuf);
   external 'Saves.com';

{ -------------------------------------
  RESTORESCREEN restores a saved screen
  ------------------------------------- }
Procedure RestoreScreen ( Page : HeapBuf);
   external 'Restores.com';

{ ------------------------------------
  CURSOROFF makes the cursor invisible
  ------------------------------------ }
Procedure CursorOff;
begin
   with regs do
   begin
      cx := $2000;
      ax := $0100;
      intr($10,regs);
   end;
end { CursorOff };

{ ---------------------------------
  CURSORON produces a normal cursor
  --------------------------------- }
Procedure CursorOn;
begin
   with regs do
   begin
      if VideoStatus = 7 then
         cx := $0C0D  { Monochrome }
      else
         cx := $0607; { Color }
      ax := $0100;
      intr($10,regs);
   end;
end { CursorOn };

{ --------------------------------------
  WAIT for Timer to elapse or a KeyPress.
  If KeyPress was HOME key, WAIT waits
  for another KeyPress.
  -------------------------------------- }
Procedure Wait ( NumberOfSeconds : Integer);
begin
   repeat until Timer(NumberOfSeconds) or KeyPressed;
   if KeyPressed then
   begin
      read(Kbd,ch);
      StartElapsed := FALSE;
      if (ch = #27) and KeyPressed then
      begin
         read(Kbd,ch);
         if ch = #71 then
         begin
            repeat until KeyPressed;
            read(Kbd,ch);
            if (ch = #27 ) and KeyPressed then
               read(Kbd,ch);
         end;
      end;
   end;
end { Wait };


{ --------------------------------
  NSORBIT - Nancy's Orbiting Light
  -------------------------------- }
Procedure NsOrbit ( StartCol   , StartRow,
                    EndCol     , EndRow,
                    Style      , NumberOfSeconds : Integer);
Var
   NumberCols, NumberRows, I,
   RowDelay, ColDelay : Integer;
begin

   RowDelay := 3;
   ColDelay := 1;
   NumberCols := EndCol - StartCol + 1;
   NumberRows := EndRow - StartRow + 1;

   BoxUL (StartCol, StartRow, EndCol, EndRow, Style, 14);

   repeat
      for i := 0 to NumberCols - 1  do
      begin
         SetAtt ( StartCol+i, StartRow, StartCol+i, StartRow, 14);
         delay(ColDelay);
         SetAtt ( StartCol+i, StartRow, StartCol+i, StartRow,  0);
         delay(ColDelay);
         SetAtt ( EndCol-i, EndRow, EndCol-i, EndRow,  14);
         delay(ColDelay);
         SetAtt ( EndCol-i, EndRow, EndCol-i, EndRow,  0);
         delay(ColDelay);
      end;

      for i := 0 to NumberRows - 1  do
      begin
         SetAtt ( EndCol, StartRow+i, EndCol, StartRow+i, 14);
         delay(RowDelay);
         SetAtt ( EndCol, StartRow+i, EndCol, StartRow+i,  0);
         delay(RowDelay);
         SetAtt ( StartCol, EndRow-i, StartCol, EndRow-i, 14);
         delay(RowDelay);
         SetAtt ( StartCol, EndRow-i, StartCol, EndRow-i,  0);
         delay(RowDelay);
      end;

      for i := 0 to NumberCols - 1  do
      begin
         SetAtt ( StartCol+i, StartRow, StartCol+i, StartRow, 14);
         delay(ColDelay);
         SetAtt ( StartCol+i, StartRow, StartCol+i, StartRow,  0);
         delay(ColDelay);
         SetAtt ( EndCol-i, EndRow, EndCol-i, EndRow, 14);
         delay(ColDelay);
         SetAtt ( EndCol-i, EndRow, EndCol-i, EndRow,  0);
         delay(ColDelay);
      end;

      for i := 0 to NumberRows - 1  do
      begin
         SetAtt ( StartCol, EndRow-i, StartCol, EndRow-i, 14);
         delay(RowDelay);
         SetAtt ( StartCol, EndRow-i, StartCol, EndRow-i,  0);
         delay(RowDelay);
         SetAtt ( EndCol, StartRow+i, EndCol, StartRow+i, 14);
         delay(RowDelay);
         SetAtt ( EndCol, StartRow+i, EndCol, StartRow+i,  0);
         delay(RowDelay);
      end;
   until Timer(NumberOfSeconds) or KeyPressed;
   if KeyPressed then
   begin
      read(Kbd,ch);
      StartElapsed := FALSE;
   end;
   BoxUL (StartCol, StartRow, EndCol, EndRow, Style, 14);
end { NsOrbit };

{ ---------------------------------
  CALENDAR for given month and year
  --------------------------------- }
Procedure Calendar ( MM, CCYY, StartCol, StartRow : Integer);
var
   target     :   string[10];
   year       :   string[4];
   PreviousMonth,
   NextMonth,
   PreviousMonthLength,
   NumDays,
   Xpos, Ypos, StartDay,
   i, j, day  :   integer;
   Temp, Months,
   Col, Row   :   AnyString;

const
   days :  array[1..7] of string[2] =
           ('Su','Mo','Tu','We','Th','Fr','Sa');
   MonthLength : array[1..12] of integer =
             (31,28,31,30,31,30,31,31,30,31,30,31);

begin
   target := strip( dows ( mm, 1, ccyy), ' ');
   day := 0;
   repeat
      day := succ(day);
   until (Copy ( target, 1, 2) = days[day]) or (day > 7);

   if day <= 7 then
   begin
      Col := #179+#197;
      Col := #194+Col+Col+Col+Col+Col+#179+#193;
      Row := #196+#196+#197;
      Row := #195+Row+Row+Row+Row+Row+Row+#196+#196+#180;
      BoxUL ( StartCol, StartRow+2, StartCol+21, StartRow+14, 1, 14);
      for i := 0 to 5 do
         PutStr ( V, Col, StartCol+3+i*3, StartRow+2, 14);
      for i := 0 to 4 do
         PutStr ( H, Row, StartCol, StartRow+4+i*2, 14);

      Months :=  'January   February  March     '+
                 'April     May       June      '+
                 'July      August    September '+
                 'October   November  December  ';

      Str (CCYY,year);
      Temp := Copy ( Months, 1+(MM-1)*10, 10);
      Temp := Center ( Strip ( Temp, ' ') + ', '+year ,20,' ');
      PutStr (H, Temp , StartCol + 1, StartRow, 14);

      for i := 1 to 7 do
         PutStr (H,days[i] + ' ',
                   StartCol+1+(i-1)*3, StartRow+1, 10);

      if MM = 1 then
         PreviousMonth := 12
      else
         PreviousMonth := MM - 1;

      PreviousMonthLength := MonthLength[PreviousMonth];
      if ( PreviousMonth = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
         PreviousMonthLength := succ(PreviousMonthLength);
      Ypos := StartRow + 3;
      if day > 1 then
      begin
         j := PreviousMonthLength - day + 1;
         for i := 1 to day - 1 do
         begin
            j := succ(j);
            str ( j:2, Temp);
            PutStr ( H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
         end;
         for i := 1 to 7 - day + 1 do
         begin
            str ( i:2, Temp);
            PutStr ( H, Temp , StartCol+1+(day-1)*3+(i-1)*3, Ypos, 14);
         end;
      end { day > 1 }
      else
      begin
         j := PreviousMonthLength - 7;
         for i := 1 to 7 do
         begin
            j := succ(j);
            str ( j:2, Temp);
            PutStr ( H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
         end;
      end { day = 1 };

      j := 0;
      Ypos := StartRow + 5;
      NumDays := MonthLength[mm];
      if ( MM = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
         NumDays := succ(NumDays);

      if Day > 1 then
         StartDay := 7 - day  + 2
      else
         StartDay := 1;

      for i := StartDay to NumDays do
      begin
         Xpos := StartCol+1+j*3;
         Str(i:2,Temp);
         PutStr ( H, Temp, Xpos, Ypos, 14);
         j := succ(j);
         if j = 7 then
         begin
            j := 0;
            Ypos := Ypos + 2;
         end;
      end;

      if Day > 1 then
         NextMonth := 42 - ( day - 1 + NumDays)
      else
         NextMonth := 42 - (NumDays + 7);
      for i := 1 to NextMonth do
      begin
         Xpos := StartCol+1+j*3;
         Str(i:2,Temp);
         PutStr ( H, Temp, Xpos, Ypos, 12);
         j := succ(j);
         if j = 7 then
         begin
            j := 0;
            Ypos := Ypos + 2;
         end;
      end;
   end;
end { Calendar };

{ ---------------------------------
  CALHEAP for given month and year
  --------------------------------- }
Procedure CalHeap ( Page : HeapBuf; MM, CCYY, StartCol, StartRow : Integer);
var
   target     :   string[10];
   year       :   string[4];
   PreviousMonth,
   NextMonth,
   PreviousMonthLength,
   NumDays,
   Xpos, Ypos, StartDay,
   i, j, day  :   integer;
   Temp, Months,
   Col, Row   :   AnyString;

const
   days :  array[1..7] of string[2] =
           ('Su','Mo','Tu','We','Th','Fr','Sa');
   MonthLength : array[1..12] of integer =
             (31,28,31,30,31,30,31,31,30,31,30,31);

begin
   target := strip( dows ( mm, 1, ccyy), ' ');
   day := 0;
   repeat
      day := succ(day);
   until (Copy ( target, 1, 2) = days[day]) or (day > 7);

   if day <= 7 then
   begin
      Col := #179+#197;
      Col := #194+Col+Col+Col+Col+Col+#179+#193;
      Row := #196+#196+#197;
      Row := #195+Row+Row+Row+Row+Row+Row+#196+#196+#180;
      BoxHeap ( Page, StartCol, StartRow+2, StartCol+21, StartRow+14, 1, 14);
      for i := 0 to 5 do
         PutHeap ( Page, V, Col, StartCol+3+i*3, StartRow+2, 14);
      for i := 0 to 4 do
         PutHeap ( Page, H, Row, StartCol, StartRow+4+i*2, 14);

      Months :=  'January   February  March     '+
                 'April     May       June      '+
                 'July      August    September '+
                 'October   November  December  ';

      Str (CCYY,year);
      Temp := Copy ( Months, 1+(MM-1)*10, 10);
      Temp := Center ( Strip ( Temp, ' ') + ', '+year ,20,' ');
      PutHeap (Page, H, Temp , StartCol + 1, StartRow, 14);

      for i := 1 to 7 do
         PutHeap (Page, H,days[i] + ' ',
                   StartCol+1+(i-1)*3, StartRow+1, 10);

      if MM = 1 then
         PreviousMonth := 12
      else
         PreviousMonth := MM - 1;

      PreviousMonthLength := MonthLength[PreviousMonth];
      if ( PreviousMonth = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
         PreviousMonthLength := succ(PreviousMonthLength);
      Ypos := StartRow + 3;
      if day > 1 then
      begin
         j := PreviousMonthLength - day + 1;
         for i := 1 to day - 1 do
         begin
            j := succ(j);
            str ( j:2, Temp);
            PutHeap ( Page, H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
         end;
         for i := 1 to 7 - day + 1 do
         begin
            str ( i:2, Temp);
            PutHeap ( Page, H, Temp , StartCol+1+(day-1)*3+(i-1)*3, Ypos, 14);
         end;
      end { day > 1 }
      else
      begin
         j := PreviousMonthLength - 7;
         for i := 1 to 7 do
         begin
            j := succ(j);
            str ( j:2, Temp);
            PutHeap ( Page, H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
         end;
      end { day = 1 };

      j := 0;
      Ypos := StartRow + 5;
      NumDays := MonthLength[mm];
      if ( MM = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
         NumDays := succ(NumDays);

      if Day > 1 then
         StartDay := 7 - day  + 2
      else
         StartDay := 1;

      for i := StartDay to NumDays do
      begin
         Xpos := StartCol+1+j*3;
         Str(i:2,Temp);
         PutHeap ( Page, H, Temp, Xpos, Ypos, 14);
         j := succ(j);
         if j = 7 then
         begin
            j := 0;
            Ypos := Ypos + 2;
         end;
      end;

      if Day > 1 then
         NextMonth := 42 - ( day - 1 + NumDays)
      else
         NextMonth := 42 - (NumDays + 7);
      for i := 1 to NextMonth do
      begin
         Xpos := StartCol+1+j*3;
         Str(i:2,Temp);
         PutHeap ( Page, H, Temp, Xpos, Ypos, 12);
         j := succ(j);
         if j = 7 then
         begin
            j := 0;
            Ypos := Ypos + 2;
         end;
      end;
   end;
end { CalHeap };

{ ------------------------------
  RWORD returns a string with ST
  replacing word N of S.
  ------------------------------ }
Function RWord  ( S : AnyString;
                  N : Integer;
                 ST : AnyString ) : AnyString;

{   A word is any blank-delimited character sequence,
    or a string of non-blanks.  There are 7 words in
    this sentence. }

var
   NumWords, start, stop, CurrentAddress, len
             : integer;
   Ts, Ats, Tail
             : AnyString;
   BlankFound
             : Boolean;

begin
   if Length(S) = 0 then
      Rword := ''
   else
   begin
      len := Length(S);
      NumWords := 0;
      start := 1;
      stop := len;
      BlankFound := True;
      CurrentAddress := 0;
      repeat
        CurrentAddress := CurrentAddress + 1;
        if BlankFound then
        begin
           if S[CurrentAddress] <> #32 then
           begin
              BlankFound := false;
              NumWords := succ(NumWords);
              if NumWords = N then
                 start := CurrentAddress;
           end;
        end
        else
        if S[CurrentAddress] = #32 then
        begin
           BlankFound := true;
           if NumWords = N then
              stop := CurrentAddress;
        end;
     until (CurrentAddress = len ) or ( stop < len );
     if N > NumWords then
        Rword := S
     else
     begin
        Tail := copy ( S, stop, Length(S)-stop+1 );
        Ts := copy ( S, 1, start-1 );
        Ats := St;
        if (length(Ts) + length(St) + length(Tail)) > 255 then
           Ats := copy ( St, 1, 255 - length(Ts) - length(tail) );
        if S[stop] = #32 then
           Rword := Ts + Ats + Tail
        else
           Rword := Ts + Ats;
     end;
   end;
end { Rword };

{ ------------------------------------------
  WORD returns a string that is word N of S.
  ------------------------------------------ }
Function Word  ( S : AnyString;
                 N : Integer ) : AnyString;

var
   NumWords, start, stop, CurrentAddress, len
             : integer;
   Ts
             : AnyString;
   BlankFound
             : Boolean;


begin
   if Length(S) = 0 then
      Word := ''
   else
   begin
      NumWords := 0;
      start := 1;
      len := length(S);
      stop := len;
      BlankFound := True;
      CurrentAddress := 0;

      repeat
         CurrentAddress := CurrentAddress + 1;
         if BlankFound then
         begin
            if S[CurrentAddress] <> #32 then
            begin
               BlankFound := false;
               NumWords := NumWords + 1;
               if NumWords = N then
                  start := CurrentAddress;
            end;
         end
         else
         if S[CurrentAddress] = #32 then
         begin
            BlankFound := true;
            if NumWords = N then
               stop := CurrentAddress;
         end;
      until (stop < len) or (CurrentAddress = len);

      if N > NumWords then
         Word := ''
      else
      begin
         if S[stop] <> #32 then
            stop := succ(stop);
         Word := copy ( S, start, stop - start );
      end;
   end;
end { Word };

{ ---------------------------------------
  WORDS returns the number of words in S.
  --------------------------------------- }
Function Words ( S : AnyString ) : Integer;
var
   NumWords,  CurrentAddress, Len
             : integer;

begin
   S := strip(S,' ');
   Len := Length(S);
   if Len = 0 then
      Words := 0
   else
   begin
      NumWords := 1;
      CurrentAddress := 1;
      for CurrentAddress := 1 to Len do
         if S[CurrentAddress] = #32 then
            NumWords := NumWords + 1;
      Words := NumWords;
   end;
end { Words };

{ ------------------------------------------
  WORDIND returns the position of WordNumber
  in S.
  ------------------------------------------ }
Function WordInd (          S : AnyString;
                   WordNumber : Integer ) : Integer;

{ Example: if S = 'I like Turbo Pascal' then
              WordInd ( S, 3 ) is 8.  }

var
   NumWords,  CurrentAddress, Len, Index
             : integer;
   NonBlank :  Boolean;

begin
   Len := Length(S);
   if Len = 0 then
      WordInd := 0
   else
   begin
      Index := 0;
      NumWords := 0;
      CurrentAddress := 0;
      NonBlank := false;
      repeat
         CurrentAddress := CurrentAddress + 1;
         if NonBlank then
         begin
            if S[CurrentAddress] = #32 then
               NonBlank := false;
         end
         else
         if S[CurrentAddress] <> #32 then
         begin
            NumWords := NumWords + 1;
            if NumWords = WordNumber then
               Index := CurrentAddress;
            NonBlank := true;
         end;
      until (CurrentAddress = Len) or (Index > 0);
      WordInd := Index;
   end;
end { WordInd };

{ -------------------------
  SPACE normalizes a string
  ------------------------- }
Function Space ( S : AnyString ) : AnyString;

{ A normalized string has no leading or trailing blanks
  and has only one space between words. }

var
   Ts : AnyString;
   CurrentWord, NumberOfWords : integer;
begin
   Ts := '';
   NumberOfWords := words(S);
   if NumberOfWords > 0 then
   begin
      for CurrentWord := 1 to NumberOfWords do
      begin
         if CurrentWord <> NumberOfWords then
            Ts := Ts + word ( S, CurrentWord ) + ' '
         else
            Ts := Ts + word ( S,CurrentWord);
      end;
   end;
  Space := Ts;
end {Space} ;