C!T ROM 2/ctrom_ii_b.zip/ctrom_ii_b/PROGRAM/PASCAL/EDITWIN/MINIKIT.PAS

Pascal/Delphi Source File | 1992-07-01 | 19KB | 649 lines

{==============================================================}
{                                                              }
{             Saved as: MINIKIT.PAS                            }
{               Author: Pat Anderson                           }
{        Last modified: Friday, June 30, 1992                  }
{              Purpose: Mini tool kit for keyboard input,      }
{                       string functions, color settings,      }
{                       cursor control, fast screen writes     }
{                       and simple windows                     }
{                                                              }
{==============================================================}


unit MiniKit;


{==============================================================}
                        INTERFACE
{==============================================================}

uses
  Crt,
  Dos;

type
  proc = procedure;
  PCursorRec = ^TCursorShape;
  TCursorShape = record
    Start : byte;
    Stop  : byte;
  end;

  TWindowCoords = record
    LeftX, TopY, RightX, BottomY : byte;
  end;

  PSavedScreenInfo = ^TSavedScreenInfo;
  TSavedScreenInfo = record
    SavedScreenBuffer : pointer;
    WindowCoords : TWindowCoords;
    CursorX : byte;
    CursorY : byte;
    CursorShape : TCursorShape;
    ScreenAttr : byte;
  end;

{$I KEYDEFS.INC}

var
  IsMono : boolean;                   { TRUE for mono, FALSE for color }

  { Some useful screen stuff }
  BaseOfScreen : word;                { $B000 for mono, $B800 for color }
  MonoScreen   : byte absolute $B000:$0000;
  ColorScreen  : byte absolute $B800:$0000;
  ScreenBuffer : pointer;             { points to MonoScreen or ColorScreen }

  LinesOnScreen : byte;

  In_DV : boolean;                    { TRUE if Desqview detected }

  { variables for text attributes for various standard categories }
  TextFore,                           { See SetColors for defaults }
  TextBack,
  Text_Attr,
  EditFore,
  EditBack,
  Edit_Attr,
  StatusFore,
  StatusBack,
  Status_Attr,
  PopFore,
  PopBack,
  Pop_Attr     : byte;

  WindowsOpen  : byte;                { How many times PopWindow called }

procedure DoNothing;
{ Call as argument to GetKey if no other DoWhileIdle procedure }

function GetKey (DoWhileIdle : proc) : char;
{ Returns a single char for normal and extended ASCII keys }
{ Repeatedly calls DoWhileIdle procedure while waiting for key press }

function Pad (S : string; PadLength : byte) : string;
{ Pad string S with spaces to length PadLength }

function Strip (S : string) : string;
{ Strip trailing blanks from string S }

function ToUpper (S : string) : string;
{ Rich Sadowsky's Public Domain UpperCase routine }

function LeftStr (S : string; NumChars : byte) : string;
{ Returns string containing left most NumChars part of string S }

function RightStr (S : string; NumChars : byte) : string;
{ Returns string containing right most NumChars part of string S }

function MakeString (StrLength : byte;  StrChar : char) : string;
{ Returns a string of StrChars of length StrLength }

function Merge (SubStr : string; S : string; Position : byte) : string;
{ merge substring into string at specified position }

function Form (number : longint) : string;
{ longint number returned as string formatted with commas }
{ format integer by casting to longint }

procedure Pause;
{ Waits until a key is pressed }

procedure GetCursorShape (var Shape : TCursorShape);
{ Sets the Start and Stop fields of Shape }

procedure CursorOff;
{ Turns the cursor off }

procedure NormCursorOn;
{ Turns underscore cursor on }

procedure BlockCursorOn;
{ Turns block cursor on }

procedure SetCursorShape (Shape : TCursorShape);
{ Set cursor shape with Start and Stop fields of Shape }

function MakeAttrByte (text_fore, text_back : byte) : byte;
{ Return single attribute byte for specified
  foreground and background combination }

procedure DrawBox (LeftX, TopY, RightX, BottomY,
                   ColorAttr : byte);
{ Draws a single line box }

procedure GetWindowCoords (var WindowCoords : TWindowCoords);
{ Save current window coordinates as reported by WinMin and WinMax }

procedure SetWindowCoords (WindowCoords : TWindowCoords);
{ Call the Window procedure with new coordinates }

function SaveScreen (var SavedScreen : TSavedScreenInfo) : boolean;
{ Save screen contents to heap - returns success = true, failure = false }

procedure RestoreScreen (var SavedScreen : TSavedScreenInfo);
{ Restores saved screen from heap to physical screen }

procedure PopWindow (LeftX, TopY, RightX, BottomY,
                     ColorAttr : byte; var SavedScreen : TSavedScreenInfo);
{ Pops up a framed window at specified screen coordinates }

procedure CloseWindow (var SavedScreen : TSavedScreenInfo);
{ procedure to close an open window }

function DirExists (DirName : string) : boolean;
{ TUG PD function to determine whether a specified directory exists }

function FileExists (FileName : string) : boolean;
{ TUG PD function to determine if a specified file already exists }

procedure FastWrite (Strng : string; Row, Col, Attr : byte);
{ Brian Foley's Public Domain FastWrite routine }

procedure BlockAttr (X1, Y1, X2, Y2 : word; Attr : byte);
{ Change color attributes in defined screen area without
  altering text characters - From IPE by Bill Swenson/Allen Drennan }

{==============================================================}
                        IMPLEMENTATION
{==============================================================}

var
  OriginalExit : pointer;             { Original TP exit procedure }
  OriginalMode : word;                { Video mode on startup }
  OriginalAttr : byte;                { Text attribute on startup }
  OriginalCursorShape : TCursorShape;
  SaveX,
  SaveY,
  SaveAttr           : byte;
  WindowOpen         : boolean;
  F                  : file;
  FileAttr           : word;

procedure DoNothing;
  begin
  end;

function GetKey (DoWhileIdle : proc) : char;
  var
    key : char;
  begin
    while not KeyPressed do
      DoWhileIdle;
    key := ReadKey;
    {Handle extended ASCII codes}
    if (key = #0) AND KeyPressed then
      key := Chr (Ord(ReadKey) OR $80);
      { $80 = 1000 0000 binary, turns on high bit }
    GetKey := key;
  end;

function Pad (S : string; PadLength : byte) : string;
  begin
    while Length (S) < PadLength do
      S := S + ' ';
    Pad := S;
  end;

function Strip (S : string) : string;
  begin
    while S[Length (S)] = ' ' do
      S := Copy (S, 1, (Length (S) - 1));
    Strip := S;
    end;

function ToUpper (S : String) : string; assembler;
  asm
       PUSH      DS
       LDS       SI,DWORD PTR [S]
       LES       DI,@Result;
       CLD
       LODSB
       STOSB
       MOV       CL,AL
       XOR       CH,CH
       JCXZ      @ExitCode
  @LowerLoop:
       LODSB
       CMP       AL,'a'
       JB        @CopyChar
       CMP       AL,'z'
       JA        @CopyChar
       SUB       AL,'a'-'A'
  @CopyChar:
       STOSB
       LOOP      @LowerLoop
  @ExitCode:
       POP       DS
end;

function LeftStr (S : string; NumChars : byte) : string;
  begin
    if NumChars = 0 then
      LeftStr := ''
    else
      LeftStr := Copy (S, 1, NumChars);
  end;

function RightStr (S : string; NumChars : byte) : string;
  begin
    if NumChars = 0 then
      RightStr := ''
    else if NumChars < Ord (S[0]) then
      RightStr := Copy (S, Ord (S[0]) - NumChars + 1, NumChars)
    else if NumChars >= Ord (S[0]) then
      RightStr := S;
  end;

function MakeString (StrLength : byte;  StrChar : char) : string;
  var
    TempStr : string;
  begin
    FillChar (TempStr[1], word (StrLength), StrChar);
    TempStr[0] := char (StrLength);
    MakeString := TempStr;
  end;

function Merge (SubStr : string; S : string; Position : byte) : string;
  begin
    Move (SubStr[1], S[Position], Ord (SubStr[0]));
    Merge := S;
  end;

function Form (number : longint) : string;
  var
    TempStr : string;
    OrgLen : byte;
  begin
    Str (number, tempstr);
    OrgLen := Length (tempstr);
    if OrgLen > 3 then
      begin
        if OrgLen < 7 then
          Insert (',', tempstr, Length (tempstr) - 2);
        if OrgLen >= 7 then
          begin
            Insert (',', tempstr, length (tempstr) - 5);
            Insert (',', tempstr, length (tempstr) - 2);
          end;
      end;
    Form := tempstr;
  end;

procedure Pause;
  var
    dummy : char;
  begin
    dummy := GetKey (DoNothing)
  end;

procedure GetCursorShape (var Shape : TCursorShape); assembler;
  asm
    mov ah,$03
    mov bx,$00
    int $10
    les di,Shape
    mov TCursorShape (es:[di]).Start,ch    {es:[di] is Start field of Shape}
    mov TCursorShape (es:[di]).Stop,cl  {es:[di+1] is Stop field of Shape}
  end;

procedure SetCursorShape; assembler;
  asm
    mov ah,$01             { Service 1, set cursor size }
    mov ch,Shape.Start
    mov cl,Shape.Stop
    int $10
  end;

procedure CursorOff;  assembler;
  asm
    mov ah,$01
    mov ch,$20
    mov cl,$00
    int $10
  end;

procedure NormCursorOn;
  var
    Shape : TCursorShape;
  begin
    if IsMono then
      begin
        Shape.Start := $0A;
        Shape.Stop := $0B;
      end
    else
      begin
        Shape.Start := $06;
        Shape.Stop := $07;
      end;
    SetCursorShape (Shape);
  end;

procedure BlockCursorOn;
  var
    Shape : TCursorShape;
  begin
    if IsMono then
      begin
        Shape.Start := $02;
        Shape.Stop := $0B;
      end
    else
      begin
        Shape.Start := $02;
        Shape.Stop := $08;
      end;
    SetCursorShape (Shape);
  end;

function MakeAttrByte;
  begin
    MakeAttrByte := (text_back * 16) + text_fore;
  end;

procedure DrawBox;
  const
    TopLeftChar        = #213;
    TopRightChar       = #184;
    BottomLeftChar     = #212;
    BottomRightChar    = #190;
    HorizontalLineChar = #205;
    VerticalLineChar   = #179;
  var
    column,
    row : byte;
  begin
    {Draw corners}
    FastWrite (TopLeftChar, TopY, LeftX, ColorAttr);
    FastWrite (BottomLeftChar, BottomY, LeftX, ColorAttr);
    FastWrite (TopRightChar, TopY, RightX, ColorAttr);
    FastWrite (BottomRightChar, BottomY, RightX, ColorAttr);
    {Draw horizontal lines}
    for column := LeftX + 1 TO RightX - 1 do
      begin
        FastWrite (HorizontalLineChar, TopY, column, ColorAttr);
        FastWrite (HorizontalLineChar, BottomY, column, ColorAttr);
      end;

    {Draw vertical lines}
    for row := TopY + 1 TO BottomY - 1 do
      begin
        FastWrite (VerticalLineChar, Row, LeftX, ColorAttr);
        FastWrite (VerticalLineChar, Row, RightX, ColorAttr);
      end;
end; {of procedure DrawBox}

procedure GetWindowCoords (var WindowCoords : TWindowCoords);
  begin
    with WindowCoords do begin
      LeftX := Succ (Lo (WindMin));
      TopY  := Succ (Hi (WindMin));
      RightX := Succ (Lo (WindMax));
      BottomY := Succ (Hi (WindMax));
    end;
  end;

procedure SetWindowCoords (WindowCoords : TWindowCoords);
  begin
    with WindowCoords do
      Window (LeftX, TopY, RightX, BottomY);
  end;

function SaveScreen (var SavedScreen : TSavedScreenInfo) : boolean;
  var OK : boolean;
  begin
    SaveScreen := true;
    OK := true;
    if not MaxAvail > 4000 then begin
      SaveScreen := false;
      OK := false;
    end;
    if SavedScreen.SavedScreenBuffer <> nil then begin
      SaveScreen := false;
      OK := false;
    end;
    if OK then
      with SavedScreen do begin
        GetMem (SavedScreenBuffer, 4000);
        Move (ScreenBuffer^, SavedScreenBuffer^, 4000);
        GetWindowCoords (WindowCoords);
        CursorX := WhereX;
        CursorY := WhereY;
        GetCursorShape (CursorShape);
        ScreenAttr := TextAttr;
      end;
  end;

procedure RestoreScreen (var SavedScreen : TSavedScreenInfo);
  begin
    with SavedScreen do begin
      Move (SavedScreenBuffer^, ScreenBuffer^, 4000);
      FreeMem (SavedScreenBuffer, 4000);
      SavedScreenBuffer := nil;
      SetWindowCoords (WindowCoords);
      GotoXY (CursorX, CursorY);
      SetCursorShape (CursorShape);
      TextAttr := ScreenAttr;
    end;
  end;

procedure PopWindow;
  var
    OK : boolean;
  begin
    OK := SaveScreen (SavedScreen);
    DrawBox (LeftX, TopY, RightX, BottomY, ColorAttr);
    TextAttr := ColorAttr;
    Window (LeftX + 1, TopY + 1, RightX - 1, BottomY - 1);
    ClrScr;
    Inc (WindowsOpen);
  end; {procedure PopWindow}

procedure CloseWindow;
  begin
    if not WindowOpen then
      Exit;
    Window (1,1,80,25);
    RestoreScreen (SavedScreen);
    WindowOpen := FALSE;
    TextAttr := SaveAttr;
    Dec (WindowsOpen);
  end; {of procedure CloseWindow}

function DirExists;
  begin
    Assign (F,DirName);
    GetFAttr (F, FileAttr);
    DirExists := (FileAttr AND Directory) <> 0
  end; {DirExists}

function FileExists;
  begin
    Assign (F, FileName);
    GetFAttr (F, FileAttr);
    FileExists := (FileAttr <> 0) AND ((FileAttr AND Directory) = 0)
  end; { FileExists }

procedure  FastWrite(Strng : String; Row, Col, Attr : Byte); assembler;
  asm
      PUSH    DS                     { ;Save DS }
      MOV     CH,Row                 { ;CH = Row }
      MOV     BL,Col                 { ;BL = Column }

      XOR     AX,AX                  { ;AX = 0 }
      MOV     CL,AL                  { ;CL = 0 }
      MOV     BH,AL                  { ;BH = 0 }
      DEC     CH                     { ;Row (in CH) to 0..24 range }
      SHR     CX,1                   { ;CX = Row * 128 }
      MOV     DI,CX                  { ;Store in DI }
      SHR     DI,1                   { ;DI = Row * 64 }
      SHR     DI,1                   { ;DI = Row * 32 }
      ADD     DI,CX                  { ;DI = (Row * 160) }
      DEC     BX                     { ;Col (in BX) to 0..79 range }
      SHL     BX,1                   { ;Account for attribute bytes }
      ADD     DI,BX                  { ;DI = (Row * 160) + (Col * 2) }
      MOV     ES,BaseOfScreen        { ;ES:DI points to BaseOfScreen:Row,Col }

      LDS     SI,DWORD PTR [Strng]   { ;DS:SI points to St[0] }
      CLD                            { ;Set direction to forward }
      LODSB                          { ;AX = Length(St); DS:SI -> St[1] }
      XCHG    AX,CX                  { ;CX = Length; AL = WaitForRetrace }
      JCXZ    @FWExit                { ;If string empty, exit }
      MOV     AH,Attr                { ;AH = Attribute }
    @FWDisplay:
      LODSB                          { ;Load next character into AL }
                                     { ; AH already has Attr }
      STOSW                          { ;Move video word into place }
      LOOP    @FWDisplay             { ;Get next character }
    @FWExit:
      POP     DS                     { ;Restore DS }
  end; {asm block}

procedure BlockAttr (X1, Y1, X2, Y2 : word; Attr : byte);
  var UpperLeft, LowerRight : word;
  begin
    UpperLeft := Pred (X1) * 2 + 160 * Pred (Y1) + 1;
    LowerRight := Pred (X2) * 2 + 160 * Pred (Y2) + 1;
    asm
      CLD
      MOV     AX,BaseOfScreen
      MOV     ES,AX
      MOV     DI,UpperLeft
      MOV     AL, Attr
      MOV     DX,X2
      SUB     DX,X1
      INC     DX
@X23: MOV     CX,DX
@X25: STOSB
      INC     DI
      LOOP    @X25
      SUB     DI,DX
      SUB     DI,DX
      ADD     DI,$00A0
      CMP     DI,LowerRight
      JLE     @X23
    end;
  end;

procedure SetColors;
  begin
    if IsMono then
      begin
        TextFore := lightgray;
        TextBack := black;
        EditFore := white;
        EditBack := black;
        PopFore  := black;
        PopBack  := lightgray;
        PopBack  := lightgray;
        StatusFore := black;
        StatusBack := lightgray;
      end
    else
      begin
        TextFore := lightgray;
        TextBack := blue;
        EditFore := white;
        EditBack := blue;
        PopFore  := blue;
        PopBack  := lightgray;
        StatusFore := yellow;
        StatusBack := red;
      end;
    Text_Attr   := MakeAttrByte (TextFore, TextBack);
    Edit_Attr   := MakeAttrByte (EditFore, EditBack);
    Pop_Attr    := MakeAttrByte (PopFore, PopBack);
    Status_Attr := MakeAttrByte (StatusFore, StatusBack);
  end; {of procedure SetColors}

procedure GetAlternateBuffer; assembler;
  asm
    mov ah,$fe
    int $10
    mov BaseOfScreen,es
  end;

procedure CheckForDesqview; assembler;
  asm
    mov In_DV,false
    mov cx,'DE'
    mov dx,'SQ'
    mov ax,$2B01
    int $21
    cmp al,$ff
    je @No_Desqview
    mov In_DV,true
  @No_Desqview:
  end;

procedure GetAdaptorType;
  begin
    if LastMode = 7 then
      IsMono := true
    else
      IsMono := false;
  end;

procedure PoliteExit; far;
  begin
    ExitProc := OriginalExit;             {Put TP's ExitProc back in chain}
    if LastMode <> OriginalMode then      {If the text mode has changed }
      TextMode (OriginalMode);            {  restore video mode}
    TextAttr := OriginalAttr;             { Restore text attribute }
    SetCursorShape (OriginalCursorShape); {restore cursor shape}
    NormVideo;                            {restore text attributes}
  end;

procedure InstallPoliteExit;
  begin
    OriginalMode := LastMode;             { save startup video mode }
    OriginalAttr := TextAttr;             { save startup text attribute }
    GetCursorShape (OriginalCursorShape); { save startup cursor shape }

    OriginalExit := ExitProc;             {Save TP's ExitProc}
    ExitProc := @PoliteExit;              {Put PoliteExit in chain}
  end;

{ Unit initialization }
begin
  InstallPoliteExit;                    { restore video mode & cursor on exit }
  GetAdaptorType;                       { color or mono }
  CheckForDesqview;                     { initialize In_DV variable }
  LinesOnScreen := Hi (WindMax) + 1;    { WindMax is 0 based }
  SetColors;                            { default text, edit, status }
                                        {   & pop attributes }
  if IsMono then                        { define screen location }
    begin
      ScreenBuffer := @MonoScreen;  { a pointer }
      BaseOfScreen := $B000;          { segment address as a word value }
    end
  else
    begin
      ScreenBuffer := @ColorScreen;
      BaseOfScreen := $B800;
    end;
  WindowsOpen := 0;
end.