lcl: apply patch of Dmitry to support .icns writer (mantis #0014638)

git-svn-id: trunk@21795 -

lcl/icnstypes.pas

@@ -175,8 +175,70 @@ const
 
 function GetIcnsIconType(const StrIconType: FourCharCode): TicnsIconType;
 
+// Returns proper TicnsIconType, or iitNone, if Width/Height is incorrect
+function GetDataTypeRGB(Width, Height: Integer; var FourChar: FourCharCode): TicnsIconType;
+function GetMaskType8bit(Width, Height: Integer; var FourChar: FourCharCode): TicnsIconType;
+
 implementation
 
+function GetDataTypeRGB(Width, Height: Integer; var FourChar: FourCharCode): TicnsIconType;
+begin
+  Result := iitNone;
+  if Width <> Height then Exit;
+  
+  case Width of
+    16: begin
+      Result := iitSmall32BitData;
+      FourChar := kSmall32BitData;
+    end;
+    32: begin
+      Result := iitLarge32BitData;
+      FourChar := kLarge32BitData;
+    end;
+    48: begin
+      Result := iitHuge32BitData;
+      FourChar := kHuge32BitData;
+    end;      
+    128: begin
+      Result := iitThumbnail32BitData;
+      FourChar := kThumbnail32BitData;
+    end;
+    256: begin
+      Result := iit256PixelDataARGB;
+      FourChar :=  kIconServices256PixelDataARGB;
+    end;
+    512: begin
+      Result := iit512PixelDataARGB;
+      FourChar := kIconServices512PixelDataARGB;
+    end;
+  end; 
+end;
+
+function GetMaskType8bit(Width, Height: Integer; var FourChar: FourCharCode): TicnsIconType;
+begin
+  Result := iitNone;
+  if Width <> Height then Exit;
+  
+  case Width of
+    16: begin
+      Result := iitSmall8BitMask;
+      FourChar := kSmall8BitMask;
+    end;
+    32: begin
+      Result := iitLarge8BitMask;
+      FourChar := kLarge8BitMask;
+    end;
+    48: begin
+      Result := iitHuge8BitMask;
+      FourChar := kHuge8BitMask;
+    end;
+    128: begin
+      Result := iitThumbnail8BitMask;
+      FourChar := kThumbnail8BitMask;
+    end;
+  end; 
+end;
+
 function GetIcnsIconType(const StrIconType: FourCharCode): TicnsIconType;
 begin
   Result := iitNone;

lcl/include/icnsicon.inc

@@ -233,9 +233,239 @@ begin
   IcnsProcess;
 end;
 
-procedure TIcnsIcon.WriteStream(AStream: TMemoryStream);
+
+// only 24 bit RGB is RLE encoded the same way as TIFF or TGA RLE
+// data is encoded channel by channel:
+// high bit = 0 => length = low 0..6 bits + 1; read length times next value
+// high bit = 1 => length = value - 125      ; read one value and repeat length times
+
+function EncodeTiffRLE(const Src: array of byte; Offset, Count: Integer; var Dst: array of Byte; DstOffset: Integer): Integer;
+var
+  cnt   : Integer;
+  i,j,k : Integer;
+  d     : Integer;
+  last  : Integer;
+const
+  LenRLEOffset = 125;
+  MaxRLEDiff   = 255-LenRLEOffset;
+
 begin
-  //
+  if Count = 0 then 
+  begin
+    Result := 0;
+    Exit;
+  end;
+  i := Offset;
+  d := DstOffset;
+  last := Offset+Count;
+
+  while i < last do 
+  begin
+    if (i < last-2) and (Src[i] = Src[i+1]) and (Src[i]=Src[i+2]) then 
+    begin
+      j := i;
+      inc(i);
+      while (i < last) and (Src[i] = Src[i-1]) do 
+        inc(i);
+      cnt := i - j;
+      while cnt > 0 do 
+      begin
+        k := Min(MaxRLEDiff, cnt);
+        if k > 2 then 
+        begin
+          Dst[d] := byte(k+LenRLEOffset); inc(d);
+          Dst[d] := Src[j]; inc(d);
+          dec(cnt, k);
+        end 
+        else 
+        begin
+          dec(i,k);
+          cnt := 0;
+          k := 0;
+        end;
+      end;
+
+    end 
+    else 
+    begin
+      j := i;
+      if (i < last-1) and (Src[i] = Src[i+1]) then 
+        inc(i);
+
+      if last-i > 2 then 
+      begin
+        inc(i);
+        while (i < last) and (Src[i] <> Src[i-1]) do inc(i);
+        if i < last then dec(i);
+      end 
+      else
+        i := last;
+
+      cnt := i - j;
+      while cnt > 0 do 
+      begin
+        k := Min(128, cnt);
+        Dst[d] := k-1;
+        inc(d);
+        Move(Src[j], Dst[d], k);
+        inc(j, k);
+        inc(d, k);
+        dec(cnt, k);
+      end;
+    end;
+  end;
+
+  Result := d - DstOffset;
+end;
+
+{ !!! WARNING !!! the following code might be INTEL ONLY! Needs to be tested on PowerPC }
+function CompressRGBImage(RGBAImage: TLazIntfImage; Stream: TStream): Int64;
+var
+  src : array of byte;
+  dst : array of byte;
+  i   : Integer;
+  raw : TRawImage;
+  sz  : Integer;
+  pb  : PByteArray;
+  k   : Integer;
+  j   : Integer;
+  StreamPos : Int64;  
+begin
+  StreamPos := Stream.Position;
+  sz :=  RGBAImage.Width*RGBAImage.Height;
+  SetLength(src, sz);
+  SetLength(dst, sz*2);
+  RGBAImage.GetRawImage(raw, false);
+  pb:=PByteArray(raw.Data);
+
+  { red , green, blue values are in separate RLE blocks } 
+  for i := 0 to 2 do
+  begin
+    k:=i+1; {the first element is Alpha, skip it}
+    for j := 0 to sz - 1 do 
+    begin
+      src[j]:=pb^[k];
+      inc(k,4);
+    end;
+    k := EncodeTiffRLE(src, 0, sz, dst, 0);
+    Stream.Write(dst[0], k);
+  end;
+  
+  Result := Stream.Position-StreamPos;
+  Stream.Position:=StreamPos;
+end;
+
+{ !!! WARNING !!! the following code might be INTEL ONLY! Needs to be tested on PowerPC }
+function CompressMaskImage(RGBAImage: TLazIntfImage; Stream: TStream): Int64;
+var
+  src : array of Byte;
+  i   : Integer;
+  arr : PIntegerArray;
+  row : TRawImage;
+  StreamPos : Int64;
+begin
+  StreamPos := Stream.Position;
+  SetLength(src, RGBAImage.Width*RGBAImage.Height);
+  RGBAImage.GetRawImage(row, false);
+  arr := PIntegerArray(row.Data);
+
+  for i := 0 to length(src) - 1 do 
+    //src[i] := byte((arr^[i] shr 24) and $FF);
+    src[i] := byte( arr^[i] and $FF);
+    //src[i]:=255;
+  Stream.Write(src[0], length(src));
+  
+  Result := Stream.Position-StreamPos;
+  Stream.Position:=StreamPos;
+end;
+
+procedure TIcnsIcon.WriteStream(AStream: TMemoryStream);
+var
+  mem         : array [0..63] of TMemoryStream;
+  icnType     : TicnsIconType;
+  id          : array [0..63] of FourCharCode;
+  FCode       : FourCharCode;
+  el          : TIconFamilyElement;
+  i, j, n     : integer;
+  totalsz     : LongWord;
+  ImageCount  : Integer;
+  RawImg      : TRawImage;
+  IconImage   : TIconImage;
+
+  IntfImage   : TLazIntfImage;
+  SrcImage    : TLazIntfImage;
+begin
+  ImageCount := TSharedIcon(FSharedImage).Count;
+  if ImageCount = 0 then Exit;
+
+  IntfImage:=nil;
+  j := 0;
+  System.FillChar(mem, sizeof(mem), 0);
+
+  for n := 0 to ImageCount - 1 do
+  begin
+    IconImage := TIconImage(TSharedIcon(FSharedImage).FImages[n]);
+    icnType := GetDataTypeRGB(IconImage.Width, IconImage.Height, FCode);
+    
+    if icnType = iitNone then Continue; {image is improper size. Skip it}
+    
+    IconImage.RawImageNeeded(false);
+    RawImg := IconImage.FImage;
+    IntfImage := TLazIntfImage.Create(IconImage.Width, IconImage.Height, [riqfRGB, riqfAlpha, riqfUpdate]);
+    IntfImage.CreateData;
+    try
+      SrcImage := TLazIntfImage.Create(RawImg, False);    
+      try
+        IntfImage.CopyPixels( SrcImage, 0,0, true);
+      finally
+        SrcImage.Free;
+      end;
+
+      // write image data
+      if (IconImage.Width >= 256)
+      then begin
+        // todo: Jpeg2000
+      end
+      else begin
+        { compressing RGB data value }
+        id[j] := FCode;
+        mem[j]:= TMemoryStream.Create;
+
+        // Apple bug? preceding 4 zero-bytes is required for 128x128 icon
+        if IconImage.Width = 128 then mem[j].WriteDWord(0);
+        CompressRGBImage(IntfImage, mem[j]);
+        mem[j].Position:=0;
+        inc(j);
+        
+        { compressing Mask data value }
+        GetMaskType8bit(IconImage.Height, IconImage.Width, id[j]);
+        mem[j]:=TMemoryStream.Create;           
+        CompressMaskImage(IntfImage, mem[j]);
+        inc(j);
+      end;
+    finally
+      IntfImage.Free;
+    end;
+  end;
+  
+  if j = 0 then Exit; {no images to write}
+
+  totalsz := sizeof(TIconFamilyElement);
+  for i := 0 to j - 1 do
+    inc(totalsz, mem[i].Size + sizeof(TIconFamilyElement));
+
+  el.elementType := kIconFamilyType;
+  el.elementSize := BEtoN(totalsz); {sizes are big-endian}
+  AStream.Write(el, sizeof(el));
+
+  for i := 0 to j - 1 do begin
+    el.elementType := id[i];
+    el.elementSize := BEtoN( LongWord(mem[i].Size + sizeof(TIconFamilyElement)) ); {sizes are big-endian }
+    AStream.Write( el, sizeof(el) );
+    AStream.CopyFrom(mem[i], mem[i].Size)
+  end;
+
+  for i := 0 to j - 1 do mem[i].Free;
 end;
 
 class function TIcnsIcon.GetFileExtensions: string;