Changeset 21


Ignore:
Timestamp:
Dec 22, 2016, 1:01:41 PM (8 years ago)
Author:
chronos
Message:
  • Added: Color format manager.
  • Modified: Color formats moved to separate files.
Location:
branches/gbitmap
Files:
8 added
6 edited

Legend:

Unmodified
Added
Removed

  • branches/gbitmap

    • Property svn:ignore

      •  

        old new  
        44project1.res
        55project1.exe
         6heaptrclog.trc

  • branches/gbitmap/GImage.pas

    r20 r21  
    66
    77uses
    8   Classes, SysUtils, Graphics, GPixmap, UPixmapSpecialized;
     8  Classes, SysUtils, Graphics, GPixmap, UPixmapSpecialized, Contnrs;
    99
    1010type
    11   TColorFormat = (cfNone, cfGray1, cfGray2, cfGray4, cfGray8, cfGray16, cfGray32,
    12     cfRGB8, cfRGB16);
    13 
    1411  TColorName = (cnBlack, cnWhite, cnBlue, cnRed, cnGreen, cnGray, cnSilver);
    1512
    … …  
    1916  end;
    2017
    21   { TBColorNone }
    22 
    23   TBColorNone = class(TInterfacedObject, IBColor)
    24     procedure SetColorName(ColorName: TColorName);
    25     procedure SetRandom;
    26   end;
    27 
    28   { TBColorGray1 }
    29 
    30   TBColorGray1 = class(TInterfacedObject, IBColor)
    31     Value: TColorGray1;
    32     constructor Create(Color: TColorGray1);
    33     procedure SetColorName(ColorName: TColorName);
    34     procedure SetRandom;
    35   end;
    36 
    37   { TBColorGray2 }
    38 
    39   TBColorGray2 = class(TInterfacedObject, IBColor)
    40     Value: TColorGray2;
    41     constructor Create(Color: TColorGray2);
    42     procedure SetColorName(ColorName: TColorName);
    43     procedure SetRandom;
    44   end;
     18  { TBColor }
     19
     20  TBColor = class(TInterfacedObject, IBColor)
     21    procedure SetColorName(ColorName: TColorName); virtual;
     22    procedure SetRandom; virtual;
     23  end;
     24
     25  IBColorClass = class of TBColor;
    4526
    4627  { TBColorRGB8 }
    4728
    48   TBColorRGB8 = class(TInterfacedObject, IBColor)
     29  TBColorRGB8 = class(TBColor)
    4930    Value: TColorRGB8;
    5031    constructor Create(Color: TColorRGB8);
    51     procedure SetColorName(ColorName: TColorName);
    52     procedure SetRandom;
     32    procedure SetColorName(ColorName: TColorName); override;
     33    procedure SetRandom; override;
    5334  end;
    5435
    … …  
    6142  private
    6243    FSize: TPoint;
     44  protected
    6345    function GetPixel(X, Y: Integer): IBColor;  virtual;
    6446    procedure SetPixel(X, Y: Integer; AValue: IBColor); virtual;
    65   protected
    6647    procedure SetSize(AValue: TPoint); virtual;
    6748  public
    … …  
    7051    procedure PaintToCanvas(Canvas: TCanvas); virtual;
    7152    function GetDataSize: Integer; virtual;
     53    constructor Create; virtual;
    7254    property Size: TPoint read FSize write SetSize;
    7355    property Pixels[X, Y: Integer]: IBColor read GetPixel write SetPixel;
    7456  end;
    7557
    76   { TBImageGray1 }
    77 
    78   TBImageGray1 = class(TBImage)
    79   private
    80     FillCallBack: TGetColorPos;
    81     function FillGetColor(Position: TPoint): TColorGray1;
    82   protected
    83     procedure SetSize(AValue: TPoint); override;
    84     function GetPixel(X, Y: Integer): IBColor;  override;
    85     procedure SetPixel(X, Y: Integer; AValue: IBColor); override;
    86   public
    87     Pixmap: TPixmapGray1;
    88     procedure Fill(Color: IBColor); override;
    89     procedure Fill(Func: TGetColorPos); override;
    90     procedure PaintToCanvas(Canvas: TCanvas); override;
    91     function GetDataSize: Integer; override;
    92     constructor Create;
    93     destructor Destroy; override;
    94   end;
    95 
    96   { TBImageGray2 }
    97 
    98   TBImageGray2 = class(TBImage)
    99   private
    100     FillCallBack: TGetColorPos;
    101     function FillGetColor(Position: TPoint): TColorGray1;
    102   protected
    103     procedure SetSize(AValue: TPoint); override;
    104     function GetPixel(X, Y: Integer): IBColor;  override;
    105     procedure SetPixel(X, Y: Integer; AValue: IBColor); override;
    106   public
    107     Pixmap: TPixmapGray2;
    108     procedure Fill(Color: IBColor); override;
    109     procedure Fill(Func: TGetColorPos); override;
    110     procedure PaintToCanvas(Canvas: TCanvas); override;
    111     function GetDataSize: Integer; override;
    112     constructor Create;
    113     destructor Destroy; override;
    114   end;
     58  TBPixmapClass = class of TBImage;
    11559
    11660  { TBImageRGB8 }
    … …  
    12468    constructor Create;
    12569    destructor Destroy; override;
     70  end;
     71
     72  { TColorFormatChannel }
     73
     74  TColorFormatChannel = record
     75    Name: string;
     76    Position: Integer;
     77    BitWidth: Integer;
     78  end;
     79
     80  { TColorFormat }
     81
     82  TColorFormat = class
     83    Name: string;
     84    BitDepth: Integer;
     85    Channels: array of TColorFormatChannel;
     86    BackendColorClass: IBColorClass;
     87    BackendImageClass: TBPixmapClass;
     88    procedure AddChannel(Name: string; Position, BitWidth: Integer);
     89    function GetBackendColor: IBColor;
     90    function GetBackendImage: TBImage;
     91    constructor Create; virtual;
     92    function GetChannelStateCount(Channel: Integer): Integer;
     93  end;
     94
     95  TColorFormatClass = class of TColorFormat;
     96
     97  { TColorFormatManager }
     98
     99  TColorFormatManager = class
     100  private
     101    FFormats: TObjectList; // TList<TColorFormat>
     102    function GetFormat(Index: Integer): TColorFormat;
     103  public
     104    constructor Create; virtual;
     105     destructor Destroy; override;
     106    procedure RegisterFormat(Format: TColorFormatClass);
     107    function FormatCount: Integer;
     108    property Formats[Index: Integer]: TColorFormat read GetFormat;
    126109  end;
    127110
    … …  
    172155  end;
    173156
     157var
     158  ColorFormatManager: TColorFormatManager;
     159
    174160
    175161implementation
    176162
    177 { TBColorNone }
    178 
    179 procedure TBColorNone.SetColorName(ColorName: TColorName);
    180 begin
    181 end;
    182 
    183 procedure TBColorNone.SetRandom;
    184 begin
     163{ TBColor }
     164
     165procedure TBColor.SetColorName(ColorName: TColorName);
     166begin
     167end;
     168
     169procedure TBColor.SetRandom;
     170begin
     171end;
     172
     173{ TColorFormatManager }
     174
     175function TColorFormatManager.GetFormat(Index: Integer): TColorFormat;
     176begin
     177  Result := TColorFormat(FFormats[Index]);
     178end;
     179
     180constructor TColorFormatManager.Create;
     181begin
     182  FFormats := TObjectList.Create;
     183end;
     184
     185destructor TColorFormatManager.Destroy;
     186begin
     187  FreeAndNil(FFormats);
     188  inherited Destroy;
     189end;
     190
     191procedure TColorFormatManager.RegisterFormat(Format: TColorFormatClass);
     192begin
     193  FFormats.Add(Format.Create);
     194end;
     195
     196function TColorFormatManager.FormatCount: Integer;
     197begin
     198  Result := FFormats.Count;
     199end;
     200
     201{ TColorFormat }
     202
     203procedure TColorFormat.AddChannel(Name: string; Position, BitWidth: Integer);
     204begin
     205  SetLength(Channels, Length(Channels) + 1);
     206  Channels[Length(Channels) - 1].Name := Name;
     207  Channels[Length(Channels) - 1].Position := Position;
     208  Channels[Length(Channels) - 1].BitWidth := BitWidth;
     209end;
     210
     211function TColorFormat.GetBackendColor: IBColor;
     212begin
     213  Result := BackendColorClass.Create;
     214end;
     215
     216function TColorFormat.GetBackendImage: TBImage;
     217begin
     218  Result := BackendImageClass.Create;
     219end;
     220
     221constructor TColorFormat.Create;
     222begin
     223  Name := 'None';
     224  BitDepth := 0;
     225  BackendColorClass := TBColor;
     226  BackendImageClass := TBImage;
     227end;
     228
     229function TColorFormat.GetChannelStateCount(Channel: Integer): Integer;
     230begin
     231  Result := 1 shl Channels[Channel].BitWidth;
    185232end;
    186233
    … …  
    190237begin
    191238  if FColorFormat = AValue then Exit;
    192   if AValue = cfGray1 then FBackend := TBColorGray1.Create(0)
    193     else if AValue = cfGray2 then FBackend := TBColorGray2.Create(0)
    194     else if AValue = cfRGB8 then FBackend := TBColorRGB8.Create(TColorRGB8.Create(0, 0, 0))
    195     else raise Exception.Create('Missing color backend for specified color format');
     239  FBackend := AValue.GetBackendColor;
    196240  FColorFormat := AValue;
    197241end;
    … …  
    209253constructor TColor.Create;
    210254begin
    211   ColorFormat := cfNone;
     255  ColorFormat := ColorFormatManager.GetFormat(0);
    212256end;
    213257
    … …  
    246290end;
    247291
    248 { TBColorGray2 }
    249 
    250 constructor TBColorGray2.Create(Color: TColorGray2);
    251 begin
    252   Value := Color;
    253 end;
    254 
    255 procedure TBColorGray2.SetColorName(ColorName: TColorName);
    256 begin
    257   case ColorName of
    258     cnBlack: Value := 0;
    259     cnGray: Value := 1;
    260     cnSilver: Value := 2;
    261     cnWhite: Value := 3;
    262     else Value := 0;
    263   end;
    264 end;
    265 
    266 procedure TBColorGray2.SetRandom;
    267 begin
    268   Random(4);
    269 end;
    270 
    271 { TBColorGray1 }
    272 
    273 constructor TBColorGray1.Create(Color: TColorGray1);
    274 begin
    275   Value := Color;
    276 end;
    277 
    278 procedure TBColorGray1.SetColorName(ColorName: TColorName);
    279 begin
    280   case ColorName of
    281     cnBlack: Value := 0;
    282     cnWhite: Value := 1;
    283     else Value := 0;
    284   end;
    285 end;
    286 
    287 procedure TBColorGray1.SetRandom;
    288 begin
    289   Value := Random(2);
    290 end;
    291 
    292 { TBImageGray2 }
    293 
    294 function TBImageGray2.FillGetColor(Position: TPoint): TColorGray1;
    295 begin
    296   Result := (FillCallBack(Position) as TBColorGray2).Value;
    297 end;
    298 
    299 procedure TBImageGray2.SetSize(AValue: TPoint);
     292{ TBImageRGB8 }
     293
     294procedure TBImageRGB8.SetSize(AValue: TPoint);
    300295begin
    301296  inherited;
    … …  
    303298end;
    304299
    305 function TBImageGray2.GetPixel(X, Y: Integer): IBColor;
    306 begin
    307   Result := TBColorGray2.Create(Pixmap.Pixels[X, Y]);
    308 end;
    309 
    310 procedure TBImageGray2.SetPixel(X, Y: Integer; AValue: IBColor);
    311 begin
    312   Pixmap.Pixels[X, Y] := (AValue as TBColorGray2).Value;
    313 end;
    314 
    315 procedure TBImageGray2.Fill(Color: IBColor);
    316 begin
    317   if Color is TBColorGray2 then
    318     Pixmap.Fill((Color as TBColorGray2).Value);
    319 end;
    320 
    321 procedure TBImageGray2.Fill(Func: TGetColorPos);
    322 begin
    323   FillCallBack := Func;
    324   Pixmap.Fill(FillGetColor);
    325 end;
    326 
    327 procedure TBImageGray2.PaintToCanvas(Canvas: TCanvas);
    328 begin
    329   Pixmap.PaintToCanvas(Canvas, Pixmap.Gray2ToColor);
    330 end;
    331 
    332 function TBImageGray2.GetDataSize: Integer;
    333 begin
    334   Result := Pixmap.GetDataSize;
    335 end;
    336 
    337 constructor TBImageGray2.Create;
    338 begin
    339   Pixmap := TPixmapGray2.Create;
    340   Pixmap.BitsPerPixel := 2;
    341 end;
    342 
    343 destructor TBImageGray2.Destroy;
    344 begin
    345   FreeAndNil(Pixmap);
    346   inherited;
    347 end;
    348 
    349 
    350 { TBImageRGB8 }
    351 
    352 procedure TBImageRGB8.SetSize(AValue: TPoint);
    353 begin
    354   inherited;
    355   Pixmap.Size := AValue;
    356 end;
    357 
    358300procedure TBImageRGB8.Fill(Color: IBColor);
    359301begin
    … …  
    377319function TBImage.GetPixel(X, Y: Integer): IBColor;
    378320begin
    379   Result := TBColorNone.Create;
     321  Result := TBColor.Create;
    380322end;
    381323
    … …  
    407349end;
    408350
    409 { TBImageGray1 }
    410 
    411 function TBImageGray1.FillGetColor(Position: TPoint): TColorGray1;
    412 begin
    413   Result := (FillCallBack(Position) as TBColorGray1).Value;
    414 end;
    415 
    416 procedure TBImageGray1.SetSize(AValue: TPoint);
    417 begin
    418   inherited;
    419   Pixmap.Size := AValue;
    420 end;
    421 
    422 function TBImageGray1.GetPixel(X, Y: Integer): IBColor;
    423 begin
    424   Result := TBColorGray1.Create(Pixmap.Pixels[X, Y]);
    425 end;
    426 
    427 procedure TBImageGray1.SetPixel(X, Y: Integer; AValue: IBColor);
    428 begin
    429   Pixmap.Pixels[X, Y] := (AValue as TBColorGray1).Value;
    430 end;
    431 
    432 procedure TBImageGray1.Fill(Color: IBColor);
    433 begin
    434   if Color is TBColorGray1 then
    435     Pixmap.Fill((Color as TBColorGray1).Value);
    436 end;
    437 
    438 procedure TBImageGray1.Fill(Func: TGetColorPos);
    439 begin
    440   FillCallBack := Func;
    441   Pixmap.Fill(FillGetColor);
    442 end;
    443 
    444 procedure TBImageGray1.PaintToCanvas(Canvas: TCanvas);
    445 begin
    446   Pixmap.PaintToCanvas(Canvas, Pixmap.Gray1ToColor);
    447 end;
    448 
    449 function TBImageGray1.GetDataSize: Integer;
    450 begin
    451   Result := Pixmap.GetDataSize;
    452 end;
    453 
    454 constructor TBImageGray1.Create;
    455 begin
    456   Pixmap := TPixmapGray1.Create;
    457   Pixmap.BitsPerPixel := 1;
    458 end;
    459 
    460 destructor TBImageGray1.Destroy;
    461 begin
    462   FreeAndNil(Pixmap);
    463   inherited;
     351constructor TBImage.Create;
     352begin
     353  Size := Point(0, 0);
    464354end;
    465355
    … …  
    470360  if FColorFormat = AValue then Exit;
    471361  FBackend.Free;
    472   if AValue = cfGray1 then FBackend := TBImageGray1.Create
    473     else if AValue = cfGray2 then FBackend := TBImageGray2.Create
    474     else if AValue = cfRGB8 then FBackend := TBImageRGB8.Create
    475     else raise Exception.Create('Missing image backend for specified color format');
     362  FBackend := AValue.GetBackendImage;
    476363  FBackend.Size := FSize;
    477364  FColorFormat := AValue;
    … …  
    525412constructor TPixmap.Create;
    526413begin
     414  ColorFormat := ColorFormatManager.GetFormat(0);
    527415  FBackend := TBImage.Create;
    528416end;
    … …  
    534422end;
    535423
     424
     425initialization
     426
     427ColorFormatManager := TColorFormatManager.Create;
     428ColorFormatManager.RegisterFormat(TColorFormat);
     429//TColorFormat = (cfNone, cfGray1, cfGray2, cfGray4, cfGray8, cfGray16, cfGray32,
     430//  cfRGB8, cfRGB16);
     431
     432
     433finalization
     434
     435FreeAndNil(ColorFormatManager);
     436
     437
    536438end.
    537        3
     439

  • branches/gbitmap/UFormMain.pas

    r20 r21  
    77uses
    88  GImage, Classes, SysUtils, FileUtil, Forms, Graphics, Controls, Dialogs, Menus,
    9   ExtCtrls, StdCtrls, GPixmap, UPixmapSpecialized;
     9  ExtCtrls, StdCtrls, GPixmap, UPixmapSpecialized, UColorGray1, UColorGray2,
     10  UColorGray4, UColorGray8, UColorRGB8, UColorRGBA8, UColorRGB565;
    1011
    1112type
    … …  
    275276  with Image do begin
    276277    Size := Point(100, 100);
    277     ColorFormat := cfGray2;
     278    ColorFormat := ColorFormatManager.Formats[1];
    278279    Fill(GImage.TColor.Create(ColorFormat, cnWhite));
    279280    Pixels[0, 0] := GImage.TColor.Create(ColorFormat, cnBlack);
    … …  
    287288procedure TForm1.FormShow(Sender: TObject);
    288289begin
     290  with ColorFormatManager do begin
     291    RegisterFormat(TColorFormatGray1);
     292    RegisterFormat(TColorFormatGray2);
     293    RegisterFormat(TColorFormatGray4);
     294    RegisterFormat(TColorFormatGray8);
     295    RegisterFormat(TColorFormatRGB8);
     296    RegisterFormat(TColorFormatRGBA8);
     297    RegisterFormat(TColorFormatRGB565);
     298  end;
    289299  ListBox1.ItemIndex := 0;
    290300end;

  • branches/gbitmap/UPixmapSpecialized.pas

    r19 r21  
    99
    1010type
    11   TColorGray1 = Byte;
    12   TColorGray2 = Byte;
    13   TColorGray4 = Byte;
    14   TColorGray8 = Byte;
    1511  TColorGray16 = Word;
    1612  TColorGray32 = Cardinal;
    … …  
    3733
    3834  TColorGrayVar = PByte;
    39 
    40   TPixmapGray1 = class(TGPixmapBit<TColorGray1>)
    41     function Gray1ToColor(Value: TColorGray1): TColor;
    42   end;
    43 
    44   TPixmapGray2 = class(TGPixmapBit<TColorGray2>)
    45     function Gray2ToColor(Value: TColorGray2): TColor;
    46   end;
    47 
    48   TPixmapGray4 = class(TGPixmapBit<TColorGray4>)
    49     function Gray4ToColor(Value: TColorGray4): TColor;
    50   end;
    51 
    52   TPixmapGray8 = class(TGPixmap<TColorGray8>)
    53     function Gray8ToColor(Value: TColorGray8): TColor;
    54   end;
    5535
    5636  TPixmapGray16 = class(TGPixmap<TColorGray16>)
    … …  
    9777end;
    9878
    99 
    100 function TPixmapGray1.Gray1ToColor(Value: TColorGray1): TColor;
    101 begin
    102   Value := (Value and $1) * $ff;
    103   Result := (Value shl 16) or (Value shl 8) or (Value shl 0);
    104 end;
    105 
    106 function TPixmapGray2.Gray2ToColor(Value: TColorGray2): TColor;
    107 begin
    108   Value := (Value and $3) * (255 div (4 - 1));
    109   Result := (Value shl 16) or (Value shl 8) or (Value shl 0);
    110 end;
    111 
    112 function TPixmapGray4.Gray4ToColor(Value: TColorGray4): TColor;
    113 begin
    114   Value := (Value and $f) * (255 div (16 - 1));
    115   Result := (Value shl 16) or (Value shl 8) or (Value shl 0);
    116 end;
    117 
    118 function TPixmapGray8.Gray8ToColor(Value: TColorGray8): TColor;
    119 begin
    120   Result := (Value shl 16) or (Value shl 8) or (Value shl 0);
    121 end;
    122 
    12379function TPixmapGray16.Gray16ToColor(Value: TColorGray16): TColor;
    12480begin

  • branches/gbitmap/project1.lpi

    r20 r21  
    2929          <SearchPaths>
    3030            <IncludeFiles Value="$(ProjOutDir)"/>
     31            <OtherUnitFiles Value="ColorFormats"/>
    3132            <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
    3233          </SearchPaths>
    … …  
    6970      </Item1>
    7071    </RequiredPackages>
    71     <Units Count="5">
     72    <Units Count="12">
    7273      <Unit0>
    7374        <Filename Value="project1.lpr"/>
    … …  
    9394        <IsPartOfProject Value="True"/>
    9495      </Unit4>
     96      <Unit5>
     97        <Filename Value="ColorFormats\UColorGray1.pas"/>
     98        <IsPartOfProject Value="True"/>
     99      </Unit5>
     100      <Unit6>
     101        <Filename Value="ColorFormats\UColorGray4.pas"/>
     102        <IsPartOfProject Value="True"/>
     103      </Unit6>
     104      <Unit7>
     105        <Filename Value="ColorFormats\UColorGray8.pas"/>
     106        <IsPartOfProject Value="True"/>
     107      </Unit7>
     108      <Unit8>
     109        <Filename Value="ColorFormats\UColorRGB565.pas"/>
     110        <IsPartOfProject Value="True"/>
     111      </Unit8>
     112      <Unit9>
     113        <Filename Value="ColorFormats\UColorRGBA8.pas"/>
     114        <IsPartOfProject Value="True"/>
     115      </Unit9>
     116      <Unit10>
     117        <Filename Value="ColorFormats\UColorGray2.pas"/>
     118        <IsPartOfProject Value="True"/>
     119      </Unit10>
     120      <Unit11>
     121        <Filename Value="ColorFormats\UColorRGB8.pas"/>
     122        <IsPartOfProject Value="True"/>
     123      </Unit11>
    95124    </Units>
    96125  </ProjectOptions>
    … …  
    103132    <SearchPaths>
    104133      <IncludeFiles Value="$(ProjOutDir)"/>
     134      <OtherUnitFiles Value="ColorFormats"/>
    105135      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
    106136    </SearchPaths>

  • branches/gbitmap/project1.lpr

    r20 r21  
    88  {$ENDIF}{$ENDIF}
    99  Interfaces, // this includes the LCL widgetset
    10   SysUtils, Forms, UFormMain, GPixmap, GImage, UPixmapSpecialized
     10  SysUtils, Forms, UFormMain, GPixmap, GImage, UPixmapSpecialized, UColorRGB8
    1111  { you can add units after this };
    1212
Note: See TracChangeset for help on using the changeset viewer.