1{%MainUnit ../graphics.pp}
2{******************************************************************************
3                          TPatternBitmapCache
4 ******************************************************************************
5
6 *****************************************************************************
7  This file is part of the Lazarus Component Library (LCL)
8
9  See the file COPYING.modifiedLGPL.txt, included in this distribution,
10  for details about the license.
11 *****************************************************************************
12}
13
14{
15  Delphi does not expose any of the internal structures that deal
16  with the management or byproducts of calls to AllocPatternBitmap,
17  especially the caching mechanisme and the cache are not exposed.
18  So all class definitions for this are in the implementation section.
19}
20
21
22type
23  { TPatternBitmap }
24
25  TPatternBitmap = class
26  private
27    FBitmap: TBitmap;
28  public
29    ColorBG: TColor;
30    ColorFG: TColor;
31    constructor Create(AColorBG, AColorFG: TColor);
32    destructor Destroy; override;
33    function GetBitmap: TBitmap;
34  end;
35
36  { TPatternBitmapCache }
37
38  TPatternBitmapCache = class
39  private
40    FLock: TCriticalSection;
41    FList: TAvlTree;
42    function InternalCompare(Tree: TAvlTree; Data1, Data2: Pointer): integer;
43  protected
44    procedure Lock;
45    procedure UnLock;
46  public
47    constructor Create;
48    destructor Destroy; override;
49    function Add(ABitmap: TPatternBitmap): TPatternBitmap;
50    function FindBitmap(AColorBG, AColorFG: TColor): TPatternBitmap;
51    function Count: Integer;
52  end;
53
54var
55  PatternBitmapCache: TPatternBitmapCache;
56
57type
58  TPatternRec = record
59    ColorBG, ColorFG: TColor;
60  end;
61  PPatternRec = ^TPatternRec;
62
63function CompareColors(C1, C2: TColor): Integer;
64begin
65  if (C1 = C2) then
66    Result := 0
67  else
68    if (C1 < C2) then
69      Result := -1
70    else Result := +1;
71end;
72
73function AllocPatternBitmap(colorBG, colorFG: TColor): TBitmap;
74var
75  x,y: Integer;
76  PatternBmp: TPatternBitmap;
77begin
78  Result := nil;
79  if not Assigned(PatternBitmapCache) then
80    Exit;
81  PatternBmp := PatternBitmapCache.FindBitmap(colorBG, colorFG);
82  if not Assigned(PatternBmp) then
83  begin
84    {$ifdef debugpatternbitmap}
85    debugln('AllocPatternBitmap: FindBitmap = nil');
86    {$endif}
87    PatternBmp := TPatternBitmap.Create(colorBG, colorFG);
88    PatternBitmapCache.Add(PatternBmp);
89  end;
90  {$ifdef debugpatternbitmap}
91  debugln(['AllocPatternBitmap: FindBitmap = ',Pointer(PatternBmp)]);
92  {$endif}
93  Result := PatternBmp.GetBitmap;
94end;
95
96constructor TPatternBitmap.Create(AColorBG, AColorFG: TColor);
97var
98  x, y: Integer;
99begin
100  ColorBG := AColorBG and $00FFFFFF; //don't use systemcolors
101  ColorFG := AColorFG and $00FFFFFF;
102  FBitmap := TBitmap.Create;
103  FBitmap.Width := 8;
104  FBitmap.Height := 8;
105  FBitmap.Canvas.Brush.Style := bsSolid;
106  FBitmap.Canvas.Brush.Color := colorBG;
107  FBitmap.Canvas.Rectangle(0,0,7,7);
108  for x := 0 to 7 do for y := 0 to 7 do
109  begin
110    if ((not Odd(x)) and (not Odd(y))) xor ((Odd(x)) and (Odd(y))) then
111      FBitmap.Canvas.Pixels[x,y] := colorFG;
112  end;
113end;
114
115destructor TPatternBitmap.Destroy;
116begin
117  {$ifdef debugpatternbitmap}
118  debugln(['TPatternBitmap.Destroy: Freeing FBitmap: ',Pointer(FBitmap)]);
119  {$endif}
120  FBitmap.Clear;
121  FBitmap.Free;
122  inherited Destroy;
123end;
124
125function TPatternBitmap.GetBitmap: TBitmap;
126begin
127  Result := FBitmap;
128end;
129
130{ TPatternBitmapCache }
131
132
133function TPatternBitmapCache.InternalCompare(Tree: TAvlTree; Data1, Data2: Pointer): integer;
134var
135  Bmp1: TPatternBitmap absolute Data1;
136  Bmp2: TPatternBitmap absolute Data2;
137begin
138  Result := CompareColors(Bmp1.ColorBG, Bmp2.ColorBG);
139  if (Result = 0) then
140    Result := CompareColors(Bmp1.ColorFG, Bmp2.ColorFG);
141  {$ifdef debugpatternbitmap}
142  debugln(['TPatternBitmapCache.InternalCompare: Result = ',Result]);
143  {$endif}
144end;
145
146procedure TPatternBitmapCache.Lock;
147begin
148  FLock.Enter;
149end;
150
151procedure TPatternBitmapCache.UnLock;
152begin
153  FLock.Leave;
154end;
155
156constructor TPatternBitmapCache.Create;
157begin
158  {$ifdef debugpatternbitmap}
159  debugln(['TPatternBitmapCache.Create']);
160  {$endif}
161  FLock := TCriticalSection.Create;
162  FList := TAvlTree.CreateObjectCompare(@InternalCompare);
163end;
164
165destructor TPatternBitmapCache.Destroy;
166begin
167  {$ifdef debugpatternbitmap}
168    debugln(['TPatternBitmapCache.Destroy: Assigned(WidgetSet) = ',Assigned(WidgetSet),
169           ', FList.Count = ',FList.Count]);
170  {$endif}
171  FList.FreeAndClear;
172  FList.Free;
173  FLock.Free;
174  inherited Destroy;
175end;
176
177function TPatternBitmapCache.Add(ABitmap: TPatternBitmap): TPatternBitmap;
178begin
179  Lock;
180  try
181    if (FindBitmap(ABitmap.ColorBG, ABitmap.ColorFG) <> nil) then
182      RaiseGDBException(ClassName+'.Add: ABitmap added twice');
183    {$ifdef debugpatternbitmap}
184    debugln('TPatternBitmapCache.Add: FindBitmap = nil');
185    {$endif}
186    Result := TPatternBitmap((FList.Add(ABitmap)).Data);
187    {$ifdef debugpatternbitmap}
188    debugln(['  Result = ',Pointer(Result)]);
189    {$endif}
190    if (FList.Count mod 1000 = 0) then debugln([Self.ClassName,'.Add: Added ',FList.Count,' items.']);
191    if (FindBitmap(ABitmap.ColorBG, ABitmap.ColorFG) = nil) then
192    begin
193      {$IFNDEF DisableChecks}
194      DebugLn(['TPatternBitmapCache fatal error: cannot retrieve added bitmap: ', Pointer(Result)]);
195      {$ENDIF}
196      RaiseGDBException(ClassName+' fatal error: cannot retrieve added bitmap');
197    end;
198  finally
199    UnLock;
200  end;
201end;
202
203function InternalCompareKeyWithData(Key, Data: Pointer): Integer;
204var
205  PatternRec: PPatternRec absolute Key;
206  Bmp: TPatternBitmap absolute Data;
207begin
208  Result := CompareColors(PatternRec^.ColorBG, Bmp.ColorBG);
209  if (Result = 0) then
210  begin
211    Result := CompareColors(PatternRec^.ColorFG, Bmp.ColorFG);
212  end;
213end;
214
215function TPatternBitmapCache.FindBitmap(AColorBG, AColorFG: TColor): TPatternBitmap;
216var
217  PatternRec: TPatternRec;
218  Res: TAvlTreeNode;
219begin
220  Lock;
221  Result := nil;
222  AColorBG := AColorBG and $00FFFFFF; //do not use systemcolors
223  AColorFG := AColorFG and $00FFFFFF; //do not use systemcolors
224  PatternRec.ColorBG := AColorBG;
225  PatternRec.ColorFG := AColorFG;
226  Res := FList.FindKey(@PatternRec, @InternalCompareKeyWithData);
227  if (Res <> nil) then
228    Result := TPatternBitmap(Res.Data);
229  UnLock;
230end;
231
232function TPatternBitmapCache.Count: Integer;
233begin
234  Result := FList.Count;
235end;
236
237