* Added compact image support by Mattias Gaertner

git-svn-id: trunk@21653 -

packages/fcl-image/examples/drawing.pp

@@ -2,7 +2,7 @@
 program Drawing;
 
 uses classes, sysutils,
-     FPImage, FPCanvas, FPImgCanv,
+     FPImage, FPCanvas, FPImgCanv, ftFont,
      FPWritePNG, FPReadPNG;
 
 const
@@ -13,6 +13,7 @@ var canvas : TFPcustomCAnvas;
     ci, image : TFPCustomImage;
     writer : TFPCustomImageWriter;
     reader : TFPCustomImageReader;
+    f : TFreeTypeFont;
 begin
   image := TFPMemoryImage.Create (100,100);
   ci := TFPMemoryImage.Create (20,20);
@@ -27,7 +28,7 @@ begin
     GrayScale := false;
     end;
   try
-    ci.LoadFromFile ('test.png', reader);
+//    ci.LoadFromFile ('test.png', reader);
     with Canvas as TFPImageCanvas do
       begin
       pen.mode := pmCopy;
@@ -51,11 +52,13 @@ begin
         end;
       pen.style := psSolid;
       RelativeBrushImage := true;
+{
       brush.image := ci;
       brush.style := bsimage;
       with brush.FPColor do
         green := green div 2;
       Ellipse (11,11, 89,89);
+}
 
       brush.style := bsSolid;
       brush.FPColor := MyColor;
@@ -68,8 +71,19 @@ begin
       pen.FPColor := colCyan;
       ellipseC (50,50, 1,1);
 
-      writeln ('Saving to inspect !');
+      InitEngine;
+      F:=TFreeTypeFont.Create;
+      F.Angle:=0.15;
+      Font:=F;
+//      Font.Name:='/usr/share/fonts/truetype/ttf-dejavu/DejaVuSans.ttf';
+      Font.Name:='/home/michael/Documents/arial.ttf';
+      Font.Size:=10;
+      Font.FPColor:=colWhite;
+//      Font.Orientation:=900;
+      
+      Canvas.TextOut(10,90,'o');
       end;
+      writeln ('Saving to inspect !');
     image.SaveToFile ('DrawTest.png', writer);
   finally
     Canvas.Free;
@@ -81,7 +95,7 @@ begin
 end;
 
 begin
-  // DefaultFontPath := 'c:\winnt\fonts\';
+//  DefaultFontPath := '/usr/share/fonts/truetype/ttf-dejavu/';
   DoDraw;
 
 end.

packages/fcl-image/fpmake.pp

@@ -87,6 +87,7 @@ begin
           AddInclude('fphandler.inc');
           AddInclude('fppalette.inc');
           AddInclude('fpcolcnv.inc');
+          AddInclude('fpcompactimg.inc');
         end;
     T:=P.Targets.AddUnit('fpimgcanv.pp');
       with T.Dependencies do

packages/fcl-image/src/fpimage.pp

@@ -343,6 +343,202 @@ function CreateWebSafePalette : TFPPalette;
 function CreateGrayScalePalette : TFPPalette;
 function CreateVGAPalette : TFPPalette;
 
+Type
+  TFPCompactImgDesc = record
+    Gray: boolean; // true = red=green=blue, false: a RGB image
+    Depth: word; // 8 or 16 bit
+    HasAlpha: boolean; // has alpha channel
+  end;
+
+  { TFPCompactImgBase }
+
+  TFPCompactImgBase = class(TFPCustomImage)
+  private
+    FDesc: TFPCompactImgDesc;
+  public
+    property Desc: TFPCompactImgDesc read FDesc;
+  end;
+  TFPCompactImgBaseClass = class of TFPCompactImgBase;
+
+  { TFPCompactImgGray16Bit }
+
+  TFPCompactImgGray16Bit = class(TFPCompactImgBase)
+  protected
+    FData: PWord;
+    function GetInternalColor(x, y: integer): TFPColor; override;
+    function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
+    procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
+    procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
+  public
+    constructor Create(AWidth, AHeight: integer); override;
+    destructor Destroy; override;
+    procedure SetSize(AWidth, AHeight: integer); override;
+  end;
+
+  TFPCompactImgGrayAlpha16BitValue = packed record
+    g,a: word;
+  end;
+  PFPCompactImgGrayAlpha16BitValue = ^TFPCompactImgGrayAlpha16BitValue;
+
+  { TFPCompactImgGrayAlpha16Bit }
+
+  TFPCompactImgGrayAlpha16Bit = class(TFPCompactImgBase)
+  protected
+    FData: PFPCompactImgGrayAlpha16BitValue;
+    function GetInternalColor(x, y: integer): TFPColor; override;
+    function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
+    procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
+    procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
+  public
+    constructor Create(AWidth, AHeight: integer); override;
+    destructor Destroy; override;
+    procedure SetSize(AWidth, AHeight: integer); override;
+  end;
+
+  { TFPCompactImgGray8Bit }
+
+  TFPCompactImgGray8Bit = class(TFPCompactImgBase)
+  protected
+    FData: PByte;
+    function GetInternalColor(x, y: integer): TFPColor; override;
+    function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
+    procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
+    procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
+  public
+    constructor Create(AWidth, AHeight: integer); override;
+    destructor Destroy; override;
+    procedure SetSize(AWidth, AHeight: integer); override;
+  end;
+
+  TFPCompactImgGrayAlpha8BitValue = packed record
+    g,a: byte;
+  end;
+  PFPCompactImgGrayAlpha8BitValue = ^TFPCompactImgGrayAlpha8BitValue;
+
+  { TFPCompactImgGrayAlpha8Bit }
+
+  TFPCompactImgGrayAlpha8Bit = class(TFPCompactImgBase)
+  protected
+    FData: PFPCompactImgGrayAlpha8BitValue;
+    function GetInternalColor(x, y: integer): TFPColor; override;
+    function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
+    procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
+    procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
+  public
+    constructor Create(AWidth, AHeight: integer); override;
+    destructor Destroy; override;
+    procedure SetSize(AWidth, AHeight: integer); override;
+  end;
+
+  TFPCompactImgRGBA8BitValue = packed record
+    r,g,b,a: byte;
+  end;
+  PFPCompactImgRGBA8BitValue = ^TFPCompactImgRGBA8BitValue;
+
+  { TFPCompactImgRGBA8Bit }
+
+  TFPCompactImgRGBA8Bit = class(TFPCompactImgBase)
+  protected
+    FData: PFPCompactImgRGBA8BitValue;
+    function GetInternalColor(x, y: integer): TFPColor; override;
+    function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
+    procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
+    procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
+  public
+    constructor Create(AWidth, AHeight: integer); override;
+    destructor Destroy; override;
+    procedure SetSize(AWidth, AHeight: integer); override;
+  end;
+
+  TFPCompactImgRGB8BitValue = packed record
+    r,g,b: byte;
+  end;
+  PFPCompactImgRGB8BitValue = ^TFPCompactImgRGB8BitValue;
+
+  { TFPCompactImgRGB8Bit }
+
+  TFPCompactImgRGB8Bit = class(TFPCompactImgBase)
+  protected
+    FData: PFPCompactImgRGB8BitValue;
+    function GetInternalColor(x, y: integer): TFPColor; override;
+    function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
+    procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
+    procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
+  public
+    constructor Create(AWidth, AHeight: integer); override;
+    destructor Destroy; override;
+    procedure SetSize(AWidth, AHeight: integer); override;
+  end;
+
+  TFPCompactImgRGB16BitValue = packed record
+    r,g,b: word;
+  end;
+  PFPCompactImgRGB16BitValue = ^TFPCompactImgRGB16BitValue;
+
+  { TFPCompactImgRGB16Bit }
+
+  TFPCompactImgRGB16Bit = class(TFPCompactImgBase)
+  protected
+    FData: PFPCompactImgRGB16BitValue;
+    function GetInternalColor(x, y: integer): TFPColor; override;
+    function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
+    procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
+    procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
+  public
+    constructor Create(AWidth, AHeight: integer); override;
+    destructor Destroy; override;
+    procedure SetSize(AWidth, AHeight: integer); override;
+  end;
+
+  { TFPCompactImgRGBA16Bit }
+
+  TFPCompactImgRGBA16Bit = class(TFPCompactImgBase)
+  protected
+    FData: PFPColor;
+    function GetInternalColor(x, y: integer): TFPColor; override;
+    function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override;
+    procedure SetInternalColor (x, y: integer; const Value: TFPColor); override;
+    procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override;
+  public
+    constructor Create(AWidth, AHeight: integer); override;
+    destructor Destroy; override;
+    procedure SetSize(AWidth, AHeight: integer); override;
+  end;
+
+{ Create a descriptor to select a CompactImg class }
+function GetFPCompactImgDesc(Gray: boolean; Depth: word; HasAlpha: boolean): TFPCompactImgDesc;
+
+{ Returns a CompactImg class that fits the descriptor }
+function GetFPCompactImgClass(const Desc: TFPCompactImgDesc): TFPCompactImgBaseClass;
+
+{ Create a CompactImg with the descriptor }
+function CreateFPCompactImg(const Desc: TFPCompactImgDesc; Width, Height: integer): TFPCustomImage;
+
+{ Create a CompactImg with the same features as Img.
+If Img is a TFPCompactImgBaseClass it will create that.
+Otherwise it returns a CompactImg that fits the Img using GetMinimumPTDesc. }
+function CreateCompatibleFPCompactImg(Img: TFPCustomImage; Width, Height: integer
+): TFPCustomImage;
+
+{ As CreateCompatibleFPCompactImg, but the image has always an alpha channel. }
+function CreateCompatibleFPCompactImgWithAlpha(Img: TFPCustomImage;
+Width, Height: integer): TFPCustomImage;
+
+{ Returns the smallest descriptor that allows to store the Img.
+It returns HasAlpha=false if all pixel are opaque.
+It returns Gray=true if all red=green=blue.
+It returns Depth=8 if all lo byte equals the hi byte or all lo bytes are 0.
+To ignore rounding errors you can pass a FuzzyDepth. For example a FuzzyDepth
+of 3 ignores the lower 3 bits when comparing.  }
+function GetMinimumPTDesc(Img: TFPCustomImage; FuzzyDepth: word = 4): TFPCompactImgDesc;
+
+{ Create a smaller CompactImg with the same information as Img.
+Pass FreeImg=true to call Img.Free }
+function GetMinimumFPCompactImg(Img: TFPCustomImage; FreeImg: boolean;
+FuzzyDepth: word = 4): TFPCustomImage;
+
+
+
 implementation
 
 procedure FPImgError (Fmt:TErrorTextIndices; data : array of const);
@@ -359,6 +555,7 @@ end;
 {$i FPHandler.inc}
 {$i FPPalette.inc}
 {$i FPColCnv.inc}
+{$i fpcompactimg.inc}
 
 function FPColor (r,g,b:word) : TFPColor;
 begin