Skip to content

Instantly share code, notes, and snippets.

@XProger

XProger/jpeg.pas

Created August 26, 2014 06:44
Show Gist options
  • Save XProger/78c463419b304c6062db to your computer and use it in GitHub Desktop.
Save XProger/78c463419b304c6062db to your computer and use it in GitHub Desktop.
Download ZIP
Load baseline JPEG image (gray & rgb)
Raw
jpeg.pas
function LoadJPG(const Stream: TStream; out Data: PByteArray; out Width, Height: LongInt): Boolean;
type
THuffmanTable = record
Bits : array [0..15] of Byte;
HVal : array [Byte] of Byte;
Size : array [Byte] of Byte;
Code : array [Byte] of Word;
end;
TQTable = array [0..63] of Single;
PQTable = ^TQTable;
PHuffmanCode = ^THuffmanCode;
THuffmanCode = record
Node : array [0..1] of PHuffmanCode;
Value : Byte;
end;
var
ChunkName : Byte;
ChunkSize : Word;
BPP : Byte;
Component : array [0..2] of record
id, h, v, t, td, ta : LongInt;
end;
{
Scan : record
ss, se, ah, al : LongInt;
end;
}
i, j, k, l, m : LongInt;
Interval : LongInt;
// Progressive : Boolean;
CurByte : Byte;
CurBit : LongInt;
dc : array [0..2] of LongInt;
// huffman trees (AC, DC)
HACode, HDCode : array [0..3] of PHuffmanCode;
// quantization table
QTable : array [0..3] of TQTable;
function ReadBit: LongInt;
begin
if CurBit = 0 then
begin
CurByte := Stream.ReadUInt8;
if CurByte = $FF then
begin
while CurByte = $FF do
CurByte := Stream.ReadUInt8;
if (CurByte >= $D0) and (CurByte <= $D7) then
FillChar(dc, SizeOf(dc), 0);
if CurByte = 0 then
CurByte := $FF
else
CurByte := Stream.ReadUInt8;
end;
end;
Result := (CurByte shr (7 - CurBit)) and 1;
CurBit := (CurBit + 1) mod 8;
end;
function ReadBits(num: LongInt): LongInt; { TODO : optimize (remove readbit) }
var
i : LongInt;
begin
Result := 0;
for i := 0 to num - 1 do
Result := (Result shl 1) or ReadBit;
end;
function Bit2Int(bit: Byte; i: LongInt): LongInt;
begin
if i shr (bit - 1) = 1 then
Result := i
else
Result := -(i xor (1 shl bit - 1));
end;
function HuffmanInit: PHuffmanCode;
begin
New(Result);
FillChar(Result^, SizeOf(THuffmanCode), 0);
end;
procedure HuffmanAdd(HCode: PHuffmanCode; Code: Word; Size, Value: Byte);
var
Bit : Byte;
begin
while Size > 0 do
begin
Bit := Code shr (Size - 1) and 1;
if HCode^.Node[Bit] = nil then
HCode^.Node[Bit] := HuffmanInit;
HCode := HCode^.Node[Bit];
Dec(Size);
end;
HCode^.Value := Value;
end;
function HuffmanGet(HCode: PHuffmanCode): Byte;
begin
while (HCode <> nil) and (HCode^.Node[0] <> HCode^.Node[1]) do // while nodes <> nil
HCode := HCode^.Node[ReadBit]; // get next huffman node
if HCode = nil then
Result := 0
else
Result := HCode^.Value;
end;
procedure HuffmanFree(HCode: PHuffmanCode);
begin
if HCode <> nil then
begin
HuffmanFree(HCode^.Node[0]);
HuffmanFree(HCode^.Node[1]);
Dispose(HCode);
end;
end;
procedure IDCT(Data: PFloatArray); // inverse DCT
const
c0 = 1.414213562;
c1 = 1.847759065;
c2 = 1.082392200;
c3 = 2.613125930;
var
t0, t1, t2, t3, t4, t5, t6, t7, t10, t11, t12, t13, z5, z10, z11, z12, z13 : Single;
p : PFloatArray;
i : LongInt;
begin
for i := 0 to 7 do
begin
p := @Data[i];
t0 := p^[8 * 0];
t1 := p^[8 * 2];
t2 := p^[8 * 4];
t3 := p^[8 * 6];
t10 := t0 + t2;
t11 := t0 - t2;
t13 := t1 + t3;
t12 := -t13 + (t1 - t3) * c0;
t0 := t10 + t13;
t3 := t10 - t13;
t1 := t11 + t12;
t2 := t11 - t12;
t4 := p^[8 * 1];
t5 := p^[8 * 3];
t6 := p^[8 * 5];
t7 := p^[8 * 7];
z13 := t6 + t5;
z10 := t6 - t5;
z11 := t4 + t7;
z12 := t4 - t7;
t7 := z11 + z13;
t11 := (z11 - z13) * c0;
z5 := (z10 + z12) * c1;
t10 := -z5 + z12 * c2;
t12 := z5 - z10 * c3;
t6 := t12 - t7;
t5 := t11 - t6;
t4 := t10 + t5;
p^[8 * 0] := t0 + t7;
p^[8 * 7] := t0 - t7;
p^[8 * 1] := t1 + t6;
p^[8 * 6] := t1 - t6;
p^[8 * 2] := t2 + t5;
p^[8 * 5] := t2 - t5;
p^[8 * 4] := t3 + t4;
p^[8 * 3] := t3 - t4;
end;
for i := 0 to 7 do
begin
p := @Data^[i * 8];
t10 := p^[0] + p^[4];
t11 := p^[0] - p^[4];
t13 := p^[2] + p^[6];
t12 := -t13 + (p^[2] - p^[6]) * c0;
t0 := t10 + t13;
t3 := t10 - t13;
t1 := t11 + t12;
t2 := t11 - t12;
z13 := p^[5] + p^[3];
z10 := p^[5] - p^[3];
z11 := p^[1] + p^[7];
z12 := p^[1] - p^[7];
t7 := z11 + z13;
t11 := (z11 - z13) * c0;
z5 := (z10 + z12) * c1;
t10 := -z5 + z12 * c2;
t12 := z5 - z10 * c3;
t6 := t12 - t7;
t5 := t11 - t6;
t4 := t10 + t5;
p^[0] := t0 + t7;
p^[7] := t0 - t7;
p^[1] := t1 + t6;
p^[6] := t1 - t6;
p^[2] := t2 + t5;
p^[5] := t2 - t5;
p^[4] := t3 + t4;
p^[3] := t3 - t4;
end;
end;
procedure Decompress; // baseline decompression
const
ZZI : array [0..63] of Byte = (
0, 1, 8, 16, 9, 2, 3, 10,
17, 24, 32, 25, 18, 11, 4, 5,
12, 19, 26, 33, 40, 48, 41, 34,
27, 20, 13, 6, 7, 14, 21, 28,
35, 42, 49, 56, 57, 50, 43, 36,
29, 22, 15, 23, 30, 37, 44, 51,
58, 59, 52, 45, 38, 31, 39, 46,
53, 60, 61, 54, 47, 55, 62, 63);
aanscale : array [0..7] of Single = ( // 1.0, k = 0; cos(k * PI / 16) * sqrt(2), k = 1...7
1.0, 1.387039845, 1.306562965, 1.175875602,
1.0, 0.785694958, 0.541196100, 0.275899379);
var
DCT : array [0..63] of Single;
pDCT : PFloatArray;
ScaleH, ScaleV : array [0..2] of LongInt;
i, j, k, m, x, y, h, v, p : LongInt;
dx, dy, mx, my : LongInt;
Color : Byte;
pData : PByteArray;
q : PQTable;
begin
ScaleH[0] := 1;
ScaleV[0] := 1;
if BPP = 3 then
begin
ScaleH[1] := Component[0].h div Component[1].h;
ScaleV[1] := Component[0].v div Component[1].v;
ScaleH[2] := Component[0].h div Component[2].h;
ScaleV[2] := Component[0].v div Component[2].v;
end;
// prepare QTables
for k := 0 to BPP - 1 do
for i := 0 to 63 do
begin
j := ZZI[i];
QTable[k][i] := QTable[k][i] * aanscale[j mod 8] * aanscale[j div 8] * 0.125;
end;
FillChar(dc, SizeOf(dc), 0);
CurBit := 0;
y := 0;
while y < Height do
begin
if Interval > 0 then
CurBit := 0;
x := 0;
while x < Width do
begin
for p := 0 to BPP - 1 do
begin
q := @QTable[Component[p].t];
for v := 0 to Component[p].v - 1 do
for h := 0 to Component[p].h - 1 do
begin
i := HuffmanGet(HDCode[Component[p].td]) and $0F;
Inc(dc[p], Bit2Int(i, ReadBits(i)));
FillChar(DCT[1], SizeOf(DCT) - SizeOf(DCT[0]), 0);
DCT[0] := dc[p] * q^[0];
i := 1;
// init dct
while i < 64 do
begin
j := HuffmanGet(HACode[Component[p].ta]);
if j <> 0 then
begin
Inc(i, j shr 4);
j := j and $0F;
DCT[ZZI[i]] := Bit2Int(j, ReadBits(j)) * q^[i];
Inc(i);
end else
break;
end;
// transform
IDCT(@DCT);
// fill data
if (ScaleH[p] = 1) and (ScaleV[p] = 1) then
begin
dx := x + h * 8;
dy := y + v * 8;
mx := Min(7, Width - dx - 1);
my := Min(7, Height - dy - 1);
pData := @Data[((Height - dy - 1) * Width + dx) * 4 + p];
pDCT := @DCT[0];
for dy := 0 to my do
begin
for dx := 0 to mx do
ClampByte(pData^[dx * 4], Round(pDCT^[dx]) + 128);
pDCT := @pDCT^[8];
pData := @pData^[-Width * 4];
end;
end else
for k := 0 to 63 do
begin
ClampByte(Color, Round(DCT[k]) + 128);
for m := 0 to ScaleH[p] * ScaleV[p] - 1 do
begin
i := x + (k mod 8 + h * 8) * ScaleH[p] + m mod ScaleH[p];
j := y + (k div 8 + v * 8) * ScaleV[p] + m div ScaleH[p];
if (i < Width) and (j < Height) then
Data^[((Height - j - 1) * Width + i) * 4 + p] := Color;
end;
end;
end;
end;
Inc(x, Component[0].h * 8);
end;
Inc(y, Component[0].v * 8);
end;
end;
var
HC : PHuffmanCode;
Code : LongWord;
Bits : array [0..15] of Byte;
begin
Result := False;
Stream.Position := Stream.Position + 2;
BPP := 1;
Interval := 0;
// Progressive := False;
for i := 0 to 3 do
begin
HACode[i] := HuffmanInit;
HDCode[i] := HuffmanInit;
end;
while Stream.Position < Stream.Size do
begin
Stream.Position := Stream.Position + 1; // skip $FF chunk start
ChunkName := Stream.ReadUInt8;
ChunkSize := SwapInt16(Stream.ReadUInt16) - 2;
case ChunkName of
$C0{, $C2} : // baseline/progressive (huffman)
begin
// Progressive := ChunkName = $C2;
Stream.Position := Stream.Position + 1; // skip precision
Height := SwapInt16(Stream.ReadUInt16);
Width := SwapInt16(Stream.ReadUInt16);
BPP := Stream.ReadUInt8;
if BPP * 3 <> ChunkSize - 6 then
break;
for i := 0 to BPP - 1 do
with Component[i] do
begin
id := Stream.ReadUInt8;
j := Stream.ReadUInt8;
h := j shr 4 and $0F;
v := j and $0F;
t := Stream.ReadUInt8;
end;
end;
$C4 : // huffman table
while ChunkSize > 0 do
begin
k := Stream.ReadUInt8;
if k and $10 > 0 then
HC := HACode[k and $0F]
else
HC := HDCode[k and $0F];
Dec(ChunkSize, 17);
Code := 0;
Stream.Read(Bits, 16);
for i := 0 to 15 do
begin
Dec(ChunkSize, Bits[i]);
for j := 0 to Bits[i] - 1 do
begin
HuffmanAdd(HC, Code, i + 1, Stream.ReadUInt8);
Inc(Code);
end;
Code := Code shl 1;
end;
end;
$DB : // quantization table
while ChunkSize > 0 do
begin
j := Stream.ReadUInt8;
if j shr 4 and $0F > 0 then
begin
for i := 0 to 63 do
QTable[j][i] := SwapInt16(Stream.ReadUInt16);
Dec(ChunkSize, 129);
end else
begin
for i := 0 to 63 do
QTable[j][i] := Stream.ReadUInt8;
Dec(ChunkSize, 65);
end;
end;
$D9 : // end of image
break;
$DA : // start of scan
begin
j := Stream.ReadUInt8;
for i := 0 to j - 1 do
begin
k := Stream.ReadUInt8;
m := Stream.ReadUInt8;
for l := 0 to BPP - 1 do
if Component[l].id = k then
begin
Component[l].td := m shr 4 and $0F;
Component[l].ta := m and $0F;
end;
end;
{Scan.ss :=} Stream.ReadUInt8;
{Scan.se :=} Stream.ReadUInt8;
{k := }Stream.ReadUInt8;
// Scan.ah := k shr 4 and $0F;
// Scan.al := k and $0F;
Result := True;
break;
end;
$DD :
Interval := SwapInt16(Stream.ReadUInt16);
$C1, $C2, $C3, $C5..$CF : // unsupported format
break;
else
Stream.Position := Stream.Position + ChunkSize;
end;
end;
if Result then
begin
Data := GetMemory(Width * Height * 4);
Decompress;
case BPP of
1 : for i := 0 to Height - 1 do
Gray2BGRA(Width, @Data[i * Width * 4]);
3 : for i := 0 to Height - 1 do
YCbCr2BGRA(Width, @Data[i * Width * 4]);
end;
end;
// free huffman tables
for i := 0 to 3 do
begin
HuffmanFree(HACode[i]);
HuffmanFree(HDCode[i]);
end;
end;
function SwapInt16(const Value: Word): Word;
begin
Result := ((Value shl 8) and $FF00) or ((Value shr 8) and $00FF);
end;
procedure YCbCr2BGRA(Width: LongInt; Data: PByteArray);
var
i, Y, Cb, Cr : LongInt;
p : PByteArray;
function Clamp(x: LongInt): Byte; inline;
const
MAX_SAMPLE = 255 * 1024;
begin
if x < 0 then x := 0;
if x > MAX_SAMPLE then x := MAX_SAMPLE;
Result := x shr 10;
end;
begin
for i := 0 to Width - 1 do
begin
p := @Data^[i * 4];
Y := p^[0] * 1024;
Cb := p^[1] - 128;
Cr := p^[2] - 128;
p^[0] := Clamp(Y + 1815 * Cb + 512);
p^[1] := Clamp(Y - 352 * Cb - 731 * Cr + 512);
p^[2] := Clamp(Y + 1436 * Cr + 512);
p^[3] := 255;
end;
end;
procedure Gray2BGRA(Width: LongInt; Data: PByteArray);
var
i : LongInt;
p : PByteArray;
begin
p := Data;
for i := 0 to Width - 1 do
begin
p^[1] := p^[0];
p^[2] := p^[0];
p^[3] := 255;
p := @Data^[i * 4 + 4];
end;
end;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment