src/lib/vampimg/ImagingXpm.pas

   1 {
   2   $Id: ImagingXpm.pas 171 2009-09-02 01:34:19Z galfar $
   3   Vampyre Imaging Library
   4   by Marek Mauder
   5   http://imaginglib.sourceforge.net
   6
   7   The contents of this file are used with permission, subject to the Mozilla
   8   Public License Version 1.1 (the "License"); you may not use this file except
   9   in compliance with the License. You may obtain a copy of the License at
  10   http://www.mozilla.org/MPL/MPL-1.1.html
  11
  12   Software distributed under the License is distributed on an "AS IS" basis,
  13   WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  14   the specific language governing rights and limitations under the License.
  15
  16   Alternatively, the contents of this file may be used under the terms of the
  17   GNU Lesser General Public License (the  "LGPL License"), in which case the
  18   provisions of the LGPL License are applicable instead of those above.
  19   If you wish to allow use of your version of this file only under the terms
  20   of the LGPL License and not to allow others to use your version of this file
  21   under the MPL, indicate your decision by deleting  the provisions above and
  22   replace  them with the notice and other provisions required by the LGPL
  23   License.  If you do not delete the provisions above, a recipient may use
  24   your version of this file under either the MPL or the LGPL License.
  25
  26   For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
  27 }
  28
  29 { This unit contains image format loader for X Window Pixmap images. }
  30 unit ImagingXpm;
  31 {$I ImagingOptions.inc}
  32
  33 interface
  34
  35 uses
  36   SysUtils, Classes, Contnrs, ImagingTypes, Imaging, ImagingUtility,
  37   ImagingFormats, ImagingIO, ImagingCanvases;
  38
  39 type
  40   { Class for loading X Window Pixmap images known as XPM.
  41     It is ASCII-text-based format, basicaly a fragment of C code
  42     declaring static array. Loaded image is in ifA8R8G8B8 data format.
  43     Loading as well as saving is supported now. }
  44   TXPMFileFormat = class(TImageFileFormat)
  45   protected
  46     function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
  47       OnlyFirstLevel: Boolean): Boolean; override;
  48     function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
  49       Index: LongInt): Boolean; override;
  50     procedure ConvertToSupported(var Image: TImageData;
  51       const Info: TImageFormatInfo); override;
  52   public
  53     constructor Create; override;
  54     function TestFormat(Handle: TImagingHandle): Boolean; override;
  55   end;
  56
  57 implementation
  58
  59 const
  60   SXPMFormatName = 'X Window Pixmap';
  61   SXPMMasks = '*.xpm';
  62   XPMSupportedFormats: TImageFormats = [ifA8R8G8B8];
  63
  64 const
  65   SXPMId = '/* XPM */';
  66   WhiteSpaces = [#9, #10, #13, #32];
  67
  68 const
  69   BucketCount = 257;
  70
  71 type
  72   TColorHolder = class
  73   public
  74     Color: TColor32;
  75   end;
  76
  77   TBucketItem = record
  78     Key: TColor32;
  79     Data: string[8];
  80   end;
  81
  82   TBucketItemArray = array of TBucketItem;
  83
  84   TBucket = record
  85     Count: Integer;
  86     ItemIdxStart: Integer;
  87     Items: TBucketItemArray;
  88   end;
  89
  90   TBucketArray = array of TBucket;
  91
  92   { Simple color-string hash table for faster than linear searches
  93     during XPM saving. }
  94   TSimpleBucketList = class
  95   private
  96     FBuckets: TBucketArray;
  97     FItemCount: Integer;
  98     FABucket, FAIndex: Integer;
  99     function GetData(AKey: TColor32): string;
 100     procedure SetData(AKey: TColor32; const AData: string);
 101     function FindItem(AKey: TColor32; out ABucket, AIndex: Integer): Boolean;
 102   public
 103     constructor Create;
 104     procedure Add(AKey: TColor32; const AData: string);
 105     function Exists(AKey: TColor32): Boolean;
 106     function EnumNext(out AData: string): TColor32;
 107     property Data[AKey: TColor32]: string read GetData write SetData; default;
 108     property ItemCount: Integer read FItemCount;
 109   end;
 110
 111   { TSimpleBucketList }
 112
 113 constructor TSimpleBucketList.Create;
 114 begin
 115   SetLength(FBuckets, BucketCount);
 116 end;
 117
 118 function TSimpleBucketList.GetData(AKey: TColor32): string;
 119 var
 120   Bucket, Index: Integer;
 121 begin
 122   Result := '';
 123   if FindItem(AKey, Bucket, Index) then
 124     Result := FBuckets[Bucket].Items[Index].Data;
 125 end;
 126
 127 procedure TSimpleBucketList.SetData(AKey: TColor32; const AData: string);
 128 var
 129   Bucket, Index: Integer;
 130 begin
 131   if FindItem(AKey, Bucket, Index) then
 132     FBuckets[Bucket].Items[Index].Data := AData;
 133 end;
 134
 135 function TSimpleBucketList.EnumNext(out AData: string): TColor32;
 136 begin
 137   // Skip empty buckets
 138   while FAIndex >= FBuckets[FABucket].Count do
 139   begin
 140     Inc(FABucket);
 141     if FABucket >= Length(FBuckets) then
 142       FABucket := 0;
 143     FAIndex := 0;
 144   end;
 145
 146   Result := FBuckets[FABucket].Items[FAIndex].Key;
 147   AData := FBuckets[FABucket].Items[FAIndex].Data;
 148   Inc(FAIndex);
 149 end;
 150
 151 function TSimpleBucketList.FindItem(AKey: TColor32; out ABucket,
 152   AIndex: Integer): Boolean;
 153 var
 154   I: Integer;
 155   Col: TColor32Rec;
 156 begin
 157   Result := False;
 158   Col := TColor32Rec(AKey);
 159   ABucket := (Col.A + 11 * Col.B + 59 * Col.R + 119 * Col.G) mod BucketCount;
 160   with FBuckets[ABucket] do
 161   for I := 0 to Count - 1 do
 162     if Items[I].Key = AKey then
 163     begin
 164       AIndex := I;
 165       Result := True;
 166       Break;
 167     end;
 168 end;
 169
 170 procedure TSimpleBucketList.Add(AKey: TColor32; const AData: string);
 171 var
 172   Bucket, Index, Delta, Size: Integer;
 173 begin
 174   if not FindItem(AKey, Bucket, Index) then
 175   with FBuckets[Bucket] do
 176   begin
 177     Size := Length(Items);
 178     if Count = Size then
 179     begin
 180       if Size > 64 then
 181         Delta := Size div 4
 182       else
 183         Delta := 16;
 184       SetLength(Items, Size + Delta);
 185     end;
 186
 187     with Items[Count] do
 188     begin
 189       Key := AKey;
 190       Data := AData;
 191     end;
 192     Inc(Count);
 193     Inc(FItemCount);
 194   end;
 195 end;
 196
 197 function TSimpleBucketList.Exists(AKey: TColor32): Boolean;
 198 var
 199   Bucket, Index: Integer;
 200 begin
 201   Result := FindItem(AKey, Bucket, Index);
 202 end;
 203
 204 {
 205   TXPMFileFormat implementation
 206 }
 207
 208 constructor TXPMFileFormat.Create;
 209 begin
 210   inherited Create;
 211   FName := SXPMFormatName;
 212   FCanLoad := True;
 213   FCanSave := True;
 214   FIsMultiImageFormat := False;
 215   FSupportedFormats := XPMSupportedFormats;
 216
 217   AddMasks(SXPMMasks);
 218 end;
 219
 220 function TXPMFileFormat.LoadData(Handle: TImagingHandle;
 221   var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
 222 var
 223   Contents, PalLookup: TStringList;
 224   S: AnsiString;
 225   I, J, NumColors, Cpp, Line: Integer;
 226
 227   procedure SkipWhiteSpace(var Line: string);
 228   begin
 229     while (Length(Line) > 0) and (Line[1] in WhiteSpaces) do
 230       Delete(Line, 1, 1);
 231   end;
 232
 233   function ReadString(var Line: string): string;
 234   begin
 235     Result := '';
 236     SkipWhiteSpace(Line);
 237     while (Length(Line) > 0) and not(Line[1] in WhiteSpaces) do
 238     begin
 239       SetLength(Result, Length(Result) + 1);
 240       Result[Length(Result)] := Line[1];
 241       Delete(Line, 1, 1);
 242     end;
 243   end;
 244
 245   function ReadInt(var Line: string): Integer;
 246   begin
 247     Result := StrToInt(ReadString(Line));
 248   end;
 249
 250   function ParseHeader: Boolean;
 251   var
 252     S: string;
 253   begin
 254     S := Contents[0];
 255     try
 256       Images[0].Width := ReadInt(S);
 257       Images[0].Height := ReadInt(S);
 258       NumColors := ReadInt(S);
 259       Cpp := ReadInt(S);
 260       Line := 1;
 261       Result := True;
 262     except
 263       Result := False;
 264     end;
 265   end;
 266
 267   function NamedToColor(const ColStr: string): TColor32;
 268   var
 269     S: string;
 270   begin
 271     S := LowerCase(ColStr);
 272     if (S = 'transparent') or (S = 'none') then
 273       Result := pcClear
 274     else if S = 'black' then
 275       Result := pcBlack
 276     else if S = 'blue' then
 277       Result := pcBlue
 278     else if S = 'green' then
 279       Result := pcGreen
 280     else if S = 'cyan' then
 281       Result := pcAqua
 282     else if S = 'red' then
 283       Result := pcRed
 284     else if S = 'magenta' then
 285       Result := pcFuchsia
 286     else if S = 'yellow' then
 287       Result := pcYellow
 288     else if S = 'white' then
 289       Result := pcWhite
 290     else if S = 'gray' then
 291       Result := pcLtGray
 292     else if S = 'dkblue' then
 293       Result := pcNavy
 294     else if S = 'dkgreen' then
 295       Result := pcGreen
 296     else if S = 'dkcyan' then
 297       Result := pcTeal
 298     else if S = 'dkred' then
 299       Result := pcMaroon
 300     else if S = 'dkmagenta' then
 301       Result := pcPurple
 302     else if S = 'dkyellow' then
 303       Result := pcOlive
 304     else if S = 'maroon' then
 305       Result := pcMaroon
 306     else if S = 'olive' then
 307       Result := pcOlive
 308     else if S = 'navy' then
 309       Result := pcNavy
 310     else if S = 'purple' then
 311       Result := pcPurple
 312     else if S = 'teal' then
 313       Result := pcTeal
 314     else if S = 'silver' then
 315       Result := pcSilver
 316     else if S = 'lime' then
 317       Result := pcLime
 318     else if S = 'fuchsia' then
 319       Result := pcFuchsia
 320     else if S = 'aqua' then
 321       Result := pcAqua
 322     else
 323       Result := pcClear;
 324   end;
 325
 326   procedure ParsePalette;
 327   var
 328     I: Integer;
 329     S, ColType, ColStr, Code: string;
 330     Color: TColor32;
 331     Holder: TColorHolder;
 332   begin
 333     for I := 0 to NumColors - 1 do
 334     begin
 335       Holder := TColorHolder.Create;
 336       // Parse pixel code and color
 337       S := Contents[Line + I];
 338       Code := Copy(S, 1, Cpp);
 339       Delete(S, 1, Cpp);
 340       ColType := ReadString(S);
 341       ColStr := ReadString(S);
 342       // Convert color from hex number or named constant
 343       if ColStr[1] = '#' then
 344       begin
 345         Delete(ColStr, 1, 1);
 346         Color := LongWord(StrToInt('$' + Trim(ColStr))) or $FF000000;
 347       end
 348       else
 349         Color := NamedToColor(ColStr);
 350       // Store code and color in table for later lookup
 351       Holder.Color := Color;
 352       PalLookup.AddObject(Code, Holder);
 353     end;
 354     Inc(Line, NumColors);
 355   end;
 356
 357   procedure ParsePixels;
 358   var
 359     X, Y, Idx: Integer;
 360     S, Code: string;
 361     Pix: PColor32;
 362   begin
 363     Pix := Images[0].Bits;
 364     for Y := 0 to Images[0].Height - 1 do
 365     begin
 366       S := Contents[Line + Y];
 367       for X := 0 to Images[0].Width - 1 do
 368       begin
 369         // Read code and look up color in the palette
 370         Code := Copy(S, X * Cpp + 1, Cpp);
 371         if PalLookup.Find(Code, Idx) then
 372           Pix^ := TColorHolder(PalLookup.Objects[Idx]).Color
 373         else
 374           Pix^ := pcClear;
 375         Inc(Pix);
 376       end;
 377     end;
 378   end;
 379
 380 begin
 381   Result := False;
 382   SetLength(Images, 1);
 383   with GetIO, Images[0] do
 384   begin
 385     // Look up table for XPM palette entries
 386     PalLookup := TStringList.Create;
 387     PalLookup.Sorted := True;
 388     PalLookup.CaseSensitive := True;
 389     // Read whole file and assign it to string list
 390     Contents := TStringList.Create;
 391     SetLength(S, GetInputSize(GetIO, Handle));
 392     Read(Handle, @S[1], Length(S));
 393     Contents.Text := S;
 394     // Remove quotes and other stuff
 395     for I := Contents.Count - 1 downto 0 do
 396     begin
 397       J := Pos('"', Contents[I]);
 398       if J > 0 then
 399         Contents[I] := Copy(Contents[I], J + 1, LastDelimiter('"', Contents[I]) - J - 1)
 400       else
 401         Contents.Delete(I);
 402     end;
 403     // Parse header and create new image
 404     if not ParseHeader then
 405       Exit;
 406     NewImage(Width, Height, ifA8R8G8B8, Images[0]);
 407     // Read palette entries and assign colors to pixels
 408     ParsePalette;
 409     ParsePixels;
 410
 411     Contents.Free;
 412     for I := 0 to PalLookup.Count - 1 do
 413       PalLookup.Objects[I].Free;
 414     PalLookup.Free;
 415     Result := True;
 416   end;
 417 end;
 418
 419 function TXPMFileFormat.SaveData(Handle: TImagingHandle;
 420   const Images: TDynImageDataArray; Index: LongInt): Boolean;
 421 const
 422   ColorCharsCount = 92;
 423   ColorChars = ' .XoO+@#$%&*=-;:>,<1234567890qwertyuipasdfghjklzxcvbnmMNBVCZASDFGHJKLPIUYTREWQ!~^/()_`''][{}|';
 424 var
 425   X, Y: Integer;
 426   ImageToSave: TImageData;
 427   MustBeFreed: Boolean;
 428   StrFile: TStringList;
 429   ColTable: TSimpleBucketList;
 430   Stream: TMemoryStream;
 431   Line, Id: string;
 432   CharsPerPixel: Integer;
 433   Ptr: PColor32Rec;
 434   ColRec: TColor32Rec;
 435
 436   procedure BuildColorTables(const Img: TImageData);
 437   var
 438     I: Integer;
 439   begin
 440     Ptr := Img.Bits;
 441     for I := 0 to Img.Width * Img.Height - 1 do
 442     begin
 443       if not ColTable.Exists(Ptr.Color) then
 444         ColTable.Add(Ptr.Color, '');
 445       Inc(Ptr);
 446     end;
 447   end;
 448
 449   procedure MakeStrIdsForColors;
 450   var
 451     I, J, K: Integer;
 452     Id, Data: string;
 453   begin
 454     SetLength(Id, CharsPerPixel);
 455     for I := 0 to ColTable.ItemCount - 1 do
 456     begin
 457       ColRec.Color := ColTable.EnumNext(Data);
 458       K := I;
 459       for J := 0 to CharsPerPixel - 1 do
 460       begin
 461         Id[J + 1] := ColorChars[K mod ColorCharsCount + 1];
 462         K := K div ColorCharsCount;
 463       end;
 464       ColTable.Data[ColRec.Color] := Id;
 465     end;
 466   end;
 467
 468 begin
 469   Result := False;
 470
 471   StrFile := TStringList.Create;
 472   ColTable := TSimpleBucketList.Create;
 473   Stream := TMemoryStream.Create;
 474
 475   if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
 476   try
 477     // Put all unique colors of image to table
 478     BuildColorTables(ImageToSave);
 479     // Compute the character per pixel
 480     CharsPerPixel := 1;
 481     X := ColorCharsCount;
 482     while ColTable.ItemCount > X do
 483     begin
 484       X := X * ColorCharsCount;
 485       Inc(CharsPerPixel);
 486     end;
 487     // Assign char id to each color
 488     MakeStrIdsForColors;
 489
 490     // Start writing XPM file
 491     StrFile.Add(SXPMId);
 492     StrFile.Add('static char *graphic[] = {');
 493     StrFile.Add('/* width height num_colors chars_per_pixel */');
 494     StrFile.Add(SysUtils.Format('"%d %d %d %d", ', [ImageToSave.Width,
 495         ImageToSave.Height, ColTable.ItemCount, CharsPerPixel]));
 496     StrFile.Add('/* colors */');
 497
 498     // Write 'colors' part of XPM file
 499     for X := 0 to ColTable.ItemCount - 1 do
 500     begin
 501       ColRec.Color := ColTable.EnumNext(Id);
 502       if ColRec.A >= 128 then
 503         StrFile.Add(Format('"%s c #%.2x%.2x%.2x",', [Id, ColRec.R, ColRec.G, ColRec.B]))
 504       else
 505         StrFile.Add(Format('"%s c None",', [Id]));
 506     end;
 507
 508     StrFile.Add('/* pixels */');
 509
 510     // Write pixels - for aech pixel of image find its char id
 511     // and append it to line
 512     Ptr := ImageToSave.Bits;
 513     for Y := 0 to ImageToSave.Height - 1 do
 514     begin
 515       Line := '';
 516       for X := 0 to ImageToSave.Width - 1 do
 517       begin
 518         Line := Line + ColTable.Data[Ptr.Color];
 519         Inc(Ptr);
 520       end;
 521       Line := '"' + Line + '"';
 522       if Y < ImageToSave.Height - 1 then
 523         Line := Line + ',';
 524       StrFile.Add(Line);
 525     end;
 526
 527     StrFile.Add('};');
 528
 529     // Finally save strings to stream and write stream's data to output
 530     // (we could directly write lines from list to output, but stream method
 531     // takes care of D2009+ Unicode strings).
 532     StrFile.SaveToStream(Stream);
 533     GetIO.Write(Handle, Stream.Memory, Stream.Size);
 534
 535     Result := True;
 536   finally
 537     StrFile.Free;
 538     ColTable.Free;
 539     Stream.Free;
 540     if MustBeFreed then
 541       FreeImage(ImageToSave);
 542   end;
 543 end;
 544
 545 procedure TXPMFileFormat.ConvertToSupported(var Image: TImageData;
 546   const Info: TImageFormatInfo);
 547 begin
 548   ConvertImage(Image, ifA8R8G8B8)
 549 end;
 550
 551 function TXPMFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
 552 var
 553   Id: array[0 .. 8] of AnsiChar;
 554   ReadCount: Integer;
 555 begin
 556   Result := False;
 557   if Handle <> nil then
 558   begin
 559     ReadCount := GetIO.Read(Handle, @Id, SizeOf(Id));
 560     GetIO.Seek(Handle, -ReadCount, smFromCurrent);
 561     Result := (Id = SXPMId) and (ReadCount = SizeOf(Id));
 562   end;
 563 end;
 564
 565 initialization
 566
 567 RegisterImageFileFormat(TXPMFileFormat);
 568
 569 {
 570   File Notes:
 571
 572   -- TODOS ----------------------------------------------------
 573   - nothing now
 574
 575   -- 0.26.3 Changes/Bug Fixes -----------------------------------
 576   - Added XPM saving.
 577
 578   -- 0.25.0 Changes/Bug Fixes -----------------------------------
 579   - Added XPM loading.
 580   - Unit created.
 581 }
 582
 583 end.