Changeset 3


Ignore:
Timestamp:
Sep 15, 2014, 11:13:21 PM (10 years ago)
Author:
chronos
Message:
  • Modified: Specific TGColor implementation moved to ColorFormats directory.
  • Added: Function to clear image with background color.
  • Modified: Drawing project image to off screen bitmap to speed up drawing.
Location:
trunk
Files:
2 added
7 edited

Legend:

Unmodified
Added
Removed

  • trunk/Forms/UFormMain.lfm

    r2 r3  
    2323    object MenuItem1: TMenuItem
    2424      Caption = 'Soubor'
     25      object MenuItem3: TMenuItem
     26        Action = Core.AProjectNew
     27      end
    2528      object MenuItem2: TMenuItem
    26         Action = Core.AProjectNew
     29        Action = Core.AExit
     30      end
     31    end
     32    object MenuItem4: TMenuItem
     33      Caption = 'Image'
     34      object MenuItem5: TMenuItem
     35        Action = Core.AImageClear
    2736      end
    2837    end
    2938  end
     39  object Timer1: TTimer
     40    Enabled = False
     41    Interval = 50
     42    OnTimer = Timer1Timer
     43    left = 195
     44    top = 206
     45  end
    3046end

  • trunk/Forms/UFormMain.pas

    r2 r3  
    1717    MenuItem1: TMenuItem;
    1818    MenuItem2: TMenuItem;
     19    MenuItem3: TMenuItem;
     20    MenuItem4: TMenuItem;
     21    MenuItem5: TMenuItem;
    1922    PaintBox1: TPaintBox;
     23    Timer1: TTimer;
    2024    procedure PaintBox1Paint(Sender: TObject);
    2125    procedure PaintBox1Resize(Sender: TObject);
     26    procedure Timer1Timer(Sender: TObject);
    2227  private
    2328    { private declarations }
    2429  public
    25     { public declarations }
     30    procedure Redraw;
    2631  end;
    2732
    … …  
    4348end;
    4449
     50procedure TFormMain.Timer1Timer(Sender: TObject);
     51var
     52  Bitmap: TBitmap;
     53begin
     54  Timer1.Enabled := False;
     55  try
     56    Bitmap := TBitmap.Create;
     57    Bitmap.SetSize(Core.Project.Bitmap.Size.X, Core.Project.Bitmap.Size.Y);
     58    Bitmap.BeginUpdate(True);
     59    Core.Project.Bitmap.PaintToCanvas(Bitmap.Canvas);
     60    Bitmap.EndUpdate(False);
     61    PaintBox1.Canvas.Draw(0, 0, Bitmap);
     62  finally
     63    Bitmap.Free;
     64  end;
     65end;
     66
     67procedure TFormMain.Redraw;
     68begin
     69  Timer1.Enabled := True;
     70end;
     71
    4572procedure TFormMain.PaintBox1Paint(Sender: TObject);
    4673begin
    47   Core.Project.Bitmap.PaintToCanvas(PaintBox1.Canvas);
     74  Redraw;
    4875end;
    4976

  • trunk/LibrePaint.lpi

    r2 r3  
    3333      </Item1>
    3434    </RequiredPackages>
    35     <Units Count="6">
     35    <Units Count="7">
    3636      <Unit0>
    3737        <Filename Value="LibrePaint.lpr"/>
    3838        <IsPartOfProject Value="True"/>
    39         <UnitName Value="LibrePaint"/>
    4039      </Unit0>
    4140      <Unit1>
    42         <Filename Value="UFormMain.pas"/>
    43         <IsPartOfProject Value="True"/>
    44         <ComponentName Value="FormMain"/>
    45         <ResourceBaseClass Value="Form"/>
    46         <UnitName Value="UFormMain"/>
    47       </Unit1>
    48       <Unit2>
    4941        <Filename Value="UCore.pas"/>
    5042        <IsPartOfProject Value="True"/>
    5143        <ComponentName Value="Core"/>
     44        <HasResources Value="True"/>
    5245        <ResourceBaseClass Value="DataModule"/>
    5346        <UnitName Value="UCore"/>
    54       </Unit2>
    55       <Unit3>
     47      </Unit1>
     48      <Unit2>
    5649        <Filename Value="UGraphic.pas"/>
    5750        <IsPartOfProject Value="True"/>
    5851        <UnitName Value="UGraphic"/>
    59       </Unit3>
    60       <Unit4>
     52      </Unit2>
     53      <Unit3>
    6154        <Filename Value="UProject.pas"/>
    6255        <IsPartOfProject Value="True"/>
    6356        <UnitName Value="UProject"/>
    64       </Unit4>
    65       <Unit5>
     57      </Unit3>
     58      <Unit4>
    6659        <Filename Value="Forms/UFormNew.pas"/>
    6760        <IsPartOfProject Value="True"/>
    6861        <ComponentName Value="FormNew"/>
     62        <HasResources Value="True"/>
    6963        <ResourceBaseClass Value="Form"/>
    7064        <UnitName Value="UFormNew"/>
     65      </Unit4>
     66      <Unit5>
     67        <Filename Value="ColorFormats/UColorRGBA8.pas"/>
     68        <IsPartOfProject Value="True"/>
     69        <UnitName Value="UColorRGBA8"/>
    7170      </Unit5>
     71      <Unit6>
     72        <Filename Value="Forms/UFormMain.pas"/>
     73        <IsPartOfProject Value="True"/>
     74        <ComponentName Value="FormMain"/>
     75        <HasResources Value="True"/>
     76        <ResourceBaseClass Value="Form"/>
     77        <UnitName Value="UFormMain"/>
     78      </Unit6>
    7279    </Units>
    7380  </ProjectOptions>
    … …  
    7986    <SearchPaths>
    8087      <IncludeFiles Value="$(ProjOutDir)"/>
    81       <OtherUnitFiles Value="Forms"/>
     88      <OtherUnitFiles Value="Forms;ColorFormats"/>
    8289      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
    8390    </SearchPaths>

  • trunk/LibrePaint.lpr

    r2 r3  
    88  {$ENDIF}{$ENDIF}
    99  Interfaces, // this includes the LCL widgetset
    10   Forms, UFormMain, UCore, UGraphic, UProject, UFormNew
     10  Forms, UCore, UGraphic, UProject, UFormNew, UFormMain, UColorRGBA8
    1111  { you can add units after this };
    1212

  • trunk/UCore.lfm

    r2 r3  
    1313      OnExecute = AProjectNewExecute
    1414    end
     15    object AExit: TAction
     16      Caption = 'Exit'
     17      OnExecute = AExitExecute
     18    end
     19    object AImageClear: TAction
     20      Caption = 'Clear'
     21      OnExecute = AImageClearExecute
     22    end
    1523  end
    1624end

  • trunk/UCore.pas

    r2 r3  
    1313
    1414  TCore = class(TDataModule)
     15    AImageClear: TAction;
     16    AExit: TAction;
    1517    AProjectNew: TAction;
    1618    ActionList1: TActionList;
     19    procedure AExitExecute(Sender: TObject);
     20    procedure AImageClearExecute(Sender: TObject);
    1721    procedure AProjectNewExecute(Sender: TObject);
    1822    procedure DataModuleCreate(Sender: TObject);
    … …  
    3135
    3236uses
    33   UFormNew, UFormMain;
     37  UFormNew, UFormMain, UColorRGBA8, Forms;
    3438
    3539{ TCore }
    … …  
    5660    Project.Bitmap.ColorFormat := ColorManager.Formats[FormNew.ComboBoxColorFormat.ItemIndex];
    5761    Project.Bitmap.DPI := FormNew.SpinEditDPI.Value;
    58     Project.Bitmap.PaintToCanvas(FormMain.PaintBox1.Canvas);
     62    FormMain.Redraw;
    5963  end;
     64end;
     65
     66procedure TCore.AExitExecute(Sender: TObject);
     67begin
     68  Application.Terminate;
     69end;
     70
     71procedure TCore.AImageClearExecute(Sender: TObject);
     72begin
     73  Project.Bitmap.Clear;
     74  FormMain.Redraw;
    6075end;
    6176

  • trunk/UGraphic.pas

    r2 r3  
    3030  TGColorFormatClass = class of TGColorFormat;
    3131
    32   { TGColorFormatRGBA8 }
    33 
    34   TGColorFormatRGBA8 = class(TGColorFormat)
    35     function GetPixelSize: Integer; override;
    36     function GetBitDepth: Integer; override;
    37     function GetName: string; override;
    38     function GetChannelBytePos(Channel: TGColorChannel): Integer; override;
    39     function GetChannelBitWidth(Channel: TGColorChannel): Integer; override;
    40     function ColorToTColor(Color: TGColor): TColor; override;
    41     function GetColorClass: TGColorClass; override;
    42   end;
    43 
    4432  { TGColor }
    4533
    4634  TGColor = class
    4735  private
     36    FColorFormat: TGColorFormatClass;
    4837    FData: PByte;
    49     FColorFormat: TGColorFormatClass;
    5038    function GetChannel(Channel: TGColorChannel): TGColor;
    5139    procedure SetColorFormat(AValue: TGColorFormatClass);
    … …  
    5644    procedure Assign(Source: TGColor); virtual;
    5745    property Channels[Channel: TGColorChannel]: TGColor read GetChannel;
     46    property Data: PByte read FData;
    5847  published
    5948    property Format: TGColorFormatClass read FColorFormat write SetColorFormat;
    … …  
    6453  TGBitmap = class
    6554  private
     55    FBackgroundColor: TGColor;
    6656    FColorFormat: TGColorFormatClass;
    6757    FDPI: Integer;
    … …  
    7060    function GetPixel(X, Y: Integer): TGColor;
    7161    function GetSize: TPoint;
     62    procedure SetBackgroundColor(AValue: TGColor);
    7263    procedure SetColorFormat(AValue: TGColorFormatClass);
    7364    procedure SetPixel(X, Y: Integer; AValue: TGColor);
    … …  
    7768    function GetDataSize: Integer;
    7869    procedure PaintToCanvas(Canvas: TCanvas);
     70    procedure Clear;
    7971    constructor Create; virtual;
    8072    destructor Destroy; override;
     73    property BackgroundColor: TGColor read FBackgroundColor write SetBackgroundColor;
    8174    property DPI: Integer read FDPI write FDPI;
    8275    property ColorFormat: TGColorFormatClass read FColorFormat write SetColorFormat;
    … …  
    134127end;
    135128
    136 { TGColorFormatRGBA8 }
    137 
    138 function TGColorFormatRGBA8.GetPixelSize: Integer;
    139 begin
    140   Result := 4;
    141 end;
    142 
    143 function TGColorFormatRGBA8.GetBitDepth: Integer;
    144 begin
    145   Result := 32;
    146 end;
    147 
    148 function TGColorFormatRGBA8.GetName: string;
    149 begin
    150   Result := 'RGBA8';
    151 end;
    152 
    153 function TGColorFormatRGBA8.GetChannelBytePos(Channel: TGColorChannel): Integer;
    154 begin
    155   case Channel of
    156     ccRed: Result := 0;
    157     ccGreen: Result := 1;
    158     ccBlue: Result := 2;
    159     ccOpacity: Result := 3;
    160     else raise Exception.Create('Unsupported color channel');
    161   end;
    162 end;
    163 
    164 function TGColorFormatRGBA8.GetChannelBitWidth(Channel: TGColorChannel
    165   ): Integer;
    166 begin
    167   if (Channel = ccBlue) or (Channel = ccRed) or (Channel = ccGreen) then
    168     Result := 8 else Result := 0;
    169 end;
    170 
    171 function TGColorFormatRGBA8.ColorToTColor(Color: TGColor): TColor;
    172 begin
    173   Result := PByte(Color.FData + GetChannelBytePos(ccRed))^ or
    174     (PByte(Color.FData + GetChannelBytePos(ccGreen))^ shl 8) or
    175     (PByte(Color.FData + GetChannelBytePos(ccBlue))^ shl 16);
    176 end;
    177 
    178 function TGColorFormatRGBA8.GetColorClass: TGColorClass;
    179 begin
    180   Result := TGColor;
    181 end;
    182 
    183129{ TGColorFormat }
    184130
    … …  
    286232end;
    287233
     234procedure TGBitmap.SetBackgroundColor(AValue: TGColor);
     235begin
     236  if FBackgroundColor = AValue then Exit;
     237  FBackgroundColor := AValue;
     238end;
     239
    288240procedure TGBitmap.SetColorFormat(AValue: TGColorFormatClass);
    289241begin
    … …  
    291243  FColorFormat := AValue;
    292244  ReAllocMem(FData, GetDataSize);
     245  FBackgroundColor.Format := ColorFormat;
    293246end;
    294247
    … …  
    328281  Pixel: TGColor;
    329282begin
     283  try
     284  Canvas.Lock;
    330285  for Y := 0 to Size.Y - 1 do
    331286    for X := 0 to Size.X - 1 do begin
    … …  
    334289      Pixel.Free;
    335290    end;
     291
     292  finally
     293    Canvas.Unlock;
     294  end;
     295end;
     296
     297procedure TGBitmap.Clear;
     298var
     299  X, Y: Integer;
     300begin
     301  for Y := 0 to Size.Y - 1 do
     302    for X := 0 to Size.X - 1 do begin
     303      Pixels[X, Y] := BackgroundColor;
     304    end;
    336305end;
    337306
    … …  
    339308begin
    340309  FData := GetMem(0);
    341   ColorFormat := TGColorFormatRGBA8;
     310  FBackgroundColor := TGColor.Create;
     311  ColorFormat := TGColorFormat;
     312  FBackgroundColor.Format := ColorFormat;
    342313end;
    343314
Note: See TracChangeset for help on using the changeset viewer.