Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/KTOOLS.ZIP/KTOOLS.PAS

Pascal/Delphi Source File | 1987-04-01 | 11.6 KB | 375 lines

UNIT KTOOLS;

INTERFACE
USES
    Dos,
    Crt;

TYPE
    Colors = 0..15;

VAR
    ActiveDP  : Byte;     (* Active Display Page               *)
    LineWidth : Integer;  (* Line Width of current video mode  *)
    VideoMode : Byte;     (* Current Video Mode i.e. 0,1,2,3,7 *)


FUNCTION CurrentVideoMode : Byte;
(*
This function returns the current video mode... 0..3 = color, 7 = mono.
Global variables  LineWidth & ActiveDP are set each time this function
is called.
*)

PROCEDURE CursorOn;
(*
This procedure checks the current video mode and restores a normal cursor.
*)

PROCEDURE CursorOff;
(*
This procedure sets bit five of the cursor control byte, turning the cursor
off.
*)

FUNCTION KUCase(S:String):String;
(*
This function uses upcase procedure to convert an entire string or line from
a text file to all uppercase characters.
*)

FUNCTION KLCase(S:String):String;
(*
This function uses CHR & ORD and does just the oppsite of KUCase.
*)

FUNCTION Color(FG,BG:Colors):Byte;
(*
This function returns the color attribute result for the combo FG on BG.
The blinking bit is removed.
*)

PROCEDURE KAttr(Row,Col,Rows,Cols:Integer;Attr:Byte);
(*
This procedure puts the specified Attribute beginning at Row/Col and goes
Cols by Rows.
*)

PROCEDURE KFill(Row,Col,Rows,Cols:Integer;Ch:Char;Attr:Byte);
(*
This procedure puts the specified Character beginning at Row/Col and goes
Cols by Rows.
*)

{$V-}
PROCEDURE KTrim(VAR S:String);
(*
This procedure trims all leading and trailing blanks from a string.
*)

PROCEDURE KWrite(Row,Col:Integer;Attr:Byte;S:String);
(*
This procedure writes at string beginning at Row/Col with text Attr.
It looks for the actual param on the stack.
*)

PROCEDURE KWriteV(Row,Col:Integer;Attr:Byte;VAR S:String);
(*
This procedure writes at string beginning at Row/Col with text Attr.
It looks for the param address on the stack.
*)

PROCEDURE KWriteC(Row:Integer;Attr:Byte;S:String);
(*
This procedure writes at string beginning at Row/Col with text Attr.
The output is centered on the screen between column 1 & 80.
*)

PROCEDURE KWriteCV(Row:Integer;Attr:Byte;VAR S:String);
(*
This procedure writes at string beginning at Row/Col with text Attr.
The output is centered on the screen between column 1 & 80.
It looks for the param address on the stack.
*)
{$V+}



IMPLEMENTATION
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

FUNCTION CurrentVideoMode:Byte;
VAR
    Regs:Registers;               {Registers defined in DOS unit}
BEGIN
    Regs.AH := $F;
    Intr($10,DOS.Registers(Regs));
    CurrentVideoMode:=Regs.AL;    {Assign video mode to function name}
    ActiveDP:=Regs.BH;            {Active page returned in register BH}
    LineWidth:=Regs.AH;           {Characters per line returned in AH}
END;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

PROCEDURE CursorOn;
VAR
    Regs:Registers;               {Registers defined in DOS unit}
    Mode:Byte;
BEGIN
    Mode := CurrentVideoMode;     {get current video mode}
    IF Mode IN[0..3] THEN
       BEGIN
          Regs.AH := $01;                { Restore Color Cursor }
          Regs.CH := $06;
          Regs.CL := $07;
          Intr($10,DOS.Registers(Regs));
       END
    ELSE
       IF Mode = 7 THEN
          BEGIN
             Regs.AH := $01;            { Restore Mono Cursor }
             Regs.CH := $C;
             Regs.CL := $D;
             Intr($10,DOS.Registers(Regs));
          END
       ELSE
          BEGIN
             Regs.AH := $01;            { We're gonna put a cursor }
             Regs.CH := $1;             { on the screen no matter what }
             Regs.CL := $D;             { one big block  if all else fails }
             Intr($10,DOS.Registers(Regs));
          END;

END;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

PROCEDURE CursorOff;
VAR
   Regs:Registers;
BEGIN                            { Set bit 5 of cursor control byte }
   Regs.AH := $01;               { which turns cursor off           }
   Regs.CH := $20;
   Intr($10,DOS.Registers(Regs));
END;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

FUNCTION KUCase(S:String):String;
VAR
   I: integer;
BEGIN
   FOR I := 1 TO Length(S) DO S[I] := UpCase(S[I]);
   KUCase := S;
END;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

FUNCTION KLCase(S:String):String;
VAR
   I: integer;
BEGIN
   FOR I := 1 TO Length(S) DO
      IF S[I] IN['A'..'Z'] THEN   {If character is A-Z }
         S[I]:=CHR(ORD(S[I])+$20);{Add HEX 20 ordinal value for lowercase}
   KLCase := S;
END;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

FUNCTION Color(FG,BG:Colors):Byte;
BEGIN
   Color := (FG+(BG SHL 4)) MOD 128;{shift BG 4 places left(nibble) and add FG}
END;                                {MOD 128 removes the blink}
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

PROCEDURE KAttr(Row,Col,Rows,Cols:Integer;Attr:Byte);
VAR
    Ch,X,Y,R,C:Integer;
    Regs:Registers;
BEGIN
   R:=(Row+(Rows-1));
   C:=(Col+(Cols-1));
   REPEAT
      X:=Col;
         REPEAT
               GOTOxy(x,Row);              {BIOS call to read screen character}
               Regs.AH:=$08;               {and attribute                     }
               Regs.BH:=ActiveDP;          {Specify active page}
               Intr($10,DOS.Registers(Regs));

               { Regs.AL contains the character read with service 8.}

               Regs.AH:=$09;             {BIOS call to write Character and}
                                         {attribute to screen}
               Regs.BH:=ActiveDP;        {Specify active page}
               Regs.BL:=Attr;            {Specify attribute }
               Regs.CX:=$01;             {write it once }
               Intr($10,DOS.Registers(Regs));
               X:=X+1;                   {INC X i.e col position}
         UNTIL X>C;
      Row:=Row+1;                        {INC Row i.e. Row position}
   UNTIL Row > R;
END;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

PROCEDURE KFill(Row,Col,Rows,Cols:Integer;Ch:Char;Attr:Byte);
VAR
    R:Integer;
    Regs:Registers;

(**)

BEGIN
   R:=(Row+(Rows-1));
   REPEAT
      GOTOxy(col,Row);
      Regs.AH:=$09;
      Regs.AL:=ORD(Ch);
      Regs.BH:=ActiveDP;
      Regs.BL:=Attr;
      Regs.CX:=cols;
      Intr($10,DOS.Registers(Regs));
      Row:=Row+1;
   UNTIL Row > R;
END;

(*

 {If you don't want to use the Bios calls, comment them out and open this
  section up and recompile. NOTE: BIOS is slower than write if DirectVideo is
  set to true, however by placing the number of cols to fill in the repeating
  register CX the difference is only slightly noticable.}

    S : String;
    SavedTextAttr:Integer;

BEGIN
   S:='';
   FOR X := 1 to Cols DO
      S:=S+Ch;
   R:=(Row+(Rows-1));
   SavedTextAttr:=CRT.TextAttr;
   CRT.TextAttr:=Attr;
   REPEAT
         GOTOxy(Col,Row);
         Write(s);
         Row:=Row+1;
   UNTIL Row > R;
   CRT.TextAttr:=SavedTextAttr
END;
*)
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

PROCEDURE KTrim(VAR s : string);
VAR
    x,b,e : Integer;
BEGIN
    For X := 1 to LENGTH(s) DO
       IF s[1]=' ' THEN DELETE(S,1,1); {delete leading spaces}

    {This may look wrong to check the entire string, but we look at }
    {S[ 1 ] each time and delete blanks at same until a character appears]
    {From that point on S[1] stays the first character we skipped;}
    {This would work as well
                              REPEAT
                                 IF s[1] = ' ' THEN DELETE(S,1,1);
                              UNTIL s[1] <> ' ';

     and on lengthy strings would be faster.  }

    b:=1;
    e:=LENGTH(s);
    For X := e DOWNTO b DO
       BEGIN
         IF s[e]=' ' THEN DELETE(S,e,1) {delete trailing spaces}
         ELSE EXIT;  {As mentioned above but this time we'll exit when we}
                     {see our first character (NON BLANK)}
       END;
END;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

(*
   The following procedures are straight forward enough and no BIOS is used
   in the code.   TEXTATTR is assigned in the CRT unit and referrenced as
   CRT.TextAttr.  This holds the attribute of the current video page and not
   necessarily a certain character pos. Thus we save it and change it before
   we write to the screen with our string.  Then we put it back the way we
   found it. Centering Text is simply taking the LineWidth minus the length
   of the string divided by 2, which gives us the starting column for our
   gotoxy(?,Row) statement.
*)

PROCEDURE KWrite(Row,Col:Integer;Attr:Byte;S:String);
VAR                             {S is actual 'Hello World' or variable }
    SavedTextAttr:Integer;      {VarParm := 'Hello World' }
BEGIN
    SavedTextAttr:=CRT.TextAttr;
    CRT.TextAttr:=Attr;
    GotoXY(Col,Row);
    Write(s);
    CRT.TextAttr:=SavedTextAttr
END;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

PROCEDURE KWriteV(Row,Col:Integer;Attr:Byte;VAR S:String);
VAR                           {S must be a variable, only the address is passed}
    SavedTextAttr:Integer;    {to save space on the stack}
BEGIN
    SavedTextAttr:=CRT.TextAttr;    {Save current page text attribute}
    CRT.TextAttr:=Attr;             {Assign our attribute value}
    GotoXY(Col,Row);                {Move cursor to our strating Pos.}
    Write(s);                       {Write our string and attribute}
    CRT.TextAttr:=SavedTextAttr;     {Restore original text attribute}

    {We want to restore the original so that TURBO's write & writeln will
     function with a specified global attribute in CRT.TextAttr and we can
     still write our own with no interference}
END;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

PROCEDURE KWriteC(Row:Integer;Attr:Byte;S:String);
VAR
    X,SavedTextAttr:Integer;
BEGIN
    SavedTextAttr:=CRT.TextAttr;
    CRT.TextAttr:=Attr;
    X:=(LineWidth-Length(S)) DIV 2; {get cursor pos to write string centered}
    GotoXY(X,Row);
    Write(s);
    CRT.TextAttr:=SavedTextAttr
END;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

PROCEDURE KWriteCV(Row:Integer;Attr:Byte;VAR S:String);
VAR
    X,SavedTextAttr:Integer;
BEGIN
    SavedTextAttr:=CRT.TextAttr;
    CRT.TextAttr:=Attr;
    X:=(LineWidth-Length(S)) DIV 2;
    GotoXY(X,Row);
    Write(s);
    CRT.TextAttr:=SavedTextAttr
END;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)

(*
   This is done to initialize the ActiveDp and LineWidth variables when the
   program is first run.  The VideoMode variable may also be used along with
   ActiveDP & LineWidth.
*)

BEGIN
   VideoMode := CurrentVideoMode;
END.

(******************************************************************************
Additions & Revisions

{010188}
Changed KFill : placed number of cols to fill in CX versa advancing cursor and
writing one position per call to BIOS. I originally thought this would show how
to use the bios calls to write to different x/y positions, however it was just
to slow to be truly useful.  The current code shows the use of the bios call
plus the use of the CX register in this type of bios function.

Added Function : KUCase,KLCase & Color.

******************************************************************************)