source: trunk/Packages/bgrabitmap/bgralzpcommon.pas

Last change on this file was 2, checked in by chronos, 6 years ago
File size: 18.1 KB
Line 
1unit BGRALzpCommon;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils;
9
10const
11 LAZPAINT_COMPRESSION_MODE_ZSTREAM = 1;
12 LAZPAINT_COMPRESSION_MODE_RLE = 2;
13 LAZPAINT_COMPRESSION_MASK = 255;
14 LAZPAINT_THUMBNAIL_PNG = 256;
15 LAZPAINT_MAGIC_HEADER : array[0..7] of char = 'LazPaint';
16
17 LazpaintChannelGreenFromRed = 1;
18 LazpaintChannelBlueFromRed = 2;
19 LazpaintChannelBlueFromGreen = 4;
20 LazpaintChannelNoAlpha = 8;
21 LazpaintPalettedRGB = 16;
22
23 LazPaintThumbMaxWidth = 128;
24 LazPaintThumbMaxHeight = 128;
25
26type
27 TLzpCompression = (lzpZStream, //slower and not necessarily better
28 lzpRLE); //custom RLE for lzp files
29
30 { TLazPaintImageHeader }
31
32 TLazPaintImageHeader = packed record
33 magic: packed array[0..7] of char;
34 zero1, headerSize: DWord;
35 width, height, nbLayers, previewOffset: DWord;
36 zero2, compressionMode, reserved1, layersOffset: DWord;
37 end;
38
39procedure LazPaintImageHeader_SwapEndianIfNeeded(AHeader: TLazPaintImageHeader);
40
41//routines to compress and uncompress byte-sized values (you need to
42//separate the channels to obtain any compression)
43
44procedure EncodeLazRLE(var sourceBuffer; size:PtrInt; ADest: TStream);
45function DecodeLazRLE(ASource: TStream; var destBuffer; availableOutputSize: PtrInt; availableInputSize: int64 = -1): PtrInt;
46
47implementation
48
49uses bufstream;
50
51const //flag to distinguish ranges of opcodes
52 simpleRepetitionFlag = $00; // $01..$3f: normal repetition
53 packedRepetitionFlag = $40; // $41..$5f: packed repetition
54 repetitionOf0Flag = $60; // $60..$6f: repeat 1..16 zeros
55 repetitionOf255Flag = $70; // $70..$7f: repeat 1..16 values of 255
56 simpleDumpFlag = $80; // $81: dump of size as byte+64, $82..$bf: simple dump (2..63)
57 packedDumpFlag = $c0; // $c3..$df: packed dump (3..31)
58 packedDumpFromLastFlag= $e0; // $e2..$fe: packed dump from last packed dump value (2..30)
59
60 //special opcodes
61 wordRepetitionOpCode = $00; //followed by word and then a value to repeat
62 byteRepetitionOpCode = $40; //followed by byte (add 64 to it to get the repetition count) and then a value to repeat
63 previousWordSizeRepetitionOpCode = $80; //use the last value of opcode $00 so only followed by value to repeat
64 previousByteSizeRepetitionOpCode = $c0; //use the last value of opcode $80 so only followed by value to repeat
65 endOfStreamOpCode = $e0; //end of RLE stream (not necessarily the end of the image)
66
67 //for future use but must not be accepted in the input stream
68 {%H-}reservedOpCode1 = $c1;
69 {%H-}reservedOpCode2 = $c2;
70 {%H-}reservedOpCode3 = $e1;
71
72 {%H-}optionalOpCode = $ff; //for future use but should be ignored if not recognized
73
74 //numeric information
75 maxNormalRepetition = 63;
76 maxSmallRepCount = 31 * 4; // sets of four packed repetition
77 maxDumpCount = 255+32;
78
79 maxRepetition = 65535; // normal: 1..63, byte+64: 64..319, word-sized: 0..65535
80 minSmallRep = 1;
81 maxSmallRep = minSmallRep+3;
82
83
84procedure EncodeLazRLE(var sourceBuffer; size:PtrInt; ADest: TStream);
85var
86 smallRepetitions: array[0..maxSmallRepCount-1] of record
87 value: NativeInt;
88 count: NativeInt; //minSmallRep..maxSmallRep
89 end;
90 smallRepetitionsCount, smallRepTotal: NativeInt;
91 buf: TStream;
92 previousWordSizeRepetition, previousByteSizeRepetition: NativeInt;
93 lastPackedDumpValue: NativeInt;
94
95 procedure OutputNormalRepetition(AValue,ACount: NativeInt);
96 begin
97 If (ACount < 1) or (ACount > maxNormalRepetition) then
98 raise exception.Create('Invalid count');
99
100 if (AValue = 0) and (ACount <= 16) then
101 begin
102 buf.WriteByte((ACount-1) or repetitionOf0Flag);
103 end else
104 if (AValue = 255) and (ACount <= 16) then
105 begin
106 buf.WriteByte((ACount-1) or repetitionOf255Flag);
107 end else
108 begin
109 buf.WriteByte(ACount or simpleRepetitionFlag);
110 buf.WriteByte(AValue);
111 end;
112 end;
113
114 procedure FlushSmallRepetitions;
115 var i,j: NativeInt;
116 packedCount: NativeInt;
117 smallOutput: NativeInt;
118 begin
119 if smallRepetitionsCount = 0 then exit;
120 if smallRepetitionsCount >= 4 then
121 begin
122 smallOutput:= smallRepetitionsCount and not 3;
123 buf.Writebyte(packedRepetitionFlag or (smallOutput shr 2));
124 packedCount := 0;
125 for i := 0 to smallOutput-1 do
126 begin
127 packedCount := packedCount + ((smallRepetitions[i].count-minSmallRep) shl ((i and 3) shl 1));
128 if (i and 3) = 3 then
129 begin
130 buf.WriteByte(packedCount);
131 for j := i-3 to i do
132 buf.WriteByte(smallRepetitions[j].value);
133 packedCount:= 0;
134 end;
135 end;
136 for i := smallOutput to smallRepetitionsCount-1 do
137 OutputNormalRepetition(smallRepetitions[i].value,smallRepetitions[i].count);
138 end else
139 begin
140 for i := 0 to smallRepetitionsCount-1 do
141 OutputNormalRepetition(smallRepetitions[i].value,smallRepetitions[i].count);
142 end;
143 smallRepetitionsCount := 0;
144 smallRepTotal := 0;
145 end;
146
147 procedure OutputRepetition(AValue,ACount: NativeInt; AAccumulate: boolean = true);
148 begin
149 if AAccumulate and (ACount >= minSmallRep) and (ACount <= maxSmallRep) and (maxSmallRepCount>0) then
150 begin
151 if (smallRepetitionsCount> 0) and (smallRepetitions[smallRepetitionsCount-1].value = AValue) and
152 (smallRepetitions[smallRepetitionsCount-1].count+ACount <= maxSmallRepCount) then
153 begin
154 inc(smallRepetitions[smallRepetitionsCount-1].count, ACount);
155 exit;
156 end;
157 if smallRepetitionsCount = maxSmallRepCount then
158 FlushSmallRepetitions;
159 if smallRepetitionsCount and 3 = 0 then smallRepTotal := 0;
160 smallRepetitions[smallRepetitionsCount].value := AValue;
161 smallRepetitions[smallRepetitionsCount].count := ACount;
162 inc(smallRepetitionsCount);
163 inc(smallRepTotal, ACount);
164 end else
165 begin
166 flushSmallRepetitions;
167 if ACount <= maxNormalRepetition then
168 OutputNormalRepetition(AValue,ACount) else
169 begin
170 if ACount = previousWordSizeRepetition then
171 begin
172 buf.WriteByte(previousWordSizeRepetitionOpCode);
173 buf.WriteByte(AValue);
174 end else
175 if ACount = previousByteSizeRepetition then
176 begin
177 buf.WriteByte(previousByteSizeRepetitionOpCode);
178 buf.WriteByte(AValue);
179 end else
180 if ACount <= 64+255 then
181 begin
182 buf.WriteByte(byteRepetitionOpCode);
183 buf.WriteByte(ACount-64);
184 buf.WriteByte(AValue);
185 previousByteSizeRepetition := ACount;
186 end else
187 if ACount <= 65535 then
188 begin
189 buf.WriteByte(wordRepetitionOpCode);
190 buf.WriteByte(ACount shr 8);
191 buf.WriteByte(ACount and 255);
192 buf.WriteByte(AValue);
193 previousWordSizeRepetition := ACount;
194 end else
195 raise exception.Create('Invalid count');
196 end;
197 end;
198 end;
199
200 procedure DumpNoPack(P: PByte; ACount: NativeInt);
201 begin
202 if ACount = 0 then exit;
203 if ACount = 1 then
204 begin
205 OutputNormalRepetition(p^,1);
206 exit;
207 end;
208 If (ACount < 0) or (ACount > maxDumpCount) then
209 raise exception.Create('Invalid count');
210
211 if ACount > 63 then
212 begin
213 if ACount > 255+64 then
214 raise exception.Create('Invalid count');
215 buf.WriteByte($01 or simpleDumpFlag);
216 buf.WriteByte(ACount-64);
217 end else
218 buf.WriteByte(ACount or simpleDumpFlag);
219
220 buf.Write(p^, ACount);
221 end;
222
223 procedure DumpPacked(p : PByte; ACount: NativeInt);
224 var diffLast: integer;
225 packedValues: array[0..31] of NativeInt;
226 nbPackedValues, idx: NativeInt;
227
228 begin
229 if ACount = 0 then exit else
230 if ACount = 1 then
231 begin
232 OutputNormalRepetition(p^,1);
233 exit;
234 end else
235 if ACount = 2 then
236 begin
237 DumpNoPack(p, ACount);
238 exit;
239 end;
240 If (ACount < 3) or (ACount > maxDumpCount) then
241 raise exception.Create('Invalid count');
242
243 diffLast := p^ - lastPackedDumpValue;
244 if (diffLast < -7) or (diffLast > 7) then
245 begin
246 if ACount > 31 then
247 begin
248 DumpPacked(p, 31);
249 DumpPacked(p+31, ACount-31);
250 exit;
251 end;
252 buf.WriteByte(ACount or packedDumpFlag);
253 lastPackedDumpValue:= p^;
254 buf.WriteByte(lastPackedDumpValue);
255 dec(ACount);
256 inc(p);
257 end else
258 if ACount > 30 then
259 begin
260 while ACount > 30 do
261 begin
262 DumpPacked(p, 30);
263 inc(p,30);
264 dec(ACount,30);
265 end;
266 DumpPacked(p, ACount);
267 exit;
268 end else
269 buf.WriteByte(ACount or packedDumpFromLastFlag);
270
271 nbPackedValues := 0;
272 while ACount >0 do
273 begin
274 packedValues[nbPackedValues] := (p^ - lastPackedDumpValue + 8) and 15;
275 inc(nbPackedValues);
276 lastPackedDumpValue := p^;
277 inc(p);
278 dec(ACount);
279 end;
280
281 idx := 0;
282 while idx < nbPackedValues do
283 begin
284 if idx+1 = nbPackedValues then
285 begin
286 buf.WriteByte(packedValues[idx] shl 4);
287 break;
288 end;
289 buf.WriteByte((packedValues[idx] shl 4) + packedValues[idx+1]);
290 inc(idx,2);
291 end;
292 end;
293
294 procedure Dump(p: PByte; ACount: NativeInt);
295 const smallestPackedDump = 5;
296 smallestPackedDumpTail = 3;
297 var
298 diffVal,i: NativeInt;
299 fitPackStart: NativeInt;
300 p2: PByte;
301 begin
302 if ACount >= smallestPackedDump then
303 begin
304 p2 := p+1;
305 fitPackStart := -1;
306 for i := 1 to ACount-1 do
307 begin
308 diffVal := p2^ - (p2-1)^;
309 if diffVal > 128 then dec(diffVal,256)
310 else if diffVal < -128 then inc(diffVal,256);
311 if (diffVal > 7) or (diffVal < -7) then
312 begin
313 if (fitPackStart <> -1) and
314 ((i-fitPackStart+1 >= smallestPackedDump) or
315 ((i-fitPackStart+1 >= smallestPackedDumpTail) and
316 (fitPackStart = 1) )) then
317 begin
318 DumpNoPack(p, fitPackStart-1);
319 DumpPacked(p+(fitPackStart-1), i-fitPackStart+1);
320 Dump(p+i, ACount-i);
321 exit;
322 end;
323 fitPackStart := -1;
324 end else
325 if fitPackStart = -1 then fitPackStart := i;
326 inc(p2);
327 end;
328 if (fitPackStart <> -1) and (ACount-fitPackStart+1 >= smallestPackedDumpTail) then
329 begin
330 DumpNoPack(p,fitPackStart-1);
331 DumpPacked(p+(fitPackStart-1), ACount-fitPackStart+1);
332 exit;
333 end;
334 ACount := ACount;
335 end;
336 DumpNoPack(p, ACount);
337 end;
338
339var
340 psrc,psrcBefore: PByte;
341 curValue: NativeInt;
342 curCount: NativeInt;
343begin
344 if size = 0 then exit;
345 psrc := @sourceBuffer;
346 if psrc = nil then
347 raise exception.Create('Source buffer not provided');
348 buf := TWriteBufStream.Create(ADest,4096);
349 curValue := psrc^;
350 curCount := 1;
351 inc(psrc);
352 dec(size);
353 smallRepetitionsCount := 0;
354 smallRepTotal := 0;
355 previousWordSizeRepetition := 0;
356 previousByteSizeRepetition := 0;
357 lastPackedDumpValue:= $80;
358 while size > 0 do
359 begin
360 if (psrc^ = curValue) and (curCount < maxRepetition) then
361 begin
362 inc(curCount);
363 dec(size);
364 inc(psrc);
365 end else
366 if (curCount > 1) or (((smallRepetitionsCount and 3) <> 0) and (smallRepTotal >= 5)) then
367 begin
368 outputRepetition(curValue,curCount);
369 curCount := 1;
370 curValue := psrc^;
371 dec(size);
372 inc(psrc);
373 end else //curCount = 1
374 begin
375 psrcBefore := psrc-1;
376 inc(psrc);
377 inc(curCount);
378 dec(size);
379 while (curCount < maxDumpCount) and (size>0) and
380 ( (psrc^ <> (psrc-1)^) or ((size>1) and ((psrc+1)^ <> (psrc-1)^)) ) do //eat doubles too
381 begin
382 inc(psrc);
383 inc(curCount);
384 dec(size);
385 if (curCount > 12) and ((psrc-1)^ = (psrc-2)^) and
386 ((psrc-3)^ = (psrc-4)^) and ((psrc-5)^ = (psrc-6)^) then //three doubles
387 begin
388 dec(psrc,6);
389 dec(curCount,6);
390 inc(size,6);
391 break;
392 end;
393 end;
394 if (size > 1) and (psrc^ = (psrc-1)^) and ((psrc+1)^ = psrc^) then //repetition coming
395 begin
396 dec(psrc);
397 dec(curCount);
398 inc(size);
399 end;
400 FlushSmallRepetitions;
401 if curCount = 1 then OutputRepetition(psrcBefore^,1) else
402 if curCount > 1 then Dump(psrcBefore, curCount);
403 if size > 0 then
404 begin
405 curValue := psrc^;
406 curCount := 1;
407 inc(psrc);
408 dec(size);
409 end else
410 begin
411 curCount := 0;
412 break;
413 end;
414 end;
415 end;
416 if curCount > 0 then OutputRepetition(curValue,curCount);
417 FlushSmallRepetitions;
418 buf.WriteByte(endOfStreamOpCode);
419 buf.Free;
420end;
421
422function DecodeLazRLE(ASource: TStream; var destBuffer; availableOutputSize: PtrInt; availableInputSize: int64 = -1): PtrInt;
423const MaxBufferSize = 1024;
424var
425 opCode: NativeInt;
426 pdest: PByte;
427 lastRepeatWordSize, lastRepeatByteSize: NativeInt;
428 lastPackedDumpValue: NativeInt;
429
430 Buffer: packed array of byte;
431 BufferPos, BufferSize: NativeInt;
432 BufferStartLocation: Int64;
433
434 procedure OutputOverflow(AWanted: PtrInt; AFunctionName: string);
435 var position: int64;
436 begin
437 position := ASource.Position - BufferSize + BufferPos;
438 raise exception.Create('Output buffer overflow. Current position is ' + IntToStr(result)+' out of '+ IntToStr(availableOutputSize)+
439 ' and '+IntToStr(AWanted)+' is required by '+AFunctionName+'. ' +
440 'The absolute input position is '+IntToStr(position)+' which is ' + inttostr(position-BufferStartLocation) + ' from start.');
441 end;
442
443 function ReduceAvailableInputSize(AWanted: PtrInt): PtrInt;
444 begin
445 if availableInputSize <> -1 then
446 begin
447 if AWanted>availableInputSize then
448 result := availableInputSize
449 else
450 result := AWanted;
451 dec(availableInputSize, result);
452 end else
453 result := AWanted;
454 end;
455
456 function GetNextBufferByte: byte;
457 begin
458 if BufferPos < BufferSize then
459 begin
460 result := Buffer[BufferPos];
461 inc(BufferPos);
462 end else
463 if BufferSize = 0 then
464 result := $e0
465 else
466 begin
467 BufferSize := ASource.Read(Buffer[0],ReduceAvailableInputSize(length(Buffer)));
468 BufferPos := 0;
469 if BufferPos < BufferSize then
470 begin
471 result := Buffer[BufferPos];
472 inc(BufferPos);
473 end else
474 result := $e0;
475 end;
476 end;
477
478 procedure RepeatValue(AValue: NativeInt; ACount: NativeInt);
479 begin
480 if result+ACount > availableOutputSize then OutputOverflow(ACount,'RepeatValue');
481 fillchar(pdest^, ACount, AValue);
482 inc(pdest, ACount);
483 inc(result, ACount);
484 end;
485
486 procedure PackedRepeatValues(ACount: NativeInt);
487 var packedCount: NativeInt;
488 begin
489 while ACount > 0 do
490 begin
491 packedCount := GetNextBufferByte;
492 RepeatValue(GetNextBufferByte, (packedCount and 3) + 1);
493 packedCount:= packedCount shr 2;
494 RepeatValue(GetNextBufferByte, (packedCount and 3) + 1);
495 packedCount:= packedCount shr 2;
496 RepeatValue(GetNextBufferByte, (packedCount and 3) + 1);
497 packedCount:= packedCount shr 2;
498 RepeatValue(GetNextBufferByte, (packedCount and 3) + 1);
499 dec(ACount);
500 end;
501 end;
502
503 procedure DumpValues(ACount: NativeInt);
504 begin
505 if result+ACount > availableOutputSize then OutputOverflow(ACount, 'DumpValues');
506 inc(result, ACount);
507 while ACount > 0 do
508 begin
509 pdest^ := GetNextBufferByte;
510 inc(pdest);
511 dec(ACount);
512 end;
513 end;
514
515 procedure PackedDumpValues(ACount: NativeInt);
516 var packedData: NativeInt;
517 begin
518 if result+ACount > availableOutputSize then OutputOverflow(ACount, 'PackedDumpValues');
519 inc(result, ACount);
520 while ACount > 0 do
521 begin
522 packedData := GetNextBufferByte;
523 lastPackedDumpValue := (lastPackedDumpValue + (packedData shr 4) - 8) and 255;
524 pdest^ := lastPackedDumpValue;
525 if ACount >= 2 then
526 begin
527 lastPackedDumpValue := (lastPackedDumpValue + (packedData and 15) - 8) and 255;
528 (pdest+1)^ := lastPackedDumpValue;
529 inc(pdest,2);
530 dec(ACount,2);
531 end else
532 begin
533 inc(pdest);
534 dec(ACount);
535 end;
536 lastPackedDumpValue:= (pdest-1)^;
537 end;
538 end;
539begin
540 BufferStartLocation:= ASource.Position;
541 setLength(Buffer,MaxBufferSize);
542 BufferSize := ASource.Read(Buffer[0],ReduceAvailableInputSize(length(Buffer)));
543 BufferPos := 0;
544
545 pdest := @destBuffer;
546 result := 0;
547 lastPackedDumpValue:= $80;
548 try
549 repeat
550 opCode := GetNextBufferByte;
551 case opCode of
552 wordRepetitionOpCode: begin
553 lastRepeatWordSize:= GetNextBufferByte shl 8;
554 lastRepeatWordSize+= GetNextBufferByte;
555 RepeatValue(GetNextBufferByte, lastRepeatWordSize);
556 end;
557 previousWordSizeRepetitionOpCode: RepeatValue(GetNextBufferByte, lastRepeatWordSize);
558 byteRepetitionOpCode: begin
559 lastRepeatByteSize:= GetNextBufferByte + 64;
560 RepeatValue(GetNextBufferByte, lastRepeatByteSize);
561 end;
562 previousByteSizeRepetitionOpCode: RepeatValue(GetNextBufferByte, lastRepeatByteSize);
563
564 $01..$3f: RepeatValue(GetNextBufferByte, opCode);
565 $41..$5f: PackedRepeatValues(opCode - $40);
566 $60..$6f: RepeatValue($00, opCode - $60 + 1);
567 $70..$7f: RepeatValue($FF, opCode - $70 + 1);
568 $81: DumpValues(GetNextBufferByte+64);
569 $82..$bf: DumpValues(opCode - $80);
570 $c3..$df: begin
571 lastPackedDumpValue := GetNextBufferByte;
572 RepeatValue(lastPackedDumpValue, 1);
573 PackedDumpValues(opCode - $c0 - 1);
574 end;
575 $e2..$fe: PackedDumpValues(opCode - $e0);
576
577 reservedOpCode1, reservedOpCode2, reservedOpCode3: raise exception.Create('Unexpected opcode');
578 endOfStreamOpCode, optionalOpCode: ;
579 end;
580 until opCode = endOfStreamOpCode;
581 finally
582 ASource.Position:= ASource.Position-BufferSize+BufferPos;
583 end;
584end;
585
586{ TLazPaintImageHeader }
587
588procedure LazPaintImageHeader_SwapEndianIfNeeded(AHeader: TLazPaintImageHeader);
589begin
590 with AHeader do
591 begin
592 headerSize := LEtoN(headerSize);
593 width := LEtoN(width);
594 height := LEtoN(height);
595 nbLayers := LEtoN(nbLayers);
596 height := LEtoN(height);
597 previewOffset := LEtoN(previewOffset);
598 compressionMode := LEtoN(compressionMode);
599 layersOffset := LEtoN(layersOffset);
600 end;
601end;
602
603
604end.
Note: See TracBrowser for help on using the repository browser.