src/lib/vampimg/ImagingXpm.pas

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