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>

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

@@ -47,7 +47,7 @@ Type
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);
@@ -61,44 +61,61 @@ Type
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);
@@ -108,7 +125,7 @@ begin
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;
@@ -128,9 +145,9 @@ 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
@@ -138,15 +155,15 @@ begin
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,80 +187,86 @@ 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;
@@ -254,35 +276,22 @@ begin
end; end;
end; end;
constructor TPictureCache.Create(aOwner: TComponent); procedure TPictureCache.Add(MapProvider: TMapProvider;
begin const TileId: TTileId; Stream: TMemoryStream);
inherited Create(aOwner); var
FMemMaxElem :=2048 div 256; FileName: String;
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; img: TLazIntfImage;
aFile : TFileStream; lFile: TFileStream;
idx: integer; idx: integer;
begin begin
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
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;
@@ -291,37 +300,41 @@ begin
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);
var
FileName: String;
idx: integer; 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;
@@ -329,18 +342,19 @@ begin
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
FileName: String;
idx: integer; idx: integer;
begin begin
FileName := GetFileName(MapProvider, TileId); FileName := GetFileName(MapProvider, TileId);
@@ -348,7 +362,7 @@ begin
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

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

@@ -38,9 +38,9 @@ type
FLauncher: TObject; FLauncher: TObject;
FCancelled: Boolean; FCancelled: Boolean;
FName: String; FName: String;
protected protected
Queue: TJobQueue; Queue: TJobQueue;
procedure DoCancel; virtual; procedure DoCancel; virtual;
Procedure WaitForResultOf(aJob: TJob); Procedure WaitForResultOf(aJob: TJob);
Procedure EnterCriticalSection; Procedure EnterCriticalSection;
@@ -51,6 +51,7 @@ type
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;
@@ -63,7 +64,7 @@ type
{ TJobQueue } { TJobQueue }
TJobQueue = Class TJobQueue = class
private private
FMainThreadId: TThreadID; FMainThreadId: TThreadID;
FOnIdle: TNotifyEvent; FOnIdle: TNotifyEvent;
@@ -98,13 +99,13 @@ type
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 UseThreads: boolean read FUseThreads write SetUseThreads;
property OnIdle: TNotifyEvent read FOnIdle write FOnIdle; property OnIdle: TNotifyEvent read FOnIdle write FOnIdle;
end; end;

3
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;
@@ -41,6 +43,7 @@ type
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;

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

@@ -23,7 +23,8 @@ interface
uses uses
Classes, SysUtils; Classes, SysUtils;
Type
type
{ TTileId } { TTileId }
TTileId = record TTileId = record
X, Y: int64; X, Y: int64;
@@ -31,8 +32,8 @@ Type
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 }