paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-22 18:29:18 +02:00
Code Issues Packages Projects Releases Wiki Activity

* QOI format read/write implementation by Marģers

Browse Source
This commit is contained in:
Michaël Van Canneyt 2022-05-07 10:30:46 +02:00
parent 712823eb6c
commit 62c9e19f39
6 changed files with 764 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
packages/fcl-image/examples/wrpngf.pas Normal file
View File

@ -0,0 +1,32 @@
uses
sysutils, fpreadqoi, fpimage, fpwritePNG;
var
image: TFPCustomImage;
reader: TFPCustomImageReader;
writer: TFPWriterPNG;
AFileName : string;
useAlpha : boolean;
begin
AFileName:=paramstr(1);
Image := TFPMemoryImage.Create(0, 0);
Reader := TFPReaderQoi.Create;
Writer := TFPWriterPNG.Create;
Image.LoadFromFile(AFileName, Reader);
UseAlpha := TFPReaderQoi(Reader).UseAlpha;
Writer.UseAlpha:=UseAlpha;
Image.SaveToFile(ChangeFileExt(aFileName,'.png'),Writer);
Writeln;
writeln(' Width ',Image.Width,' Height ', Image.Height, ' UseAlpha ',UseAlpha);
Writeln;
image.Free;
Reader.Free;
Writer.Free;
end.

36
packages/fcl-image/examples/wrqoif.pas Normal file
View File

@ -0,0 +1,36 @@
uses
sysutils, fpreadpng, fpimage, fpwriteQoi;
var
image: TFPCustomImage;
reader: TFPCustomImageReader;
writer: TFPWriterQoi;
AFileName : string;
useAlpha : boolean;
begin
AFileName:=paramstr(1);
Image := TFPMemoryImage.Create(0, 0);
Reader := TFPReaderPNG.Create;
Writer := TFPWriterQoi.Create;
Image.LoadFromFile(AFileName, Reader);
UseAlpha := TFPReaderPNG(Reader).UseAlpha;
Writer.UseAlpha:=UseAlpha;
Image.SaveToFile(ChangeFileExt(aFileName,'.qoi'),Writer);
Writeln;
writeln(' BitDepth ',TFPReaderPNG(Reader).BitDepth );
writeln(' ColorType ',TFPReaderPNG(Reader).ColorType );
writeln(' Width ',Image.Width,' Height ', Image.Height, ' UseAlpha ',UseAlpha);
Writeln;
image.Free;
Reader.Free;
Writer.Free;
end.

23
packages/fcl-image/fpmake.pp
View File

@ -290,12 +290,33 @@ begin
Addunit('fpimgcmn');
AddUnit('fpqrcodegen');
end;
// qoi
T:=P.Targets.AddUnit('qoicomn.pp');
with T.Dependencies do
begin
AddUnit('fpimage');
AddUnit('fpimgcmn');
end;
T:=P.Targets.AddUnit('fpreadqoi.pp');
with T.Dependencies do
begin
AddUnit('fpimage');
AddUnit('qoicomn');
end;
T:=P.Targets.AddUnit('fpwriteqoi.pp');
with T.Dependencies do
begin
AddUnit('fpimage');
AddUnit('qoicomn');
end;
P.ExamplePath.Add('examples');
T:=P.Targets.AddExampleProgram('drawing.pp');
T:=P.Targets.AddExampleProgram('imgconv.pp');
T:=P.Targets.AddExampleProgram('createbarcode.lpr');
T:=P.Targets.AddExampleProgram('wrpngf.pas');
T:=P.Targets.AddExampleProgram('wrqoif.pas');
{$ifndef ALLPACKAGES}
Run;
end;

281
packages/fcl-image/src/fpreadqoi.pas Normal file
View File

@ -0,0 +1,281 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2022 by the Free Pascal development team
QOI reader implementation
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$mode objfpc}{$h+}
unit FPReadQoi;
interface
uses FPImage, classes, sysutils, QoiComn;
type
TFPReaderQoi = class (TFPCustomImageReader)
Private
QoiHeader : TQoiHeader; // The header as read from the stream.
function getUseAlpha:boolean;
protected
// required by TFPCustomImageReader
procedure InternalRead (Stream:TStream; Img:TFPCustomImage); override;
function InternalCheck (Stream:TStream) : boolean; override;
public
constructor Create; override;
property UseAlpha : boolean read getUseAlpha;
end;
implementation
function RGBAToFPColor(Const RGBA: TQoiPixel) : TFPcolor;
begin
with Result, RGBA do
begin
Red :=(R shl 8) or R;
Green :=(G shl 8) or G;
Blue :=(B shl 8) or B;
Alpha :=(A shl 8) or A;
end;
end;
Constructor TFPReaderQoi.create;
begin
inherited create;
end;
function TFPReaderQoi.getUseAlpha:boolean;
begin
result := (QoiHeader.channels=qoChannelRGBA);
end;
function TFPReaderQoi.InternalCheck (Stream:TStream) : boolean;
// NOTE: Does not rewind the stream!
var
n: Int64;
begin
Result:=False;
if Stream=nil then
exit;
n:=SizeOf(TQoiHeader);
Result:=Stream.Read(QoiHeader,n)=n;
if Result then
begin
{$IFDEF ENDIAN_LITTLE}
QoiHeader.width:=Swap32(QoiHeader.width);
QoiHeader.height:=Swap32(QoiHeader.height);
{$ENDIF}
Result := (QoiHeader.magic = 'qoif'); // Just check magic number
end;
end;
// NOTE: It is assumed that signature and IDHDR chunk already have been read.
procedure TFPReaderQoi.InternalRead (Stream:TStream; Img:TFPCustomImage);
var iP, q : qword;
b, run : byte;
g : shortint;
px : TQoiPixel;
arr : array [0..63] of TQoiPixel;
iA : dword; {index in pixel array}
p, aQ : pbyte; orgSize, imgSize : qword;
Row, Col, w, h : dword;
aLine : pbyte;
begin
with QoiHeader do
begin
Img.SetSize (Width, Height);
imgSize := Width * Height;
w:=Width;
h:=Height;
end;
orgSize:=Stream.size;
orgSize:=orgSize-sizeof(TQoiHeader);
getmem(aLine,orgSize);
q:=Stream.Read(aLine^,orgSize);
if orgSize>q then orgSize:=q;
ip:=0;
q:=0;
p:=aLine;
dword(px):=0;
px.a:=255;
{initalize previosly seen pixel array}
//fillchar(arr,sizeof(arr),0);
iA:=QoiPixelIndex(px);
//for iA:=0 to 63 do
arr[iA]:=px;
Row:=0;
Col:=0;
{actual decoding loop}
while (orgSize> ip) and (imgSize>q) do
begin
b:=p^;
inc(p);
inc(ip);
case (b shr 6) of
0: begin { pixel from previos pixel array}
if b = p^ then {deal with end of encoding}
begin
if b = 0 then
begin
dec(p);
for iA:=0 to 6 do
begin
b:=p^;
inc(p);
inc(ip);
if b<>0 then break;
end;
if b<>0 then
begin
{invalid encoding}
break;
end;
b:=p^;
inc(p);
inc(ip);
if b = 1 then
begin
//writeln('end of encoding ');
{success - no more encoded pixels}
break;
end else
begin
{invalid encoding}
break;
end;
end else
begin
{invalid encoding}
break;
end;
end;
{pixel from array}
iA:= b and 63;
px:=arr[iA];
img.Colors[Col,Row] := RGBAToFPColor( px );
inc(q);
inc(Col);
if Col = w then begin inc(Row); Col:=0; if Row>=h then break; end;
end;
1: begin { diff }
b:=b and 63;
px.r:=px.r+ byte(b shr 4) and 3+shortint(-2);
px.g:=px.g+ byte(b shr 2) and 3+shortint(-2);
px.b:=px.b+ byte(b shr 0) and 3+shortint(-2);
img.Colors[Col,Row] := RGBAToFPColor( px );
inc(q);
inc(Col);
if Col = w then begin inc(Row); Col:=0; if Row>=h then break; end;
iA:=QoiPixelIndex(px);
arr[iA]:=px;
end;
2: begin { luma }
g:=b and 63 - 32;
b:=p^;
inc(p);
inc(ip);
px.g:=px.g + g;
px.r:=px.r+g+shortint((b shr 4)-8);
px.b:=px.b+g+shortint((b and 15)-8);
img.Colors[Col,Row] := RGBAToFPColor( px );
inc(q);
inc(Col);
if Col = w then begin inc(Row); Col:=0; if Row>=h then break; end;
iA:=QoiPixelIndex(px);
arr[iA]:=px;
end;
3: begin
run:=b and 63+1;
case run of
64: begin { rgba }
px.r:=p^;
inc(p);
px.g:=p^;
inc(p);
px.b:=p^;
inc(p);
px.a:=p^;
inc(p);
inc(ip,4);
img.Colors[Col,Row] := RGBAToFPColor( px );
inc(q);
inc(Col);
if Col = w then begin inc(Row); Col:=0; if Row>=h then break; end;
iA:=QoiPixelIndex(px);
arr[iA]:=px;
end;
63: begin { rgb }
px.r:=p^;
inc(p);
px.g:=p^;
inc(p);
px.b:=p^;
inc(p);
inc(ip,3);
img.Colors[Col,Row] := RGBAToFPColor( px );
inc(q);
inc(Col);
if Col = w then begin inc(Row); Col:=0; if Row>=h then break; end;
iA:=QoiPixelIndex(px);
arr[iA]:=px;
end;
otherwise { run - repeat previos pixel}
repeat
img.Colors[Col,Row] := RGBAToFPColor( px );
inc(q);
inc(Col);
if Col = w then begin inc(Row); Col:=0; if Row>=h then break; end;
dec(run);
until run =0;
end;
end;
end; {case of }
end; { while do}
freeMem(aLine);
end;
initialization
ImageHandlers.RegisterImageReader ('QOI Format', 'qoi', TFPReaderQoi);
end.

330
packages/fcl-image/src/fpwriteqoi.pas Normal file
View File

@ -0,0 +1,330 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2022 by the Free Pascal development team
QOI writer class.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$mode objfpc}{$h+}
unit fpwriteqoi;
interface
uses FPImage, classes, sysutils, QoiComn;
type
TFPWriterQoi = class (TFPCustomImageWriter)
private
QoiHeader : TQoiHeader;
procedure setUseAlpha(useAlpha:boolean);
function getUseAlpha:boolean;
protected
function SaveHeader(Stream:TStream; Img: TFPCustomImage):boolean; virtual;
procedure InternalWrite (Stream:TStream; Img: TFPCustomImage); override;
public
constructor Create; override;
property useAlpha:boolean read getUseAlpha write setUseAlpha;
end;
implementation
constructor TFPWriterQoi.create;
begin
inherited create;
with QoiHeader do
begin
magic:='qoif';
channels:=qoChannelRGB;
colorspace:=0;
end;
end;
procedure TFPWriterQoi.setUseAlpha(useAlpha:boolean);
begin
if useAlpha then QoiHeader.channels := qoChannelRGBA else QoiHeader.channels:=qoChannelRGB;
end;
function TFPWriterQoi.getUseAlpha:boolean;
begin
result:= (QoiHeader.channels=qoChannelRGBA);
end;
function TFPWriterQoi.SaveHeader(Stream:TStream; Img : TFPCustomImage):boolean;
begin
Result:=False;
with QoiHeader do
begin
Width:=Img.Width;
Height:=Img.Height;
//writeln('Save width ',width, ' height ', height);
end;
{$IFDEF ENDIAN_LITTLE}
QoiHeader.width:=Swap32(QoiHeader.width);
QoiHeader.height:=Swap32(QoiHeader.height);
{$ENDIF}
//writeln('Save width 2 ',QoiHeader.width, ' height ', QoiHeader.height);
Stream.Write(QoiHeader,sizeof(TQoiHeader));
{$IFDEF ENDIAN_LITTLE}
QoiHeader.width:=Swap32(QoiHeader.width);
QoiHeader.height:=Swap32(QoiHeader.height);
{$ENDIF}
Result:=true;
end;
procedure TFPWriterQoi.InternalWrite (Stream:TStream; Img:TFPCustomImage);
var
Row,Col,RowSize:sizeuint;
h, w, orgSize, mSize : sizeuint;
aLine, p: PByte;
color : TFPColor;
var iP, iq, imgSize : qword;
//q: PQoiPixel;
b, run : byte;
g, dr, dg, db, dr_dg, db_dg : byte;// shortint;
px, cx : TQoiPixel;
arr : array [0..63] of TQoiPixel;
iA : dword; {index in pixel array}
//endOf : qword;
begin
mSize:= img.Width * sizeof(TQoiPixel)+ img.Width;
RowSize:= img.Width * sizeof(TQoiPixel)+ img.Width + 8+sizeof(TQoiPixel)*64+64;
SaveHeader(Stream,Img); { write the headers }
GetMem(aLine,RowSize);
p:=aLine;
dword(px):=0;
px.a:=255;
{initalize previosly seen pixel array}
fillchar(arr,sizeof(arr),0);
iA:=QoiPixelIndex(px);
//for iA:=0 to 63 do
//arr[iA]:=px;
Row:=0;
Col:=0;
h:=Img.Height;
w:=Img.Width;
iq:=0;
ip:=0;
imgSize:= h*w;
if imgSize > 0 then
while (imgSize)> iq do
begin
color:=img.colors[Col,Row];
cx.r:=color.Red shr 8;
cx.g:=color.Green shr (8);
cx.b:=color.Blue shr (8);
cx.a:=color.Alpha shr (8);
iA:=QoiPixelIndex (cx);
if dword(cx)=dword(px) then { run }
begin
run:=0;
//inc (q);
inc (iq);
inc(col);
if col = w then begin inc(row); col:=0; end;
if (col < w) and (row<h) then
begin
color:=img.colors[Col,Row];
cx.r:=color.Red shr 8;
cx.g:=color.Green shr (8);
cx.b:=color.Blue shr (8);
cx.a:=color.Alpha shr (8);
while (imgSize >= (iq+1))
and (dword(cx)=dword(px)) do
begin
inc (run);
inc (iq);
inc(col);
if col = w then begin
inc(row); col:=0;
if (col >= w) or (row>=h) then break;
end;
color:=img.colors[Col,Row];
cx.r:=color.Red shr 8;
cx.g:=color.Green shr (8);
cx.b:=color.Blue shr (8);
cx.a:=color.Alpha shr (8);
if run = 61 then break;
end;
end;
b:=($ff xor 63) or run;
p^:=b;
inc(p);
inc(ip);
end else
if dword(arr[iA]) = dword(cx) then { index }
begin
px:=cx;
p^:=byte(iA);
inc(p);
inc(ip);
//inc(q);
inc(iq);
inc(col);
if col = w then begin inc(row); col:=0; end;
end else
if px.a <> cx.a then { rgba }
begin
b:=$ff;
p^:=b;
inc(p);
px:=cx;
//PQoiPixel(p)^:=cx;
//inc(p,4);
p^:=cx.r;inc(p);
p^:=cx.g;inc(p);
p^:=cx.b;inc(p);
p^:=cx.a;inc(p);
inc(ip,5);
//inc(q);
inc (iq);
inc(col);
if col = w then begin inc(row); col:=0; end;
arr[iA]:=cx;
end else
begin
dr := (cx.r - px.r);
dg := (cx.g - px.g);
db := (cx.b - px.b);
px:=cx;
dr_dg := dr-dg+8;
db_dg := db-dg+8;
dr:=dr+2;
dg:=dg+2;
db:=db+2;
g:=dg+30;
//inc(q);
inc (iq);
inc(col);
if col = w then begin inc(row); col:=0; end;
arr[iA]:=cx;
if (dr and ($ff xor 3))+(dg and ($ff xor 3))+(db and ($ff xor 3)) = 0 then { diff }
begin
b:=64 or (dr shl 4) or (dg shl 2)or (db ) ;
p^:=b;
inc(p);
inc(ip);
end else
if ((g) and ($ff xor 63)) + (dr_dg and ($ff xor 15))+ (db_dg and ($ff xor 15))=0 then { luma }
begin
b:=128 or g;
p^:=b;
inc(p);
b:=(dr_dg shl 4) or db_dg;
p^:=b;
inc(p);
inc(ip,2);
end else {rgb}
begin
b:=$fe;
p^:=b;
inc(p);
//PQoiPixel(p)^:=cx;
//inc(p,3);
p^:=cx.r;inc(p);
p^:=cx.g;inc(p);
p^:=cx.b;inc(p);
inc(ip,4);
end;
end;
if ip >= mSize then
begin
{save data }
orgSize:=ip;
Stream.Write(aLine[0],orgSize);
ip:=0;
p:=aLine;
end;
end;
{mark end of encoding}
{
endof:=qword(1) shl 56;
pqword(p)^:=endof;
inc(p,8);
}
p^:=0; inc(p);
p^:=0; inc(p);
p^:=0; inc(p);
p^:=0; inc(p);
p^:=0; inc(p);
p^:=0; inc(p);
p^:=0; inc(p);
p^:=1; inc(p);
inc(ip,8);
orgSize:=ip;
Stream.Write(aLine[0],orgSize);
FreeMem(aLine);
end;
initialization
ImageHandlers.RegisterImageWriter ('QOI Format', 'qoi', TFPWriterQoi);
end.

63
packages/fcl-image/src/qoicomn.pas Normal file
View File

@ -0,0 +1,63 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2022 by the Free Pascal development team
QOI reader/writer common code.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$mode objfpc}{$h+}
unit qoicomn;
interface
type PQoiHeader = ^TQoiHeader;
TQoiHeader = packed record
magic : array [0..3] of char; { magic bytes 'qoif' }
width : dword; { image width in pixels (BE)}
height : dword; { image height in pixels (BE)}
channels : byte; { 3 = RGB, 4 = RGBA }
colorspace : byte; { 0 = sRGB with linear alpha }
{ 1 = all channels linear }
end;
type PQoiPixel = ^TQoiPixel;
TQoiPixel = packed record
r,g,b,a : byte;
end;
const qoChannelRGB = 3;
qoChannelRGBA = 4;
function swap32 (a : dword):dword;
function QoiPixelIndex (px : TQoiPixel):dword;
implementation
function swap32 (a : dword):dword;
var h, l : dword;
begin
a:=roldword(a,16);
h:=a shr 8;
h:= h and $ff00ff;
l:= a and $ff00ff;
l:= l shl 8;
swap32:=h or l;
end;
function QoiPixelIndex (px : TQoiPixel):dword;
begin
QoiPixelIndex:= (dword(px.r)*3+dword(px.g)*5+dword(px.b)*7+dword(px.a)*11) and 63;
end;
end.