Rising Force the Roguelike Code

unit TicToc;

interface

{ $DEFINE NOMULTIMEDIA}

uses Windows, Dialogs, SysUtils, Math;

const
  MAXCHANNEL = 40;
  EventsSecond: cardinal = 1000;

type

  TMyEvent = record
    CurSecond:   cardinal;
    Counter:     cardinal;
    LastCounter: cardinal;
  end;

  TPerformanceCNT = class
    Last, Delta, Max, Min, Sum, Stat: int64;
    procedure Reset;
    procedure Tic;
    procedure Toc;
    constructor Create;
    function PerformanceStr: string;
  end;

var
  Timer: int64;

  Timer2: array[0..MAXCHANNEL] of cardinal;
  Events: array[0..MAXCHANNEL] of TMyEvent;


  QFrequency: int64;
  UseQ: boolean;


{$IFDEF NOMULTIMEDIA}
procedure QueryPerformanceCounter(var q: int64);
function QueryPerformanceFrequency(var q: int64): boolean;
{$ENDIF}



procedure Tic;
procedure Toc;

procedure Tic2(Channel: byte = 1);
function Toc2(Channel: byte = 1): string;

procedure ReticEvent(Channel: byte = 1);
procedure TicEvent(Channel: byte = 1);
function TocEvent(Channel: byte = 1): string;

function MyGetTickCount: cardinal;
function MyGetTime: real;


implementation


{$IFDEF NOMULTIMEDIA}
procedure QueryPerformanceCounter(var q: int64);
begin
  q := GetTickCount;
end;

function QueryPerformanceFrequency(var q: int64): boolean;
begin
  q      := 1000;
  Result := True;
end;

{$ENDIF}

function MyGetTickCount: cardinal;
var
  q: int64;
begin
  if UseQ then
  begin
    QueryPerformanceCounter(q);
    Result := round(q / QFrequency * 1000);
  end
  else
    Result := GetTickCount;
end;

procedure Tic;
begin
  QueryPerformanceCounter(Timer);
end;


procedure Toc;
var
  q: int64;
begin
  QueryPerformanceCounter(q);
  ShowMessage('Çàäåðæêà=' + FloatToStr(SimpleRoundTo(
    (q - Timer) / QFrequency * 1000)) + ' ìñ');
  Timer := q;
end;


procedure Tic2(Channel: byte);
begin
  Timer2[Channel] := MyGetTickCount;
end;

function Toc2(Channel: byte): string;
var
  i: cardinal;
begin
  i      := myGetTickCount;
  Result := IntToStr(i - Timer2[Channel]) + ' ms';
  Timer2[Channel] := i;
end;


procedure ReticEvent(Channel: byte);
begin
  with Events[Channel] do
  begin
    CurSecond   := 0;
    Counter     := 0;
    LastCounter := 0;
  end;
end;

procedure TicEvent(Channel: byte);
var
  c: cardinal;
begin
  c := myGetTickCount div EventsSecond;
  with Events[Channel] do
    if c = CurSecond then
      Inc(Counter)
    else
    begin
      LastCounter := Counter;
      CurSecond   := c;
      Counter     := 0;
    end;
end;

function TocEvent(Channel: byte): string;
var
  c: cardinal;
begin
  Result := IntToStr(Events[Channel].LastCounter);
  c      := myGetTickCount div EventsSecond;
  with Events[Channel] do
    if c <> CurSecond then
    begin
      LastCounter := Counter;
      CurSecond   := c;
      Counter     := 0;
    end;
end;

{ TPerformanceCNT }

constructor TPerformanceCNT.Create;
begin
  inherited;
  Reset;
end;

function TPerformanceCNT.PerformanceStr: string;
begin
  if Stat > 0 then
{    Result := 'Delta= ' + IntToStr(Delta) + ' ìêñ' + #13#10 +
      'Min= ' + IntToStr(Min) + ' ìêñ' + #13#10 +
      'Max= ' + IntToStr(Max) + ' ìêñ' + #13#10 + 'Count= ' + IntToStr(Stat) + #13#10 +
      'AVG= ' + IntToStr(round(Sum / Stat)) + ' ìêñ'}
    Result := Format('%d(%d) ms', [Delta div 1000, Max div 1000])
  else
    Result := 'NO DATA';
end;

procedure TPerformanceCNT.Reset;
begin
  Stat := 0;
  Sum  := 0;
  Max  := 0;
  Min  := 10000000;
end;

procedure TPerformanceCNT.Tic;
begin
  QueryPerformanceCounter(Last);
end;

procedure TPerformanceCNT.Toc;
var
  q: int64;
begin
  QueryPerformanceCounter(q);
  Delta := round((q - Last) / QFrequency * 1000000);
  if Delta > Max then
    Max := Delta;
  if Delta < Min then
    Min := Delta;
  Stat  := Stat + 1;
  Sum   := Sum + Delta;
  Last  := q;
end;

function MyGetTime: real;
var
  q: int64;
begin
  if UseQ then
  begin
    QueryPerformanceCounter(q);
    Result := q / QFrequency;
  end
  else
    Result := GetTickCount / 1000;
end;

begin
  UseQ := (QueryPerformanceFrequency(QFrequency)) and (QFrequency > 100);
end.