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