sync: restore source from Google Drive
Sync changed files to Google Drive / sync (push) Successful in 1h45m13s
Sync changed files to Google Drive / sync (push) Successful in 1h45m13s
This commit is contained in:
admin_d committed
1 parent
e2d8247e91
commit
7063d1b1c9
993 files changed
+949976
No files matched your search
+196
@@ -0,0 +1,196 @@
|
||||
unit KM_Achievements;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, KromUtils,
|
||||
KM_CommonClasses, KM_Defaults, KM_ResourceHouse, KM_ResourceUnit;
|
||||
|
||||
|
||||
type
|
||||
//Achievements represent the behavior we want to encourage, they are to
|
||||
//help player to explore the game and try out all its possibilities.
|
||||
//These are the points we need to ask ourselves before adding an achievement:
|
||||
// - Does it encourages advancing into the game (beat campaigns, play MP, use all troops, focus on different town specializations)
|
||||
// - Is it player controlled (good: train 100 knights in one game. bad: have single archer kill 10 militia with 10 shots)
|
||||
// - Could it be proud of (good: win without losses. bad: get defeated 10 times)
|
||||
|
||||
//Can be split into basic mechanic types:
|
||||
// A. during single mission
|
||||
// B. accumulating all the time
|
||||
// 1. statistical (collect some stats, e.g. build 5 Inns)
|
||||
// 2. conditional (have something combined with something else)
|
||||
TKMAchievements = class;
|
||||
|
||||
TKMAchievementEvent = (aeHouseBuilt, aeMissionEnd, aeMissionStart, aeUnitTrained);
|
||||
|
||||
TKMAchievement = class
|
||||
private
|
||||
fIsAwarded: Boolean;
|
||||
public
|
||||
procedure Process(aEvent: TKMAchievementEvent; aParams: array of const); virtual; abstract;
|
||||
|
||||
//Progress towards receiving the achievement
|
||||
property IsAwarded: Boolean read fIsAwarded;
|
||||
function Progress: Single; virtual;
|
||||
|
||||
//Save load
|
||||
procedure LoadFromStream(aStream: TKMemoryStream); virtual;
|
||||
procedure SaveToStream(aStream: TKMemoryStream); virtual;
|
||||
end;
|
||||
|
||||
//Build one of each houses and train one of each units
|
||||
TKMAchievementVariety = class(TKMAchievement)
|
||||
private
|
||||
fHousesBuilt: array [HOUSE_MIN..HOUSE_MAX] of Boolean;
|
||||
fCitizenTrained: array [CITIZEN_MIN..CITIZEN_MAX] of Boolean;
|
||||
fWarriorsTrained: array [WARRIOR_EQUIPABLE_MIN..WARRIOR_EQUIPABLE_MAX] of Boolean;
|
||||
public
|
||||
procedure Process(aEvent: TKMAchievementEvent; aParams: array of const); override;
|
||||
function Progress: Single; override;
|
||||
procedure LoadFromStream(aStream: TKMemoryStream); override;
|
||||
procedure SaveToStream(aStream: TKMemoryStream); override;
|
||||
end;
|
||||
|
||||
//Easy:
|
||||
// - Win with just starting troops
|
||||
// - Build one of each houses and train one of each units
|
||||
|
||||
//Medium:
|
||||
// - Win MP game with only one type of warriors
|
||||
// - Beat the campaign
|
||||
// - Have certain amount of warfare made and equip soldiers with it till some time
|
||||
|
||||
//Hard:
|
||||
// -
|
||||
|
||||
TKMAchievements = class
|
||||
private
|
||||
fList: TList;
|
||||
fOwner: TPlayerIndex;
|
||||
procedure ProcessEvent(aEvent: TKMAchievementEvent; aParams: array of const);
|
||||
public
|
||||
constructor Create(aOwner: TPlayerIndex);
|
||||
destructor Destroy; override;
|
||||
|
||||
//Just like Stats or GIP or Scripting we receive a handful of events from the game
|
||||
procedure HouseBuilt(aHouseType: TKMHouseType);
|
||||
procedure MissionEnd(aGameResult: TGameResultMsg; aMissionName: string);
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math, KM_PlayersCollection, KM_Resource;
|
||||
|
||||
|
||||
{ TKMAchievement }
|
||||
function TKMAchievement.Progress: Single;
|
||||
begin
|
||||
//As simple as that incase child class does not implements Progress
|
||||
Result := Byte(fIsAwarded);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAchievement.LoadFromStream(aStream: TKMemoryStream);
|
||||
begin
|
||||
//
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAchievement.SaveToStream(aStream: TKMemoryStream);
|
||||
begin
|
||||
//
|
||||
end;
|
||||
|
||||
|
||||
{ TKMAchievementVariety }
|
||||
procedure TKMAchievementVariety.Process(aEvent: TKMAchievementEvent; aParams: array of const);
|
||||
var
|
||||
ut: TKMUnitType;
|
||||
begin
|
||||
if aEvent = aeMissionStart then
|
||||
begin
|
||||
//Reset achievement on each new mission
|
||||
FillChar(fHousesBuilt, SizeOf(fHousesBuilt), #0);
|
||||
FillChar(fCitizenTrained, SizeOf(fHousesBuilt), #0);
|
||||
FillChar(fWarriorsTrained, SizeOf(fHousesBuilt), #0);
|
||||
end;
|
||||
if aEvent = aeHouseBuilt then
|
||||
begin
|
||||
Assert((Length(aParams) = 1) and (aParams[0].VType = vtInteger));
|
||||
fHousesBuilt[TKMHouseType(aParams[0].VInteger)] := True;
|
||||
end;
|
||||
if aEvent = aeUnitTrained then
|
||||
begin
|
||||
Assert((Length(aParams) = 1) and (aParams[0].VType = vtInteger));
|
||||
ut := TKMUnitType(aParams[0].VInteger);
|
||||
if ut in [CITIZEN_MIN..CITIZEN_MAX] then
|
||||
fCitizenTrained[ut] := True
|
||||
else
|
||||
if ut in [WARRIOR_EQUIPABLE_MIN..WARRIOR_EQUIPABLE_MAX] then
|
||||
fWarriorsTrained[ut] := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMAchievementVariety.Progress: Single;
|
||||
begin
|
||||
//Result :=
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAchievementVariety.LoadFromStream(aStream: TKMemoryStream);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAchievementVariety.SaveToStream(aStream: TKMemoryStream);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
end;
|
||||
|
||||
|
||||
{ TKMAchievements }
|
||||
constructor TKMAchievements.Create(aOwner: TPlayerIndex);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fOwner := aOwner;
|
||||
|
||||
fList := TList.Create;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMAchievements.Destroy;
|
||||
begin
|
||||
fList.Free;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAchievements.HouseBuilt(aHouseType: TKMHouseType);
|
||||
begin
|
||||
//Inform all interested achievements
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAchievements.MissionEnd(aGameResult: TGameResultMsg; aMissionName: string);
|
||||
begin
|
||||
ProcessEvent(aeMissionEnd, [Byte(aGameResult), aMissionName]);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAchievements.ProcessEvent(aEvent: TKMAchievementEvent; aParams: array of const);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
for I := 0 to fList.Count - 1 do
|
||||
TKMAchievement(fList[I]).Process(aEvent, aParams);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+504
@@ -0,0 +1,504 @@
|
||||
unit KM_CommonSave;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Math, SysUtils,
|
||||
KM_Points;
|
||||
|
||||
const
|
||||
OBJECT_SIZE = SizeOf(TObject);
|
||||
|
||||
type
|
||||
TKMSaveStreamFormat = (ssfBinary, ssfText);
|
||||
|
||||
TKSaveStream = class(TMemoryStream)
|
||||
public
|
||||
// Assert savegame sections
|
||||
procedure CheckMarker(const aTitle: string); virtual; abstract;
|
||||
procedure PlaceMarker(const aTitle: string); virtual; abstract;
|
||||
|
||||
procedure ReadANSI(out aValue: string); virtual; abstract;
|
||||
procedure WriteANSI(const aValue: string); virtual; abstract;
|
||||
|
||||
//Ansistrings saved by PascalScript into savegame
|
||||
procedure ReadHugeString(out Value: AnsiString); overload;
|
||||
procedure WriteHugeString(const Value: AnsiString); overload;
|
||||
|
||||
// {$IFDEF DESKTOP}
|
||||
//Legacy format for campaigns info, maxlength 65k ansichars
|
||||
procedure ReadA(out Value: AnsiString); reintroduce; overload; virtual; abstract;
|
||||
procedure WriteA(const Value: AnsiString); reintroduce; overload; virtual; abstract;
|
||||
// {$ENDIF}
|
||||
// {$IFDEF TABLET}
|
||||
// //Legacy format for campaigns info, maxlength 65k ansichars
|
||||
// procedure ReadA(out Value: string); reintroduce; overload; virtual; abstract;
|
||||
// procedure WriteA(const Value: string); reintroduce; overload; virtual; abstract;
|
||||
// {$ENDIF}
|
||||
|
||||
// Unicode strings
|
||||
procedure ReadW(out Value: UnicodeString); reintroduce; overload; virtual; abstract;
|
||||
procedure WriteW(const Value: UnicodeString); reintroduce; overload; virtual; abstract;
|
||||
|
||||
function Write(const Buffer; Count: Longint): Longint; overload; override;
|
||||
|
||||
procedure Write(const Value: TKMDirection ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: TKMPoint ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: TKMPointW ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: TKMPointF ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: TKMPointDir ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: TKMRangeInt ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: TKMRangeSingle); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: TKMRect ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: Single ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: Extended ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: Integer ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: Cardinal ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: Byte ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: Boolean ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: Word ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: ShortInt ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: SmallInt ); reintroduce; overload; virtual; abstract;
|
||||
procedure Write(const Value: TDateTime ); reintroduce; overload; virtual; abstract;
|
||||
|
||||
procedure Read(out Value: TKMDirection ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: TKMPoint ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: TKMPointW ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: TKMPointF ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: TKMPointDir ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: TKMRangeInt ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: TKMRangeSingle); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: TKMRect ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: Single ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: Extended ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: Integer ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: Cardinal ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: Byte ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: Boolean ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: Word ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: ShortInt ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: SmallInt ); reintroduce; overload; virtual; abstract;
|
||||
procedure Read(out Value: TDateTime ); reintroduce; overload; virtual; abstract;
|
||||
end;
|
||||
|
||||
// Extended with custom Read/Write commands which accept various types without asking for their length
|
||||
TKMSaveStreamBinary = class(TKSaveStream)
|
||||
public
|
||||
// Assert savegame sections
|
||||
procedure CheckMarker(const aTitle: string); override;
|
||||
procedure PlaceMarker(const aTitle: string); override;
|
||||
|
||||
procedure ReadANSI(out aValue: string); override;
|
||||
procedure WriteANSI(const aValue: string); override;
|
||||
|
||||
// {$IFDEF DESKTOP}
|
||||
//Legacy format for campaigns info, maxlength 65k ansichars
|
||||
procedure ReadA(out Value: AnsiString); override;
|
||||
procedure WriteA(const Value: AnsiString); override;
|
||||
// {$ENDIF}
|
||||
// {$IFDEF TABLET}
|
||||
// //Legacy format for campaigns info, maxlength 65k ansichars
|
||||
// procedure ReadA(out Value: string); override;
|
||||
// procedure WriteA(const Value: string); override;
|
||||
// {$ENDIF}
|
||||
|
||||
// Unicode strings
|
||||
procedure ReadW(out Value: UnicodeString); override;
|
||||
procedure WriteW(const Value: UnicodeString); override;
|
||||
|
||||
function Write(const Buffer; Count: Longint): Longint; override;
|
||||
|
||||
procedure Write(const Value: TKMDirection ); override;
|
||||
procedure Write(const Value: TKMPoint ); override;
|
||||
procedure Write(const Value: TKMPointW ); override;
|
||||
procedure Write(const Value: TKMPointF ); override;
|
||||
procedure Write(const Value: TKMPointDir ); override;
|
||||
procedure Write(const Value: TKMRangeInt ); override;
|
||||
procedure Write(const Value: TKMRangeSingle); override;
|
||||
procedure Write(const Value: TKMRect ); override;
|
||||
procedure Write(const Value: Single ); override;
|
||||
procedure Write(const Value: Extended ); override;
|
||||
procedure Write(const Value: Integer ); override;
|
||||
procedure Write(const Value: Cardinal ); override;
|
||||
procedure Write(const Value: Byte ); override;
|
||||
procedure Write(const Value: Boolean ); override;
|
||||
procedure Write(const Value: Word ); override;
|
||||
procedure Write(const Value: ShortInt ); override;
|
||||
procedure Write(const Value: SmallInt ); override;
|
||||
procedure Write(const Value: TDateTime ); override;
|
||||
|
||||
procedure Read(out Value: TKMDirection ); override;
|
||||
procedure Read(out Value: TKMPoint ); override;
|
||||
procedure Read(out Value: TKMPointW ); override;
|
||||
procedure Read(out Value: TKMPointF ); override;
|
||||
procedure Read(out Value: TKMPointDir ); override;
|
||||
procedure Read(out Value: TKMRangeInt ); override;
|
||||
procedure Read(out Value: TKMRangeSingle); override;
|
||||
procedure Read(out Value: TKMRect ); override;
|
||||
procedure Read(out Value: Single ); override;
|
||||
procedure Read(out Value: Extended ); override;
|
||||
procedure Read(out Value: Integer ); override;
|
||||
procedure Read(out Value: Cardinal ); override;
|
||||
procedure Read(out Value: Byte ); override;
|
||||
procedure Read(out Value: Boolean ); override;
|
||||
procedure Read(out Value: Word ); override;
|
||||
procedure Read(out Value: ShortInt ); override;
|
||||
procedure Read(out Value: SmallInt ); override;
|
||||
procedure Read(out Value: TDateTime ); override;
|
||||
end;
|
||||
|
||||
// Text writer
|
||||
TKMSaveStreamText = class(TKSaveStream)
|
||||
private
|
||||
fLastSection: string;
|
||||
procedure WriteText(const aString: string);
|
||||
public
|
||||
procedure PlaceMarker(const aTitle: string); override;
|
||||
|
||||
procedure WriteANSI(const aValue: string); override;
|
||||
procedure WriteA(const Value: AnsiString); override;
|
||||
procedure WriteW(const Value: UnicodeString); override;
|
||||
|
||||
function Write(const Buffer; Count: Longint): Longint; override;
|
||||
|
||||
procedure Write(const Value: TKMDirection ); override;
|
||||
procedure Write(const Value: TKMPoint ); override;
|
||||
procedure Write(const Value: TKMPointW ); override;
|
||||
procedure Write(const Value: TKMPointF ); override;
|
||||
procedure Write(const Value: TKMPointDir ); override;
|
||||
procedure Write(const Value: TKMRangeInt ); override;
|
||||
procedure Write(const Value: TKMRangeSingle); override;
|
||||
procedure Write(const Value: TKMRect ); override;
|
||||
procedure Write(const Value: Single ); override;
|
||||
procedure Write(const Value: Extended ); override;
|
||||
procedure Write(const Value: Integer ); override;
|
||||
procedure Write(const Value: Cardinal ); override;
|
||||
procedure Write(const Value: Byte ); override;
|
||||
procedure Write(const Value: Boolean ); override;
|
||||
procedure Write(const Value: Word ); override;
|
||||
procedure Write(const Value: ShortInt ); override;
|
||||
procedure Write(const Value: SmallInt ); override;
|
||||
procedure Write(const Value: TDateTime ); override;
|
||||
end;
|
||||
|
||||
TStreamEvent = procedure (aData: TKSaveStream) of object;
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
function TKSaveStream.Write(const Buffer; Count: Longint): Longint;
|
||||
begin
|
||||
Result := inherited Write(Buffer, Count);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKSaveStream.ReadHugeString(out Value: AnsiString);
|
||||
var I: Cardinal;
|
||||
begin
|
||||
Read(I, SizeOf(I));
|
||||
SetLength(Value, I);
|
||||
if I > 0 then
|
||||
Read(Pointer(Value)^, I);
|
||||
end;
|
||||
|
||||
procedure TKSaveStream.WriteHugeString(const Value: AnsiString);
|
||||
var I: Cardinal;
|
||||
begin
|
||||
I := Length(Value);
|
||||
inherited Write(I, SizeOf(I));
|
||||
if I = 0 then Exit;
|
||||
inherited Write(Pointer(Value)^, I);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMSaveStreamBinary }
|
||||
procedure TKMSaveStreamBinary.CheckMarker(const aTitle: string);
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
// We use only Latin for Markers, hence ANSI is fine
|
||||
// But since Android does not support "AnsiString" we take "string" as input
|
||||
ReadANSI(s);
|
||||
Assert(s = aTitle);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMSaveStreamBinary.PlaceMarker(const aTitle: string);
|
||||
begin
|
||||
// We use only Latin for Markers, hence ANSI is fine
|
||||
// But since Android does not support "AnsiString" we take "string" as input
|
||||
WriteANSI(aTitle);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMSaveStreamBinary.ReadANSI(out aValue: string);
|
||||
var
|
||||
I: Word;
|
||||
bytes: TBytes;
|
||||
begin
|
||||
aValue := '';
|
||||
inherited Read(I, SizeOf(I));
|
||||
SetLength(bytes, I);
|
||||
if I = 0 then Exit;
|
||||
inherited Read(bytes[0], I);
|
||||
aValue := TEncoding.ANSI.GetString(bytes);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMSaveStreamBinary.WriteANSI(const aValue: string);
|
||||
var
|
||||
I: Word;
|
||||
bytes: TBytes;
|
||||
begin
|
||||
bytes := TEncoding.ANSI.GetBytes(aValue);
|
||||
I := Length(bytes);
|
||||
Write(I, SizeOf(I));
|
||||
if I = 0 then Exit;
|
||||
Write(bytes[0], I);
|
||||
end;
|
||||
|
||||
|
||||
//{$IFDEF DESKTOP}
|
||||
procedure TKMSaveStreamBinary.ReadA(out Value: AnsiString);
|
||||
var I: Word;
|
||||
begin
|
||||
Read(I, SizeOf(I));
|
||||
SetLength(Value, I);
|
||||
if I > 0 then
|
||||
Read(Pointer(Value)^, I);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamBinary.WriteA(const Value: AnsiString);
|
||||
var I: Word;
|
||||
begin
|
||||
I := Length(Value);
|
||||
inherited Write(I, SizeOf(I));
|
||||
if I = 0 then Exit;
|
||||
inherited Write(Pointer(Value)^, I);
|
||||
end;
|
||||
//{$ENDIF}
|
||||
|
||||
|
||||
//{$IFDEF TABLET}
|
||||
//procedure TKMemoryStream.ReadA(out Value: string);
|
||||
//var I: Word;
|
||||
//begin
|
||||
// Read(I, SizeOf(I));
|
||||
// SetLength(Value, I);
|
||||
// if I > 0 then
|
||||
// Read(Pointer(Value)^, I * SizeOf(WideChar));
|
||||
//end;
|
||||
//
|
||||
//procedure TKMemoryStream.WriteA(const Value: string);
|
||||
//var I: Word;
|
||||
//begin
|
||||
// I := Length(Value);
|
||||
// inherited Write(I, SizeOf(I));
|
||||
// if I = 0 then Exit;
|
||||
// inherited Write(Pointer(Value)^, I * SizeOf(WideChar));
|
||||
//end;
|
||||
//{$ENDIF}
|
||||
|
||||
|
||||
procedure TKMSaveStreamBinary.ReadW(out Value: UnicodeString);
|
||||
var I: Word;
|
||||
begin
|
||||
Read(I, SizeOf(I));
|
||||
SetLength(Value, I);
|
||||
if I > 0 then
|
||||
Read(Pointer(Value)^, I * SizeOf(WideChar));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMSaveStreamBinary.WriteW(const Value: UnicodeString);
|
||||
var I: Word;
|
||||
begin
|
||||
I := Length(Value);
|
||||
inherited Write(I, SizeOf(I));
|
||||
if I = 0 then Exit;
|
||||
inherited Write(Pointer(Value)^, I * SizeOf(WideChar));
|
||||
end;
|
||||
|
||||
function TKMSaveStreamBinary.Write(const Buffer; Count: Longint): Longint;
|
||||
begin
|
||||
Result := inherited Write(Buffer, Count);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamBinary.Read(out Value: TKMDirection); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: TKMPoint); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: TKMPointW); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: TKMPointF); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: TKMPointDir); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: TKMRangeInt); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: TKMRangeSingle); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: TKMRect); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: Single); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: Extended); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: Integer); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: Cardinal); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: Byte); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: Boolean); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: Word); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: ShortInt); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: SmallInt); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Read(out Value: TDateTime); begin inherited Read(Value, SizeOf(Value)); end;
|
||||
|
||||
|
||||
procedure TKMSaveStreamBinary.Write(const Value: TKMDirection); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: TKMPoint); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: TKMPointW); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: TKMPointF); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: TKMPointDir); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: TKMRangeInt); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: TKMRangeSingle); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: TKMRect); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: Single); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: Extended); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: Integer); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: Cardinal); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: Byte); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: Boolean); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: Word); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: ShortInt); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: SmallInt); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
procedure TKMSaveStreamBinary.Write(const Value: TDateTime); begin inherited Write(Value, SizeOf(Value)); end;
|
||||
|
||||
|
||||
{ TKMSaveStreamText }
|
||||
procedure TKMSaveStreamText.WriteText(const aString: string);
|
||||
var
|
||||
I: Word;
|
||||
bytes: TBytes;
|
||||
begin
|
||||
bytes := TEncoding.ANSI.GetBytes(aString + ' ');
|
||||
|
||||
I := Length(bytes);
|
||||
inherited Write(bytes[0], I);
|
||||
end;
|
||||
|
||||
function TKMSaveStreamText.Write(const Buffer; Count: Longint): Longint;
|
||||
begin
|
||||
if Count = 1 then
|
||||
WriteText(IntToHex(PByte(@Buffer)^, 2) + 'h')
|
||||
else
|
||||
if Count = 2 then
|
||||
WriteText(IntToHex(PWord(@Buffer)^, 4) + 'h')
|
||||
else
|
||||
WriteText(IntToStr(Count) + 'bytes');
|
||||
Result := -1;
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.PlaceMarker(const aTitle: string);
|
||||
begin
|
||||
fLastSection := aTitle;
|
||||
WriteText(sLineBreak + '[' + aTitle + ']' + sLineBreak);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.WriteA(const Value: AnsiString);
|
||||
begin
|
||||
WriteText(UnicodeString(Value));
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.WriteANSI(const aValue: string);
|
||||
begin
|
||||
WriteText(aValue);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.WriteW(const Value: UnicodeString);
|
||||
begin
|
||||
WriteText(Value);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: TKMPointDir);
|
||||
begin
|
||||
WriteText(Value.ToString);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: TKMRangeInt);
|
||||
begin
|
||||
WriteText(Value.ToString);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: TKMRangeSingle);
|
||||
begin
|
||||
WriteText(Value.ToString);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: TKMRect);
|
||||
begin
|
||||
WriteText(Value.ToString);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: TKMDirection);
|
||||
begin
|
||||
WriteText('Dir' + IntToStr(Ord(Value)));
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: TKMPoint);
|
||||
begin
|
||||
WriteText(Value.ToString);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: TKMPointW);
|
||||
begin
|
||||
WriteText(Value.ToString);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: TKMPointF);
|
||||
begin
|
||||
WriteText(Value.ToString);
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: Boolean);
|
||||
begin
|
||||
WriteText(BoolToStr(Value, True));
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: Word);
|
||||
begin
|
||||
WriteText(IntToStr(Value));
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: ShortInt);
|
||||
begin
|
||||
WriteText(IntToStr(Value));
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: SmallInt);
|
||||
begin
|
||||
WriteText(IntToStr(Value));
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: Byte);
|
||||
begin
|
||||
WriteText(IntToStr(Value));
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: Single);
|
||||
begin
|
||||
WriteText(Format('%.5f', [Value]));
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: Extended);
|
||||
begin
|
||||
WriteText(Format('%.5f', [Value]));
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: Integer);
|
||||
begin
|
||||
WriteText(IntToStr(Value));
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: Cardinal);
|
||||
begin
|
||||
WriteText(IntToStr(Value));
|
||||
end;
|
||||
|
||||
procedure TKMSaveStreamText.Write(const Value: TDateTime);
|
||||
var
|
||||
Str: String;
|
||||
begin
|
||||
DateTimeToString(Str, 'dd.mm.yyyy hh:nn:ss.zzz', Value);
|
||||
WriteText(Str);
|
||||
end;
|
||||
|
||||
end.
|
||||
+353
@@ -0,0 +1,353 @@
|
||||
unit KM_PerfLog;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Generics.Collections
|
||||
{$IFDEF FPC}
|
||||
, KM_Sort
|
||||
{$ENDIF}
|
||||
;
|
||||
|
||||
|
||||
type
|
||||
TKMPerfSection = (pskTick,
|
||||
pskHungarian, pskAIFields, pskFOW,
|
||||
pskHands, pskPathfinding, pskTerrain, psGIP, pskScripting,
|
||||
pskRender,
|
||||
psFOWCheck, psFOWCheck3, psFOWCheck5,
|
||||
psRenderTer,
|
||||
psRenderTerBase, pskUpdateVBO, psDoTiles, psDoWater, psDoTilesLayers, psDoOverlays, psDoLighting, psDoShadows,
|
||||
psRenderFences, psRenderPlans,
|
||||
psRenderOther, psRenderList, psRenderHands, psRenderFOW
|
||||
);
|
||||
|
||||
const
|
||||
//Unicode for TStringList population
|
||||
SectionName: array [TKMPerfSection] of UnicodeString = ('Tick', 'Hungur', 'AIFields', 'FOW',
|
||||
'Hands', 'PFinding', 'Terrain', 'GIP', 'Script',
|
||||
'Render',
|
||||
'FOWChecks', 'FOWCheck3', 'FOWCheck5',
|
||||
'RenderTer', 'RenTerBase',
|
||||
'UpdateVBO', 'DoTiles', 'DoWater', 'DoLayers', 'DoOverlays', 'DoLight', 'DoShadows',
|
||||
'RenFences', 'RenPlans',
|
||||
'RenderOth', 'RendList', 'RendHands', 'RenderFOW'
|
||||
);
|
||||
|
||||
const
|
||||
SKIP_SECTION: set of TKMPerfSection = [pskHungarian, pskAIFields, pskFOW, psFOWCheck, psFOWCheck3, psFOWCheck5,
|
||||
psRenderOther, psRenderList, psRenderHands, psRenderFOW,
|
||||
pskHands, pskPathfinding, pskTerrain, psGIP, pskScripting];
|
||||
|
||||
type
|
||||
//Log how much time each section takes and write results to a log file
|
||||
|
||||
TKMPerfSectionData = record
|
||||
Section: TKMPerfSection;
|
||||
Time: Int64;
|
||||
end;
|
||||
|
||||
TKMPerfLog = class
|
||||
private
|
||||
fTick: Cardinal;
|
||||
fRenderCounter: Cardinal;
|
||||
fCount: array [TKMPerfSection] of Integer;
|
||||
fTimeEnter: array [TKMPerfSection] of Int64;
|
||||
// fTimes: array [TPerfSection] of array of Int64;
|
||||
fTickTimes: TDictionary<Cardinal, TDictionary<TKMPerfSection, Int64>>;
|
||||
// fRenderTimes: TDictionary<Cardinal, TDictionary<TKMPerfSection, Int64>>;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
procedure Clear;
|
||||
procedure StartTick(aTick: Cardinal);
|
||||
procedure EndTick;
|
||||
procedure StartRender;//(aCounter: Cardinal);
|
||||
procedure EndRender;
|
||||
procedure EnterSection(aSection: TKMPerfSection);
|
||||
procedure LeaveSection(aSection: TKMPerfSection);
|
||||
procedure SaveToFile(const aFilename: UnicodeString);
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Classes, SysUtils, KM_CommonUtils;
|
||||
|
||||
|
||||
const
|
||||
SECT_W = 12;
|
||||
|
||||
|
||||
// LIMITS: array[TPerfSection] of Integer = (30000, 5000, 5000, 5000, 5000, 5000, 5000, 5000);
|
||||
|
||||
|
||||
{ TKMPerfLog }
|
||||
constructor TKMPerfLog.Create;
|
||||
var
|
||||
K: TKMPerfSection;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
for K := Low(TKMPerfSection) to High(TKMPerfSection) do
|
||||
fTimeEnter[K] := 0;
|
||||
|
||||
fTickTimes := TDictionary<Cardinal, TDictionary<TKMPerfSection, Int64>>.Create;
|
||||
|
||||
fRenderCounter := 0;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMPerfLog.Destroy;
|
||||
var
|
||||
SectDict: TDictionary<TKMPerfSection, Int64>;
|
||||
begin
|
||||
for SectDict in fTickTimes.Values do
|
||||
SectDict.Free;
|
||||
|
||||
fTickTimes.Clear;
|
||||
fTickTimes.Free;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPerfLog.Clear;
|
||||
var
|
||||
I: TKMPerfSection;
|
||||
begin
|
||||
for I := Low(TKMPerfSection) to High(TKMPerfSection) do
|
||||
fCount[I] := 0;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPerfLog.StartTick(aTick: Cardinal);
|
||||
var
|
||||
K: TKMPerfSection;
|
||||
SectDict: TDictionary<TKMPerfSection, Int64>;
|
||||
begin
|
||||
Assert(not fTickTimes.ContainsKey(aTick), 'Tick is already started');
|
||||
|
||||
fTick := aTick;
|
||||
|
||||
SectDict := TDictionary<TKMPerfSection, Int64>.Create;
|
||||
fTickTimes.Add(fTick, SectDict);
|
||||
|
||||
EnterSection(pskTick);
|
||||
|
||||
//Init all sections
|
||||
for K := Low(TKMPerfSection) to High(TKMPerfSection) do
|
||||
begin
|
||||
if K = pskTick then
|
||||
Continue;
|
||||
|
||||
EnterSection(K);
|
||||
LeaveSection(K);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPerfLog.EndTick;
|
||||
begin
|
||||
LeaveSection(pskTick);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPerfLog.StartRender;//(aCounter: Cardinal);
|
||||
var
|
||||
K: TKMPerfSection;
|
||||
SectDict: TDictionary<TKMPerfSection, Int64>;
|
||||
begin
|
||||
Inc(fRenderCounter);
|
||||
// Assert(not fRenderTimes.ContainsKey(fRenderCounter), 'Tick is already started');
|
||||
|
||||
SectDict := TDictionary<TKMPerfSection, Int64>.Create;
|
||||
fTickTimes.Add(fRenderCounter, SectDict);
|
||||
|
||||
EnterSection(pskRender);
|
||||
|
||||
//Init all sections
|
||||
for K := Low(TKMPerfSection) to High(TKMPerfSection) do
|
||||
begin
|
||||
if K in [pskTick, pskRender] then
|
||||
Continue;
|
||||
|
||||
EnterSection(K);
|
||||
LeaveSection(K);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPerfLog.EndRender;
|
||||
begin
|
||||
LeaveSection(pskRender);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPerfLog.EnterSection(aSection: TKMPerfSection);
|
||||
begin
|
||||
Assert(fTimeEnter[aSection] = 0, 'Entering not left section');
|
||||
fTimeEnter[aSection] := TimeGetUsec;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPerfLog.LeaveSection(aSection: TKMPerfSection);
|
||||
var
|
||||
T, OldT: Int64;
|
||||
SectDict: TDictionary<TKMPerfSection, Int64>;
|
||||
// SectData: TKMPerfSectionData;
|
||||
begin
|
||||
T := TimeGetUsec - fTimeEnter[aSection]; //Measure it ASAP
|
||||
// if fCount[aSection] >= Length(fTimes[aSection]) then
|
||||
// SetLength(fTimes[aSection], fCount[aSection] + 1024);
|
||||
//
|
||||
// fTimes[aSection, fCount[aSection]] := T;
|
||||
// Assert(fTickTimes.ContainsKey(fTick), 'Leave unopened section at tick' + IntToStr(fTick));
|
||||
|
||||
if fTickTimes.TryGetValue(fTick, SectDict) then
|
||||
// raise Exception.CreateFmt('Leave unopened section at tick %d', [fTick])
|
||||
// else
|
||||
begin
|
||||
// SectData.Section := aSection;
|
||||
// SectData.Time := T;
|
||||
if SectDict.TryGetValue(aSection, OldT) then
|
||||
SectDict.Items[aSection] := OldT + T
|
||||
else
|
||||
SectDict.Add(aSection, T);
|
||||
end;
|
||||
|
||||
// Inc(fCount[aSection]);
|
||||
|
||||
fTimeEnter[aSection] := 0;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}
|
||||
function CompareTicks(const aKey1, aKey2): Integer;
|
||||
var
|
||||
k1: Cardinal absolute aKey1;
|
||||
k2: Cardinal absolute aKey2;
|
||||
begin
|
||||
if k1 < k2 then Result := -1
|
||||
else if k1 > k2 then Result := +1
|
||||
else Result := 0;
|
||||
end;
|
||||
|
||||
function CompareSects(const aKey1, aKey2): Integer;
|
||||
var
|
||||
k1: TKMPerfSection absolute aKey1;
|
||||
k2: TKMPerfSection absolute aKey2;
|
||||
begin
|
||||
if k1 < k2 then Result := -1
|
||||
else if k1 > k2 then Result := +1
|
||||
else Result := 0;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TKMPerfLog.SaveToFile(const aFilename: UnicodeString);
|
||||
var
|
||||
I: Integer;
|
||||
K: TKMPerfSection;
|
||||
S: TStringList;
|
||||
TickKey: Cardinal;
|
||||
SectKey: TKMPerfSection;
|
||||
Str: String;
|
||||
SectDict: TDictionary<TKMPerfSection, Int64>;
|
||||
|
||||
FastTick: Boolean;
|
||||
|
||||
SectsArray: TArray<TKMPerfSection>;
|
||||
TicksArray: TArray<Cardinal>;
|
||||
|
||||
Total: array[TKMPerfSection] of Int64;
|
||||
begin
|
||||
ForceDirectories(ExtractFilePath(aFilename));
|
||||
|
||||
S := TStringList.Create;
|
||||
|
||||
TicksArray := fTickTimes.Keys.ToArray;
|
||||
{$IFNDEF FPC}
|
||||
TArray.Sort<Cardinal>(TicksArray);
|
||||
{$ELSE}
|
||||
SortCustom(TicksArray, Low(TicksArray), High(TicksArray), SizeOf(TicksArray[0]), CompareTicks);
|
||||
{$ENDIF}
|
||||
|
||||
// Str := 'Tick '; //7
|
||||
Str := ' ';
|
||||
for K := Low(TKMPerfSection) to High(TKMPerfSection) do
|
||||
begin
|
||||
if K in SKIP_SECTION then
|
||||
Continue;
|
||||
|
||||
Total[K] := 0;
|
||||
Str := Str + Format('%' + IntToStr(SECT_W) + 's', [SectionName[K]]);
|
||||
end;
|
||||
S.Append(Str);
|
||||
|
||||
|
||||
I := 0;
|
||||
for TickKey in TicksArray do
|
||||
begin
|
||||
Inc(I);
|
||||
SectDict := fTickTimes.Items[TickKey];
|
||||
|
||||
SectsArray := SectDict.Keys.ToArray;
|
||||
{$IFNDEF FPC}
|
||||
TArray.Sort<TKMPerfSection>(SectsArray);
|
||||
{$ELSE}
|
||||
SortCustom(SectsArray, Low(SectsArray), High(SectsArray), SizeOf(SectsArray[0]), CompareSects);
|
||||
{$ENDIF}
|
||||
|
||||
FastTick := False;
|
||||
Str := Format('%6d:', [TickKey]);
|
||||
for SectKey in SectsArray do
|
||||
begin
|
||||
if SectKey in SKIP_SECTION then
|
||||
Continue;
|
||||
// if (SectKey = psTick) and (SectDict.Items[SectKey] < 5000) then //Skip ticks with low execution time
|
||||
// begin
|
||||
// FastTick := True;
|
||||
// Break;
|
||||
// end;
|
||||
|
||||
Str := Str + Format('%' + IntToStr(SECT_W) + 'd', [SectDict.Items[SectKey]]);
|
||||
|
||||
if I < Length(TicksArray) then
|
||||
Total[SectKey] := Total[SectKey] + SectDict.Items[SectKey];
|
||||
end;
|
||||
|
||||
if not FastTick then
|
||||
S.Append(Str);
|
||||
end;
|
||||
|
||||
S.Append('AVERAGE');
|
||||
Str := '';
|
||||
for K := Low(TKMPerfSection) to High(TKMPerfSection) do
|
||||
begin
|
||||
if K in SKIP_SECTION then
|
||||
Continue;
|
||||
|
||||
Str := Str + Format('%' + IntToStr(SECT_W) + 'd', [Round(Total[K] / Length(TicksArray))]);
|
||||
end;
|
||||
S.Append(Str);
|
||||
|
||||
// for K := Low(TPerfSection) to High(TPerfSection) do
|
||||
// begin
|
||||
// //Section name
|
||||
// S.Append(SectionName[K]);
|
||||
// S.Append(StringOfChar('-', 60));
|
||||
//
|
||||
// //Times
|
||||
// for I := 0 to fCount[K] - 1 do
|
||||
// if fTimes[K,I] > LIMITS[K] then //Dont bother saving 95% of data
|
||||
// S.Append(Format('%d'#9'%d', [I, fTimes[K,I]]));
|
||||
//
|
||||
// //Footer
|
||||
// S.Append('');
|
||||
// S.Append('');
|
||||
// end;
|
||||
|
||||
S.SaveToFile(aFilename);
|
||||
S.Free;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
Reference in new issue
Block a user