unit RoadSys;

interface
  uses  windows, messages;

type
  TByteArray    = array of Byte;
  PByteArray    = ^TByteArray;

    TBaseClass  = class of TBaseObject;

    TBaseObject = class
      constructor Create;virtual;abstract;
    end;

  ProcedureOfObject = procedure of object;
  TMouseRec       = record
    X,Y       : Integer;
    LButton,
    RButton,
    MButton   : Boolean;
  end;

  TWindow    = class
    Handle  : Cardinal;
    Left,
    Top,
    Width,
    Height  : Integer;
    DC      : HDC;
    constructor Create(iLeft, iTop, iWidth, iHeight: Integer);
    procedure Show;
    procedure Hide;
    destructor Destroy;override;
  end;

    TRoadApplication  = class
        Keys    : array[0..255] of Byte;
        Mouse   : TMouseRec;
        Window  : TWindow;
        FullScreened  : Boolean;
        procedure ChangeDisplayMode(iWidth, iHeight, iBPP : Integer);
        procedure ChangeDisplayModeToDefault;
        procedure InitFullScreen;
        procedure InitWindowed(iLeft,iTop,iWidth,iHeight  : Integer);
        procedure ProcessMessages;
        procedure SetUpdateProc(NewUpdateProc : pointer);overload;
        procedure SetUpdateProc(NewUpdateProc : ProcedureOfObject);overload;
        procedure SetRenderProc(NewRenderProc : pointer);overload;
        procedure SetRenderProc(NewRenderProc : ProcedureOfObject);overload;
        procedure Run(UPS : DWORD);
      private
        UpdateProc               : procedure;
        RenderProc               : procedure;
        UpdateProcObject         : ProcedureOfObject;
        RenderProcObject         : ProcedureOfObject;
        function GetScreenWidth  : Integer;
        function GetScreenHeight : Integer;
      published
        property ScreenWidth  : Integer read GetScreenWidth;
        property ScreenHeight : Integer read GetScreenHeight;
    end;

  TMappedFile = class
    Memory  : Pointer;
    function MapFile(FileName : String; GenAccess  : Cardinal) : Boolean;
    function MapFileCopyWrite(FileName : String) : Boolean;
    procedure UnMapFile;
    private
    hFile : Cardinal;
    flProtect : Cardinal;
    hFMap : Cardinal;
    DesAcc  : Cardinal;
    FFileSize: integer;
    procedure SetFileSize(NewFileSize : integer);
    published
    property FileSize : integer read FFileSize write SetFileSize;
  end;

  TFont = class
    Font  : HFont;
    constructor Create(FontName : string; FontHeight : integer);
    destructor Destroy;override;
  end;

const
  S_WINDOWCLASS   =   'TRoadWindow';
implementation
  uses  RoadGlobal;
function WinProc(wnd  : Cardinal; msg:Cardinal; wPar,lPar  : Integer):  Cardinal; stdcall;
begin
  with Application do
  Case msg of
        WM_KEYDOWN:
            Keys[wPar]  :=  1;
          WM_KEYUP:
            Keys[wPar]  :=  0;
      WM_MOUSEMOVE:
        begin
          Mouse.X :=  LoWord(lPar);
          Mouse.Y :=  HiWord(lPar);
        end;
        WM_LBUTTONDOWN:
          Mouse.LButton :=  True;
        WM_LBUTTONUP  :
          Mouse.LButton :=  False;
        WM_RBUTTONDOWN:
          Mouse.RButton :=  True;
        WM_RBUTTONUP  :
          Mouse.RButton :=  False;
  end;
  Result  :=  DefWindowProc(wnd,msg,wPar,lPar);
end;

constructor TWindow.Create(iLeft, iTop, iWidth, iHeight: Integer);
var
  wndClass  : TWndClass;
begin
  ZeroMemory(@wndClass,SizeOf(wndClass));
  with wndClass do
    begin
      style           := CS_HREDRAW	or CS_VREDRAW;
      lpfnWndProc     := @WinProc;
      hbrBackground   :=  GetStockObject(BLACK_BRUSH);
      hInstance       :=  HInstance;
      lpszClassName   := S_WINDOWCLASS;
      hCursor         :=  (LoadCursor(HInstance,IDC_ARROW))
    end;
   RegisterClass(wndClass);
   Handle :=  CreateWindow(wndClass.lpszClassName,nil,WS_POPUP or WS_VISIBLE,iLeft,iTop,iWidth,iHeight,0,0,HInstance,nil);
   if Handle<>0 then
    begin
      Left  :=  iLeft;
      Top   :=  iTop;
      Width :=  iWidth;
      Height  :=  iHeight;
    end;
   DC :=  GetWindowDC(Handle);
end;

destructor TWindow.Destroy;
begin
  inherited;
end;

procedure TWindow.Hide;
begin
  ShowWindow(Handle,SW_HIDE);
end;

procedure TWindow.Show;
begin
  ShowWindow(Handle,SW_SHOW);
end;

{ TRoadApplication }

procedure TRoadApplication.ChangeDisplayMode(iWidth, iHeight,
  iBPP: Integer);
var
  _Dev  : TDeviceModeA;
begin
  ZeroMemory(@_Dev,SizeOf(_Dev));
  with _Dev do
    begin
      dmSize  :=  SizeOf(_Dev);
      dmBitsPerPel  :=  iBPP;
      dmPelsWidth   :=  iWidth;
      dmPelsHeight  :=  iHeight;
      dmFields      :=  DM_BITSPERPEL	or DM_PELSWIDTH	or DM_PELSHEIGHT;
    end;
  ChangeDisplaySettings(_Dev,0);
end;

procedure TRoadApplication.ChangeDisplayModeToDefault;
asm
  push 0
  push 0
  call ChangeDisplaySettings
end;

function TRoadApplication.GetScreenHeight: Integer;
begin
  Result  :=  GetSystemMetrics(SM_CYSCREEN);
end;

function TRoadApplication.GetScreenWidth: Integer;
begin
  Result  :=  GetSystemMetrics(SM_CXSCREEN);
end;

procedure TRoadApplication.InitFullScreen;
begin
  Window  :=  TWindow.Create(0,0,ScreenWidth,ScreenHeight);
  FullScreened  :=  True;  
end;

procedure TRoadApplication.InitWindowed(iLeft, iTop, iWidth,
  iHeight: Integer);
begin
  Window  :=  TWindow.Create(iLeft,iTop,iWidth,iHeight);  
end;

procedure TRoadApplication.ProcessMessages;
var
  Msg : TMsg;
begin
  while PeekMessage(Msg,0,0,0,PM_REMOVE) do
    begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
    end;
end;

procedure TRoadApplication.Run(UPS : DWORD);
var
  t : dword;
  Upd : dword;
begin
  Upd :=  GetTickCount;
  t   :=  1000 div UPS;
  while IsWindow(Window.Handle) do
    begin
      ProcessMessages;
      if GetTickCount - Upd >= t then
        begin
          Upd := GetTickCount;
          if Assigned(UpdateProc) then
            UpdateProc
              else
                if Assigned(UpdateProcObject) then
                  UpdateProcObject;
        end;
      if Assigned(RenderProc) or Assigned(RenderProcObject) then
        begin
          Render.SetRenderContext;
          if Assigned(RenderProc) then
            RenderProc
              else
                if Assigned(RenderProcObject) then
                  RenderProcObject;
          Render.FreeRenderContext;
        end;

    end;
end;

procedure TRoadApplication.SetRenderProc(NewRenderProc: pointer);
begin
  RenderProc  :=  NewRenderProc;
end;

procedure TRoadApplication.SetUpdateProc(NewUpdateProc: pointer);
begin
  UpdateProc  :=  NewUpdateProc;
end;

procedure TRoadApplication.SetRenderProc(NewRenderProc: ProcedureOfObject);
begin
  RenderProcObject  :=  NewRenderProc;
end;

procedure TRoadApplication.SetUpdateProc(NewUpdateProc: ProcedureOfObject);
begin
  UpdateProcObject  :=  NewUpdateProc;
end;

function TMappedFile.MapFile(FileName : String; GenAccess  : Cardinal) : Boolean;
begin
  hFile :=  CreateFile(PChar(FileName), GenAccess,0,nil,OPEN_ALWAYS,FILE_ATTRIBUTE_NORMAL,0);
  FileSize  :=  GetFileSize(hFile,nil);
  flProtect :=  0;
  DesAcc    :=  0;
  if (GenAccess and GENERIC_READ)<>0 then
   begin
    flProtect :=  flProtect or PAGE_READONLY;
    DesAcc    :=  DesAcc or FILE_MAP_READ;
   end;
   if (GenAccess and GENERIC_WRITE)<>0 then
         begin
          flProtect :=  PAGE_READWRITE;
          DesAcc    :=  DesAcc or FILE_MAP_WRITE;
         end;
  hFMap   :=  CreateFileMapping(hFile,nil,flProtect,0,0,nil);
  Memory  :=  MapViewOfFile(hFMap,DesAcc,0,0,0);
  Result  :=  Memory <> nil;
end;

function TMappedFile.MapFileCopyWrite(FileName: String): Boolean;
begin
  hFile :=  CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
  FileSize  :=  GetFileSize(hFile,nil);
  hFMap   :=  CreateFileMapping(hFile,nil,PAGE_WRITECOPY,0,0,nil);
  Memory  :=  MapViewOfFile(hFMap,FILE_MAP_COPY,0,0,0);
  Result  :=  Memory <> nil;
end;

procedure TMappedFile.SetFileSize(NewFileSize: integer);
begin
  UnmapViewOfFile(Memory);
  CloseHandle(hFMap);
  hFMap   :=  CreateFileMapping(hFile,nil,flProtect,0,NewFileSize,nil);
  Memory  :=  MapViewOfFile(hFMap,DesAcc,0,0,0);
end;

procedure TMappedFile.UnMapFile;
begin
  UnmapViewOfFile(Memory);
  CloseHandle(hFMap);
  CloseHandle(hFile);
end;



{ TFont }

constructor TFont.Create(FontName : string; FontHeight : integer);
begin
  Font  :=  CreateFont(-FontHeight,0,0,0,FW_BOLD,0,0,0,ANSI_CHARSET,OUT_TT_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,FF_DONTCARE or DEFAULT_PITCH,PChar(FontName));
end;

destructor TFont.Destroy;
begin
  DeleteObject(Font);
  inherited;
end;

end.
