source: trunk/Packages/bgrabitmap/bgrareadgif.pas

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