1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 { This unit provides some optimisations of TFPReaderGif: decompression algorithm and direct pixel access of TBGRABitmap.
3 Note: to read an animation use TBGRAAnimatedGif instead. }
4
5 unit BGRAReadGif;
6
7 {$mode objfpc}{$H+}
8
9 interface
10
11 uses
12 BGRAClasses, SysUtils, FPimage, FPReadGif;
13
14 type
15 PGifRGB = ^TGifRGB;
16
17 { TBGRAReaderGif }
18
19 TBGRAReaderGif = class(TFPReaderGif)
20 protected
21 procedure ReadPaletteAtOnce(Stream: TStream; Size: integer);
22 procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
ReadScanLinenull23 function ReadScanLine(Stream: TStream): boolean; override;
WriteScanLineBGRAnull24 function WriteScanLineBGRA(Img: TFPCustomImage): Boolean; virtual;
25 end;
26
27 implementation
28
29 uses BGRABitmapTypes;
30
31 { TBGRAReaderGif }
32
33 procedure TBGRAReaderGif.ReadPaletteAtOnce(Stream: TStream; Size: integer);
34 Var
35 RGBEntries, RGBEntry : PGifRGB;
36 I : Integer;
37 c : TFPColor;
38 begin
39 FPalette.count := 0;
40 getmem(RGBEntries, sizeof(TGifRGB)*Size);
41 Stream.Read(RGBEntries^, sizeof(TGifRGB)*Size);
42 For I:=0 To Size-1 Do
43 Begin
44 RGBEntry := RGBEntries+I;
45 With c do
46 begin
47 Red:=RGBEntry^.Red or (RGBEntry^.Red shl 8);
48 Green:=RGBEntry^.Green or (RGBEntry^.Green shl 8);
49 Blue:=RGBEntry^.Blue or (RGBEntry^.Blue shl 8);
50 Alpha:=alphaOpaque;
51 end;
52 FPalette.Add(C);
53 End;
54 FreeMem(RGBEntries);
55 end;
56
57 procedure TBGRAReaderGif.InternalRead(Stream: TStream; Img: TFPCustomImage);
58 var
59 Introducer:byte;
60 ColorTableSize :Integer;
61 ContProgress: Boolean;
62 begin
63 FPalette:=nil;
64 FScanLine:=nil;
65 try
66 ContProgress:=true;
67 Progress(psStarting, 0, False, Rect(0,0,0,0), '', ContProgress);
68 if not ContProgress then exit;
69
70 FPalette := TFPPalette.Create(0);
71
72 Stream.Position:=0;
73 // header
74 Stream.Read(FHeader,SizeOf(FHeader));
75 Progress(psRunning, 0, False, Rect(0,0,0,0), '', ContProgress);
76 if not ContProgress then exit;
77
78 // Endian Fix Mantis 8541. Gif is always little endian
79 {$IFDEF ENDIAN_BIG}
80 with FHeader do
81 begin
82 ScreenWidth := LEtoN(ScreenWidth);
83 ScreenHeight := LEtoN(ScreenHeight);
84 end;
85 {$ENDIF}
86 // global palette
87 if (FHeader.Packedbit and $80) <> 0 then
88 begin
89 ColorTableSize := FHeader.Packedbit and 7 + 1;
90 ReadPaletteAtOnce(stream, 1 shl ColorTableSize);
91 end;
92
93 // skip extensions
94 Repeat
95 Introducer:=SkipBlock(Stream);
96 until (Introducer = $2C) or (Introducer = $3B);
97
98 // descriptor
99 Stream.Read(FDescriptor, SizeOf(FDescriptor));
100 {$IFDEF ENDIAN_BIG}
101 with FDescriptor do
102 begin
103 Left := LEtoN(Left);
104 Top := LEtoN(Top);
105 Width := LEtoN(Width);
106 Height := LEtoN(Height);
107 end;
108 {$ENDIF}
109 // local palette
110 if (FDescriptor.Packedbit and $80) <> 0 then
111 begin
112 ColorTableSize := FDescriptor.Packedbit and 7 + 1;
113 ReadPaletteAtOnce(stream, 1 shl ColorTableSize);
114 end;
115
116 // parse header
117 if not AnalyzeHeader then exit;
118
119 // create image
120 if Assigned(OnCreateImage) then
121 OnCreateImage(Self,Img);
122 Img.SetSize(FWidth,FHeight);
123
124 // read pixels
125 if not ReadScanLine(Stream) then exit;
126 if Img is TBGRACustomBitmap then
127 begin
128 if not WriteScanLineBGRA(Img) then exit;
129 end else
130 if not WriteScanLine(Img) then exit;
131
132 // ToDo: read further images
133 finally
134 FreeAndNil(FPalette);
135 ReAllocMem(FScanLine,0);
136 end;
137 Progress(FPimage.psEnding, 100, false, Rect(0,0,FWidth,FHeight), '', ContProgress);
138 end;
139
ReadScanLinenull140 function TBGRAReaderGif.ReadScanLine(Stream: TStream): Boolean;
141 var
142 OldPos,
143 UnpackedSize,
144 PackedSize:longint;
145 I: Integer;
146 Data,
147 Bits,
148 Code: LongWord;
149 SourcePtr: PByte;
150 InCode: LongWord;
151
152 CodeSize: LongWord;
153 CodeMask: LongWord;
154 FreeCode: LongWord;
155 OldCode: LongWord;
156 Prefix: array[0..4095] of LongWord;
157 Suffix,
158 Stack: array [0..4095] of Byte;
159 StackPointer, StackTop: PByte;
160 StackSize: integer;
161 DataComp,
162 Target: PByte;
163 {%H-}B,
164 {%H-}FInitialCodeSize,
165 FirstChar: Byte;
166 ClearCode,
167 EOICode: Word;
168 ContProgress: Boolean;
169
170 begin
171 DataComp:=nil;
172 ContProgress:=true;
173 try
174 // read dictionary size
175 Stream.read({%H-}FInitialCodeSize, 1);
176
177 // search end of compressor table
178 OldPos:=Stream.Position;
179 PackedSize := 0;
180 Repeat
181 Stream.read({%H-}B, 1);
182 if B > 0 then
183 begin
184 inc(PackedSize, B);
185 Stream.Seek(B, soFromCurrent);
186 end;
187 until B = 0;
188
189 Progress(psRunning, trunc(100.0 * (Stream.position / Stream.size)),
190 False, Rect(0,0,0,0), '', ContProgress);
191 if not ContProgress then exit(false);
192
193 Getmem(DataComp, PackedSize);
194 // read compressor table
195 SourcePtr:=DataComp;
196 Stream.Position:=OldPos;
197 Repeat
198 Stream.read(B, 1);
199 if B > 0 then
200 begin
201 Stream.ReadBuffer(SourcePtr^, B);
202 Inc(SourcePtr,B);
203 end;
204 until B = 0;
205
206 Progress(psRunning, trunc(100.0 * (Stream.position / Stream.size)),
207 False, Rect(0,0,0,0), '', ContProgress);
208 if not ContProgress then exit(false);
209
210 SourcePtr:=DataComp;
211 Target := FScanLine;
212 CodeSize := FInitialCodeSize + 1;
213 ClearCode := 1 shl FInitialCodeSize;
214 EOICode := ClearCode + 1;
215 FreeCode := ClearCode + 2;
216 OldCode := 4096;
217 CodeMask := (1 shl CodeSize) - 1;
218 UnpackedSize:=FWidth * FHeight;
219 for I := 0 to ClearCode - 1 do
220 begin
221 Prefix[I] := 4096;
222 Suffix[I] := I;
223 end;
224 StackTop := @Stack[high(Stack)];
225 StackPointer := StackTop;
226 FirstChar := 0;
227 Data := 0;
228 Bits := 0;
229 // LZW decompression gif
230 while (UnpackedSize > 0) and (PackedSize > 0) do
231 begin
232 Inc(Data, SourcePtr^ shl Bits);
233 Inc(Bits, 8);
234 while Bits >= CodeSize do
235 begin
236 Code := Data and CodeMask;
237 Data := Data shr CodeSize;
238 Dec(Bits, CodeSize);
239 if Code = EOICode then Break;
240 if Code = ClearCode then
241 begin
242 CodeSize := FInitialCodeSize + 1;
243 CodeMask := (1 shl CodeSize) - 1;
244 FreeCode := ClearCode + 2;
245 OldCode := 4096;
246 Continue;
247 end;
248 if Code > FreeCode then Break;
249 if OldCode = 4096 then
250 begin
251 FirstChar := Suffix[Code];
252 Target^ := FirstChar;
253 Inc(Target);
254 Dec(UnpackedSize);
255 OldCode := Code;
256 Continue;
257 end;
258 InCode := Code;
259 if Code = FreeCode then
260 begin
261 StackPointer^ := FirstChar;
262 dec(StackPointer);
263 Code := OldCode;
264 end;
265 while Code > ClearCode do
266 begin
267 StackPointer^ := Suffix[Code];
268 dec(StackPointer);
269 Code := Prefix[Code];
270 end;
271 FirstChar := Suffix[Code];
272 StackPointer^ := FirstChar;
273 dec(StackPointer);
274 Prefix[FreeCode] := OldCode;
275 Suffix[FreeCode] := FirstChar;
276 if (FreeCode = CodeMask) and
277 (CodeSize < 12) then
278 begin
279 Inc(CodeSize);
280 CodeMask := (1 shl CodeSize) - 1;
281 end;
282 if FreeCode < 4095 then Inc(FreeCode);
283 OldCode := InCode;
284 StackSize := StackTop-StackPointer;
285 if StackSize > 0 then
286 begin
287 Move((StackPointer+1)^, Target^, StackSize);
288 inc(Target, StackSize);
289 StackPointer:= StackTop;
290 dec(UnpackedSize, StackSize);
291 end;
292 end;
293 Inc(SourcePtr);
294 Dec(PackedSize);
295 end;
296 Progress(psRunning, trunc(100.0 * (Stream.position / Stream.size)),
297 False, Rect(0,0,0,0), '', ContProgress);
298 if not ContProgress then exit(false);
299 finally
300 if DataComp<>nil then
301 FreeMem(DataComp);
302 end;
303 Result:=true;
304 end;
305
TBGRAReaderGif.WriteScanLineBGRAnull306 function TBGRAReaderGif.WriteScanLineBGRA(Img: TFPCustomImage): Boolean;
307 Var
308 Row, Col,i : Integer;
309 Pass, Every : byte;
310 P : PByte;
311 PBGRAPalette: PBGRAPixel;
312 PDest: PBGRAPixel;
IsMultiplenull313 function IsMultiple(NumberA, NumberB: Integer): Boolean;
314 begin
315 Result := (NumberA >= NumberB) and
316 (NumberB > 0) and
317 (NumberA mod NumberB = 0);
318 end;
319 begin
320 Result:=false;
321 P:=FScanLine;
322 getmem(PBGRAPalette, (FPalette.Count)*sizeof(TBGRAPixel));
323 for i := 0 to FPalette.Count-1 do PBGRAPalette[i] := FPColorToBGRA(FPalette.Color[i]);
324 If FInterlace then
325 begin
326 For Pass := 1 to 4 do
327 begin
328 Case Pass of
329 1 : begin
330 Row := 0;
331 Every := 8;
332 end;
333 2 : begin
334 Row := 4;
335 Every := 8;
336 end;
337 3 : begin
338 Row := 2;
339 Every := 4;
340 end;
341 else{4}
342 begin
343 Row := 1;
344 Every := 2;
345 end;
346 end;
347 Repeat
348 PDest := TBGRACustomBitmap(Img).ScanLine[Row];
349 for Col:=Img.Width-1 downto 0 do
350 begin
351 PDest^ := PBGRAPalette[P^];
352 Inc(P);
353 Inc(PDest);
354 end;
355 Inc(Row, Every);
356 until Row >= Img.Height;
357 end;
358 end
359 else
360 begin
361 for Row:=0 to Img.Height-1 do
362 begin
363 PDest := TBGRACustomBitmap(Img).ScanLine[Row];
364 for Col:=Img.Width-1 downto 0 do
365 begin
366 PDest^ := PBGRAPalette[P^];
367 Inc(P);
368 Inc(PDest);
369 end;
370 end;
371 end;
372 FreeMem(PBGRAPalette);
373 Result:=true;
374 end;
375
376
377 initialization
378
379 DefaultBGRAImageReader[ifGif] := TBGRAReaderGif;
380
381 end.
382