Changeset 19
- Timestamp:
- Dec 20, 2016, 6:02:51 PM (8 years ago)
- Files:
-
- 1 added
- 7 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/gbitmap
- Property svn:ignore
-
old new 3 3 project1.lps 4 4 project1.res 5 project1.exe
-
- Property svn:ignore
-
branches/gbitmap/GImage.pas
r18 r19 6 6 7 7 uses 8 Classes, SysUtils, G Pixmap;8 Classes, SysUtils, Graphics, GPixmap, UPixmapSpecialized; 9 9 10 10 type 11 TColorGray8 = Byte;12 13 { TRGB8 }14 15 TRGB8 = record16 R: Byte;17 B: Byte;18 G: Byte;19 function Create(R, G, B: Byte): TRGB8;20 end;21 22 23 11 TBColor = class 24 12 end; 25 13 26 14 TBColorGray1 = class(TBColor) 27 Value: TColorGray8; 15 Value: TColorGray1; 16 end; 17 18 TBColorGray2 = class(TBColor) 19 Value: TColorGray2; 28 20 end; 29 21 30 22 TBColorRGB8 = class(TBColor) 31 Value: T RGB8;23 Value: TColorRGB8; 32 24 end; 33 25 … … 35 27 36 28 TBImage = class 37 procedure Fill(Color: TBColor); virtual; 29 public 30 type 31 TGetColorPos = function (Position: TPoint): TBColor of object; 32 private 33 FSize: TPoint; 34 protected 35 procedure SetSize(AValue: TPoint); virtual; 36 public 37 procedure Fill(Color: TBColor); virtual; overload; 38 procedure Fill(Func: TGetColorPos); virtual; overload; 39 procedure PaintToCanvas(Canvas: TCanvas); virtual; 40 property Size: TPoint read FSize write SetSize; 38 41 end; 39 42 … … 41 44 42 45 TBImageGray1 = class(TBImage) 43 Pixmap: TGPixmap<TColorGray8>; 46 protected 47 procedure SetSize(AValue: TPoint); override; 48 public 49 Pixmap: TPixmapGray1; 44 50 procedure Fill(Color: TBColor); override; 51 procedure Fill(Func: TGetColorPos); override; 52 procedure PaintToCanvas(Canvas: TCanvas); override; 53 constructor Create; 54 destructor Destroy; override; 55 end; 56 57 { TBImageGray2 } 58 59 TBImageGray2 = class(TBImage) 60 protected 61 procedure SetSize(AValue: TPoint); override; 62 public 63 Pixmap: TPixmapGray2; 64 procedure Fill(Color: TBColor); override; 65 procedure PaintToCanvas(Canvas: TCanvas); override; 66 constructor Create; 67 destructor Destroy; override; 45 68 end; 46 69 … … 48 71 49 72 TBImageRGB8 = class(TBImage) 50 Pixmap: TGPixmap<TRGB8>; 73 protected 74 procedure SetSize(AValue: TPoint); override; 75 public 76 Pixmap: TGPixmap<TColorRGB8>; 51 77 procedure Fill(Color: TBColor); override; 52 end; 53 54 55 TColorFormat = (cfNone, cfGray1, cfRGB8); 56 57 { TImage } 58 59 TImage = class 78 constructor Create; 79 destructor Destroy; override; 80 end; 81 82 83 TColorFormat = (cfNone, cfGray1, cfGray2, cfGray4, cfGray8, cfGray16, cfGray32, 84 cfRGB8, cfRGB16); 85 86 { TGImage } 87 88 TGImage = class 89 public 90 type 91 TGetColorPos = function (Position: TPoint): TBColor of object; 60 92 private 61 93 FBackend: TBImage; 62 94 FColorFormat: TColorFormat; 95 FSize: TPoint; 63 96 procedure SetColorFormat(AValue: TColorFormat); 97 procedure SetSize(AValue: TPoint); 64 98 public 65 99 property Backend: TBImage read FBackend; 66 100 property ColorFormat: TColorFormat read FColorFormat write SetColorFormat; 67 procedure Fill(Color: TBColor); 68 constructor Create; 69 destructor Destroy; override; 70 end; 101 property Size: TPoint read FSize write SetSize; 102 procedure Fill(Color: TBColor); overload; 103 procedure Fill(Func: TGetColorPos); overload; 104 procedure PaintToCanvas(Canvas: TCanvas); 105 constructor Create; 106 destructor Destroy; override; 107 end; 108 71 109 72 110 implementation 73 111 74 { TRGB8 } 75 76 function TRGB8.Create(R, G, B: Byte): TRGB8; 77 begin 78 Result.R := R; 79 Result.G := G; 80 Result.B := B; 81 end; 112 { TBImageGray2 } 113 114 procedure TBImageGray2.SetSize(AValue: TPoint); 115 begin 116 inherited; 117 Pixmap.Size := AValue; 118 end; 119 120 procedure TBImageGray2.Fill(Color: TBColor); 121 begin 122 if Color is TBColorGray2 then 123 Pixmap.Fill((Color as TBColorGray2).Value); 124 end; 125 126 procedure TBImageGray2.PaintToCanvas(Canvas: TCanvas); 127 begin 128 Pixmap.PaintToCanvas(Canvas, Pixmap.Gray2ToColor); 129 end; 130 131 constructor TBImageGray2.Create; 132 begin 133 Pixmap := TPixmapGray2.Create; 134 end; 135 136 destructor TBImageGray2.Destroy; 137 begin 138 Pixmap.Free; 139 inherited Destroy; 140 end; 141 82 142 83 143 { TBImageRGB8 } 144 145 procedure TBImageRGB8.SetSize(AValue: TPoint); 146 begin 147 inherited; 148 Pixmap.Size := AValue; 149 end; 84 150 85 151 procedure TBImageRGB8.Fill(Color: TBColor); … … 89 155 end; 90 156 157 constructor TBImageRGB8.Create; 158 begin 159 Pixmap := TGPixmap<TColorRGB8>.Create; 160 end; 161 162 destructor TBImageRGB8.Destroy; 163 begin 164 Pixmap.Free; 165 inherited Destroy; 166 end; 167 91 168 { TBImage } 92 169 170 procedure TBImage.SetSize(AValue: TPoint); 171 begin 172 if (FSize.X = AValue.X) and (FSize.Y = AValue.Y) then Exit; 173 FSize := AValue; 174 end; 175 93 176 procedure TBImage.Fill(Color: TBColor); 94 177 begin 95 178 end; 96 179 180 procedure TBImage.Fill(Func: TGetColorPos); 181 begin 182 end; 183 184 procedure TBImage.PaintToCanvas(Canvas: TCanvas); 185 begin 186 end; 187 97 188 { TBImageGray1 } 189 190 procedure TBImageGray1.SetSize(AValue: TPoint); 191 begin 192 inherited; 193 Pixmap.Size := AValue; 194 end; 98 195 99 196 procedure TBImageGray1.Fill(Color: TBColor); … … 103 200 end; 104 201 105 { TImage } 106 107 procedure TImage.SetColorFormat(AValue: TColorFormat); 202 procedure TBImageGray1.Fill(Func: TGetColorPos); 203 begin 204 //Pixmap.Fill(); 205 end; 206 207 procedure TBImageGray1.PaintToCanvas(Canvas: TCanvas); 208 begin 209 Pixmap.PaintToCanvas(Canvas, Pixmap.Gray1ToColor); 210 end; 211 212 constructor TBImageGray1.Create; 213 begin 214 Pixmap := TPixmapGray1.Create; 215 end; 216 217 destructor TBImageGray1.Destroy; 218 begin 219 Pixmap.Free; 220 inherited Destroy; 221 end; 222 223 { TGImage } 224 225 procedure TGImage.SetColorFormat(AValue: TColorFormat); 108 226 begin 109 227 if FColorFormat = AValue then Exit; 110 228 FBackend.Free; 111 if FColorFormat = cfGray1 then 112 FBackend := TBImageGray1.Create; 113 if FColorFormat = cfRGB8 then 114 FBackend := TBImageRGB8.Create; 229 if AValue = cfGray1 then FBackend := TBImageGray1.Create 230 else if AValue = cfGray2 then FBackend := TBImageGray2.Create 231 else if AValue = cfRGB8 then FBackend := TBImageRGB8.Create 232 else FBackend := nil; 233 if Assigned(FBackend) then FBackend.Size := FSize; 115 234 FColorFormat := AValue; 116 235 end; 117 236 118 procedure TImage.Fill(Color: TBColor); 119 begin 120 if Assigned(Backend) then 121 Backend.Fill(Color); 122 end; 123 124 constructor TImage.Create; 237 procedure TGImage.SetSize(AValue: TPoint); 238 begin 239 if (FSize.X = AValue.X) and (FSize.Y = AValue.Y) then Exit; 240 FSize := AValue; 241 if Assigned(FBackend) then 242 FBackend.Size := AValue; 243 end; 244 245 procedure TGImage.Fill(Color: TBColor); 246 begin 247 if Assigned(FBackend) then FBackend.Fill(Color); 248 end; 249 250 procedure TGImage.Fill(Func: TGetColorPos); 251 begin 252 // if Assigned(FBackend) then FBackend.Fill(Func: TGetColorPos); 253 end; 254 255 procedure TGImage.PaintToCanvas(Canvas: TCanvas); 256 begin 257 if Assigned(FBackend) then FBackend.PaintToCanvas(Canvas); 258 end; 259 260 constructor TGImage.Create; 125 261 begin 126 262 FBackend := nil; 127 263 end; 128 264 129 destructor T Image.Destroy;265 destructor TGImage.Destroy; 130 266 begin 131 267 if Assigned(FBackend) then FreeAndNil(FBackend); -
branches/gbitmap/UFormMain.lfm
r18 r19 8 8 ClientWidth = 685 9 9 OnShow = FormShow 10 LCLVersion = '1.6. 0.4'10 LCLVersion = '1.6.2.0' 11 11 object Image1: TImage 12 12 Left = 208 … … 20 20 Height = 314 21 21 Hint = 'Gray 8-bit'#13#10'Gray 32-bit'#13#10'RGB 8-bit' 22 Top = 3 822 Top = 30 23 23 Width = 165 24 24 Items.Strings = ( … … 32 32 'RGB 16-bit' 33 33 'Gray variable-bit' 34 'Image Gray 1-bit' 34 35 ) 35 ItemHeight = 3036 ItemHeight = 20 36 37 OnSelectionChange = ListBox1SelectionChange 37 38 ScrollWidth = 163 … … 40 41 object Label1: TLabel 41 42 Left = 18 42 Height = 2 443 Height = 20 43 44 Top = 459 44 Width = 5545 Width = 44 45 46 Caption = 'Label1' 46 47 ParentColor = False -
branches/gbitmap/UFormMain.pas
r18 r19 7 7 uses 8 8 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Menus, 9 ExtCtrls, StdCtrls, GPixmap ;9 ExtCtrls, StdCtrls, GPixmap, UPixmapSpecialized, GImage; 10 10 11 11 type 12 TRGB8 = record13 R: Byte;14 B: Byte;15 G: Byte;16 function Create(R, G, B: Byte): TRGB8;17 end;18 19 { TRGB16 }20 21 TRGB16 = record22 R: Word;23 B: Word;24 G: Word;25 function Create(R, G, B: Word): TRGB16;26 end;27 28 { TGrayVar }29 30 TGrayVar = PByte;31 12 32 13 { TForm1 } … … 39 20 procedure ListBox1SelectionChange(Sender: TObject; User: boolean); 40 21 private 41 function Gray8ToColor(Value: Byte): TColor; 42 function Gray32ToColor(Value: Cardinal): TColor; 43 function Gray16Random(Position: TPoint): Word; 44 function Gray16ToColor(Value: Word): TColor; 45 function Gray32Random(Position: TPoint): Cardinal; 46 function Gray4Random(Position: TPoint): Byte; 47 function Gray1Random(Position: TPoint): Byte; 48 function Gray2Random(Position: TPoint): Byte; 49 function Gray8Random(Position: TPoint): Byte; 50 function RGB16Random(Position: TPoint): TRGB16; 51 function RGB16ToColor(Value: TRGB16): TColor; 52 function RGB8Random(Position: TPoint): TRGB8; 53 function RGB8ToColor(Value: TRGB8): TColor; 54 function Gray1ToColor(Value: Byte): TColor; 55 function Gray2ToColor(Value: Byte): TColor; 56 function Gray4ToColor(Value: Byte): TColor; 57 function GrayVarToColor(Value: TGrayVar): TColor; 58 function GrayVarCreate(Value: QWord): TGrayVar; 59 procedure TestGray16; 22 function Gray1Random(Position: TPoint): TColorGray1; 23 function Gray2Random(Position: TPoint): TColorGray2; 24 function Gray4Random(Position: TPoint): TColorGray4; 25 function Gray8Random(Position: TPoint): TColorGray8; 26 function Gray16Random(Position: TPoint): TColorGray16; 27 function Gray32Random(Position: TPoint): TColorGray32; 28 function RGB8Random(Position: TPoint): TColorRGB8; 29 function RGB16Random(Position: TPoint): TColorRGB16; 30 public 31 procedure TestGray1; 60 32 procedure TestGray2; 61 33 procedure TestGray4; 62 public63 procedure TestGray1;64 34 procedure TestGray8; 35 procedure TestGray16; 65 36 procedure TestGray32; 66 37 procedure TestRGB8; 67 38 procedure TestRGB16; 68 39 procedure TestGrayVar; 40 procedure TestImage; 69 41 end; 70 42 … … 72 44 Form1: TForm1; 73 45 46 74 47 implementation 75 48 76 49 {$R *.lfm} 77 50 78 { TRGB16 }79 80 function TRGB16.Create(R, G, B: Word): TRGB16;81 begin82 Result.R := R;83 Result.G := G;84 Result.B := B;85 end;86 87 { TRGB8 }88 89 function TRGB8.Create(R, G, B: Byte): TRGB8;90 begin91 Result.R := R;92 Result.G := G;93 Result.B := B;94 end;95 96 51 { TForm1 } 97 52 98 function TForm1.Gray1ToColor(Value: Byte): TColor; 99 begin 100 Value := (Value and $1) * $ff; 101 Result := (Value shl 16) or (Value shl 8) or (Value shl 0); 102 end; 103 104 function TForm1.Gray2ToColor(Value: Byte): TColor; 105 begin 106 Value := (Value and $3) * (255 div (4 - 1)); 107 Result := (Value shl 16) or (Value shl 8) or (Value shl 0); 108 end; 109 110 function TForm1.Gray4ToColor(Value: Byte): TColor; 111 begin 112 Value := (Value and $f) * (255 div (16 - 1)); 113 Result := (Value shl 16) or (Value shl 8) or (Value shl 0); 114 end; 115 116 function TForm1.Gray8ToColor(Value: Byte): TColor; 117 begin 118 Result := (Value shl 16) or (Value shl 8) or (Value shl 0); 119 end; 120 121 function TForm1.Gray16ToColor(Value: Word): TColor; 122 begin 123 Value := (Value shr 8) and $ff; 124 Result := (Value shl 16) or (Value shl 8) or (Value shl 0); 125 end; 126 127 function TForm1.Gray32ToColor(Value: Cardinal): TColor; 128 begin 129 Value := (Value shr 24) and $ff; 130 Result := (Value shl 16) or (Value shl 8) or (Value shl 0); 131 end; 132 133 function TForm1.RGB8ToColor(Value: TRGB8): TColor; 134 begin 135 Result := (Value.R shl 16) or (Value.G shl 8) or (Value.B shl 0); 136 end; 137 138 function TForm1.RGB16ToColor(Value: TRGB16): TColor; 139 begin 140 Result := ((Value.R shr 8) shl 16) or ((Value.G shr 8) shl 8) or 141 ((Value.B shr 8) shl 0); 142 end; 143 144 function TForm1.GrayVarToColor(Value: TGrayVar): TColor; 145 var 146 ValuePart: Byte; 147 begin 148 if Assigned(Value) then begin 149 ValuePart := PByte(Value + MemSize(Value) - 1)^; 150 Result := (ValuePart shl 16) or (ValuePart shl 8) or (ValuePart shl 0); 151 end else Result := clBlack; 152 end; 153 154 function TForm1.GrayVarCreate(Value: QWord): TGrayVar; 155 begin 156 Result := GetMem(SizeOf(Value)); 157 Move(Value, Result^, SizeOf(Value)); 158 end; 159 160 function TForm1.Gray1Random(Position: TPoint): Byte; 53 54 function TForm1.Gray1Random(Position: TPoint): TColorGray1; 161 55 begin 162 56 Result := Random(2); 163 57 end; 164 58 165 function TForm1.Gray2Random(Position: TPoint): Byte;59 function TForm1.Gray2Random(Position: TPoint): TColorGray2; 166 60 begin 167 61 Result := Random(4); 168 62 end; 169 63 170 function TForm1.Gray4Random(Position: TPoint): Byte;64 function TForm1.Gray4Random(Position: TPoint): TColorGray4; 171 65 begin 172 66 Result := Random($10); 173 67 end; 174 68 175 function TForm1.Gray8Random(Position: TPoint): Byte;69 function TForm1.Gray8Random(Position: TPoint): TColorGray8; 176 70 begin 177 71 Result := Random($100); 178 72 end; 179 73 180 function TForm1.Gray16Random(Position: TPoint): Word;74 function TForm1.Gray16Random(Position: TPoint): TColorGray16; 181 75 begin 182 76 Result := Random($10000); 183 77 end; 184 78 185 function TForm1.Gray32Random(Position: TPoint): Cardinal;79 function TForm1.Gray32Random(Position: TPoint): TColorGray32; 186 80 begin 187 81 Result := Random($ffffffff); 188 82 end; 189 83 190 function TForm1.RGB8Random(Position: TPoint): T RGB8;84 function TForm1.RGB8Random(Position: TPoint): TColorRGB8; 191 85 begin 192 86 Result.R := Random($100); … … 195 89 end; 196 90 197 function TForm1.RGB16Random(Position: TPoint): T RGB16;91 function TForm1.RGB16Random(Position: TPoint): TColorRGB16; 198 92 begin 199 93 Result.R := Random($10000); … … 204 98 procedure TForm1.TestGray1; 205 99 var 206 Bitmap: T GPixmapBit<Byte>;207 begin 208 Bitmap := T GPixmapBit<Byte>.Create;100 Bitmap: TPixmapGray1; 101 begin 102 Bitmap := TPixmapGray1.Create; 209 103 with Bitmap do begin 210 104 BitsPerPixel := 1; … … 223 117 procedure TForm1.TestGray2; 224 118 var 225 Bitmap: T GPixmapBit<Byte>;226 begin 227 Bitmap := T GPixmapBit<Byte>.Create;119 Bitmap: TPixmapGray2; 120 begin 121 Bitmap := TPixmapGray2.Create; 228 122 with Bitmap do begin 229 123 BitsPerPixel := 2; … … 242 136 procedure TForm1.TestGray4; 243 137 var 244 Bitmap: T GPixmapBit<Byte>;245 begin 246 Bitmap := T GPixmapBit<Byte>.Create;138 Bitmap: TPixmapGray4; 139 begin 140 Bitmap := TPixmapGray4.Create; 247 141 with Bitmap do begin 248 142 BitsPerPixel := 4; … … 261 155 procedure TForm1.TestGray8; 262 156 var 263 Bitmap: T GPixmap<Byte>;264 begin 265 Bitmap := T GPixmap<Byte>.Create;157 Bitmap: TPixmapGray8; 158 begin 159 Bitmap := TPixmapGray8.Create; 266 160 with Bitmap do begin 267 161 Size := Point(100, 100); … … 279 173 procedure TForm1.TestGray16; 280 174 var 281 Bitmap: T GPixmap<Word>;282 begin 283 Bitmap := T GPixmap<Word>.Create;175 Bitmap: TPixmapGray16; 176 begin 177 Bitmap := TPixmapGray16.Create; 284 178 with Bitmap do begin 285 179 Size := Point(100, 100); … … 297 191 procedure TForm1.TestGray32; 298 192 var 299 Bitmap: T GPixmap<Cardinal>;300 begin 301 Bitmap := T GPixmap<Cardinal>.Create;193 Bitmap: TPixmapGray32; 194 begin 195 Bitmap := TPixmapGray32.Create; 302 196 with Bitmap do begin 303 197 Size := Point(100, 100); … … 315 209 procedure TForm1.TestRGB8; 316 210 var 317 Bitmap: T GPixmap<TRGB8>;318 begin 319 Bitmap := T GPixmap<TRGB8>.Create;320 with Bitmap do begin 321 Size := Point(100, 100); 322 Fill(T RGB8.Create(255, 0, 0));211 Bitmap: TPixmapRGB8; 212 begin 213 Bitmap := TPixmapRGB8.Create; 214 with Bitmap do begin 215 Size := Point(100, 100); 216 Fill(TColorRGB8.Create(255, 0, 0)); 323 217 Fill(RGB8Random); 324 Pixels[0, 0] := T RGB8.Create(1, 1, 1);218 Pixels[0, 0] := TColorRGB8.Create(1, 1, 1); 325 219 Canvas.Pen.LineTo(Point(60, 40)); 326 220 Image1.Picture.Bitmap.SetSize(Size.X, Size.Y); … … 333 227 procedure TForm1.TestRGB16; 334 228 var 335 Bitmap: T GPixmap<TRGB16>;336 begin 337 Bitmap := T GPixmap<TRGB16>.Create;338 with Bitmap do begin 339 Size := Point(100, 100); 340 Fill(T RGB16.Create($ffff, 0, 0));229 Bitmap: TPixmapRGB16; 230 begin 231 Bitmap := TPixmapRGB16.Create; 232 with Bitmap do begin 233 Size := Point(100, 100); 234 Fill(TColorRGB16.Create($ffff, 0, 0)); 341 235 Fill(RGB16Random); 342 Pixels[0, 0] := T RGB16.Create(1, 1, 1);236 Pixels[0, 0] := TColorRGB16.Create(1, 1, 1); 343 237 Canvas.Pen.LineTo(Point(60, 40)); 344 238 Image1.Picture.Bitmap.SetSize(Size.X, Size.Y); … … 351 245 procedure TForm1.TestGrayVar; 352 246 var 353 Bitmap: T GPixmap<TGrayVar>;354 begin 355 Bitmap := T GPixmap<TGrayVar>.Create;247 Bitmap: TPixmapGrayVar; 248 begin 249 Bitmap := TPixmapGrayVar.Create; 356 250 with Bitmap do begin 357 251 Size := Point(100, 100); … … 362 256 PaintToCanvas(Image1.Picture.Bitmap.Canvas, GrayVarToColor); 363 257 Label1.Caption := IntToStr(GetDataSize); 258 Free; 259 end; 260 end; 261 262 procedure TForm1.TestImage; 263 var 264 Image: TGImage; 265 Color: TBColorGray1; 266 begin 267 Image := TGImage.Create; 268 with Image do begin 269 Size := Point(100, 100); 270 ColorFormat := cfGray1; 271 Color := TBColorGray1.Create; 272 Color.Value := 1; 273 Fill(Color); 274 Random; 275 PaintToCanvas(Image1.Picture.Bitmap.Canvas); 364 276 Free; 365 277 end; … … 384 296 7: TestRGB16; 385 297 8: TestGrayVar; 298 9: TestImage; 386 299 end; 387 300 end; -
branches/gbitmap/project1.lpi
r18 r19 34 34 </Item1> 35 35 </RequiredPackages> 36 <Units Count=" 4">36 <Units Count="5"> 37 37 <Unit0> 38 38 <Filename Value="project1.lpr"/> … … 54 54 <IsPartOfProject Value="True"/> 55 55 </Unit3> 56 <Unit4> 57 <Filename Value="UPixmapSpecialized.pas"/> 58 <IsPartOfProject Value="True"/> 59 </Unit4> 56 60 </Units> 57 61 </ProjectOptions> -
branches/gbitmap/project1.lpr
r18 r19 8 8 {$ENDIF}{$ENDIF} 9 9 Interfaces, // this includes the LCL widgetset 10 Forms, UFormMain, GPixmap, GImage 10 Forms, UFormMain, GPixmap, GImage, UPixmapSpecialized 11 11 { you can add units after this }; 12 12
Note:
See TracChangeset
for help on using the changeset viewer.