1{%MainUnit ../graphics.pp} 2 3{****************************************************************************** 4 TicnsIcon 5 ****************************************************************************** 6 7 ***************************************************************************** 8 This file is part of the Lazarus Component Library (LCL) 9 10 See the file COPYING.modifiedLGPL.txt, included in this distribution, 11 for details about the license. 12 ***************************************************************************** 13} 14 15{ TIcnsList } 16 17function TIcnsList.GetItem(Index: Integer): PIcnsRec; 18begin 19 Result := inherited Get(Index); 20end; 21 22procedure TIcnsList.SetItem(Index: Integer; const AValue: PIcnsRec); 23begin 24 inherited Put(Index, AValue); 25end; 26 27procedure TIcnsList.Notify(Ptr: Pointer; Action: TListNotification); 28begin 29 if Action = lnDeleted then 30 Dispose(PIcnsRec(Ptr)); 31 inherited Notify(Ptr, Action); 32end; 33 34function TIcnsList.Add(AIconType: TicnsIconType; ARawImage: TRawImage): Integer; 35var 36 Rec: PIcnsRec; 37begin 38 New(Rec); 39 Rec^.IconType := AIconType; 40 Rec^.RawImage := ARawImage; 41 Result := inherited Add(Rec); 42end; 43 44{ TIcnsIcon } 45 46procedure TIcnsIcon.IcnsAdd(AIconType: TicnsIconType; ARawImage: TRawImage); 47 48 function GetMaskList: TIcnsList; 49 begin 50 if FMaskList = nil then 51 FMaskList := TIcnsList.Create; 52 Result := FMaskList; 53 end; 54 55 function GetImageList: TIcnsList; 56 begin 57 if FImageList = nil then 58 FImageList := TIcnsList.Create; 59 Result := FImageList; 60 end; 61 62begin 63 if AIconType in icnsMaskTypes 64 then GetMaskList.Add(AIconType, ARawImage) 65 else GetImageList.Add(AIconType, ARawImage); 66end; 67 68procedure TIcnsIcon.IcnsProcess; 69 70 procedure MergeMask(var AImage, AMask: TRawImage); 71 var 72 LazIntfImage, LazIntfMask: TLazIntfImage; 73 Col, Row: Integer; 74 Color: TFpColor; 75 begin 76 if AMask.Description.Depth = 1 then 77 begin 78 // merge mask 79 AImage.Description.MaskBitOrder := AMask.Description.MaskBitOrder; 80 AImage.Description.MaskLineEnd := AMask.Description.MaskLineEnd; 81 AImage.Description.MaskBitsPerPixel := AMask.Description.MaskBitsPerPixel; 82 AImage.Description.MaskShift := AMask.Description.MaskShift; 83 AImage.MaskSize := AMask.MaskSize; 84 AImage.Mask := ReallocMem(AImage.Mask, AMask.MaskSize); 85 Move(AMask.Mask^, AImage.Mask^, AMask.MaskSize); 86 end 87 else 88 begin 89 LazIntfImage := TLazIntfImage.Create(AImage, False); 90 LazIntfMask := TLazIntfImage.Create(AMask, False); 91 for Row := 0 to LazIntfImage.Height - 1 do 92 for Col := 0 to LazIntfImage.Width - 1 do 93 begin 94 Color := LazIntfImage.Colors[Col,Row]; 95 Color.alpha := LazIntfMask.Colors[Col,Row].alpha; 96 LazIntfImage.Colors[Col,Row] := Color; 97 end; 98 LazIntfMask.Free; 99 LazIntfImage.Free; 100 end; 101 end; 102 103var 104 i, AIndex: integer; 105 ImagesForMask: TicnsIconTypes; 106 IconImage: TIconImage; 107begin 108 // merge separate image and masc rawdata together 109 110 if FMaskList <> nil then 111 begin 112 for i := 0 to FMaskList.Count - 1 do 113 begin 114 ImagesForMask := icnsMaskToImageMap[FMaskList[i]^.IconType]; 115 for AIndex := 0 to FImageList.Count - 1 do 116 if FImageList[AIndex]^.IconType in ImagesForMask then 117 MergeMask(FImageList[AIndex]^.RawImage, FMaskList[i]^.RawImage); 118 // dispose RawImage since no more needed 119 FMaskList[i]^.RawImage.FreeData; 120 end; 121 FreeAndNil(FMaskList); 122 end; 123 124 for i := 0 to FImageList.Count - 1 do 125 begin 126 if FImageList[i]^.IconType in icnsWithAlpha then 127 begin 128 // todo: we have no jpeg 2000 reader to decompress their data => skip for now 129 FImageList[i]^.RawImage.FreeData; 130 Continue; 131 end; 132 133 // Add image 134 with TSharedIcon(FSharedImage) do 135 begin 136 IconImage := GetImagesClass.Create(FImageList[i]^.RawImage); 137 Add(IconImage); 138 end; 139 end; 140 FreeAndNil(FImageList); 141 CheckRequestedSize; 142 FCurrent := GetBestIndexForSize(FRequestedSize); 143end; 144 145class function TIcnsIcon.GetSharedImageClass: TSharedRasterImageClass; 146begin 147 Result := TSharedIcnsIcon; 148end; 149 150constructor TIcnsIcon.Create; 151begin 152 inherited Create; 153 FImageList := nil; 154 FMaskList := nil; 155end; 156 157destructor TIcnsIcon.Destroy; 158begin 159 inherited Destroy; 160 FImageList.Free; 161 FMaskList.Free; 162end; 163 164procedure TIcnsIcon.ReadData(Stream: TStream); 165var 166 Resource: TIconFamilyResource; 167 Position: Int64; 168begin 169 Position := Stream.Position; 170 Stream.Read(Resource, SizeOf(Resource)); 171 if Resource.resourceType = kIconFamilyType then 172 begin 173 Stream.Position := Position; 174 LoadFromStream(Stream, BEtoN(Resource.resourceSize)) 175 end else 176 begin 177 Stream.Position := Position; 178 LoadFromStream(Stream); 179 end; 180end; 181 182procedure TIcnsIcon.ReadStream(AStream: TMemoryStream; ASize: Longint); 183var 184 Resource: TIconFamilyResource; 185 186 IntfImage: TLazIntfImage; 187 ImgReader: TLazReaderIcnsPart; 188 LazReader: ILazImageReader; 189 RawImg: TRawImage; 190begin 191 AStream.Read(Resource, SizeOf(Resource)); 192 193 if (Resource.resourceType <> kIconFamilyType) then 194 raise EInvalidGraphic.Create('Stream is not an ICNS type'); 195 196 IntfImage := nil; 197 ImgReader := nil; 198 199 Resource.resourceSize := BEtoN(Resource.resourceSize); 200 201 if ASize > Resource.resourceSize then 202 ASize := Resource.resourceSize; 203 204 while AStream.Position < ASize do 205 begin 206 if IntfImage = nil 207 then IntfImage := TLazIntfImage.Create(0,0,[]) 208 else IntfImage.SetSize(0,0); 209 210 if ImgReader = nil 211 then ImgReader := TLazReaderIcnsPart.Create; 212 213 if Supports(ImgReader, ILazImageReader, LazReader) 214 then LazReader.UpdateDescription := True 215 else IntfImage.DataDescription := QueryDescription([riqfRGB, riqfAlpha, riqfMask]); // fallback to default 216 217 ImgReader.ImageRead(AStream, IntfImage); 218 IntfImage.GetRawImage(RawImg, True); 219 220 IcnsAdd(ImgReader.IconType, RawImg); 221 end; 222 223 LazReader := nil; 224 IntfImage.Free; 225 ImgReader.Free; 226 227 IcnsProcess; 228end; 229 230 231// only 24 bit RGB is RLE encoded the same way as TIFF or TGA RLE 232// data is encoded channel by channel: 233// high bit = 0 => length = low 0..6 bits + 1; read length times next value 234// high bit = 1 => length = value - 125 ; read one value and repeat length times 235 236function EncodeTiffRLE(const Src: array of byte; Offset, Count: Integer; var Dst: array of Byte; DstOffset: Integer): Integer; 237var 238 cnt : Integer; 239 i,j,k : Integer; 240 d : Integer; 241 last : Integer; 242const 243 LenRLEOffset = 125; 244 MaxRLEDiff = 255-LenRLEOffset; 245 246begin 247 if Count = 0 then 248 begin 249 Result := 0; 250 Exit; 251 end; 252 i := Offset; 253 d := DstOffset; 254 last := Offset+Count; 255 256 while i < last do 257 begin 258 if (i < last-2) and (Src[i] = Src[i+1]) and (Src[i]=Src[i+2]) then 259 begin 260 j := i; 261 inc(i); 262 while (i < last) and (Src[i] = Src[i-1]) do 263 inc(i); 264 cnt := i - j; 265 while cnt > 0 do 266 begin 267 k := Min(MaxRLEDiff, cnt); 268 if k > 2 then 269 begin 270 Dst[d] := byte(k+LenRLEOffset); inc(d); 271 Dst[d] := Src[j]; inc(d); 272 dec(cnt, k); 273 end 274 else 275 begin 276 dec(i,k); 277 cnt := 0; 278 k := 0; 279 end; 280 end; 281 282 end 283 else 284 begin 285 j := i; 286 if (i < last-1) and (Src[i] = Src[i+1]) then 287 inc(i); 288 289 if last-i > 2 then 290 begin 291 inc(i); 292 while (i < last) and (Src[i] <> Src[i-1]) do inc(i); 293 if i < last then dec(i); 294 end 295 else 296 i := last; 297 298 cnt := i - j; 299 while cnt > 0 do 300 begin 301 k := Min(128, cnt); 302 Dst[d] := k-1; 303 inc(d); 304 Move(Src[j], Dst[d], k); 305 inc(j, k); 306 inc(d, k); 307 dec(cnt, k); 308 end; 309 end; 310 end; 311 312 Result := d - DstOffset; 313end; 314 315{ !!! WARNING !!! the following code might be INTEL ONLY! Needs to be tested on PowerPC } 316function CompressRGBImage(RGBAImage: TLazIntfImage; Stream: TStream): Int64; 317var 318 src : array of byte; 319 dst : array of byte; 320 i : Integer; 321 raw : TRawImage; 322 sz : Integer; 323 pb : PByteArray; 324 k : Integer; 325 j : Integer; 326 StreamPos : Int64; 327begin 328 StreamPos := Stream.Position; 329 sz := RGBAImage.Width*RGBAImage.Height; 330 SetLength(src, sz); 331 SetLength(dst, sz*2); 332 RGBAImage.GetRawImage(raw, false); 333 pb:=PByteArray(raw.Data); 334 335 { red , green, blue values are in separate RLE blocks } 336 for i := 0 to 2 do 337 begin 338 k:=i+1; {the first element is Alpha, skip it} 339 for j := 0 to sz - 1 do 340 begin 341 src[j]:=pb^[k]; 342 inc(k,4); 343 end; 344 k := EncodeTiffRLE(src, 0, sz, dst, 0); 345 Stream.Write(dst[0], k); 346 end; 347 348 Result := Stream.Position-StreamPos; 349 Stream.Position:=StreamPos; 350end; 351 352{ !!! WARNING !!! the following code might be INTEL ONLY! Needs to be tested on PowerPC } 353function CompressMaskImage(RGBAImage: TLazIntfImage; Stream: TStream): Int64; 354var 355 src : array of Byte; 356 i : Integer; 357 arr : PIntegerArray; 358 row : TRawImage; 359 StreamPos : Int64; 360begin 361 StreamPos := Stream.Position; 362 SetLength(src, RGBAImage.Width*RGBAImage.Height); 363 RGBAImage.GetRawImage(row, false); 364 arr := PIntegerArray(row.Data); 365 366 for i := 0 to length(src) - 1 do 367 //src[i] := byte((arr^[i] shr 24) and $FF); 368 src[i] := byte( arr^[i] and $FF); 369 //src[i]:=255; 370 Stream.Write(src[0], length(src)); 371 372 Result := Stream.Position-StreamPos; 373 Stream.Position:=StreamPos; 374end; 375 376procedure TIcnsIcon.WriteStream(AStream: TMemoryStream); 377var 378 mem : array [0..63] of TMemoryStream; 379 icnType : TicnsIconType; 380 id : array [0..63] of FourCharCode; 381 FCode : FourCharCode; 382 el : TIconFamilyElement; 383 i, j, n : integer; 384 totalsz : LongWord; 385 ImageCount : Integer; 386 RawImg : TRawImage; 387 IconImage : TIconImage; 388 389 IntfImage : TLazIntfImage; 390 SrcImage : TLazIntfImage; 391begin 392 ImageCount := TSharedIcon(FSharedImage).Count; 393 if ImageCount = 0 then Exit; 394 395 IntfImage:=nil; 396 j := 0; 397 System.FillChar(mem, sizeof(mem), 0); 398 399 for n := 0 to ImageCount - 1 do 400 begin 401 IconImage := TIconImage(TSharedIcon(FSharedImage).FImages[n]); 402 icnType := GetDataTypeRGB(IconImage.Width, IconImage.Height, FCode); 403 404 if icnType = iitNone then Continue; {image is improper size. Skip it} 405 406 IconImage.RawImageNeeded(false); 407 RawImg := IconImage.FImage; 408 IntfImage := TLazIntfImage.Create(IconImage.Width, IconImage.Height, [riqfRGB, riqfAlpha, riqfUpdate]); 409 IntfImage.CreateData; 410 try 411 SrcImage := TLazIntfImage.Create(RawImg, False); 412 try 413 IntfImage.CopyPixels( SrcImage, 0,0, true); 414 finally 415 SrcImage.Free; 416 end; 417 418 // write image data 419 if (IconImage.Width >= 256) 420 then begin 421 // todo: Jpeg2000 422 end 423 else begin 424 { compressing RGB data value } 425 id[j] := FCode; 426 mem[j]:= TMemoryStream.Create; 427 428 // Apple bug? preceding 4 zero-bytes is required for 128x128 icon 429 if IconImage.Width = 128 then mem[j].WriteDWord(0); 430 CompressRGBImage(IntfImage, mem[j]); 431 mem[j].Position:=0; 432 inc(j); 433 434 { compressing Mask data value } 435 GetMaskType8bit(IconImage.Height, IconImage.Width, id[j]); 436 mem[j]:=TMemoryStream.Create; 437 CompressMaskImage(IntfImage, mem[j]); 438 inc(j); 439 end; 440 finally 441 IntfImage.Free; 442 end; 443 end; 444 445 if j = 0 then Exit; {no images to write} 446 447 totalsz := sizeof(TIconFamilyElement); 448 for i := 0 to j - 1 do 449 inc(totalsz, mem[i].Size + sizeof(TIconFamilyElement)); 450 451 el.elementType := kIconFamilyType; 452 el.elementSize := BEtoN(totalsz); {sizes are big-endian} 453 AStream.Write(el, sizeof(el)); 454 455 for i := 0 to j - 1 do begin 456 el.elementType := id[i]; 457 el.elementSize := BEtoN( LongWord(mem[i].Size + sizeof(TIconFamilyElement)) ); {sizes are big-endian } 458 AStream.Write( el, sizeof(el) ); 459 AStream.CopyFrom(mem[i], mem[i].Size) 460 end; 461 462 for i := 0 to j - 1 do mem[i].Free; 463end; 464 465class function TIcnsIcon.GetFileExtensions: string; 466begin 467 Result := 'icns'; 468end; 469 470function TIcnsIcon.LazarusResourceTypeValid(const ResourceType: string): boolean; 471begin 472 Result := (UpperCase(ResourceType) = 'ICNS'); 473end; 474