LCL: start implementing AllocPatternBitmap function (Delphi compatibility). Resolves Issue #0010587.

git-svn-id: trunk@53926 -

.gitattributes

@@ -7218,6 +7218,7 @@ lcl/include/notebook.inc svneol=native#text/pascal
 lcl/include/page.inc svneol=native#text/pascal
 lcl/include/pagecontrol.inc svneol=native#text/pascal
 lcl/include/paintbox.inc svneol=native#text/pascal
+lcl/include/patternbitmap.inc svneol=native#text/plain
 lcl/include/pen.inc svneol=native#text/pascal
 lcl/include/picture.inc svneol=native#text/pascal
 lcl/include/pixmap.inc svneol=native#text/pascal

lcl/graphics.pp

@@ -2032,6 +2032,8 @@ function CreateBitmapFromLazarusResource(AHandle: TLResource; AMinimumClass: TCu
 function CreateCompatibleBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean = False): Boolean;
 
 function CreateBitmapFromFPImage(Img: TFPCustomImage): TBitmap;
+function AllocPatternBitmap(colorBG, colorFG: TColor): TBitmap;
+
 
 var
   { Stores information about the current screen
@@ -2767,6 +2769,7 @@ end;
 {$I bitmap.inc}
 {$I tiffimage.inc}
 {$I gifimage.inc}
+{$I patternbitmap.inc}
 
 function CreateGraphicFromResourceName(Instance: THandle; const ResName: String): TGraphic;
 var
@@ -2836,11 +2839,13 @@ begin
   FontResourceCache:=TFontHandleCache.Create;
   PenResourceCache:=TPenHandleCache.Create;
   BrushResourceCache:=TBrushHandleCache.Create;
+  PatternBitmapCache := TPatternBitmapCache.Create;
 end;
 
 procedure InterfaceFinal;
 begin
   //debugln('Graphics.InterfaceFinal');
+  FreeAndNil(PatternBitmapCache);
   FreeAndNil(FontResourceCache);
   FreeAndNil(PenResourceCache);
   FreeAndNil(BrushResourceCache);

lcl/include/patternbitmap.inc

@@ -0,0 +1,237 @@
+{%MainUnit ../graphics.pp}
+{******************************************************************************
+                          TPatternBitmapCache
+ ******************************************************************************
+
+ *****************************************************************************
+  This file is part of the Lazarus Component Library (LCL)
+
+  See the file COPYING.modifiedLGPL.txt, included in this distribution,
+  for details about the license.
+ *****************************************************************************
+}
+
+{
+  Delphi does not expose any of the internal structures that deal
+  with the management or byproducts of calls to AllocPatternBitmap,
+  especially the caching mechanisme and the cache are not exposed.
+  So all class definitions for this are in the implementation section.
+}
+
+
+type
+  { TPatternBitmap }
+
+  TPatternBitmap = class
+  private
+    FBitmap: TBitmap;
+  public
+    ColorBG: TColor;
+    ColorFG: TColor;
+    constructor Create(AColorBG, AColorFG: TColor);
+    destructor Destroy; override;
+    function GetBitmap: TBitmap;
+  end;
+
+  { TPatternBitmapCache }
+
+  TPatternBitmapCache = class
+  private
+    FLock: TCriticalSection;
+    FList: TAvgLvlTree;
+    function InternalCompare(Tree: TAvgLvlTree; Data1, Data2: Pointer): integer;
+  protected
+    procedure Lock;
+    procedure UnLock;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    function Add(ABitmap: TPatternBitmap): TPatternBitmap;
+    function FindBitmap(AColorBG, AColorFG: TColor): TPatternBitmap;
+    function Count: Integer;
+  end;
+
+var
+  PatternBitmapCache: TPatternBitmapCache;
+
+type
+  TPatternRec = record
+    ColorBG, ColorFG: TColor;
+  end;
+  PPatternRec = ^TPatternRec;
+
+function CompareColors(C1, C2: TColor): Integer;
+begin
+  if (C1 = C2) then
+    Result := 0
+  else
+    if (C1 < C2) then
+      Result := -1
+    else Result := +1;
+end;
+
+function AllocPatternBitmap(colorBG, colorFG: TColor): TBitmap;
+var
+  x,y: Integer;
+  PatternBmp: TPatternBitmap;
+begin
+  Result := nil;
+  if not Assigned(PatternBitmapCache) then
+    Exit;
+  PatternBmp := PatternBitmapCache.FindBitmap(colorBG, colorFG);
+  if not Assigned(PatternBmp) then
+  begin
+    {$ifdef debugpatternbitmap}
+    debugln('AllocPatternBitmap: FindBitmap = nil');
+    {$endif}
+    PatternBmp := TPatternBitmap.Create(colorBG, colorFG);
+    PatternBitmapCache.Add(PatternBmp);
+  end;
+  {$ifdef debugpatternbitmap}
+  debugln(['AllocPatternBitmap: FindBitmap = ',Pointer(PatternBmp)]);
+  {$endif}
+  Result := PatternBmp.GetBitmap;
+end;
+
+constructor TPatternBitmap.Create(AColorBG, AColorFG: TColor);
+var
+  x, y: Integer;
+begin
+  ColorBG := AColorBG and $00FFFFFF; //don't use systemcolors
+  ColorFG := AColorFG and $00FFFFFF;
+  FBitmap := TBitmap.Create;
+  FBitmap.Width := 8;
+  FBitmap.Height := 8;
+  FBitmap.Canvas.Brush.Style := bsSolid;
+  FBitmap.Canvas.Brush.Color := colorBG;
+  FBitmap.Canvas.Rectangle(0,0,7,7);
+  for x := 0 to 7 do for y := 0 to 7 do
+  begin
+    if ((not Odd(x)) and (not Odd(y))) xor ((Odd(x)) and (Odd(y))) then
+      FBitmap.Canvas.Pixels[x,y] := colorFG;
+  end;
+end;
+
+destructor TPatternBitmap.Destroy;
+begin
+  {$ifdef debugpatternbitmap}
+  debugln(['TPatternBitmap.Destroy: Freeing FBitmap: ',Pointer(FBitmap)]);
+  {$endif}
+  FBitmap.Clear;
+  FBitmap.Free;
+  inherited Destroy;
+end;
+
+function TPatternBitmap.GetBitmap: TBitmap;
+begin
+  Result := FBitmap;
+end;
+
+{ TPatternBitmapCache }
+
+
+function TPatternBitmapCache.InternalCompare(Tree: TAvgLvlTree; Data1,
+  Data2: Pointer): integer;
+var
+  Bmp1: TPatternBitmap absolute Data1;
+  Bmp2: TPatternBitmap absolute Data2;
+begin
+  Result := CompareColors(Bmp1.ColorBG, Bmp2.ColorBG);
+  if (Result = 0) then
+    Result := CompareColors(Bmp1.ColorFG, Bmp2.ColorFG);
+  {$ifdef debugpatternbitmap}
+  debugln(['TPatternBitmapCache.InternalCompare: Result = ',Result]);
+  {$endif}
+end;
+
+procedure TPatternBitmapCache.Lock;
+begin
+  FLock.Enter;
+end;
+
+procedure TPatternBitmapCache.UnLock;
+begin
+  FLock.Leave;
+end;
+
+constructor TPatternBitmapCache.Create;
+begin
+  {$ifdef debugpatternbitmap}
+  debugln(['TPatternBitmapCache.Create']);
+  {$endif}
+  FLock := TCriticalSection.Create;
+  FList := TAvgLvlTree.CreateObjectCompare(@InternalCompare);
+end;
+
+destructor TPatternBitmapCache.Destroy;
+begin
+  {$ifdef debugpatternbitmap}
+    debugln(['TPatternBitmapCache.Destroy: Assigned(WidgetSet) = ',Assigned(WidgetSet),
+           ', FList.Count = ',FList.Count]);
+  {$endif}
+  FList.FreeAndClear;
+  FList.Free;
+  FLock.Free;
+  inherited Destroy;
+end;
+
+function TPatternBitmapCache.Add(ABitmap: TPatternBitmap): TPatternBitmap;
+begin
+  Lock;
+  try
+    if (FindBitmap(ABitmap.ColorBG, ABitmap.ColorFG) <> nil) then
+      RaiseGDBException(ClassName+'.Add: ABitmap added twice');
+    {$ifdef debugpatternbitmap}
+    debugln('TPatternBitmapCache.Add: FindBitmap = nil');
+    {$endif}
+    Result := TPatternBitmap((FList.Add(ABitmap)).Data);
+    {$ifdef debugpatternbitmap}
+    debugln(['  Result = ',Pointer(Result)]);
+    {$endif}
+    if (FList.Count mod 1000 = 0) then debugln([Self.ClassName,'.Add: Added ',FList.Count,' items.']);
+    if (FindBitmap(ABitmap.ColorBG, ABitmap.ColorFG) = nil) then
+    begin
+      {$IFNDEF DisableChecks}
+      DebugLn(['TPatternBitmapCache fatal error: cannot retrieve added bitmap: ', Pointer(Result)]);
+      {$ENDIF}
+      RaiseGDBException(ClassName+' fatal error: cannot retrieve added bitmap');
+    end;
+  finally
+    UnLock;
+  end;
+end;
+
+function InternalCompareKeyWithData(Key, Data: Pointer): Integer;
+var
+  PatternRec: PPatternRec absolute Key;
+  Bmp: TPatternBitmap absolute Data;
+begin
+  Result := CompareColors(PatternRec^.ColorBG, Bmp.ColorBG);
+  if (Result = 0) then
+  begin
+    Result := CompareColors(PatternRec^.ColorFG, Bmp.ColorFG);
+  end;
+end;
+
+function TPatternBitmapCache.FindBitmap(AColorBG, AColorFG: TColor): TPatternBitmap;
+var
+  PatternRec: TPatternRec;
+  Res: TAvgLvlTreeNode;
+begin
+  Lock;
+  Result := nil;
+  AColorBG := AColorBG and $00FFFFFF; //do not use systemcolors
+  AColorFG := AColorFG and $00FFFFFF; //do not use systemcolors
+  PatternRec.ColorBG := AColorBG;
+  PatternRec.ColorFG := AColorFG;
+  Res := FList.FindKey(@PatternRec, @InternalCompareKeyWithData);
+  if (Res <> nil) then
+    Result := TPatternBitmap(Res.Data);
+  UnLock;
+end;
+
+function TPatternBitmapCache.Count: Integer;
+begin
+  Result := FList.Count;
+end;
+

lcl/lclbase.lpk

@@ -27,7 +27,7 @@
     <License Value="modified LGPL-2
 "/>
     <Version Major="1" Minor="7"/>
-    <Files Count="283">
+    <Files Count="284">
       <Item1>
         <Filename Value="checklst.pas"/>
         <UnitName Value="CheckLst"/>
@@ -1163,6 +1163,10 @@
         <Filename Value="industrialbase.pp"/>
         <UnitName Value="IndustrialBase"/>
       </Item283>
+      <Item284>
+        <Filename Value="include/patternbitmap.inc"/>
+        <Type Value="Include"/>
+      </Item284>
     </Files>
     <LazDoc Paths="../docs/xml/lcl"/>
     <i18n>