unit WinGr;

{ Unit WinGr, Copr. 1996, 1998 Matthias Koeppe

  This unit is the Windows-mode equivalent of units
  Crt, Graph, Bgi, Gr, MetaGr, Drivers, GvDriver, MyMouse, MyFonts.
}

interface

{$ifndef Windows}
implementation
end.
{$endif}

{$ifdef VER80}
{$define DELF}
{$endif}
{$ifdef VER90}
{$define DELF}
{$endif}

{$ifdef DELF}
uses WinTypes,
  Messages,
  WinProcs,
  Objects,
  Drivers;
{$else}
uses WinTypes, Win31,
  WinProcs, Objects, Drivers;
{$endif}

{ The DC
}
var
  HWindow: HWnd;
  DC: HDC;
  DevDC: HDC;
  MemDC: HDC;
  AuxDC: HDC;
  MemBitmap: HBITMAP;
  DrawLock: Integer;
  ClipRgn: HRGN;
  UsedRgn: HRGN;
  Painting: Boolean;
  PaintClip: TRect;

const
  WindowClass = 'GvSystem';
  evSystem = $1000;
  gvs_NoFrame = 1;

{ Callbacks
}
type
  TGetMCProc = procedure(n: Integer);

procedure NoPaint(View: pointer; var PS: TPaintStruct);
procedure NoSystemMessage(View: pointer; var Event: TEvent);
procedure NoGetMCursor(n: Integer);

const
  Paint: procedure(View: pointer; var PS: TPaintStruct) = NoPaint;
  SystemMessage: procedure(View: pointer; var Event: TEvent) = NoSystemMessage;
  GetMCursor: TGetMCProc = NoGetMCursor;

{ Window Caption
}
const
  Caption: Boolean = true;

procedure SetCaption(on_: Boolean);

{ Physical
}
var
  SizeX, SizeY: Word;

function InitGraphics: Boolean;
procedure CloseGraphics;
function BeginDraw: HDC;
function BeginGetInfo: HDC;
function ExBeginDraw(Buf: Boolean): HDC;
procedure EndDraw;
procedure ForceEndDraw;
function GetMaxX: Integer;
function GetMaxY: Integer;
function GetMaxColor: LongInt;
function GetResX: Integer;
function GetResY: Integer;
function GetAspect: Real;
procedure SelectWnd(Wnd: TWinHandle);
function GetView(Wnd: TWinHandle): pointer;

{ Draw origin and clipping rectangle
}
var
  DrawOrigin: TPoint;
  ClipRect: TRect;
  MetaClipRect: TRect;
  MetaOrigin: TPoint;

procedure SetDrawOrigin(x, y: Integer);
procedure SetDrawOriginP(var P: TPoint);
procedure SetClipRect(x1, y1, x2, y2: Integer);
procedure SetClipRectR(var R: TRect);

{ Background color and mode
}
procedure SetBkColor(Color: Word);
procedure SetBkMode(Mode: Integer);

const
  Transparent = 1;
  Opaque = 2;

const
  BkColor: Word = 0;
  BkMode: Integer = Transparent;
  ExBkColor: TColorRef = 0;

{ Color system
}
function TransColor(Col: Word): TColorRef;

{ MetaGr compatibility ******************************************************
}
const
	NormalPut       = 0;
	CopyPut         = 0;
	XORPut          = 1;
	ORPut           = 2;
	ANDPut          = 3;
	NotPut          = 4;
	BackPut         = 8;

	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;
	Border          = 16;

	SolidLn         = 0;
	DottedLn        = 1;
	CenterLn        = 2;
	DashedLn        = 3;
	UserBitLn       = 4;

	EmptyFill       = 0;
	SolidFill       = 1;
	LineFill        = 2;
	LtSlashFill     = 3;
	SlashFill       = 4;
	BkSlashFill     = 5;
	LtBkSlashFill   = 6;
	HatchFill       = 7;
	XHatchFill      = 8;
	InterleaveFill  = 9;
	WideDotFill     = 10;
	CloseDotFill    = 11;
	UserFill        = 12;

	NormWidth       = 1;
	ThickWidth      = 3;

Procedure PutPixel(x,y: Integer; Color:Byte);
Function  GetPixel(x,y: Integer): Byte;
Procedure HoriLine(x1,y1,x2: Integer);
Procedure VertLine(x1,y1,y2: Integer);
Procedure Bar (x1,y1,x2,y2: Integer);
Procedure Rectangle (x1,y1,x2,y2: Integer);
Procedure Circle (xm,ym,r: Integer);
Procedure FillCircle (xm,ym,r: Integer);

Procedure Line(x1,y1,x2,y2: Integer);
Procedure MoveTo(x ,y: Integer);
Procedure MoveRel(x,y: Integer);
Procedure LineTo(x,y: Integer);
Procedure LineRel(x,y: Integer);

Procedure SetColor (Color: Byte);
Procedure SetFillStyle (FillStyle, Color: Word);
Procedure SetLineStyle (LineStyle, Pattern, Thickness:Word);
Procedure SetWriteMode (Mode: Byte);
Procedure ClearDevice;
Procedure ClearPage;

Procedure SetMetaOrigin(x,y: Integer);
Procedure SetMetaOriginP(P: TPoint);
Procedure SetMetaClipRect(x1, y1, x2, y2: Integer);
Procedure SetMetaClipRectR(var R: TRect);

{ Graph compatibility *******************************************************
}
const
  { GraphResult error return codes: }
  grOk               =   0;
  grNoInitGraph      =  -1;
  grNotDetected      =  -2;
  grFileNotFound     =  -3;
  grInvalidDriver    =  -4;
  grNoLoadMem        =  -5;
  grNoScanMem        =  -6;
  grNoFloodMem       =  -7;
  grFontNotFound     =  -8;
  grNoFontMem        =  -9;
  grInvalidMode      = -10;
  grError            = -11;   { generic error }
  grIOerror          = -12;
  grInvalidFont      = -13;
  grInvalidFontNum   = -14;

  { define graphics drivers }
  CurrentDriver = -128; { passed to GetModeRange }
  Detect        = 0;    { requests autodetection }
  CGA           = 1;
  MCGA          = 2;
  EGA           = 3;
  EGA64         = 4;
  EGAMono       = 5;
  IBM8514       = 6;
  HercMono      = 7;
  ATT400        = 8;
  VGA           = 9;
  PC3270        = 10;

  { graphics modes for each driver }
  CGAC0      = 0;  { 320x200 palette 0: LightGreen, LightRed, Yellow; 1 page }
  CGAC1      = 1;  { 320x200 palette 1: LightCyan, LightMagenta, White; 1 page }
  CGAC2      = 2;  { 320x200 palette 2: Green, Red, Brown; 1 page }
  CGAC3      = 3;  { 320x200 palette 3: Cyan, Magenta, LightGray; 1 page }
  CGAHi      = 4;  { 640x200 1 page }
  MCGAC0     = 0;  { 320x200 palette 0: LightGreen, LightRed, Yellow; 1 page }
  MCGAC1     = 1;  { 320x200 palette 1: LightCyan, LightMagenta, White; 1 page }
  MCGAC2     = 2;  { 320x200 palette 2: Green, Red, Brown; 1 page }
  MCGAC3     = 3;  { 320x200 palette 3: Cyan, Magenta, LightGray; 1 page }
  MCGAMed    = 4;  { 640x200 1 page }
  MCGAHi     = 5;  { 640x480 1 page }
  EGALo      = 0;  { 640x200 16 color 4 page }
  EGAHi      = 1;  { 640x350 16 color 2 page }
  EGA64Lo    = 0;  { 640x200 16 color 1 page }
  EGA64Hi    = 1;  { 640x350 4 color  1 page }
  EGAMonoHi  = 3;  { 640x350 64K on card, 1 page; 256K on card, 2 page }
  HercMonoHi = 0;  { 720x348 2 page }
  ATT400C0   = 0;  { 320x200 palette 0: LightGreen, LightRed, Yellow; 1 page }
  ATT400C1   = 1;  { 320x200 palette 1: LightCyan, LightMagenta, White; 1 page }
  ATT400C2   = 2;  { 320x200 palette 2: Green, Red, Brown; 1 page }
  ATT400C3   = 3;  { 320x200 palette 3: Cyan, Magenta, LightGray; 1 page }
  ATT400Med  = 4;  { 640x200 1 page }
  ATT400Hi   = 5;  { 640x400 1 page }
  VGALo      = 0;  { 640x200 16 color 4 page }
  VGAMed     = 1;  { 640x350 16 color 2 page }
  VGAHi      = 2;  { 640x480 16 color 1 page }
  PC3270Hi   = 0;  { 720x350 1 page }
  IBM8514LO  = 0;  { 640x480 256 colors }
  IBM8514HI  = 1;  { 1024x768 256 colors }

  { Set/GetTextStyle constants: }
  DefaultFont   = 0;    { 8x8 bit mapped font }
  TriplexFont   = 1;    { "Stroked" fonts }
  SmallFont     = 2;
  SansSerifFont = 3;
  GothicFont    = 4;

  HorizDir   = 0;       { left to right }
  VertDir    = 1;       { bottom to top }

  UserCharSize = 0;     { user-defined char size }

  { Clipping constants: }
  ClipOn  = true;
  ClipOff = false;

  { Bar3D constants: }
  TopOn  = true;
  TopOff = false;

const
  MaxColors = 15;
type
  PaletteType = record
      Size   : byte;
      Colors : array[0..MaxColors] of shortint;
    end;

  LineSettingsType = record
      LineStyle : word;
      Pattern   : word;
      Thickness : word;
    end;

  TextSettingsType = record
      Font      : word;
      Direction : word;
      CharSize  : word;
      Horiz     : word;
      Vert      : word;
    end;

  FillSettingsType = record               { Pre-defined fill style }
      Pattern : word;
      Color   : word;
    end;

  FillPatternType = array[1..8] of byte;  { User defined fill style }

  PointType = record
      X, Y : integer;
    end;

  ViewPortType = record
      x1, y1, x2, y2 : integer;
      Clip           : boolean;
    end;

  ArcCoordsType = record
      X, Y           : integer;
      Xstart, Ystart : integer;
      Xend, Yend     : integer;
    end;

{ *** high-level error handling *** }
function GraphErrorMsg(ErrorCode : integer) : String;
function GraphResult : integer;

{ *** detection, initialization and crt mode routines *** }
procedure DetectGraph(var GraphDriver, GraphMode : integer);
function GetDriverName : string;

procedure InitGraph(var GraphDriver : integer;
		    var GraphMode   : integer;
			PathToDriver : String);

function RegisterBGIfont(Font : pointer) : integer;
function RegisterBGIdriver(Driver : pointer) : integer;
function InstallUserDriver(DriverFileName : string;
			    AutoDetectPtr : pointer) : integer;
function InstallUserFont(FontFileName : string) : integer;
procedure SetGraphBufSize(BufSize : word);
function GetMaxMode : integer;
procedure GetModeRange(GraphDriver : integer; var LoMode, HiMode : integer);
function GetModeName(GraphMode : integer) : string;
procedure SetGraphMode(Mode : integer);
function GetGraphMode : integer;
procedure GraphDefaults;
procedure RestoreCrtMode;
procedure CloseGraph;

function  GetX : integer;
function  GetY : integer;

{ *** Screen, viewport, page routines *** }
procedure SetViewPort(x1, y1, x2, y2 : integer; Clip : boolean);
procedure GetViewSettings(var ViewPort : ViewPortType);
procedure ClearViewPort;
procedure SetVisualPage(Page : word);
procedure SetActivePage(Page : word);

{ *** line-oriented routines *** }
procedure GetLineSettings(var LineInfo : LineSettingsType);

{ *** polygon, fills and figures *** }
procedure Bar3D(x1, y1, x2, y2 : integer; Depth : word; Top : boolean);
procedure DrawPoly(NumPoints : word; var PolyPoints);
procedure FillPoly(NumPoints : word; var PolyPoints);
procedure GetFillSettings(var FillInfo : FillSettingsType);
procedure GetFillPattern(var FillPattern : FillPatternType);
procedure SetFillPattern(Pattern : FillPatternType; Color : word);
procedure FloodFill(X, Y : integer; Border : word);

{ *** arc, circle, and other curves *** }
procedure Arc(X, Y : integer; StAngle, EndAngle, Radius : word);
procedure GetArcCoords(var ArcCoords : ArcCoordsType);
procedure Ellipse(X, Y : integer;
		  StAngle, EndAngle : word;
                  XRadius, YRadius  : word);
procedure FillEllipse(X, Y : integer;
		      XRadius, YRadius  : word);
procedure GetAspectRatio(var Xasp, Yasp : word);
procedure SetAspectRatio(Xasp, Yasp : word);
procedure PieSlice(X, Y : integer; StAngle, EndAngle, Radius : word);
procedure Sector(X, Y : Integer;
		 StAngle, EndAngle,
		 XRadius, YRadius : word);


{ *** color and palette routines *** }
const
  VgaColors: array[0..15] of TColorRef =
    ($000000, $800000, $008000, $808000,
     $000080, $800080, $008080, $C0C0C0,
     $808080, $FF0000, $00FF00, $FFFF00,
     $0000FF, $FF00FF, $00FFFF, $FFFFFF);

{procedure SetBkColor(ColorNum : word);}
{function GetBkColor : word;}
function GetColor : word;
procedure SetAllPalette(var Palette);
procedure SetPalette(ColorNum : word; Color : shortint);
procedure GetPalette(var Palette : PaletteType);
function GetPaletteSize : integer;
procedure GetDefaultPalette(var Palette : PaletteType);
procedure SetRGBPalette(ColorNum, RedValue, GreenValue, BlueValue : integer);

{ *** bit-image routines *** }
function  ImageSize(x1, y1, x2, y2 : integer) : word;
procedure GetImage(x1, y1, x2, y2 : integer; var BitMap);
procedure PutImage(X, Y : integer; var BitMap; BitBlt : word);

{ *** text routines *** }
procedure GetTextSettings(var TextInfo : TextSettingsType);
procedure OutText(TextString : string);
procedure SetTextStyle(Font, Direction : word; CharSize : word);
procedure SetUserCharSize(MultX, DivX, MultY, DivY : word);

{ Font system ***************************************************************
}
const
  ftUnresolved  = 0;
  ftBGI         = 1;
  ftBIOS        = 2;
  ftCPI         = 4;
  ftWin         = 8;
  ftWinVector   = 16;
  ftWinHuge     = 32;           { collection of single glyphs }

const
  ftNormal          = 0;
  ftBold            = 1;
  ftThin            = 2;
  ftItalic          = 4;
  ftUnderlined      = 8;
  ftStruckOut       = 16;
  ftVerticalMoves   = 64;
  ftNoVerticalMoves = 0;
  ftNoDescent       = 128;

type
  PFontCollection = ^TFontCollection;
  TFontCollection = object(TCollection)
    procedure Insert(Item: pointer); virtual;
    procedure FreeItem(Item: pointer); virtual;
  end;

var
  FontCollection: PFontCollection;

procedure InitFonts;
procedure DoneFonts;

const
  LeftText      = 0;
  CenterText    = 1;
  RightText     = 2;
  BottomText    = 0;
  TopText       = 2;
  BaseLine      = 3;
  LeadLine      = 4;

type
  TTextMetric = WinTypes.TTextMetric;
  PTextMetric = ^TTextMetric;

  TFontRec = TLogFont;
  PFontRec = ^TFontRec;

var
  sHoriz, sVert, sFont, sColor:Word;
  sCharSpace: Integer;
  sMarker: Char;
  sAttr: Word;

const
  potMarker: Char = '~';

procedure OutTextXY(x, y: Integer; s: string);
procedure SetTextJustify(Horiz, Vert: Word);
procedure SetTextParams(Font: Word; CharSpace: Integer; Color: Word;
  UseMarker: Boolean);
procedure SetExtTextParams(Font: Word; Charspace: Integer; Color: Word;
  UseMarker: Boolean; Attr: Word);
procedure SetKern(Enable: Boolean);
procedure SetMarker(Marker: Char);
function TextWidth(s: string): Integer;
function TextHeight(s: string): Integer;
procedure GetTextMetrics(var Metrics: TTextMetric);

function DefFont(Font: PFontRec): Word;
procedure ReplaceFont(Font: Word; FontRec: PFontRec);
procedure FreeFont(Font: Word);

function LoadCpiFont(FName: string; ReqCP, ReqLength: Integer;
  CharSpace, AVertAdd, AHeight: Integer): PFontRec;
function LoadBgiFileFont(FName: string; ReqHeight, AMultX, ADivX, AMultY,
  ADivY: Integer; CharSpace, AVertAdd, AHeight: Integer;
  Attr: Word): PFontRec;
function LoadBiosFont(ReqLength: Word;
  CharSpace, AVertAdd, AHeight: Integer): PFontRec;
function LoadWinFont(FName: string; reqNr, reqPt, reqLength: Integer;
  CharSpace, AVertAdd, AHeight: Integer; Attr: Word): PFontRec;

{ Crt/WinCrt section ********************************************************
}
const
  CheckBreak: Boolean = true;    { Enable Ctrl-Break }

function KeyPressed: Boolean;
function ReadKey: Char;
procedure Delay(MS: Word);

{ Drivers/GvDriver section **************************************************
}

var

{ Uninitialized variables }

  MouseButtons: Byte;
  MouseWhere: TPoint;
  CriticalArea: TRect;
  CursorNum: Integer;
  NewNum: Integer;
  CursorPtr: pointer;
  CursorHandle: HCursor;

{ Initialized variables }

const
  DoubleDelay: Word = 8;
  RepeatDelay: Word = 8;
  TickMS: Word = 40;
var
  AutoDelay: Word absolute RepeatDelay;

{ Event manager routines }

procedure InitEvents;
procedure DoneEvents;
procedure ShowMouse;
procedure HideMouse;
procedure GetMouseEvent(var Event: TEvent);
procedure GetKeyEvent(var Event: TEvent);
procedure GetTimerEvent(var Event: TEvent);
function GetTimerTicks: Word;
function GetShiftState: Byte;
procedure SetCriticalAreaR(var R: TRect);
procedure SetCurrentCursor (n: Integer);

{ MyMouse
}

procedure SetMCursor(n: Integer);
procedure SetMousePos(x, y: Integer);
procedure SetMouseArea(x1, y1, x2, y2: Integer);
procedure SetCriticalArea(x1, y1, x2, y2: Integer);
procedure SetCursorPtr(p: pointer);
function MouseInstalled: Boolean;

{ Standard mouse cursor }

const
  mcStd         = 0;
  mcCross       = 1;
  mcHourGlass   = 2;
  mcLargeCross  = 3;

const
  mcNoCursor = -1;

const
  MCurStandard: Integer = mcStd;
  MCurrent: Integer = mcNoCursor;

{ Video }

procedure InitVideo;
procedure DoneVideo;
procedure SetScreenMode(Mode: Byte);

implementation

uses Strings, WinRes;

const
  GvSystemWinExtra = 4;
  gwl_ViewPtr = 0;

procedure NoPaint;
begin
end;

procedure NoSystemMessage;
begin
end;

procedure NoGetMCursor(n: Integer);
begin
end;

function TransColor(Col: Word): TColorRef;
begin
  TransColor := VgaColors[Col]
end;

function InitGraphics: Boolean;
var
  Rect: winTypes.TRect;
begin
  HWindow := CreateWindow(WindowClass, 'Graphics Vision', ws_OverlappedWindow,
    0, 0, 600, 400, 0, 0, hInstance, nil);
  GetClientRect(HWindow, Rect);
  SizeX := Rect.right - Rect.left;
  SizeY := Rect.bottom - Rect.top;
  ShowWindow(HWindow, sw_Show);
  InitGraphics := true;
  DrawLock := 0;
end;

procedure SelectWnd(Wnd: TWinHandle);
var
  Rect: WinTypes.TRect;
begin
  If (HWindow <> Wnd) and (DrawLock <> 0) then ForceEndDraw;
  HWindow := Wnd;
  GetClientRect(HWindow, Rect);
  SizeX := Rect.right - Rect.left;
  SizeY := Rect.bottom - Rect.top;
end;

var
  SavePen: HPen;
  SaveBrush: HBrush;
  SaveFont: HFont;
  SaveBitmap: HBitmap;
  SaveRgn: HRgn;

function ExBeginDraw(Buf: Boolean): HDC;
begin
  If DC = 0
  then begin
    If DevDC = 0 then DevDC := GetDC(HWindow);
    AuxDC := CreateCompatibleDC(DevDC); { for bitmap pasting }
    If Buf
    then begin
      MemDC := CreateCompatibleDC(DevDC); { for buffered drawing }
      DC := MemDC;
      MemBitmap := CreateCompatibleBitmap(DevDC, SizeX, SizeY);
      SaveBitmap := SelectObject(MemDC, MemBitmap);
    end
    else begin
      DC := DevDC;
      SaveBitmap := 0
    end;
    SetBkMode(Transparent);
    WinProcs.SetBkColor(DC, TransColor(BkColor));
    SavePen := SelectObject(DC, GetStockObject(Black_Pen));
    SaveBrush := SelectObject(DC, GetStockObject(White_Brush));
    SaveFont := SelectObject(DC, GetStockObject(System_Font));
    SetClipRect(0, 0, 0, 0);
    GraphDefaults;
  end;
  Inc(DrawLock);
  ExBeginDraw := DC
end;

function BeginDraw: HDC;
begin
  BeginDraw := ExBeginDraw(false)
end;

function BeginGetInfo: HDC;
begin
  if DC = 0
  then begin
    BeginDraw;
    SetMetaClipRect(0, 0, 0, 0);
  end
  else BeginDraw;
  BeginGetInfo := DC
end;

procedure EndDraw;
begin
  Dec(DrawLock);
  If DrawLock < 0 then DrawLock := 0 else
  if DrawLock = 0
  then begin
    If UsedRgn <> 0
    then DeleteObject(UsedRgn);
    UsedRgn := 0;
    DeleteObject(SelectObject(DC, SavePen));
    DeleteObject(SelectObject(DC, SaveBrush));
    if SaveBitmap <> 0 then DeleteObject(SelectObject(DC, SaveBitmap));
    DeleteObject(SelectObject(DC, SaveRgn));
    DeleteObject(SelectObject(DC, SaveFont));
    If not Painting
    then begin
      ReleaseDC(HWindow, DevDC);
      DevDC := 0;
    end;
    if MemDC <> 0 then DeleteDC(MemDC);
    if AuxDC <> 0 then DeleteDC(AuxDC);
    DC := 0;
    MemDC := 0;
    AuxDC := 0;
  end
end;

procedure ForceEndDraw;
begin
  DrawLock := 1;
  EndDraw;
end;

procedure CloseGraphics;
begin
  EndDraw;
  DestroyWindow(HWindow);
  HWindow := 0
end;

function GetMaxX: Integer;
begin
  GetMaxX := SizeX - 1
end;

function GetMaxY: Integer;
begin
  GetMaxY := SizeY - 1
end;

function GetMaxColor: LongInt;
begin
  GetMaxColor := GetDeviceCaps(BeginGetInfo, NumColors) - 1;
  EndDraw
end;

function GetResX: Integer;
begin
  GetResX := GetDeviceCaps(BeginGetInfo, LogPixelsX);
  EndDraw
end;

function GetResY: Integer;
begin
  GetResY := GetDeviceCaps(BeginGetInfo, LogPixelsY);
  EndDraw
end;

function GetAspect: Real;
begin
  GetAspect := 1.0
end;

procedure SetDrawOrigin(x, y: Integer);
begin
  SetViewportOrg(DC, x, y);
  DrawOrigin.x := x;
  DrawOrigin.y := y
end;

procedure SetDrawOriginP(var P: TPoint);
begin
  SetDrawOrigin(P.x, P.y)
end;

procedure SetClipRect(x1, y1, x2, y2: Integer);
var
  CC: TRect;
begin
  Cliprect.Assign(x1, y1, x2, y2);
  CC := Cliprect;
  If Painting then CC.Intersect(PaintClip);
  If UsedRgn = 0
  then UsedRgn := CreateRectRgn(CC.A.X, CC.A.Y, CC.B.X, CC.B.Y)
  else SetRectRgn(UsedRgn, CC.A.X, CC.A.Y, CC.B.X, CC.B.Y);
  CombineRgn(UsedRgn, UsedRgn, ClipRgn, RGN_AND);
  SelectClipRgn(DC, UsedRgn);
  {IntersectClipRect(DC, x1, y1, x2, y2);}
end;

procedure SetClipRectR(var R: TRect);
begin
  SetClipRect(R.A.X, R.A.Y, R.B.X, R.B.Y);
end;

procedure SetMetaOrigin(x, y: Integer);
begin
  MetaOrigin.x := x;
  MetaOrigin.y := y
end;

procedure SetMetaOriginP(P: TPoint);
begin
  SetMetaOrigin(P.x, P.y)
end;

procedure SetMetaClipRect(x1, y1, x2, y2: Integer);
begin
  MetaCliprect.Assign(x1, y1, x2, y2)
end;

procedure SetMetaClipRectR(var R: TRect);
begin
  MetaCliprect := R
end;

{ Background color and mode
}
procedure SetBkColor(Color: Word);
begin
  BkColor := Color;
  ExBkColor := transColor(Color);
  WinProcs.SetBkColor(DC, ExBkColor);
end;

procedure SetBkMode(Mode: Integer);
begin
  BkMode := Mode;
  WinProcs.SetBkMode(DC, Mode)
end;

{ MetaGraph
}
var
  LogPen: TLogPen;
  Current: TPoint;
  PenColor: Word;
  TheFillInfo: FillSettingsType;
  TheFillPattern: FillPatternType;
  UserPattern: HBitmap;

Procedure PutPixel(x,y: Integer; Color:Byte);
begin
  WinProcs.SetPixel(DC, x, y, TransColor(Color))
end;

Function GetPixel(x,y: Integer): Byte;
begin
  GetPixel := 0
end;

procedure HoriLine(x1, y1, x2: Integer);
begin
  If x2 >= x1 then Inc(x2) else Dec(x1);
  WinProcs.MoveTo(DC, x1, y1);
  WinProcs.LineTo(DC, x2, y1);
end;

Procedure VertLine(x1,y1,y2: Integer);
begin
  If y2 >= y1 then Inc(y2) else Dec(y1);
  WinProcs.MoveTo(DC, x1, y1);
  WinProcs.LineTo(DC, x1, y2);
end;

Procedure Bar (x1,y1,x2,y2: Integer);
var
  OldPen: HPen;
begin
  OldPen := SelectObject(DC, GetStockObject(Null_Pen));
  WinProcs.SetBkMode(DC, Opaque);
  WinProcs.Rectangle(DC, x1, y1, x2 + 2, y2 + 2);
  WinProcs.SetBkMode(DC, BkMode);
  DeleteObject(SelectObject(DC, OldPen));
end;

Procedure Rectangle (x1,y1,x2,y2: Integer);
var
  OldBrush: HBrush;
begin
  OldBrush := SelectObject(DC, GetStockObject(Hollow_Brush));
  WinProcs.Rectangle(DC, x1, y1, x2 + 1, y2 + 1);
  DeleteObject(SelectObject(DC, OldBrush));
end;

Procedure Circle (xm,ym,r: Integer);
var
  OldBrush: HBrush;
begin
  OldBrush := SelectObject(DC, GetStockObject(Hollow_Brush));
  WinProcs.Ellipse(DC, xm - r, ym - r, xm + r, ym + r);
  DeleteObject(SelectObject(DC, OldBrush));
end;

Procedure FillCircle (xm,ym,r: Integer);
begin
  WinProcs.SetBkMode(DC, Opaque);
  WinProcs.Ellipse(DC, xm - r, ym - r, xm + r, ym + r);
  WinProcs.SetBkMode(DC, BkMode);
end;

Procedure Line(x1,y1,x2,y2: Integer);
begin
  WinProcs.MoveTo(DC, x1, y1);
  WinProcs.LineTo(DC, x2, y2);
  WinProcs.SetPixel(DC, x1, y1, LogPen.lopnColor);
  WinProcs.SetPixel(DC, x2, y2, LogPen.lopnColor);
end;

Procedure MoveTo(x, y: Integer);
begin
  WinProcs.MoveTo(DC, x, y);
  Current.x := x;
  Current.y := y
end;

Procedure MoveRel(x,y: Integer);
begin
  MoveTo(Current.x + x, Current.y + y)
end;

Procedure LineTo(x,y: Integer);
begin
  WinProcs.LineTo(DC, x, y);
  Current.x := x;
  Current.y := y
end;

Procedure LineRel(x,y: Integer);
begin
  LineTo(Current.x + x, Current.y + y)
end;

Procedure SetColor (Color: Byte);
begin
  PenColor := Color;
  LogPen.lopnColor := TransColor(Color);
  DeleteObject(SelectObject(DC, CreatePenIndirect(LogPen)));
  SetTextColor(DC, LogPen.lopnColor);
end;

Procedure SetFillStyle (FillStyle, Color: Word);
var
  Brush: TLogBrush;
  DIB: THandle;
  P: PChar;
  i: Integer;
const
  Styles: array[0..12] of Word =
    (bs_Hollow, bs_Solid,
     bs_Hatched + 256*hs_Horizontal, bs_Hatched + 256*hs_FDiagonal,
     bs_Hatched + 256*hs_FDiagonal, bs_Hatched + 256*hs_BDiagonal,
     bs_Hatched + 256*hs_BDiagonal, bs_Hatched + 256*hs_DiagCross,
     bs_Hatched + 256*hs_DiagCross, bs_Solid, bs_Solid, bs_Solid,
     bs_DIBpattern);
  InfoHeader: TBitmapInfoHeader =
    (biSize: 	SizeOf(TBitmapInfoHeader);
     biWidth:	8;
     biHeight:	8;
     biPlanes:	1;
     biBitCount: 1;
     biCompression: bi_RGB);
begin
  TheFillInfo.Pattern := FillStyle;
  TheFillInfo.Color := Color;
  with Brush do
  begin
    lbStyle := Lo(Styles[FillStyle]);
    If lbStyle = bs_DIBPattern
    then begin
      DIB := GlobalAlloc(gmem_Moveable,
	SizeOf(TBitmapInfoHeader) + 2*SizeOf(TColorRef) + 8 * 4);
      P := GlobalLock(DIB);
      Move(InfoHeader, P^, SizeOf(TBitmapInfoHeader));
      Inc(P, SizeOf(TBitmapInfoHeader));
      TColorRef(pointer(P)^) := TransColor(BkColor);
      TColorRef(pointer(P+4)^) := TransColor(Color);
      Inc(P, 8);
      For i := 8 downto 1 do
      begin
	P[0] := Char(TheFillPattern[i]);
	Inc(P, 4);
      end;
      GlobalUnlock(DIB);
      DeleteObject(SelectObject(DC, CreateDIBPatternBrush(DIB, DIB_RGB_COLORS)));
    end
    else begin
      lbColor := TransColor(Color);
      lbHatch := Hi(Styles[FillStyle]);
      DeleteObject(SelectObject(DC, CreateBrushIndirect(Brush)));
    end
  end;
end;

Procedure SetLineStyle (LineStyle, Pattern, Thickness:Word);
const
  Styles: array[0..4] of Byte =
    (ps_Solid, ps_Dot, ps_DashDot, ps_Dash, {ps_DashDotDot} ps_Dot);
begin
  LogPen.lopnStyle := Styles[LineStyle];
  LogPen.lopnWidth.X := Thickness;
  LogPen.lopnWidth.Y := Thickness;
  DeleteObject(SelectObject(DC, CreatePenIndirect(LogPen)));
end;

Procedure SetWriteMode (Mode: Byte);
const
  Modes: array[0..3] of Byte =
    (r2_CopyPen, r2_XORPen, r2_MergePen, r2_MaskPen);
begin
  SetROP2(DC, Modes[Mode]);
end;

Procedure ClearDevice;
var
  OldBrush: HBrush;
  OldPen: HPen;
  Rect: TRect;
  Orig: TPoint;
begin
  Rect := ClipRect;
  Orig := DrawOrigin;
  SetClipRect(0, 0, SizeX, SizeY);
  SetDrawOrigin(0, 0);
  OldPen := SelectObject(DC, GetStockObject(Null_Pen));
  OldBrush := SelectObject(DC, GetStockObject(Black_Brush));
  WinProcs.Rectangle(DC, 0, 0, SizeX, SizeY);
  DeleteObject(SelectObject(DC, OldPen));
  DeleteObject(SelectObject(DC, OldBrush));
  SetClipRectR(Rect);
  SetDrawOriginP(Orig);
end;

Procedure ClearPage;
begin
  ClearDevice
end;

{ *** Graph *** }

function GraphErrorMsg(ErrorCode : integer) : String;
begin GraphErrorMsg := '' end;

function GraphResult : integer;
begin GraphResult := grOK end;

procedure DetectGraph(var GraphDriver, GraphMode : integer);
begin
  GraphDriver := VGA;
  GraphMode := VGAHi
end;

function GetDriverName : string;
begin
  GetDriverName := 'Windows BGI';
end;

procedure InitGraph(var GraphDriver : integer;
		    var GraphMode   : integer;
			PathToDriver : String);
begin
  InitGraphics;
  BeginDraw;
end;

function RegisterBGIfont(Font : pointer) : integer;
begin RegisterBGIfont := 0 end;
function RegisterBGIdriver(Driver : pointer) : integer;
begin RegisterBGIdriver := 0 end;
function InstallUserDriver(DriverFileName : string;
			    AutoDetectPtr : pointer) : integer;
begin InstallUserDriver := 0 end;
function InstallUserFont(FontFileName : string) : integer;
begin InstallUserFont := 0 end;
procedure SetGraphBufSize(BufSize : word);
begin end;
function GetMaxMode : integer;
begin GetMaxMode := 0 end;
procedure GetModeRange(GraphDriver : integer; var LoMode, HiMode : integer);
begin LoMode := 0; HiMode := 0 end;
function GetModeName(GraphMode : integer) : string;
begin GetModeName := 'Windows' end;

procedure SetGraphMode(Mode : integer);
begin
  If HWindow <> 0 then CloseGraphics;
  InitGraphics;
  BeginDraw;
end;

function GetGraphMode : integer;
begin GetGraphMode := 0 end;

procedure GraphDefaults;
begin
  SetColor(White);
  SetFillStyle(SolidFill, White);
  SetWriteMode(NormalPut);
  SetKern(true);
end;

procedure RestoreCrtMode;
begin CloseGraphics end;
procedure CloseGraph;
begin CloseGraphics end;

function  GetX : integer;
begin GetX := Current.X end;
function  GetY : integer;
begin GetY := Current.Y end;

{ *** Screen, viewport, page routines *** }
procedure SetViewPort(x1, y1, x2, y2 : integer; Clip : boolean);
begin
  SetDrawOrigin(x1, y1);
  If Clip
  then SetClipRect(x1, y1, x2+1, y2+1)
  else SetClipRect(0, 0, SizeX, SizeY)
end;

procedure GetViewSettings(var ViewPort : ViewPortType);
begin
  with ViewPort do
  begin
    x1 := ClipRect.A.X;
    y1 := ClipRect.A.Y;
    x2 := ClipRect.B.X - 1;
    y2 := ClipRect.B.Y - 1;
    clip := true
  end
end;

procedure ClearViewPort;
var
  OldBrush: HBrush;
  OldPen: HPen;
begin
  OldPen := SelectObject(DC, GetStockObject(Null_Pen));
  OldBrush := SelectObject(DC, GetStockObject(Black_Brush));
  WinProcs.Rectangle(DC, 0, 0, ClipRect.B.X-ClipRect.A.X, ClipRect.B.Y-ClipRect.A.Y);
  DeleteObject(SelectObject(DC, OldPen));
  DeleteObject(SelectObject(DC, OldBrush));
end;

procedure SetVisualPage(Page : word);
begin
end;

procedure SetActivePage(Page : word);
begin
end;

{ *** line-oriented routines *** }
procedure GetLineSettings(var LineInfo : LineSettingsType);
begin
  with LineInfo do
  begin
    LineStyle := 0;
    Pattern := 0;
    Thickness := 1;
  end;
end;

{ *** polygon, fills and figures *** }
procedure Bar3D(x1, y1, x2, y2 : integer; Depth : word; Top : boolean);
begin
  If Top
  then WinProcs.Rectangle(DC, x1, y1, x2 + 1, y2 + 1)
  else begin
    Rectangle(x1, y1, x2, y2);
    Line(x1, y1, x1 + Depth, y1 - Depth div 2)
  end;
  Line(x1, y1, x1 + Depth, y1 - Depth div 2);
  Line(x2, y1, x2 + Depth, y1 - Depth div 2);
  Line(x2, y2, x2 + Depth, y2 - Depth div 2);
  Line(x1 + Depth, y1 - Depth div 2, x2 + Depth, y1 - Depth div 2);
  Line(x2 + Depth, y1 - Depth div 2, x2 + Depth, y2 - Depth div 2);
end;

procedure DrawPoly(NumPoints : word; var PolyPoints);
begin
  WinProcs.Polyline(DC, PolyPoints, NumPoints)
end;

procedure FillPoly(NumPoints : word; var PolyPoints);
begin
  WinProcs.SetBkMode(DC, Opaque);
  WinProcs.Polygon(DC, PolyPoints, NumPoints);
  WinProcs.SetBkMode(DC, BkMode);
end;

procedure GetFillSettings(var FillInfo : FillSettingsType);
begin
  FillInfo := TheFillInfo;
end;

procedure GetFillPattern(var FillPattern : FillPatternType);
begin
  FillPattern := TheFillPattern
end;

procedure SetFillPattern(Pattern : FillPatternType; Color : word);
begin
  TheFillPattern := Pattern;
  SetFillStyle(UserFill, Color);
end;

procedure FloodFill(X, Y : integer; Border : word);
begin
  WinProcs.FloodFill(DC, X, Y, TransColor(Border))
end;

{ *** arc, circle, and other curves *** }

var
  TheArcCoords: ArcCoordsType;

procedure MakeArcCoords(XCenter, YCenter, StAngle, EndAngle, XRadius, YRadius: Word);
var
  arg: Real;
begin
  with TheArcCoords do
  begin
    X := XCenter;
    Y := YCenter;
    arg := StAngle * (pi/180);
    Xstart := Round(XCenter + XRadius*cos(arg));
    Ystart := Round(YCenter - YRadius*sin(arg));
    arg := EndAngle * (pi/180);
    XEnd := Round(XCenter + XRadius*cos(arg));
    YEnd := Round(YCenter - YRadius*sin(arg));
  end
end;

procedure Arc(X, Y : integer; StAngle, EndAngle, Radius : word);
begin
  MakeArcCoords(X, Y, StAngle, EndAngle, Radius, Radius);
  WinProcs.Arc(DC, X-Radius, Y-Radius, X+Radius+2, Y+Radius+2,
    TheArcCoords.Xstart, TheArcCoords.Ystart, TheArcCoords.Xend, TheArcCoords.Yend);
end;

procedure GetArcCoords(var ArcCoords : ArcCoordsType);
begin
  ArcCoords := TheArcCoords;
end;

procedure Ellipse(X, Y : integer;
		  StAngle, EndAngle : word;
		  XRadius, YRadius  : word);
begin
  MakeArcCoords(X, Y, StAngle, EndAngle, XRadius, YRadius);
  WinProcs.Arc(DC, X-XRadius, Y-YRadius, X+XRadius+2, Y+YRadius+2,
    TheArcCoords.Xstart, TheArcCoords.Ystart, TheArcCoords.Xend, TheArcCoords.Yend);
end;

procedure FillEllipse(X, Y : integer;
		      XRadius, YRadius  : word);
begin
  WinProcs.SetBkMode(DC, Opaque);
  WinProcs.Ellipse(DC, X-XRadius, Y-YRadius, X+XRadius+2, Y+YRadius+2);
  WinProcs.SetBkMode(DC, BkMode);
end;

procedure GetAspectRatio(var Xasp, Yasp : word);
begin
  Xasp := 1;
  Yasp := 1
end;

procedure SetAspectRatio(Xasp, Yasp : word);
begin
end;

procedure PieSlice(X, Y : integer; StAngle, EndAngle, Radius : word);
begin
  MakeArcCoords(X, Y, StAngle, EndAngle, Radius, Radius);
  WinProcs.SetBkMode(DC, Opaque);
  WinProcs.Pie(DC, X-Radius, Y-Radius, X+Radius+2, Y+Radius+2,
    TheArcCoords.Xstart, TheArcCoords.Ystart, TheArcCoords.Xend, TheArcCoords.Yend);
  WinProcs.SetBkMode(DC, BkMode);
end;

procedure Sector(X, Y : Integer;
		 StAngle, EndAngle,
		 XRadius, YRadius : word);
begin
  MakeArcCoords(X, Y, StAngle, EndAngle, XRadius, YRadius);
  WinProcs.SetBkMode(DC, Opaque);
  WinProcs.Pie(DC, X-XRadius, Y-YRadius, X+XRadius+2, Y+YRadius+2,
    TheArcCoords.Xstart, TheArcCoords.Ystart, TheArcCoords.Xend, TheArcCoords.Yend);
  WinProcs.SetBkMode(DC, BkMode);
end;

{ *** color and palette routines *** }
{procedure SetBkColor(ColorNum : word);}
{function GetBkColor : word;}
function GetColor : word;
begin
  GetColor := PenColor;
end;

procedure SetAllPalette(var Palette);
begin
end;

procedure SetPalette(ColorNum : word; Color : shortint);
begin
end;

procedure GetPalette(var Palette : PaletteType);
begin
end;

function GetPaletteSize : integer;
begin
end;

procedure GetDefaultPalette(var Palette : PaletteType);
begin
end;

procedure SetRGBPalette(ColorNum, RedValue, GreenValue, BlueValue : integer);
begin
end;


{ *** bit-image routines *** }
function  ImageSize(x1, y1, x2, y2 : integer) : word;
begin
  ImageSize := 27;
end;

procedure GetImage(x1, y1, x2, y2 : integer; var BitMap);
begin
end;

procedure PutImage(X, Y : integer; var BitMap; BitBlt : word);
begin
end;

{ *** text routines *** }
procedure GetTextSettings(var TextInfo : TextSettingsType);
begin
  with TextInfo do
  begin
    Font      := 0;
    Direction := 0;
    CharSize  := 0;
    Horiz     := 0;
    Vert      := 0
  end
end;

procedure OutText(TextString : string);
begin
  OutTextXY(Current.X, Current.Y, TextString);
  Inc(Current.X, TextWidth(TextString));
end;

procedure SetTextStyle(Font, Direction : word; CharSize : word);
begin
end;

procedure SetUserCharSize(MultX, DivX, MultY, DivY : word);
begin
end;

{ ******** CRT ************* }

var
  KeyBuf: Word;

function KeyPressed: Boolean;
var
  Event: TEvent;
begin
  If KeyBuf = 0
  then begin
    GetKeyEvent(Event);
    If Event.What = evKeyDown
    then KeyBuf := Event.KeyCode
    else begin
      KeyBuf := 0;
      GetTimerEvent(Event)
    end
  end;
  KeyPressed := KeyBuf <> 0
end;

function ReadKey: Char;
begin
  while not KeyPressed do;
  ReadKey := Chr(Lo(KeyBuf));
  KeyBuf := 0;
end;

procedure Delay(MS: Word);
var
  Start: LongInt;
  Msg: TMsg;
begin
  Start := GetTickCount;
  repeat
    PeekMessage(Msg, 0, 0, $FFFF, pm_NoRemove);
  until (GetTickCount >= Start + MS);
end;

{ The new Event manager *******************************************************
}

var
  TimeCount: LongInt;
  MouseTime: LongInt;

procedure InitEvents;
begin
end;

procedure DoneEvents;
begin
end;

procedure RealizeCursor;
begin
  {If NewNum <> CursorNum
  then} begin
    CursorHandle := 0;
    GetMCursor(NewNum);
    CursorNum := NewNum;
  end;
  If CursorHandle <> 0
  then SetCursor(CursorHandle)
  else SetCursor(LoadCursor(0, idc_Arrow));
end;

procedure AdaptCursor;
begin
  {GetCursorPos(WinTypes.TPoint(MouseWhere));
  ScreenToClient(HWindow, WinTypes.TPoint(MouseWhere));
  If (MouseWhere.x >= 0) and (MouseWhere.y >= 0) and
     (MouseWhere.x < SizeX) and (MouseWhere.y < SizeY)
  then begin
    ChangeCursor;
    RealizeCursor
  end}
end;

procedure ShowMouse;
begin
  AdaptCursor;
end;

procedure HideMouse;
begin
  AdaptCursor;
end;

function GetTimerTicks: Word;
begin
  GetTimerTicks := TimeCount
end;

procedure GetMouseEvent(var Event: TEvent);
var
  Msg: TMsg;
  LastWhere: TPoint;
begin
  If DC <> 0 then ForceEndDraw;
  If PeekMessage(Msg, 0, wm_MouseFirst, wm_MouseLast, pm_Remove) then
  with Msg do
  begin
    Event.Wnd := hwnd;
    Event.Buttons := wParam and (mk_LButton + mk_RButton);
    If wParam and mk_MButton <> 0
    then Event.Buttons := Event.Buttons or 4;
    If (Event.Buttons <> 0) and (MouseButtons = 0)
    then MouseTime := time + TickMS * RepeatDelay
    else MouseTime := time + TickMS;
    MouseButtons := Event.Buttons;
    LastWhere := MouseWhere;
    LongInt(MouseWhere) := lParam;
    ClientToScreen(hwnd, WinTypes.TPoint(MouseWhere));
    Event.Where := MouseWhere;
    case Message of
      wm_RButtonDown, {:
	begin
	  CloseGraphics;
	  Halt(1)
	end;           }
      wm_LButtonDown,
      wm_MButtonDown:
	begin
	  Event.What := evMouseDown;
	  Event.Double := false;
	  {SetCapture(HWindow);}
	end;
      wm_LButtonUp,
      wm_RButtonUp,
      wm_MButtonUp:
	begin
	  Event.What := evMouseUp;
	  Event.Double := false;
	  {If wParam and (mk_LButton + mk_RButton + mk_LButton) = 0
	  then ReleaseCapture;}
	end;
      wm_LButtonDblClk,
      wm_RButtonDblClk,
      wm_MButtonDblClk:
	begin
	  Event.What := evMouseDown;
	  Event.Double := true
	end;
      wm_MouseMove:
	If LongInt(MouseWhere) <> LongInt(LastWhere)
	then Event.What := evMouseMove
	else Event.What := evNothing;
    end;
    AdaptCursor;
  end else
  if (MouseButtons <> 0) and (GetTickCount > MouseTime)
  then begin
    MouseTime := GetTickCount + TickMS;
    Event.Wnd := 0;
    Event.What := evMouseAuto;
    Event.Where := MouseWhere;
    Event.Buttons := MouseButtons;
  end else
  Event.What := evNothing
end;

function TranslateKey(wEvent: Word; AltKey: Boolean): Word;
type
  TModifier = (None, Shift, Ctrl, Alt);
const
  Cursor: array[$21..$28] of Word =
    (kbPgUp, kbPgDn, kbEnd, kbHome, kbLeft, kbUp, kbRight, kbDown);
  CtrlCursor: array[$21..$28] of Word =
    (kbCtrlPgUp, kbCtrlPgDn, kbCtrlEnd, kbCtrlHome, kbCtrlLeft,
     kbUp, kbCtrlRight, kbDown);
  FuncBases: array[TModifier] of Word =
    (kbF1, kbShiftF1, kbCtrlF1, kbAltF1);
  InsDel: array[TModifier, $2D..$2E] of Word =
    ((kbIns, kbDel), (kbShiftIns, kbShiftDel), (kbCtrlIns, kbCtrlDel), (0, 0));
var
  Modifier: TModifier;
  State: Word;
begin
  State := GetShiftState;
  Modifier := None;
  If AltKey
  then begin
    { Special funkey handling -- at least F10 is always reported as `syskey' }
    if ((wEvent >= $70) and (wEvent <=$79))
    then begin
      if State and kbAltShift <> 0
      then Modifier := Alt
    end
    else Modifier := Alt
  end;
  if Modifier = None
  then begin
    if State and kbCtrlShift <> 0 then Modifier := Ctrl else
    if State and (kbLeftShift+kbRightShift) <> 0 then Modifier := Shift else
  end;
  TranslateKey := 0;
  case wEvent of
    $70..$79:  {funkeys}
      TranslateKey := FuncBases[Modifier] + (wEvent - $70) shl 8;
    $08:
      If Modifier = Alt then TranslateKey := kbAltBack else
      if Modifier = Ctrl then TranslateKey := kbCtrlBack else
      TranslateKey := kbBack;
    $09:
      If Modifier = Shift then TranslateKey := kbShiftTab else
      if Modifier = None then TranslateKey := kbTab;
    $0D:
      If Modifier = Ctrl then TranslateKey := kbCtrlEnter else
      TranslateKey := kbEnter;
    $1B:
      TranslateKey := kbEsc;
    $21..$28:
      If Modifier = Ctrl then TranslateKey := CtrlCursor[wEvent]
      else TranslateKey := Cursor[wEvent];
    $2D, $2E:
      TranslateKey := InsDel[Modifier][wEvent];
    vk_Add:
      TranslateKey := kbGrayPlus;
    vk_Subtract:
      TranslateKey := kbGrayMinus;
    $20: ;
    else
      If Modifier = Alt
      then TranslateKey := GetAltCode(Chr(wEvent))
  end;
end;

procedure GetKeyEvent(var Event: TEvent);
var
  Msg: TMsg;
begin
  If DC <> 0 then ForceEndDraw;
  Event.What := evNothing;
  If PeekMessage(Msg, 0, wm_KeyDown, wm_KeyDown, pm_Remove) or
     PeekMessage(Msg, 0, wm_Char, wm_Char, pm_Remove) or
     PeekMessage(Msg, 0, wm_SysKeyDown, wm_SysKeyDown, pm_Remove) then
  with Msg do
  begin
    case Message of
      wm_Char:
	begin
	  Event.What := evKeyDown;
          if AnsiCode
          then Event.CharCode := Chr(wParam)
          else begin
            wParam := Lo(wParam); {Hi-byte is sentinel}
            AnsiTo437(@wParam);
            Event.CharCode := Chr(wParam)
          end;
	  Event.ScanCode := 0;
	end;
      wm_KeyDown,
      wm_SysKeyDown:
	begin
	  If CheckBreak and (wParam = vk_Cancel)
	  then begin
	    CloseGraphics;
	    Halt(1);
	  end;
	  Event.KeyCode := TranslateKey(wParam, Message=wm_SysKeyDown);
	  If Event.KeyCode = 0
	  then begin
	    TranslateMessage(Msg);
	    If Message = wm_SysKeyDown
	    then DispatchMessage(Msg)
	  end
	  else Event.What := evKeyDown;
	end;
    end;
  end
end;

procedure GetTimerEvent(var Event: TEvent);
var
  Msg: TMsg;
begin
  Event.What := evNothing;
  If PeekMessage(Msg, 0, 0, wm_KeyDown - 1, pm_Remove) or
     PeekMessage(Msg, 0, wm_KeyDown + 1, wm_Char - 1, pm_Remove) or
     PeekMessage(Msg, 0, wm_Char + 1, wm_SysKeyDown - 1, pm_Remove) or
     PeekMessage(Msg, 0, wm_SysKeyDown + 1, wm_MouseFirst - 1, pm_Remove) or
     PeekMessage(Msg, 0, wm_MouseLast + 1, $FFFF, pm_Remove)
  then begin
    If Msg.message = wm_Timer then
    with Msg do
    begin
      Event.What := evTimer;
      Event.InfoLong := TimeCount;
      Inc(TimeCount);
    end
    else begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
    end;
  end;
end;

function GetShiftState: Byte;
var
  State: Byte;
begin
  State := 0;
  If GetKeyState(vk_Shift) and $8000 <> 0 then State := State or (kbLeftShift + kbRightShift);
  If GetKeyState(vk_Control) and $8000 <> 0 then State := State or kbCtrlShift;
  If GetKeyState(vk_Menu) and $8000 <> 0 then State := State or kbAltShift;
  If GetKeyState(vk_NumLock) and 1 <> 0 then State := State or kbNumState;
  If GetKeyState(vk_Capital) and 1 <> 0 then State := State or kbCapsState;
  GetShiftState := State
end;

procedure SetCriticalAreaR(var R: TRect);
begin
end;

procedure SetCurrentCursor (n: Integer);
begin
  MCurrent:=n;
  If n=mcNoCursor then n:=MCurStandard;
  SetMCursor (n);
end;

procedure SetMCursor(n: Integer);
begin
  NewNum := n;
  RealizeCursor;
end;

procedure SetMousePos(x, y: Integer);
begin
end;

procedure SetMouseArea(x1, y1, x2, y2: Integer);
begin
end;

procedure SetCriticalArea(x1, y1, x2, y2: Integer);
begin
end;

procedure SetCursorPtr(p: pointer);
begin
end;

function MouseInstalled: Boolean;
begin
  MouseInstalled := true
end;

{ Video }

procedure InitVideo;
begin
  {InitGraphics;}
end;

procedure DoneVideo;
begin
  {CloseGraphics}
end;

procedure SetScreenMode(Mode: Byte);
begin
end;

{ Fonts }

procedure TFontCollection.FreeItem(Item: pointer);
begin
  If Item <> nil then
  Dispose(PLogFont(Item))
end;

procedure TFontCollection.Insert(Item: pointer);
var
  i: Integer;
Begin
  For i := 0 to Count - 1 do
    If Items^[i] = nil
    then Begin
      AtPut(i, Item);
      Exit
    End;
  TCollection.Insert(Item)
End;

procedure InitFonts;
var
  LogFont: PLogFont;
begin
  New(FontCollection, Init(8, 8));

  New(LogFont);
  FillChar(LogFont^, SizeOf(TLogFont), 0);
  with LogFont^ do
  begin
    lfHeight := 16;
    StrCopy(lfFaceName, 'System')
  end;
  FontCollection^.Insert(LogFont);

  New(LogFont);
  FillChar(LogFont^, SizeOf(TLogFont), 0);
  with LogFont^ do
  begin
    lfHeight := 13;
    StrCopy(lfFaceName, 'MS Sans Serif');
    lfWeight := fw_Bold;
  end;
  FontCollection^.Insert(LogFont);

  New(LogFont);
  FillChar(LogFont^, SizeOf(TLogFont), 0);
  with LogFont^ do
  begin
    lfHeight := 13;
    lfPitchAndFamily := ff_Modern;
    StrCopy(lfFaceName, 'Terminal');
  end;
  FontCollection^.Insert(LogFont);
end;

procedure DoneFonts;
begin
  Dispose(FontCollection, Done);
  FontCollection := nil
end;

var
  LowColor, HighColor: TColorRef;
  AnsiFont: Boolean;
  CanKern: Boolean;

procedure OutTextXY(x, y: Integer; s: string);
var
  P, Q: PChar;
  col: Boolean;
  i: Integer;
begin
  If s <> ''
  then begin
    SetTextAlign(DC, ta_Left + ta_Top + ta_UpdateCP);
    case sHoriz of
      LeftText:
	;
      CenterText:
	Dec(x, TextWidth(s) div 2);
      RightText:
	Dec(x, TextWidth(s));
    end;
    case sVert of
      TopText:
	;
      CenterText:
	Dec(Y, TextHeight('') div 2);
      BaseLine:
	SetTextAlign(DC, ta_Left + ta_Baseline + ta_UpdateCP);
      BottomText:
	SetTextAlign(DC, ta_Left + ta_Bottom + ta_UpdateCP);
    end;
    WinProcs.MoveTo(DC, x, y);
    If not AnsiCode and AnsiFont then AnsiFrom437Str(@s);
    P := @s[1]; Q := P;
    col := false;
    SetTextColor(DC, LowColor);
    if CanKern
    then begin
      For i := 1 to Length(s) do
      begin
        If Q[0] = sMarker
        then begin
	  If col
	  then SetTextColor(DC, HighColor)
	  else SetTextColor(DC, LowColor);
	  If Q <> P then TextOut(DC, 0, 0, P, Q - P);
	  col := not col;
	  P := Q + 1
        end;
        Inc(Q)
      end;
      If col
      then SetTextColor(DC, HighColor)
      else SetTextColor(DC, LowColor);
      If Q <> P then TextOut(DC, 0, 0, P, Q - P);
    end
    else begin
      For i := 1 to Length(s) do
      begin
        If s[i] = sMarker
        then begin
	  If col
	  then SetTextColor(DC, HighColor)
	  else SetTextColor(DC, LowColor);
	  col := not col;
        end
        else begin
          TextOut(DC, 0, 0, @s[i], 1);
        end
      end
    end
  end
end;

procedure SetTextJustify(Horiz, Vert: Word);
begin
  sHoriz := Horiz;
  sVert := Vert
end;

procedure SetTextParams(Font: Word; CharSpace: Integer; Color: Word;
  UseMarker: Boolean);
var
  LF: PLogFont;
  TM: WinTypes.TTextMetric;
begin
  BeginGetInfo;
  sFont := Font;
  LF := FontCollection^.At(Font);
  If DC <> 0 then
  DeleteObject(SelectObject(DC,
    CreateFontIndirect(LF^)));
  WinProcs.GetTextMetrics(DC, TM);
  AnsiFont := TM.tmCharSet = Ansi_CharSet;
  sColor := Color;
  LowColor := TransColor(Lo(Color));
  HighColor := TransColor(Hi(Color));
  If UseMarker
    then sMarker := potMarker
    else sMarker := #255;
  SetTextCharacterExtra(DC, CharSpace);
  SetKern(true);
end;

procedure SetExtTextParams(Font: Word; Charspace: Integer; Color: Word;
  UseMarker: Boolean; Attr: Word);
begin
  SetTextParams(Font, Charspace, Color, UseMarker)
end;

procedure SetKern(Enable: Boolean);
begin
  CanKern := Enable
end;

procedure SetMarker(Marker: Char);
Begin
  potMarker := Marker
End;

function TextWidth(s: string): Integer;
var
  i: Integer;
  w: Integer;
begin
  If not AnsiCode then AnsiFrom437Str(@s);
  If CanKern
  then begin
    For i := Length(s) downto 1 do
      If s[i] = sMarker then Delete(s, i, 1);
    If s = ''
    then TextWidth := 0
    else TextWidth := LoWord(GetTextExtent(DC, @s[1], Length(s)))
  end
  else begin
    w := 0;
    For i := 1 to Length(s) do
    begin
      if s[i] <> sMarker
      then Inc(w, LoWord(GetTextExtent(DC, @s[i], 1)))
    end;
    TextWidth := w;
  end
end;

function TextHeight(s: string): Integer;
var
  Metrics: TTextMetric;
begin
  GetTextMetrics(Metrics);
  TextHeight := Metrics.tmHeight
end;

procedure GetTextMetrics(var Metrics: TTextMetric);
begin
  WinProcs.GetTextMetrics(DC, Metrics)
end;

function DefFont(Font: PFontRec): Word;
Begin
  if FontCollection <> nil then
  with FontCollection^ do Begin
    Insert(Font);
    DefFont := IndexOf(Font)
  End
End;

procedure ReplaceFont(Font: Word; FontRec: PFontRec);
var
  Item: pointer;
Begin
  if FontCollection <> nil then
  with FontCollection^ do Begin
    Item := At(Font);
    FreeItem(Item);
    AtPut(Font, FontRec)
  End
End;

procedure FreeFont(Font: Word);
begin
  if (FontCollection <> nil) and (Font <> 0) then
  with FontCollection^ do
  Begin
    FreeItem(Items^[Font]);
    Items^[Font] := nil
  End
end;

function LoadCpiFont(FName: string; ReqCP, ReqLength: Integer;
  CharSpace, AVertAdd, AHeight: Integer): PFontRec;
var
  LogFont: PFontRec;
begin
  New(LogFont);
  FillChar(LogFont^, SizeOf(TLogFont), 0);
  with LogFont^ do
  begin
    lfHeight := ReqLength;
    lfPitchAndFamily := ff_Modern;
    StrCopy(lfFaceName, 'Terminal');
  end;
  LoadCpiFont := LogFont;
end;

function LoadBgiFileFont(FName: string; ReqHeight, AMultX, ADivX, AMultY,
  ADivY: Integer; CharSpace, AVertAdd, AHeight: Integer;
  Attr: Word): PFontRec;
var
  LogFont: PFontRec;
begin
  New(LogFont);
  FillChar(LogFont^, SizeOf(TLogFont), 0);
  with LogFont^ do
  begin
    lfHeight := ReqHeight;
    lfPitchAndFamily := ff_Modern;
    StrCopy(lfFaceName, 'Terminal');
  end;
  LoadBgiFileFont := LogFont;
end;

function LoadBiosFont(ReqLength: Word;
  CharSpace, AVertAdd, AHeight: Integer): PFontRec;
var
  LogFont: PFontRec;
begin
  New(LogFont);
  FillChar(LogFont^, SizeOf(TLogFont), 0);
  with LogFont^ do
  begin
    lfHeight := ReqLength;
    lfPitchAndFamily := ff_Modern;
    StrCopy(lfFaceName, 'Terminal');
  end;
  LoadBiosFont := LogFont;
end;

function LoadWinFont(FName: string; reqNr, reqPt, reqLength: Integer;
  CharSpace, AVertAdd, AHeight: Integer; Attr: Word): PFontRec;
var
  LogFont: PFontRec;
begin
  New(LogFont);
  FillChar(LogFont^, SizeOf(TLogFont), 0);
  with LogFont^ do
  begin
    if ReqLength = 0
    then lfHeight := reqPt
    else lfHeight := ReqLength;
    If Attr and ftBold <> 0 then lfWeight := fw_Bold else
    if Attr and ftThin <> 0 then lfWeight := fw_Thin else
    lfWeight := fw_Normal;
    If Attr and ftItalic <> 0 then lfItalic := 1;
    lfCharSet := Default_CharSet;
  end;
  LoadWinFont := LogFont;
end;

{ Window function *******************************************************
}

procedure SetCaption(on_: Boolean);
var
  style: LongInt;
  R: WinTypes.TRect;
begin
  Caption := on_;
{  style := GetWindowLong(HWindow, gwl_Style);
  If not on and (style and ws_Maximize <> 0)
  then SetWindowLong(HWindow, gwl_Style, style and not ws_Caption)
  else SetWindowLong(HWindow, gwl_Style, style or ws_Caption);}
end;

var
  C: TWndClass;

function GvWinFn(Wnd: HWnd; Message: Word; wParam: Word;
  lParam: Longint): Longint; export;
var
  Rect: TRect;
  Pt: TPoint;
  PS: TPaintStruct;
  Event: TEvent;
  TheMsg: TMSG;
begin
  GvWinFn := 0;
  case Message of
    wm_NCCreate:
      begin
	GvWinFn := DefWindowProc(wnd, Message, wParam, lParam);
	SetWindowLong(wnd, gwl_ViewPtr, LongInt(PCreateStruct(lParam)^.lpCreateParams));
	{SetTimer(wnd, 1, 50, nil); } {now in TMainGroup.CreateRootWindow}
        Exit;
      end;
    wm_NCDestroy:
      begin
	{KillTimer(wnd, 1);}
	GvWinFn := DefWindowProc(wnd, Message, wParam, lParam);
        Exit;
      end;
    wm_WindowPosChanging,
    wm_NCActivate,
    wm_NCCalcSize,
    wm_NCPaint:
      If GetWindowLong(wnd, gwl_Style) and gvs_NoFrame <> 0
      then begin
	If Message = wm_NCActivate
	then GvWinFn := 1
	else GvWinFn := 0;
        Exit
      end;
    wm_Paint:
      begin
	SelectWnd(wnd);
	If DC <> 0 then ForceEndDraw;
	DevDC := BeginPaint(wnd, PS);
	GetClipBox(DevDC, WinTypes.TRect(PaintClip));
	Painting := true;
	Paint(GetView(wnd), PS);
	Painting := false;
	EndPaint(wnd, PS);
	DevDC := 0;
        Exit;
      end;
  end;
  TheMsg.hwnd := wnd;
  TheMsg.message := Message;
  TheMsg.wParam := wParam;
  TheMsg.lParam := lParam;
  Event.What := evSystem;
  Event.InfoPtr := @TheMsg;
  Event.Wnd := HWindow;
  SystemMessage(GetView(wnd), Event);
  If Event.What = evSystem
  then GvWinFn := DefWindowProc(wnd, Message, wParam, lParam)
  else GvWinFn := 0;
end;

function GetView(Wnd: TWinHandle): pointer;
begin
  If GetWindowLong(Wnd, gwl_WndProc) = LongInt(@GvWinFn)
  then GetView := pointer(GetWindowLong(Wnd, gwl_ViewPtr))
  else GetView := nil
end;

begin
  with C do
  begin
    lpszClassName := 'GvSystem';
    hCursor       := 0 {LoadCursor(0, idc_Arrow)};
    lpszMenuName  := nil;
    style         := cs_HRedraw or cs_VRedraw or cs_DblClks {or cs_GlobalClass};
    lpfnWndProc   := TFarProc(@GvWinFn);
    hInstance     := System.hInstance;
    hIcon         := WinProcs.LoadIcon(0, idi_Application);
    cbWndExtra    := GvSystemWinExtra;
    cbClsExtra    := 0;
    hbrBackground := 0 {GetStockObject(White_Brush)};
  end;
  WinProcs.RegisterClass(C);
end.

