lcl: implement imagelist cache to reduce amount of imagelists for bitbtns and speedbuttons

git-svn-id: trunk@12906 -

.gitattributes

@@ -2580,6 +2580,7 @@ lcl/graphmath.pp svneol=native#text/pascal
 lcl/graphtype.pp svneol=native#text/pascal
 lcl/grids.pas svneol=native#text/pascal
 lcl/helpintfs.pas svneol=native#text/plain
+lcl/imagelistcache.pas svneol=native#text/pascal
 lcl/images/README.txt svneol=native#text/plain
 lcl/images/btncalccancel.xpm -text svneol=native#image/x-xpixmap
 lcl/images/btncalcimg.xpm -text svneol=native#image/x-xpixmap

lcl/buttons.pp

@@ -40,7 +40,7 @@ interface
 uses
   Types, Classes, SysUtils, Math, LCLType, LCLProc, LCLIntf, LCLStrConsts,
   GraphType, Graphics, ImgList, ActnList, Controls, StdCtrls, LMessages, Forms,
-  Themes, Menus{for ShortCut procedures}, LResources;
+  Themes, Menus{for ShortCut procedures}, LResources, ImageListCache;
 
 type
   { TButton }
@@ -73,15 +73,26 @@ type
 
   { TButtonGlyph }
 
-  TButtonGlyph = class
+  TButtonGlyph = class(TObject, IUnknown, IImageCacheListener)
   private
+    FImageIndexes: array[TButtonState] of Integer;
     FImages: TCustomImageList;
     FOriginal: TBitmap;
     FNumGlyphs: TNumGlyphs;
     FOnChange: TNotifyEvent;
+    FImagesCache: TImageListCache;
     procedure SetGlyph(Value: TBitmap);
     procedure SetNumGlyphs(Value: TNumGlyphs);
   protected
+    // IUnknown
+    function QueryInterface(const iid: tguid; out obj): longint; stdcall;
+    function _AddRef: longint; stdcall;
+    function _Release: longint; stdcall;
+
+    // IImageCacheListener
+    procedure CacheSetImageList(AImageList: TCustomImageList);
+    procedure CacheSetImageIndex(AIndex, AImageIndex: Integer);
+
     procedure GlyphChanged(Sender: TObject);
   public
     constructor Create;

lcl/imagelistcache.pas

@@ -0,0 +1,329 @@
+{
+ /***************************************************************************
+                               ImageListCache.pp
+                               ----------------
+                   Initial Revision  : Sun Nov 18 00:04:00 GMT+07 2007
+
+
+ ***************************************************************************/
+
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.modifiedLGPL, included in this distribution,        *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+
+unit ImageListCache;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Graphics, ImgList;
+
+type
+  // interface that cache user should have to listen for cache changes
+  IImageCacheListener = interface
+    procedure CacheSetImageList(AImageList: TCustomImageList);
+    procedure CacheSetImageIndex(AIndex, AImageIndex: Integer);
+  end;
+
+  // cache item
+  TImageCacheItem = record
+    FImageList: TCustomImageList;    // link to imagelist
+    FListener: IImageCacheListener;  // link to listener
+    FImageIndexes: array of Integer; // indexes of imagelist that listener reserved
+  end;
+  PImageCacheItem = ^TImageCacheItem;
+  
+  { TImageCacheItems }
+
+  TImageCacheItems = class(TList)
+  private
+    function GetItem(AIndex: Integer): PImageCacheItem;
+    function GetItemForListener(AListener: IImageCacheListener): PImageCacheItem;
+    procedure SetItem(AIndex: Integer; const AValue: PImageCacheItem);
+  protected
+    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
+  public
+    function GetNew: PImageCacheItem;
+    property Items[AIndex: Integer]: PImageCacheItem read GetItem write SetItem; default;
+  end;
+
+  { TImageListCache }
+
+  TImageListCache = class
+  private
+    FItems: TImageCacheItems;
+    FImages: TList;
+    FListeners: TInterfaceList;
+    FObsoletedCount: Integer;
+    procedure CheckRebuildNeed;
+    function GetImageListFor(AWidth, AHeight: Integer): TCustomImageList;
+
+    procedure UnregisterBitmaps(AListener: IImageCacheListener);
+  public
+    constructor Create;
+    destructor Destroy; override;
+    
+    function RegisterListener(AListener: IImageCacheListener): Integer;
+    procedure UnregisterListener(AListener: IImageCacheListener);
+    procedure RegisterBitmap(AListener: IImageCacheListener; ABitmap: TBitmap; ABitmapCount: Integer = 1);
+    procedure Rebuild;
+  end;
+  
+  function GetImageListCache: TImageListCache;
+  
+implementation
+
+const
+  // number of cache changes that can happen w/o rebuild
+  ImageListCacheRebuildThreashold = 1;
+
+var
+  FImageListCache: TImageListCache = nil;
+  
+function GetImageListCache: TImageListCache;
+begin
+  if FImageListCache = nil then
+    FImageListCache := TImageListCache.Create;
+  Result := FImageListCache;
+end;
+
+
+{ TImageListCache }
+
+procedure TImageListCache.CheckRebuildNeed;
+begin
+  if FObsoletedCount >= ImageListCacheRebuildThreashold then
+    Rebuild;
+end;
+
+function TImageListCache.GetImageListFor(AWidth, AHeight: Integer): TCustomImageList;
+var
+  i: integer;
+begin
+  for i := 0 to FImages.Count - 1 do
+    if (TCustomImageList(FImages[i]).Height = AHeight) and
+       (TCustomImageList(FImages[i]).Width = AWidth) then
+    begin
+      Result := TCustomImageList(FImages[i]);
+      exit;
+    end;
+  Result := TCustomImageList.Create(nil);
+  FImages.Add(Result);
+  with Result do
+  begin
+    Width := AWidth;
+    Height := AHeight;
+    //WriteLn('Creating new imagelist in cache for Width=',Width,' Height=', Height, ' Count = ', FImages.Count);
+  end;
+end;
+
+procedure TImageListCache.UnregisterBitmaps(AListener: IImageCacheListener);
+var
+  Item: PImageCacheItem;
+begin
+  Item := FItems.GetItemForListener(AListener);
+
+  if (Item <> nil) then
+  begin
+    Item^.FListener := nil;
+    inc(FObsoletedCount, Length(Item^.FImageIndexes));
+  end;
+  CheckRebuildNeed;
+end;
+
+constructor TImageListCache.Create;
+begin
+  FObsoletedCount := 0;
+  FItems := TImageCacheItems.Create;
+  FImages := TList.Create;
+  FListeners := TInterfaceList.Create;
+end;
+
+destructor TImageListCache.Destroy;
+var
+  i: integer;
+begin
+  FItems.Free;
+  for i := 0 to FImages.Count - 1 do
+    TObject(FImages[i]).Free;
+  FImages.Free;
+  FListeners.Free;
+  inherited Destroy;
+end;
+
+function TImageListCache.RegisterListener(AListener: IImageCacheListener): Integer;
+begin
+  Result := FListeners.IndexOf(AListener);
+  if Result = -1 then
+    Result := FListeners.Add(AListener);
+end;
+
+procedure TImageListCache.UnregisterListener(AListener: IImageCacheListener);
+var
+  Index: Integer;
+begin
+  Index := FListeners.IndexOf(AListener);
+  if Index <> -1 then
+  begin
+    UnregisterBitmaps(AListener);
+    FListeners.Remove(AListener);
+  end;
+  if FListeners.Count = 0 then
+    Free;
+end;
+
+procedure TImageListCache.RegisterBitmap(AListener: IImageCacheListener; ABitmap: TBitmap; ABitmapCount: Integer = 1);
+var
+  i, AStart, OldLen: Integer;
+  Item: PImageCacheItem;
+begin
+  RegisterListener(AListener);
+  Item := FItems.GetItemForListener(AListener);
+  if Item = nil then
+  begin
+    Item := FItems.GetNew;
+    Item^.FImageList := GetImageListFor(ABitmap.Width div ABitmapCount, ABitmap.Height);
+    Item^.FListener := AListener;
+  end;
+
+  AStart := Item^.FImageList.Add(ABitmap, nil);
+  AListener.CacheSetImageList(Item^.FImageList);
+  OldLen := Length(Item^.FImageIndexes);
+  SetLength(Item^.FImageIndexes, OldLen + Item^.FImageList.Count - AStart);
+  
+  for i := AStart to Item^.FImageList.Count - 1 do
+  begin
+    Item^.FImageIndexes[OldLen + i - AStart] := i;
+    AListener.CacheSetImageIndex(OldLen + i - AStart, AStart);
+  end;
+end;
+
+// cache rebuild
+procedure TImageListCache.Rebuild;
+var
+  i, j, k, ACount: integer;
+  AListener: IImageCacheListener;
+  ADeleted: TBits;
+  AChanged: Boolean;
+  AIndexes: array of Integer;
+  AUpdates: TList;
+begin
+  // 1. check what items to be deleted (their listerners are not assigned)
+  // 2. delete no more needed images from imagelists
+  // 3. notify listeners about new image indexes
+  
+  // traverse all ImageLists
+  for i := 0 to FImages.Count - 1 do
+  begin
+    ACount := TCustomImageList(FImages[i]).Count;
+    ADeleted := TBits.Create(ACount);
+    AChanged := False;
+    AUpdates := TList.Create;
+    // traverse for all items
+    // if item is to be deleted then set flag in ADeleted, else add item to AUpdates array
+    for j := FItems.Count - 1 downto 0 do
+      if FItems[j]^.FImageList = TCustomImageList(FImages[i]) then
+      begin
+        for k := 0 to High(FItems[j]^.FImageIndexes) do
+          ADeleted.Bits[FItems[j]^.FImageIndexes[k]] := FItems[j]^.FListener = nil;
+        if FItems[j]^.FListener = nil then
+        begin
+          FItems.Delete(j);
+          AChanged := True;
+        end
+        else
+          AUpdates.Add(FItems[j]);
+      end;
+    // is something has been deleted from current imagelist then
+    // we continue processing
+    if AChanged then
+    begin
+      // AIndexes is our old=>new image indexes map
+      // at first step we set old=old and at same moment clearing our imagelist
+      SetLength(AIndexes, ACount);
+      for j := High(AIndexes) downto 0 do
+      begin
+        AIndexes[j] := j;
+        if ADeleted[j] then
+          TCustomImageList(FImages[i]).Delete(j);
+      end;
+      // we traversing our indexes map and set new values for old values
+      for j := 0 to High(AIndexes) do
+        if ADeleted[j] then
+        begin
+          for k := j + 1 to High(AIndexes) do
+            dec(AIndexes[k]);
+        end;
+      // all preparation done - we have old=>new map
+      // process all Items that needs to be updated
+      for j := 0 to AUpdates.Count - 1 do
+      begin
+        AListener := PImageCacheItem(AUpdates[j])^.FListener;
+        for k := 0 to High(PImageCacheItem(AUpdates[j])^.FImageIndexes) do
+        begin
+          // update cache item and notify listener
+          PImageCacheItem(AUpdates[j])^.FImageIndexes[k] := AIndexes[PImageCacheItem(AUpdates[j])^.FImageIndexes[k]];
+          AListener.CacheSetImageIndex(k, PImageCacheItem(AUpdates[j])^.FImageIndexes[k]);
+        end;
+      end;
+    end;
+    AUpdates.Free;
+    ADeleted.Free;
+    SetLength(AIndexes, 0);
+  end;
+
+  FObsoletedCount := 0;
+end;
+
+{ TImageCacheItems }
+
+function TImageCacheItems.GetItem(AIndex: Integer): PImageCacheItem;
+begin
+  Result := inherited Get(AIndex)
+end;
+
+procedure TImageCacheItems.SetItem(AIndex: Integer;
+  const AValue: PImageCacheItem);
+begin
+  inherited Put(AIndex, AValue);
+end;
+
+procedure TImageCacheItems.Notify(Ptr: Pointer; Action: TListNotification);
+begin
+  if (Action = lnDeleted) and (Ptr <> nil) then
+    Dispose(PImageCacheItem(Ptr));
+end;
+
+function TImageCacheItems.GetNew: PImageCacheItem;
+begin
+  New(Result);
+  Add(Result);
+end;
+
+function TImageCacheItems.GetItemForListener(AListener: IImageCacheListener): PImageCacheItem;
+var
+  i: integer;
+begin
+  Result := nil;
+  for i := 0 to Count - 1 do
+    if Items[i]^.FListener = AListener then
+    begin
+      Result := Items[i];
+      break;
+    end;
+end;
+
+end.
+

lcl/include/buttonglyph.inc

@@ -22,7 +22,6 @@ constructor TButtonGlyph.Create;
 begin
   FOriginal := TBitmap.Create;
   FOriginal.OnChange := @GlyphChanged;
-  FImages := TCustomImageList.Create(nil);
 end;
 
 {------------------------------------------------------------------------------
@@ -30,38 +29,42 @@ end;
 ------------------------------------------------------------------------------}
 destructor TButtonGlyph.Destroy;
 begin
+  if FImagesCache <> nil then
+    FImagesCache.UnregisterListener(Self);
   FOriginal.Free;
   FOriginal := nil;
-  FImages.Free;
   inherited Destroy;
 end;
 
 procedure TButtonGlyph.GetImageIndexAndEffect(State: TButtonState;
   var AIndex: Integer; var AEffect: TGraphicsDrawEffect);
+var
+  AStoredState: TButtonState;
 begin
-  AIndex := 0;
+  AStoredState := bsUp;
   AEffect := gdeNormal;
   case State of
     bsDisabled:
      begin
        if NumGlyphs > 1 then
-         AIndex := 1
+         AStoredState := State
        else
          AEffect := gdeDisabled;
       end;
     bsDown:
       begin
         if NumGlyphs > 2 then
-          AIndex := 2
+          AStoredState := State
         else
           AEffect := gdeShadowed;
       end;
     bsExclusive:
       if NumGlyphs > 3 then
-        AIndex := 3
+        AStoredState := State
       else
         AEffect := gdeHighlighted;
   end;
+  AIndex := FImageIndexes[AStoredState];
 end;
 
 {------------------------------------------------------------------------------
@@ -94,12 +97,14 @@ end;
 
 procedure TButtonGlyph.GlyphChanged(Sender: TObject);
 begin
-  FImages.Clear;
+  if FImagesCache <> nil then
+    FImagesCache.UnregisterListener(Self);
+
   if (FOriginal.Width > 0) and (FOriginal.Height > 0) then
   begin
-    FImages.Width := FOriginal.Width div Max(1, FNumGlyphs);
+    FImagesCache := GetImageListCache;
-    FImages.Height := FOriginal.Height;
+    FImagesCache.RegisterListener(Self);
-    FImages.Add(FOriginal, nil);
+    FImagesCache.RegisterBitmap(Self, FOriginal, Max(1, NumGlyphs));
   end;
 
   if Sender = FOriginal then
@@ -121,7 +126,7 @@ var
   src_wh, dst_wh: Integer;
   AEffect: TGraphicsDrawEffect;
 begin
-  Result:=Client;
+  Result := Client;
   if (FOriginal = nil) then
     exit;
 
@@ -163,7 +168,7 @@ begin
   FImages.Draw(Canvas, DestRect.Left, DestRect.Top, ImgID, AEffect);
 
   // ToDo: VCL returns the text rectangle
-  Result:=SrcRect;
+  Result := SrcRect;
 end;
 
 
@@ -179,4 +184,33 @@ begin
   end;
 end;
 
+function TButtonGlyph.QueryInterface(const iid: tguid; out obj): longint; stdcall;
+begin
+  if GetInterface(iid, obj) then
+    Result := 0
+  else
+    Result := E_NOINTERFACE;
+end;
+
+function TButtonGlyph._AddRef: longint; stdcall;
+begin
+  Result := -1;
+end;
+
+function TButtonGlyph._Release: longint; stdcall;
+begin
+  Result := -1;
+end;
+
+procedure TButtonGlyph.CacheSetImageList(AImageList: TCustomImageList);
+begin
+  FImages := AImageList;
+end;
+
+procedure TButtonGlyph.CacheSetImageIndex(AIndex, AImageIndex: Integer);
+begin
+  if (AIndex >= ord(Low(TButtonState))) and (AIndex <= Ord(High(TButtonState))) then
+    FImageIndexes[TButtonState(AIndex)] := AImageIndex;
+end;
+
 // included by buttons.pp