OS/2 Shareware BBS: 10 Tools/10-Tools.zip/vp21beta.zip/ARTLSRC.RAR/CRT.PAS

Pascal/Delphi Source File | 2000-08-15 | 13KB | 561 lines

//█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█
//█                                                       █
//█      Virtual Pascal Runtime Library.  Version 2.1.    █
//█      CRT Interface unit for OS/2 & Win32              █
//█      ─────────────────────────────────────────────────█
//█      Copyright (C) 1995-2000 vpascal.com              █
//█                                                       █
//▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀

{$S-,R-,Q-,I-,X+,T-,Cdecl-,OrgName-,AlignRec-,Use32+}

unit Crt;

interface

const

{ CRT modes }

  BW40          = 0;            { 40x25 B/W on Color Adapter   }
  CO40          = 1;            { 40x25 Color on Color Adapter }
  BW80          = 2;            { 80x25 B/W on Color Adapter   }
  CO80          = 3;            { 80x25 Color on Color Adapter }
  Mono          = 7;            { 80x25 on Monochrome Adapter  }
  Font8x8       = 256;          { Add-in for 8x8 font          }

  MON1          = $FE;          { Monochrome, ASCII chars only }
  MON2          = $FD;          { Monochrome, graphics chars   }
  COL1          = $FC;          { Color, ASCII chars only      }
  COL2          = $FB;          { Color, graphics chars        }

{ Foreground and background color constants }

  Black         = 0;
  Blue          = 1;
  Green         = 2;
  Cyan          = 3;
  Red           = 4;
  Magenta       = 5;
  Brown         = 6;
  LightGray     = 7;

{ Foreground color constants }

  DarkGray      = 8;
  LightBlue     = 9;
  LightGreen    = 10;
  LightCyan     = 11;
  LightRed      = 12;
  LightMagenta  = 13;
  Yellow        = 14;
  White         = 15;

{ Add-in for blinking }

  Blink         = 128;

{ Interface variables }

const
  CheckBreak: Boolean = True;   { Enable Ctrl-Break      }
  CheckEOF: Boolean = False;    { Allow Ctrl-Z for EOF?  }
  TextAttr: Byte = LightGray;   { Current text attribute }

var
  LastMode: Word;               { Current text mode }
  WindMin: Word;                { Window upper left coordinates }
  WindMax: Word;                { Window lower right coordinates }

{ The following interface variables are not used (for compatibility only) }

const
  DirectVideo: Boolean = False; { Enable direct video addressing }
  CheckSnow: Boolean = True;    { Enable snow filtering }

{ Interface procedures }

procedure AssignCrt(var F: Text);
function KeyPressed: Boolean;
function ReadKey: Char;
procedure TextMode(Mode: Integer);
procedure Window(X1,Y1,X2,Y2: Byte);
procedure GotoXY(X,Y: Byte);
function WhereX: Byte;
function WhereY: Byte;
procedure ClrScr;
procedure ClrEol;
procedure InsLine;
procedure DelLine;
procedure TextColor(Color: Byte);
procedure TextBackground(Color: Byte);
procedure LowVideo;
procedure HighVideo;
procedure NormVideo;
procedure Delay(MS: Longint);

{ The following procedures are not implemented

procedure Sound(Hz: Word);
procedure NoSound;

use new procedure PlaySound instead

}
{$IFDEF DPMI32}
procedure Sound(Hz: Word);
procedure NoSound;
{$ENDIF}

procedure PlaySound(Freq,Duration: Longint);

implementation

uses Dos, vpsyslow;

{ Private variables }

var
  NormAttr: Byte;
  DelayCount: Longint;
  PrevXcptProc: Pointer;
  ScreenSize: tSysPoint;

{ Determines if a key has been pressed on the keyboard and returns True }
{ if a key has been pressed                                             }

function KeyPressed: Boolean;
begin
  KeyPressed := SysKeyPressed;
end;

{ Reads a character from the keyboard and returns a character or an     }
{ extended scan code.                                                   }

function ReadKey: Char;
begin
  ReadKey := SysReadKey;
end;

{ Reads normal character attribute }

procedure ReadNormAttr;
begin
  NormAttr := SysReadAttributesAt(WhereX-1, WhereY-1);
  NormVideo;
end;

{ Setups window coordinates }

procedure SetWindowPos;
begin
  WindMin := 0;
  WindMax := ScreenSize.x - 1 + (ScreenSize.y - 1) shl 8;
end;

{ Stores current video mode in LastMode }

procedure GetLastMode;
begin
  LastMode := SysTvGetScrMode( @ScreenSize );
end;

{ Selects a specific text mode. The valid text modes are:               }
{   BW40: 40x25 Black and white                                         }
{   CO40  40x25 Color                                                   }
{   BW80  80x25 Black and white                                         }
{   CO80  80x25 Color                                                   }
{   Mono  80x25 Black and white                                         }
{   Font8x8 (Add-in) 43-/50-line mode                                   }

procedure TextMode(Mode: Integer);
begin
  TextAttr := LightGray;
  SysTvSetScrMode( Mode );
  GetLastMode;
  NormVideo;
  SetWindowPos;
  ClrScr;
end;

{ Defines a text window on the screen.                                  }

procedure Window(X1,Y1,X2,Y2: Byte);
begin
  if (X1 <= X2) and (Y1 <= Y2) then
  begin
    Dec(X1);
    Dec(Y1);
    if (X1 >= 0) and (Y1 >= 0) then
    begin
      Dec(X2);
      Dec(Y2);
      if (X2 < ScreenSize.x) and (Y2 < ScreenSize.y) then
      begin
        WindMin := X1 + Y1 shl 8;
        WindMax := X2 + Y2 shl 8;
        GotoXY(1,1);
      end;
    end;
  end;
end;

{ Moves the cursor to the given coordinates within the screen.          }

procedure GotoXY(X,Y: Byte);
var
  X1,Y1: Word;
begin
  if (X > 0) and (Y > 0) then
  begin
    X1 := X - 1 + Lo(WindMin);
    Y1 := Y - 1 + Hi(WindMin);
    if (X1 <= Lo(WindMax)) and (Y1 <= Hi(WindMax)) then
      SysTVSetCurPos( X1, Y1 );
  end;
end;

{ Returns the X coordinate of the current cursor location.              }

function WhereX: Byte;
var
  X,Y: SmallWord;
begin
  SysGetCurPos(X, Y);
  WhereX := X - Lo(WindMin) + 1;
end;

{ Returns the Y coordinate of the current cursor location.              }

function WhereY: Byte;
var
  X,Y: SmallWord;
begin
  SysGetCurPos(X,Y);
  WhereY := Y - Hi(WindMin) + 1;
end;

{ Clears the screen and returns the cursor to the upper-left corner.    }

procedure ClrScr;
begin
  SysScrollUp( Lo(WindMin), Hi(WindMin), Lo(WindMax), Hi(WindMax), Hi(WindMax)-Hi(WindMin)+1, Ord( ' ' ) + TextAttr shl 8 );
  GotoXY(1,1);
end;

{ Clears all characters from the cursor position to the end of the line }
{ without moving the cursor.                                            }

procedure ClrEol;
var
  X,Y, Len: SmallWord;
  Buffer: Array[0..255] of char;
begin
  SysGetCurPos(X, Y);
  Len := succ(Lo(WindMax)-X);
  fillchar(Buffer, Len, ' ');
  SysWrtCharStrAtt(@Buffer, Len, X, Y, TextAttr);
end;

{ Inserts an empty line at the cursor position.                         }

procedure InsLine;
var
  Cell,X,Y: SmallWord;
begin
  Cell := Ord(' ') + TextAttr shl 8;
  SysGetCurPos(X,Y);
  SysScrollDn(Lo(WindMin),Y,Lo(WindMax),Hi(WindMax),1,Cell);
end;

{ Deletes the line containing the cursor.                               }

procedure DelLine;
var
  Cell,X,Y: SmallWord;
begin
  Cell := Ord(' ') + TextAttr shl 8;
  SysGetCurPos(X,Y);
  SysScrollUp(Lo(WindMin),Y,Lo(WindMax),Hi(WindMax),1,Cell);
end;

{ Selects the foreground character color.                               }

procedure TextColor(Color: Byte);
begin
  if Color > White then Color := (Color and $0F) or $80;
  TextAttr := (TextAttr and $70) or Color;
end;

{ Selects the background color.                                         }

procedure TextBackground(Color: Byte);
begin
  TextAttr := (TextAttr and $8F) or ((Color and $07) shl 4);
end;

{ Selects low intensity characters.                                     }

procedure LowVideo;
begin
  TextAttr := TextAttr and $F7;
end;

{ Selects normal intensity characters.                                  }

procedure NormVideo;
begin
  TextAttr := NormAttr;
end;

{ Selects high-intensity characters.                                    }

procedure HighVideo;
begin
  TextAttr := TextAttr or $08;
end;

{ Delays a specified number of milliseconds. }

procedure Delay(MS: Longint);
begin
  SysCtrlSleep( MS );
end;

{ Plays sound of a specified frequency and duration.                    }

procedure PlaySound(Freq,Duration: Longint);
begin
  SysBeepEx(Freq, Duration);
end;

{$IFDEF DPMI32}
procedure Sound(Hz: Word);
begin
  SysSound(Hz);
end;

procedure NoSound;
begin
  SysNoSound;
end;
{$ENDIF}

{ Do line feed operation }

procedure LineFeed;
var
  Cell: SmallWord;
begin
  Cell := Ord(' ') + TextAttr shl 8;
  SysScrollUp(Lo(WindMin),Hi(WindMin),Lo(WindMax),Hi(WindMax),1,Cell);
end;

{ Outputs packed string to the CRT device }

type
  PWin32Cell = ^TWin32Cell;
  TWin32Cell = record
    Ch:     SmallWord;
    Attr:   SmallWord;
  end;

procedure WritePackedString(S: PChar; Len: Longint);
var
  Buf: array[1..256] of Char;
  I,BufChars: Integer;
  X,Y:        SmallWord;
  X1,Y1:      Longint;
  C:          Char;

  procedure FlushBuffered;
  begin
    If BufChars > 0 then
    begin
      SysWrtCharStrAtt(@Buf, BufChars, X1, Y1, TextAttr);
      BufChars := 0;
      X1 := X;
      Y1 := Y;
    end;
  end;

begin
  SysGetCurPos(X, Y);
  BufChars := 0;
  X1 := X;
  Y1 := Y;
  for I := 0 to Len - 1 do
  begin
    C := S[I];
    case C of
      ^J:               { Line Feed }
        begin
          FlushBuffered;
          {$IFDEF LINUX}
          X := Lo(WindMin);
          x1 := x;
          {$ENDIF}
          if Y >= Hi(WindMax) then LineFeed else Inc(Y);
          y1 := y;
        end;
      {$IFNDEF LINUX}
      ^M:               { Carriage return }
        begin
          FlushBuffered;
          X := Lo(WindMin);
          x1 := x;
        end;
      {$ENDIF}
      ^H:               { Backspace }
        begin
          FlushBuffered;
          if X > Lo(WindMin) then Dec(X);
          if X1 > Lo(WindMin) then Dec(X1);
        end;
      ^G:               { Bell }
        SysBeep;
      else
        Inc(BufChars);
        Buf[BufChars] := C;
        Inc(X);
        if X > Lo(WindMax) then
        begin
          FlushBuffered;
          X := Lo(WindMin);
          X1 := X;
          Inc(Y);
          if Y > Hi(WindMax) then
          begin
            FlushBuffered;
            LineFeed;
            Y := Hi(WindMax);
          end;
          Y1 := Y;
        end;
    end;
  end;
  FlushBuffered;
  SysTVSetCurPos(X, Y);
end;

{ CRT text file I/O functions }

function CrtRead(var F: Text): Longint;
var
  CurPos: Longint;
  C: Char;
begin
  with TextRec(F) do
  begin
    CurPos := 0;
    repeat
      SysFlushKeyBuf;
      C := ReadKey;
      case C of
        ^H:                     { Backspace }
          if CurPos > 0 then
          begin
            WritePackedString(^H' '^H, 3);
            Dec(CurPos);
          end;
        #27:                    { Escape }
          while CurPos > 0 do
          begin
            WritePackedString(^H' '^H, 3);
            Dec(CurPos);
          end;
        ' '..#255:
          if CurPos < BufSize - 2 then
          begin
            BufPtr^[CurPos] := C;
            Inc(CurPos);
            WritePackedString(@C,1);
          end;
      end; { case }
    until (C = ^M) or (CheckEOF and (C = ^Z));
    BufPtr^[CurPos] := C;
    Inc(CurPos);
    if C = ^M then              { Carriage Return }
    begin
      BufPtr^[CurPos] := ^J;    { Line Feed }
      Inc(CurPos);
      WritePackedString(^M^J,2);
    end;
    BufPos := 0;
    BufEnd := CurPos;
  end;
  CrtRead := 0;                 { I/O result = 0: success }
end;

function CrtWrite(var F: Text): Longint;
begin
  with TextRec(F) do
  begin
    WritePackedString(PChar(BufPtr),BufPos);
    BufPos := 0;
  end;
  CrtWrite := 0;                { I/O result = 0: success }
end;

function CrtReturn(var F: Text): Longint;
begin
  CrtReturn := 0;               { I/O result = 0: success }
end;

function CrtOpen(var F: Text): Longint;
begin
  with TextRec(F) do
  begin
    CloseFunc := @CrtReturn;
    if Mode = fmInput then
    begin
      InOutFunc := @CrtRead;
      FlushFunc := @CrtReturn;
    end
   else
    begin
      Mode := fmOutput;
      InOutFunc := @CrtWrite;
      FlushFunc := @CrtWrite;
    end;
  end;
  CrtOpen := 0;                 { I/O result = 0: success }
end;

{ Associates a text file with CRT device.                               }

procedure AssignCrt(var F: Text);
begin
  with TextRec(F) do
  begin
    Handle := $FFFFFFFF;
    Mode := fmClosed;
    BufSize := SizeOf(Buffer);
    BufPtr := @Buffer;
    OpenFunc := @CrtOpen;
    Name[0] := #0;
  end;
end;

{ Signal Handler }

function CrtCtrlBreakHandler: Boolean;
begin
  CrtCtrlBreakHandler := not CheckBreak;
end;

begin
  SysTvInitCursor;
  GetLastMode;
  ReadNormAttr;
  SetWindowPos;
  AssignCrt(Input);  Reset(Input);
  AssignCrt(Output); ReWrite(Output);
  CtrlBreakHandler := CrtCtrlBreakHandler;
  SysCtrlSetCBreakHandler;
  {$IFDEF LINUX}
  SysTvKbdInit;
  {$ENDIF}
end.