////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Bitmap cache object.                                                       //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20251215 - Created by A.K.                                                 //
// 20251220 - Uses THashList instead of TStringList                           //
// 20260624 - IsValidGraphicFileName,BitmapLoadFromFile                       //
////////////////////////////////////////////////////////////////////////////////

unit _crw_bmpcache; //  Bitmap cache.

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, math, graphics,
 _crw_alloc, _crw_ef, _crw_rtc, _crw_str, _crw_fio,
 _crw_hl, _crw_utf8, _crw_dbglog;

 {
 Record for TBitmapCache statictics info.
 }
type
 TBmpStatInfo = record   // BmpCache stat info:
  CapCount    : SizeInt; // Capture Count
  BmpCount    : SizeInt; // BmpList Count
  BmpCount1   : SizeInt; // BmpList Count 1Bit
  BmpCount4   : SizeInt; // BmpList Count 4Bit
  BmpCount8   : SizeInt; // BmpList Count 8Bit
  BmpCount15  : SizeInt; // BmpList Count 15Bit
  BmpCount16  : SizeInt; // BmpList Count 16Bit
  BmpCount24  : SizeInt; // BmpList Count 24Bit
  BmpCount32  : SizeInt; // BmpList Count 32Bit
  BmpCountEmp : SizeInt; // BmpList Count Empty
  BmpCountEtc : SizeInt; // BmpList Count other bitness
  BmpCountBad : SizeInt; // BmpList Count bad (invalid)
  BmpMemCount : SizeInt; // BmpList Count memory (byte)
 end;

 {
 TBitmapCache class contains thread-safe bitmap cache.
 BmpCache object is default (system) instance of TBitmapCache.
 Use BmpCache.Capture/Uncapture to protect/release cached bitmaps.
 The BmpCache.Clear will not work until BmpCache became uncaptured.
 Use BmpCache.Find(BmpFileName) to find bitmap by (full) file name.
 Use BmpCache.Find(BmpFileName,True) to find or create/load bitmap.
 Use BmpCache.Clear to clear cached bitmaps if BmpCache uncaptured.
 }
type
 EBitmapCache = class(EEchoException);
 TBitmapCache = class(TMasterObject)
 private
  myLatch        : TLatch;
  myBmpList      : THashList;
  myBmpMemCount  : SizeInt;
  myCaptureCount : SizeInt;
 protected
  procedure Lock;
  procedure Unlock;
 private
  procedure ClearBmpList;
 public
  constructor Create;
  destructor  Destroy; override;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 public
  function    Capture:SizeInt;
  function    Uncapture:SizeInt;
  function    IsCaptured:Boolean;
  function    IsUncaptured:Boolean;
  function    CaptureCount:SizeInt;
 public
  function    Count:Integer;
  function    Clear:Boolean;
  function    CanClear:Boolean;
  function    BmpFileNamesAsText(nBits:Integer=0):LongString;
  function    GetBmpStatInfo:TBmpStatInfo;
  function    GetBmpStatInfoAsText:LongString;
  function    BmpStatInfoToText(const R:TBmpStatInfo):LongString;
  function    IsLoadableFile(const aBmpFileName:LongString):Boolean;
  function    LoadFromDir(aDir:LongString; aMask:LongString=''):Integer;
 public
  function    Find(aBmpFileName:LongString; aCanLoad:Boolean=False):TBitmap;
 private
  class var mySupportedGraphicClassNames:LongString;
  class var mySupportedGraphicExtensions:LongString;
  class var mySupportedGraphicWildCards:LongString;
 public
  class function PrimeGraphicExtenstions(const Sep:LongString=''):LongString;
  class function SupportedGraphicClassNames(const Sep:LongString=''):LongString;
  class function SupportedGraphicExtensions(const Sep:LongString=''):LongString;
  class function SupportedGraphicWildCards(const Sep:LongString=''):LongString;
 public
  class function IsValidGraphicFileName(const FileName:LongString):Boolean;
  class function BitmapLoadFromFile(Bmp:TBitmap; const FileName:LongString):Boolean;
 public
  class procedure SelfTest(var F:Text; Dir:LongString);
 public // 0:set False; 1:set True; else don't change
  class var TransparencyCmd:Integer;
 end;

 {
 BmpCache object is default (system) instance of TBitmapCache.
 }
function BmpCache:TBitmapCache;

procedure Kill(var TheObject:TBitmapCache); overload;

function dlc_BmpCacheLog:Integer;

implementation

/////////////////
// Debug routines
/////////////////

function dlc_BmpCacheLog:Integer;
const dlc:Integer=0;
begin
 if (dlc=0) then dlc:=RegisterDebugLogChannel('_BmpCacheLog');
 Result:=dlc;
end;

//////////////////////////////
// TBitmapCache implementation
//////////////////////////////

constructor TBitmapCache.Create;
begin
 inherited Create;
 myLatch:=NewLatch;
 myLatch.Master:=@myLatch;
 myBmpList:=NewHashList(False,HashList_DefaultHasher);
 myBmpList.Master:=@myBmpList;
 myBmpList.OwnsObjects:=True;
end;

destructor TBitmapCache.Destroy;
begin
 Kill(myLatch);
 Kill(myBmpList);
 inherited Destroy;
end;

procedure TBitmapCache.AfterConstruction;
begin
 inherited AfterConstruction;
 SupportedGraphicClassNames;
 ClearBmpList;
end;

procedure TBitmapCache.BeforeDestruction;
begin
 ClearBmpList;
 inherited BeforeDestruction;
end;

procedure TBitmapCache.Lock;
begin
 if Assigned(Self) then myLatch.Lock;
end;

procedure TBitmapCache.Unlock;
begin
 if Assigned(Self) then myLatch.Unlock;
end;

procedure TBitmapCache.ClearBmpList;
begin
 if Assigned(Self) then
 try
  Lock;
  try
   myBmpList.Clear;
   myBmpMemCount:=0;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self,'ClearBmpList');
 end;
end;

function TBitmapCache.CaptureCount:SizeInt;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myCaptureCount;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self,'CaptureCount');
 end;
end;

function TBitmapCache.Capture:SizeInt;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   Inc(myCaptureCount);
   Result:=myCaptureCount;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self,'Capture');
 end;
end;

function TBitmapCache.Uncapture:SizeInt;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   Dec(myCaptureCount);
   Result:=myCaptureCount;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self,'Uncapture');
 end;
end;

function TBitmapCache.IsCaptured:Boolean;
begin
 if Assigned(Self)
 then Result:=(CaptureCount>0)
 else Result:=False;
end;

function TBitmapCache.IsUncaptured:Boolean;
begin
 if Assigned(Self)
 then Result:=(CaptureCount<=0)
 else Result:=False;
end;

function TBitmapCache.Count:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myBmpList.Count;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self,'Count');
 end;
end;

function TBitmapCache.Clear:Boolean;
begin
 Result:=False;
 if Assigned(Self) then
 try
  Lock;
  try
   if CanClear then ClearBmpList;
   Result:=(myBmpList.Count=0);
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self,'Clear');
 end;
end;

function TBitmapCache.CanClear:Boolean;
begin
 if Assigned(Self)
 then Result:=IsUncaptured
 else Result:=False;
end;

function FilterFiles(List:THashList; nBits:Integer):LongString;
var Lines:TStringList; i:Integer; Bmp:TBitmap;
begin
 Result:='';
 Lines:=nil;
 if Assigned(List) then
 try
  if not (nBits in [1,4,8,15,16,24,32]) then nBits:=0;
  Lines:=TStringList.Create;
  Lines.Sorted:=True;
  Lines.Duplicates:=dupIgnore;
  for i:=0 to List.Count-1 do
  if (List.Objects[i] is TBitmap) then begin
   Bmp:=(List.Objects[i] as TBitmap);
   if Bmp.Empty then continue;
   if (nBits=0)
   then Lines.Add(List.Keys[i])
   else
   case Bmp.PixelFormat of
    pf1bit:  if (nBits=1)  then Lines.Add(List.Keys[i]);
    pf4bit:  if (nBits=4)  then Lines.Add(List.Keys[i]);
    pf8bit:  if (nBits=8)  then Lines.Add(List.Keys[i]);
    pf15bit: if (nBits=15) then Lines.Add(List.Keys[i]);
    pf16bit: if (nBits=16) then Lines.Add(List.Keys[i]);
    pf24bit: if (nBits=24) then Lines.Add(List.Keys[i]);
    pf32bit: if (nBits=32) then Lines.Add(List.Keys[i]);
   end;
   Result:=Lines.Text;
  end;
 finally
  Kill(Lines);
 end;
end;

function TBitmapCache.BmpFileNamesAsText(nBits:Integer=0):LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=FilterFiles(myBmpList,nBits);
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self,'BmpFileNamesAsText');
 end;
end;

function TBitmapCache.GetBmpStatInfo:TBmpStatInfo;
var i:Integer; Obj:TObject; Bmp:TBitmap;
begin
 Result:=Default(TBmpStatInfo);
 if Assigned(Self) then
 try
  Lock;
  try
   Result.CapCount:=myCaptureCount;
   Result.BmpCount:=myBmpList.Count;
   Result.BmpMemCount:=myBmpMemCount;
   for i:=0 to myBmpList.Count-1 do begin
    Obj:=myBmpList.Objects[i];
    if (Obj is TBitmap) then begin
     Bmp:=(Obj as TBitmap);
     if Bmp.Empty
     then Inc(Result.BmpCountEmp)
     else
     case Bmp.PixelFormat of
      pf1bit:  Inc(Result.BmpCount1);
      pf4bit:  Inc(Result.BmpCount4);
      pf8bit:  Inc(Result.BmpCount8);
      pf15bit: Inc(Result.BmpCount15);
      pf16bit: Inc(Result.BmpCount16);
      pf24bit: Inc(Result.BmpCount24);
      pf32bit: Inc(Result.BmpCount32);
      else     Inc(Result.BmpCountEtc);
     end;
    end else Inc(Result.BmpCountBad);
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self,'GetBmpStatInfo');
 end;
end;

function TBitmapCache.GetBmpStatInfoAsText:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Result:=BmpStatInfoToText(GetBmpStatInfo);
 except
  on E:Exception do BugReport(E,Self,'GetBmpStatInfoAsText');
 end;
end;

function TBitmapCache.BmpStatInfoToText(const R:TBmpStatInfo):LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Result:=Format('CaptureCount  = %d',[R.CapCount])+EOL
         +Format('BmpListCount  = %d',[R.BmpCount])+EOL
         +Format('BmpCount1bit  = %d',[R.BmpCount1])+EOL
         +Format('BmpCount4bit  = %d',[R.BmpCount4])+EOL
         +Format('BmpCount8bit  = %d',[R.BmpCount8])+EOL
         +Format('BmpCount15bit = %d',[R.BmpCount15])+EOL
         +Format('BmpCount16bit = %d',[R.BmpCount16])+EOL
         +Format('BmpCount24bit = %d',[R.BmpCount24])+EOL
         +Format('BmpCount32bit = %d',[R.BmpCount32])+EOL
         +Format('BmpCountEmpty = %d',[R.BmpCountEmp])+EOL
         +Format('BmpCountEtc   = %d',[R.BmpCountEtc])+EOL
         +Format('BmpCountBad   = %d',[R.BmpCountBad])+EOL
         +Format('BmpMemCount   = %d',[R.BmpMemCount])+EOL;
 except
  on E:Exception do BugReport(E,Self,'BmpStatInfoToText');
 end;
end;

function TBitmapCache.IsLoadableFile(const aBmpFileName:LongString):Boolean;
begin
 if Assigned(Self)
 then Result:=IsValidGraphicFileName(aBmpFileName)
 else Result:=False;
end;

function EastimateStringMemory(const S:LongString):SizeInt;
const Head=SizeOf(SizeInt)+SizeOf(Integer); Block=16;
begin
 Result:=AdjustBufferSize(Length(S)+Head+1,Block);
end;

function TBitmapCache.Find(aBmpFileName:LongString; aCanLoad:Boolean=False):TBitmap;
var i:Integer; Obj:TObject; aBmpFileKey:LongString;
begin
 Result:=nil;
 if Assigned(Self) then
 try
  if IsEmptyStr(aBmpFileName) then Exit;
  aBmpFileName:=UnifyFileAlias(aBmpFileName);
  aBmpFileKey:=aBmpFileName; // Key for hashlist
  // On UTF8 non-ASCII key it must make lowercase
  if (DefaultFileSystemCodePage=CP_UTF8) then begin
   if not IsLexeme(aBmpFileKey,lex_Ascii)
   then if utf8_valid(aBmpFileKey)
   then aBmpFileKey:=utf8_lowercase(aBmpFileKey);
  end;
  // Search in hashlist, load/insert if not found
  Lock;
  try
   i:=myBmpList.IndexOf(aBmpFileKey);
   if (i>=0) then begin
    Obj:=myBmpList.Objects[i];
    if (Obj is TBitmap) then Result:=TBitmap(Obj);
    Exit; // aBmpFileKey was found in the list
   end;
   if aCanLoad and IsLoadableFile(aBmpFileName) then
   try
    Result:=TBitmap.Create;
    if BitmapLoadFromFile(Result,aBmpFileName) then begin
     Inc(myBmpMemCount,Result.InstanceSize);
     Inc(myBmpMemCount,GetFileSize(aBmpFileName));
     Inc(myBmpMemCount,EastimateStringMemory(aBmpFileName));
     myBmpList.KeyedObjects[aBmpFileKey]:=Result;
    end else RAISE EBitmapCache.Create('Fail LoadFromFile('+aBmpFileName+').');
   except
    on E:Exception do begin
     BugReport(E,Self,'Find');
     FreeAndNil(Result);
    end;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self,'Find');
 end;
end;

function ApplySep(const S,Sep:LongString):LongString;
begin
 Result:=S;
 if (Sep<>'') and (Sep<>';') and (Result<>'')
 then Result:=StringReplace(Result,';',Sep,[rfReplaceAll]);
end;

class function TBitmapCache.PrimeGraphicExtenstions(const Sep:LongString=''):LongString;
const PrimeExts='bmp;gif;png;jpeg;ico;icns;xpm;tif;pbm;cur;tga;';
begin
 Result:=ApplySep(PrimeExts,Sep);
end;

class function TBitmapCache.SupportedGraphicClassNames(const Sep:LongString=''):LongString;
var i:Integer; gc:TGraphicClass; ExtList,Ext,Cls:LongString;
begin
 if (mySupportedGraphicClassNames='') then begin
  mySupportedGraphicClassNames:='';
  mySupportedGraphicExtensions:='';
  mySupportedGraphicWildCards:='';
  ExtList:=PrimeGraphicExtenstions;
  for i:=1 to WordCount(ExtList,ScanSpaces) do begin
   Ext:=ExtractWord(i,ExtList,ScanSpaces);
   gc:=GetGraphicClassForFileExtension(Ext);
   if Assigned(gc) then begin
    Cls:=gc.ClassName; Ext:=gc.GetFileExtensions;
    if (Cls<>'') then mySupportedGraphicClassNames+=(Cls+';');
    if (Ext<>'') then mySupportedGraphicExtensions+=(Ext+';');
   end;
  end;
  ExtList:=mySupportedGraphicExtensions;
  for i:=1 to WordCount(ExtList,ScanSpaces) do begin
   Ext:=ExtractWord(i,ExtList,ScanSpaces);
   mySupportedGraphicWildCards+=('*.'+Ext+';');
  end;
 end;
 Result:=ApplySep(mySupportedGraphicClassNames,Sep);
end;

class function TBitmapCache.SupportedGraphicExtensions(const Sep:LongString=''):LongString;
begin
 if (mySupportedGraphicExtensions='') then SupportedGraphicClassNames;
 Result:=ApplySep(mySupportedGraphicExtensions,Sep);
end;

class function TBitmapCache.SupportedGraphicWildCards(const Sep:LongString=''):LongString;
begin
 if (mySupportedGraphicWildCards='') then SupportedGraphicClassNames;
 Result:=ApplySep(mySupportedGraphicWildCards,Sep);
end;

function TBitmapCache.LoadFromDir(aDir:LongString; aMask:LongString=''):Integer;
var Files:TStringList; i:Integer;
begin
 Result:=0;
 try
  Files:=TStringList.Create;
  try
   aMask:=TrimDef(aMask,SupportedGraphicWildCards);
   if DirExists(aDir)
   then Files.Text:=FindAllFilesAsText(aDir,TrimDef(aMask,aMask));
   for i:=0 to Files.Count-1 do begin
    if Assigned(Find(Files[i],True))
    then Inc(Result);
   end;
  finally
   Kill(Files);
  end;
 except
  on E:Exception do BugReport(E,BmpCache,'LoadFromDir');
 end;
end;

class function TBitmapCache.IsValidGraphicFileName(const FileName:LongString):Boolean;
var gc:TGraphicClass;
begin
 Result:=False; if IsEmptyStr(FileName) then Exit;
 gc:=GetGraphicClassForFileExtension(ExtractFileExt(FileName));
 if Assigned(gc) and FileIsReadable(FileName) then Result:=True;
end;

class function TBitmapCache.BitmapLoadFromFile(Bmp:TBitmap; const FileName:LongString):Boolean;
var Pic:TPicture; gc:TGraphicClass;
begin
 Result:=False;
 if Assigned(Bmp) then
 if IsNonEmptyStr(FileName) then
 if FileIsReadable(FileName) then
 try
  gc:=GetGraphicClassForFileExtension(ExtractFileExt(FileName));
  if Assigned(gc) then begin
   if gc.ClassNameIs('TBitmap') then begin
    Bmp.LoadFromFile(FileName);
    Result:=True;
   end else begin
    Pic:=TPicture.Create;
    try
     Pic.LoadFromFile(FileName);
     if Assigned(Pic.Bitmap) and not Pic.Bitmap.Empty then begin
      Bmp.Assign(Pic.Bitmap);
      Result:=True;
     end;
    finally
     FreeAndNil(Pic);
    end;
   end;
  end;
  if Assigned(gc) then begin
   if DebugLogEnabled(dlc_BmpCacheLog) then begin
    DebugLog(dlc_BmpCacheLog,Format('%s BitmapLoadFromFile %s %s',
      [ExtractWord(1+BoolToInt(Result),'Fail,Done',ScanSpaces),
       GraphicExtension(gc),FileName]));
   end;
   if Result then begin
    if Bmp.Transparent then begin
     if DebugLogEnabled(dlc_BmpCacheLog) then begin
      DebugLog(dlc_BmpCacheLog,Format('Transpatency %d %s %s',
      [Ord(Bmp.TransparentMode),ColorToString(Bmp.TransparentColor),FileName]));
     end;
     if (TransparencyCmd in [0,1])
     then Bmp.Transparent:=(TransparencyCmd>0);
    end;
   end;
  end else begin
   if DebugLogEnabled(dlc_BmpCacheLog) then begin
    DebugLog(dlc_BmpCacheLog,Format('Unsupported file type %s',[FileName]));
   end;
  end;
 except
  on E:Exception do BugReport(E,nil,'BitmapLoadFromFile');
 end;
end;

class procedure TBitmapCache.SelfTest(var F:Text; Dir:LongString);
var Files:TStringList; i,Iter,nTry,nSuc,Bal,Num,Mem:Integer; R:TBmpStatInfo;
begin
 try
  Files:=TStringList.Create;
  try
   writeln(F,'Start BmpCache.SelfTest:');
   writeln(F,'Dir = ',Dir);
   if DirExists(Dir)
   then Files.Text:=FindAllFilesAsText(Dir,SupportedGraphicWildCards);
   writeln(F,Files.Count,' file(s) found to process.');
   BmpCache.Clear;
   writeln(F,BmpCache.Count,' item(s) in BmpCache on Enter.');
   nTry:=0; nSuc:=0;
   Bal:=GetAllocMemSize;
   for Iter:=1 to 10 do begin
    for i:=0 to Files.Count-1 do begin
     if Assigned(BmpCache.Find(Files[i],True))
     then Inc(nSuc);
     Inc(nTry);
    end;
   end;
   Mem:=GetAllocMemSize-Bal;
   R:=BmpCache.GetBmpStatInfo;
   Num:=BmpCache.Count;
   BmpCache.Clear;
   Bal:=GetAllocMemSize-Bal;
   writeln(F,nTry,' test(s), ',nSuc,' succeed.');
   writeln(F,Num,' item(s) in BmpCache on Iterations.');
   writeln(F,BmpCache.Count,' item(s) in BmpCache on Leave.');
   writeln(F,Mem,' byte(s) was occupied.');
   writeln(F,Bal,' byte(s) Balance.');
   writeln(F,'BmpCache Stat:');
   writeln(F,Trim(BmpCache.BmpStatInfoToText(R)));
   writeln(F,'IoResult = ',IoResult);
   writeln(F,'Done BmpCache.SelfTest.');
  finally
   Kill(Files);
  end;
 except
  on E:Exception do BugReport(E,BmpCache,'SelfTest');
 end;
end;

//////////////////////////
// BmpCache implementation
//////////////////////////
const
 TheBmpCache:TBitmapCache=nil;

function BmpCache:TBitmapCache;
begin
 if not Assigned(TheBmpCache) then begin
  TheBmpCache:=TBitmapCache.Create;
  TheBmpCache.Master:=@TheBmpCache;
 end;
 Result:=TheBmpCache;
end;

procedure Kill(var TheObject:TBitmapCache); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_bmpcache;
begin
 dlc_BmpCacheLog;
 BmpCache.Ok;
end;

procedure Free_crw_bmpcache;
begin
 TheBmpCache.Clear;
 ResourceLeakageLog(Format('%-60s = %d',['BmpCache.Count',TheBmpCache.Count]));
 ResourceLeakageLog(Format('%-60s = %d',['BmpCache.CaptureCount',TheBmpCache.CaptureCount]));
 Kill(TheBmpCache);
 TBitmapCache.mySupportedGraphicClassNames:='';
 TBitmapCache.mySupportedGraphicClassNames:='';
 TBitmapCache.mySupportedGraphicWildCards:='';
end;

initialization

 Init_crw_bmpcache;

finalization

 Free_crw_bmpcache;

end.

//////////////
// END OF FILE
//////////////

