{******************************************************************************}
{* DCRT emuliert die von Textopia benoetigten CRT-Funktionen unter Delphi 4   *}
{* Geschrieben von Oliver Berse 1999                                          *)
(******************************************************************************}
UNIT dcrt;
INTERFACE
USES WINDOWS,SYSUTILS;
{$D+} {$L+} {$R+} {$H-}
CONST
  black        = 0;
  blue         = 1;
  green        = 2;
  cyan         = 3;
  red          = 4;
  magenta      = 5;
  brown        = 6;
  lightGray    = 7;
  darkGray     = 8;
  lightBlue    = 9;
  lightGreen   = 10;
  lightCyan    = 11;
  lightRed     = 12;
  lightMagenta = 13;
  yellow       = 14;
  white        = 15;
  {
    Funktionen & Prozeduren der originalen CRT-Unit von TP
  }
  PROCEDURE ClrScr;
  PROCEDURE ClrEol;
  PROCEDURE DelLine;
  PROCEDURE GotoXY(x,y : BYTE);
  PROCEDURE HighVideo;
  FUNCTION  KeyPressed: BOOLEAN;
  FUNCTION  ReadKey: CHAR;
  PROCEDURE TextColor(Color: BYTE);
  PROCEDURE TextBackground(Color: BYTE);
  PROCEDURE window(x1,y1,x2,y2: BYTE);
  FUNCTION  WhereX: BYTE;
  FUNCTION  WhereY: BYTE;
  PROCEDURE LowVideo;
  PROCEDURE NormVideo;
  {
    Interne Routinen
  }
  PROCEDURE DelChrXY(x,y : BYTE; c : CHAR);
  PROCEDURE FloodScreen(fc : CHAR);
  PROCEDURE ResetInputBuffer;
  PROCEDURE WriteChrXY(x,y : BYTE; c : CHAR);
  PROCEDURE WriteStrXY(x,y : BYTE; str: PCHAR; sizedw: INTEGER);

IMPLEMENTATION

TYPE
  POpenText = ^TOpenText;
  TOpenText = FUNCTION (VAR F: Text; Mode: WORD): INTEGER; FAR;

VAR
  wmin,
  wmax,
  prevmode,
  startattr  : WORD;
  textattr,
  lastx,
  lasty      : BYTE;
  popentxt   : POpenText;
  hcin       : THandle;
  hcout      : THandle;
  textscreen : TSmallRect;
  cptmp      : INTEGER;
  condata    : TInputRecord;
  {
    Ascii- und ScanCode der letzen Eingabe
  }
  prevkey,  
  prevscan : CHAR;

Function TextOut(var f: Text) : INTEGER; far;
VAR
  dwSize: DWORD;
BEGIN
  With TTExtRec(F) DO
  BEGIN
    IF BufPos>0 THEN
    BEGIN
      lastx:=WhereX;
      lasty:=WhereY;
      dwSize:=0;
      WHILE (dwSize<BufPos) DO
      BEGIN
        WriteChrXY(lastx,lasty,BufPtr[dwSize]);
        Inc(dwSize);
      End;
      BufPos:=0;
    End;
  End;
  RESULT:=0;
End;

FUNCTION OpenText(VAR F: Text; Mode: WORD): INTEGER; far;
VAR
  OpenRESULT: INTEGER;
BEGIN
  OpenRESULT:=102;
  IF Assigned(popentxt) THEN
  BEGIN
    TTextRec(F).OpenFunc:=popentxt;
    OpenRESULT:=popentxt^(F, Mode);
    IF OpenRESULT=0 THEN
    BEGIN
      IF Mode=fmInput THEN hcin:=TTextRec(F).Handle
                      ELSE BEGIN
                             hcout:=TTextRec(F).Handle;
                             TTextRec(Output).InOutFunc:=@TextOut;
                             TTextRec(Output).FlushFunc:=@TextOut;
                           END;
    END;
  END;
  RESULT:=OpenRESULT;
END;

PROCEDURE FloodScreen(fc : CHAR);
VAR
  line    : INTEGER;
  coord   : TCoord;
  sizedw,
  countdw : DWORD;
BEGIN
  coord.x:=textscreen.Left;
  sizedw:=textscreen.Right-textscreen.Left+1;
  For line:=textscreen.Top To textscreen.Bottom DO
  BEGIN
    coord.y:=line;
    FillConsoleOutputAttribute(hcout,TextAttr,sizedw,coord,countdw);
    FillConsoleOutputCharacter(hcout,fc,sizedw,coord,countdw);
  END;
  GotoXY(1,1);
END;

PROCEDURE WriteChrXY(x,y : BYTE; c : CHAR);
VAR
  coord   : TCoord;
  sizedw,
  countdw : DWORD;
BEGIN
  lastx:=x;
  lasty:=y;
  CASE c OF
    #13: lastx:=1;
    #10: BEGIN
           lastx:=1;
           Inc(lasty);
         END;
    ELSE BEGIN
           coord.x:=lastx-1+textscreen.Left;
           coord.y:=lasty-1+textscreen.Top;
           sizedw:=1;
           FillConsoleOutputAttribute(hcout,TextAttr,sizedw,coord,countdw);
           FillConsoleOutputCHARacter(hcout,c,sizedw,coord,countdw);
           Inc(lastx);
         END;
  END;
  IF (lastx+textscreen.Left)>(textscreen.Right+1) THEN
  BEGIN
    lastx:=1;
    Inc(lasty);
  END;
  IF (lasty+textscreen.Top)>(textscreen.Bottom+1) THEN
  BEGIN
    Dec(lasty);
    GotoXY(1,1);DelLine;
  END;
  GotoXY(lastx,lasty);
END;

Procedure WriteStrXY(x,y : BYTE; str: PCHAR; sizedw : INTEGER);
VAR
 cdw: INTEGER;
BEGIN
  IF sizedw>0 THEN
  BEGIN
    lastx:=x;
    lasty:=y;
    cdw:=0;
    WHILE cdw<sizedw DO
    BEGIN
      WriteChrXY(lastx,lasty,str[cdw]);
      Inc(cdw);
    End;
  End;
End;

PROCEDURE ResetInputBuffer;
BEGIN
  FlushConsoleInputBuffer(hcin);
END;

FUNCTION KeyPressed: BOOLEAN;
VAR
  NumberOFEvents: DWORD;
  NumRead: DWORD;
  Pressed: BOOLEAN;
BEGIN
  Pressed:=FALSE;
  GetNumberOFConsoleInputEvents(hcin,NumberOFEvents);
  IF NumberOFEvents>0 THEN
  BEGIN
    IF PeekConsoleInput(hcin,condata,1,NumRead) THEN
    BEGIN
       IF (condata.EventTYPE = KEY_EVENT) AND
          (condata.Event.KeyEvent.bKeyDOwn) THEN Pressed:=TRUE
          ELSE ReadConsoleInput(hcin,condata,1,NumRead);
    END;
  END;
  RESULT :=Pressed;
END;

FUNCTION ReadKey : CHAR;
CONST
  fkeys             = [#59..#68];
  shift             = [vk_shift,vk_control,vk_menu,vk_capital];
  ctrl_pressed      = Left_ctrl_pressed OR Right_ctrl_pressed;
  alt_pressed       = Left_alt_pressed OR Right_alt_pressed;
  AltKey            : String
                    = '-0123456789=abcdefghijklmnopqrstuvwxyz';
  CvtKey            : String
                    = #130#129#120#121#122#123#124#125#126#127#128+
                      #131#30#48#46#32#18#33#34#35#23#36#37#38+
                      #50#49#24#25#16#19#31#20#22#47#17#45#21#44;
VAR
  i  : DWord;
  oK : Boolean;
BEGIN
  IF prevkey=#0 THEN RESULT:=prevscan
                ELSE BEGIN
                       with condata.event.KeyEvent do
                       BEGIN
                         REPEAT;
                           REPEAT;
                             Ok:=ReadConsoleInput(hcin,condata,1,i);
                           UNTIL OK AND
                                 (condata.EventType=KEY_EVENT) AND
                                 (bKeyDown=FALSE);
                           prevscan:=Char(wVirtualScanCode);
                         UNTIL NOT(wVirtualKeyCode IN shift);
                         RESULT:=AsciiChar;
                         IF dwControlKeyState<>0 THEN
                         BEGIN
                           IF RESULT=#0 THEN
                           BEGIN
                             IF (dwControlKeyState AND Shift_Pressed)<>0 THEN
                             BEGIN
                               IF prevscan IN fkeys THEN prevscan:=Char(Ord(prevscan)+25);
                               IF prevscan=#122 THEN prevscan:=#1;
                             END ELSE IF (dwControlKeyState AND ctrl_pressed)<>0 THEN
                             BEGIN
                               IF prevscan IN fkeys THEN prevscan:=Char(Ord(prevscan)+35)
                                                    ELSE BEGIN
                                                           {
                                                            Cursortasten-Codes
                                                           }
                                                           CASE prevscan OF
                                                             #55:prevscan:=#114;
                                                             #73:prevscan:=#132;
                                                             #75:prevscan:=#115;
                                                             #77:prevscan:=#116;
                                                             #79:prevscan:=#117;
                                                             #81:prevscan:=#118;
                                                           END;
                                                         END;
                             END ELSE IF (dwControlKeyState AND alt_pressed)<>0 THEN
                             BEGIN
                               IF prevscan IN fkeys THEN prevscan:=Char(Ord(prevscan)+45);
                             END;
                         END ELSE BEGIN
                                    IF (dwControlKeyState AND ctrl_pressed)<>0 THEN
                                    BEGIN
                                      IF RESULT IN ['a'..'z'] THEN RESULT:=Char(Ord(RESULT)-96)
                                    END ELSE IF (dwControlKeyState AND alt_pressed)<>0 THEN
                                    BEGIN
                                      i:=Pos(RESULT,AltKey);
                                      IF i>0 THEN
                                      BEGIN
                                        prevscan:=CvtKey[i];
                                        RESULT:=#0;
                                      END;
                                    END ELSE IF (dwControlKeyState AND Shift_Pressed)<>0 THEN
                                    BEGIN
                                      IF RESULT=#9 THEN
                                      BEGIN
                                        RESULT:=#0;
                                        prevscan:=#15;
                                      END ELSE CharUpper(PChar(RESULT));
                                    END;
                                  END;
      END;
    END;
  END;
  prevkey:=RESULT;
END;

PROCEDURE Window(x1,y1,x2,y2: BYTE);
BEGIN
  textscreen.Left:=x1-1;
  textscreen.Top:=y1-1;
  textscreen.Right:=x2-1;
  textscreen.Bottom:=y2-1;
  wmin:=(textscreen.Top SHL 8) OR textscreen.Left;
  wmax:=(textscreen.Bottom SHL 8) OR textscreen.Right;
  SetConsolewindowInfo(hcout,TRUE,textscreen); { Rahmen mit anpassen }
  GotoXY(1,1);
END;

PROCEDURE GotoXY(x,y : BYTE);
VAR
  coord :TCoord;
BEGIN
  coord.x:=x-1+textscreen.Left;
  coord.y:=y-1+textscreen.Top;
  SetConsoleCursorPosition(hcout,coord);
END;

FUNCTION WhereX: BYTE;
VAR
  cbi : TConsoleScreenBufferInfo;
BEGIN
  GetConsoleScreenBufferInfo(hcout,CBI);
  RESULT:=TCoord(CBI.dwCursorPosition).x+1-textscreen.Left;
END;

FUNCTION WhereY: BYTE;
VAR
  cbi : TConsoleScreenBufferInfo;
BEGIN
  GetConsoleScreenBufferInfo(hcout,CBI);
  RESULT:=TCoord(CBI.dwCursorPosition).y+1-textscreen.Top;
END;

PROCEDURE ClrScr;
BEGIN
  FloodScreen(' ');
END;

PROCEDURE ClrEol;
VAR
  coord   :TCoord;
  sizedw,
  countdw : DWORD;
BEGIN
  coord.x:=WhereX-1+textscreen.Left;
  coord.y:=WhereY-1+textscreen.Top;
  sizedw:=textscreen.Right-coord.y+1;
  FillConsoleOutputAttribute(hcout,TextAttr,sizedw,coord,countdw);
  FillConsoleOutputCHARacter(hcout,' ',sizedw,coord,countdw);
END;

PROCEDURE DelLine;
VAR
  sizedw,
  countdw      : DWORD;
  sourcescreen : TSmallRect;
  coord        : TCoord;
  ci           : TCHARinfo;
BEGIN
  sourcescreen:=textscreen;
  sourcescreen.Top:=WhereY+textscreen.Top;
  CI.AsciiCHAR:=' ';
  CI.Attributes:=TextAttr;
  coord.x:=sourcescreen.Left;
  coord.y:=sourcescreen.Top-1;
  sizedw:=sourcescreen.Right-sourcescreen.Left+1;
  ScrollConsoleScreenBuffer(hcout,sourcescreen,NIL,coord,CI);
  FillConsoleOutputAttribute(hcout,TextAttr,sizedw,coord,countdw);
END;

PROCEDURE TextColor(Color: BYTE);
BEGIN
  prevmode:=TextAttr;
  TextAttr:=(Color AND $0F) OR (TextAttr AND $F0);
  SetConsoleTextAttribute(hcout,TextAttr);
END;

PROCEDURE TextBackground(Color: BYTE);
BEGIN
  prevmode:=TextAttr;
  TextAttr:=(Color SHL 4) OR (TextAttr AND $0F);
  SetConsoleTextAttribute(hcout,TextAttr);
END;

PROCEDURE LowVideo;
BEGIN
  prevmode:=TextAttr;
  TextAttr:=TextAttr AND $F7;
  SetConsoleTextAttribute(hcout,TextAttr);
END;

PROCEDURE HighVideo;
BEGIN
  prevmode:=TextAttr;
  TextAttr:=TextAttr OR $08;
  SetConsoleTextAttribute(hcout,TextAttr);
END;

PROCEDURE NormVideo;
BEGIN
  prevmode :=TextAttr;
  TextAttr :=StartAttr;
  SetConsoleTextAttribute(hcout,TextAttr);
END;

PROCEDURE DelChrXY(x,y : BYTE; c : CHAR);
VAR
  coord   : TCoord;
  sizedw,
  countdw : DWORD;
BEGIN
  lastx:=x;
  lasty:=y;
  coord.x:=lastx-1+textscreen.Left;
  coord.y:=lasty-1+textscreen.Top;
  sizedw:=1;
  FillConsoleOutputAttribute(hcout,TextAttr,sizedw,coord,countdw);
  FillConsoleOutputCHARacter(hcout,c,sizedw,coord,countdw);
  GotoXY(lastx,lasty);
END;

PROCEDURE Init;
CONST
  ExtInpConsoleMode =
    ENABLE_window_INPUT OR ENABLE_PROCESSED_INPUT OR ENABLE_MOUSE_INPUT;
  ExtOutConsoleMode =
    ENABLE_PROCESSED_OUTPUT OR ENABLE_WRAP_AT_EOL_OUTPUT;
VAR
  cbi   : TConsoleScreenBufferInfo;
  cmode : DWORD;
  coord : TCoord;
BEGIN
  popentxt:=TTextRec(Output).OpenFunc;
  Reset(Input);
  hcin:=TTextRec(Input).Handle;
  ReWrite(Output);
  hcout:=TTextRec(Output).Handle;
  GetConsoleMode(hcin,cMode);
  IF (cMode AND ExtInpConsoleMode)<>ExtInpConsoleMode THEN
  BEGIN
    cMode:=cMode OR ExtInpConsoleMode;
    SetConsoleMode(hcin,cMode);
  END;
  TTextRec(Output).InOutFunc:=@TextOut;
  TTextRec(Output).FlushFunc:=@TextOut;
  GetConsoleScreenBufferInfo(hcout,CBI);
  GetConsoleMode(hcout,cMode);
  IF (cMode AND ExtOutConsoleMode)<>ExtOutConsoleMode THEN
  BEGIN
    cMode:=cMode OR ExtOutConsoleMode;
    SetConsoleMode(hcout,cMode);
  END;
  textattr:=CBI.wAttributes;
  startattr:=CBI.wAttributes;
  prevmode:=CBI.wAttributes;
  coord.x:=CBI.srwindow.Left;
  coord.y:=CBI.srwindow.Top;
  wmin:=(coord.y SHL 8) OR coord.x;
  coord.x:=CBI.srwindow.Right;
  coord.y:=CBI.srwindow.Bottom;
  wmax:=(coord.y SHL 8) OR coord.x;
  textscreen:=CBI.srwindow;
  cptmp:=GetConsoleOutputCP;
  SetConsoleOutputCP(1250);
  prevkey:=#32;
  prevscan:=#32;
  ResetInputBuffer;
END;

PROCEDURE Done;
BEGIN
  SetConsoleOutputCP(cptmp);
  TextAttr:=StartAttr;
  SetConsoleTextAttribute(hcout,TextAttr);
  ResetInputBuffer;
  Close(Input);
  Close(Output);
END;

INITIALIZATION
  Init;
FINALIZATION
  Done;
END.
