Ignore:
Timestamp:
Feb 1, 2012, 3:02:33 PM (12 years ago)
Author:
chronos
Message:
  • Modified: Updated BGRABitmap package to version 5.5.
  • Modified: Removed draw method ComboBox and reorganized method list to single listview with using ownerdraw facility.
  • Added: New draw method TBitmap.RawImage.Data Move which use fast Move operation. It requires same pixel format.
  • Added: New draw method Dummy for comparion of empty method and to determine possibily max frame rate limit.
Location:
GraphicTest/BGRABitmap
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • GraphicTest/BGRABitmap

    • Property svn:ignore set to
      lib

  • GraphicTest/BGRABitmap/bgrapaintnet.pas

    r210 r317  
    55interface
    66
     7{ This unit reads Paint.NET files. It needs BGRADNetDeserial to deserialize binary .Net objects.
     8
     9  A Paint.NET image consists in three parts :
     10  - Xml header
     11  - Binary serialized information (contains layer information)
     12  - Compressed data (pixel data)
     13
     14  The class TPaintDotNetFile do not read the Xml header. ComputeFlatImage builds the resulting image
     15  by using blending operations to merge layers.
     16
     17  The unit registers a TFPCustomImageReader so that it can be read by any image reading function of FreePascal }
     18
    719uses
    8   Classes, SysUtils, BGRADNetDeserial, BGRABitmap, BGRABitmapTypes;
     20  Classes, SysUtils, BGRADNetDeserial, BGRALayers, BGRABitmap, BGRABitmapTypes, FPImage;
    921
    1022type
    … …  
    1224  { TPaintDotNetFile }
    1325
    14   TPaintDotNetFile = class
     26  TPaintDotNetFile = class(TBGRACustomLayeredBitmap)
    1527  public
    16     procedure LoadFromFile(filename: string);
    17     procedure LoadFromStream(stream: TStream);
    18     procedure Clear;
    19     function ToString: string;
    20     destructor Destroy; override;
     28    procedure LoadFromFile(filename: string); override;
     29    procedure LoadFromStream(stream: TStream); override;
     30    procedure Clear; override;
     31    function ToString: ansistring; override;
     32    function GetLayerBitmapCopy(layer: integer): TBGRABitmap; override;
    2133    constructor Create;
    22     function Width: integer;
    23     function Height: integer;
    24     function NbLayers: integer;
    25     function BlendOperation(Layer: integer): TBlendOperation;
    26     function LayerVisible(layer: integer): boolean;
    27     function LayerOpacity(layer: integer): byte;
    28     function LayerName(layer: integer): string;
    29     function MakeBitmapLayer(layer: integer): TBGRABitmap;
    30     function ComputeFlatImage: TBGRABitmap;
     34  protected
     35    function GetWidth: integer; override;
     36    function GetHeight: integer; override;
     37    function GetNbLayers: integer; override;
     38    function GetBlendOperation(Layer: integer): TBlendOperation; override;
     39    function GetLayerVisible(layer: integer): boolean; override;
     40    function GetLayerOpacity(layer: integer): byte; override;
     41    function GetLayerName(layer: integer): string; override;
    3142  private
    3243    XmlHeader: string;
    3344    ThumbNail: TBGRABitmap;
    3445    Content:   TDotNetDeserialization;
    35     Document:  PSerializedObject;
    36     Layers:    PSerializedObject;
     46    Document:  TSerializedClass;
     47    Layers:    TSerializedClass;
    3748    LayerData: array of TMemoryStream;
    38     function GetLayer(num: integer): PSerializedObject;
    39     function GetBlendOperation(layer: PSerializedObject): TBlendOperation;
    40     function GetLayerName(layer: PSerializedObject): string;
    41     function GetLayerVisible(layer: PSerializedObject): boolean;
    42     function GetLayerOpacity(layer: PSerializedObject): byte;
     49    function InternalGetLayer(num: integer): TSerializedClass;
     50    function InternalGetBlendOperation(layer: TSerializedClass): TBlendOperation;
     51    function InternalGetLayerName(layer: TSerializedClass): string;
     52    function InternalGetLayerVisible(layer: TSerializedClass): boolean;
     53    function InternalGetLayerOpacity(layer: TSerializedClass): byte;
    4354    function LayerDataSize(numLayer: integer): int64;
    4455    procedure LoadLayer(dest: TMemoryStream; src: TStream; uncompressedSize: int64);
     56  end;
     57
     58  { TFPReaderPaintDotNet }
     59
     60  TFPReaderPaintDotNet = class(TFPCustomImageReader)
     61    protected
     62      function InternalCheck(Stream: TStream): boolean; override;
     63      procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
    4564  end;
    4665
    … …  
    146165{$hints on}
    147166
     167{ TFPReaderPaintDotNet }
     168
     169function TFPReaderPaintDotNet.InternalCheck(Stream: TStream): boolean;
     170begin
     171  result := IsPaintDotNetStream(stream);
     172end;
     173
     174procedure TFPReaderPaintDotNet.InternalRead(Stream: TStream; Img: TFPCustomImage
     175  );
     176var
     177  pdn: TPaintDotNetFile;
     178  flat: TBGRABitmap;
     179  x,y: integer;
     180begin
     181  pdn    := TPaintDotNetFile.Create;
     182  try
     183    pdn.LoadFromStream(Stream);
     184    flat := pdn.ComputeFlatImage;
     185    try
     186      Img.SetSize(pdn.Width,pdn.Height);
     187      for y := 0 to pdn.Height-1 do
     188        for x := 0 to pdn.Width-1 do
     189          Img.Colors[x,y] := BGRAToFPColor(flat.GetPixel(x,y));
     190    finally
     191      flat.free;
     192    end;
     193    pdn.Free;
     194  except
     195    on ex: Exception do
     196    begin
     197      pdn.Free;
     198      raise Exception.Create('Error while loading Paint.NET file. ' + ex.Message);
     199    end;
     200  end;
     201end;
     202
    148203{ TPaintDotNetFile }
    149204
    … …  
    163218var
    164219  header: packed array[0..3] of char;
    165   XmlHeaderSize: longword;
     220  XmlHeaderSize: integer;
    166221  CompressionFormat: word;
    167222  i:      integer;
    … …  
    192247        IntToStr(Compressionformat) + ')');
    193248  end;
    194   Document := Content.FindObject('Document');
     249  Document := Content.FindClass('Document');
    195250  if Document <> nil then
    196     Layers := Content.GetObjectField(Document^, 'layers');
     251    Layers := Content.GetObjectField(Document, 'layers') as TSerializedClass;
    197252  SetLength(LayerData, NbLayers);
    198253  for i := 0 to NbLayers - 1 do
    … …  
    203258end;
    204259
    205 function TPaintDotNetFile.ToString: string;
     260function TPaintDotNetFile.ToString: ansistring;
    206261var
    207262  i, j, nbbytes: integer;
    … …  
    216271  for i := 0 to NbLayers - 1 do
    217272  begin
    218     Result += LineEnding + 'Layer ' + IntToStr(i) + ' : ' + LayerName(i) + LineEnding;
     273    Result += LineEnding + 'Layer ' + IntToStr(i) + ' : ' + LayerName[i] + LineEnding;
    219274    Result += '[ ';
    220275    LayerData[i].Position := 0;
    … …  
    234289    Result   += ']' + lineending;
    235290  end;
    236 end;
    237 
    238 destructor TPaintDotNetFile.Destroy;
    239 begin
    240   content.Free;
    241   Thumbnail.Free;
    242   inherited Destroy;
    243291end;
    244292
    … …  
    265313end;
    266314
    267 function TPaintDotNetFile.Width: integer;
     315function TPaintDotNetFile.GetWidth: integer;
    268316begin
    269317  if Document = nil then
    270318    Result := 0
    271319  else
    272     Result := StrToInt(Content.GetSimpleField(Document^, 'width'));
    273 end;
    274 
    275 function TPaintDotNetFile.Height: integer;
     320    Result := StrToInt(Content.GetSimpleField(Document, 'width'));
     321end;
     322
     323function TPaintDotNetFile.GetHeight: integer;
    276324begin
    277325  if Document = nil then
    278326    Result := 0
    279327  else
    280     Result := StrToInt(Content.GetSimpleField(Document^, 'height'));
    281 end;
    282 
    283 function TPaintDotNetFile.NbLayers: integer;
     328    Result := StrToInt(Content.GetSimpleField(Document, 'height'));
     329end;
     330
     331function TPaintDotNetFile.GetNbLayers: integer;
    284332begin
    285333  if Layers = nil then
    286334    Result := 0
    287335  else
    288     Result := StrToInt(Content.GetSimpleField(Layers^, '_size'));
    289 end;
    290 
    291 function TPaintDotNetFile.BlendOperation(Layer: integer): TBlendOperation;
    292 begin
    293   Result := GetBlendOperation(GetLayer(layer));
    294 end;
    295 
    296 function TPaintDotNetFile.LayerVisible(layer: integer): boolean;
    297 begin
    298   Result := GetLayerVisible(GetLayer(layer));
    299 end;
    300 
    301 function TPaintDotNetFile.LayerOpacity(layer: integer): byte;
    302 begin
    303   Result := GetLayerOpacity(GetLayer(layer));
    304 end;
    305 
    306 function TPaintDotNetFile.LayerName(layer: integer): string;
    307 begin
    308   Result := GetLayerName(GetLayer(layer));
    309 end;
    310 
    311 function TPaintDotNetFile.MakeBitmapLayer(layer: integer): TBGRABitmap;
     336    Result := StrToInt(Content.GetSimpleField(Layers, '_size'));
     337end;
     338
     339function TPaintDotNetFile.GetBlendOperation(Layer: integer): TBlendOperation;
     340begin
     341  Result := InternalGetBlendOperation(InternalGetLayer(layer));
     342end;
     343
     344function TPaintDotNetFile.GetLayerVisible(layer: integer): boolean;
     345begin
     346  Result := InternalGetLayerVisible(InternalGetLayer(layer));
     347end;
     348
     349function TPaintDotNetFile.GetLayerOpacity(layer: integer): byte;
     350begin
     351  Result := InternalGetLayerOpacity(InternalGetLayer(layer));
     352end;
     353
     354function TPaintDotNetFile.GetLayerName(layer: integer): string;
     355begin
     356  Result := InternalGetLayerName(InternalGetLayer(layer));
     357end;
     358
     359function TPaintDotNetFile.GetLayerBitmapCopy(layer: integer): TBGRABitmap;
    312360begin
    313361  if (layer < 0) or (layer >= NbLayers) then
    … …  
    315363
    316364  Result := TBGRABitmap.Create(Width, Height);
    317   if Result.NbPixels * 4 <> LayerData[layer].Size then
     365  if int64(Result.NbPixels) * 4 <> LayerData[layer].Size then
    318366  begin
    319367    Result.Free;
    … …  
    331379end;
    332380
    333 function TPaintDotNetFile.ComputeFlatImage: TBGRABitmap;
    334 var
    335   tempLayer, tempMerge: TBGRABitmap;
    336   i: integer;
    337 begin
    338   Result := TBGRABitmap.Create(Width, Height);
    339   for i := 0 to NbLayers - 1 do
    340   begin
    341     tempLayer := MakeBitmapLayer(i);
    342     if tempLayer <> nil then
    343     begin
    344       //first layer is simply the background
    345       if i = 0 then
    346         Result.PutImage(0, 0, tempLayer, dmSet)
    347       else
    348       //simple blend operations
    349       if BlendOperation(i) in [boTransparent, boLinearBlend] then
    350       begin
    351         tempLayer.ApplyGlobalOpacity(LayerOpacity(i));
    352         Result.BlendImage(0, 0, tempLayer, BlendOperation(i));
    353       end
    354       else
    355         //complex blend operations are done in a third bitmap
    356       begin
    357         tempMerge := Result.Duplicate as TBGRABitmap;
    358         tempMerge.BlendImage(0, 0, tempLayer, BlendOperation(i));
    359         tempMerge.ApplyGlobalOpacity(LayerOpacity(i));
    360         Result.PutImage(0, 0, tempMerge, dmFastBlend);
    361         tempMerge.Free;
    362       end;
    363       tempLayer.Free;
    364     end;
    365   end;
    366 end;
    367 
    368 function TPaintDotNetFile.GetLayerName(layer: PSerializedObject): string;
    369 var
    370   prop: PSerializedObject;
     381function TPaintDotNetFile.InternalGetLayerName(layer: TSerializedClass): string;
     382var
     383  prop: TCustomSerializedObject;
    371384begin
    372385  if layer = nil then
    … …  
    374387  else
    375388  begin
    376     prop := Content.GetObjectField(layer^, 'Layer+properties');
     389    prop := Content.GetObjectField(layer, 'Layer+properties');
    377390    if prop = nil then
    378391      Result := ''
    379392    else
    380393    begin
    381       Result := Content.GetSimpleField(prop^, 'name');
     394      Result := Content.GetSimpleField(prop, 'name');
    382395    end;
    383396  end;
    … …  
    386399function TPaintDotNetFile.LayerDataSize(numLayer: integer): int64;
    387400var
    388   layer, surface, scan0: PSerializedObject;
    389 begin
    390   layer := GetLayer(numLayer);
     401  layer, surface, scan0: TCustomSerializedObject;
     402begin
     403  layer := InternalGetLayer(numLayer);
    391404  if layer = nil then
    392405    Result := 0
    393406  else
    394407  begin
    395     surface := Content.GetObjectField(layer^, 'surface');
     408    surface := Content.GetObjectField(layer, 'surface');
    396409    if surface = nil then
    397410      Result := 0
    398411    else
    399412    begin
    400       scan0  := Content.GetObjectField(surface^, 'scan0');
    401       Result := StrToInt64(Content.GetSimpleField(scan0^, 'length64'));
     413      scan0  := Content.GetObjectField(surface, 'scan0');
     414      Result := StrToInt64(Content.GetSimpleField(scan0, 'length64'));
    402415    end;
    403416  end;
    … …  
    457470end;
    458471
    459 function TPaintDotNetFile.GetLayer(num: integer): PSerializedObject;
    460 var
    461   layerList: PSerializedObject;
     472function TPaintDotNetFile.InternalGetLayer(num: integer): TSerializedClass;
     473var
     474  layerList: TCustomSerializedObject;
    462475begin
    463476  if Layers = nil then
    … …  
    468481  else
    469482  begin
    470     layerList := Content.GetObjectField(Layers^, '_items');
    471     Result    := Content.GetObject(layerList^.fields[num].Value);
    472   end;
    473 end;
    474 
    475 function TPaintDotNetFile.GetBlendOperation(layer: PSerializedObject): TBlendOperation;
    476 var
    477   prop, blendOp: PSerializedObject;
     483    layerList := Content.GetObjectField(Layers, '_items');
     484    Result    := Content.GetObject(layerList.FieldAsString[num]) as TSerializedClass;
     485  end;
     486end;
     487
     488function TPaintDotNetFile.InternalGetBlendOperation(layer: TSerializedClass): TBlendOperation;
     489var
     490  prop, blendOp: TCustomSerializedObject;
    478491  blendName:     string;
    479492begin
    … …  
    482495  else
    483496  begin
    484     prop := Content.GetObjectField(layer^, 'properties');
     497    prop := Content.GetObjectField(layer, 'properties');
    485498    if prop = nil then
    486499      Result := boTransparent
    487500    else
    488501    begin
    489       blendOp := Content.GetObjectField(prop^, 'blendOp');
     502      blendOp := Content.GetObjectField(prop, 'blendOp');
    490503      if blendOp = nil then
    491504        Result := boTransparent
    492505      else
    493506      begin
    494         blendName := Content.GetObjectType(blendOp);
     507        blendName := blendOp.TypeAsString;
    495508        if (pos('+', blendName) <> 0) then
    496509          Delete(blendName, 1, pos('+', blendName));
    … …  
    548561end;
    549562
    550 function TPaintDotNetFile.GetLayerVisible(layer: PSerializedObject): boolean;
    551 var
    552   prop: PSerializedObject;
     563function TPaintDotNetFile.InternalGetLayerVisible(layer: TSerializedClass): boolean;
     564var
     565  prop: TCustomSerializedObject;
    553566begin
    554567  if layer = nil then
    … …  
    556569  else
    557570  begin
    558     prop := Content.GetObjectField(layer^, 'Layer+properties');
     571    prop := Content.GetObjectField(layer, 'Layer+properties');
    559572    if prop = nil then
    560573      Result := False
    561574    else
    562575    begin
    563       Result := (Content.GetSimpleField(prop^, 'visible') = 'True');
    564     end;
    565   end;
    566 end;
    567 
    568 function TPaintDotNetFile.GetLayerOpacity(layer: PSerializedObject): byte;
    569 var
    570   prop: PSerializedObject;
     576      Result := (Content.GetSimpleField(prop, 'visible') = 'True');
     577    end;
     578  end;
     579end;
     580
     581function TPaintDotNetFile.InternalGetLayerOpacity(layer: TSerializedClass): byte;
     582var
     583  prop: TCustomSerializedObject;
    571584begin
    572585  if layer = nil then
    … …  
    574587  else
    575588  begin
    576     prop := Content.GetObjectField(layer^, 'Layer+properties');
     589    prop := Content.GetObjectField(layer, 'Layer+properties');
    577590    if prop = nil then
    578591      Result := 0
    579592    else
    580593    begin
    581       Result := StrToInt(Content.GetSimpleField(prop^, 'opacity'));
    582     end;
    583   end;
    584 end;
    585 
    586 {var fout: TFileStream;
    587     comp: Tcompressionstream;
    588 
    589     gzipHeader: packed record
    590        magicWord: word;
    591        compMethod,flags: byte;
    592        fileModif: Longword;
    593        extraflag,os: byte;
    594     end;                   }
     594      Result := StrToInt(Content.GetSimpleField(prop, 'opacity'));
     595    end;
     596  end;
     597end;
    595598
    596599initialization
    597600
    598 {  gzipHeader.magicWord := $8b1F;
    599   gzipHeader.compMethod := 8;
    600   gzipHeader.flags := 0;
    601   gzipHeader.fileModif := 0;
    602   gzipHeader.extraflag := 0;
    603   gzipHeader.os := $ff;
    604 
    605   fout := TFileStream.Create('testcomp.gz', fmCreate);
    606   fout.Write(gzipHeader,sizeof(gzipHeader));
    607   comp := Tcompressionstream.Create(cldefault,fout,true);
    608   comp.WriteAnsiString('Hello world');
    609   comp.free;
    610   fout.Free;  }
     601  ImageHandlers.RegisterImageReader ('Paint.NET image', 'pdn', TFPReaderPaintDotNet);
    611602
    612603end.
    613604
     605
Note: See TracChangeset for help on using the changeset viewer.