Changeset 20 for branches/gbitmap

Timestamp:

Dec 21, 2016, 3:49:27 PM (8 years ago)

Author:

chronos

Message:

• Modified: For single class layer TPixmap and TColor is used. They have TBPixmap and TBColor backends pairs.

Location:

branches/gbitmap

Files:

• GImage.pas (modified) (16 diffs)
• GPixmap.pas (modified) (5 diffs)
• UFormMain.pas (modified) (4 diffs)
• project1.lpi (modified) (4 diffs)
• project1.lpr (modified) (1 diff)

branches/gbitmap/GImage.pas

@@ -9 +9 @@
 
 type
-  TBColor = class
-  end;
-
-  TBColorGray1 = class(TBColor)
+  TColorFormat = (cfNone, cfGray1, cfGray2, cfGray4, cfGray8, cfGray16, cfGray32,
+    cfRGB8, cfRGB16);
+
+  TColorName = (cnBlack, cnWhite, cnBlue, cnRed, cnGreen, cnGray, cnSilver);
+
+  IBColor = interface
+    procedure SetColorName(ColorName: TColorName);
+    procedure SetRandom;
+  end;
+
+  { TBColorNone }
+
+  TBColorNone = class(TInterfacedObject, IBColor)
+    procedure SetColorName(ColorName: TColorName);
+    procedure SetRandom;
+  end;
+
+  { TBColorGray1 }
+
+  TBColorGray1 = class(TInterfacedObject, IBColor)
     Value: TColorGray1;
-  end;
-
-  TBColorGray2 = class(TBColor)
+    constructor Create(Color: TColorGray1);
+    procedure SetColorName(ColorName: TColorName);
+    procedure SetRandom;
+  end;
+
+  { TBColorGray2 }
+
+  TBColorGray2 = class(TInterfacedObject, IBColor)
     Value: TColorGray2;
-  end;
-
-  TBColorRGB8 = class(TBColor)
+    constructor Create(Color: TColorGray2);
+    procedure SetColorName(ColorName: TColorName);
+    procedure SetRandom;
+  end;
+
+  { TBColorRGB8 }
+
+  TBColorRGB8 = class(TInterfacedObject, IBColor)
     Value: TColorRGB8;
+    constructor Create(Color: TColorRGB8);
+    procedure SetColorName(ColorName: TColorName);
+    procedure SetRandom;
   end;
 
@@ -29 +58 @@
   public
     type
-      TGetColorPos = function (Position: TPoint): TBColor of object;
+      TGetColorPos = function (Position: TPoint): IBColor of object;
   private
     FSize: TPoint;
+    function GetPixel(X, Y: Integer): IBColor;  virtual;
+    procedure SetPixel(X, Y: Integer; AValue: IBColor); virtual;
   protected
     procedure SetSize(AValue: TPoint); virtual;
   public
-    procedure Fill(Color: TBColor); virtual; overload;
+    procedure Fill(Color: IBColor); virtual; overload;
     procedure Fill(Func: TGetColorPos); virtual; overload;
     procedure PaintToCanvas(Canvas: TCanvas); virtual;
+    function GetDataSize: Integer; virtual;
     property Size: TPoint read FSize write SetSize;
+    property Pixels[X, Y: Integer]: IBColor read GetPixel write SetPixel;
   end;
 
@@ -44 +77 @@
 
   TBImageGray1 = class(TBImage)
+  private
+    FillCallBack: TGetColorPos;
+    function FillGetColor(Position: TPoint): TColorGray1;
   protected
     procedure SetSize(AValue: TPoint); override;
+    function GetPixel(X, Y: Integer): IBColor;  override;
+    procedure SetPixel(X, Y: Integer; AValue: IBColor); override;
   public
     Pixmap: TPixmapGray1;
-    procedure Fill(Color: TBColor); override;
+    procedure Fill(Color: IBColor); override;
     procedure Fill(Func: TGetColorPos); override;
     procedure PaintToCanvas(Canvas: TCanvas); override;
+    function GetDataSize: Integer; override;
     constructor Create;
     destructor Destroy; override;
@@ -58 +97 @@
 
   TBImageGray2 = class(TBImage)
+  private
+    FillCallBack: TGetColorPos;
+    function FillGetColor(Position: TPoint): TColorGray1;
   protected
     procedure SetSize(AValue: TPoint); override;
+    function GetPixel(X, Y: Integer): IBColor;  override;
+    procedure SetPixel(X, Y: Integer; AValue: IBColor); override;
   public
     Pixmap: TPixmapGray2;
-    procedure Fill(Color: TBColor); override;
+    procedure Fill(Color: IBColor); override;
+    procedure Fill(Func: TGetColorPos); override;
     procedure PaintToCanvas(Canvas: TCanvas); override;
+    function GetDataSize: Integer; override;
     constructor Create;
     destructor Destroy; override;
@@ -75 +121 @@
   public
     Pixmap: TGPixmap<TColorRGB8>;
-    procedure Fill(Color: TBColor); override;
+    procedure Fill(Color: IBColor); override;
     constructor Create;
     destructor Destroy; override;
   end;
 
-
-  TColorFormat = (cfNone, cfGray1, cfGray2, cfGray4, cfGray8, cfGray16, cfGray32,
-    cfRGB8, cfRGB16);
-
-  { TGImage }
-
-  TGImage = class
+  { TColor }
+
+  TColor = class
+  private
+    FBackend: IBColor;
+    FColorFormat: TColorFormat;
+    procedure SetColorFormat(AValue: TColorFormat);
+  public
+    property Backend: IBColor read FBackend;
+    property ColorFormat: TColorFormat read FColorFormat write SetColorFormat;
+    procedure SetColorName(ColorName: TColorName);
+    procedure SetRandom;
+    constructor Create; overload;
+    constructor Create(ColorFormat: TColorFormat; ColorName: TColorName); overload;
+    destructor Destroy; override;
+  end;
+
+  { TPixmap }
+
+  TPixmap = class
   public
     type
-      TGetColorPos = function (Position: TPoint): TBColor of object;
+      TGetColorPos = function (Position: TPoint; ColorFormat: TColorFormat): TColor of object;
   private
     FBackend: TBImage;
     FColorFormat: TColorFormat;
     FSize: TPoint;
+    FillCallBack: TGetColorPos;
+    function FillGetColor(Position: TPoint): IBColor;
+    function GetPixel(X, Y: Integer): TColor;
     procedure SetColorFormat(AValue: TColorFormat);
+    procedure SetPixel(X, Y: Integer; AValue: TColor);
     procedure SetSize(AValue: TPoint);
   public
+    procedure Fill(Color: TColor); overload;
+    procedure Fill(Func: TGetColorPos); overload;
+    procedure PaintToCanvas(Canvas: TCanvas);
+    function GetDataSize: Integer;
+    constructor Create;
+    destructor Destroy; override;
     property Backend: TBImage read FBackend;
     property ColorFormat: TColorFormat read FColorFormat write SetColorFormat;
     property Size: TPoint read FSize write SetSize;
-    procedure Fill(Color: TBColor); overload;
-    procedure Fill(Func: TGetColorPos); overload;
-    procedure PaintToCanvas(Canvas: TCanvas);
-    constructor Create;
-    destructor Destroy; override;
+    property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
   end;
 
@@ -110 +175 @@
 implementation
 
+{ TBColorNone }
+
+procedure TBColorNone.SetColorName(ColorName: TColorName);
+begin
+end;
+
+procedure TBColorNone.SetRandom;
+begin
+end;
+
+{ TColor }
+
+procedure TColor.SetColorFormat(AValue: TColorFormat);
+begin
+  if FColorFormat = AValue then Exit;
+  if AValue = cfGray1 then FBackend := TBColorGray1.Create(0)
+    else if AValue = cfGray2 then FBackend := TBColorGray2.Create(0)
+    else if AValue = cfRGB8 then FBackend := TBColorRGB8.Create(TColorRGB8.Create(0, 0, 0))
+    else raise Exception.Create('Missing color backend for specified color format');
+  FColorFormat := AValue;
+end;
+
+procedure TColor.SetColorName(ColorName: TColorName);
+begin
+  FBackend.SetColorName(ColorName);
+end;
+
+procedure TColor.SetRandom;
+begin
+  FBackend.SetRandom;
+end;
+
+constructor TColor.Create;
+begin
+  ColorFormat := cfNone;
+end;
+
+constructor TColor.Create(ColorFormat: TColorFormat; ColorName: TColorName);
+begin
+  Self.ColorFormat := ColorFormat;
+  Backend.SetColorName(ColorName);
+end;
+
+destructor TColor.Destroy;
+begin
+  inherited Destroy;
+end;
+
+{ TBColorRGB8 }
+
+constructor TBColorRGB8.Create(Color: TColorRGB8);
+begin
+  Value := Color;
+end;
+
+procedure TBColorRGB8.SetColorName(ColorName: TColorName);
+begin
+  case ColorName of
+    cnBlack: Value := TColorRGB8.Create(0, 0, 0);
+    cnGray: Value := TColorRGB8.Create($80, $80, $80);
+    cnSilver: Value := TColorRGB8.Create($C0, $C0, $C0);
+    cnWhite: Value := TColorRGB8.Create($ff, $ff, $ff);
+    else Value := TColorRGB8.Create(0, 0, 0);;
+  end;
+end;
+
+procedure TBColorRGB8.SetRandom;
+begin
+  Value := TColorRGB8.Create(Random(256), Random(256), Random(256));
+end;
+
+{ TBColorGray2 }
+
+constructor TBColorGray2.Create(Color: TColorGray2);
+begin
+  Value := Color;
+end;
+
+procedure TBColorGray2.SetColorName(ColorName: TColorName);
+begin
+  case ColorName of
+    cnBlack: Value := 0;
+    cnGray: Value := 1;
+    cnSilver: Value := 2;
+    cnWhite: Value := 3;
+    else Value := 0;
+  end;
+end;
+
+procedure TBColorGray2.SetRandom;
+begin
+  Random(4);
+end;
+
+{ TBColorGray1 }
+
+constructor TBColorGray1.Create(Color: TColorGray1);
+begin
+  Value := Color;
+end;
+
+procedure TBColorGray1.SetColorName(ColorName: TColorName);
+begin
+  case ColorName of
+    cnBlack: Value := 0;
+    cnWhite: Value := 1;
+    else Value := 0;
+  end;
+end;
+
+procedure TBColorGray1.SetRandom;
+begin
+  Value := Random(2);
+end;
+
 { TBImageGray2 }
+
+function TBImageGray2.FillGetColor(Position: TPoint): TColorGray1;
+begin
+  Result := (FillCallBack(Position) as TBColorGray2).Value;
+end;
 
 procedure TBImageGray2.SetSize(AValue: TPoint);
@@ -118 +303 @@
 end;
 
-procedure TBImageGray2.Fill(Color: TBColor);
+function TBImageGray2.GetPixel(X, Y: Integer): IBColor;
+begin
+  Result := TBColorGray2.Create(Pixmap.Pixels[X, Y]);
+end;
+
+procedure TBImageGray2.SetPixel(X, Y: Integer; AValue: IBColor);
+begin
+  Pixmap.Pixels[X, Y] := (AValue as TBColorGray2).Value;
+end;
+
+procedure TBImageGray2.Fill(Color: IBColor);
 begin
   if Color is TBColorGray2 then
@@ -124 +319 @@
 end;
 
+procedure TBImageGray2.Fill(Func: TGetColorPos);
+begin
+  FillCallBack := Func;
+  Pixmap.Fill(FillGetColor);
+end;
+
 procedure TBImageGray2.PaintToCanvas(Canvas: TCanvas);
 begin
@@ -129 +330 @@
 end;
 
+function TBImageGray2.GetDataSize: Integer;
+begin
+  Result := Pixmap.GetDataSize;
+end;
+
 constructor TBImageGray2.Create;
 begin
   Pixmap := TPixmapGray2.Create;
+  Pixmap.BitsPerPixel := 2;
 end;
 
 destructor TBImageGray2.Destroy;
 begin
-  Pixmap.Free;
-  inherited Destroy;
+  FreeAndNil(Pixmap);
+  inherited;
 end;
 
@@ -149 +356 @@
 end;
 
-procedure TBImageRGB8.Fill(Color: TBColor);
+procedure TBImageRGB8.Fill(Color: IBColor);
 begin
   if Color is TBColorRGB8 then
@@ -162 +369 @@
 destructor TBImageRGB8.Destroy;
 begin
-  Pixmap.Free;
+  FreeAndNil(Pixmap);
   inherited Destroy;
 end;
 
 { TBImage }
+
+function TBImage.GetPixel(X, Y: Integer): IBColor;
+begin
+  Result := TBColorNone.Create;
+end;
+
+procedure TBImage.SetPixel(X, Y: Integer; AValue: IBColor);
+begin
+end;
 
 procedure TBImage.SetSize(AValue: TPoint);
@@ -174 +390 @@
 end;
 
-procedure TBImage.Fill(Color: TBColor);
+procedure TBImage.Fill(Color: IBColor);
 begin
 end;
@@ -186 +402 @@
 end;
 
+function TBImage.GetDataSize: Integer;
+begin
+  Result := 0;
+end;
+
 { TBImageGray1 }
+
+function TBImageGray1.FillGetColor(Position: TPoint): TColorGray1;
+begin
+  Result := (FillCallBack(Position) as TBColorGray1).Value;
+end;
 
 procedure TBImageGray1.SetSize(AValue: TPoint);
@@ -194 +420 @@
 end;
 
-procedure TBImageGray1.Fill(Color: TBColor);
+function TBImageGray1.GetPixel(X, Y: Integer): IBColor;
+begin
+  Result := TBColorGray1.Create(Pixmap.Pixels[X, Y]);
+end;
+
+procedure TBImageGray1.SetPixel(X, Y: Integer; AValue: IBColor);
+begin
+  Pixmap.Pixels[X, Y] := (AValue as TBColorGray1).Value;
+end;
+
+procedure TBImageGray1.Fill(Color: IBColor);
 begin
   if Color is TBColorGray1 then
@@ -202 +438 @@
 procedure TBImageGray1.Fill(Func: TGetColorPos);
 begin
-  //Pixmap.Fill();
+  FillCallBack := Func;
+  Pixmap.Fill(FillGetColor);
 end;
 
@@ -210 +447 @@
 end;
 
+function TBImageGray1.GetDataSize: Integer;
+begin
+  Result := Pixmap.GetDataSize;
+end;
+
 constructor TBImageGray1.Create;
 begin
   Pixmap := TPixmapGray1.Create;
+  Pixmap.BitsPerPixel := 1;
 end;
 
 destructor TBImageGray1.Destroy;
 begin
-  Pixmap.Free;
-  inherited Destroy;
-end;
-
-{ TGImage }
-
-procedure TGImage.SetColorFormat(AValue: TColorFormat);
+  FreeAndNil(Pixmap);
+  inherited;
+end;
+
+{ TPixmap }
+
+procedure TPixmap.SetColorFormat(AValue: TColorFormat);
 begin
   if FColorFormat = AValue then Exit;
   FBackend.Free;
   if AValue = cfGray1 then FBackend := TBImageGray1.Create
-  else if AValue = cfGray2 then FBackend := TBImageGray2.Create
-  else if AValue = cfRGB8 then FBackend := TBImageRGB8.Create
-  else FBackend := nil;
-  if Assigned(FBackend) then FBackend.Size := FSize;
+    else if AValue = cfGray2 then FBackend := TBImageGray2.Create
+    else if AValue = cfRGB8 then FBackend := TBImageRGB8.Create
+    else raise Exception.Create('Missing image backend for specified color format');
+  FBackend.Size := FSize;
   FColorFormat := AValue;
 end;
 
-procedure TGImage.SetSize(AValue: TPoint);
+function TPixmap.FillGetColor(Position: TPoint): IBColor;
+begin
+  Result := FillCallBack(Position, ColorFormat).Backend;
+end;
+
+function TPixmap.GetPixel(X, Y: Integer): TColor;
+begin
+  Result := TColor.Create;
+  Result.ColorFormat := ColorFormat;
+  Result.FBackend := FBackend.Pixels[X, Y];
+end;
+
+procedure TPixmap.SetPixel(X, Y: Integer; AValue: TColor);
+begin
+  FBackend.Pixels[X, Y] := AValue.FBackend;
+end;
+
+procedure TPixmap.SetSize(AValue: TPoint);
 begin
   if (FSize.X = AValue.X) and (FSize.Y = AValue.Y) then Exit;
   FSize := AValue;
-  if Assigned(FBackend) then
-    FBackend.Size := AValue;
-end;
-
-procedure TGImage.Fill(Color: TBColor);
-begin
-  if Assigned(FBackend) then FBackend.Fill(Color);
-end;
-
-procedure TGImage.Fill(Func: TGetColorPos);
-begin
-//  if Assigned(FBackend) then FBackend.Fill(Func: TGetColorPos);
-end;
-
-procedure TGImage.PaintToCanvas(Canvas: TCanvas);
-begin
-  if Assigned(FBackend) then FBackend.PaintToCanvas(Canvas);
-end;
-
-constructor TGImage.Create;
-begin
-  FBackend := nil;
-end;
-
-destructor TGImage.Destroy;
-begin
-  if Assigned(FBackend) then FreeAndNil(FBackend);
+  FBackend.Size := AValue;
+end;
+
+procedure TPixmap.Fill(Color: TColor);
+begin
+  FBackend.Fill(Color.Backend);
+end;
+
+procedure TPixmap.Fill(Func: TGetColorPos);
+begin
+  FillCallBack := Func;
+  FBackend.Fill(FillGetColor);
+end;
+
+procedure TPixmap.PaintToCanvas(Canvas: TCanvas);
+begin
+  FBackend.PaintToCanvas(Canvas);
+end;
+
+function TPixmap.GetDataSize: Integer;
+begin
+  FBackend.GetDataSize;
+end;
+
+constructor TPixmap.Create;
+begin
+  FBackend := TBImage.Create;
+end;
+
+destructor TPixmap.Destroy;
+begin
+  FreeAndNil(FBackend);
   inherited Destroy;
 end;
 
 end.
-
+       3

branches/gbitmap/GPixmap.pas

@@ -53 +53 @@
     FData: PByte;
     FSize: TPoint;
+    FCanvas: TGCanvas<TGColor>;
     function GetPixel(X, Y: Integer): TGColor; virtual;
     function GetSize: TPoint; virtual;
@@ -60 +61 @@
     procedure CheckLimits(X, Y: Integer);
   public
-    Canvas: TGCanvas<TGColor>;
     constructor Create;
     destructor Destroy; override;
@@ -67 +67 @@
     procedure Fill(Func: TGGetColor); overload;
     function GetDataSize: Int64; virtual;
+    property Canvas: TGCanvas<TGColor> read FCanvas;
     property Pixels[X, Y: Integer]: TGColor read GetPixel write SetPixel;
     property Size: TPoint read GetSize write SetSize;
@@ -120 +121 @@
 constructor TGPixmap<TGColor>.Create;
 begin
-  Canvas := TGCanvas<TGColor>.Create;
-  Canvas.Bitmap := Self;
+  FCanvas := TGCanvas<TGColor>.Create;
+  FCanvas.Bitmap := Self;
 end;
 
@@ -127 +128 @@
 begin
   Size := Point(0, 0);
+  FreeAndNil(FCanvas);
 end;
 

branches/gbitmap/UFormMain.pas

@@ -6 +6 @@
 
 uses
-  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Menus,
-  ExtCtrls, StdCtrls, GPixmap, UPixmapSpecialized, GImage;
+  GImage, Classes, SysUtils, FileUtil, Forms, Graphics, Controls, Dialogs, Menus,
+  ExtCtrls, StdCtrls, GPixmap, UPixmapSpecialized;
 
 type
@@ -28 +28 @@
     function RGB8Random(Position: TPoint): TColorRGB8;
     function RGB16Random(Position: TPoint): TColorRGB16;
+    function ColorRandom(Position: TPoint; ColorFormat: TColorFormat): GImage.TColor;
   public
     procedure TestGray1;
@@ -96 +97 @@
 end;
 
+function TForm1.ColorRandom(Position: TPoint; ColorFormat: TColorFormat): GImage.TColor;
+begin
+  Result := GImage.TColor.Create;
+  Result.ColorFormat := ColorFormat;
+  Result.SetRandom;
+end;
+
 procedure TForm1.TestGray1;
 var
@@ -262 +270 @@
 procedure TForm1.TestImage;
 var
-  Image: TGImage;
-  Color: TBColorGray1;
-begin
-  Image := TGImage.Create;
+  Image: GImage.TPixmap;
+begin
+  Image := GImage.TPixmap.Create;
   with Image do begin
     Size := Point(100, 100);
-    ColorFormat := cfGray1;
-    Color := TBColorGray1.Create;
-    Color.Value := 1;
-    Fill(Color);
-    Random;
+    ColorFormat := cfGray2;
+    Fill(GImage.TColor.Create(ColorFormat, cnWhite));
+    Pixels[0, 0] := GImage.TColor.Create(ColorFormat, cnBlack);
+    Fill(ColorRandom);
     PaintToCanvas(Image1.Picture.Bitmap.Canvas);
+    Label1.Caption := IntToStr(GetDataSize);
     Free;
   end;

branches/gbitmap/project1.lpi

@@ -18 +18 @@
       <StringTable ProductVersion=""/>
     </VersionInfo>
-    <BuildModes Count="1">
-      <Item1 Name="Default" Default="True"/>
+    <BuildModes Count="2">
+      <Item1 Name="Debug" Default="True"/>
+      <Item2 Name="Release">
+        <CompilerOptions>
+          <Version Value="11"/>
+          <PathDelim Value="\"/>
+          <Target>
+            <Filename Value="project1"/>
+          </Target>
+          <SearchPaths>
+            <IncludeFiles Value="$(ProjOutDir)"/>
+            <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+          </SearchPaths>
+          <Parsing>
+            <SyntaxOptions>
+              <SyntaxMode Value="Delphi"/>
+              <CStyleOperator Value="False"/>
+              <AllowLabel Value="False"/>
+              <CPPInline Value="False"/>
+            </SyntaxOptions>
+          </Parsing>
+          <CodeGeneration>
+            <SmartLinkUnit Value="True"/>
+          </CodeGeneration>
+          <Linking>
+            <Debugging>
+              <GenerateDebugInfo Value="False"/>
+            </Debugging>
+            <LinkSmart Value="True"/>
+            <Options>
+              <Win32>
+                <GraphicApplication Value="True"/>
+              </Win32>
+            </Options>
+          </Linking>
+        </CompilerOptions>
+      </Item2>
     </BuildModes>
     <PublishOptions>
@@ -73 +108 @@
       <SyntaxOptions>
         <SyntaxMode Value="Delphi"/>
+        <CStyleOperator Value="False"/>
         <IncludeAssertionCode Value="True"/>
+        <AllowLabel Value="False"/>
+        <CPPInline Value="False"/>
       </SyntaxOptions>
     </Parsing>
@@ -86 +124 @@
     </CodeGeneration>
     <Linking>
+      <Debugging>
+        <UseHeaptrc Value="True"/>
+      </Debugging>
       <Options>
         <Win32>
@@ -92 +133 @@
       </Options>
     </Linking>
+    <Other>
+      <CompilerMessages>
+        <IgnoredMessages idx5024="True"/>
+      </CompilerMessages>
+      <CustomOptions Value="-dDEBUG"/>
+    </Other>
   </CompilerOptions>
   <Debugging>

branches/gbitmap/project1.lpr

@@ -8 +8 @@
   {$ENDIF}{$ENDIF}
   Interfaces, // this includes the LCL widgetset
-  Forms, UFormMain, GPixmap, GImage, UPixmapSpecialized
+  SysUtils, Forms, UFormMain, GPixmap, GImage, UPixmapSpecialized
   { you can add units after this };
 
 {$R *.res}
 
+{$IFDEF DEBUG}
+const
+  HeapTraceLog = 'heaptrclog.trc';
+{$ENDIF}
+
 begin
-  RequireDerivedFormResource:=True;
+  {$IFDEF DEBUG}
+  // Heap trace
+  DeleteFile(ExtractFilePath(ParamStr(0)) + HeapTraceLog);
+  SetHeapTraceOutput(ExtractFilePath(ParamStr(0)) + HeapTraceLog);
+  {$ENDIF}
+
+  RequireDerivedFormResource := True;
   Application.Initialize;
   Application.CreateForm(TForm1, Form1);