source: trunk/Packages/bgrabitmap/bgrareadpsd.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 17.4 KB
Line 
1{
2 This original file was part of the Free Pascal run time library.
3 Copyright (c) 2008 by the Free Pascal development team
4
5 Psd reader for fpImage.
6
7 See the file COPYING.FPC, included in this distribution,
8 for details about the copyright.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************
15
16 03/2014 changes by circular :
17 - added MinifyHeight,WantedHeight and OutputHeight (useful for thumbnails)
18}
19unit BGRAReadPSD;
20
21{$mode objfpc}{$H+}
22
23interface
24
25uses
26 Classes, SysUtils, FPimage, FPReadPSD;
27
28type
29 { TBGRAReaderPSD }
30
31 TBGRAReaderPSD = class(TFPReaderPSD)
32 private
33 FCompressed: boolean;
34 protected
35 FScanLines : array of PByte;
36 FInputLine : array of record
37 StreamOffset: Int64;
38 Size: PtrInt;
39 end;
40 FOutputHeight: integer;
41 function ReadPalette(Stream: TStream): boolean;
42 procedure AnalyzeHeader;
43 procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
44 function ReadScanLine(Stream: TStream; AInputSize: PtrInt; AChannel: integer): boolean; overload;
45 procedure WriteScanLine(Img: TFPCustomImage; Row: integer); overload;
46 function InternalCheck(Stream: TStream) : boolean; override;
47 public
48 MinifyHeight,WantedHeight: integer;
49 constructor Create; override;
50 property Compressed: Boolean read FCompressed;
51 property OutputHeight: integer read FOutputHeight;
52 end;
53
54implementation
55
56uses BGRABitmapTypes;
57
58function clamp(AValue, AMax: integer): integer;
59begin
60 if AValue < 0 then result := 0 else
61 if AValue > AMax then result := AMax else
62 result := AValue;;
63end;
64
65function CMYKtoRGB ( C : TFPColor): TFPColor;
66var r,g,b: integer;
67begin
68 r := $ffff - c.red + c.green div 10 + c.blue div 10 - c.alpha;
69 g := $ffff + c.red div 10 - c.green + c.blue div 10 - c.alpha;
70 b := $ffff + c.red div 10 + c.green div 10 - c.blue - c.alpha;
71 result.red := clamp(r, 65535);
72 result.green := clamp(g, 65535);
73 result.blue := clamp(b, 65535);
74 Result.alpha:=alphaOpaque;
75end;
76
77function fInv(t: single): single;
78begin
79 if t > 6/29 then result := t*t*t else
80 result := 3*(6/29)*(6/29)*(t-4/29);
81end;
82
83function Csrgb(linear: single): single;
84begin
85 if linear <= 0.0031308 then
86 result := 12.92*linear else
87 result := (1+0.055)*exp(ln(linear)*(1/2.4)) - 0.055;
88end;
89
90function LabToRGB(L,a,b: single):TFPColor; overload;
91var r,g,blue: single;
92begin
93 if a < 0 then
94 r := L + a + 0.25*b
95 else
96 r := L + 0.75*a + 0.25*b;
97 g := L - 0.25*a;
98 blue := L - b;
99 Result.red:= clamp(round((r)*65535),65535);
100 Result.green:= clamp(round((g)*65535),65535);
101 Result.blue:= clamp(round((blue)*65535),65535);
102 result.alpha := 65535;
103end;
104
105function LabToRGB(const Lab:TLab):TFPColor; overload;
106var L: single;
107begin
108 L := 1/255*Lab.L;
109 result := LabToRGB(L,(Lab.a-128)/127,(Lab.b-128)/127);
110end;
111
112{ TBGRAReaderPSD }
113
114function TBGRAReaderPSD.ReadPalette(Stream: TStream): boolean;
115Var
116 I : Integer;
117 c : TFPColor;
118 OldPos: Integer;
119 BufSize:Longint;
120 {%H-}PalBuf: array[0..767] of Byte;
121 ContProgress: Boolean;
122begin
123 Result:=false;
124 ThePalette.count := 0;
125 OldPos := Stream.Position;
126 BufSize:=0;
127 Stream.Read(BufSize, SizeOf(BufSize));
128 BufSize:=BEtoN(BufSize);
129 Stream.Read({%H-}PalBuf, BufSize);
130 ContProgress:=true;
131 Progress(FPimage.psRunning, 0, False, Rect(0,0,0,0), '', ContProgress);
132 if not ContProgress then exit;
133 For I:=0 To BufSize div 3 Do
134 Begin
135 With c do
136 begin
137 Red:=PalBuf[I] shl 8;
138 Green:=PalBuf[I+(BufSize div 3)] shl 8;
139 Blue:=PalBuf[I+(BufSize div 3)* 2] shl 8;
140 Alpha:=alphaOpaque;
141 end;
142 ThePalette.Add(C);
143 End;
144 Stream.Position := OldPos;
145 Result:=true;
146end;
147
148procedure TBGRAReaderPSD.AnalyzeHeader;
149var channel: integer;
150begin
151 With FHeader do
152 begin
153 Depth:=BEtoN(Depth);
154 if (Signature <> '8BPS') then
155 Raise Exception.Create('Unknown/Unsupported PSD image type');
156 Channels:=BEtoN(Channels);
157 if Channels > 4 then
158 FBytesPerPixel:=Depth*4
159 else
160 FBytesPerPixel:=Depth*Channels;
161 Mode:=BEtoN(Mode);
162 FWidth:=BEtoN(Columns);
163 FHeight:=BEtoN(Rows);
164 FChannelCount:=Channels;
165 FLineSize:=(PtrInt(FWidth)*Depth+7) div 8;
166 setlength(FScanLines, FChannelCount);
167 for channel := 0 to FChannelCount-1 do
168 GetMem(FScanLines[channel],FLineSize);
169 end;
170end;
171
172procedure TBGRAReaderPSD.InternalRead(Stream: TStream; Img: TFPCustomImage);
173var
174 H,HOutput,InputLineIndex,LenOfLineIndex,channel: Integer;
175 LenOfLineFactor: PtrInt;
176 BufSize:Cardinal;
177 Encoding:word;
178 ContProgress: Boolean;
179 CurOffset: int64;
180 PrevOutputRow, OutputRow, OutputRowAdd, OutputRowAcc, OutputRowAccAdd, OutputRowMod: integer;
181begin
182 FScanLines:=nil;
183 FPalette:=nil;
184 try
185 Stream.Position:=0;
186 ContProgress:=true;
187 Progress(FPimage.psStarting, 0, False, Rect(0,0,0,0), '', ContProgress);
188 if not ContProgress then exit;
189 // read header
190 Stream.Read(FHeader, SizeOf(FHeader));
191 Progress(FPimage.psRunning, 0, False, Rect(0,0,0,0), '', ContProgress);
192 if not ContProgress then exit;
193 AnalyzeHeader;
194 Case FHeader.Mode of
195 0:begin // Bitmap (monochrome)
196 FPalette := TFPPalette.Create(0);
197 CreateBWPalette;
198 end;
199 1, 8:begin // Gray-scale
200 FPalette := TFPPalette.Create(0);
201 CreateGrayPalette;
202 end;
203 2:begin // Indexed color (palette color)
204 FPalette := TFPPalette.Create(0);
205 if not ReadPalette(stream) then exit;
206 end;
207 end;
208
209 if Assigned(OnCreateImage) then
210 OnCreateImage(Self,Img);
211
212 if (MinifyHeight > 0) and (FHeight > MinifyHeight) then
213 FOutputHeight:= MinifyHeight
214 else
215 if WantedHeight > 0 then
216 FOutputHeight:= WantedHeight
217 else
218 FOutputHeight:= FHeight;
219 Img.SetSize(FWidth,FOutputHeight);
220
221 // color palette
222 BufSize:=0;
223 Stream.Read(BufSize, SizeOf(BufSize));
224 BufSize:=BEtoN(BufSize);
225 Stream.Seek(BufSize, soCurrent);
226 // color data block
227 Stream.Read(BufSize, SizeOf(BufSize));
228 BufSize:=BEtoN(BufSize);
229 Stream.Read(FColorDataBlock, SizeOf(FColorDataBlock));
230 Stream.Seek(BufSize-SizeOf(FColorDataBlock), soCurrent);
231 // mask
232 Stream.Read(BufSize, SizeOf(BufSize));
233 BufSize:=BEtoN(BufSize);
234 Stream.Seek(BufSize, soCurrent);
235 // compression type
236 Encoding:=0;
237 Stream.Read(Encoding, SizeOf(Encoding));
238 FCompressed:=BEtoN(Encoding) = 1;
239 if BEtoN(Encoding)>1 then
240 Raise Exception.Create('Unknown compression type');
241 If FCompressed then
242 begin
243 SetLength(FLengthOfLine, FHeight * FChannelCount);
244 Stream.ReadBuffer(FLengthOfLine[0], 2 * Length(FLengthOfLine));
245 Progress(FPimage.psRunning, 0, False, Rect(0,0,0,0), '', ContProgress);
246 if not ContProgress then exit;
247 if not (FHeader.Mode in [0, 2]) then
248 LenOfLineFactor := FHeader.Depth div 8
249 else
250 LenOfLineFactor := 1;
251 end else
252 begin
253 FLengthOfLine := nil;
254 end;
255
256 setlength(FInputLine, FHeight * FChannelCount);
257 CurOffset := Stream.Position;
258 H := 0;
259 channel := 0;
260 InputLineIndex:= 0;
261 for LenOfLineIndex := 0 to FHeight * FChannelCount-1 do
262 begin
263 FInputLine[InputLineIndex].StreamOffset := CurOffset;
264 if FLengthOfLine <> nil then
265 FInputLine[InputLineIndex].Size := BEtoN(FLengthOfLine[LenOfLineIndex])*LenOfLineFactor else
266 FInputLine[InputLineIndex].Size := FLineSize;
267 inc(CurOffset, FInputLine[InputLineIndex].Size);
268 inc(H);
269 Inc(InputLineIndex, FChannelCount);
270 if H = FHeight then
271 begin
272 H := 0;
273 Inc(channel);
274 InputLineIndex:= channel;
275 end;
276 end;
277
278 InputLineIndex := 0;
279 PrevOutputRow := -1;
280 OutputRow := 0;
281 OutputRowAdd := FOutputHeight div FHeight;
282 OutputRowMod:= FHeight;
283 OutputRowAccAdd := FOutputHeight mod FHeight;
284 OutputRowAcc:= 0;
285
286 For H := 0 to FHeight - 1 do
287 begin
288 if OutputRow > PrevOutputRow then
289 begin
290 for channel := 0 to FChannelCount-1 do
291 begin
292 Stream.Position := FInputLine[InputLineIndex].StreamOffset;
293 ReadScanLine(Stream, FInputLine[InputLineIndex].Size, channel);
294 Inc(InputLineIndex);
295 end;
296 For HOutput:= PrevOutputRow+1 to OutputRow do WriteScanLine(Img, HOutput);
297 Progress(FPimage.psRunning, round((H+1)*99.0 / (FHeight * FChannelCount)), False, Rect(0,0,0,0), '', ContProgress);
298 if not ContProgress then exit;
299 end else inc(InputLineIndex, FChannelCount);
300
301 PrevOutputRow:= OutputRow;
302 Inc(OutputRow, OutputRowAdd);
303 Inc(OutputRowAcc, OutputRowAccAdd);
304 if OutputRowAcc> OutputRowMod then
305 begin
306 dec(OutputRowAcc, OutputRowMod);
307 inc(OutputRow);
308 end;
309 end;
310 Progress(FPimage.psRunning, 100, False, Rect(0,0,0,0), '', ContProgress);
311 if not ContProgress then exit;
312
313 {$ifdef FPC_Debug_Image}
314 WriteLn('TBGRAReaderPSD.InternalRead AAA1 ',Stream.position,' ',Stream.size);
315 {$endif}
316 finally
317 FreeAndNil(FPalette);
318 for channel := 0 to FChannelCount-1 do
319 ReAllocMem(FScanLines[channel],0);
320 end;
321 Progress(FPimage.psEnding, 100, false, Rect(0,0,FWidth,FHeight), '', ContProgress);
322end;
323
324function TBGRAReaderPSD.ReadScanLine(Stream: TStream; AInputSize: PtrInt;
325 AChannel: integer): boolean;
326Var
327 P : PByte;
328 B : Byte;
329 I, left : PtrInt;
330 N : Shortint;
331 Count:integer;
332 buf, PBuf: PByte;
333begin
334 Result:=false;
335 If Not Compressed then
336 Stream.ReadBuffer(FScanLines[AChannel]^,FLineSize)
337 else
338 begin
339 getmem(buf, AInputSize);
340 if stream.Read(buf^,AInputSize) <> AInputSize then
341 begin
342 freemem(buf);
343 result := false;
344 exit;
345 end;
346 P:=FScanLines[AChannel];
347 left := FLineSize;
348 i:=AInputSize;
349 PBuf := buf;
350 repeat
351 Count:=0;
352 N:= PShortInt(PBuf)^;
353 inc(PBuf);
354 dec(i);
355 If N = -128 then
356 else
357 if N < 0 then
358 begin
359 Count:=-N+1;
360 if Count > left then Count := left;
361 dec(left,Count);
362 B:= PBuf^;
363 Inc(PBuf);
364 dec(i);
365 fillchar(p^,count,B);
366 inc(p,count);
367 end
368 else
369 begin
370 Count:=N+1;
371 if Count > left then Count := left;
372 dec(left,Count);
373 Move(PBuf^, P^, Count);
374 Inc(PBuf, Count);
375 inc(p, count);
376 dec(i, count);
377 end;
378 until (i <= 0) or (left <= 0);
379 freemem(buf);
380 end;
381 Result:=true;
382end;
383
384function Value32To16(p: PDWord; gamma: single): Word;
385var v: single;
386begin
387 v := (BEtoN(P^) - 1024000000)/40960000;
388 if v <= 0 then result := 0 else
389 if v >= 1 then result := 65535 else
390 result := round(exp(ln(v)*gamma)*65535);
391end;
392
393procedure TBGRAReaderPSD.WriteScanLine(Img: TFPCustomImage; Row: integer);
394Var
395 Col : Integer;
396 C : TFPColor;
397 P, P1, P2, P3 : PByte;
398 Lab : TLab;
399begin
400 C.Alpha:=AlphaOpaque;
401 P:=FScanLines[0];
402 begin
403 case FBytesPerPixel of
404 1 : begin
405 for Col:=0 to Img.Width-1 do
406 if (P[col div 8] and (128 shr (col mod 8))) <> 0 then
407 Img.Colors[Col,Row]:=ThePalette[0]
408 else
409 Img.Colors[Col,Row]:=ThePalette[1];
410 end;
411 8 : begin
412 for Col:=0 to Img.Width-1 do
413 begin
414 Img.Colors[Col,Row]:=ThePalette[P[0]];
415 inc(p);
416 end;
417 end;
418 16 : if (FHeader.Mode = 1) or (FHeader.Mode = 8) then
419 begin
420 if FChannelCount = 1 then
421 for Col:=0 to Img.Width-1 do
422 begin
423 C.Red:=BEtoN(PWord(P)^);
424 C.green:=C.Red;
425 C.blue:=C.Red;
426 C.alpha:=65535;
427 Img[col, row] := C;
428 Inc(P,2);
429 end else
430 if FChannelCount = 2 then
431 begin
432 P1:=FScanLines[1];
433 for Col:=0 to Img.Width-1 do
434 begin
435 C.Red:=P^ shl 8 + P^;
436 C.green:=C.Red;
437 C.blue:=C.Red;
438 C.alpha:=p1^ shl 8 + P1^;
439 Img[col, row] := C;
440 Inc(P);
441 Inc(P1);
442 end;
443 end;
444 end else
445 begin
446 for Col:=0 to Img.Width-1 do
447 begin
448 Img.Colors[Col,Row]:=ThePalette[BEtoN(PWord(P)^)];
449 inc(p,2);
450 end;
451 end;
452 24 : if FChannelCount>=3 then
453 begin
454 P1:=FScanLines[1];
455 P2:=FScanLines[2];
456 for Col:=0 to Img.Width-1 do
457 begin
458 if (FHeader.Mode =9) then
459 begin
460 Lab.L:=P[0];
461 Lab.a:=P1[0];
462 Lab.b:=P2[0];
463 C:=LabToRGB(Lab);
464 end
465 else
466 With C do
467 begin
468 Red:=P[0] or (P[0] shl 8);
469 green:=P1[0] or (P1[0] shl 8);
470 blue:=P2[0] or (P2[0] shl 8);
471 alpha:=alphaOpaque;
472 end;
473 Inc(P);
474 Inc(P1);
475 Inc(P2);
476 Img[col, row] := C;
477 end;
478 end;
479 32 : if (FHeader.Mode = 1) or (FHeader.Mode = 8) then
480 begin
481 if FChannelCount = 1 then
482 for Col:=0 to Img.Width-1 do
483 begin
484 C.Red:=Value32To16(PDWord(P),1.3);
485 C.green:=C.Red;
486 C.blue:=C.Red;
487 C.alpha:=65535;
488 Img[col, row] := C;
489 Inc(P,4);
490 end else
491 if FChannelCount = 2 then
492 begin
493 P1:=FScanLines[1];
494 for Col:=0 to Img.Width-1 do
495 begin
496 C.Red:=BEtoN(PWord(P)^);
497 C.green:=C.Red;
498 C.blue:=C.Red;
499 C.alpha:=BEtoN(PWord(p1)^);
500 Img[col, row] := C;
501 Inc(P,2);
502 Inc(P1,2);
503 end;
504 end;
505 end else
506 if FChannelCount >= 4 then
507 begin
508 P1:=FScanLines[1];
509 P2:=FScanLines[2];
510 P3:=FScanLines[3];
511 for Col:=0 to Img.Width-1 do
512 begin
513 if (FHeader.Mode =4) then
514 begin
515 P^ := 255 - P^;
516 P1^ := 255 - P1^;
517 P2^ := 255 - P2^;
518 P3^ := 255 - P3^;
519 end;
520 C.Red:=P[0] or (P[0] shl 8);
521 C.green:=P1[0] or (P1[0] shl 8);
522 C.blue:=P2[0] or (P2[0] shl 8);
523 C.alpha:=P3[0] or (P3[0] shl 8);
524 if (FHeader.Mode =4) then C:=CMYKtoRGB(C); // CMYK to RGB
525 Img[col, row] := C;
526 Inc(P);
527 Inc(P1);
528 Inc(P2);
529 Inc(P3);
530 end;
531 end;
532 48 :if FChannelCount = 3 then
533 begin
534 P1:=FScanLines[1];
535 P2:=FScanLines[2];
536 C.alpha:=alphaOpaque;
537 for Col:=0 to Img.Width-1 do
538 begin
539 if (FHeader.Mode =9) then
540 C := LabToRGB(BEtoN(PWord(P)^)/65535, (BEtoN(PWord(P1)^)-32768)/32767, (BEtoN(PWord(P2)^)-32768)/32767)
541 else
542 With C do
543 begin
544 Red:=BEtoN(PWord(P)^);
545 green:=BEtoN(PWord(P1)^);
546 blue:=BEtoN(PWord(P2)^);
547 end;
548 Inc(P,2);
549 Inc(P1,2);
550 Inc(P2,2);
551 Img[col, row] := C;
552 end;
553 end;
554 64 : if FChannelCount = 4 then
555 begin
556 P1:=FScanLines[1];
557 P2:=FScanLines[2];
558 P3:=FScanLines[3];
559 for Col:=0 to Img.Width-1 do
560 begin
561 C.Red:=BEtoN(PWord(P)^);
562 C.green:=BEtoN(PWord(P1)^);
563 C.blue:=BEtoN(PWord(P2)^);
564 C.alpha:=BEtoN(PWord(P3)^);
565 if (FHeader.Mode =4) then
566 begin
567 C.red:=$ffff-C.red;
568 C.green:=$ffff-C.green;
569 C.blue:=$ffff-C.blue;
570 C.alpha:=$ffff-C.alpha;
571 end;
572 if (FHeader.Mode =4) then C:=CMYKtoRGB(C); // CMYK to RGB
573 Img[col, row] := C;
574 Inc(P,2);
575 Inc(P1,2);
576 Inc(P2,2);
577 Inc(P3,2);
578 end;
579 end;
580 96 :if FChannelCount = 3 then
581 begin
582 P1:=FScanLines[1];
583 P2:=FScanLines[2];
584 C.alpha:=alphaOpaque;
585 for Col:=0 to Img.Width-1 do
586 begin
587 With C do
588 begin
589 Red:=Value32To16(PDWord(P),2.7);
590 green:=Value32To16(PDWord(P1),2.7);
591 blue:=Value32To16(PDWord(P2),2.7);
592 end;
593 Inc(P,4);
594 Inc(P1,4);
595 Inc(P2,4);
596 Img[col, row] := C;
597 end;
598 end;
599 end;
600 end;
601end;
602
603function TBGRAReaderPSD.InternalCheck(Stream: TStream): boolean;
604var
605 OldPos: Int64;
606begin
607 try
608 OldPos:=Stream.Position;
609 Stream.Read(FHeader,SizeOf(FHeader));
610 Result:=(FHeader.Signature = '8BPS');
611 Stream.Position:=OldPos;
612 except
613 Result:=False;
614 end;
615end;
616
617constructor TBGRAReaderPSD.Create;
618begin
619 inherited Create;
620end;
621
622initialization
623
624 DefaultBGRAImageReader[ifPsd] := TBGRAReaderPSD;
625
626end.
Note: See TracBrowser for help on using the repository browser.