pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

LazMapViewer: Cosmetic changes

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6316 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2018-04-16 22:45:16 +00:00
parent 51c0ef9d38
commit a6ad243934
5 changed files with 227 additions and 208 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
components/lazmapviewer/lazmapviewerpkg.lpk
View File

@ -3,7 +3,7 @@
<Package Version="4"> <Package Version="4">
<Name Value="lazMapViewerPkg"/> <Name Value="lazMapViewerPkg"/>
<Type Value="RunAndDesignTime"/> <Type Value="RunAndDesignTime"/>
<Author Value="Maciej Kaczkowski, ti_dic"/> <Author Value="Maciej Kaczkowski, ti_dic, Werner Pamler"/>
<CompilerOptions> <CompilerOptions>
<Version Value="11"/> <Version Value="11"/>
<SearchPaths> <SearchPaths>

336
components/lazmapviewer/source/mvcache.pas
View File

@ -30,9 +30,9 @@ Type
TPictureCache = Class(TComponent) TPictureCache = Class(TComponent)
private private
FMemMaxElem : integer; FMemMaxElem: integer;
Crit : TCriticalSection; Crit: TCriticalSection;
Cache : TStringList; Cache: TStringList;
FBasePath: String; FBasePath: String;
FUseDisk: Boolean; FUseDisk: Boolean;
FUseThreads: Boolean; FUseThreads: Boolean;
@ -40,113 +40,130 @@ Type
Procedure EnterCrit; Procedure EnterCrit;
Procedure LeaveCrit; Procedure LeaveCrit;
protected protected
function GetNewImgFor(aStream : TStream) : TLazIntfImage; function GetNewImgFor(aStream: TStream): TLazIntfImage;
procedure FreeCache; procedure FreeCache;
Function MapProvider2FileName(MapProvider : TMapProvider) : String; Function MapProvider2FileName(MapProvider: TMapProvider): String;
Function DiskCached(const aFileName : String) : Boolean; Function DiskCached(const aFileName: String): Boolean;
procedure LoadFromDisk(const aFileName : String;out img : TLazIntfImage); procedure LoadFromDisk(const aFileName: String; out img: TLazIntfImage);
Function GetFileName(MapProvider : TMapProvider;const TileId : TTileId) : String; Function GetFileName(MapProvider: TMapProvider;const TileId: TTileId): String;
public public
Procedure CheckCacheSize(sender : TObject); Procedure CheckCacheSize(Sender: TObject);
constructor Create(aOwner : TComponent);override; constructor Create(aOwner: TComponent); override;
destructor destroy;override; destructor destroy; override;
Procedure Add(MapProvider : TMapProvider;const TileId : TTileId;Stream : TMemoryStream); Procedure Add(MapProvider: TMapProvider; const TileId: TTileId; Stream: TMemoryStream);
Procedure GetFromCache(MapProvider : TMapProvider;const TileId : TTileId;out img : TLazIntfImage); Procedure GetFromCache(MapProvider: TMapProvider; const TileId: TTileId; out img: TLazIntfImage);
function InCache(MapProvider : TMapProvider;const TileId : TTileId) : Boolean; function InCache(MapProvider: TMapProvider; const TileId: TTileId): Boolean;
property UseDisk : Boolean read FUseDisk write FUseDisk; property UseDisk: Boolean read FUseDisk write FUseDisk;
property BasePath : String read FBasePath write FBasePath; property BasePath: String read FBasePath write FBasePath;
property UseThreads : Boolean read FUseThreads write SetUseThreads; property UseThreads: Boolean read FUseThreads write SetUseThreads;
end; end;
implementation implementation
uses FPimage,GraphType,FPReadJPEG;
uses
FPimage, GraphType, FPReadJPEG;
{ TPictureCache } { TPictureCache }
function IsValidPNG(stream: TStream): Boolean; function IsValidPNG(AStream: TStream): Boolean;
var var
s: string; s: string;
y: Int64; y: Int64;
begin begin
if Assigned(stream) then if Assigned(AStream) then
begin begin
SetLength(s, 3); SetLength(s, 3);
y := stream.Position; y := AStream.Position;
stream.Position := 1; AStream.Position := 1;
stream.Read(s[1], 3); AStream.Read(s[1], 3);
stream.Position := y; AStream.Position := y;
Result := s = 'PNG'; Result := (s = 'PNG');
end end
else else
Result := False; Result := false;
end; end;
function IsValidJPEG(stream: TStream): Boolean; function IsValidJPEG(AStream: TStream): Boolean;
var var
s: string; s: string;
y: Int64; y: Int64;
begin begin
if Assigned(stream) then if Assigned(AStream) then
begin begin
SetLength(s, 4); SetLength(s, 4);
y := stream.Position; y := AStream.Position;
stream.Position := 6; AStream.Position := 6;
stream.Read(s[1], 4); AStream.Read(s[1], 4);
stream.Position := y; AStream.Position := y;
Result := (s = 'JFIF') or (s = 'Exif'); Result := (s = 'JFIF') or (s = 'Exif');
end end
else else
Result := False; Result := false;
end;
constructor TPictureCache.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
FMemMaxElem := 2048 div 256;
Cache := TStringList.create;
end;
destructor TPictureCache.Destroy;
begin
inherited;
FreeCache;
FreeAndNil(Crit);
end; end;
procedure TPictureCache.SetUseThreads(AValue: Boolean); procedure TPictureCache.SetUseThreads(AValue: Boolean);
begin begin
if FUseThreads=AValue then Exit; if FUseThreads = AValue then Exit;
FUseThreads:=AValue; FUseThreads := AValue;
if aValue then if aValue then
Crit:=TCriticalSection.Create Crit := TCriticalSection.Create
else else
FreeAndnil(Crit); FreeAndNil(Crit);
end; end;
procedure TPictureCache.EnterCrit; procedure TPictureCache.EnterCrit;
begin begin
if Assigned(Crit) then if Assigned(Crit) then
Crit.Enter; Crit.Enter;
end; end;
procedure TPictureCache.LeaveCrit; procedure TPictureCache.LeaveCrit;
begin begin
if Assigned(Crit) then if Assigned(Crit) then
Crit.Leave; Crit.Leave;
end; end;
function TPictureCache.GetNewImgFor(aStream: TStream): TLazIntfImage; function TPictureCache.GetNewImgFor(aStream: TStream): TLazIntfImage;
var var
reader : TFPCustomImageReader; reader: TFPCustomImageReader;
rawImg : TRawImage; rawImg: TRawImage;
begin begin
result:=nil; Result := nil;
Reader := nil; Reader := nil;
if not(assigned(aStream)) then if not Assigned(aStream) then
exit; exit;
if IsValidJPEG(astream) then if IsValidJPEG(astream) then
Reader := TFPReaderJPEG.create Reader := TFPReaderJPEG.create
else else
if IsValidPNG(astream) then if IsValidPNG(astream) then
Reader := TLazReaderPNG.create; Reader := TLazReaderPNG.create;
if Assigned(reader) then if Assigned(reader) then
Begin begin
try try
rawImg.Init; rawImg.Init;
rawImg.Description.Init_BPP24_B8G8R8_BIO_TTB(TILE_SIZE,TILE_SIZE); rawImg.Description.Init_BPP24_B8G8R8_BIO_TTB(TILE_SIZE, TILE_SIZE);
Result:=TLazIntfImage.create(rawImg,true); Result := TLazIntfImage.Create(rawImg, true);
Try try
Result.LoadFromStream(aStream,reader); Result.LoadFromStream(aStream, reader);
except except
FreeAndNil(result); FreeAndNil(Result);
end; end;
finally finally
FreeAndNil(Reader) FreeAndNil(Reader)
@ -155,14 +172,13 @@ begin
end; end;
procedure TPictureCache.FreeCache; procedure TPictureCache.FreeCache;
var i : integer; var
i: integer;
begin begin
EnterCrit; EnterCrit;
Try try
For i:=0 to pred(Cache.Count) do for i := 0 to pred(Cache.Count) do
begin
Cache.Objects[i].Free; Cache.Objects[i].Free;
end;
Cache.Clear; Cache.Clear;
Cache.Free; Cache.Free;
finally finally
@ -171,189 +187,187 @@ begin
end; end;
function TPictureCache.MapProvider2FileName(MapProvider: TMapProvider): String; function TPictureCache.MapProvider2FileName(MapProvider: TMapProvider): String;
var i : integer; var
i: integer;
begin begin
Result:=''; Result := '';
if Assigned(MapProvider) then if Assigned(MapProvider) then
begin begin
Result:=MapProvider.Name; Result := MapProvider.Name;
For i:=1 to length(Result) do for i := 1 to Length(Result) do
if not(result[i] in ['a'..'z','A'..'Z','0'..'9','_','.']) then if not (Result[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '.']) then
Result[i]:='-'; Result[i] := '-';
end; end;
end; end;
function TPictureCache.DiskCached(const aFileNAme: String): Boolean; function TPictureCache.DiskCached(const aFileNAme: String): Boolean;
Var FullFileName : string; var
FullFileName: string;
begin begin
if UseDisk then if UseDisk then
Begin begin
FullFileName:=BasePath+aFileName; FullFileName := BasePath + aFileName;
Result:=FileExists(FullFileName); Result := FileExists(FullFileName);
end end
Else else
Result:=False; Result := False;
end; end;
procedure TPictureCache.LoadFromDisk(const aFileName: String; out procedure TPictureCache.LoadFromDisk(const aFileName: String;
img: TLazIntfImage); out img: TLazIntfImage);
var FullFileName : String; var
aStream : TFileStream; FullFileName: String;
lStream: TFileStream;
begin begin
img:=nil; img := nil;
FullFileName:=BasePath+aFileName; FullFileName := BasePath + aFileName;
if FileExists(fullFileName) then if FileExists(fullFileName) then
Begin begin
aStream:=TFileStream.Create(FullFileName,fmOpenRead); lStream := TFileStream.Create(FullFileName, fmOpenRead);
try try
Try try
img:=GetNewImgFor(aStream); img := GetNewImgFor(lStream);
except except
FreeAndNil(img); FreeAndNil(img);
end; end;
if Assigned(img) then if Assigned(img) then
begin begin
EnterCrit; EnterCrit;
Try try
Cache.AddObject(aFileName,img); Cache.AddObject(aFileName, img);
finally finally
LeaveCrit; LeaveCrit;
end; end;
end; end;
finally finally
aStream.Free; lStream.Free;
end; end;
end; end;
end; end;
function TPictureCache.GetFileName(MapProvider: TMapProvider;const TileId: TTileId function TPictureCache.GetFileName(MapProvider: TMapProvider;
): String; const TileId: TTileId): String;
begin begin
Result:=MapProvider2FileName(MapProvider)+'_'+inttostr(TileId.X)+'_'+inttostr(TileId.Y)+'_'+inttostr(TileId.Z); Result := Format('%s_%d_%d_%d',
[MapProvider2FileName(MapProvider), TileId.X, TileId.Y, TileId.Z]
);
end; end;
procedure TPictureCache.CheckCacheSize(Sender : TObject); procedure TPictureCache.CheckCacheSize(Sender: TObject);
var i ,idx : integer; var
i, idx: integer;
begin begin
EnterCrit; EnterCrit;
try try
if Cache.Count>FMemMaxElem then if Cache.Count > FMemMaxElem then
Begin begin
For i:=1 to 10 do for i:=1 to 10 do
Begin begin
idx:=pred(Cache.Count); idx := pred(Cache.Count);
if idx>1 then if idx > 1 then
Begin begin
Cache.Objects[idx].free; Cache.Objects[idx].Free;
Cache.Delete(idx); Cache.Delete(idx);
end;
end; end;
end;
end; end;
finally finally
LeaveCrit; LeaveCrit;
end; end;
end; end;
constructor TPictureCache.Create(aOwner: TComponent); procedure TPictureCache.Add(MapProvider: TMapProvider;
const TileId: TTileId; Stream: TMemoryStream);
var
FileName: String;
img: TLazIntfImage;
lFile: TFileStream;
idx: integer;
begin begin
inherited Create(aOwner); FileName := GetFileName(MapProvider, TileId);
FMemMaxElem :=2048 div 256;
Cache:=TStringList.create;
end;
destructor TPictureCache.destroy;
begin
inherited destroy;
FreeCache;
FreeAndNil(Crit);
end;
procedure TPictureCache.Add(MapProvider: TMapProvider;const TileId: TTileId;
Stream: TMemoryStream);
var FileName : String;
img : TLazIntfImage;
aFile : TFileStream;
idx : integer;
begin
FileName:=GetFileName(MapProvider,TileId);
EnterCrit; EnterCrit;
Try try
idx:=Cache.IndexOF(FileName); idx := Cache.IndexOF(FileName);
if idx<>-1 then if idx <> -1 then
Cache.Objects[idx].Free Cache.Objects[idx].Free
else else
Begin begin
Cache.Insert(0,FileName); Cache.Insert(0, FileName);
idx:=0; idx := 0;
end; end;
img:=GetNewImgFor(Stream); img:= GetNewImgFor(Stream);
Cache.Objects[idx]:=img; Cache.Objects[idx]:=img;
finally finally
LeaveCrit; LeaveCrit;
end; end;
if UseDisk then if UseDisk then
Begin begin
if assigned(img) then if assigned(img) then
Begin begin
aFile:=TFileStream.Create(BasePath+FileName,fmCreate); lFile := TFileStream.Create(BasePath + FileName, fmCreate);
Try try
Stream.Position:=0; Stream.Position := 0;
aFile.CopyFrom(Stream,0); lFile.CopyFrom(Stream, 0);
finally finally
FreeAndNil(aFile); FreeAndNil(lFile);
end; end;
end; end;
end; end;
if Not(FUseThreads) then
if not FUseThreads then
CheckCacheSize(self); CheckCacheSize(self);
end; end;
procedure TPictureCache.GetFromCache(MapProvider: TMapProvider;const TileId: TTileId; out img: TLazIntfImage); procedure TPictureCache.GetFromCache(MapProvider: TMapProvider;
var FileName : String; const TileId: TTileId; out img: TLazIntfImage);
idx : integer; var
FileName: String;
idx: integer;
begin begin
img:=nil; img := nil;
FileName:=GetFileName(MapProvider,TileId); FileName := GetFileName(MapProvider, TileId);
EnterCrit; EnterCrit;
Try try
idx:=Cache.IndexOF(FileName); idx := Cache.IndexOf(FileName);
if idx<>-1 then if idx <> -1 then
Begin begin
img:=TLazIntfImage(Cache.Objects[idx]); img := TLazIntfImage(Cache.Objects[idx]);
if Idx>FMemMaxElem div 2 then if Idx > FMemMaxElem div 2 then
Begin begin
Cache.Delete(idx); Cache.Delete(idx);
Cache.Insert(0,FileName); Cache.Insert(0, FileName);
Cache.Objects[0]:=img; Cache.Objects[0] := img;
end; end;
end; end;
finally finally
leaveCrit; LeaveCrit;
end; end;
if idx=-1 then if idx = -1 then
Begin begin
if UseDisk then if UseDisk then
LoadFromDisk(FileName,img); LoadFromDisk(FileName, img);
end; end;
end; end;
function TPictureCache.InCache(MapProvider: TMapProvider;const TileId: TTileId function TPictureCache.InCache(MapProvider: TMapProvider;
): Boolean; const TileId: TTileId): Boolean;
var FileName : String; var
idx : integer; FileName: String;
idx: integer;
begin begin
FileName:=GetFileName(MapProvider,TileId); FileName := GetFileName(MapProvider, TileId);
EnterCrit; EnterCrit;
try try
idx:=Cache.IndexOF(FileNAme); idx := Cache.IndexOF(FileNAme);
finally finally
leaveCrit; LeaveCrit;
end; end;
if idx<>-1 then if idx <> -1 then
Result:=True Result := True
else else
Result:=DiskCached(FileName); Result := DiskCached(FileName);
end; end;
end. end.

79
components/lazmapviewer/source/mvjobqueue.pas
View File

@ -35,46 +35,47 @@ type
TJob = Class TJob = Class
private private
FLauncher : TObject; FLauncher: TObject;
FCancelled : Boolean; FCancelled: Boolean;
FName: String; FName: String;
protected
Queue : TJobQueue;
procedure DoCancel;virtual; protected
Procedure WaitForResultOf(aJob : TJob); Queue: TJobQueue;
procedure DoCancel; virtual;
Procedure WaitForResultOf(aJob: TJob);
Procedure EnterCriticalSection; Procedure EnterCriticalSection;
procedure LeaveCriticalSection; procedure LeaveCriticalSection;
//should be called inside critical section //should be called inside critical section
function pGetTask : integer;virtual; function pGetTask: integer; virtual;
procedure pTaskStarted(aTask: integer);virtual;abstract; procedure pTaskStarted(aTask: integer); virtual; abstract;
procedure pTaskEnded(aTask : integer;aExcept : Exception);virtual;abstract; procedure pTaskEnded(aTask: integer; aExcept: Exception); virtual; abstract;
property Launcher : TObject read FLauncher; property Launcher: TObject read FLauncher;
public public
procedure ExecuteTask(aTask : integer;FromWaiting : boolean);virtual;abstract; procedure ExecuteTask(aTask: integer; FromWaiting: boolean); virtual; abstract;
function Running : boolean;virtual;abstract; function Running: boolean; virtual; abstract;
procedure Cancel; procedure Cancel;
property Cancelled : boolean read FCancelled; property Cancelled: boolean read FCancelled;
property Name : String read FName write FName; property Name: String read FName write FName;
end; end;
TJobArray = Array of TJob; TJobArray = Array of TJob;
{ TJobQueue } { TJobQueue }
TJobQueue = Class TJobQueue = class
private private
FMainThreadId : TThreadID; FMainThreadId: TThreadID;
FOnIdle: TNotifyEvent; FOnIdle: TNotifyEvent;
waitings : TStringList; waitings: TStringList;
FNbThread : integer; FNbThread: integer;
TerminatedThread : integer; TerminatedThread: integer;
FSect : TCriticalSection; FSect: TCriticalSection;
FEvent,TerminateEvent : TEvent; FEvent, TerminateEvent: TEvent;
FUseThreads: boolean; FUseThreads: boolean;
Threads : TList; Threads: TList;
Jobs : TObjectList; Jobs: TObjectList;
procedure pJobCompleted(var aJob: TJob); procedure pJobCompleted(var aJob: TJob);
procedure SetUseThreads(AValue: boolean); procedure SetUseThreads(AValue: boolean);
procedure ClearWaitings; procedure ClearWaitings;
@ -83,29 +84,29 @@ type
Procedure FreeThreads; Procedure FreeThreads;
Procedure EnterCriticalSection; Procedure EnterCriticalSection;
procedure LeaveCriticalSection; procedure LeaveCriticalSection;
Procedure DoWaiting(E : Exception;TaskId : integer); Procedure DoWaiting(E: Exception; TaskId: integer);
//Should be called inside critical section //Should be called inside critical section
procedure pAddWaiting(aJob : TJob;aTask : integer;JobId : String); procedure pAddWaiting(aJob: TJob; aTask: integer; JobId: String);
procedure pTaskStarted(aJob : TJob;aTask : integer); procedure pTaskStarted(aJob: TJob; aTask: integer);
procedure pTaskEnded(var aJob : TJob;aTask : integer;aExcept : Exception); procedure pTaskEnded(var aJob: TJob; aTask: integer; aExcept: Exception);
function pGetJob(out TaskId : integer;out Restart : boolean) : TJob; function pGetJob(out TaskId: integer; out Restart: boolean) : TJob;
function pFindJobByName(const aName : string;ByLauncher: TObject) : TJobArray; function pFindJobByName(const aName: string; ByLauncher: TObject) : TJobArray;
procedure pNotifyWaitings(aJob : TJob); procedure pNotifyWaitings(aJob: TJob);
Function IsMainThread : boolean; Function IsMainThread: boolean;
public public
constructor Create(NbThread : integer = 5); constructor Create(NbThread: integer = 5);
destructor Destroy;override; destructor Destroy; override;
procedure QueueAsyncCall(const AMethod: TDataEvent; Data: PtrInt); procedure QueueAsyncCall(const AMethod: TDataEvent; Data: PtrInt);
procedure QueueSyncCall(const AMethod: TDataEvent; Data: PtrInt); procedure QueueSyncCall(const AMethod: TDataEvent; Data: PtrInt);
property UseThreads : boolean read FUseThreads write SetUseThreads; Procedure AddJob(aJob: TJob; Launcher: TObject);
Procedure AddJob(aJob : TJob;Launcher : TObject);
function AddUniqueJob(aJob: TJob; Launcher: TObject) : boolean; function AddUniqueJob(aJob: TJob; Launcher: TObject) : boolean;
function CancelAllJob(ByLauncher: TObject) : TJobArray; function CancelAllJob(ByLauncher: TObject): TJobArray;
function CancelJobByName(aJobName : String;ByLauncher: TObject) : boolean; function CancelJobByName(aJobName: String; ByLauncher: TObject): boolean;
Procedure WaitForTerminate(const lstJob : TJobArray); Procedure WaitForTerminate(const lstJob: TJobArray);
Procedure WaitAllJobTerminated(ByLauncher: TObject); Procedure WaitAllJobTerminated(ByLauncher: TObject);
property OnIdle : TNotifyEvent read FOnIdle write FOnIdle; property UseThreads: boolean read FUseThreads write SetUseThreads;
property OnIdle: TNotifyEvent read FOnIdle write FOnIdle;
end; end;

7
components/lazmapviewer/source/mvjobs.pas
View File

@ -26,7 +26,9 @@ uses
type type
{ TSimpleJob: job with only one task } { TSimpleJob: job with only one task }
TSimpleJob = class(TJob) TSimpleJob = class(TJob)
private private
FRunning, FEnded: boolean; FRunning, FEnded: boolean;
@ -35,12 +37,13 @@ type
procedure pTaskStarted(aTask: integer); override; procedure pTaskStarted(aTask: integer); override;
procedure pTaskEnded(aTask: integer; aExcept: Exception); override; procedure pTaskEnded(aTask: integer; aExcept: Exception); override;
public public
function Running : boolean; override; function Running: boolean; override;
end; end;
TJobProc = procedure (Data: TObject; Job: TJob) of object; TJobProc = procedure (Data: TObject; Job: TJob) of object;
{ TEventJob: job with only one task (callback an event) } { TEventJob: job with only one task (callback an event) }
TEventJob = class(TSimpleJob) TEventJob = class(TSimpleJob)
private private
FData: TObject; FData: TObject;
@ -59,7 +62,7 @@ implementation
{ TEventJob } { TEventJob }
constructor TEventJob.Create(aEvent: TJobProc; Data: TObject; constructor TEventJob.Create(aEvent: TJobProc; Data: TObject;
OwnData: Boolean; JobName: String=''); OwnData: Boolean; JobName: String = '');
begin begin
Name := JobName; Name := JobName;
FTask := aEvent; FTask := aEvent;

11
components/lazmapviewer/source/mvmapprovider.pas
View File

@ -23,16 +23,17 @@ interface
uses uses
Classes, SysUtils; Classes, SysUtils;
Type
type
{ TTileId } { TTileId }
TTileId = record TTileId = record
X,Y : int64; X, Y: int64;
Z : integer; Z: integer;
end; end;
TGetSvrStr = Function (id : integer) : string of object; TGetSvrStr = function (id: integer): string of object;
TGetValStr = Function (const Tile : TTileId) : String of object; TGetValStr = function (const Tile: TTileId): String of object;
{ TMapProvider } { TMapProvider }