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">
<Name Value="lazMapViewerPkg"/>
<Type Value="RunAndDesignTime"/>
<Author Value="Maciej Kaczkowski, ti_dic"/>
<Author Value="Maciej Kaczkowski, ti_dic, Werner Pamler"/>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>

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

@ -47,7 +47,7 @@ Type
procedure LoadFromDisk(const aFileName: String; out img: TLazIntfImage);
Function GetFileName(MapProvider: TMapProvider;const TileId: TTileId): String;
public
Procedure CheckCacheSize(sender : TObject);
Procedure CheckCacheSize(Sender: TObject);
constructor Create(aOwner: TComponent); override;
destructor destroy; override;
Procedure Add(MapProvider: TMapProvider; const TileId: TTileId; Stream: TMemoryStream);
@ -61,44 +61,61 @@ Type
implementation
uses FPimage,GraphType,FPReadJPEG;
uses
FPimage, GraphType, FPReadJPEG;
{ TPictureCache }
function IsValidPNG(stream: TStream): Boolean;
function IsValidPNG(AStream: TStream): Boolean;
var
s: string;
y: Int64;
begin
if Assigned(stream) then
if Assigned(AStream) then
begin
SetLength(s, 3);
y := stream.Position;
stream.Position := 1;
stream.Read(s[1], 3);
stream.Position := y;
Result := s = 'PNG';
y := AStream.Position;
AStream.Position := 1;
AStream.Read(s[1], 3);
AStream.Position := y;
Result := (s = 'PNG');
end
else
Result := False;
Result := false;
end;
function IsValidJPEG(stream: TStream): Boolean;
function IsValidJPEG(AStream: TStream): Boolean;
var
s: string;
y: Int64;
begin
if Assigned(stream) then
if Assigned(AStream) then
begin
SetLength(s, 4);
y := stream.Position;
stream.Position := 6;
stream.Read(s[1], 4);
stream.Position := y;
y := AStream.Position;
AStream.Position := 6;
AStream.Read(s[1], 4);
AStream.Position := y;
Result := (s = 'JFIF') or (s = 'Exif');
end
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;
procedure TPictureCache.SetUseThreads(AValue: Boolean);
@ -108,7 +125,7 @@ begin
if aValue then
Crit := TCriticalSection.Create
else
FreeAndnil(Crit);
FreeAndNil(Crit);
end;
procedure TPictureCache.EnterCrit;
@ -128,9 +145,9 @@ var
reader: TFPCustomImageReader;
rawImg: TRawImage;
begin
result:=nil;
Result := nil;
Reader := nil;
if not(assigned(aStream)) then
if not Assigned(aStream) then
exit;
if IsValidJPEG(astream) then
Reader := TFPReaderJPEG.create
@ -138,15 +155,15 @@ begin
if IsValidPNG(astream) then
Reader := TLazReaderPNG.create;
if Assigned(reader) then
Begin
begin
try
rawImg.Init;
rawImg.Description.Init_BPP24_B8G8R8_BIO_TTB(TILE_SIZE, TILE_SIZE);
Result:=TLazIntfImage.create(rawImg,true);
Try
Result := TLazIntfImage.Create(rawImg, true);
try
Result.LoadFromStream(aStream, reader);
except
FreeAndNil(result);
FreeAndNil(Result);
end;
finally
FreeAndNil(Reader)
@ -155,14 +172,13 @@ begin
end;
procedure TPictureCache.FreeCache;
var i : integer;
var
i: integer;
begin
EnterCrit;
Try
For i:=0 to pred(Cache.Count) do
begin
try
for i := 0 to pred(Cache.Count) do
Cache.Objects[i].Free;
end;
Cache.Clear;
Cache.Free;
finally
@ -171,80 +187,86 @@ begin
end;
function TPictureCache.MapProvider2FileName(MapProvider: TMapProvider): String;
var i : integer;
var
i: integer;
begin
Result := '';
if Assigned(MapProvider) then
begin
Result := MapProvider.Name;
For i:=1 to length(Result) do
if not(result[i] in ['a'..'z','A'..'Z','0'..'9','_','.']) then
for i := 1 to Length(Result) do
if not (Result[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '.']) then
Result[i] := '-';
end;
end;
function TPictureCache.DiskCached(const aFileNAme: String): Boolean;
Var FullFileName : string;
var
FullFileName: string;
begin
if UseDisk then
Begin
begin
FullFileName := BasePath + aFileName;
Result := FileExists(FullFileName);
end
Else
else
Result := False;
end;
procedure TPictureCache.LoadFromDisk(const aFileName: String; out
img: TLazIntfImage);
var FullFileName : String;
aStream : TFileStream;
procedure TPictureCache.LoadFromDisk(const aFileName: String;
out img: TLazIntfImage);
var
FullFileName: String;
lStream: TFileStream;
begin
img := nil;
FullFileName := BasePath + aFileName;
if FileExists(fullFileName) then
Begin
aStream:=TFileStream.Create(FullFileName,fmOpenRead);
begin
lStream := TFileStream.Create(FullFileName, fmOpenRead);
try
Try
img:=GetNewImgFor(aStream);
try
img := GetNewImgFor(lStream);
except
FreeAndNil(img);
end;
if Assigned(img) then
begin
EnterCrit;
Try
try
Cache.AddObject(aFileName, img);
finally
LeaveCrit;
end;
end;
finally
aStream.Free;
lStream.Free;
end;
end;
end;
function TPictureCache.GetFileName(MapProvider: TMapProvider;const TileId: TTileId
): String;
function TPictureCache.GetFileName(MapProvider: TMapProvider;
const TileId: TTileId): String;
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;
procedure TPictureCache.CheckCacheSize(Sender: TObject);
var i ,idx : integer;
var
i, idx: integer;
begin
EnterCrit;
try
if Cache.Count > FMemMaxElem then
Begin
For i:=1 to 10 do
Begin
begin
for i:=1 to 10 do
begin
idx := pred(Cache.Count);
if idx > 1 then
Begin
Cache.Objects[idx].free;
begin
Cache.Objects[idx].Free;
Cache.Delete(idx);
end;
end;
@ -254,35 +276,22 @@ begin
end;
end;
constructor TPictureCache.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
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;
procedure TPictureCache.Add(MapProvider: TMapProvider;
const TileId: TTileId; Stream: TMemoryStream);
var
FileName: String;
img: TLazIntfImage;
aFile : TFileStream;
lFile: TFileStream;
idx: integer;
begin
FileName := GetFileName(MapProvider, TileId);
EnterCrit;
Try
try
idx := Cache.IndexOF(FileName);
if idx <> -1 then
Cache.Objects[idx].Free
else
Begin
begin
Cache.Insert(0, FileName);
idx := 0;
end;
@ -291,37 +300,41 @@ begin
finally
LeaveCrit;
end;
if UseDisk then
Begin
begin
if assigned(img) then
Begin
aFile:=TFileStream.Create(BasePath+FileName,fmCreate);
Try
begin
lFile := TFileStream.Create(BasePath + FileName, fmCreate);
try
Stream.Position := 0;
aFile.CopyFrom(Stream,0);
lFile.CopyFrom(Stream, 0);
finally
FreeAndNil(aFile);
FreeAndNil(lFile);
end;
end;
end;
if Not(FUseThreads) then
if not FUseThreads then
CheckCacheSize(self);
end;
procedure TPictureCache.GetFromCache(MapProvider: TMapProvider;const TileId: TTileId; out img: TLazIntfImage);
var FileName : String;
procedure TPictureCache.GetFromCache(MapProvider: TMapProvider;
const TileId: TTileId; out img: TLazIntfImage);
var
FileName: String;
idx: integer;
begin
img := nil;
FileName := GetFileName(MapProvider, TileId);
EnterCrit;
Try
idx:=Cache.IndexOF(FileName);
try
idx := Cache.IndexOf(FileName);
if idx <> -1 then
Begin
begin
img := TLazIntfImage(Cache.Objects[idx]);
if Idx > FMemMaxElem div 2 then
Begin
begin
Cache.Delete(idx);
Cache.Insert(0, FileName);
Cache.Objects[0] := img;
@ -329,18 +342,19 @@ begin
end;
finally
leaveCrit;
LeaveCrit;
end;
if idx = -1 then
Begin
begin
if UseDisk then
LoadFromDisk(FileName, img);
end;
end;
function TPictureCache.InCache(MapProvider: TMapProvider;const TileId: TTileId
): Boolean;
var FileName : String;
function TPictureCache.InCache(MapProvider: TMapProvider;
const TileId: TTileId): Boolean;
var
FileName: String;
idx: integer;
begin
FileName := GetFileName(MapProvider, TileId);
@ -348,7 +362,7 @@ begin
try
idx := Cache.IndexOF(FileNAme);
finally
leaveCrit;
LeaveCrit;
end;
if idx <> -1 then
Result := True

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

@ -38,9 +38,9 @@ type
FLauncher: TObject;
FCancelled: Boolean;
FName: String;
protected
Queue: TJobQueue;
procedure DoCancel; virtual;
Procedure WaitForResultOf(aJob: TJob);
Procedure EnterCriticalSection;
@ -51,6 +51,7 @@ type
procedure pTaskStarted(aTask: integer); virtual; abstract;
procedure pTaskEnded(aTask: integer; aExcept: Exception); virtual; abstract;
property Launcher: TObject read FLauncher;
public
procedure ExecuteTask(aTask: integer; FromWaiting: boolean); virtual; abstract;
function Running: boolean; virtual; abstract;
@ -63,7 +64,7 @@ type
{ TJobQueue }
TJobQueue = Class
TJobQueue = class
private
FMainThreadId: TThreadID;
FOnIdle: TNotifyEvent;
@ -98,13 +99,13 @@ type
destructor Destroy; override;
procedure QueueAsyncCall(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);
function AddUniqueJob(aJob: TJob; Launcher: TObject) : boolean;
function CancelAllJob(ByLauncher: TObject): TJobArray;
function CancelJobByName(aJobName: String; ByLauncher: TObject): boolean;
Procedure WaitForTerminate(const lstJob: TJobArray);
Procedure WaitAllJobTerminated(ByLauncher: TObject);
property UseThreads: boolean read FUseThreads write SetUseThreads;
property OnIdle: TNotifyEvent read FOnIdle write FOnIdle;
end;

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

@ -26,7 +26,9 @@ uses
type
{ TSimpleJob: job with only one task }
TSimpleJob = class(TJob)
private
FRunning, FEnded: boolean;
@ -41,6 +43,7 @@ type
TJobProc = procedure (Data: TObject; Job: TJob) of object;
{ TEventJob: job with only one task (callback an event) }
TEventJob = class(TSimpleJob)
private
FData: TObject;

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

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