paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

LazMapViewer: mvCache update (code by Ekkehard Domning):

Browse Source 
- Add property for the maximum number of tiles kept in memory (linked to MapView by Engine)
- Cache items stored in TFPObjectList rather than StringList
- Sorted StringList for faster searching.


git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@9574 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz 2025-01-09 16:54:05 +00:00
parent a57c5a8f75
commit 5fbafff4bf
3 changed files with 194 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -17,10 +17,11 @@ unit mvCache;
interface
uses
Classes, SysUtils, IntfGraphics, syncObjs,
Classes, SysUtils, Contnrs, IntfGraphics, syncObjs,
mvMapProvider, mvTypes, FPImage;
Type
EMvCacheException = class(Exception);
{ TPictureCacheItem }
TPictureCacheItem = class(TObject)
@ -35,21 +36,23 @@ Type
TPictureCacheItemClass = class of TPictureCacheItem;
{ TPictureCache }
TPictureCache = Class(TComponent)
private
FCacheItemClass: TPictureCacheItemClass;
FMaxAge: Integer;
FMemMaxElem: integer;
FMemMaxItemCount: Integer;
FCacheObjectList : TFPObjectList;
FCacheIDs: TStringList;
Crit: TCriticalSection;
Cache: TStringList;
FBasePath: String;
FUseDisk: Boolean;
FUseThreads: Boolean;
procedure SetMemMaxItemCount(Value: Integer);
procedure SetCacheItemClass(AValue: TPictureCacheItemClass);
procedure SetUseThreads(AValue: Boolean);
Procedure EnterCrit;
Procedure LeaveCrit;
procedure EnterCrit;
procedure LeaveCrit;
function GetCacheMemMaxItemCountDefault: Integer;
protected
//function GetNewImgFor(aStream: TStream): TLazIntfImage;
procedure ClearCache;
@ -57,12 +60,14 @@ Type
Function DiskCached(const aFileName: String): Boolean;
procedure LoadFromDisk(const aFileName: String; out item: TPictureCacheItem);
Function GetFileName(MapProvider: TMapProvider; const TileId: TTileId): String;
procedure AddItem(const Item: TPictureCacheItem; const AIDString : String);
procedure DeleteItem(const AItemIndex : Integer);
public
Procedure CheckCacheSize(Sender: TObject);
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
Procedure Add(MapProvider: TMapProvider; const TileId: TTileId; Stream: TMemoryStream);
Procedure GetFromCache(MapProvider: TMapProvider; const TileId: TTileId; out item: TPictureCacheItem);
Procedure GetFromCache(MapProvider: TMapProvider; const TileId: TTileId; out Item: TPictureCacheItem);
function GetPreviewFromCache(MapProvider: TMapProvider; var TileId: TTileId; out ARect: TRect): boolean;
function InCache(MapProvider: TMapProvider; const TileId: TTileId): Boolean;
procedure Prepare(MapProvider: TMapProvider);
@ -72,6 +77,8 @@ Type
property UseThreads: Boolean read FUseThreads write SetUseThreads;
property CacheItemClass: TPictureCacheItemClass read FCacheItemClass write SetCacheItemClass;
property MaxAge: Integer read FMaxAge write FMaxAge; // in days
property MemMaxItemCount: Integer read FMemMaxItemCount write SetMemMaxItemCount;
property CacheMemMaxItemCountDefault: Integer read GetCacheMemMaxItemCountDefault;
end;
@ -81,7 +88,11 @@ uses
GraphType, DateUtils, FPReadJPEG;
const
MEMCACHE_MAX = 64; // Tiles kept in memory
// Tiles kept in memory
// One tile has approx 256*256*4 Bytes = 256KBytes, 128 Tiles in Memory will consume 32MB of Memory
MEMCACHE_MIN = 16;
MEMCACHE_DEFAULT = 128; //64;
MEMCACHE_MAX = 1024;
MEMCACHE_SWEEP_CNT = 10; // Max tiles to be swept at once
FLAT_CACHE = false; // all cache files in flat folder, or grouped by provider and zoom
@ -150,21 +161,41 @@ begin
inherited Destroy;
end;
{ TPictureCache }
{
Some explanation about the internal cache memory.
There are two lists.
The first is the FCacheObjectList: ObjectList, which contains the stored objects.
The second is the FCacheIDs: StringList, which contains the IDString (= most likely the filename)
and in the objects property the reference to the object stored in the ObjectList.
This StringList is sorted to speed up the access to the cache items.
The FCacheObjectList contains the oldest objects in the lower indicees,
the newer ones at the end. If an Item is retrieved and located in the lower half
of the Indicees, it is place again at the end. This keeps often used items in the
cache.
If the cache is full, the list is reduced to FMemMaxItemCount-MEMCACHE_SWEEP_CNT,
so that not on every added tile another has to be deleted.
}
constructor TPictureCache.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
FCacheItemClass := TPictureCacheItem;
FMemMaxElem := MEMCACHE_MAX;
FMemMaxItemCount := MEMCACHE_DEFAULT;
FMaxAge := MaxInt;
Cache := TStringList.Create;
FCacheObjectList := TFPObjectList.Create(True); // Owns the objects
FCacheIDs := TStringList.Create;
FCacheIDs.Sorted := True;
FCacheIDs.Duplicates := dupAccept;
end;
destructor TPictureCache.Destroy;
begin
inherited;
ClearCache;
Cache.Free;
FreeAndNil(FCacheObjectList);
FreeAndNil(FCacheIDs);
FreeAndNil(Crit);
inherited;
end;
procedure TPictureCache.SetUseThreads(AValue: Boolean);
@ -177,6 +208,23 @@ begin
FreeAndNil(Crit);
end;
procedure TPictureCache.SetMemMaxItemCount(Value: Integer);
var
newcnt : Integer;
begin
if Value < MEMCACHE_MIN then
newcnt := MEMCACHE_MIN
else if Value > MEMCACHE_MAX then
newcnt := MEMCACHE_MAX
else
newcnt := Value;
if FMemMaxItemCount <> newcnt then
begin
FMemMaxItemCount := newcnt;
CheckCacheSize(Self);
end;
end;
procedure TPictureCache.SetCacheItemClass(AValue: TPictureCacheItemClass);
begin
if FCacheItemClass = AValue then Exit;
@ -196,6 +244,11 @@ begin
Crit.Leave;
end;
function TPictureCache.GetCacheMemMaxItemCountDefault: Integer;
begin
Result := MEMCACHE_DEFAULT;
end;
{
function TPictureCache.GetNewImgFor(aStream: TStream): TLazIntfImage;
var
@ -235,9 +288,8 @@ var
begin
EnterCrit;
try
for I := 0 to Pred(Cache.Count) do
Cache.Objects[I].Free;
Cache.Clear;
for I := FCacheObjectList.Count-1 downto 0 do
DeleteItem(i);
finally
LeaveCrit;
end;
@ -288,15 +340,8 @@ begin
except
FreeAndNil(item);
end;
if Assigned(item) then
begin
EnterCrit;
try
Cache.AddObject(aFileName, item);
finally
LeaveCrit;
end;
end;
if Assigned(Item) then
AddItem(Item, aFileName);
finally
lStream.Free;
end;
@ -315,50 +360,103 @@ begin
Result := SetDirSeparators(Format('%s/%d/%d_%d', [prov, TileID.Z, TileID.X, TileID.Y]));
end;
procedure TPictureCache.CheckCacheSize(Sender: TObject);
{ AddItem allows the insertion of an existing TPictureCacheItem.
CAUTION: This will not create any File on Disk!! }
procedure TPictureCache.AddItem(const Item: TPictureCacheItem;
const AIDString: String);
var
i, idx: integer;
pci, pci0 : TPictureCacheItem;
ndx, ndxi : Integer;
begin
EnterCrit;
try
if Cache.Count > FMemMaxElem then
begin
for i := 1 to MEMCACHE_SWEEP_CNT do
// First check is a Item with this ID is in the list
ndx := FCacheIDs.IndexOf(AIDString);
if ndx >= 0 then
begin // Delete the Item
ndxi := FCacheObjectList.IndexOf(FCacheIDs.Objects[ndx]);
if ndxi >= 0 then
DeleteItem(ndxi);
end;
pci := Item;
try
try
FCacheObjectList.Add(Item);
pci0 := pci; // from here the Item is in the object list
pci := Nil; // so nil
FCacheIDs.AddObject(AIDString,pci0);
except
end;
finally
if Assigned(pci) then
pci.Free; // assigned, that means the add to the objectlist failed. Free item
end;
finally
LeaveCrit;
end;
end;
procedure TPictureCache.DeleteItem(const AItemIndex: Integer);
var
i: Integer;
pci : TPictureCacheItem;
cnt : Integer;
begin
EnterCrit;
try
cnt := FCacheObjectList.Count;
if (AItemIndex < 0) or (AItemIndex >= cnt) then Exit; // Out of Index, exut
// Extract the item
pci := TPictureCacheItem(FCacheObjectList.Extract(FCacheObjectList.Items[AItemIndex]));
if Assigned(pci) then // should be always assigned
try
for i := 0 to FCacheIDs.Count-1 do
begin
idx := pred(Cache.Count);
if idx > 1 then
if (FCacheIDs.Objects[i] = pci) then // String fit, object also?
begin
Cache.Objects[idx].Free;
Cache.Delete(idx);
FCacheIDs.Delete(i); // Delete the entry
Break;
end;
end;
finally
pci.Free; // always free the extracted item
end;
finally
LeaveCrit;
end;
end;
procedure TPictureCache.CheckCacheSize(Sender: TObject);
var
cnt: integer;
begin
EnterCrit;
try
cnt := FCacheObjectList.Count;
if cnt < FMemMaxItemCount then Exit;
repeat
cnt := FCacheObjectList.Count;
if cnt < (FMemMaxItemCount-MEMCACHE_SWEEP_CNT) then Break;
DeleteItem(0);
until False;
finally
LeaveCrit;
end;
end;
procedure TPictureCache.Add(MapProvider: TMapProvider;
const TileId: TTileId; Stream: TMemoryStream);
var
FileName: String;
item: TPictureCacheItem;
lFile: TFileStream;
idx: integer;
begin
FileName := GetFileName(MapProvider, TileId);
EnterCrit;
try
item := FCacheItemClass.Create(Stream); //GetNewImgFor(Stream);
idx := Cache.IndexOf(FileName);
if idx <> -1 then
Cache.Objects[idx].Free
else
begin
Cache.Insert(0, FileName);
idx := 0;
end;
Cache.Objects[idx]:=item;
AddItem(Item, FileName);
finally
LeaveCrit;
end;
@ -390,15 +488,22 @@ begin
FileName := GetFileName(MapProvider, TileId);
EnterCrit;
try
idx := Cache.IndexOf(FileName);
idx := FCacheIDs.IndexOf(FileName);
if idx <> -1 then
begin
item := TPictureCacheItem(Cache.Objects[idx]);
if Idx > FMemMaxElem div 2 then
Item := TPictureCacheItem(FCacheIDs.Objects[idx]);
if Assigned(Item) then
begin
Cache.Delete(idx);
Cache.Insert(0, FileName);
Cache.Objects[0] := item;
idx := FCacheObjectList.IndexOf(Item);
if idx > FMemMaxItemCount div 2 then
begin
FCacheObjectList.Extract(Item);
try
FCacheObjectList.Add(Item);
except
Item.Free;
end;
end;
end;
end;
@ -479,7 +584,7 @@ begin
FileName := GetFileName(MapProvider, TileId);
EnterCrit;
try
idx := Cache.IndexOF(FileNAme);
idx := FCacheIDs.IndexOF(FileNAme);
finally
LeaveCrit;
end;

21
components/lazmapviewer/source/mvengine.pas
View File

@ -86,6 +86,8 @@ type
function GetCacheMaxAge: Integer;
function GetCacheOnDisk: Boolean;
function GetCachePath: String;
function GetCacheMemMaxItemCount : Integer;
function GetCacheMemMaxItemCountDefault : Integer;
function GetCenter: TRealPoint;
function GetHeight: integer;
class function GetProjectionType(const aWin: TMapWindow): TProjectionType;
@ -102,6 +104,7 @@ type
procedure SetCacheMaxAge(AValue: Integer);
procedure SetCacheOnDisk(AValue: Boolean);
procedure SetCachePath(AValue: String);
procedure SetCacheMemMaxItemCount(AValue : Integer);
procedure SetCenter(ACenter: TRealPoint);
procedure SetCyclic(AValue: Boolean);
procedure SetDownloadEngine(AValue: TMvCustomDownloadEngine);
@ -183,6 +186,7 @@ type
property MapProjectionType: TProjectionType read GetMapProjectionType;
property BkColor: TFPColor read FBkColor write SetBkColor;
property CacheMemMaxItemCountDefault: Integer read GetCacheMemMaxItemCountDefault;
property Center: TRealPoint read GetCenter write SetCenter;
property DrawPreviewTiles : Boolean read FDrawPreviewTiles write FDrawPreviewTiles;
property InDrag: Boolean read FInDrag;
@ -190,11 +194,11 @@ type
property CacheMaxAge: Integer read GetCacheMaxAge write SetCacheMaxAge;
property ZoomMin: Integer read FZoomMax write FZoomMin;
property ZoomMax: Integer read FZoomMax write FZoomMax;
published
property Active: Boolean read FActive write SetActive default false;
property CacheOnDisk: Boolean read GetCacheOnDisk write SetCacheOnDisk;
property CachePath: String read GetCachePath write SetCachePath;
property CacheMemMaxItemCount : Integer read GetCacheMemMaxItemCount write SetCacheMemMaxItemCount;
property Cyclic: Boolean read FCyclic write SetCyclic default false;
property DownloadEngine: TMvCustomDownloadEngine
read FDownloadEngine write SetDownloadEngine;
@ -571,6 +575,16 @@ begin
Result := Cache.BasePath;
end;
function TMapViewerEngine.GetCacheMemMaxItemCount: Integer;
begin
Result := Cache.MemMaxItemCount;
end;
function TMapViewerEngine.GetCacheMemMaxItemCountDefault: Integer;
begin
Result := Cache.CacheMemMaxItemCountDefault;
end;
function TMapViewerEngine.GetCenter: TRealPoint;
begin
Result := MapWin.Center;
@ -1272,6 +1286,11 @@ begin
Cache.BasePath := SetDirSeparators(aValue);
end;
procedure TMapViewerEngine.SetCacheMemMaxItemCount(AValue: Integer);
begin
Cache.MemMaxItemCount := AValue;
end;
procedure TMapViewerEngine.SetCenter(ACenter: TRealPoint);
begin
if (MapWin.Center.Lon = aCenter.Lon) and (MapWin.Center.Lat = aCenter.Lat) then

19
components/lazmapviewer/source/mvmapviewer.pas
View File

@ -538,6 +538,7 @@ type
procedure DrawGpsObj(const {%H-}Area: TRealArea; AObj: TGPSObj);
function GetCacheMaxAge: Integer;
function GetCacheOnDisk: boolean;
function GetCacheMemMaxItemCount : Integer;
function GetCenter: TRealPoint;
function GetCyclic: Boolean;
function GetDownloadEngine: TMvCustomDownloadEngine;
@ -557,6 +558,7 @@ type
function GetZoom: integer;
function GetZoomToCursor: Boolean;
function IsCacheMaxAgeStored: Boolean;
function IsCacheMemMaxItemCountStored : Boolean;
function IsCachePathStored: Boolean;
function IsFontStored: Boolean;
function IsLayersStored: Boolean;
@ -565,6 +567,7 @@ type
procedure SetCacheMaxAge(AValue: Integer);
procedure SetCacheOnDisk(AValue: boolean);
procedure SetCachePath(AValue: String);
procedure SetCacheMemMaxItemCount(AValue : Integer);
procedure SetCenter(AValue: TRealPoint);
procedure SetCyclic(AValue: Boolean);
procedure SetDebugTiles(AValue: Boolean);
@ -697,6 +700,7 @@ type
property CachePath: String read FCachePath write SetCachePath stored IsCachePathStored;
property CacheFullPath: String read FCacheFullPath stored False;
property CacheMaxAge: Integer read GetCacheMaxAge write SetCacheMaxAge stored IsCacheMaxAgeStored;
property CacheMemMaxItemCount : Integer read GetCacheMemMaxItemCount write SetCacheMemMaxItemCount stored IsCacheMemMaxItemCountStored;
property Cyclic: Boolean read GetCyclic write SetCyclic default false;
property DebugTiles: Boolean read FDebugTiles write SetDebugTiles default false;
property DefaultTrackColor: TColor read FDefaultTrackColor write SetDefaultTrackColor default clRed;
@ -2265,6 +2269,11 @@ begin
Result := FCacheOnDisk;
end;
function TMapView.GetCacheMemMaxItemCount: Integer;
begin
Result := Engine.CacheMemMaxItemCount;
end;
function TMapView.GetCenter: TRealPoint;
begin
Result := Engine.Center;
@ -2382,6 +2391,11 @@ begin
Result := Engine.CacheMaxAge <> MaxInt;
end;
function TMapView.IsCacheMemMaxItemCountStored: Boolean;
begin
Result := (Engine.CacheMemMaxItemCount <> Engine.CacheMemMaxItemCountDefault);
end;
function TMapView.IsCachePathStored: Boolean;
begin
Result := not SameText(CachePath, 'cache/');
@ -2420,6 +2434,11 @@ begin
ChangeCachePath(CacheLocation, NewPath);
end;
procedure TMapView.SetCacheMemMaxItemCount(AValue: Integer);
begin
Engine.CacheMemMaxItemCount:= AValue;
end;
procedure TMapView.SetCenter(AValue: TRealPoint);
begin
Engine.Center := AValue;