source: branches/Xvcl/Drivers/Driver.VideoVCL.pas

unit Driver.VideoVCL;

interface

uses
  Vcl.Forms, Vcl.Graphics, System.Types, UFormMain, Xvcl.Classes, Xvcl.Kernel,
  Xvcl.Graphics, Generics.Collections;

type
  TDriverVideoVCL = class(TDriver)
    Form: Vcl.Forms.TForm;
    procedure Initialize; override;
    procedure Finalize; override;
  end;

  TVideoDeviceVCL = class(TVideoDevice)
    CanvasVCL: Vcl.Graphics.TCanvas;
    function ColorToVCL(Color: TColor): Vcl.Graphics.TColor;
    procedure FillRect(Rect: TRectangle; Color: TColor); override;
    procedure Line(Pos1, Pos2: TPoint; Color: TColor); override;
    procedure TextOut(Position: TPoint; Text: string); override;
    function GetTextSize(Text: string): TPoint; override;
  end;

implementation

{ TDriveVideoVCL }

procedure TDriverVideoVCL.Finalize;
begin
  Form.Destroy;
  inherited;
end;

procedure TDriverVideoVCL.Initialize;
var
  VideoDeviceVCL: TVideoDeviceVCL;
begin
  inherited;
  Application.CreateForm(TForm1, Form1);
  Form := Application.MainForm;
  VideoDeviceVCL := TVideoDeviceVCL.Create;
  VideoDeviceVCL.CanvasVCL := TForm1(Form).Image1.Canvas;
  VideoDeviceVCL.Size := TPoint.Create(Form.Width, Form.Height);
  Kernel.Screen.Size := TPoint.Create(Form.Width, Form.Height);
  if Assigned(Kernel.Screen.VideoDevice) then
    Kernel.Screen.VideoDevice.Destroy;
  Kernel.Screen.VideoDevice := VideoDeviceVCL;

  Application.MainForm.Show;
end;

{ TVideoDeviceVCL }

function TVideoDeviceVCL.ColorToVCL(Color: TColor): Vcl.Graphics.TColor;
begin
  case Color of
    clBlack: Result := $000000;
    clWhite: Result := $ffffff;
    clBlue: Result := $ff0000;
    clGreen: Result := $00ff00;
    clRed: Result := $0000ff;
    clSilver: Result := $c0c0c0;
    clGray: Result := $808080;
    clLightBlue: Result := $ffb0b0;
    clLightRed: Result := $b0ffb0;
    clLightGreen: Result := $b0b0ff;
    clBrown: Result := $a52a2a;
    clMagenta: Result := $ff00ff;
    clCyan: Result := $00ffff;
    clYellow: Result := $ffff00;
    else Result := $000000;
  end;
end;

procedure TVideoDeviceVCL.FillRect(Rect: TRectangle; Color: TColor);
begin
  inherited;
  CanvasVCL.Brush.Color := ColorToVCL(Color);
  CanvasVCL.FillRect(System.Types.Rect(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom));
end;

function TVideoDeviceVCL.GetTextSize(Text: string): TPoint;
begin
  Result := TPoint.Create(CanvasVCL.TextWidth(Text), CanvasVCL.TextHeight(Text));
end;

procedure TVideoDeviceVCL.Line(Pos1, Pos2: TPoint; Color: TColor);
begin
  CanvasVCL.Pen.Color := ColorToVCL(Color);
  CanvasVCL.MoveTo(Pos1.X, Pos1.Y);
  CanvasVCL.LineTo(Pos2.X, Pos2.Y);
end;

procedure TVideoDeviceVCL.TextOut(Position: TPoint; Text: string);
begin
  CanvasVCL.Brush.Style := bsClear;
  CanvasVCL.TextOut(Position.X, Position.Y, Text);
end;

end.