mirror of
				https://gitlab.com/freepascal.org/fpc/source.git
				synced 2025-11-04 14:59:37 +01:00 
			
		
		
		
	
		
			
				
	
	
		
			1004 lines
		
	
	
		
			22 KiB
		
	
	
	
		
			ObjectPascal
		
	
	
	
	
	
			
		
		
	
	
			1004 lines
		
	
	
		
			22 KiB
		
	
	
	
		
			ObjectPascal
		
	
	
	
	
	
{
 | 
						|
    $Id$
 | 
						|
 | 
						|
    Borland Pascal 7 Compatible CRT Unit for win32
 | 
						|
 | 
						|
    See the file COPYING.FPC, included in this distribution,
 | 
						|
    for details about the copyright.
 | 
						|
 | 
						|
    This program is distributed in the hope that it will be useful,
 | 
						|
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 | 
						|
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 | 
						|
 | 
						|
 **********************************************************************}
 | 
						|
unit crt;
 | 
						|
 | 
						|
{$mode objfpc}
 | 
						|
 | 
						|
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 ROM font }
 | 
						|
 | 
						|
{ Mode constants for 3.0 compatibility }
 | 
						|
  C40           = CO40;
 | 
						|
  C80           = CO80;
 | 
						|
 | 
						|
{ 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;
 | 
						|
 | 
						|
var
 | 
						|
 | 
						|
{ Interface variables }
 | 
						|
  CheckBreak: Boolean;    { Enable Ctrl-Break }
 | 
						|
  CheckEOF: Boolean;      { Enable Ctrl-Z }
 | 
						|
  DirectVideo: Boolean;   { Enable direct video addressing }
 | 
						|
  CheckSnow: Boolean;     { Enable snow filtering }
 | 
						|
  LastMode: Word;         { Current text mode }
 | 
						|
  TextAttr: Byte;         { Current text attribute }
 | 
						|
  WindMin: Word;          { Window upper left coordinates }
 | 
						|
  WindMax: Word;          { Window lower right coordinates }
 | 
						|
 | 
						|
{ 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: Word);
 | 
						|
procedure Sound(Hz: Word);
 | 
						|
procedure NoSound;
 | 
						|
 | 
						|
{Extra Functions}
 | 
						|
procedure cursoron;
 | 
						|
procedure cursoroff;
 | 
						|
procedure cursorbig;
 | 
						|
 | 
						|
 | 
						|
implementation
 | 
						|
 | 
						|
uses
 | 
						|
  dos,
 | 
						|
  windows;
 | 
						|
 | 
						|
 | 
						|
var
 | 
						|
    OutHandle     : THandle;
 | 
						|
    InputHandle   : THandle;
 | 
						|
 | 
						|
    CursorSaveX   : Longint;
 | 
						|
    CursorSaveY   : Longint;
 | 
						|
 | 
						|
    ScreenWidth   : Longint;
 | 
						|
    ScreenHeight  : Longint;
 | 
						|
    IsWindowsNT   : Boolean;
 | 
						|
 | 
						|
    SaveCursorSize: Longint;
 | 
						|
 | 
						|
 | 
						|
 | 
						|
{
 | 
						|
  definition of textrec is in textrec.inc
 | 
						|
}
 | 
						|
{$i textrec.inc}
 | 
						|
 | 
						|
{****************************************************************************
 | 
						|
                           Low level Routines
 | 
						|
****************************************************************************}
 | 
						|
 | 
						|
function GetPlatformID: Longint;
 | 
						|
var OsVersion: TOSVersionInfo;
 | 
						|
begin
 | 
						|
  OsVersion.dwOsVersionInfoSize := SizeOf(OsVersion);
 | 
						|
 | 
						|
  GetVersionEx(OsVersion);
 | 
						|
 | 
						|
  Result := OsVersion.dwPlatformID;
 | 
						|
end; { func. GetPlatformID }
 | 
						|
 | 
						|
 | 
						|
procedure TurnMouseOff;
 | 
						|
var Mode: DWORD;
 | 
						|
begin
 | 
						|
  if GetConsoleMode(InputHandle, @Mode) then      { Turn the mouse-cursor off }
 | 
						|
    begin
 | 
						|
      Mode := Mode AND NOT enable_processed_input
 | 
						|
                   AND NOT enable_mouse_input;
 | 
						|
 | 
						|
      SetConsoleMode(InputHandle, Mode);
 | 
						|
    end; { if }
 | 
						|
end; { proc. TurnMouseOff }
 | 
						|
 | 
						|
 | 
						|
function GetScreenHeight : longint;
 | 
						|
var ConsoleInfo: TConsoleScreenBufferinfo;
 | 
						|
begin
 | 
						|
  GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
 | 
						|
  Result := ConsoleInfo.dwSize.Y;
 | 
						|
end; { func. GetScreenHeight }
 | 
						|
 | 
						|
 | 
						|
function GetScreenWidth : longint;
 | 
						|
var ConsoleInfo: TConsoleScreenBufferInfo;
 | 
						|
begin
 | 
						|
  GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
 | 
						|
  Result := ConsoleInfo.dwSize.X;
 | 
						|
end; { func. GetScreenWidth }
 | 
						|
 | 
						|
 | 
						|
procedure SetScreenCursor(x,y : longint);
 | 
						|
var CurInfo: TCoord;
 | 
						|
begin
 | 
						|
  FillChar(Curinfo, SizeOf(Curinfo), 0);
 | 
						|
  CurInfo.X := X - 1;
 | 
						|
  CurInfo.Y := Y - 1;
 | 
						|
 | 
						|
  SetConsoleCursorPosition(OutHandle, CurInfo);
 | 
						|
 | 
						|
  CursorSaveX := X - 1;
 | 
						|
  CursorSaveY := Y - 1;
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
procedure GetScreenCursor(var x,y : longint);
 | 
						|
begin
 | 
						|
  X := CursorSaveX + 1;
 | 
						|
  Y := CursorSaveY + 1;
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
{****************************************************************************
 | 
						|
                              Helper Routines
 | 
						|
****************************************************************************}
 | 
						|
 | 
						|
 | 
						|
Function WinMinX: Byte;
 | 
						|
{
 | 
						|
  Current Minimum X coordinate
 | 
						|
}
 | 
						|
Begin
 | 
						|
  WinMinX:=(WindMin and $ff)+1;
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
 | 
						|
Function WinMinY: Byte;
 | 
						|
{
 | 
						|
  Current Minimum Y Coordinate
 | 
						|
}
 | 
						|
Begin
 | 
						|
  WinMinY:=(WindMin shr 8)+1;
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
 | 
						|
Function WinMaxX: Byte;
 | 
						|
{
 | 
						|
  Current Maximum X coordinate
 | 
						|
}
 | 
						|
Begin
 | 
						|
  WinMaxX:=(WindMax and $ff)+1;
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
 | 
						|
Function WinMaxY: Byte;
 | 
						|
{
 | 
						|
  Current Maximum Y coordinate;
 | 
						|
}
 | 
						|
Begin
 | 
						|
  WinMaxY:=(WindMax shr 8) + 1;
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
 | 
						|
Function FullWin:boolean;
 | 
						|
{
 | 
						|
  Full Screen 80x25? Window(1,1,80,25) is used, allows faster routines
 | 
						|
}
 | 
						|
begin
 | 
						|
  FullWin:=(WinMinX=1) and (WinMinY=1) and
 | 
						|
           (WinMaxX=ScreenWidth) and (WinMaxY=ScreenHeight);
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
{****************************************************************************
 | 
						|
                             Public Crt Functions
 | 
						|
****************************************************************************}
 | 
						|
 | 
						|
 | 
						|
procedure textmode(mode : integer);
 | 
						|
begin
 | 
						|
  {!!! Not done yet !!! }
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
Procedure TextColor(Color: Byte);
 | 
						|
{
 | 
						|
  Switch foregroundcolor
 | 
						|
}
 | 
						|
Begin
 | 
						|
  TextAttr:=(Color and $8f) or (TextAttr and $70);
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
 | 
						|
Procedure TextBackground(Color: Byte);
 | 
						|
{
 | 
						|
  Switch backgroundcolor
 | 
						|
}
 | 
						|
Begin
 | 
						|
  TextAttr:=((Color shl 4) and ($f0 and not Blink)) or (TextAttr and ($0f OR Blink) );
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
 | 
						|
Procedure HighVideo;
 | 
						|
{
 | 
						|
  Set highlighted output.
 | 
						|
}
 | 
						|
Begin
 | 
						|
  TextColor(TextAttr Or $08);
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
 | 
						|
Procedure LowVideo;
 | 
						|
{
 | 
						|
  Set normal output
 | 
						|
}
 | 
						|
Begin
 | 
						|
  TextColor(TextAttr And $77);
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
 | 
						|
Procedure NormVideo;
 | 
						|
{
 | 
						|
  Set normal back and foregroundcolors.
 | 
						|
}
 | 
						|
Begin
 | 
						|
  TextColor(7);
 | 
						|
  TextBackGround(0);
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
Procedure GotoXy(X: Byte; Y: Byte);
 | 
						|
{
 | 
						|
  Go to coordinates X,Y in the current window.
 | 
						|
}
 | 
						|
Begin
 | 
						|
  If (X>0) and (X<=WinMaxX- WinMinX+1) and
 | 
						|
     (Y>0) and (Y<=WinMaxY-WinMinY+1) Then
 | 
						|
   Begin
 | 
						|
     Inc(X,WinMinX-1);
 | 
						|
     Inc(Y,WinMinY-1);
 | 
						|
     SetScreenCursor(x,y);
 | 
						|
   End;
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
Procedure Window(X1, Y1, X2, Y2: Byte);
 | 
						|
{
 | 
						|
  Set screen window to the specified coordinates.
 | 
						|
}
 | 
						|
Begin
 | 
						|
  if (X1>X2) or (X2>ScreenWidth) or
 | 
						|
     (Y1>Y2) or (Y2>ScreenHeight) then
 | 
						|
   exit;
 | 
						|
  WindMin:=((Y1-1) Shl 8)+(X1-1);
 | 
						|
  WindMax:=((Y2-1) Shl 8)+(X2-1);
 | 
						|
  GoToXY(1,1);
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
procedure ClrScr;
 | 
						|
var
 | 
						|
  ClipRect: TSmallRect;
 | 
						|
  SrcRect: TSmallRect;
 | 
						|
  DestCoor: TCoord;
 | 
						|
  CharInfo: TCharInfo;
 | 
						|
begin
 | 
						|
  CharInfo.UnicodeChar := 32;
 | 
						|
  CharInfo.Attributes := TextAttr;
 | 
						|
 | 
						|
  SrcRect.Left := WinMinX - 1;
 | 
						|
  SrcRect.Top := WinMinY - 1;
 | 
						|
  SrcRect.Right := WinMaxX - 1;
 | 
						|
  SrcRect.Bottom := WinMaxY - 1;
 | 
						|
  ClipRect := SrcRect;
 | 
						|
 | 
						|
  if IsWindowsNT then
 | 
						|
    begin
 | 
						|
      DestCoor.X := -WinMaxX;
 | 
						|
      DestCoor.Y := -WinMaxY;
 | 
						|
 | 
						|
      ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
 | 
						|
                                DestCoor, CharInfo);
 | 
						|
    end
 | 
						|
      else begin      { Win95 seems to have a bug in scrolling, unfortunately }
 | 
						|
             { This routine 3 times copies the bottom 12 lines to the }
 | 
						|
             { top part of the screen. This eventually will clear the }
 | 
						|
             { screen. }
 | 
						|
 | 
						|
             DestCoor.X := WinMinX - 1;
 | 
						|
             DestCoor.Y := WinMinY - (Succ((WinMaxY - WinMinY) div 2));
 | 
						|
 | 
						|
             {-------- Scroll 1st part }
 | 
						|
             ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
 | 
						|
                                       DestCoor, CharInfo);
 | 
						|
 | 
						|
 | 
						|
             {-------- Scroll 2nd part }
 | 
						|
             ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
 | 
						|
                                       DestCoor, CharInfo);
 | 
						|
 | 
						|
             {-------- Scroll 3rd part (last line) }
 | 
						|
             ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
 | 
						|
                                       DestCoor, CharInfo);
 | 
						|
           end; { if in Windows95 }
 | 
						|
 | 
						|
  GotoXY(1,1);
 | 
						|
end; { proc. ClrScr }
 | 
						|
 | 
						|
 | 
						|
procedure ClrEol;
 | 
						|
{
 | 
						|
  Clear from current position to end of line.
 | 
						|
}
 | 
						|
var Temp: Dword;
 | 
						|
    CharInfo: Char;
 | 
						|
    Coord: TCoord;
 | 
						|
    X,Y: Longint;
 | 
						|
begin
 | 
						|
  GetScreenCursor(x,y);
 | 
						|
 | 
						|
  CharInfo := #32;
 | 
						|
  Coord.X := X - 1;
 | 
						|
  Coord.Y := Y - 1;
 | 
						|
 | 
						|
  FillConsoleOutputCharacter(OutHandle, CharInfo, WinMaxX - (X + 01), Coord, @Temp);
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
 | 
						|
Function WhereX: Byte;
 | 
						|
{
 | 
						|
  Return current X-position of cursor.
 | 
						|
}
 | 
						|
var
 | 
						|
  x,y : longint;
 | 
						|
Begin
 | 
						|
  GetScreenCursor(x,y);
 | 
						|
  WhereX:=x-WinMinX+1;
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
 | 
						|
Function WhereY: Byte;
 | 
						|
{
 | 
						|
  Return current Y-position of cursor.
 | 
						|
}
 | 
						|
var
 | 
						|
  x,y : longint;
 | 
						|
Begin
 | 
						|
  GetScreenCursor(x,y);
 | 
						|
  WhereY:=y-WinMinY+1;
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
{*************************************************************************
 | 
						|
                            KeyBoard
 | 
						|
*************************************************************************}
 | 
						|
 | 
						|
var
 | 
						|
   ScanCode : char;
 | 
						|
   SpecialKey : boolean;
 | 
						|
   DoingNumChars: Boolean;
 | 
						|
   DoingNumCode: Byte;
 | 
						|
 | 
						|
Function RemapScanCode (ScanCode: byte; CtrlKeyState: byte; keycode:longint): byte;
 | 
						|
  { Several remappings of scancodes are necessary to comply with what
 | 
						|
    we get with MSDOS. Special Windows keys, as Alt-Tab, Ctrl-Esc etc.
 | 
						|
    are excluded }
 | 
						|
var
 | 
						|
  AltKey, CtrlKey, ShiftKey: boolean;
 | 
						|
const
 | 
						|
  {
 | 
						|
    Keypad key scancodes:
 | 
						|
 | 
						|
      Ctrl Norm
 | 
						|
 | 
						|
      $77  $47 - Home
 | 
						|
      $8D  $48 - Up arrow
 | 
						|
      $84  $49 - PgUp
 | 
						|
      $8E  $4A - -
 | 
						|
      $73  $4B - Left Arrow
 | 
						|
      $8F  $4C - 5
 | 
						|
      $74  $4D - Right arrow
 | 
						|
      $4E  $4E - +
 | 
						|
      $75  $4F - End
 | 
						|
      $91  $50 - Down arrow
 | 
						|
      $76  $51 - PgDn
 | 
						|
      $92  $52 - Ins
 | 
						|
      $93  $53 - Del
 | 
						|
  }
 | 
						|
  CtrlKeypadKeys: array[$47..$53] of byte =
 | 
						|
    ($77, $8D, $84, $8E, $73, $8F, $74, $4E, $75, $91, $76, $92, $93);
 | 
						|
 | 
						|
begin
 | 
						|
  AltKey := ((CtrlKeyState AND
 | 
						|
            (RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
 | 
						|
  CtrlKey := ((CtrlKeyState AND
 | 
						|
            (RIGHT_CTRL_PRESSED OR LEFT_CTRL_PRESSED)) > 0);
 | 
						|
  ShiftKey := ((CtrlKeyState AND SHIFT_PRESSED) > 0);
 | 
						|
  if AltKey then begin
 | 
						|
    Case KeyCode of
 | 
						|
      VK_NUMPAD0 ..
 | 
						|
      VK_NUMPAD9    : begin
 | 
						|
                       DoingNumChars := true;
 | 
						|
                       DoingNumCode := Byte((DoingNumCode * 10) + (KeyCode - VK_NUMPAD0));
 | 
						|
                      end;
 | 
						|
    end; { case }
 | 
						|
 | 
						|
 | 
						|
    case ScanCode of
 | 
						|
    // Digits, -, =
 | 
						|
    $02..$0D: inc(ScanCode, $76);
 | 
						|
    // Function keys
 | 
						|
    $3B..$44: inc(Scancode, $2D);
 | 
						|
    $57..$58: inc(Scancode, $34);
 | 
						|
    // Extended cursor block keys
 | 
						|
    $47..$49, $4B, $4D, $4F..$53:
 | 
						|
              inc(Scancode, $50);
 | 
						|
    // Other keys
 | 
						|
    $1C:      Scancode := $A6;   // Enter
 | 
						|
    $35:      Scancode := $A4;   // / (keypad and normal!)
 | 
						|
    end
 | 
						|
   end
 | 
						|
  else if CtrlKey then
 | 
						|
    case Scancode of
 | 
						|
    // Tab key
 | 
						|
    $0F:      Scancode := $94;
 | 
						|
    // Function keys
 | 
						|
    $3B..$44: inc(Scancode, $23);
 | 
						|
    $57..$58: inc(Scancode, $32);
 | 
						|
    // Keypad keys
 | 
						|
    $35:      Scancode := $95;   // \
 | 
						|
    $37:      Scancode := $96;   // *
 | 
						|
    $47..$53: Scancode := CtrlKeypadKeys[Scancode];
 | 
						|
    end
 | 
						|
  else if ShiftKey then
 | 
						|
    case Scancode of
 | 
						|
    // Function keys
 | 
						|
    $3B..$44: inc(Scancode, $19);
 | 
						|
    $57..$58: inc(Scancode, $30);
 | 
						|
    end
 | 
						|
  else
 | 
						|
    case Scancode of
 | 
						|
    // Function keys
 | 
						|
    $57..$58: inc(Scancode, $2E); // F11 and F12
 | 
						|
  end;
 | 
						|
  Result := ScanCode;
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
function KeyPressed : boolean;
 | 
						|
var
 | 
						|
  nevents, nread, i: longint;
 | 
						|
  buf : TINPUTRECORD;
 | 
						|
  AltKey: Boolean;
 | 
						|
begin
 | 
						|
  KeyPressed := FALSE;
 | 
						|
  if ScanCode <> #0 then
 | 
						|
    KeyPressed := TRUE
 | 
						|
  else
 | 
						|
   begin
 | 
						|
     nevents:=0;
 | 
						|
     GetNumberOfConsoleInputEvents(TextRec(input).Handle,nevents);
 | 
						|
     For i := 1 to nevents do
 | 
						|
      begin
 | 
						|
        ReadConsoleInputA(TextRec(input).Handle,buf,1,nread);
 | 
						|
        if buf.EventType = KEY_EVENT then
 | 
						|
         if buf.KeyEvent.bKeyDown then
 | 
						|
          begin
 | 
						|
            { Alt key is VK_MENU }
 | 
						|
            { Capslock key is VK_CAPITAL }
 | 
						|
 | 
						|
            AltKey := ((Buf.KeyEvent.dwControlKeyState AND
 | 
						|
                          (RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
 | 
						|
            if (Buf.KeyEvent.wVirtualKeyCode in [VK_SHIFT, VK_MENU, VK_CONTROL,
 | 
						|
                                                VK_CAPITAL, VK_NUMLOCK,
 | 
						|
                                                VK_SCROLL]) then
 | 
						|
              begin
 | 
						|
                { Discard this key }
 | 
						|
              end
 | 
						|
                else begin
 | 
						|
            KeyPressed := TRUE;
 | 
						|
 | 
						|
            if ord(buf.KeyEvent.AsciiChar) = 0 then
 | 
						|
             begin
 | 
						|
               SpecialKey := TRUE;
 | 
						|
                          ScanCode := Chr(RemapScanCode(Buf.KeyEvent.wVirtualScanCode, Buf.KeyEvent.dwControlKeyState,
 | 
						|
                                                        Buf.KeyEvent.wVirtualKeyCode));
 | 
						|
             end
 | 
						|
            else
 | 
						|
             begin
 | 
						|
               SpecialKey := FALSE;
 | 
						|
               ScanCode := Chr(Ord(buf.KeyEvent.AsciiChar));
 | 
						|
             end;
 | 
						|
 | 
						|
                        if Buf.KeyEvent.wVirtualKeyCode in [VK_NUMPAD0..VK_NUMPAD9] then
 | 
						|
                         if AltKey then
 | 
						|
                          begin
 | 
						|
                            Keypressed := false;
 | 
						|
                            Specialkey := false;
 | 
						|
                            ScanCode := #0;
 | 
						|
                          end
 | 
						|
                            else BREAK;
 | 
						|
          end;
 | 
						|
          end { if }
 | 
						|
           else if (Buf.KeyEvent.wVirtualKeyCode in [VK_MENU]) then
 | 
						|
                 if DoingNumChars then
 | 
						|
                  if DoingNumCode > 0 then
 | 
						|
                   begin
 | 
						|
                     ScanCode := Chr(DoingNumCode);
 | 
						|
                     Keypressed := true;
 | 
						|
 | 
						|
                     DoingNumChars := false;
 | 
						|
                     DoingNumCode := 0;
 | 
						|
                     BREAK;
 | 
						|
                   end; { if }
 | 
						|
 | 
						|
      end;
 | 
						|
   end;
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
function ReadKey: char;
 | 
						|
begin
 | 
						|
  repeat
 | 
						|
    Sleep(1);
 | 
						|
  until KeyPressed;
 | 
						|
 | 
						|
  if SpecialKey then begin
 | 
						|
    ReadKey := #0;
 | 
						|
    SpecialKey := FALSE;
 | 
						|
  end
 | 
						|
  else begin
 | 
						|
    ReadKey := ScanCode;
 | 
						|
    ScanCode := #0;
 | 
						|
  end;
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
{*************************************************************************
 | 
						|
                                   Delay
 | 
						|
*************************************************************************}
 | 
						|
 | 
						|
procedure Delay(MS: Word);
 | 
						|
begin
 | 
						|
  Sleep(ms);
 | 
						|
end; { proc. Delay }
 | 
						|
 | 
						|
 | 
						|
procedure sound(hz : word);
 | 
						|
begin
 | 
						|
  MessageBeep(0); { lame ;-) }
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
procedure nosound;
 | 
						|
begin
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
{****************************************************************************
 | 
						|
                          HighLevel Crt Functions
 | 
						|
****************************************************************************}
 | 
						|
 | 
						|
procedure removeline(y : longint);
 | 
						|
var
 | 
						|
  ClipRect: TSmallRect;
 | 
						|
  SrcRect: TSmallRect;
 | 
						|
  DestCoor: TCoord;
 | 
						|
  CharInfo: TCharInfo;
 | 
						|
begin
 | 
						|
  CharInfo.UnicodeChar := 32;
 | 
						|
  CharInfo.Attributes := TextAttr;
 | 
						|
 | 
						|
  Y := WinMinY + Y-1;
 | 
						|
 | 
						|
  SrcRect.Top := Y - 01;
 | 
						|
  SrcRect.Left := WinMinX - 1;
 | 
						|
  SrcRect.Right := WinMaxX - 1;
 | 
						|
  SrcRect.Bottom := WinMaxY - 1;
 | 
						|
 | 
						|
  DestCoor.X := WinMinX - 1;
 | 
						|
  DestCoor.Y := Y - 2;
 | 
						|
  ClipRect := SrcRect;
 | 
						|
 | 
						|
  ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect, DestCoor, CharInfo);
 | 
						|
end; { proc. RemoveLine }
 | 
						|
 | 
						|
 | 
						|
procedure delline;
 | 
						|
begin
 | 
						|
  removeline(wherey);
 | 
						|
end; { proc. DelLine }
 | 
						|
 | 
						|
 | 
						|
procedure insline;
 | 
						|
var
 | 
						|
  ClipRect: TSmallRect;
 | 
						|
  SrcRect: TSmallRect;
 | 
						|
  DestCoor: TCoord;
 | 
						|
  CharInfo: TCharInfo;
 | 
						|
  X,Y: Longint;
 | 
						|
begin
 | 
						|
  GetScreenCursor(X, Y);
 | 
						|
 | 
						|
  CharInfo.UnicodeChar := 32;
 | 
						|
  CharInfo.Attributes := TextAttr;
 | 
						|
 | 
						|
  SrcRect.Top := Y - 1;
 | 
						|
  SrcRect.Left := WinMinX - 1;
 | 
						|
  SrcRect.Right := WinMaxX - 1;
 | 
						|
  SrcRect.Bottom := WinMaxY - 1;
 | 
						|
 | 
						|
  DestCoor.X := WinMinX - 1;
 | 
						|
  DestCoor.Y := Y;
 | 
						|
  ClipRect := SrcRect;
 | 
						|
 | 
						|
  ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect, DestCoor, CharInfo);
 | 
						|
end; { proc. InsLine }
 | 
						|
 | 
						|
 | 
						|
 | 
						|
 | 
						|
{****************************************************************************
 | 
						|
                             Extra Crt Functions
 | 
						|
****************************************************************************}
 | 
						|
 | 
						|
procedure cursoron;
 | 
						|
var CursorInfo: TConsoleCursorInfo;
 | 
						|
begin
 | 
						|
  GetConsoleCursorInfo(OutHandle, CursorInfo);
 | 
						|
  CursorInfo.dwSize := SaveCursorSize;
 | 
						|
  CursorInfo.bVisible := true;
 | 
						|
  SetConsoleCursorInfo(OutHandle, CursorInfo);
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
procedure cursoroff;
 | 
						|
var CursorInfo: TConsoleCursorInfo;
 | 
						|
begin
 | 
						|
  GetConsoleCursorInfo(OutHandle, CursorInfo);
 | 
						|
  CursorInfo.bVisible := false;
 | 
						|
  SetConsoleCursorInfo(OutHandle, CursorInfo);
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
procedure cursorbig;
 | 
						|
var CursorInfo: TConsoleCursorInfo;
 | 
						|
begin
 | 
						|
  GetConsoleCursorInfo(OutHandle, CursorInfo);
 | 
						|
  CursorInfo.dwSize := 100;
 | 
						|
  CursorInfo.bVisible := true;
 | 
						|
  SetConsoleCursorInfo(OutHandle, CursorInfo);
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
{*****************************************************************************
 | 
						|
                          Read and Write routines
 | 
						|
*****************************************************************************}
 | 
						|
 | 
						|
var
 | 
						|
  CurrX, CurrY : longint;
 | 
						|
 | 
						|
procedure WriteChar(c:char);
 | 
						|
var
 | 
						|
    Cell    : TCharInfo;
 | 
						|
    BufSize : Coord;                    { Column-row size of source buffer }
 | 
						|
    WritePos: TCoord;                       { Upper-left cell to write from }
 | 
						|
    DestRect: TSmallRect;
 | 
						|
begin
 | 
						|
  Case C of
 | 
						|
   #10 : begin
 | 
						|
           Inc(CurrY);
 | 
						|
         end;
 | 
						|
   #13 : begin
 | 
						|
           CurrX := WinMinX;
 | 
						|
         end; { if }
 | 
						|
   #08 : begin
 | 
						|
           if CurrX > WinMinX then Dec(CurrX);
 | 
						|
         end; { ^H }
 | 
						|
   #07 : begin
 | 
						|
           // MessagBeep(0);
 | 
						|
         end; { ^G }
 | 
						|
     else begin
 | 
						|
            BufSize.X := 01;
 | 
						|
            BufSize.Y := 01;
 | 
						|
 | 
						|
            WritePos.X := 0;
 | 
						|
            WritePos.Y := 0;
 | 
						|
 | 
						|
            Cell.UniCodeChar := Ord(c);
 | 
						|
            Cell.Attributes := TextAttr;
 | 
						|
 | 
						|
            DestRect.Left := (CurrX - 01);
 | 
						|
            DestRect.Top := (CurrY - 01);
 | 
						|
            DestRect.Right := (CurrX - 01) + 01;
 | 
						|
            DestRect.Bottom := (CurrY - 01);
 | 
						|
 | 
						|
            WriteConsoleOutput(OutHandle, Cell, BufSize, WritePos, @DestRect);
 | 
						|
 | 
						|
            Inc(CurrX);
 | 
						|
          end; { else }
 | 
						|
  end; { case }
 | 
						|
  if CurrX > WinMaxX then
 | 
						|
    begin
 | 
						|
      CurrX := WinMinX;
 | 
						|
      Inc(CurrY);
 | 
						|
    end; { if }
 | 
						|
  While CurrY > WinMaxY do
 | 
						|
   begin
 | 
						|
     RemoveLine(1);
 | 
						|
     Dec(CurrY);
 | 
						|
   end; { while }
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
Function CrtWrite(var f : textrec):integer;
 | 
						|
var
 | 
						|
  i : longint;
 | 
						|
begin
 | 
						|
  GetScreenCursor(CurrX,CurrY);
 | 
						|
  for i:=0 to f.bufpos-1 do
 | 
						|
   WriteChar(f.buffer[i]);
 | 
						|
  SetScreenCursor(CurrX,CurrY);
 | 
						|
  f.bufpos:=0;
 | 
						|
  CrtWrite:=0;
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
Function CrtRead(Var F: TextRec): Integer;
 | 
						|
 | 
						|
  procedure BackSpace;
 | 
						|
  begin
 | 
						|
    if (f.bufpos>0) and (f.bufpos=f.bufend) then
 | 
						|
     begin
 | 
						|
       WriteChar(#8);
 | 
						|
       WriteChar(' ');
 | 
						|
       WriteChar(#8);
 | 
						|
       dec(f.bufpos);
 | 
						|
       dec(f.bufend);
 | 
						|
     end;
 | 
						|
  end;
 | 
						|
 | 
						|
var
 | 
						|
  ch : Char;
 | 
						|
Begin
 | 
						|
  GetScreenCursor(CurrX,CurrY);
 | 
						|
  f.bufpos:=0;
 | 
						|
  f.bufend:=0;
 | 
						|
  repeat
 | 
						|
    if f.bufpos>f.bufend then
 | 
						|
     f.bufend:=f.bufpos;
 | 
						|
    SetScreenCursor(CurrX,CurrY);
 | 
						|
    ch:=readkey;
 | 
						|
    case ch of
 | 
						|
    #0 : case readkey of
 | 
						|
          #71 : while f.bufpos>0 do
 | 
						|
                 begin
 | 
						|
                   dec(f.bufpos);
 | 
						|
                   WriteChar(#8);
 | 
						|
                 end;
 | 
						|
          #75 : if f.bufpos>0 then
 | 
						|
                 begin
 | 
						|
                   dec(f.bufpos);
 | 
						|
                   WriteChar(#8);
 | 
						|
                 end;
 | 
						|
          #77 : if f.bufpos<f.bufend then
 | 
						|
                 begin
 | 
						|
                   WriteChar(f.bufptr^[f.bufpos]);
 | 
						|
                   inc(f.bufpos);
 | 
						|
                 end;
 | 
						|
          #79 : while f.bufpos<f.bufend do
 | 
						|
                 begin
 | 
						|
                   WriteChar(f.bufptr^[f.bufpos]);
 | 
						|
                   inc(f.bufpos);
 | 
						|
                 end;
 | 
						|
         end;
 | 
						|
    ^S,
 | 
						|
    #8 : BackSpace;
 | 
						|
    ^Y,
 | 
						|
   #27 : begin
 | 
						|
           f.bufpos:=f.bufend;
 | 
						|
           while f.bufend>0 do
 | 
						|
            BackSpace;
 | 
						|
         end;
 | 
						|
   #13 : begin
 | 
						|
           WriteChar(#13);
 | 
						|
           WriteChar(#10);
 | 
						|
           f.bufptr^[f.bufend]:=#13;
 | 
						|
           f.bufptr^[f.bufend+1]:=#10;
 | 
						|
           inc(f.bufend,2);
 | 
						|
           break;
 | 
						|
         end;
 | 
						|
   #26 : if CheckEOF then
 | 
						|
          begin
 | 
						|
            f.bufptr^[f.bufend]:=#26;
 | 
						|
            inc(f.bufend);
 | 
						|
            break;
 | 
						|
          end;
 | 
						|
    else
 | 
						|
     begin
 | 
						|
       if f.bufpos<f.bufsize-2 then
 | 
						|
        begin
 | 
						|
          f.buffer[f.bufpos]:=ch;
 | 
						|
          inc(f.bufpos);
 | 
						|
          WriteChar(ch);
 | 
						|
        end;
 | 
						|
     end;
 | 
						|
    end;
 | 
						|
  until false;
 | 
						|
  f.bufpos:=0;
 | 
						|
  SetScreenCursor(CurrX,CurrY);
 | 
						|
  CrtRead:=0;
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
Function CrtReturn(Var F:TextRec):Integer;
 | 
						|
Begin
 | 
						|
  CrtReturn:=0;
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
Function CrtClose(Var F: TextRec): Integer;
 | 
						|
Begin
 | 
						|
  F.Mode:=fmClosed;
 | 
						|
  CrtClose:=0;
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
Function CrtOpen(Var F: TextRec): Integer;
 | 
						|
Begin
 | 
						|
  If F.Mode=fmOutput Then
 | 
						|
   begin
 | 
						|
     TextRec(F).InOutFunc:=@CrtWrite;
 | 
						|
     TextRec(F).FlushFunc:=@CrtWrite;
 | 
						|
   end
 | 
						|
  Else
 | 
						|
   begin
 | 
						|
     F.Mode:=fmInput;
 | 
						|
     TextRec(F).InOutFunc:=@CrtRead;
 | 
						|
     TextRec(F).FlushFunc:=@CrtReturn;
 | 
						|
   end;
 | 
						|
  TextRec(F).CloseFunc:=@CrtClose;
 | 
						|
  CrtOpen:=0;
 | 
						|
End;
 | 
						|
 | 
						|
 | 
						|
procedure AssignCrt(var F: Text);
 | 
						|
begin
 | 
						|
  Assign(F,'');
 | 
						|
  TextRec(F).OpenFunc:=@CrtOpen;
 | 
						|
end;
 | 
						|
 | 
						|
 | 
						|
var
 | 
						|
  CursorInfo  : TConsoleCursorInfo;
 | 
						|
  ConsoleInfo : TConsoleScreenBufferinfo;
 | 
						|
begin
 | 
						|
  { Initialize the output handles }
 | 
						|
  OutHandle := GetStdHandle(STD_OUTPUT_HANDLE);
 | 
						|
  InputHandle := GetStdHandle(STD_INPUT_HANDLE);
 | 
						|
  LastMode := 3;
 | 
						|
 | 
						|
  {--------------------- Get the cursor size and such -----------------------}
 | 
						|
  FillChar(CursorInfo, SizeOf(CursorInfo), 00);
 | 
						|
  GetConsoleCursorInfo(OutHandle, CursorInfo);
 | 
						|
  SaveCursorSize := CursorInfo.dwSize;
 | 
						|
 | 
						|
  {------------------ Get the current cursor position and attr --------------}
 | 
						|
  FillChar(ConsoleInfo, SizeOf(ConsoleInfo), 0);
 | 
						|
  GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
 | 
						|
  CursorSaveX := ConsoleInfo.dwCursorPosition.X;
 | 
						|
  CursorSaveY := ConsoleInfo.dwCursorPosition.Y;
 | 
						|
  TextAttr := ConsoleInfo.wAttributes;
 | 
						|
 | 
						|
  { Load startup values }
 | 
						|
  ScreenWidth := GetScreenWidth;
 | 
						|
  ScreenHeight := GetScreenHeight;
 | 
						|
  IsWindowsNT := (GetPlatformID = VER_PLATFORM_WIN32_NT);
 | 
						|
  TurnMouseOff;
 | 
						|
 | 
						|
  WindMax := (ScreenWidth - 1) OR ((ScreenHeight - 1) SHL 8);
 | 
						|
  DoingNumChars := false;
 | 
						|
  DoingNumCode := 0;
 | 
						|
 | 
						|
  { Redirect the standard output }
 | 
						|
  AssignCrt(Output);
 | 
						|
  Rewrite(Output);
 | 
						|
  TextRec(Output).Handle:= OutHandle;
 | 
						|
 | 
						|
  AssignCrt(Input);
 | 
						|
  Reset(Input);
 | 
						|
  TextRec(Input).Handle:= InputHandle;
 | 
						|
end. { unit Crt }
 | 
						|
{
 | 
						|
  $Log$
 | 
						|
  Revision 1.12  1999-10-22 14:36:20  peter
 | 
						|
    * crtreturn also needs f:textrec as parameter
 | 
						|
 | 
						|
  Revision 1.11  1999/08/28 09:30:39  peter
 | 
						|
    * fixes from Maarten Bekers
 | 
						|
 | 
						|
  Revision 1.10  1999/08/24 13:15:44  peter
 | 
						|
    * Removeline fixed
 | 
						|
 | 
						|
  Revision 1.9  1999/07/06 22:44:11  florian
 | 
						|
    * some fixes to compile ddraw units from the jedi project
 | 
						|
 | 
						|
  Revision 1.8  1999/06/09 16:46:11  peter
 | 
						|
    * fixed fullwin,textbackground
 | 
						|
 | 
						|
  Revision 1.7  1999/05/22 14:01:01  peter
 | 
						|
    * more fixed from Maarten Bekkers
 | 
						|
 | 
						|
  Revision 1.6  1999/05/19 16:22:02  peter
 | 
						|
    * fixed left crt bugs
 | 
						|
 | 
						|
  Revision 1.5  1999/05/01 13:18:26  peter
 | 
						|
    * changed back fixes
 | 
						|
 | 
						|
  Revision 1.4  1999/04/30 11:34:27  michael
 | 
						|
  + Fixed some compiling errors
 | 
						|
 | 
						|
  Revision 1.3  1999/04/23 09:06:17  michael
 | 
						|
  + now it REALLY compiles
 | 
						|
 | 
						|
  Revision 1.2  1999/04/20 11:34:12  peter
 | 
						|
    + crt unit that compiles
 | 
						|
 | 
						|
}
 |