freepascal.compiler/packages/rtl-console/src/win16/video.pp

{
    This file is part of the Free Pascal run time library.
    Copyright (c) 2015 by Nikolay Nikolov
    member of the Free Pascal development team

    Video unit for Win16

    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.

 **********************************************************************}
{$IFNDEF FPC_DOTTEDUNITS}
unit video;
{$ENDIF FPC_DOTTEDUNITS}

{$mode objfpc}
{$modeswitch advancedrecords}

{ smart callbacks: on }
{$K+}

interface

{$IFDEF FPC_DOTTEDUNITS}
uses
  WinApi.WinTypes;
{$ELSE FPC_DOTTEDUNITS}
uses
  WinTypes;
{$ENDIF FPC_DOTTEDUNITS}

{$I videoh.inc}

var
  KeyEventWndProc: WNDPROC;

implementation

{$IFDEF FPC_DOTTEDUNITS}
uses
  WinApi.WinProcs, System.Unicode.Graphemebreakproperty, System.Unicode.Eastasianwidth, System.CharSet;
{$ELSE FPC_DOTTEDUNITS}
uses
  WinProcs, graphemebreakproperty, eastasianwidth, charset;
{$ENDIF FPC_DOTTEDUNITS}

{$I video.inc}

const
  ColorRefs: array[0..15] of COLORREF=
    ($000000,$aa0000,$00aa00,$aaaa00,$0000aa,$aa00aa,$0055aa,$aaaaaa,
     $555555,$ff5555,$55ff55,$ffff55,$5555ff,$ff55ff,$55ffff,$ffffff);

var
  VideoWindow: HWND;

procedure WindowPaint(hwnd: HWND);
var
  dc: HDC;
  ps: PAINTSTRUCT;
  oldfont: HFONT;
  oldtextcolor,oldbkcolor: COLORREF;
  Metrics: TEXTMETRIC;
  y,y1,y2,x,x1,x2: SmallInt;
  ch: TVideoCell;
  CharWidth,CharHeight: SmallInt;
begin
  dc:=BeginPaint(hwnd,FarAddr(ps));
  { don't do anything, before the video unit has been fully initialized... }
  if videobuf<>nil then
  begin
    oldfont:=SelectObject(dc,GetStockObject(OEM_FIXED_FONT));
    GetTextMetrics(dc,FarAddr(Metrics));
    CharWidth:=Metrics.tmMaxCharWidth;
    CharHeight:=Metrics.tmHeight+Metrics.tmExternalLeading;
    x1:=ps.rcPaint.left div CharWidth;
    x2:=1+ps.rcPaint.right div CharWidth;
    y1:=ps.rcPaint.top div CharHeight;
    y2:=1+ps.rcPaint.bottom div CharHeight;
    if x1<0 then
      x1:=0;
    if y1<0 then
      y1:=0;
    if x2>=ScreenWidth then
      x2:=ScreenWidth-1;
    if y2>=ScreenHeight then
      y2:=ScreenHeight-1;
    oldtextcolor:=GetTextColor(dc);
    oldbkcolor:=GetBkColor(dc);
    for y:=y1 to y2 do
      for x:=x1 to x2 do
      begin
        ch:=videobuf^[y*ScreenWidth+x];
        SetTextColor(dc,ColorRefs[(ch shr 8) and 15]);
        SetBkColor(dc,ColorRefs[(ch shr 12) and 15]);
        TextOut(dc,x*CharWidth,y*CharHeight,FarAddr(ch),1);
      end;
    SetTextColor(dc,oldtextcolor);
    SetBkColor(dc,oldbkcolor);
    SelectObject(dc,oldfont);
  end;
  EndPaint(hwnd,FarAddr(ps));
end;

function MainWndProc(hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; export;
begin
  case msg of
    WM_KEYDOWN,
    WM_KEYUP,
    WM_SYSKEYDOWN,
    WM_SYSKEYUP:
      MainWndProc:=KeyEventWndProc(hwnd,msg,wParam,lParam);
    WM_PAINT:
      WindowPaint(hwnd);
    WM_DESTROY:
      begin
        VideoWindow:=0;
        PostQuitMessage(0);
      end;
    else
      MainWndProc:=DefWindowProc(hwnd,msg,wParam,lParam);
  end;
end;

procedure InitWinClass;
var
  wc: WNDCLASS;
begin
  wc.style:=0;
  wc.lpfnWndProc:=@MainWndProc;
  wc.cbClsExtra:=0;
  wc.cbWndExtra:=0;
  wc.hInstance:=HInstance;
  wc.hIcon:=LoadIcon(0,IDI_APPLICATION);
  wc.hCursor:=LoadCursor(0,IDC_ARROW);
  wc.hbrBackground:=GetStockObject(BLACK_BRUSH);
  wc.lpszMenuName:=nil;
  wc.lpszClassName:='FPCConsoleWndClass';
  if not RegisterClass(FarAddr(wc)) then
  begin
    MessageBox(0,'Error registering window class',nil,MB_OK or MB_ICONHAND or MB_TASKMODAL);
    Halt(1);
  end;
end;

procedure InitWindow;
begin
  VideoWindow:=CreateWindow(
    'FPCConsoleWndClass',
    'Console',
    WS_OVERLAPPEDWINDOW,
    CW_USEDEFAULT,
    CW_USEDEFAULT,
    CW_USEDEFAULT,
    CW_USEDEFAULT,
    0,
    0,
    HInstance,
    nil);
  if VideoWindow=0 then
  begin
    MessageBox(0,'Error creating window',nil,MB_OK or MB_ICONHAND or MB_TASKMODAL);
    Halt(1);
  end;
  ShowWindow(VideoWindow,CmdShow);
  UpdateWindow(VideoWindow);
end;

procedure ProcessMessages;
var
  m: MSG;
begin
  while PeekMessage(FarAddr(m),0,0,0,1) do
  begin
    TranslateMessage(FarAddr(m));
    DispatchMessage(FarAddr(m));
  end;
end;

procedure SysInitVideo;
begin
  if hPrevInst=0 then
    InitWinClass;
  InitWindow;
  ProcessMessages;
  ScreenWidth:=80;
  ScreenHeight:=25;
end;

procedure SysDoneVideo;
begin
  if VideoWindow<>0 then
  begin
    if not DestroyWindow(VideoWindow) then
      MessageBox(0,'Error destroying window',nil,MB_OK or MB_ICONHAND or MB_TASKMODAL);
    VideoWindow:=0;
  end;
end;

procedure SysUpdateScreen(Force: Boolean);
var
  dc: HDC;
  oldfont: HFONT;
  oldtextcolor,oldbkcolor: COLORREF;
  Metrics: TEXTMETRIC;
  y,x: SmallInt;
  ch: TVideoCell;
  CharWidth,CharHeight: SmallInt;
begin
  if VideoWindow<>0 then
  begin
    dc:=GetDC(VideoWindow);
    if dc=0 then
    begin
      MessageBox(0,'GetDC() failed',nil,MB_OK or MB_ICONHAND or MB_TASKMODAL);
      exit;
    end;
    oldfont:=SelectObject(dc,GetStockObject(OEM_FIXED_FONT));
    GetTextMetrics(dc,FarAddr(Metrics));
    CharWidth:=Metrics.tmMaxCharWidth;
    CharHeight:=Metrics.tmHeight+Metrics.tmExternalLeading;
    oldtextcolor:=GetTextColor(dc);
    oldbkcolor:=GetBkColor(dc);
    for y:=0 to ScreenHeight-1 do
      for x:=0 to ScreenWidth-1 do
      begin
        ch:=videobuf^[y*ScreenWidth+x];
        if force or (ch<>oldvideobuf^[y*ScreenWidth+x]) then
        begin
          oldvideobuf^[y*ScreenWidth+x]:=videobuf^[y*ScreenWidth+x];
          SetTextColor(dc,ColorRefs[(ch shr 8) and 15]);
          SetBkColor(dc,ColorRefs[(ch shr 12) and 15]);
          TextOut(dc,x*CharWidth,y*CharHeight,FarAddr(ch),1);
        end;
      end;
    SetTextColor(dc,oldtextcolor);
    SetBkColor(dc,oldbkcolor);
    SelectObject(dc,oldfont);
    ReleaseDC(VideoWindow,dc);
  end;
  ProcessMessages;
end;

function SysGetCapabilities: Word;
begin
  SysGetCapabilities:=cpUnderLine+cpBlink+cpColor;
end;

procedure SysSetCursorPos(NewCursorX, NewCursorY: Word);
begin
  CursorX:=NewCursorX;
  CursorY:=NewCursorY;
end;

function SysGetCursorType: Word;
begin
end;

procedure SysSetCursorType(NewType: Word);
begin
end;

function SysSetVideoMode(const mode:Tvideomode):boolean;
begin
end;

const
  SysVideoDriver: TVideoDriver = (
    InitDriver                : @SysInitVideo;
    InitEnhancedDriver        : nil;
    DoneDriver                : @SysDoneVideo;
    UpdateScreen              : @SysUpdateScreen;
    UpdateScreenArea          : nil;
    ClearScreen               : nil;
    SetVideoMode              : @SysSetVideoMode;
    GetVideoModeCount         : nil;
    GetVideoModeData          : nil;
    SetCursorPos              : @SysSetCursorPos;
    GetCursorType             : @SysGetCursorType;
    SetCursorType             : @SysSetCursorType;
    GetCapabilities           : @SysGetCapabilities;
    GetActiveCodePage         : nil;
    ActivateCodePage          : nil;
    GetSupportedCodePageCount : nil;
    GetSupportedCodePage      : nil;
  );

begin
  KeyEventWndProc:=@DefWindowProc;
  SetVideoDriver(SysVideoDriver);
end.