paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-07 20:50:42 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ Fix for writing more than 60 colors in palette or no palette at all (by Colin Western)

Browse Source 
git-svn-id: trunk@3785 -
This commit is contained in:
michael 2006-06-04 09:50:43 +00:00
parent 29a5f40758
commit a70517c25e
1 changed files with 23 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
fcl/image/fpwritexpm.pp
View File

@ -76,6 +76,7 @@ end;
procedure TFPWriterXPM.InternalWrite (Str:TStream; Img:TFPCustomImage); procedure TFPWriterXPM.InternalWrite (Str:TStream; Img:TFPCustomImage);
var p, l : TStringList; var p, l : TStringList;
c, len, r, t : integer; c, len, r, t : integer;
TmpPalette, Palette: TFPPalette;
procedure BuildPaletteStrings; procedure BuildPaletteStrings;
var r,c,e : integer; var r,c,e : integer;
procedure MakeCodes (const head:string; charplace:integer); procedure MakeCodes (const head:string; charplace:integer);
@ -85,12 +86,13 @@ var p, l : TStringList;
dec (charplace); dec (charplace);
while (r <= e) and (c >= 0) do while (r <= e) and (c >= 0) do
begin begin
if Charplace = 1 then if Charplace > 0 then
MakeCodes (head+PalChars[r],charplace) MakeCodes (head+PalChars[r],charplace)
else else begin
p.Add (head+PalChars[r]); p.Add (head+PalChars[r]);
dec(c);
end;
inc (r); inc (r);
dec(c);
end; end;
end; end;
begin begin
@ -98,7 +100,7 @@ var p, l : TStringList;
len := 1; len := 1;
e := length(PalChars); e := length(PalChars);
r := e; r := e;
c := img.palette.count; c := Palette.count;
while (r <= c) do while (r <= c) do
begin begin
inc (len); inc (len);
@ -123,25 +125,35 @@ var s : string;
begin begin
l := TStringList.Create; l := TStringList.Create;
p := TStringList.Create; p := TStringList.Create;
TmpPalette := nil;
try try
l.Add ('/* XPM */'); l.Add ('/* XPM */');
l.Add ('static char *graphic[] = {'); l.Add ('static char *graphic[] = {');
c := img.palette.count; Palette := img.palette;
if not Assigned(Palette) then begin
TmpPalette := TFPPalette.Create(0);
TmpPalette.Build(Img);
Palette := TmpPalette;
end;
c := Palette.count;
BuildPaletteStrings; BuildPaletteStrings;
l.add (format('"%d %d %d %d",',[img.width,img.height,c,len])); l.add (format('"%d %d %d %d",',[img.width,img.height,c,len]));
InitConsts; InitConsts;
for r := 0 to c-1 do for r := 0 to c-1 do
begin begin
if img.palette[r] <> colTransparent then if Palette[r] <> colTransparent then
l.Add (format('"%s c #%s",',[p[r],ColorToHex(img.palette.color[r])])) l.Add (format('"%s c #%s",',[p[r],ColorToHex(Palette.color[r])]))
else else
l.Add (format('"%s c None",',[p[r]])); l.Add (format('"%s c None",',[p[r]]));
end; end;
for r := 0 to img.Height-1 do for r := 0 to img.Height-1 do
begin begin
s := p[img.pixels[0,r]]; s := '';
for t := 1 to img.Width-1 do for t := 0 to img.Width-1 do
s := s + p[img.pixels[t,r]]; if Assigned(TmpPalette) then
s := s + p[TmpPalette.IndexOf(img.Colors[t,r])]
else
s := s + p[img.pixels[t,r]];
s := '"'+s+'"'; s := '"'+s+'"';
if r < img.Height-1 then if r < img.Height-1 then
s := s + ','; s := s + ',';
@ -149,6 +161,7 @@ begin
end; end;
l.Add ('};'); l.Add ('};');
finally finally
TmpPalette.Free;
l.SaveToStream (Str); l.SaveToStream (Str);
p.Free; p.Free;
l.Free; l.Free;