{*******************************************************}
{                                                       }
{       Dosvox CRT emulation procedures                 }
{       By Jose' Antonio Borges                         }
{       January/1998                                    }
{       Copyright (c) 1998 - NCE/UFRJ                   }
{                                                       }
{       Based on the                                    }
{       Turbo Pascal Runtime Library                    }
{       Windows CRT Interface Unit                      }
{       Copyright (c) 1991,92 Borland International     }
{                                                       }
{*******************************************************}

unit DvCrt;

{$S-}

interface

uses WinTypes, WinProcs, WinDos, Strings, mmSystem;

const
  WindowOrg: TPoint =                       { CRT window origin }
    (X: cw_UseDefault; Y: cw_UseDefault);
  WindowSize: TPoint =                      { CRT window size }
    (X: 648; Y: 480);
  ScreenSize: TPoint = (X: 80; Y: 25);      { Screen buffer dimensions }
  Cursor: TPoint = (X: 0; Y: 0);            { Cursor location }
  InactiveTitle: PChar = '(Programa terminado - %s)';
                                            { Inactive window title }
  CheckEOF: Boolean = False;                { Allow Ctrl-Z for EOF? }
  CheckBreak: Boolean = True;               { Allow Ctrl-C for break? }
  CheckFocus: Boolean = False;		    { Generate keyboard char on focus? }
  SelectOEMFont: Boolean = False;           { Use OEM or System font }

var
{ Interface variables }

  CrtWindow: HWnd;        { CRT window handle }
  LastMode: Word;         { Current text mode }
  TextAttr: Byte;         { Current text attribute }

var
  WindowTitle: array[0..79] of Char;        { CRT window title }

procedure InitWinCrt;
procedure DoneWinCrt;
procedure AssignCrt(var F: Text);

procedure WriteBuf(Buffer: PChar; Count: Word);
procedure WriteChar(Ch: Char);

function KeyPressed: Boolean;
function ReadKey: Char;
function ReadBuf(Buffer: PChar; Count: Word): Word;

procedure GotoXY(X, Y: Integer);
function WhereX: Integer;
function WhereY: Integer;
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;

procedure Window (X1,Y1,X2,Y2: Byte);
procedure TextMode(Mode: Integer);

procedure putClipBoard (data: PChar);
procedure getClipBoard (data: PChar; maxSize: word);
procedure ForceCursor;
procedure unForceCursor;

function getScreenChar (x, y: integer): char;
function getScreenAttrib (x, y: integer): byte;
procedure canChangeColors (canChange: boolean);

var
  hasAlternateWinProc: boolean;
  alternateWinProc: procedure (Window: HWnd; Message, WParam: Word; LParam: Longint;
                               var result: longint);
  hasmmCallback: boolean;
  mmCallback: procedure (Window: HWnd; WParam: Word; LParam: Longint);

  currentWindow: TRect;                     { Active window box }

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 }

{ 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;

  highIntens = 8;
  defaultAttrib = lightGray;

implementation

{ Double word record }

type
  LongRec = record
    Lo, Hi: Integer;
  end;

{ MinMaxInfo array }

type
  PMinMaxInfo = ^TMinMaxInfo;
  TMinMaxInfo = array[0..4] of TPoint;

{ CRT window procedure }

function CrtWinProc(Window: HWnd; Message, WParam: Word;
  LParam: Longint): Longint; export; forward;

{ CRT window class }

const
  CrtClass: TWndClass = (
    style: cs_HRedraw + cs_VRedraw;
    lpfnWndProc: @CrtWinProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: nil;
    lpszClassName: 'DvWinCrt');

const
  KeyCount: Integer = 0;                { Count of keys in KeyBuffer }
  Created: Boolean = False;       	{ CRT window created? }
  Focused: Boolean = False;             { CRT window focused? }
  Reading: Boolean = False;             { Reading from CRT window? }
  Painting: Boolean = False;            { Handling wm_Paint? }
  ForcedCur: Boolean = False;           { Force cursor to appear }

var
  SaveExit: Pointer;                    { Saved exit procedure pointer }
  ScreenBuffer: PChar;                  { Screen buffer pointer }
  AttribBuffer: PChar;                  { Screen attributes buffer pointer }
  ClientSize: TPoint;                   { Client area dimensions }
  Range: TPoint;                        { Scroll bar ranges }
  CharSize: TPoint;                     { Character cell size }
  CharAscent: Integer;                  { Character ascent }
  DC: HDC;                              { Global device context }
  PS: TPaintStruct;                     { Global paint structure }
  SaveFont: HFont;                      { Saved device context font }
  KeyBuffer: array[0..63] of Char;      { Keyboard type-ahead buffer }
  TimerIsSet: boolean;                  { Time was ellapsed }
  varColors: boolean;                   { Can change screen colors }
  videoIsSlow: boolean;                 { Scrolling is faster than redrawing }

{ Sound Area }

const
     soundSize = 11025;
     wavHdr: array [0..43] of byte = (
        $52, $49, $46, $46, $ff, $ff, $ff, $ff, $57, $41, $56, $45, $66, $6d, $74, $20,
        $10, $00, $00, $00, $01, $00, $01, $00, $11, $2b, $00, $00, $11, $2b, $00, $00,
        $01, $00, $08, $00, $64, $61, $74, $61, $ff, $ff, $ff, $ff);

type
  tSound = array [0.. sizeof (wavHdr) + soundSize-1] of byte;

var
  pSound: ^tSound;

{ Special keys table }

type SpecialKeyAction = record
         Key: word;
         BasicChar, CtlChar: char;
     end;

const
  SpecialKeysCount = 22;
  SpecialKeys: array[1..SpecialKeysCount] of SpecialKeyAction = (
     (Key: VK_F1;  basicChar: #59;  ctlChar: #94),
     (Key: VK_F2;  basicChar: #60;  ctlChar: #95),
     (Key: VK_F3;  basicChar: #61;  ctlChar: #96),
     (Key: VK_F4;  basicChar: #62;  ctlChar: #97),
     (Key: VK_F5;  basicChar: #63;  ctlChar: #98),
     (Key: VK_F6;  basicChar: #64;  ctlChar: #99),
     (Key: VK_F7;  basicChar: #65;  ctlChar: #100),
     (Key: VK_F8;  basicChar: #66;  ctlChar: #101),
     (Key: VK_F9;  basicChar: #67;  ctlChar: #102),
     (Key: VK_F10; basicChar: #68;  ctlChar: #103),
     (Key: VK_F11; basicChar: #69;  ctlChar: #104),
     (Key: VK_F12; basicChar: #70;  ctlChar: #105),

     (Key: VK_INSERT; basicChar: #82;  ctlChar: #255),
     (Key: VK_DELETE; basicChar: #83;  ctlChar: #83),
     (Key: VK_HOME;   basicChar: #71;  ctlChar: #119),
     (Key: VK_END;    basicChar: #79;  ctlChar: #117),

     (Key: VK_PRIOR; basicChar: #73;  ctlChar: #132),
     (Key: VK_NEXT;  basicChar: #81;  ctlChar: #118),
     (Key: VK_UP;    basicChar: #72;  ctlChar: #72),
     (Key: VK_DOWN;  basicChar: #80;  ctlChar: #80),
     (Key: VK_LEFT;  basicChar: #75;  ctlChar: #115),
     (Key: VK_RIGHT; basicChar: #77;  ctlChar: #116)
  );

{ Return the smaller of two integer values }

function Min(X, Y: Integer): Integer;
begin
  if X < Y then Min := X else Min := Y;
end;

{ Return the larger of two integer values }

function Max(X, Y: Integer): Integer;
begin
  if X > Y then Max := X else Max := Y;
end;

{ Allocate device context }

procedure InitDeviceContext;
begin
  if Painting then
    DC := BeginPaint(CrtWindow, PS)
  else
    DC := GetDC(CrtWindow);
  if selectOemFont then
    SaveFont := SelectObject(DC, GetStockObject(OEM_Fixed_Font))
  else
    SaveFont := SelectObject(DC, GetStockObject(System_Fixed_Font));
end;

{ Release device context }

procedure DoneDeviceContext;
begin
  SelectObject(DC, SaveFont);
  if Painting then
    EndPaint(CrtWindow, PS) else
    ReleaseDC(CrtWindow, DC);
end;

{ Show caret }

procedure ShowCursor;
begin
  CreateCaret(CrtWindow, 0, CharSize.X, 2);
  SetCaretPos((currentWindow.left+Cursor.X) * CharSize.X,
    (currentWindow.top+Cursor.Y) * CharSize.Y + CharAscent);
  ShowCaret(CrtWindow);
end;

{ Hide caret }

procedure HideCursor;
begin
  DestroyCaret;
end;

procedure ForceCursor;
begin
   if not forcedCur then showCursor;
   forcedCur := true;
end;

procedure unForceCursor;
begin
    if forcedCur then HideCursor;
    forcedCur := false;
end;


{ Terminate CRT window }

procedure Terminate;
begin
  if Focused and Reading then HideCursor;
  Halt(255);
end;

{ Set cursor position }

procedure CursorTo(X, Y: Integer);
var w, h: integer;
begin
  with currentWindow do
      begin
        w := right-left;
        h := bottom-top;
      end;
  Cursor.X := Max(0, Min(X, w));
  Cursor.Y := Max(0, Min(Y, h));
end;

{ Return pointer to location in screen buffer }

function ScreenPtr(X, Y: Integer): PChar;
begin
  ScreenPtr := @ScreenBuffer[Y * ScreenSize.X + X];
end;

{ Return pointer to location in attribute buffer }

function AttribPtr(X, Y: Integer): PChar;
begin
  AttribPtr := @AttribBuffer[Y * ScreenSize.X + X];
end;

{ read screen memory }

function getScreenChar (x, y: integer): char;
begin
    getScreenChar := ScreenPtr (x-1, y-1)^;
end;

{ read attributes memory }

function getScreenAttrib (x, y: integer): byte;
begin
    getScreenAttrib := ord (attribPtr (x-1, y-1)^);
end;

{ calculates the color number }

function colorNumber (n: byte): TColorRef;
var c: TColorRef;
begin
  case n of
       Black:         c := RGB (0, 0, 0);
       Blue:          c := RGB (0, 0, 255);
       Green:         c := RGB (0, 255, 0);
       Cyan:          c := RGB (0, 255, 255);
       Red:           c := RGB (255, 0, 0);
       Magenta:	      c := RGB (192, 0, 192);
       Brown:         c := RGB (100, 64, 64);
       LightGray:     c := RGB (192, 192, 192);
       DarkGray:      c := RGB (128, 128, 128);
       LightBlue:     c := RGB (128, 128, 255);
       LightGreen:    c := RGB (128, 255, 128);
       LightCyan:     c := RGB (128, 255, 255);
       LightRed:      c := RGB (255, 128, 128);
       LightMagenta:  c := RGB (255, 128, 255);
       Yellow:        c := RGB (255, 255, 0);
       White:         c := RGB (255, 255, 255);
  end;
  colorNumber := c;
end;

{ Update text on cursor line }

procedure ShowText(L, R: Integer; Y: integer);
var p: PChar;
    nc: integer;
    oldAttr: char;
    LL, attr: byte;
begin
  if L < R then
  begin
    if not painting then
        InitDeviceContext;
    with currentWindow do
      begin
         L := L + left;
         R := R + left;
         Y := Y + top;
      end;
    while L < R do
        begin
            p := attribPtr (L, Y);
            attr := ord(p^);
            LL := L;
            repeat
                oldAttr := p^;
                inc (p);
                LL := LL + 1;
            until (LL >= R) or (oldAttr <> p^);
            nc := LL - L;

            setTextColor (DC, colorNumber (attr and $f));
            setBkColor   (DC, colorNumber (attr shr 4));

            TextOut(DC, L * CharSize.X,
                        Y * CharSize.Y, ScreenPtr(L, Y), nc);
            L := L + nc;
        end;
    if not painting then
        DoneDeviceContext;
  end;
end;

{ Write text buffer to CRT window }

procedure WriteBuf(Buffer: PChar; Count: Word);
var
  L, R: Integer;

procedure NewLine;
var
  oldBrush, newBrush: HBrush;
  w, h, y: integer;
  s: string;
  rect: tRect;
begin
  ShowText(L, R, Cursor.Y);
  L := 0;
  R := 0;
  Inc(Cursor.Y);
  if Cursor.Y = currentWindow.bottom-currentWindow.top+1 then
  begin
    if not painting then
        InitDeviceContext;
    Dec(Cursor.Y);
    with currentWindow do
      begin
        w := right-left+1;
        h := bottom-top+1;

        for y := top to bottom-1 do
          begin
            move (ScreenPtr (left, y+1)^, ScreenPtr (left, y)^, w);
            move (AttribPtr (left, y+1)^, AttribPtr (left, y)^, w);
          end;

        FillChar(ScreenPtr(left, bottom)^, w, ' ');
        FillChar(AttribPtr(left, bottom)^, w, textAttr);

        getWindowRect (crtWindow, rect);
        if videoIsSlow and (getActiveWindow = crtWindow) and
           (rect.bottom < getSystemMetrics (SM_CYSCREEN) - 32) then
            begin
              bitBlt (DC, left*CharSize.X, top*CharSize.Y, w*CharSize.X, (h-1)*CharSize.Y,
                        DC, left*CharSize.X, (top+1)*CharSize.Y, SRCCOPY);

                newBrush := createSolidBrush (colorNumber (textAttr shr 4));
                oldBrush := selectObject (DC, newBrush);
                patBlt (DC, left*CharSize.X, bottom*CharSize.Y,
                            w*CharSize.X, CharSize.Y, PATCOPY);
                selectObject (DC, oldBrush);
                deleteObject (newBrush);
            end
        else
            invalidateRect (crtWindow, NIL, false);
      end;
    if not painting then
      DoneDeviceContext;
    UpdateWindow(CrtWindow);
  end;
end;

begin
  InitWinCrt;
  L := Cursor.X;
  R := Cursor.X;
  while Count > 0 do
  begin
    case Buffer^ of
      #32..#255:
	begin
          with currentWindow do
            begin                        {************* verificar ****************}
	      ScreenPtr(left+Cursor.X, top+Cursor.Y)^ := Buffer^;
	      AttribPtr(left+Cursor.X, top+Cursor.Y)^ := chr(textAttr);
	      Inc(Cursor.X);
              if Cursor.X > R then R := Cursor.X;
              if Cursor.X = (right+1) then
                  begin
                      cursor.X := 0;
                      NewLine;
                  end;
            end;
	end;
      #13:
         cursor.X := 0;
      #10:
	NewLine;
      #8:
	if Cursor.X > 0 then
          with currentWindow do
  	    begin
	      Dec(Cursor.X);
	      ScreenPtr(left+Cursor.X, top+Cursor.Y)^ := ' ';
	      AttribPtr(left+Cursor.X, top+Cursor.Y)^ := chr(textAttr);
	      if Cursor.X < L then L := Cursor.X;
	    end;
      #7:
        MessageBeep(0);
    end;
    Inc(Buffer);
    Dec(Count);
  end;
  ShowText(L, R, Cursor.Y);
end;

{ Write character to CRT window }

procedure WriteChar(Ch: Char);
begin
  WriteBuf(@Ch, 1);
end;

{ Return keyboard status }

function KeyPressed: Boolean;
var
  M: TMsg;
begin
  InitWinCrt;
  while PeekMessage(M, 0, 0, 0, pm_Remove) do
  begin
    if M.Message = wm_Quit then Terminate;
    TranslateMessage(M);
    DispatchMessage(M);
  end;
  KeyPressed := KeyCount > 0;
end;

{ Read key from CRT window }

function ReadKey: Char;
begin
  if forcedCur then
      begin
          forcedCur := false;
          hideCursor;
      end;

  if not KeyPressed then
  begin
    Reading := True;
    if Focused then ShowCursor;
    repeat WaitMessage until KeyPressed;
    if Focused then HideCursor;
    Reading := False;
  end;
  ReadKey := KeyBuffer[0];
  Dec(KeyCount);
  Move(KeyBuffer[1], KeyBuffer[0], KeyCount);
end;

{ Read text buffer from CRT window }

function ReadBuf(Buffer: PChar; Count: Word): Word;
var
  Ch: Char;
  I: Word;
begin
  I := 0;
  repeat
    Ch := ReadKey;
    case Ch of
      #8:
	if I > 0 then
	begin
	  Dec(I);
	  WriteChar(#8);
	end;
      #32..#255:
	if I < Count - 2 then
	begin
	  Buffer[I] := Ch;
	  Inc(I);
	  WriteChar(Ch);
	end;
    end;
  until (Ch = #13) or (CheckEOF and (Ch = #26));
  Buffer[I] := Ch;
  Inc(I);
  if Ch = #13 then
  begin
    Buffer[I] := #10;
    Inc(I);
    WriteChar(#13);
    WriteChar(#10);
  end;
  ReadBuf := I;
end;

{ Set cursor position }

procedure GotoXY(X, Y: Integer);
begin
  CursorTo(X - 1, Y - 1);
end;

{ Return cursor X position }

function WhereX: Integer;
begin
  WhereX := Cursor.X + 1;
end;

{ Return cursor Y position }

function WhereY: Integer;
begin
  WhereY := Cursor.Y + 1;
end;

{ Clear screen }

procedure ClrScr;
var y: integer;
begin
  InitWinCrt;
  with currentWindow do
    begin
      for y := top to bottom do
        begin
          fillchar (ScreenPtr (left, y)^, right-left+1, ' ');
          fillchar (AttribPtr (left, y)^, right-left+1, textAttr);
        end;
      end;
  Cursor.X := 0;
  Cursor.Y := 0;
  InvalidateRect(CrtWindow, nil, False);
  UpdateWindow (CrtWindow);
end;

{ Clear to end of line }

procedure ClrEol;
var w: integer;
begin
  InitWinCrt;
  with currentWindow do
      begin
          w := right-left+1;
          fillchar (ScreenPtr (left+Cursor.X, top+Cursor.Y)^, w-Cursor.X, ' ');
          fillchar (AttribPtr (left+Cursor.X, top+Cursor.Y)^, w-Cursor.X, textAttr);
      end;
  ShowText(Cursor.X, ScreenSize.X, Cursor.Y);
end;

{ Line insert }

procedure InsLine;
var y, w, h: integer;
begin
   InitWinCrt;
   with currentWindow do
      begin
          w := right-left+1;
          h := bottom-top+1;
          for y := top+h-2 downto top+Cursor.y do
            begin
              move (ScreenPtr(left, y)^,ScreenPtr(left, y+1)^, w);
              move (AttribPtr(left, y)^,AttribPtr(left, y+1)^, w);
            end;
          fillChar (ScreenPtr(left, top+Cursor.y)^, w, ' ');
          fillChar (AttribPtr(left, top+Cursor.y)^, w, textAttr);
      end;
  InvalidateRect(CrtWindow, nil, False);
  UpdateWindow (CrtWindow);
end;

{ Line delete }

procedure DelLine;
var y, w, h: integer;
begin
   InitWinCrt;
   with currentWindow do
      begin
          w := right-left+1;
          h := bottom-top+1;
          for y := top+Cursor.y to top+h-2 do
            begin
              move (ScreenPtr(left, y+1)^,ScreenPtr(left, y)^, w);
              move (AttribPtr(left, y+1)^,AttribPtr(left, y)^, w);
            end;
          fillChar (ScreenPtr(left, top+h-1)^, w, ' ');
          fillChar (AttribPtr(left, top+h-1)^, w, textAttr);
      end;
  InvalidateRect(CrtWindow, nil, False);
  UpdateWindow (CrtWindow);
end;

{ text color select }

procedure TextColor(Color: Byte);
begin
    InitWinCrt;
    if varColors then  textAttr := (textAttr and $f0) or (color and $f);
end;

{ background color select }

procedure TextBackground(Color: Byte);
begin
    InitWinCrt;
    if varColors then  textAttr := (textAttr and $0f) or (color shl 4);
end;

{ auxiliary color setting }

procedure LowVideo;
begin
   InitWinCrt;
   if varColors then  textAttr := textAttr and not HighIntens;
end;

procedure HighVideo;
begin
   InitWinCrt;
   if varColors then  textAttr := textAttr or HighIntens;
end;

procedure NormVideo;
begin
   InitWinCrt;
   if varColors then  textAttr := defaultAttrib;
end;

procedure canChangeColors (canChange: boolean);
begin
   InitWinCrt;
   varColors := canChange;
end;

{ delay }

procedure Delay(MS: Word);
begin
    InitWinCrt;
    timerIsSet := false;
    if SetTimer (CrtWindow, 100, MS, NIL) = 0 then
        exit;
    repeat
        waitMessage;
        keypressed;
    until timerIsSet;
    KillTimer (CrtWindow, 100);
end;

{ select active area }

procedure Window (X1, Y1, X2, Y2: Byte);
begin
  Cursor.X := 0;
  Cursor.Y := 0;
  with currentWindow do
      begin
          left := X1-1;  right  := X2-1;
          top  := Y1-1;  bottom := Y2-1;
      end;
end;

{ text mode - not implemented }

procedure TextMode(Mode: Integer);
begin
   clrscr;
   lastMode := mode;
end;

{ sound }

procedure Sound(Hz: Word);
var l: longint;
    p, period: integer;
begin
    if psound <> NIL then
       noSound;
    getMem (psound, sizeof (psound^)+2);  {1 second}
    period := 11025 div hz;
    p := sizeof (wavHdr);
    l := 0;
    while p <= soundSize-period do
        begin
            fillchar (psound^[p], period div 2 + 1, $60);
            p := p + period div 2;
            fillchar (psound^[p], period-(period div 2)+1, $a0);
            p := sizeof (wavHdr) +
                 integer (longint(11025)* l div longint(hz));
            l := l + 1;
        end;
    psound^[p-1] := $80;
    l := p - sizeof (wavHdr);
    move (l, wavHdr[40], 4);
    l := l + 36;
    move (l, wavHdr[4], 4);
    move (wavHdr, psound^, sizeof (wavHdr));
    sndPlaySound (pchar (psound), snd_async + snd_memory + snd_loop);
end;

{ stop sound }

procedure NoSound;
begin
    if psound <> NIL then
        begin
            sndPlaySound (NIL, SND_ASYNC);
            freeMem (psound, sizeof (psound^)+2);  {1 second}
            psound := NIL;
        end;
end;

{ put data on the clipboard (data must be null terminated) }

procedure putClipBoard (data: PChar);
var
  p: pointer;
  hmem: THandle;
  size: word;
begin
  if not openClipboard (crtWindow) then
     exit;
  emptyClipboard;
  size := strLen (data) + 1;
  hmem := globalAlloc (GHND, size);
  p := globalLock (hmem);
  move (data^, p^, size);
  setClipboardData (CF_TEXT, hmem);
  globalUnlock (hmem);
  closeClipboard;
end;

{ get data from the clipboard }

procedure getClipBoard (data: PChar; maxSize: word);
var
  nread: longint;
  p: PChar;
  hmem: THandle;
begin
  if maxSize = 0 then exit;
  if not openClipboard (crtWindow) then exit;
  hmem := getClipboardData (CF_TEXT);
  if hmem <> 0 then
    begin
      p := globalLock (hmem);
      nread := strlen (p) + 1;
      if nread > maxSize then nread := maxSize;
      move (p^, data^, nread);
      data[nread-1] := #$0;   { forced for overflows... }
      globalUnlock (hmem);
    end
  else
    data[0] := #$0;
  closeClipboard;
end;

{ wm_Create message handler }

procedure WindowCreate;
begin
  Created := True;
  GetMem(ScreenBuffer, ScreenSize.X * ScreenSize.Y);
  FillChar(ScreenBuffer^, ScreenSize.X * ScreenSize.Y, ' ');
  GetMem(AttribBuffer, ScreenSize.X * ScreenSize.Y);
  FillChar(AttribBuffer^, ScreenSize.X * ScreenSize.Y, textAttr);
  with currentWindow do
      begin
          left := 0;  right  := ScreenSize.X-1;
          top  := 0;  bottom := ScreenSize.Y-1;
      end;
end;

{ wm_Paint message handler }

procedure WindowPaint;
var
  X1, X2, Y1, Y2: Integer;
begin
  Painting := True;
  InitDeviceContext;
  X1 := Max(0, PS.rcPaint.left div CharSize.X);
  X2 := Min(ScreenSize.X,
    (PS.rcPaint.right + CharSize.X - 1) div CharSize.X);
  Y1 := Max(0, PS.rcPaint.top div CharSize.Y);
  Y2 := Min(ScreenSize.Y,
    (PS.rcPaint.bottom + CharSize.Y - 1) div CharSize.Y);
  while Y1 < Y2 do
    begin
      showText (X1-currentWindow.left, X2-currentWindow.left, Y1-currentWindow.top);
      Inc(Y1);
    end;
  DoneDeviceContext;
  Painting := False;
end;

{ wm_GetMinMaxInfo message handler }

procedure WindowMinMaxInfo(MinMaxInfo: PMinMaxInfo);
var
  X, Y: Integer;
  Metrics: TTextMetric;
begin
  InitDeviceContext;
  GetTextMetrics(DC, Metrics);
  CharSize.X := Metrics.tmMaxCharWidth;
  CharSize.Y := Metrics.tmHeight + Metrics.tmExternalLeading;
  CharAscent := Metrics.tmAscent;
  X := Min(ScreenSize.X * CharSize.X,
       GetSystemMetrics(sm_CXScreen)) + GetSystemMetrics(sm_CXFrame) * 2;
  Y := Min(ScreenSize.Y * CharSize.Y  + GetSystemMetrics(sm_CYCaption),
       GetSystemMetrics(sm_CYScreen)) + GetSystemMetrics(sm_CYFrame) * 2;
  MinMaxInfo^[1].x := X;
  MinMaxInfo^[1].y := Y;
  MinMaxInfo^[3].x := CharSize.X * 16 + GetSystemMetrics(sm_CXFrame) * 2;
  MinMaxInfo^[3].y := CharSize.Y * 4 +  GetSystemMetrics(sm_CYFrame) * 2 +
                                        GetSystemMetrics(sm_CYCaption);
  MinMaxInfo^[4].x := X;
  MinMaxInfo^[4].y := Y;
  DoneDeviceContext;
end;

{ wm_Char message handler }

procedure WindowChar(Ch: Char);
begin
{ if CheckBreak and (Ch = #3) then Terminate; }
  if KeyCount < SizeOf(KeyBuffer) then
   begin
    if ord(Ch) = VK_BACK then
        if GetKeyState(vk_Control) < 0 then KeyBuffer[KeyCount] := #127
                                       else KeyBuffer[KeyCount] := #08
    else
    if ord(Ch) = VK_RETURN then
        if GetKeyState(vk_Control) < 0 then KeyBuffer[KeyCount] := #10
                                       else KeyBuffer[KeyCount] := #13
    else
        KeyBuffer[KeyCount] := Ch;
    Inc(KeyCount);
   end;
end;

{ wm_KeyDown message handler }

function WindowKeyDown(KeyDown: Byte): boolean;
var
  AltDown, CtrlDown: Boolean;
  I: Integer;

const
    ALTCODES: array [ord('A')..ord('Z')] of byte = (
        $1E, $30, $2E, $20, $12, $21, $22, $23, $17, $24,
        $25, $26, $32, $31, $18, $19, $10, $13, $1F, $14,
        $16, $2F, $11, $2D, $15, $2C
    );
    ALTNUMCODES: array [ord('0')..ord('9')] of byte = (
        $81, $78, $79, $7A, $7B, $7C, $7D, $7E, $7F, $80
    );

begin
  windowKeyDown := true;
  if CheckBreak and (KeyDown = vk_Cancel) then   {control-break}
      Terminate;

  AltDown := getKeyState(vk_Menu) < 0;
  if altDown then
    if keyDown in [ord('A')..ord('Z'), ord('0')..ord('9')] then
        begin
          KeyBuffer[KeyCount] := #0;
          Inc(KeyCount);
          if keyDown in [ord('A')..ord('Z')] then
              KeyBuffer[KeyCount] := chr(ALTCODES[keyDown])
          else
              KeyBuffer[KeyCount] := chr(ALTNUMCODES[keyDown]);
          Inc(KeyCount);
          exit;
        end;

  CtrlDown := GetKeyState(vk_Control) < 0;
  if not ctrlDown then
    if (KeyDown in [VK_ESCAPE, VK_TAB]) and(GetKeyState(vk_Menu) < 0) then
    begin
        windowKeyDown := false;
        exit;
    end;

  if KeyCount <= SizeOf(KeyBuffer)-2 then
    for I := 1 to SpecialKeysCount do
      with SpecialKeys[I] do
        if (Key = KeyDown) then
          begin
              KeyBuffer[KeyCount] := #0;
              Inc(KeyCount);
              if CtrlDown then
                 KeyBuffer[KeyCount] := ctlChar
              else                                { simulating cut/paste }
                 if (ctlChar = #$ff) and (GetKeyState (vk_Shift) < 0) then
                    KeyBuffer[KeyCount] := #$fe
                 else
                    KeyBuffer[KeyCount] := basicChar;
              Inc(KeyCount);
              exit;
          end;
end;

{ wm_SetFocus message handler }

procedure WindowSetFocus;
begin
  Focused := True;
  if Reading or ForcedCur then ShowCursor;
  if checkFocus then
      begin
          KeyBuffer[KeyCount] := #$ee;
          inc (KeyCount);
      end;
end;

{ wm_KillFocus message handler }

procedure WindowKillFocus;
begin
  if Reading or ForcedCur then HideCursor;
  Focused := False;
  if checkFocus then
      begin
          KeyBuffer[KeyCount] := #$ef;
          inc (KeyCount);
      end;
end;

{ wm_Destroy message handler }

procedure WindowDestroy;
begin
  KillTimer (crtWindow, 100);
  FreeMem(ScreenBuffer, ScreenSize.X * ScreenSize.Y);
  FreeMem(AttribBuffer, ScreenSize.X * ScreenSize.Y);
  Longint(Cursor) := 0;
  PostQuitMessage(0);
  Created := False;
end;

{ wm_timer function }

procedure WindowTimer;
begin
    timerIsSet := true;
end;

{ CRT window procedure }
function CrtWinProc(Window: HWnd; Message, WParam: Word;
 LParam: Longint): Longint;
var result: longint;
label defproc;
begin
  CrtWinProc := 0;
  CrtWindow := Window;
  if hasAlternateWinProc then
      begin
          alternateWinProc (Window, Message, WParam, LParam, result);
          if result <> 0 then
              begin
                  CrtWinProc := result;
                  exit;
              end;
      end;
  case Message of
    wm_Create: WindowCreate;
    wm_Paint: WindowPaint;
    wm_GetMinMaxInfo: WindowMinMaxInfo(PMinMaxInfo(LParam));
    wm_Char: WindowChar(Char(WParam));
    wm_KeyDown: WindowKeyDown(Byte(WParam));
    wm_SetFocus: WindowSetFocus;
    wm_KillFocus: WindowKillFocus;
    wm_Destroy: WindowDestroy;
    wm_Timer: WindowTimer;
    mm_wom_done: if hasmmCallback then
                    mmCallback (Window, WParam, LParam)
                 else
                    goto defProc;
    wm_SysKeyDown:
        begin
            if checkBreak then
                goto defProc
            else
                if not WindowKeyDown(Byte(WParam)) then goto defProc;
        end;
  else
    begin
defProc:
        CrtWinProc := DefWindowProc(Window, Message, WParam, LParam);
    end;
  end;
end;

{ Text file device driver output function }

function CrtOutput(var F: TTextRec): Integer; far;
begin
  if F.BufPos <> 0 then
  begin
    WriteBuf (PChar(F.BufPtr), F.BufPos);
    F.BufPos := 0;
    KeyPressed;
  end;
  CrtOutput := 0;
end;

{ Text file device driver input function }

function CrtInput(var F: TTextRec): Integer; far;
begin
  F.BufEnd := ReadBuf(PChar(F.BufPtr), F.BufSize);
  F.BufPos := 0;
  CrtInput := 0;
end;

{ Text file device driver close function }

function CrtClose(var F: TTextRec): Integer; far;
begin
  CrtClose := 0;
end;

{ Text file device driver open function }

function CrtOpen(var F: TTextRec): Integer; far;
begin
  if F.Mode = fmInput then
  begin
    F.InOutFunc := @CrtInput;
    F.FlushFunc := nil;
  end else
  begin
    F.Mode := fmOutput;
    F.InOutFunc := @CrtOutput;
    F.FlushFunc := @CrtOutput;
  end;
  F.CloseFunc := @CrtClose;
  CrtOpen := 0;
end;

{ Assign text file to CRT device }

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

{ Create CRT window if required }

procedure InitWinCrt;
var resp: array [0..79] of char;
    n, corf, corl, erro: integer;
    Metrics: TTextMetric;
    DC: hdc;
begin
  if not Created then
  begin
    varColors := true;
    videoIsSlow := false;
    corf := defaultAttrib shr 4;
    corl := defaultAttrib and $f;
    lastMode := CO80;

    n := GetPrivateProfileString('VIDEO', 'CORESFIXAS', 'NAO', resp, 80, 'DOSVOX.INI');
    if (n <> 0) and (upcase(resp[0]) = 'S') then varColors := false;
    n := GetPrivateProfileString('VIDEO', 'LENTO', 'NAO', resp, 80, 'DOSVOX.INI');
    if (n <> 0) and (upcase(resp[0]) = 'S') then videoIsSlow := true;
    n := GetPrivateProfileString('VIDEO', 'CORFUNDO', '0', resp, 80, 'DOSVOX.INI');
    if (n <> 0) then val (strPas (resp), corf, erro);
    n := GetPrivateProfileString('VIDEO', 'CORLETRA', '7', resp, 80, 'DOSVOX.INI');
    if (n <> 0) then val (strPas (resp), corl, erro);
    textAttr := (corf shl 4) or corl;

    dc := getDC (0);
    GetTextMetrics(DC, Metrics);
    releaseDC (0, dc);
    WindowSize.x := Metrics.tmMaxCharWidth * 80 + GetSystemMetrics(sm_CXFrame) * 2;
    WindowSize.y := (Metrics.tmHeight + Metrics.tmExternalLeading) * ScreenSize.Y +
                    GetSystemMetrics(sm_CYFrame) * 2 + GetSystemMetrics(sm_CYCaption);

    CrtWindow := CreateWindow(
      CrtClass.lpszClassName,
      WindowTitle,
      ws_OverlappedWindow,
      WindowOrg.X, WindowOrg.Y,
      WindowSize.X, WindowSize.Y,
      0,
      0,
      HInstance,
      nil);
    ShowWindow(CrtWindow, CmdShow);
    UpdateWindow(CrtWindow);
  end;
end;

{ Destroy CRT window if required }

procedure DoneWinCrt;
begin
  if Created then
     begin
        while keypressed do readkey;
        DestroyWindow(CrtWindow);
     end;
  Halt(0);
end;

{ WinCrt unit exit procedure }

procedure ExitWinCrt; far;
var
  P: PChar;
  Message: TMsg;
  Title: array[0..127] of Char;
begin
  ExitProc := SaveExit;
  if Created and (ErrorAddr = nil) then
  begin
    P := WindowTitle;
    WVSPrintF(Title, InactiveTitle, P);
    SetWindowText(CrtWindow, Title);
    EnableMenuItem(GetSystemMenu(CrtWindow, False), sc_Close, mf_Enabled);
    CheckBreak := False;
    while GetMessage(Message, 0, 0, 0) do
    begin
      TranslateMessage(Message);
      DispatchMessage(Message);
    end;
  end;
end;

begin
  CrtWindow := 0;
  hasAlternateWinProc := false;
  hasmmCallback := false;
  if HPrevInst = 0 then
  begin
    CrtClass.hInstance := HInstance;
    CrtClass.hIcon := LoadIcon(0, idi_Application);
    CrtClass.hCursor := LoadCursor(0, idc_Arrow);
    CrtClass.hbrBackground := getStockObject (BLACK_BRUSH);
    RegisterClass(CrtClass);
  end;
  AssignCrt(Input);
  Reset(Input);
  AssignCrt(Output);
  Rewrite(Output);
  GetModuleFileName(HInstance, WindowTitle, SizeOf(WindowTitle));
  OemToAnsi(WindowTitle, WindowTitle);
  SaveExit := ExitProc;
  ExitProc := @ExitWinCrt;
  pSound := NIL;
end.

