--- Merging r30290 into '.':

U    packages/fcl-image/src/fpreadpng.pp
--- Recording mergeinfo for merge of r30290 into '.':
 U   .
--- Merging r30296 into '.':
U    packages/fcl-image/src/fpwritepng.pp
--- Recording mergeinfo for merge of r30296 into '.':
 G   .
--- Merging r30690 into '.':
U    packages/fcl-image/src/fpreadtiff.pas
--- Recording mergeinfo for merge of r30690 into '.':
 G   .
--- Merging r30692 into '.':
G    packages/fcl-image/src/fpreadtiff.pas
--- Recording mergeinfo for merge of r30692 into '.':
 G   .
--- Merging r30696 into '.':
G    packages/fcl-image/src/fpwritepng.pp
--- Recording mergeinfo for merge of r30696 into '.':
 G   .
--- Merging r30697 into '.':
G    packages/fcl-image/src/fpwritepng.pp
--- Recording mergeinfo for merge of r30697 into '.':
 G   .

# revisions: 30290,30296,30690,30692,30696,30697

git-svn-id: branches/fixes_3_0@31106 -

packages/fcl-image/src/fpreadpng.pp

@@ -403,20 +403,24 @@ end;
 function TFPReaderPNG.CalcColor: TColorData;
 var cd : longword;
     r : word;
-    b : byte;
-    tmp : pbytearray;
+    b : pbyte;
 begin
   if UsingBitGroup = 0 then
     begin
     Databytes := 0;
     if Header.BitDepth = 16 then
       begin
-       getmem(tmp, bytewidth);
-       fillchar(tmp^, bytewidth, 0);
-       for r:=0 to bytewidth-2 do
-        tmp^[r+1]:=FCurrentLine^[Dataindex+r];
-       move (tmp^[0], Databytes, bytewidth);
-       freemem(tmp);
+        b := @Databytes;
+        b^ := 0;
+        r := 0;
+        while (r < ByteWidth-1) do
+        begin
+          b^ := FCurrentLine^[DataIndex+r+1];
+          inc (b);
+          b^ := FCurrentLine^[DataIndex+r];
+          inc (b);
+          inc (r,2);
+        end;
       end
     else move (FCurrentLine^[DataIndex], Databytes, bytewidth);
     {$IFDEF ENDIAN_BIG}

packages/fcl-image/src/fpreadtiff.pas

@@ -213,8 +213,8 @@ begin
   for i:=0 to SampleCnt-1 do begin
     if SampleBits[i]>64 then
       TiffError('Samples bigger than 64 bit not supported');
-    if not (SampleBits[i] in [1, 8, 16]) then
-      TiffError('Only samples of 1, 8 and 16 bit are supported');
+    if not (SampleBits[i] in [1, 8, 12, 16]) then
+      TiffError('Only samples of 1, 8, 12 and 16 bit are supported');
     inc(SampleBitsPerPixel, SampleBits[i]);
   end;
   case IFD.PhotoMetricInterpretation of
@@ -228,8 +228,8 @@ begin
           IFD.AlphaBits:=AlphaBits;
         end;
       end;
-      if not (GrayBits in [1, 8, 16]) then
-        TiffError('gray image only supported with gray BitsPerSample 1, 8 or 16');
+      if not (GrayBits in [1, 8, 12, 16]) then
+        TiffError('gray image only supported with gray BitsPerSample 1, 8, 12 or 16');
       if not (AlphaBits in [0, 8, 16]) then
         TiffError('gray image only supported with alpha BitsPerSample 8 or 16');
     end;
@@ -366,6 +366,7 @@ procedure TFPReaderTiff.ReadImgValue(BitCount: Word; var Run: Pointer; x: dword;
   Predictor: word; var LastValue: word; out Value: Word); inline;
 var
   BitNumber: byte;
+  Byte1, Byte2: byte;
 begin
   case BitCount of
   1:
@@ -391,6 +392,18 @@ begin
       Value:=Value shl 8+Value;
       inc(Run);
     end;
+  12:
+    begin
+      Byte1 := PCUInt8(Run)^;
+      Byte2 := PCUInt8(Run+1)^;
+      if (x mod 2) = 0 then begin
+        Value := (((Byte1) shl 4) or (Byte2 shr 4)) * 16;
+        inc(Run);
+      end else begin
+        Value := (((Byte1 and $0F) shl 8) or Byte2) * 16;
+        inc(Run, 2);
+      end;
+    end;
   16:
     begin
       Value:=FixEndian(PCUInt16(Run)^);
@@ -551,6 +564,9 @@ begin
   if Debug then
     writeln('ReadIFD Start=',Start);
   {$endif}
+  // set default values if not read from file
+  IFD.RowsPerStrip := $FFFFFFFF;
+  
   Result:=0;
   SetStreamPos(Start);
   IFD.IFDStart:=Start;
@@ -1973,7 +1989,7 @@ begin
   for i:=0 to ImageCount-1 do begin
     CurImg:=Images[i];
     NewSize:=Int64(CurImg.ImageWidth)*CurImg.ImageHeight;
-    if (NewSize<BestSize) then continue;
+    if (NewSize<=BestSize) then continue;
     BestSize:=NewSize;
     Best:=i;
   end;

packages/fcl-image/src/fpwritepng.pp

@@ -34,6 +34,7 @@ type
       CFmt : TColorFormat; // format of the colors to convert from
       FFmtColor : TColorFormatFunction;
       FTransparentColor : TFPColor;
+      FTransparentColorOk: boolean;
       FSwitchLine, FCurrentLine, FPreviousLine : pByteArray;
       FPalette : TFPPalette;
       OwnsPalette : boolean;
@@ -83,6 +84,7 @@ type
       property ChunkDataBuffer : pByteArray read FChunk.data;
       property UsetRNS : boolean read FUsetRNS;
       property SingleTransparentColor : TFPColor read FTransparentColor;
+      property SingleTransparentColorOk : boolean read FTransparentColorOk;
       property ThePalette : TFPPalette read FPalette;
       property ColorFormat : TColorformat read CFmt;
       property ColorFormatFunc : TColorFormatFunction read FFmtColor;
@@ -270,18 +272,38 @@ end;
 
 procedure TFPWriterPNG.DetermineHeader (var AHeader : THeaderChunk);
 var c : integer;
+
+  function ReducedColorEquals(const c1,c2: TFPColor): boolean;
+  var g1,g2: word;
+  begin
+    if FGrayScale then
+      begin
+        g1 := CalculateGray(c1);
+        g2 := CalculateGray(c2);
+        if fwordsized then
+          result := (g1 = g2)
+        else
+          result := (g1 shr 8 = g2 shr 8);
+      end else
+      begin
+        if FWordSized then
+          result := (c1.red = c2.red) and (c1.green = c2.green) and (c1.blue = c2.blue)
+        else
+          result := (c1.red shr 8 = c2.red shr 8) and (c1.green shr 8 = c2.green shr 8) and (c1.blue shr 8 = c2.blue shr 8);
+      end;
+  end;
+
   function CountAlphas : integer;
   var none, half : boolean;
-      x,y : longint;  // warning, checks on <0 !
+      maxTransparentAlpha: word;
+
+    procedure CountFromPalettedImage;
+    var
       p : integer;
-      c : TFPColor;
       a : word;
+      c : TFPColor;
   begin
-    half := false;
-    none := false;
-    with TheImage do
-      if UsePalette then
-        with Palette do
+      with TheImage.Palette do
           begin
           p := count-1;
           FTransparentColor.alpha := alphaOpaque;
@@ -289,39 +311,95 @@ var c : integer;
             begin
             c := color[p];
             a := c.Alpha;
-            if a = alphaTransparent then
+          if a <= maxTransparentAlpha then
               begin
               none := true;
+            if a < FTransparentColor.alpha then
               FTransparentColor := c;
               end
-            else if a <> alphaOpaque then
-              begin
-              half := true;
-              if FtransparentColor.alpha < a then
-                FtransparentColor := c;
-              end;
+          else if a <> alphaOpaque then half := true;
             dec (p);
             end;
+
+        //check transparent color is used consistently
+        FTransparentColorOk := true;
+        p := count-1;
+        while (p >= 0) do
+          begin
+          c := color[p];
+          if c.alpha > maxTransparentAlpha then
+          begin
+            if ReducedColorEquals(c, FTransparentColor) then
+              begin
+              FTransparentColorOk := false;
+              break;
+              end;
           end
       else
+        begin
+            if not ReducedColorEquals(c, FTransparentColor) then
+              begin
+              FTransparentColorOk := false;
+              break;
+              end;
+          end;
+          dec(p);
+          end;
+        end;
+    end;
+
+    procedure CountFromRGBImage;
+    var
+      a : word;
+      c : TFPColor;
+      x,y : longint;  // checks on < 0
+    begin
+      with TheImage do
         begin
         x := width-1;
         y := height-1;
         FTransparentColor.alpha := alphaOpaque;
-        while (y >= 0) and not (half and none) do
+        while (y >= 0) and not half do //we stop if we already need a full alpha
           begin
           c := colors[x,y];
           a := c.Alpha;
-          if a = alphaTransparent then
+          if a <= maxTransparentAlpha then
             begin
             none := true;
+            if a < FTransparentColor.alpha then
             FTransparentColor := c;
             end
-          else if a <> alphaOpaque then
+          else if a <> alphaOpaque then half := true;
+          dec (x);
+          if (x < 0) then
             begin
-            half := true;
-            if FtransparentColor.alpha < a then
-              FtransparentColor := c;
+            dec (y);
+            x := width-1;
+            end;
+          end;
+
+        //check transparent color is used consistently
+        FTransparentColorOk := true;
+        x := width-1;
+        y := height-1;
+        while (y >= 0) do
+          begin
+          c := colors[x,y];
+          if c.alpha > maxTransparentAlpha then
+          begin
+            if ReducedColorEquals(c, FTransparentColor) then
+              begin
+              FTransparentColorOk := false;
+              break;
+              end;
+          end
+          else
+          begin
+            if not ReducedColorEquals(c, FTransparentColor) then
+              begin
+              FTransparentColorOk := false;
+              break;
+              end;
             end;
           dec (x);
           if (x < 0) then
@@ -331,11 +409,34 @@ var c : integer;
             end;
           end;
         end;
-      result := 1;
+    end;
+
+  begin
+    FTransparentColorOk := false;
+    if FWordSized then maxTransparentAlpha := 0
+    else maxTransparentAlpha := $00ff;
+    half := false;
+    none := false;
+    with TheImage do
+      if UsePalette then
+        CountFromPalettedImage
+      else
+        CountFromRGBImage;
+
+    if half then //if there are semitransparent colors,
+                 //an alpha channel is needed
+      result := 3
+    else
       if none then
-        inc (result);
-      if half then
-        inc (result);
+      begin
+      if FTransparentColorOk then
+        result := 2 //it is possible to use tRNS only
+                    //if the transparent color is used consistently
+      else
+        result := 3;
+      end
+    else
+      result := 1;
   end;
   procedure DetermineColorFormat;
   begin
@@ -660,7 +761,7 @@ procedure TFPWriterPNG.WritetRNS;
   procedure PaletteAlpha;
   var r : integer;
   begin
-    with TheImage.palette do
+    with FPalette do
       begin
       // search last palette entry with transparency
       r := count;