source: trunk/Packages/bgrabitmap/paletteformats.inc

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 17.3 KB
Line 
1var
2 PaletteFormats : array of record
3 formatIndex: TBGRAPaletteFormat;
4 ext: string;
5 description: string;
6 reader: TPaletteReaderProc;
7 writer: TPaletteWriterProc;
8 checkFormat: TCheckPaletteFormatProc;
9 end;
10
11const
12 GimpPaletteHeader : string = 'GIMP Palette';
13 KOfficePaletteHeader : string = 'KDE RGB Palette';
14 AdobeSwatchExchangeHeader : string = 'ASEF';
15 JascPaletteHeader : string = 'JASC-PAL';
16 PaintDotNetPaletteHeader : string = '; paint.net Palette File';
17 PaintDotNetPaletteHeaderUTF8 : string = #$EF#$BB#$BF + '; paint.net Palette File';
18
19procedure SaveToStreamAsPaintDotNet(APalette: TBGRAPalette; AStream: TStream);
20
21 procedure WriteStr(s: string);
22 begin
23 AStream.WriteBuffer(s[1],length(S));
24 end;
25 procedure WriteStrLn(s: string);
26 begin
27 WriteStr(s+#$0D#$0A);
28 end;
29
30var
31 i: Integer;
32
33begin
34 WriteStrLn(PaintDotNetPaletteHeaderUTF8);
35 for i := 0 to APalette.Count-1 do
36 with APalette.Color[i] do
37 WriteStrLn(IntToHex(alpha,2)+IntToHex(red,2)+IntToHex(green,2)+IntToHex(blue,2));
38end;
39
40procedure SaveToStreamAsGimp(APalette: TBGRAPalette; AStream: TStream);
41 procedure WriteStr(s: string);
42 begin
43 AStream.WriteBuffer(s[1],length(S));
44 end;
45 procedure WriteStrLn(s: string);
46 begin
47 WriteStr(s+#$0A);
48 end;
49
50 procedure WriteChannelValue(AValue: byte);
51 var s: string;
52 begin
53 s := IntToStr(AValue);
54 while length(s) < 3 do s := ' '+s;
55 WriteStr(s);
56 end;
57
58var
59 i: Integer;
60
61begin
62 WriteStrLn(GimpPaletteHeader);
63 WriteStrLn('Name: Palette');
64 WriteStrLn('Columns: 3');
65 WriteStrLn('#');
66 for i := 0 to APalette.Count-1 do
67 with APalette.Color[i] do
68 begin
69 WriteChannelValue(red);
70 WriteStr(' ');
71 WriteChannelValue(green);
72 WriteStr(' ');
73 WriteChannelValue(blue);
74 WriteStrLn(#$09+BGRAToStr(APalette.Color[i],CSSColors));
75 end;
76end;
77
78procedure SaveToStreamAsAdobeSwatchExchange(APalette: TBGRAPalette; AStream: TStream);
79 procedure WriteStr(s: string);
80 begin
81 AStream.WriteBuffer(s[1],length(S));
82 end;
83 procedure WriteInt32(AValue: Int32);
84 begin
85 AValue := NtoBE(AValue);
86 AStream.WriteBuffer(AValue,sizeof(AValue));
87 end;
88 procedure WriteInt16(AValue: Int16);
89 begin
90 AValue := NtoBE(AValue);
91 AStream.WriteBuffer(AValue,sizeof(AValue));
92 end;
93 procedure WriteSingle(AValue: Single);
94 begin
95 DWord(AValue) := BEtoN(DWord(AValue));
96 AStream.WriteBuffer(AValue,sizeof(AValue));
97 end;
98 procedure WriteBlock(ABlockType: Int16; AContentLength: Int32); overload;
99 begin
100 WriteInt16(ABlockType);
101 WriteInt32(AContentLength);
102 end;
103
104 procedure WriteBlock(ABlockType: Int16; AName: string; AExtraContentLength: Int32); overload;
105 var contentLength: Int32;
106 wideName: UnicodeString;
107 nameBuf: array of byte;
108 i: Integer;
109 begin
110 wideName := UTF8Decode(AName);
111 setlength(nameBuf, (length(wideName)+1)*2);
112 contentLength:= AExtraContentLength + 2 + length(nameBuf);
113 WriteBlock(ABlockType, contentLength);
114 WriteInt16(length(nameBuf) shr 1);
115 for i := 1 to length(wideName) do
116 begin
117 nameBuf[((i-1) shl 1)] := ord(wideName[i]) shr 8;
118 nameBuf[((i-1) shl 1)+1] := ord(wideName[i]) and 255;
119 end;
120 AStream.WriteBuffer(nameBuf[0],length(namebuf));
121 end;
122
123var
124 i: Integer;
125
126begin
127 WriteStr(AdobeSwatchExchangeHeader+#$00#$01+#$00#$00);
128 WriteInt32(APalette.Count+2); //number of blocks
129 WriteBlock($1c0, 'Palette', 0); //group start
130 for i := 0 to APalette.Count-1 do
131 with APalette.Color[i] do
132 begin
133 WriteBlock(1, BGRAToStr(APalette.Color[i],CSSColors), 4+4*3+2);
134 WriteStr('RGB ');
135 WriteSingle(red/255);
136 WriteSingle(green/255);
137 WriteSingle(blue/255);
138 WriteInt16(2); //normal
139 end;
140 WriteBlock($2c0, 0); //group end
141end;
142
143procedure SaveToStreamAsKOffice(APalette: TBGRAPalette; AStream: TStream);
144 procedure WriteStr(s: string);
145 begin
146 AStream.WriteBuffer(s[1],length(S));
147 end;
148 procedure WriteStrLn(s: string);
149 begin
150 WriteStr(s+#$0A);
151 end;
152
153 procedure WriteChannelValue(AValue: byte);
154 begin
155 WriteStr(IntToStr(AValue));
156 end;
157
158var
159 i: Integer;
160
161begin
162 WriteStrLn(KOfficePaletteHeader);
163 for i := 0 to APalette.Count-1 do
164 with APalette.Color[i] do
165 begin
166 WriteChannelValue(red);
167 WriteStr(' ');
168 WriteChannelValue(green);
169 WriteStr(' ');
170 WriteChannelValue(blue);
171 WriteStrLn(#$09+BGRAToStr(APalette.Color[i],CSSColors));
172 end;
173end;
174
175procedure SaveToStreamAsJasc(APalette: TBGRAPalette; AStream: TStream);
176 procedure WriteStr(s: string);
177 begin
178 AStream.WriteBuffer(s[1],length(S));
179 end;
180 procedure WriteStrLn(s: string);
181 begin
182 WriteStr(s+#$0D#$0A);
183 end;
184
185var
186 i: Integer;
187
188begin
189 WriteStrLn(JascPaletteHeader);
190 WriteStrLn('0100');
191 WriteStrLn(IntToStr(APalette.Count));
192 for i := 0 to APalette.Count-1 do
193 with APalette.Color[i] do
194 WriteStrLn(IntToStr(red)+' '+IntToStr(green)+' '+IntToStr(blue));
195end;
196
197function LoadFromStreamAsPaintDotNet(APalette: TBGRAPalette; AStream: TStream): boolean;
198var lines: TStringList;
199 header,s: string;
200 idxComment: integer;
201 code: integer;
202 hexArgb: int32;
203 i: Integer;
204begin
205 result := false;
206 lines := TStringList.Create;
207 try
208 lines.LoadFromStream(AStream);
209 if lines.Count = 0 then
210 begin
211 lines.Free;
212 exit;
213 end;
214 header := lines[0];
215 if (header <> PaintDotNetPaletteHeader) and (header <> PaintDotNetPaletteHeaderUTF8) then
216 begin
217 lines.Free;
218 exit;
219 end;
220
221 for i := 0 to lines.Count-1 do
222 begin
223 s := lines[i];
224 idxComment := pos(';',s);
225 if idxComment<>0 then s := copy(s,1,idxComment-1);
226 s := trim(s);
227 if length(s)> 0 then
228 begin
229 val('$'+s, hexArgb, code);
230 if code = 0 then
231 APalette.AddColor(BGRA((hexArgb shr 16) and 255,
232 (hexArgb shr 8) and 255,
233 hexArgb and 255,
234 (hexArgb shr 24) and 255));
235 end;
236 end;
237 result := true;
238 finally
239 lines.Free;
240 end;
241end;
242
243function LoadFromStreamAsGimp(APalette: TBGRAPalette; AStream: TStream): boolean;
244var lines,line: TStringList;
245 s: string;
246 idxComment: integer;
247 code: integer;
248 c: TBGRAPixel;
249 i: Integer;
250begin
251 result := false;
252 lines := TStringList.Create;
253 line := TStringList.Create;
254 try
255 lines.LoadFromStream(AStream);
256 if (lines.Count < 3) or (lines[0] <> GimpPaletteHeader) or
257 (copy(lines[1],1,6) <> 'Name: ') or
258 (copy(lines[2],1,9) <> 'Columns: ') then
259 begin
260 lines.Free;
261 line.Free;
262 exit;
263 end;
264 for i := 3 to lines.Count-1 do
265 begin
266 s := lines[i];
267 idxComment := pos('#',s);
268 if idxComment<>0 then s := copy(s,1,idxComment-1);
269 s := trim(s);
270 if length(s)> 0 then
271 begin
272 line.CommaText := s;
273 if line.Count >= 3 then
274 begin
275 c.alpha:= 255;
276 val(line[0],c.red,code);
277 if code <> 0 then continue;
278 val(line[1],c.green,code);
279 if code <> 0 then continue;
280 val(line[2],c.blue,code);
281 if code <> 0 then continue;
282 APalette.AddColor(c);
283 end;
284 end;
285 end;
286 result := true;
287 finally
288 lines.Free;
289 line.Free;
290 end;
291end;
292
293function clamp(AValue, AMax: integer): integer;
294begin
295 if AValue < 0 then result := 0 else
296 if AValue > AMax then result := AMax else
297 result := AValue;;
298end;
299
300function LabToRGB(L,a,b: single): TBGRAPixel; overload;
301var r,g,blue: single;
302begin
303 if a < 0 then
304 r := L + a + 0.5*b
305 else
306 r := L + 0.75*a + 0.5*b;
307 g := L - 0.5*a;
308 blue := L - b;
309 Result.red:= clamp(round((r)*255),255);
310 Result.green:= clamp(round((g)*255),255);
311 Result.blue:= clamp(round((blue)*255),255);
312 result.alpha := 255;
313end;
314
315function LoadFromStreamAsAdobeSwatchExchange(APalette: TBGRAPalette; AStream: TStream): boolean;
316 function ReadInt16: int16;
317 begin
318 {$PUSH}{$HINTS OFF}
319 AStream.Read(result, sizeof(result));
320 {$POP}
321 result := BEtoN(result);
322 end;
323 function ReadInt32: int32;
324 begin
325 {$PUSH}{$HINTS OFF}
326 AStream.Read(result, sizeof(result));
327 {$POP}
328 result := BEtoN(result);
329 end;
330 function ReadStr(ALength: integer): string;
331 begin
332 setlength(result, ALength);
333 ALength := AStream.Read(result[1], ALength);
334 setlength(result, ALength);
335 end;
336 function ReadSingle: single;
337 begin
338 {$PUSH}{$HINTS OFF}
339 AStream.Read(Result, sizeof(result));
340 {$POP}
341 DWord(Result) := BEtoN(DWord(Result));
342 end;
343 function DblToByte(AValue: double): byte;
344 begin
345 if AValue < 0 then result := 0
346 else if AValue > 1 then result := 255 else
347 result := round(AValue*255);
348 end;
349
350var header: string;
351 nbBlocks,blockSize: int32;
352 blockType,nameLength: int16;
353 nextPos: int64;
354 colorFormat: string;
355 colorF: TColorF;
356 i: Integer;
357begin
358 result := false;
359 header := ReadStr(length(AdobeSwatchExchangeHeader)+4);
360 if header <> AdobeSwatchExchangeHeader+#$00#$01+#$00#$00 then exit;
361 nbBlocks := ReadInt32;
362 for i := 0 to nbBlocks-1 do
363 begin
364 blockType := ReadInt16;
365 blockSize := ReadInt32;
366 nextPos := AStream.Position + blockSize;
367 if blockType = 1 then
368 begin
369 nameLength := ReadInt16;
370 ReadStr(nameLength*2);
371 colorFormat := ReadStr(4);
372 if colorFormat = 'RGB ' then
373 begin
374 colorF[1] := ReadSingle;
375 colorF[2] := ReadSingle;
376 colorF[3] := ReadSingle;
377 colorF[4] := 1;
378 APalette.AddColor(BGRA(DblToByte(colorF[1]),DblToByte(colorF[2]),DblToByte(colorF[3])));
379 ReadInt16; //ignore color type
380 end else
381 if colorFormat = 'CMYK' then
382 begin
383 colorF[1] := ReadSingle;
384 colorF[2] := ReadSingle;
385 colorF[3] := ReadSingle;
386 colorF[4] := ReadSingle;
387
388 APalette.AddColor(BGRA(DblToByte(1 - colorF[1] + ColorF[2]/10 + ColorF[3]/10 - ColorF[4]),
389 DblToByte(1 - colorF[2] + ColorF[1]/10 + ColorF[3]/10 - ColorF[4]),
390 DblToByte(1 - colorF[3] + ColorF[1]/10 + ColorF[2]/10 - ColorF[4])));
391 ReadInt16; //ignore color type
392 end else
393 if colorFormat = 'LAB ' then
394 begin
395 colorF[1] := ReadSingle;
396 colorF[2] := ReadSingle;
397 colorF[3] := ReadSingle;
398 colorF[4] := 1;
399
400 APalette.AddColor(LabToRGB(colorF[1],colorF[2]/128,colorF[3]/128));
401 ReadInt16; //ignore color type
402 end else
403 if colorFormat = 'GRAY' then
404 begin
405 colorF[1] := ReadSingle;
406 colorF[2] := colorF[1];
407 colorF[3] := colorF[1];
408 colorF[4] := 1;
409 APalette.AddColor(BGRA(DblToByte(colorF[1]),DblToByte(colorF[2]),DblToByte(colorF[3])));
410 ReadInt16; //ignore color type
411 end;
412 end;
413 if AStream.Position<>nextPos then
414 AStream.Position:= nextPos;
415 end;
416 result := true;
417end;
418
419function LoadFromStreamAsKOffice(APalette: TBGRAPalette; AStream: TStream): boolean;
420var lines,line: TStringList;
421 s: string;
422 idxComment: integer;
423 code: integer;
424 c: TBGRAPixel;
425 i: Integer;
426begin
427 result := false;
428 lines := TStringList.Create;
429 line := TStringList.Create;
430 try
431 lines.LoadFromStream(AStream);
432 if (lines.Count < 1) or (lines[0] <> KOfficePaletteHeader) then
433 begin
434 lines.Free;
435 line.Free;
436 exit;
437 end;
438 for i := 3 to lines.Count-1 do
439 begin
440 s := lines[i];
441 idxComment := pos('#',s);
442 if idxComment<>0 then s := copy(s,1,idxComment-1);
443 s := trim(s);
444 if length(s)> 0 then
445 begin
446 line.CommaText := s;
447 if line.Count >= 3 then
448 begin
449 c.alpha:= 255;
450 val(line[0],c.red,code);
451 if code <> 0 then continue;
452 val(line[1],c.green,code);
453 if code <> 0 then continue;
454 val(line[2],c.blue,code);
455 if code <> 0 then continue;
456 APalette.AddColor(c);
457 end;
458 end;
459 end;
460 result := true;
461 finally
462 lines.Free;
463 line.Free;
464 end;
465end;
466
467function LoadFromStreamAsJasc(APalette: TBGRAPalette; AStream: TStream): boolean;
468var lines,line: TStringList;
469 s: string;
470 idxComment: integer;
471 code: integer;
472 c: TBGRAPixel;
473 i: Integer;
474begin
475 result := false;
476 lines := TStringList.Create;
477 line := TStringList.Create;
478 try
479 lines.LoadFromStream(AStream);
480 if (lines.Count < 2) or (lines[0] <> JascPaletteHeader) or
481 (lines[1] <> '0100') then
482 begin
483 lines.Free;
484 line.Free;
485 exit;
486 end;
487 for i := 2 to lines.Count-1 do
488 begin
489 s := lines[i];
490 idxComment := pos('#',s);
491 if idxComment<>0 then s := copy(s,1,idxComment-1);
492 s := trim(s);
493 if length(s)> 0 then
494 begin
495 line.CommaText := s;
496 if line.Count >= 3 then
497 begin
498 c.alpha:= 255;
499 val(line[0],c.red,code);
500 if code <> 0 then continue;
501 val(line[1],c.green,code);
502 if code <> 0 then continue;
503 val(line[2],c.blue,code);
504 if code <> 0 then continue;
505 APalette.AddColor(c);
506 end;
507 end;
508 end;
509 result := true;
510 finally
511 lines.Free;
512 line.Free;
513 end;
514end;
515
516function CheckPaletteFormatAsJasc(ABuf256: string): boolean;
517begin
518 result := (copy(ABuf256,1,length(JascPaletteHeader)+1) = JascPaletteHeader+#$0A) or
519 (copy(ABuf256,1,length(JascPaletteHeader)+2) = JascPaletteHeader+#$0D#$0A);
520end;
521
522function CheckPaletteFormatAsGimp(ABuf256: string): boolean;
523begin
524 result := (copy(ABuf256,1,length(GimpPaletteHeader)+1) = GimpPaletteHeader+#$0A) or
525 (copy(ABuf256,1,length(GimpPaletteHeader)+2) = GimpPaletteHeader+#$0D#$0A);
526end;
527
528function CheckPaletteFormatAsKOffice(ABuf256: string): boolean;
529begin
530 result := (copy(ABuf256,1,length(KOfficePaletteHeader)+1) = KOfficePaletteHeader+#$0A) or
531 (copy(ABuf256,1,length(KOfficePaletteHeader)+2) = KOfficePaletteHeader+#$0D#$0A);
532end;
533
534function CheckPaletteFormatAsPaintDotNet(ABuf256: string): boolean;
535begin
536 result := (copy(ABuf256,1,length(PaintDotNetPaletteHeader)+1) = PaintDotNetPaletteHeader+#$0A) or
537 (copy(ABuf256,1,length(PaintDotNetPaletteHeader)+2) = PaintDotNetPaletteHeader+#$0D#$0A) or
538 (copy(ABuf256,1,length(PaintDotNetPaletteHeaderUTF8)+1) = PaintDotNetPaletteHeaderUTF8+#$0A) or
539 (copy(ABuf256,1,length(PaintDotNetPaletteHeaderUTF8)+2) = PaintDotNetPaletteHeaderUTF8+#$0D#$0A);
540end;
541
542function CheckPaletteFormatAsAdobeSwatchExchange(ABuf256: string): boolean;
543begin
544 result := copy(ABuf256,1,length(AdobeSwatchExchangeHeader)) = AdobeSwatchExchangeHeader;
545end;
546
547
548procedure RegisterDefaultPaletteFormats; forward;
549
550procedure BGRARegisterPaletteFormat(AFormatIndex: TBGRAPaletteFormat; AExtension: string;
551 ADescription: string; AReadProc: TPaletteReaderProc; AWriteProc: TPaletteWriterProc;
552 ACheckFormatProc: TCheckPaletteFormatProc);
553var
554 i: Integer;
555begin
556 RegisterDefaultPaletteFormats;
557 if AFormatIndex = palUnknown then
558 raise Exception.Create('Invalid format index');
559 for i := 0 to high(PaletteFormats) do
560 if PaletteFormats[i].formatIndex = AFormatIndex then
561 with PaletteFormats[i] do
562 begin
563 ext := AExtension;
564 description := ADescription;
565 reader := AReadProc;
566 writer := AWriteProc;
567 checkFormat := ACheckFormatProc;
568 exit;
569 end;
570 setlength(PaletteFormats,length(PaletteFormats)+1);
571 with PaletteFormats[high(PaletteFormats)] do
572 begin
573 formatIndex:= AFormatIndex;
574 ext := AExtension;
575 description := ADescription;
576 reader := AReadProc;
577 writer := AWriteProc;
578 checkFormat := ACheckFormatProc;
579 end;
580end;
581
582function BGRARegisteredPaletteFormatFilter(AAllSupportedDescription: string
583 ): string;
584var allExt: TStringList;
585 allDesc: string;
586 i: Integer;
587begin
588 result := '';
589 RegisterDefaultPaletteFormats;
590 allExt := TStringList.Create;
591 allExt.CaseSensitive := false;
592 for i := 0 to high(PaletteFormats) do
593 with PaletteFormats[i] do
594 begin
595 if allExt.IndexOf(ext) = -1 then allExt.Add(ext);
596 if length(result)>0 then result += '|';
597 result += description + ' (*'+ext+')|*'+ext;
598 end;
599 if allExt.Count > 0 then
600 begin
601 allDesc := AAllSupportedDescription + ' (';
602 for i := 0 to allExt.count-1 do
603 begin
604 if i > 0 then
605 allDesc += '; ';
606 allDesc += '*' + allExt[i];
607 end;
608 allDesc += ')';
609 allDesc += '|';
610 for i := 0 to allExt.count-1 do
611 begin
612 if i > 0 then
613 allDesc += '; ';
614 allDesc += '*' + allExt[i];
615 end;
616 result := allDesc + '|' + result;
617 end;
618 allExt.Free;
619end;
620
621var DefaultPaletteFormatsRegistered: boolean;
622
623procedure RegisterDefaultPaletteFormats;
624begin
625 if DefaultPaletteFormatsRegistered then exit;
626 DefaultPaletteFormatsRegistered := true;
627 BGRARegisterPaletteFormat(palPaintDotNet, '.txt', 'Paint.NET',
628 @LoadFromStreamAsPaintDotNet, @SaveToStreamAsPaintDotNet,
629 @CheckPaletteFormatAsPaintDotNet);
630 BGRARegisterPaletteFormat(palGimp, '.gpl', 'GIMP',
631 @LoadFromStreamAsGimp, @SaveToStreamAsGimp,
632 @CheckPaletteFormatAsGimp);
633 BGRARegisterPaletteFormat(palAdobeSwatchExchange, '.ase', 'Adobe Swatch Exchange',
634 @LoadFromStreamAsAdobeSwatchExchange, @SaveToStreamAsAdobeSwatchExchange,
635 @CheckPaletteFormatAsAdobeSwatchExchange);
636 BGRARegisterPaletteFormat(palKOffice, '.colors', 'KOffice',
637 @LoadFromStreamAsKOffice, @SaveToStreamAsKOffice,
638 @CheckPaletteFormatAsKOffice);
639 BGRARegisterPaletteFormat(palJascPSP, '.pal', 'Jasc Paint Shop Pro',
640 @LoadFromStreamAsJasc, @SaveToStreamAsJasc,
641 @CheckPaletteFormatAsJasc);
642end;
643
Note: See TracBrowser for help on using the repository browser.