Copy disabled (too large)
Download .txt
Showing preview only (18,251K chars total). Download the full file to get everything.
Repository: bgrabitmap/bgrabitmap
Branch: master
Commit: 44a65262e214
Files: 497
Total size: 17.3 MB
Directory structure:
gitextract_smpcvqwr/
├── .github/
│ ├── FUNDING.yml
│ ├── dependabot.yml
│ └── workflows/
│ ├── make.pas
│ └── make.yml
├── .gitignore
├── .gitmodules
├── COPYING.LGPL.txt
├── COPYING.modifiedLGPL.txt
├── Makefile
├── bglcontrols/
│ ├── bglcontrols.lpk
│ ├── bglcontrols.pas
│ ├── bglvirtualscreen.pas
│ └── bglvirtualscreen_icon.lrs
├── bgrabitmap/
│ ├── avifbgra.pas
│ ├── basiccolorspace.inc
│ ├── bezier.inc
│ ├── bgraanimatedgif.pas
│ ├── bgraarrow.pas
│ ├── bgrabitmap.inc
│ ├── bgrabitmap.pas
│ ├── bgrabitmappack.lpk
│ ├── bgrabitmappack.pas
│ ├── bgrabitmappack4android.lpk
│ ├── bgrabitmappack4android.pas
│ ├── bgrabitmappack4android_freetype.lpk
│ ├── bgrabitmappack4android_freetype.pas
│ ├── bgrabitmappack4fpgui.lpk
│ ├── bgrabitmappack4fpgui.pas
│ ├── bgrabitmappack4nogui.lpk
│ ├── bgrabitmappack4nogui.pas
│ ├── bgrabitmappack4nolcl.lpk
│ ├── bgrabitmappack4nolcl.pas
│ ├── bgrabitmappack4nolcl_freetype.lpk
│ ├── bgrabitmappack4nolcl_freetype.pas
│ ├── bgrabitmaptypes.pas
│ ├── bgrablend.pas
│ ├── bgrablurgl.pas
│ ├── bgracanvas.pas
│ ├── bgracanvas2d.pas
│ ├── bgracanvasgl.pas
│ ├── bgraclasses.pas
│ ├── bgracolorint.pas
│ ├── bgracolorquantization.pas
│ ├── bgracompressablebitmap.pas
│ ├── bgracoordpool3d.pas
│ ├── bgracustombitmap.inc
│ ├── bgracustomtextfx.pas
│ ├── bgradefaultbitmap.pas
│ ├── bgradithering.pas
│ ├── bgradnetdeserial.pas
│ ├── bgrafillinfo.pas
│ ├── bgrafilterblur.pas
│ ├── bgrafilters.pas
│ ├── bgrafilterscanner.pas
│ ├── bgrafiltertype.pas
│ ├── bgrafontgl.pas
│ ├── bgrafpcanvas.inc
│ ├── bgrafpgui.inc
│ ├── bgrafpgui_uses.inc
│ ├── bgrafpguibitmap.pas
│ ├── bgrafreetype.pas
│ ├── bgragifformat.pas
│ ├── bgragradientoriginal.pas
│ ├── bgragradients.pas
│ ├── bgragradientscanner.pas
│ ├── bgragraphics.pas
│ ├── bgragrayscalemask.pas
│ ├── bgragtkbitmap.pas
│ ├── bgraiconcursor.pas
│ ├── bgralayeroriginal.pas
│ ├── bgralayers.pas
│ ├── bgralazpaint.pas
│ ├── bgralazresource.pas
│ ├── bgralclbitmap.pas
│ ├── bgralzpcommon.pas
│ ├── bgramacbitmap.pas
│ ├── bgramatrix3d.pas
│ ├── bgramemdirectory.pas
│ ├── bgramsegui.inc
│ ├── bgramsegui_text.inc
│ ├── bgramsegui_uses.inc
│ ├── bgramseguibitmap.pas
│ ├── bgramultifiletype.pas
│ ├── bgranogui.inc
│ ├── bgranogui_uses.inc
│ ├── bgranoguibitmap.pas
│ ├── bgraopengl.pas
│ ├── bgraopengl3d.pas
│ ├── bgraopengltype.pas
│ ├── bgraopenraster.pas
│ ├── bgrapaintnet.pas
│ ├── bgrapalette.pas
│ ├── bgrapapers.pas
│ ├── bgrapath.pas
│ ├── bgrapdf.pas
│ ├── bgrapen.pas
│ ├── bgraphongtypes.pas
│ ├── bgraphoxo.pas
│ ├── bgrapixel.inc
│ ├── bgrapngcomn.pas
│ ├── bgrapolygon.pas
│ ├── bgrapolygonaliased.pas
│ ├── bgraqtbitmap.pas
│ ├── bgrareadavif.pas
│ ├── bgrareadbmp.pas
│ ├── bgrareadbmpmiomap.pas
│ ├── bgrareadgif.pas
│ ├── bgrareadico.pas
│ ├── bgrareadjpeg.pas
│ ├── bgrareadlzp.pas
│ ├── bgrareadpcx.pas
│ ├── bgrareadpng.pas
│ ├── bgrareadpsd.pas
│ ├── bgrareadtga.pas
│ ├── bgrareadtiff.pas
│ ├── bgrareadwebp.pas
│ ├── bgrareadxpm.pas
│ ├── bgrarenderer3d.pas
│ ├── bgraresample.pas
│ ├── bgrascanner.inc
│ ├── bgrascene3d.pas
│ ├── bgrascenetypes.pas
│ ├── bgraslicescaling.pas
│ ├── bgraspritegl.pas
│ ├── bgrasse.inc
│ ├── bgrasse.pas
│ ├── bgrastreamlayers.pas
│ ├── bgrasvg.pas
│ ├── bgrasvgoriginal.pas
│ ├── bgrasvgshapes.pas
│ ├── bgrasvgtype.pas
│ ├── bgratext.pas
│ ├── bgratextbidi.pas
│ ├── bgratextfx.pas
│ ├── bgrathumbnail.pas
│ ├── bgratransform.pas
│ ├── bgratypewriter.pas
│ ├── bgraunicode.pas
│ ├── bgraunicodetext.pas
│ ├── bgraunits.pas
│ ├── bgrautf8.pas
│ ├── bgravectorize.pas
│ ├── bgrawinbitmap.pas
│ ├── bgrawinresource.pas
│ ├── bgrawriteavif.pas
│ ├── bgrawritebmp.pas
│ ├── bgrawritebmpmiomap.pas
│ ├── bgrawritejpeg.pas
│ ├── bgrawritelzp.pas
│ ├── bgrawritepcx.pas
│ ├── bgrawritepng.pas
│ ├── bgrawritetiff.pas
│ ├── bgrawritewebp.pas
│ ├── blendpixelinline.inc
│ ├── blendpixels.inc
│ ├── blendpixelsover.inc
│ ├── blurbox.inc
│ ├── blurfast.inc
│ ├── blurnormal.inc
│ ├── csscolorconst.inc
│ ├── darwinlib.pas
│ ├── density256.inc
│ ├── expandedbitmap.pas
│ ├── extendedcolorspace.inc
│ ├── face3d.inc
│ ├── generatedcolorspace.inc
│ ├── generatedunicode.inc
│ ├── generatedutf8.inc
│ ├── geometrytypes.inc
│ ├── libavif.pas
│ ├── libwebp.pas
│ ├── lightingclasses3d.inc
│ ├── linearrgbabitmap.pas
│ ├── lineartexscan.inc
│ ├── lineartexscan2.inc
│ ├── linuxlib.pas
│ ├── multishapeline.inc
│ ├── object3d.inc
│ ├── paletteformats.inc
│ ├── part3d.inc
│ ├── perspectivecolorscan.inc
│ ├── perspectivescan.inc
│ ├── perspectivescan2.inc
│ ├── phongdraw.inc
│ ├── phongdrawsse.inc
│ ├── phonglight.inc
│ ├── phonglightsse.inc
│ ├── polyaliaspersp.inc
│ ├── readme.txt
│ ├── shapes3d.inc
│ ├── spectraldata.inc
│ ├── unibitmap.inc
│ ├── unibitmapgeneric.inc
│ ├── universaldrawer.pas
│ ├── unzipperext.pas
│ ├── uunittest.pas
│ ├── vertex3d.inc
│ ├── wordxyzabitmap.pas
│ └── xyzabitmap.pas
├── commit.sh
├── dev/
│ ├── assistant/
│ │ └── builddata.py
│ ├── colorspace/
│ │ ├── generatecolorspaces.lpi
│ │ ├── generatecolorspaces.lpr
│ │ └── unitmakerunit.pas
│ ├── makedoc/
│ │ ├── pmakedoc.lpi
│ │ ├── pmakedoc.lpr
│ │ ├── readme.txt
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── parseunicode/
│ │ ├── ArabicShaping.txt
│ │ ├── BidiBrackets.txt
│ │ ├── BidiCharacterTest.result
│ │ ├── BidiCharacterTest.txt
│ │ ├── BidiMirroring.txt
│ │ ├── UnicodeData.txt
│ │ ├── parseunicodeclasses.lpi
│ │ ├── parseunicodeclasses.lpr
│ │ ├── testunicodealgo.lpi
│ │ └── testunicodealgo.lpr
│ ├── readme.txt
│ └── releaser/
│ ├── archiveurl.pas
│ ├── bgrabitmap.logic
│ ├── constfile.pas
│ ├── copyfile.pas
│ ├── macbundle.pas
│ ├── managerfile.pas
│ ├── packagefile.pas
│ ├── projectfile.pas
│ ├── releaser.lpi
│ ├── releaser.lpr
│ ├── releasertypes.pas
│ └── textline.pas
├── doc/
│ ├── dot.bat
│ ├── generate.bat
│ ├── generate.sh
│ ├── introduction.txt
│ ├── navigation.js
│ ├── pasdoc.cfg
│ ├── pasdoc.css
│ ├── readme.md
│ └── units.txt
├── libwebp/
│ └── readme.md
├── readme.md
├── test/
│ ├── bgraaggtest/
│ │ ├── aa_demo.lpi
│ │ ├── aa_demo.lpr
│ │ ├── aa_demo_main.lfm
│ │ ├── aa_demo_main.pas
│ │ ├── alpha_gradient.lpi
│ │ ├── alpha_gradient.lpr
│ │ ├── alpha_gradient_main.lfm
│ │ ├── alpha_gradient_main.pas
│ │ ├── blur.lpi
│ │ ├── blur.lpr
│ │ ├── blur_main.lfm
│ │ ├── blur_main.pas
│ │ ├── bspline.lpi
│ │ ├── bspline.lpr
│ │ ├── bspline_main.lfm
│ │ ├── bspline_main.pas
│ │ ├── distortions.lpi
│ │ ├── distortions.lpr
│ │ ├── distortions_main.lfm
│ │ ├── distortions_main.pas
│ │ ├── gouraud.lpi
│ │ ├── gouraud.lpr
│ │ ├── gouraud_main.lfm
│ │ ├── gouraud_main.pas
│ │ ├── image_filters2.lpi
│ │ ├── image_filters2.lpr
│ │ ├── image_filters2_main.lfm
│ │ ├── image_filters2_main.pas
│ │ ├── image_perspective.lpi
│ │ ├── image_perspective.lpr
│ │ ├── image_perspective_main.lfm
│ │ └── image_perspective_main.pas
│ ├── bgralape/
│ │ ├── basic_functions.inc
│ │ ├── basic_geometry_functions.inc
│ │ ├── bgralapesys.pas
│ │ ├── color_functions.inc
│ │ ├── extended_geometry_functions.inc
│ │ ├── lape.func
│ │ ├── lape.proc
│ │ ├── pbgralape.lpi
│ │ ├── pbgralape.lpr
│ │ ├── tests.pas
│ │ ├── text_functions.inc
│ │ ├── ubgralape.pas
│ │ ├── umain.lfm
│ │ └── umain.pas
│ ├── bgratutorial3d/
│ │ ├── bgratutorial3d.lpi
│ │ ├── bgratutorial3d.lpr
│ │ ├── bgratutorial3dsoftware.lpi
│ │ ├── bgratutorial3dsoftware.lpr
│ │ ├── ex1.pas
│ │ ├── ex2.pas
│ │ ├── ex3.pas
│ │ ├── ex4.pas
│ │ ├── ex5.pas
│ │ ├── obj/
│ │ │ ├── airboat.obj
│ │ │ ├── al.obj
│ │ │ ├── cessna.obj
│ │ │ ├── ciseau.obj
│ │ │ ├── cube.obj
│ │ │ ├── diamond.obj
│ │ │ ├── dodecahedron.obj
│ │ │ ├── fourche.obj
│ │ │ ├── gourd.obj
│ │ │ ├── helice.obj
│ │ │ ├── helico.obj
│ │ │ ├── lampe.obj
│ │ │ ├── magnolia.obj
│ │ │ ├── mario.obj
│ │ │ ├── pelle.obj
│ │ │ ├── roue.obj
│ │ │ ├── sandal.obj
│ │ │ ├── shuttle.obj
│ │ │ ├── teapot.obj
│ │ │ ├── trumpet.obj
│ │ │ └── violin_case.obj
│ │ ├── ubgrasamples.pas
│ │ ├── umain.lfm
│ │ ├── umain.pas
│ │ └── utexture.pas
│ ├── colorspace/
│ │ ├── ColorsDemo.lpi
│ │ ├── ColorsDemo.lpr
│ │ ├── HorseShoe.lpi
│ │ ├── HorseShoe.lpr
│ │ ├── bgracolorex.pas
│ │ ├── colorsdemounit.lfm
│ │ ├── colorsdemounit.pas
│ │ ├── uhorseshoe.lfm
│ │ └── uhorseshoe.pas
│ ├── createbitmap/
│ │ ├── createbitmap.lpi
│ │ ├── createbitmap.lpr
│ │ ├── umain.lfm
│ │ └── umain.pas
│ ├── gammafactor/
│ │ ├── gammafactor.lpi
│ │ ├── gammafactor.lpr
│ │ ├── umain.lfm
│ │ └── umain.pas
│ ├── layeroriginal/
│ │ ├── layeroriginal.lpi
│ │ ├── layeroriginal.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── rationalbezier/
│ │ ├── rationalbezier.lpi
│ │ ├── rationalbezier.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── test4ideu/
│ │ └── fractal_tree/
│ │ ├── fractal_tree.pas
│ │ ├── fractal_tree.prj
│ │ ├── main.mfm
│ │ ├── main.pas
│ │ └── main_mfm.pas
│ ├── test4lcl/
│ │ ├── test4lcl.lpi
│ │ ├── test4lcl.lpr
│ │ ├── umain.lfm
│ │ └── umain.pas
│ ├── test4lcl_opengl/
│ │ ├── opengltest0/
│ │ │ ├── ptestvirtualscreen.lpi
│ │ │ ├── ptestvirtualscreen.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ ├── opengltest1/
│ │ │ ├── opengltest1.lpi
│ │ │ ├── opengltest1.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ ├── opengltest2/
│ │ │ ├── opengltest2.lpi
│ │ │ ├── opengltest2.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ ├── opengltest3/
│ │ │ ├── opengltest3.lpi
│ │ │ ├── opengltest3.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ ├── opengltest4/
│ │ │ ├── opengltest4.lpi
│ │ │ ├── opengltest4.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ ├── opengltest5/
│ │ │ ├── ptestvirtualscreen.lpi
│ │ │ ├── ptestvirtualscreen.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ └── tux_game/
│ │ ├── mainunit.lfm
│ │ ├── mainunit.pas
│ │ ├── tux_game.lpi
│ │ ├── tux_game.lpr
│ │ └── ugame.pas
│ ├── test4other/
│ │ ├── test4fpgui.lpi
│ │ ├── test4fpgui.lpr
│ │ ├── test4nogui.lpi
│ │ ├── test4nogui.lpr
│ │ ├── test4nolcl.lpi
│ │ ├── test4nolcl.lpr
│ │ ├── test4nolcl_freetype.lpi
│ │ ├── test4nolcl_freetype.lpr
│ │ └── zengl/
│ │ ├── 06 - Text (BGRABitmap)/
│ │ │ ├── demo06.lpi
│ │ │ ├── demo06.lpr
│ │ │ ├── demo06_macosx.lpi
│ │ │ ├── demo06_macosx.plist
│ │ │ └── macosx_postbuild.sh
│ │ ├── 07 - Sprites (BGRABitmap)/
│ │ │ ├── demo07.lpi
│ │ │ ├── demo07.lpr
│ │ │ ├── demo07_macosx.lpi
│ │ │ ├── demo07_macosx.plist
│ │ │ └── macosx_postbuild.sh
│ │ ├── 08 - Sprite Engine (BGRABitmap)/
│ │ │ ├── demo08.lpi
│ │ │ ├── demo08.lpr
│ │ │ ├── demo08_macosx.lpi
│ │ │ ├── demo08_macosx.plist
│ │ │ └── macosx_postbuild.sh
│ │ ├── bgrazengl.pas
│ │ └── readme.txt
│ ├── testbgrafunc/
│ │ ├── COPYING.LGPL.txt
│ │ ├── COPYING.modifiedLGPL.txt
│ │ ├── readme.txt
│ │ ├── testbgrafunc.lpi
│ │ ├── testbgrafunc.lpr
│ │ ├── ucube3d.pas
│ │ ├── umain.lfm
│ │ ├── umain.lrs
│ │ ├── umain.pas
│ │ ├── utest.pas
│ │ ├── utest1.pas
│ │ ├── utest10.pas
│ │ ├── utest11.pas
│ │ ├── utest14.pas
│ │ ├── utest15.pas
│ │ ├── utest16.pas
│ │ ├── utest17.pas
│ │ ├── utest18.pas
│ │ ├── utest19.pas
│ │ ├── utest2.pas
│ │ ├── utest22.pas
│ │ ├── utest23.pas
│ │ ├── utest24.pas
│ │ ├── utest25.pas
│ │ ├── utest26.pas
│ │ ├── utest27.pas
│ │ ├── utest3.pas
│ │ ├── utest31.pas
│ │ ├── utest32.pas
│ │ ├── utest33.pas
│ │ ├── utest4.pas
│ │ ├── utest5.pas
│ │ ├── utest6.pas
│ │ ├── utest7.pas
│ │ ├── utest8.pas
│ │ ├── utest9.pas
│ │ ├── utestback.pas
│ │ ├── utestpacrect.pas
│ │ ├── utexture.pas
│ │ └── utore3d.pas
│ ├── testbiditext/
│ │ ├── project1.lpi
│ │ ├── project1.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── testbiditext2/
│ │ ├── project1.lpi
│ │ ├── project1.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── testcanvas2d/
│ │ ├── testcanvas2D.lpi
│ │ ├── testcanvas2D.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── testcore/
│ │ ├── arial.glyphs
│ │ ├── createfont.lpi
│ │ ├── createfont.lpr
│ │ ├── testcore.lpi
│ │ └── testcore.lpr
│ ├── testgif/
│ │ ├── project1.lpi
│ │ ├── project1.lpr
│ │ ├── project2.lpi
│ │ ├── project2.lpr
│ │ ├── unit1.lfm
│ │ ├── unit1.pas
│ │ ├── unit2.lfm
│ │ └── unit2.pas
│ ├── testglyph/
│ │ ├── testglyph.lpi
│ │ ├── testglyph.lpr
│ │ ├── umain.lfm
│ │ └── umain.pas
│ ├── testsvg/
│ │ ├── testsvg.lpi
│ │ ├── testsvg.lpr
│ │ ├── unit1.lfm
│ │ ├── unit1.pas
│ │ └── uprofiler.pas
│ ├── testvirtualscreen/
│ │ ├── project1.lpi
│ │ ├── project1.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ └── vectorize/
│ ├── umain.lfm
│ ├── umain.pas
│ ├── vectorize.lpi
│ └── vectorize.lpr
├── update_BGRABitmap.json
└── winmake/
├── copyfile.bat
├── remove.bat
└── removedir.bat
================================================
FILE CONTENTS
================================================
================================================
FILE: .github/FUNDING.yml
================================================
# These are supported funding model platforms
github: # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
patreon: # Replace with a single Patreon username
open_collective: # Replace with a single Open Collective username
ko_fi: # Replace with a single Ko-fi username
tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
liberapay: # Replace with a single Liberapay username
issuehunt: # Replace with a single IssueHunt username
otechie: # Replace with a single Otechie username
custom: ['https://sourceforge.net/p/lazpaint/donate/?source=navbar'] # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']
================================================
FILE: .github/dependabot.yml
================================================
---
version: 2
updates:
- package-ecosystem: "github-actions"
directory: "/"
schedule:
interval: "monthly"
================================================
FILE: .github/workflows/make.pas
================================================
program Make;
{$mode objfpc}{$H+}
uses
Classes,
SysUtils,
StrUtils,
FileUtil,
Zipper,
fphttpclient,
RegExpr,
openssl,
opensslsockets,
Process;
const
Target: string = 'test';
Dependencies: array of string = ('epiktimer', 'BGRAControls');
type
TLog = (audit, info, error);
Output = record
Success: boolean;
Output: string;
end;
procedure OutLog(Knd: TLog; Msg: string);
begin
case Knd of
error: Writeln(stderr, #27'[91m', Msg, #27'[0m');
info: Writeln(stderr, #27'[32m', Msg, #27'[0m');
audit: Writeln(stderr, #27'[33m', Msg, #27'[0m');
end;
end;
function CheckModules: Output;
var Line: string;
begin
if FileExists('.gitmodules') then
if RunCommand('git', ['submodule', 'update', '--init', '--recursive',
'--force', '--remote'], Result.Output) then
begin
for Line in SplitString(Result.Output, LineEnding) do
if Line <> '' then
OutLog(info, Line);
end;
end;
function AddPackage(Path: string): Output;
begin
with TRegExpr.Create do
begin
Expression :=
{$IFDEF MSWINDOWS}
'(cocoa|x11|_template)'
{$ELSE}
'(cocoa|gdi|_template)'
{$ENDIF}
;
if not Exec(Path) and RunCommand('lazbuild', ['--add-package-link', Path],
Result.Output) then
OutLog(info, 'added ' + Path);
Free;
end;
end;
function BuildProject(Path: string): Output;
var
Line: string;
begin
OutLog(audit, 'build from ' + Path);
try
Result.Success := RunCommand('lazbuild', ['--build-all', '--recursive',
'--no-write-project', Path], Result.Output);
if Result.Success then
for Line in SplitString(Result.Output, LineEnding) do
begin
if ContainsStr(Line, 'Linking') then
begin
Result.Output := SplitString(Line, ' ')[2];
OutLog(info, ' to ' + Result.Output);
break;
end;
end
else
begin
ExitCode += 1;
with TRegExpr.Create do
begin
Expression := '(Fatal|Error|/ld(\.[a-z]+)?):';
for Line in SplitString(Result.Output, LineEnding) do
begin
if Exec(Line) then
OutLog(error, Line);
end;
Free;
end;
end;
except
on E: Exception do
OutLog(error, E.ClassName + LineEnding + E.Message);
end;
end;
function RunTest(Path: string): Output;
var
Temp: string;
begin
Result := BuildProject(Path);
Temp:= Result.Output;
if Result.Success then
try
if not RunCommand(Temp, ['--all', '--format=plain', '--progress'], Result.Output) then
begin
ExitCode += 1;
OutLog(error, Result.Output);
end;
except
on E: Exception do
OutLog(error, E.ClassName + LineEnding + E.Message);
end;
end;
function InstallOPM(Each: string): string;
var
OutFile, Uri: string;
Zip: TStream;
begin
Result :=
{$IFDEF MSWINDOWS}
GetEnvironmentVariable('APPDATA') + '\.lazarus\onlinepackagemanager\packages\'
{$ELSE}
GetEnvironmentVariable('HOME') + '/.lazarus/onlinepackagemanager/packages/'
{$ENDIF}
+ Each;
OutFile := GetTempFileName;
Uri := 'https://packages.lazarus-ide.org/' + Each + '.zip';
if not DirectoryExists(Result) then
begin
Zip := TFileStream.Create(OutFile, fmCreate or fmOpenWrite);
with TFPHttpClient.Create(nil) do
begin
try
AddHeader('User-Agent', 'Mozilla/5.0 (compatible; fpweb)');
AllowRedirect := True;
Get(Uri, Zip);
OutLog(audit, 'Download from ' + Uri + ' to ' + OutFile);
finally
Free;
end;
end;
Zip.Free;
CreateDir(Result);
with TUnZipper.Create do
begin
try
FileName := OutFile;
OutputPath := Result;
Examine;
UnZipAllFiles;
OutLog(audit, 'Unzip from ' + OutFile + ' to ' + Result);
finally
Free;
end;
end;
DeleteFile(OutFile);
end;
end;
procedure BuildAll;
var
Each, Item: string;
List: TStringList;
begin
CheckModules;
InitSSLInterface;
for Item in Dependencies do
begin
List := FindAllFiles(InstallOPM(Item), '*.lpk', True);
try
for Each in List do
AddPackage(Each);
finally
List.Free;
end;
end;
List := FindAllFiles(GetCurrentDir, '*.lpk', True);
try
for Each in List do
AddPackage(Each);
finally
List.Free;
end;
List := FindAllFiles(Target, '*.lpi', True);
try
for Each in List do
if not ContainsStr(Each, 'zengl') then
if ContainsStr(ReadFileToString(ReplaceStr(Each, '.lpi', '.lpr')),
'consoletestrunner') then
RunTest(Each)
else
BuildProject(Each);
finally
List.Free;
end;
OutLog(audit, '------------');
if ExitCode <> 0 then
OutLog(error, 'Errors: ' + IntToStr(ExitCode))
else
OutLog(info, 'No Errors 😊');
OutLog(audit, '------------');
end;
begin
BuildAll;
end.
================================================
FILE: .github/workflows/make.yml
================================================
---
name: Make
on:
schedule:
- cron: '0 0 1 * *'
push:
branches:
- "**"
pull_request:
branches:
- master
- main
concurrency:
group: ${{ github.workflow }}-${{ github.ref }}
cancel-in-progress: true
jobs:
build:
runs-on: ${{ matrix.os }}
timeout-minutes: 120
strategy:
matrix:
os:
- ubuntu-latest
- windows-latest
steps:
- name: Checkout
uses: actions/checkout@v6
with:
submodules: true
- name: Install Lazarus on Linux
if: runner.os == 'Linux'
shell: bash
run: |
set -xeuo pipefail
sudo bash -c 'apt-get update; apt-get install -y lazarus libxtst-dev' >/dev/null
- name: Build on Linux
if: runner.os == 'Linux'
shell: bash
run: |
set -xeuo pipefail
instantfpc -Fu/usr/lib/lazarus/*/components/lazutils .github/workflows/make.pas
delp -r "${PWD}"
- name: Get Lazarus installer from cache on Windows
if: runner.os == 'Windows'
id: cache-lazarus
uses: actions/cache@v5
with:
path: lazarus-installer
key: ${{ runner.os }}-lazarus-installer-4.0
- name: Download Lazarus installer if not cached on Windows
if: runner.os == 'Windows' && steps.cache-lazarus.outputs.cache-hit != 'true'
shell: powershell
run: |
New-Item -ItemType Directory -Force -Path lazarus-installer
$Uri = 'http://consume.o2switch.net/lazarus/lazarus-4.0-fpc-3.2.2-win64.exe'
$OutFile = "lazarus-installer\lazarus-setup.exe"
Invoke-WebRequest -Uri $Uri -OutFile $OutFile
- name: Install Lazarus on Windows
if: runner.os == 'Windows'
shell: powershell
run: |
$Installer = "lazarus-installer\lazarus-setup.exe"
& $Installer /SP- /VERYSILENT /SUPPRESSMSGBOXES /NORESTART | Out-Null
- name: Build on Windows
if: runner.os == 'Windows'
shell: powershell
run: |
$Env:PATH += ';C:\Lazarus;C:\Lazarus\fpc\3.2.2\bin\x86_64-win64'
instantfpc '-FuC:\Lazarus\components\lazutils' .github/workflows/make.pas
delp -r $PWD.Path
================================================
FILE: .gitignore
================================================
*.bak
*.dbg
*.exe
*.lps
*.res
*.lrt
*.bak1
*.app
.DS_Store
backup
lib
bin
debug
/bgrabitmap/lib4nogui
/bgrabitmap/lib4fpgui
/bgrabitmap/lib4android
/bgrabitmap/lib4android+freetype
test/testglyph/testglyph
test/rationalbezier/rationalbezier
test/testbiditext2/project1
test/colorspace/ColorsDemo
test/colorspace/HorseShoe
test/testbiditext/project1
test/test4ideu/fractal_tree/units/
test/test4other/test.png
dev/releaser/releaser
dev/colorspace/UnitMaker
dev/colorspace/generatecolorspaces
dev/colorspace/generatedcolorspace.inc
test/test4other/test4nolcl
test/test4other/test4nolcl_freetype
bgrabitmap/doc/
dev/makedoc/pmakedoc
pasdoc
doc/web
test/testcore/lib
test/testcore/lib_createfont
use/*/
================================================
FILE: .gitmodules
================================================
[submodule "use/fpGUI"]
path = use/fpGUI
url = https://github.com/graemeg/fpGUI.git
[submodule "use/lape"]
path = use/lape
url = https://github.com/nielsAD/lape.git
================================================
FILE: COPYING.LGPL.txt
================================================
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.
================================================
FILE: COPYING.modifiedLGPL.txt
================================================
This is the file COPYING.modifiedLGPL, it applies to all units of the
BGRABitmap library.
These files are distributed under the GNU Lesser General Public License
(see the file COPYING.LGPL) with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,
and to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify this
library, you may extend this exception to your version of the library, but
you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
If you didn't receive a copy of the file COPYING.LGPL, contact:
Free Software Foundation, Inc.,
675 Mass Ave
Cambridge, MA 02139
USA
================================================
FILE: Makefile
================================================
ifeq ($(OS),Windows_NT) # true for Windows_NT or later
COPY := winmake\copyfile
REMOVE := winmake\remove
REMOVEDIR := winmake\removedir
THEN := &
RUN :=
else
COPY := cp
REMOVE := rm -f
REMOVEDIR := rm -rf
THEN := ;
RUN := ./
RUN := $(strip $(RUN))
endif
all: generate compile
install: not_installable
uninstall: not_installable
not_installable:
echo "The library cannot be installed on the system but statically linked to another Lazarus package or application."
clean: clean_bgrabitmap clean_generate
clean_bgrabitmap:
$(REMOVE) "bgrabitmap/generatedcolorspace.inc"
$(REMOVE) "bgrabitmap/generatedunicode.inc"
$(REMOVE) "bgrabitmap/generatedutf8.inc"
$(REMOVEDIR) "bgrabitmap/lib"
$(REMOVEDIR) "bgrabitmap/lib4nogui"
$(REMOVEDIR) "bgrabitmap/backup"
clean_generate:
$(REMOVE) "dev/colorspace/generatecolorspaces"
$(REMOVE) "dev/colorspace/generatedcolorspace.inc"
$(REMOVEDIR) "dev/colorspace/lib"
$(REMOVEDIR) "dev/colorspace/backup"
$(REMOVE) "dev/parseunicode/parseunicodeclasses"
$(REMOVE) "dev/parseunicode/generatedunicode.inc"
$(REMOVE) "dev/parseunicode/generatedutf8.inc"
$(REMOVE) "dev/parseunicode/generatedkerningfallback.inc"
$(REMOVEDIR) "dev/parseunicode/lib"
$(REMOVEDIR) "dev/parseunicode/backup"
generate: bgrabitmap/generatedcolorspace.inc bgrabitmap/generatedunicode.inc
bgrabitmap/generatedcolorspace.inc: dev/colorspace/generatecolorspaces.lpr dev/colorspace/unitmakerunit.pas
lazbuild dev/colorspace/generatecolorspaces.lpi
cd dev $(THEN) cd colorspace $(THEN) $(RUN)generatecolorspaces
$(COPY) dev/colorspace/generatedcolorspace.inc bgrabitmap/generatedcolorspace.inc
bgrabitmap/generatedunicode.inc: dev/parseunicode/parseunicodeclasses.lpr dev/parseunicode/ArabicShaping.txt dev/parseunicode/BidiBrackets.txt dev/parseunicode/BidiMirroring.txt dev/parseunicode/UnicodeData.txt
lazbuild dev/parseunicode/parseunicodeclasses.lpi
cd dev $(THEN) cd parseunicode $(THEN) $(RUN)parseunicodeclasses
$(COPY) dev/parseunicode/generatedunicode.inc bgrabitmap/generatedunicode.inc
$(COPY) dev/parseunicode/generatedutf8.inc bgrabitmap/generatedutf8.inc
compile: BGRABitmapPack BGRABitmapPack4NoGUI
lazbuild:
#lazbuild will determine what to recompile
BGRABitmapPack: lazbuild bgrabitmap/bgrabitmappack.lpk
lazbuild bgrabitmap/bgrabitmappack.lpk
BGRABitmapPack4NoGUI: lazbuild bgrabitmap/bgrabitmappack4nogui.lpk
lazbuild bgrabitmap/bgrabitmappack4nogui.lpk
================================================
FILE: bglcontrols/bglcontrols.lpk
================================================
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="BGLControls"/>
<Type Value="RunAndDesignTime"/>
<Author Value="Circular"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\$(FPCVer)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Optimizations>
<OptimizationLevel Value="3"/>
<VariablesInRegisters Value="True"/>
</Optimizations>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
</Linking>
</CompilerOptions>
<Description Value="Drawing routines with alpha blending and antialiasing"/>
<License Value="modified LGPL"/>
<Version Major="1" Minor="2"/>
<Files Count="2">
<Item1>
<Filename Value="bglvirtualscreen_icon.lrs"/>
<Type Value="LRS"/>
</Item1>
<Item2>
<Filename Value="bglvirtualscreen.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="BGLVirtualScreen"/>
</Item2>
</Files>
<RequiredPkgs Count="4">
<Item1>
<PackageName Value="BGRABitmapPack"/>
</Item1>
<Item2>
<PackageName Value="lazopenglcontext"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
<Item4>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item4>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<CustomOptions Items="ExternHelp" Version="2">
<_ExternHelp Items="Count"/>
</CustomOptions>
</Package>
</CONFIG>
================================================
FILE: bglcontrols/bglcontrols.pas
================================================
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit BGLControls;
interface
uses
BGLVirtualScreen, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('BGLVirtualScreen', @BGLVirtualScreen.Register);
end;
initialization
RegisterPackage('BGLControls', @Register);
end.
================================================
FILE: bglcontrols/bglvirtualscreen.pas
================================================
// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit BGLVirtualScreen;
{$mode objfpc}{$H+}
interface
uses
Classes, BGRAClasses, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
ExtCtrls, BGRABitmapTypes, BGRAOpenGL, OpenGLContext, BGRACanvasGL,
BGRASpriteGL;
type
TCustomBGLVirtualScreen = class;
TBGLRedrawEvent = procedure (Sender: TObject; BGLContext: TBGLContext) of object;
TBGLLoadTexturesEvent = procedure (Sender: TObject; BGLContext: TBGLContext) of object;
TBGLElapseEvent = procedure (Sender: TObject; BGLContext: TBGLContext; ElapsedMs: integer) of object;
TBGLFramesPerSecondEvent = procedure (Sender: TObject; BGLContext: TBGLContext; FramesPerSecond: integer) of object;
TBGLUseContextCallback = procedure (Sender: TObject; BGLContext: TBGLContext; Data: Pointer) of object;
{ TCustomBGLVirtualScreen }
TCustomBGLVirtualScreen = class(TCustomOpenGLControl)
private
{ Private declarations }
FOnRedraw: TBGLRedrawEvent;
FOnLoadTextures: TBGLLoadTexturesEvent;
FOnUnloadTextures: TBGLLoadTexturesEvent;
FOnElapse: TBGLElapseEvent;
FOnFramesPerSecond: TBGLFramesPerSecondEvent;
FSmoothedElapse: boolean;
FTexturesLoaded: boolean;
FBevelInner, FBevelOuter: TPanelBevel;
FBevelWidth: TBevelWidth;
FBorderWidth: TBorderWidth;
FRedrawOnIdle: boolean;
FSprites: TBGLCustomSpriteEngine;
FElapseAccumulator, FElapseCount, FStoredFPS: integer;
FSmoothedElapseAccumulator: single;
FContextPrepared: boolean;
FOldSprites: TBGLCustomSpriteEngine;
FShaderList,FOldShaderList: TStringList;
function GetCanvas: TBGLCustomCanvas;
procedure SetBevelInner(const AValue: TPanelBevel);
procedure SetBevelOuter(const AValue: TPanelBevel);
procedure SetBevelWidth(const AValue: TBevelWidth);
procedure SetBorderWidth(const AValue: TBorderWidth);
procedure SetRedrawOnIdle(AValue: Boolean);
procedure SetSmoothedElapse(AValue: boolean);
protected
class var FToRedrawOnIdle: array of TCustomBGLVirtualScreen;
{ Protected declarations }
procedure RedrawContent(ctx: TBGLContext); virtual;
procedure SetEnabled(Value: boolean); override;
procedure OnAppIdle(Sender: TObject; var Done: Boolean);
procedure LoadTextures; virtual;
function PrepareBGLContext: TBGLContext;
procedure ReleaseBGLContext(ctx: TBGLContext);
public
{ Public declarations }
procedure DoOnPaint; override;
procedure QueryLoadTextures; virtual;
procedure UnloadTextures; virtual;
procedure UseContext(ACallback: TBGLUseContextCallback; AData: Pointer = nil);
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
public
property Canvas: TBGLCustomCanvas read GetCanvas;
property Sprites: TBGLCustomSpriteEngine read FSprites;
property OnLoadTextures: TBGLLoadTexturesEvent Read FOnLoadTextures Write FOnLoadTextures;
property OnUnloadTextures: TBGLLoadTexturesEvent Read FOnUnloadTextures Write FOnUnloadTextures;
property OnRedraw: TBGLRedrawEvent Read FOnRedraw Write FOnRedraw;
property OnElapse: TBGLElapseEvent Read FOnElapse Write FOnElapse;
property OnFramesPerSecond: TBGLFramesPerSecondEvent Read FOnFramesPerSecond Write FOnFramesPerSecond;
property RedrawOnIdle: Boolean read FRedrawOnIdle write SetRedrawOnIdle default False;
property BorderWidth: TBorderWidth Read FBorderWidth Write SetBorderWidth default 0;
property BevelInner: TPanelBevel Read FBevelInner Write SetBevelInner default bvNone;
property BevelOuter: TPanelBevel Read FBevelOuter Write SetBevelOuter default bvNone;
property BevelWidth: TBevelWidth Read FBevelWidth Write SetBevelWidth default 1;
property SmoothedElapse: boolean read FSmoothedElapse write SetSmoothedElapse default False;
end;
TBGLVirtualScreen = class(TCustomBGLVirtualScreen)
published
property OnRedraw;
property Align;
property Anchors;
property AutoSize;
property BorderSpacing;
property BevelInner;
property BevelOuter;
property BevelWidth;
property BidiMode;
property BorderWidth;
property BorderStyle;
property Caption;
property ChildSizing;
property ClientHeight;
property ClientWidth;
property Color;
property Constraints;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ParentBidiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property RedrawOnIdle;
property ShowHint;
property TabOrder;
property TabStop;
property UseDockManager default True;
property Visible;
property OnClick;
property OnContextPopup;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnElapse;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnFramesPerSecond;
property OnGetSiteInfo;
property OnGetDockCaption;
property OnLoadTextures;
property OnUnloadTextures;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
property SmoothedElapse;
end;
procedure Register;
implementation
procedure Register;
begin
{$I bglvirtualscreen_icon.lrs}
RegisterComponents('OpenGL', [TBGLVirtualScreen]);
end;
{ TCustomBGLVirtualScreen }
procedure TCustomBGLVirtualScreen.SetBevelInner(const AValue: TPanelBevel);
begin
if FBevelInner = AValue then
exit;
FBevelInner := AValue;
Invalidate;
end;
function TCustomBGLVirtualScreen.GetCanvas: TBGLCustomCanvas;
begin
result := BGLCanvas;
end;
procedure TCustomBGLVirtualScreen.SetBevelOuter(const AValue: TPanelBevel);
begin
if FBevelOuter = AValue then
exit;
FBevelOuter := AValue;
Invalidate;
end;
procedure TCustomBGLVirtualScreen.SetBevelWidth(const AValue: TBevelWidth);
begin
if FBevelWidth = AValue then
exit;
FBevelWidth := AValue;
Invalidate;
end;
procedure TCustomBGLVirtualScreen.SetBorderWidth(const AValue: TBorderWidth);
begin
if FBorderWidth = AValue then
exit;
FBorderWidth := AValue;
Invalidate;
end;
procedure TCustomBGLVirtualScreen.SetRedrawOnIdle(AValue: Boolean);
var
i: Integer;
j: Integer;
begin
if FRedrawOnIdle=AValue then Exit;
FRedrawOnIdle:=AValue;
if FRedrawOnIdle then
begin
if length(FToRedrawOnIdle)= 0 then
Application.AddOnIdleHandler(@OnAppIdle);
setlength(FToRedrawOnIdle, length(FToRedrawOnIdle)+1);
FToRedrawOnIdle[high(FToRedrawOnIdle)] := self;
end
else
if length(FToRedrawOnIdle)> 0 then
begin
for i := 0 to high(FToRedrawOnIdle) do
begin
if FToRedrawOnIdle[i]=self then
begin
for j := i to high(FToRedrawOnIdle)-1 do
FToRedrawOnIdle[j] := FToRedrawOnIdle[j+1];
setlength(FToRedrawOnIdle, length(FToRedrawOnIdle)-1);
break;
end;
end;
if length(FToRedrawOnIdle) = 0 then
Application.RemoveOnIdleHandler(@OnAppIdle);
end;
end;
procedure TCustomBGLVirtualScreen.SetSmoothedElapse(AValue: boolean);
begin
if FSmoothedElapse=AValue then Exit;
FSmoothedElapse:=AValue;
end;
procedure TCustomBGLVirtualScreen.DoOnPaint;
var
ctx: TBGLContext;
knownFPS: Integer;
begin
if not FTexturesLoaded then LoadTextures;
ctx := PrepareBGLContext;
if Color = clNone then
BGLViewPort(ClientWidth,ClientHeight)
else
if Color = clDefault then
BGLViewPort(ClientWidth,ClientHeight,ColorToBGRA(clWindow))
else
BGLViewPort(ClientWidth,ClientHeight,ColorToBGRA(Color));
RedrawContent(ctx);
inherited DoOnPaint;
SwapBuffers;
inc(FElapseAccumulator, FrameDiffTimeInMSecs);
Inc(FElapseCount);
if FElapseAccumulator >= 2000 then
begin
FStoredFPS := 1000*FElapseCount div FElapseAccumulator;
if Assigned(FOnFramesPerSecond) then
FOnFramesPerSecond(self, ctx, FStoredFPS);
FElapseAccumulator := 0;
FElapseCount := 0;
end;
If Assigned(FOnElapse) then
begin
if SmoothedElapse then
begin
If FStoredFPS <> 0 then
knownFPS:= FStoredFPS
else
if FElapseAccumulator >= 500 then
knownFPS := 1000*FElapseCount div FElapseAccumulator
else
knownFPS := 0;
if knownFPS > 0 then
begin
IncF(FSmoothedElapseAccumulator, 1000/knownFPS);
end else
IncF(FSmoothedElapseAccumulator, FrameDiffTimeInMSecs);
FOnElapse(self, ctx, Trunc(FSmoothedElapseAccumulator));
DecF(FSmoothedElapseAccumulator, Trunc(FSmoothedElapseAccumulator));
end else
FOnElapse(self, ctx, FrameDiffTimeInMSecs);
end;
ReleaseBGLContext(ctx);
end;
procedure TCustomBGLVirtualScreen.QueryLoadTextures;
begin
FTexturesLoaded := false;
end;
procedure TCustomBGLVirtualScreen.LoadTextures;
var ctx: TBGLContext;
begin
if MakeCurrent then
begin
if Assigned(FOnLoadTextures) then
begin
ctx := PrepareBGLContext;
FOnLoadTextures(self, ctx);
ReleaseBGLContext(ctx);
end;
FTexturesLoaded:= true;
end;
end;
function TCustomBGLVirtualScreen.PrepareBGLContext: TBGLContext;
begin
if FContextPrepared then
raise exception.Create('Context already prepared');
FOldSprites := BGRASpriteGL.BGLSpriteEngine;
BGRASpriteGL.BGLSpriteEngine := FSprites;
FOldShaderList := BGLCanvas.Lighting.ShaderList;
BGLCanvas.Lighting.ShaderList := FShaderList;
result.Canvas := BGLCanvas;
result.Sprites := FSprites;
FContextPrepared := true;
end;
procedure TCustomBGLVirtualScreen.ReleaseBGLContext(ctx: TBGLContext);
begin
if not FContextPrepared then
raise exception.Create('Context not prepared');
ctx.Canvas.Lighting.ShaderList := FOldShaderList;
BGRASpriteGL.BGLSpriteEngine := FOldSprites;
FContextPrepared := false;
end;
procedure TCustomBGLVirtualScreen.UnloadTextures;
var ctx: TBGLContext;
begin
if MakeCurrent then
begin
ctx := PrepareBGLContext;
if Assigned(FOnUnloadTextures) then FOnUnloadTextures(self, ctx);
FSprites.Clear;
ctx.Canvas.Lighting.FreeShaders;
ReleaseBGLContext(ctx);
FTexturesLoaded := false;
end;
end;
procedure TCustomBGLVirtualScreen.UseContext(ACallback: TBGLUseContextCallback; AData: Pointer);
var
ctx: TBGLContext;
begin
if not MakeCurrent then
raise exception.Create('Unable to switch to the OpenGL context');
ctx := PrepareBGLContext;
try
ACallback(self, ctx, AData);
finally
ReleaseBGLContext(ctx);
end;
end;
procedure TCustomBGLVirtualScreen.RedrawContent(ctx: TBGLContext);
var
ARect: TRect;
w: integer;
begin
ARect := rect(0,0,ctx.Canvas.Width,ctx.Canvas.Height);
w := BevelWidth;
if w = 0 then w := 1;
// if BevelOuter is set then draw a frame with BevelWidth
if (BevelOuter <> bvNone) and (w > 0) then
ctx.Canvas.Frame3d(ARect, w, BevelOuter); // Note: Frame3D inflates ARect
ARect.Inflate(-BorderWidth, -BorderWidth);
// if BevelInner is set then skip the BorderWidth and draw a frame with BevelWidth
if (BevelInner <> bvNone) and (w > 0) then
ctx.Canvas.Frame3d(ARect, w, BevelInner); // Note: Frame3D inflates ARect
if Assigned(FOnRedraw) then
FOnRedraw(self, ctx);
end;
procedure TCustomBGLVirtualScreen.SetEnabled(Value: boolean);
begin
if Value <> Enabled then Invalidate;
inherited SetEnabled(Value);
end;
procedure TCustomBGLVirtualScreen.OnAppIdle(Sender: TObject; var Done: Boolean);
var
i: Integer;
begin
if length(FToRedrawOnIdle) > 0 then
begin
for i := 0 to high(FToRedrawOnIdle) do
if not (csDesigning in FToRedrawOnIdle[i].ComponentState) then
FToRedrawOnIdle[i].Invalidate;
Done:=false;
end;
end;
constructor TCustomBGLVirtualScreen.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FTexturesLoaded:= False;
AutoResizeViewport := true;
FSprites := TBGLDefaultSpriteEngine.Create;
FShaderList:= TStringList.Create;
FStoredFPS := 0;
FElapseAccumulator := 0;
FElapseCount := 0;
FSmoothedElapseAccumulator := 0;
end;
destructor TCustomBGLVirtualScreen.Destroy;
var
i: Integer;
begin
for i := 0 to FShaderList.Count-1 do
FShaderList.Objects[i].Free;
FShaderList.Free;
RedrawOnIdle := false;
FSprites.Free;
inherited Destroy;
end;
end.
================================================
FILE: bglcontrols/bglvirtualscreen_icon.lrs
================================================
LazarusResources.Add('TBGLVirtualScreen','PNG',[
#137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#3#0#0#0#215#169#205
+#202#0#0#0#1'sRGB'#0#174#206#28#233#0#0#0#4'gAMA'#0#0#177#143#11#252'a'#5#0#0
+#3#0'PLTE'#0#0#0'7k'#190'vv'#146#128#128#128#150#181#231#192#192#192#194#192
+#193#223#223#219#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#179#142
+#179#217#0#0#1#0'tRNS'#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255
+#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0'S'#247#7'%'#0#0#0
+#9'pHYs'#0#0#14#195#0#0#14#195#1#199'o'#168'd'#0#0#0#25'tEXtSoftware'#0'Pain'
+'t.NET v3.5.87;'#128']'#0#0#0#145'IDAT(S}'#146#1#14#133' '#12'C;`'#204#251'_'
+#216#223'150'#244'WM'#180#175#133'd'#130#243'C'#248#3#202'.'#166#217'(GR+'
+#253#2#246#168#241#173#245#13#136#208'n'#182#1'i'#188'Dr'#3#244#220#150#212
+#128#24#200'xo'#128#27#152#195#21#140#133#140#15#236#5#132#191#0#212#216#186
+'&'#0#173#131#12#127'j'#248#167#163#240'g'#160#170#142#194'O@'#237#246#151
+#165#152#214'+?5`'#10#234#25#241'=D'#28#204#247'Y1v'#20#250#233''''#6#168')'
+#239#221#1#240'z >O'#201#15#143#1#178'Ms O)'#0#0#0#0'IEND'#174'B`'#130
]);
================================================
FILE: bgrabitmap/avifbgra.pas
================================================
// SPDX-License-Identifier: LGPL-3.0-linking-exception
{ @abstract(Easy to use classes and functions to read/write images in AVIF format.)
It supports multi-image files.
Note that it requires libavif library. }
unit avifbgra;
{ Author: Domingo Galmes <dgalmesp@gmail.com> 01-11-2021 }
{$mode ObjFPC}{$H+}
interface
uses
Classes, SysUtils, BGRABitmapTypes, libavif;
type
{* Exception when using libavif library }
EAvifException = class(Exception);
{* Pixel format to use when encoding the image }
avifPixelFormat = libavif.avifPixelFormat;
const
{** This format uses YUV color space with a 4:4:4 chroma subsampling.
In this format, each component (Y for luminance, U, and V for chrominance) has the same
sample rate, meaning there's no chroma subsampling. This results in high-quality images
because it retains all the color information. }
AVIF_PIXEL_FORMAT_YUV444 = libavif.AVIF_PIXEL_FORMAT_YUV444;
{** This format also uses the YUV color space but with 4:2:2 chroma subsampling.
Here, the horizontal resolution of the chroma channels is halved
compared to the luminance channel, reducing the image size while still maintaining good quality.
It strikes a balance between compression and image quality. }
AVIF_PIXEL_FORMAT_YUV422 = libavif.AVIF_PIXEL_FORMAT_YUV422;
{** Utilizing the YUV color space with 4:2:0 chroma subsampling, this format reduces both
the horizontal and vertical resolution of the chroma channels by half relative
to the luminance channel. This is a commonly used format for digital video compression,
offering significant file size reduction at the cost of some image quality,
especially in areas with high color detail. }
AVIF_PIXEL_FORMAT_YUV420 = libavif.AVIF_PIXEL_FORMAT_YUV420;
{** This is a monochrome format where only the Y (luminance) component is used, and there are
no U and V (chrominance) components. Essentially, it's a grayscale image, which can
significantly reduce the file size while being appropriate for images that
don't require color. }
AVIF_PIXEL_FORMAT_YUV400 = libavif.AVIF_PIXEL_FORMAT_YUV400;
type
{* Codec choices for encoding and/or decoding AVIF }
avifCodecChoice = libavif.avifCodecChoice;
const
{ AOM stands for Alliance for Open Media, which is the consortium
that developed the AV1 codec. This choice indicates the use of AOM's reference implementation
for both encoding and decoding AVIF images. }
AVIF_CODEC_CHOICE_AOM = libavif.AVIF_CODEC_CHOICE_AOM;
{ This decoding-only codec is focused on decoding AV1 content. Developed by the VideoLAN, VLC, and FFmpeg
communities, dav1d is known for its speed and efficiency in decoding AV1 streams. }
AVIF_CODEC_CHOICE_DAV1D = libavif.AVIF_CODEC_CHOICE_DAV1D;
{ This decoding-only codec is developed by Google. It is designed for efficiency and is used in
various Google products for decoding AV1 content. }
AVIF_CODEC_CHOICE_LIBGAV1 = libavif.AVIF_CODEC_CHOICE_LIBGAV1;
{ This encoding-only codec is designed to offer efficient encoding of video content. }
AVIF_CODEC_CHOICE_RAV1E = libavif.AVIF_CODEC_CHOICE_RAV1E;
{ This encoding-only codec focuses on offering high performance and scalability. SVT stands for
Scalable Video Technology. }
AVIF_CODEC_CHOICE_SVT = libavif.AVIF_CODEC_CHOICE_SVT;
{ Ongoing development in the next-generation video compression technology beyond AV1. }
AVIF_CODEC_CHOICE_AVM = libavif.AVIF_CODEC_CHOICE_AVM;
const
{ Default number of allocated threads for processing }
AVIF_BGRA_DEFAULT_MAX_THREADS = 2;
{ Default timescale of the media (in Hz), not relevant for images }
AVIF_BGRA_DEFAULT_TIMESCALE = 30;
{ Default quality of color compression }
AVIF_BGRA_DEFAULT_QUALITY = 30;
{ Default difference between color quality and alpha quality }
AVIF_BGRA_DEFAULT_QUALITY_ALPHA_DELTA = 25;
{ Default quality of compression of the alpha channel }
AVIF_BGRA_DEFAULT_QUALITY_ALPHA = AVIF_BGRA_DEFAULT_QUALITY + AVIF_BGRA_DEFAULT_QUALITY_ALPHA_DELTA;
{ Specify that no information will be lost in the compression process }
AVIF_BGRA_LOSSLESS_QUALITY = 100;
{ Let the encoder choose the adequate speed }
AVIF_BGRA_SPEED_DEFAULT = AVIF_SPEED_DEFAULT;
{ Common format for image compression with half the resolution for chroma channels
(ignored when used with AVIF_BGRA_LOSSLESS_QUALITY) }
AVIF_BGRA_PIXEL_FORMAT_DEFAULT = AVIF_PIXEL_FORMAT_YUV420;
{ Let the encoder choose the adequate codec }
AVIF_BGRA_CODEC_CHOICE_AUTO = AVIF_CODEC_CHOICE_AUTO;
type
{ Reader for AVIF images or animations (not derived from TFPCustomImageReader) }
TAvifReader = class
private
function GetImageCount: uint32;
function GetImageIndex: integer;
function GetRepetitionCount: integer;
function GetSequenceDuration: double;
function GetTimescale: uint64;
protected
FDecoder: PavifDecoder;
FDecoderWrap: TObject; //TDecoderBase;
FStream: TStream;
FStreamOwned: boolean;
FWidth: uint32;
FHeight: uint32;
FImageDurationSeconds: double;
FImageDurationTimescales: UInt64;
procedure Init(AStream: TStream; AStreamOwned: boolean);
procedure SetDecoder(ACodec: avifCodecChoice);
function GetDecoder: avifCodecChoice;
procedure Close; // call before unloading libavif
public
constructor Create(AFileName: string); virtual; overload;
constructor Create(AStream: TStream; AStreamOwned: boolean = false); virtual; overload;
destructor Destroy; override;
class function CreateDecoder: PavifDecoder;
class procedure DestroyDecoder(var ADecoder: PavifDecoder);
function GetNextImage(AOutBitmap: TBGRACustomBitmap): boolean;
function GetNthImage(AOutBitmap: TBGRACustomBitmap; AImageIndex: uint32): boolean;
property Decoder: avifCodecChoice read GetDecoder write SetDecoder;
property ImageIndex: integer read GetImageIndex;
property ImageCount: uint32 read GetImageCount;
property ImageDurationSeconds: double read FImageDurationSeconds;
property ImageDurationTimescales: uint64 read FImageDurationTimescales;
property SequenceDuration: double read GetSequenceDuration;
property RepetitionCount: integer read GetRepetitionCount;
property Width: uint32 read FWidth;
property Height: uint32 read FHeight;
property Timescale: uint64 read GetTimescale; // if all images have 1 timescale of duration is the same as FPS
end;
{ Writer for AVIF images or animations (not derived from TFPCustomImageWriter) }
TAvifWriter = class
protected
FEncoder: PAvifEncoder;
FEncoderWrap: TObject; //TEncoderBase;
FQuality0to100: integer;
FPixelFormat: avifPixelFormat;
FQualityAlpha0to100: integer;
FIgnoreAlpha: boolean;
FAvifOutput: avifRWData;
FOnlyOneImage: boolean;
FImagesCount: uint32;
FLossless: boolean;
procedure EncoderFinish;
procedure SetMaxThreads(AMT: integer);
procedure SetIgnoreAlpha(AValue: boolean);
function GetMaxThreads: integer;
procedure SetEncoder(ACodec: avifCodecChoice);
function GetEncoder: avifCodecChoice;
function GetLossless: boolean;
procedure SetLossless(AValue: boolean);
procedure SetTimescale(ATimescale: uint64);
function GetTimescale: uint64;
procedure SetSpeed(ASpeed: integer);
function GetSpeed: integer;
procedure SetQuality(AValue: integer);
procedure SetQualityAlpha(AValue: integer);
procedure ApplyQuality;
public
constructor Create(
AQuality0to100: integer = AVIF_BGRA_DEFAULT_QUALITY;
ASpeed0to10: integer = AVIF_BGRA_SPEED_DEFAULT;
APixelFormat: avifPixelFormat = AVIF_BGRA_PIXEL_FORMAT_DEFAULT;
AIgnoreAlpha: boolean = False); virtual; overload;
procedure Close;
destructor Destroy; override;
class function CreateEncoder: PAvifEncoder;
class procedure DestroyEncoder(var AEncoder: PAvifEncoder);
procedure AddImage(ABitmap: TBGRACustomBitmap; ADurationMs: cardinal=0);
function SaveToFile(AFileName: string): NativeUInt;
function SaveToStream(AStream: TStream): NativeUInt;
function SaveToMemory(AData: Pointer; ASize: NativeUInt): NativeUInt;
function GetOutputSize: NativeUInt;
property Encoder: avifCodecChoice read GetEncoder write SetEncoder;
property OnlyOneImage: boolean read FOnlyOneImage write FOnlyOneImage;
property MaxThreads: integer read GetMaxThreads write SetMaxThreads;
property PixelFormat: avifPixelFormat read FPixelFormat write FPixelFormat;
property Quality: integer read FQuality0to100 write SetQuality;
property QualityAlpha: integer read FQualityAlpha0to100 write SetQualityAlpha;
property Speed: integer read GetSpeed write SetSpeed;
property Timescale: uint64 read GetTimescale write SetTimescale; // frequency in Hertz
property IgnoreAlpha: boolean read FIgnoreAlpha write SetIgnoreAlpha;
property Lossless: boolean read GetLossless write SetLossless;
end;
{ Load an AVIF image from the given stream }
procedure AvifLoadFromStream(AStream: TStream; aBitmap: TBGRACustomBitmap);
{ Load an AVIF image from the given file }
procedure AvifLoadFromFile(const AFilename: string; aBitmap: TBGRACustomBitmap);
{ Load an AVIF image from the given file without using the reader class }
procedure AvifLoadFromFileNative(const AFilename: string; aBitmap: TBGRACustomBitmap);
{ Load an AVIF image from memory, without using the reader class }
procedure AvifLoadFromMemory(AData: Pointer; ASize: cardinal; aBitmap: TBGRACustomBitmap);
{ Save an image into a stream using AVIF format. Return the number of bytes needed. }
function AvifSaveToStream(aBitmap: TBGRACustomBitmap; AStream: TStream;
aQuality0to100: integer = AVIF_BGRA_DEFAULT_QUALITY;
aSpeed0to10: integer = AVIF_BGRA_SPEED_DEFAULT;
aPixelFormat:avifPixelFormat = AVIF_BGRA_PIXEL_FORMAT_DEFAULT;
aIgnoreAlpha:boolean = false): NativeUInt;
{ Save an image into a file using AVIF format. Return the number of bytes needed. }
function AvifSaveToFile(aBitmap: TBGRACustomBitmap; const AFilename: string;
aQuality0to100: integer = AVIF_BGRA_DEFAULT_QUALITY;
aSpeed0to10: integer = AVIF_BGRA_SPEED_DEFAULT;
aPixelFormat: avifPixelFormat = AVIF_BGRA_PIXEL_FORMAT_DEFAULT;
aIgnoreAlpha: boolean = false): NativeUInt;
{ Save an image to memory using AVIF format. Return the number of bytes needed. }
function AvifSaveToMemory(aBitmap: TBGRACustomBitmap; AData: Pointer; ASize: cardinal;
aQuality0to100: integer = AVIF_BGRA_DEFAULT_QUALITY;
aSpeed0to10:integer = AVIF_BGRA_SPEED_DEFAULT;
aPixelFormat:avifPixelFormat = AVIF_BGRA_PIXEL_FORMAT_DEFAULT;
aIgnoreAlpha:boolean = false): NativeUInt;
{ Save an image into a stream using AVIF format. Return the number of bytes needed. }
function AvifSaveToStream(ABitmap: TBGRACustomBitmap; AStream: TStream;
AIgnoreAlpha: boolean = False;
AQuality0to100: integer = AVIF_BGRA_DEFAULT_QUALITY;
AQualityAlpha0to100: integer = AVIF_BGRA_DEFAULT_QUALITY_ALPHA;
APixelFormat: avifPixelFormat = AVIF_BGRA_PIXEL_FORMAT_DEFAULT;
ACodec: avifCodecChoice = AVIF_BGRA_CODEC_CHOICE_AUTO;
ASpeed0to10: integer = AVIF_BGRA_SPEED_DEFAULT): nativeuint; overload;
{ Save an image into a file using AVIF format. Return the number of bytes needed. }
function AvifSaveToFile(ABitmap: TBGRACustomBitmap; const AFilename: string;
AIgnoreAlpha: boolean = False;
AQuality0to100: integer = AVIF_BGRA_DEFAULT_QUALITY;
AQualityAlpha0to100: integer = AVIF_BGRA_DEFAULT_QUALITY_ALPHA;
APixelFormat: avifPixelFormat = AVIF_BGRA_PIXEL_FORMAT_DEFAULT;
ACodec: avifCodecChoice = AVIF_BGRA_CODEC_CHOICE_AUTO;
ASpeed0to10: integer = AVIF_BGRA_SPEED_DEFAULT): nativeuint; overload;
{ Save an image to memory using AVIF format. Return the number of bytes needed. }
function AvifSaveToMemory(ABitmap: TBGRACustomBitmap; AData: Pointer; ASize: nativeuint;
AIgnoreAlpha: boolean = False;
AQuality0to100: integer = AVIF_BGRA_DEFAULT_QUALITY;
AQualityAlpha0to100: integer = AVIF_BGRA_DEFAULT_QUALITY_ALPHA;
APixelFormat: avifPixelFormat = AVIF_BGRA_PIXEL_FORMAT_DEFAULT;
ACodec: avifCodecChoice = AVIF_BGRA_CODEC_CHOICE_AUTO;
ASpeed0to10: integer = AVIF_BGRA_SPEED_DEFAULT): nativeuint; overload;
{ Checks that the signature of the memory block correspond to a valid AVIF header }
function AvifValidateHeaderSignature(
aBuffer: Pointer // at least 12 first bytes of file
): boolean;
implementation
uses
Math;
type
PavifIOStreamReader = ^avifIOStreamReader;
avifIOStreamReader = record
io: avifIO; // this must be the first member for easy casting to avifIO*
buffer: avifRWData;
Stream: TStream;
end;
TAvifImageBase = class
public
procedure Init(aImagePtr: Pointer); virtual; abstract;
function GetTransformFlags: longword; virtual; abstract;
function GetImirMode: uint8; virtual; abstract;
procedure SetColorPrimaries(AColorPrimaries: avifColorPrimaries); virtual; abstract;
procedure SetTransferCharacteristics(ATC: avifTransferCharacteristics); virtual; abstract;
procedure SetMatrixCoefficients(AMC: avifMatrixCoefficients); virtual; abstract;
procedure SetYuvRange(AYR: avifRange); virtual; abstract;
procedure SetTransformFlags(ATF: avifTransformFlags); virtual; abstract;
procedure SetImirMode(AIM: uint8); virtual; abstract;
end;
generic TAvifImage<T> = class(TAvifImageBase)
protected
FImage: T;
public
constructor Create(aImagePtr: Pointer = nil);
procedure Init(aImagePtr: Pointer); override;
function GetTransformFlags: longword; override;
function GetImirMode: uint8; override;
procedure SetColorPrimaries(AColorPrimaries: avifColorPrimaries); override;
procedure SetTransferCharacteristics(ATC: avifTransferCharacteristics); override;
procedure SetMatrixCoefficients(AMC: avifMatrixCoefficients); override;
procedure SetYuvRange(AYR: avifRange); override;
procedure SetTransformFlags(ATF: avifTransformFlags); override;
procedure SetImirMode(AIM: uint8); override;
end;
TDecoderBase = class
public
procedure Init(aDecoderPtr: Pointer); virtual; abstract;
function GetImage: PavifImage; virtual; abstract;
function GetIo:PavifIO; virtual; abstract;
function GetDecoder:PavifDecoder; virtual; abstract;
function GetSequenceDuration: double; virtual; abstract;
function GetImageCount: longint; virtual; abstract;
function GetImageIndex: longint; virtual; abstract;
function GetImageDurationSeconds: double; virtual; abstract;
function GetImageDurationTimescales: UInt64;virtual; abstract;
function GetRepetitionCount: integer; virtual; abstract;
function GetTimescale: UInt64; virtual; abstract;
procedure SetCodecChoice(ACodec:avifCodecChoice); virtual; abstract;
function GetCodecChoice: avifCodecChoice; virtual; abstract;
end;
{ TDecoder }
generic TDecoder<T> = class(TDecoderBase)
protected
FDecoder: T;
public
constructor Create(aDecoderPtr: Pointer = nil); virtual;
procedure Init(aDecoderPtr: Pointer); override;
function GetImage: PavifImage; override;
function GetIo:PavifIO; override;
function GetDecoder:PavifDecoder; override;
function GetSequenceDuration: double; override;
function GetImageCount: longint; override;
function GetImageIndex: longint; override;
function GetImageDurationSeconds: double; override;
function GetImageDurationTimescales: UInt64; override;
function GetRepetitionCount: integer; override;
function GetTimescale: UInt64; override;
procedure SetCodecChoice(ACodec:avifCodecChoice); override;
function GetCodecChoice: avifCodecChoice; override;
end;
{ TDecoderWithRepetition }
generic TDecoderWithRepetition<T> = class(specialize TDecoder<T>)
constructor Create(aDecoderPtr: Pointer = nil); override;
function GetRepetitionCount: integer; override;
end;
TEncoderBase = class
public
procedure Init(aEncoderPtr: Pointer); virtual; abstract;
procedure SetMaxThreads(AMT: integer); virtual; abstract;
procedure SetSpeed(ASpeed: integer); virtual; abstract;
function GetSpeed: integer; virtual; abstract;
procedure SetQuality(AQuality: integer); virtual; abstract;
function GetQuality: integer; virtual; abstract;
procedure SetQualityAlpha(AQuality: integer); virtual; abstract;
function GetQualityAlpha: integer; virtual; abstract;
function HasQuality: boolean; virtual; abstract;
procedure SetMinQuantizer(AMinQ: integer); virtual; abstract;
procedure SetMaxQuantizer(AMQ: integer); virtual; abstract;
procedure SetMinQuantizerAlpha(AMinQ: integer); virtual; abstract;
procedure SetMaxQuantizerAlpha(AMQ: integer); virtual; abstract;
procedure SetCodecChoice(AMQ: avifCodecChoice); virtual; abstract;
function GetCodecChoice: avifCodecChoice; virtual; abstract;
procedure SetTimescale(aValue:UInt64); virtual; abstract;
function GetTimescale:UInt64; virtual; abstract;
function GetMaxThreads: integer; virtual; abstract;
function GetMinQuantizer: integer; virtual; abstract;
function GetMaxQuantizer: integer; virtual; abstract;
function GetMinQuantizerAlpha: integer; virtual; abstract;
function GetMaxQuantizerAlpha: integer; virtual; abstract;
end;
{ TEncoder }
generic TEncoder<T> = class(TEncoderBase)
protected
FEncoder: T;
public
constructor Create(aEncoderPtr: Pointer = nil); virtual;
procedure Init(aEncoderPtr: Pointer); override;
procedure SetMaxThreads(AMT: integer); override;
procedure SetSpeed(ASpeed: integer); override;
function GetSpeed: integer; override;
procedure SetMinQuantizer(AMinQ: integer); override;
procedure SetMaxQuantizer(AMQ: integer); override;
procedure SetMinQuantizerAlpha(AMinQ: integer); override;
procedure SetMaxQuantizerAlpha(AMQ: integer); override;
procedure SetCodecChoice(ACC: avifCodecChoice); override;
function GetCodecChoice: avifCodecChoice; override;
procedure SetTimescale(aValue:UInt64); override;
function GetTimescale:UInt64; override;
function GetMaxThreads: integer; override;
procedure SetQuality(AQuality: integer); override;
function GetQuality: integer;override;
procedure SetQualityAlpha(AQuality: integer); override;
function GetQualityAlpha: integer; override;
function HasQuality: boolean; override;
function GetMinQuantizer: integer; override;
function GetMaxQuantizer: integer; override;
function GetMinQuantizerAlpha: integer; override;
function GetMaxQuantizerAlpha: integer; override;
end;
{ TEncoderWithQuality }
generic TEncoderWithQuality<T> = class(specialize TEncoder<T>)
constructor Create(aEncoderPtr: Pointer = nil); override;
procedure SetQuality(AQuality: integer); override;
function GetQuality: integer;override;
procedure SetQualityAlpha(AQuality: integer); override;
function GetQualityAlpha: integer; override;
function HasQuality: boolean; override;
end;
TAvifRGBImageBase = class
public
function GetRgbImage: PavifRGBImage; virtual; abstract;
function GetWidth:UInt32; virtual; abstract;
function GetHeight:UInt32; virtual; abstract;
procedure SetWidth(aWidth:UInt32); virtual; abstract;
procedure SetHeight(aHeight:UInt32); virtual; abstract;
procedure SetPixels(aPixels: PUInt8); virtual; abstract;
procedure SetDepth(aDepth:UInt32); virtual; abstract;
procedure SetFormat(aFormat:avifRGBFormat); virtual; abstract;
procedure SetRowBytes(aRowBytes : UInt32); virtual; abstract;
procedure SetIgnoreAlpha(AIgnoreAlpha : avifBool); virtual; abstract;
procedure SetAlphaPremultiplied(aValue:avifBool);virtual; abstract;
end;
TAvifRGBImageField = record
case integer of
0: (rgb0_8: avifRGBImage0_8_4);
1: (rgb0_10: avifRGBImage0_10_0);
2: (rgb0_11: avifRGBImage0_11_0);
3: (rgb1_00: avifRGBImage1_0_0);
end;
{ TAvifRGBImage }
generic TAvifRGBImage<T> = class(TAvifRGBImageBase)
protected
wrgb: TAvifRGBImageField;
FImage: T;
public
constructor Create;
function GetRgbImage: PavifRGBImage; override;
function GetWidth:UInt32; override;
function GetHeight:UInt32; override;
procedure SetWidth(aWidth:UInt32); override;
procedure SetHeight(aHeight:UInt32); override;
procedure SetPixels(aPixels: PUInt8); override;
procedure SetDepth(aDepth:UInt32); override;
procedure SetFormat(aFormat:avifRGBFormat); override;
procedure SetRowBytes(aRowBytes : UInt32); override;
procedure SetIgnoreAlpha(AIgnoreAlpha : avifBool); override;
procedure SetAlphaPremultiplied(aValue:avifBool);override;
end;
function TAvifImageFactory(aImagePtr: Pointer): TAvifImageBase;
begin
if AVIF_VERSION >= AVIF_VERSION_1_0_0 then
Result := specialize TAvifImage<PavifImage1_0_0>.Create(aImagePtr)
else if AVIF_VERSION >= AVIF_VERSION_0_11_0 then
Result := specialize TAvifImage<PavifImage0_11_0>.Create(aImagePtr)
else
Result := specialize TAvifImage<PavifImage0_8_4>.Create(aImagePtr);
end;
function TDecoderFactory(aDecoderPtr: Pointer): TDecoderBase;
begin
if AVIF_VERSION >= AVIF_VERSION_1_0_0 then
result := specialize TDecoderWithRepetition<PAvifDecoder1_0_0>.Create(aDecoderPtr)
else if AVIF_VERSION >= AVIF_VERSION_0_11_0 then
result := specialize TDecoder<PAvifDecoder0_11_0>.Create(aDecoderPtr)
else if AVIF_VERSION >= AVIF_VERSION_0_10_0 then
result := specialize TDecoder<PAvifDecoder0_10_0>.Create(aDecoderPtr)
else if AVIF_VERSION >= AVIF_VERSION_0_9_3 then
result := specialize TDecoder<PAvifDecoder0_9_3>.Create(aDecoderPtr)
else if AVIF_VERSION >= AVIF_VERSION_0_9_2 then
result := specialize TDecoder<PAvifDecoder0_9_2>.Create(aDecoderPtr)
else
result := specialize TDecoder<PAvifDecoder0_8_4>.Create(aDecoderPtr);
end;
function TEncoderFactory(aEncoderPtr: Pointer): TEncoderBase;
begin
if AVIF_VERSION >= AVIF_VERSION_1_0_0 then
result:=specialize TEncoderWithQuality<PAvifEncoder1_0_0>.Create(aEncoderPtr)
else if AVIF_VERSION >= AVIF_VERSION_0_11_0 then
result:=specialize TEncoder<PAvifEncoder0_11_0>.Create(aEncoderPtr)
else
result:=specialize TEncoder<PAvifEncoder>.Create(aEncoderPtr);
end;
function TAvifRGBImageFactory(): TAvifRGBImageBase;
begin
if AVIF_VERSION >= AVIF_VERSION_1_0_0 then
result:=specialize TAvifRGBImage<PavifRGBImage1_0_0>.Create
else if AVIF_VERSION >= AVIF_VERSION_0_11_0 then
result:=specialize TAvifRGBImage<PavifRGBImage0_11_0>.Create
else if AVIF_VERSION >= AVIF_VERSION_0_10_0 then
result:=specialize TAvifRGBImage<PavifRGBImage0_10_0>.Create
else
result:=specialize TAvifRGBImage<PavifRGBImage0_8_4>.Create;
end;
{ TDecoderWithRepetition }
constructor TDecoderWithRepetition.Create(aDecoderPtr: Pointer);
begin
inherited Create(aDecoderPtr);
end;
function TDecoderWithRepetition.GetRepetitionCount: integer;
begin
result := FDecoder^.repetitionCount;
end;
{ TEncoderWithQuality }
constructor TEncoderWithQuality.Create(aEncoderPtr: Pointer);
begin
inherited Create(aEncoderPtr);
end;
procedure TEncoderWithQuality.SetQuality(AQuality: integer);
begin
FEncoder^.quality := AQuality;
end;
function TEncoderWithQuality.GetQuality: integer;
begin
result := FEncoder^.quality;
end;
procedure TEncoderWithQuality.SetQualityAlpha(AQuality: integer);
begin
FEncoder^.qualityAlpha := AQuality;
end;
function TEncoderWithQuality.GetQualityAlpha: integer;
begin
result := FEncoder^.qualityAlpha;
end;
function TEncoderWithQuality.HasQuality: boolean;
begin
Result:= true;
end;
constructor TDecoder.Create(aDecoderPtr:Pointer);
begin
Init(aDecoderPtr);
end;
procedure TDecoder.Init(aDecoderPtr:Pointer);
begin
FDecoder:=T(aDecoderPtr);
end;
function TDecoder.GetImage:PavifImage;
begin
result := FDecoder^.image;
end;
function TDecoder.GetIo:PavifIO;
begin
result := FDecoder^.io;
end;
function TDecoder.GetDecoder:PavifDecoder;
begin
result := FDecoder;
end;
function TDecoder.GetImageIndex:longint;
begin
result := FDecoder^.imageIndex;
end;
function TDecoder.GetImageDurationSeconds: double;
begin
result := FDecoder^.imageTiming.duration;
end;
function TDecoder.GetImageDurationTimescales: UInt64;
begin
result := FDecoder^.imageTiming.durationInTimescales;
end;
function TDecoder.GetRepetitionCount: integer;
begin
result := 0;
end;
function TDecoder.GetTimescale: UInt64;
begin
result := FDecoder^.timescale;
end;
procedure TDecoder.SetCodecChoice(ACodec: avifCodecChoice);
begin
FDecoder^.codecChoice := ACodec;
end;
function TDecoder.GetCodecChoice: avifCodecChoice;
begin
result := FDecoder^.codecChoice;
end;
function TDecoder.GetImageCount:longint;
begin
result := FDecoder^.imageCount;
end;
function TDecoder.GetSequenceDuration:double;
begin
result := FDecoder^.duration;
end;
constructor TAvifRGBImage.Create;
begin
wrgb := Default(TAvifRGBImageField);
FImage:= T(@wrgb);
end;
function TAvifRGBImage.GetRgbImage: PavifRGBImage;
begin
result := FImage;
end;
function TAvifRGBImage.GetWidth:UInt32;
begin
result := FImage^.width;
end;
function TAvifRGBImage.GetHeight:UInt32;
begin
result := FImage^.height;
end;
procedure TAvifRGBImage.SetWidth(aWidth:UInt32);
begin
FImage^.width:=aWidth;
end;
procedure TAvifRGBImage.SetHeight(aHeight:UInt32);
begin
FImage^.height:=aHeight;
end;
procedure TAvifRGBImage.SetPixels(aPixels:PUInt8);
begin
FImage^.pixels:=aPixels;
end;
procedure TAvifRGBImage.SetDepth(aDepth:UInt32);
begin
FImage^.depth:=aDepth;
end;
procedure TAvifRGBImage.SetFormat(aFormat:avifRGBFormat);
begin
FImage^.format:=aFormat;
end;
procedure TAvifRGBImage.SetRowBytes(aRowBytes:UInt32);
begin
FImage^.rowBytes:=aRowBytes;
end;
procedure TAvifRGBImage.SetIgnoreAlpha(AIgnoreAlpha:avifBool);
begin
FImage^.ignoreAlpha:=aIgnoreAlpha;
end;
procedure TAvifRGBImage.SetAlphaPremultiplied(aValue: avifBool);
begin
FImage^.alphaPremultiplied:=aVAlue;
end;
constructor TEncoder.Create(aEncoderPtr: Pointer);
begin
Init(aEncoderPtr);
end;
procedure TEncoder.Init(aEncoderPtr: Pointer);
begin
FEncoder := T(aEncoderPtr);
end;
procedure TEncoder.SetMaxThreads(AMT: integer);
begin
FEncoder^.maxThreads := AMT;
end;
procedure TEncoder.SetSpeed(ASpeed: integer);
begin
FEncoder^.speed := ASpeed;
end;
function TEncoder.GetSpeed: integer;
begin
result := FEncoder^.speed;
end;
procedure TEncoder.SetMinQuantizer(AMinQ: integer);
begin
FEncoder^.minQuantizer := AMinQ;
end;
procedure TEncoder.SetMaxQuantizer(AMQ: integer);
begin
FEncoder^.maxQuantizer := AMQ;
end;
procedure TEncoder.SetMinQuantizerAlpha(AMinQ: integer);
begin
FEncoder^.minQuantizerAlpha := AMinQ;
end;
procedure TEncoder.SetMaxQuantizerAlpha(AMQ: integer);
begin
FEncoder^.maxQuantizerAlpha := AMQ;
end;
procedure TEncoder.SetCodecChoice(ACC: avifCodecChoice);
begin
FEncoder^.codecChoice := ACC;
end;
function TEncoder.GetCodecChoice: avifCodecChoice;
begin
result := FEncoder^.codecChoice;
end;
procedure TEncoder.SetTimescale(aValue: UInt64);
begin
FEncoder^.timescale:=aValue;
end;
function TEncoder.GetTimescale: UInt64;
begin
result := FEncoder^.timescale;
end;
function TEncoder.GetMaxThreads: integer;
begin
result:= FEncoder^.maxThreads;
end;
procedure TEncoder.SetQuality(AQuality: integer);
begin
raise EAvifException.Create('Quality not available in this version of libavif');
end;
function TEncoder.GetQuality: integer;
begin
result := 0;
raise EAvifException.Create('Quality not available in this version of libavif');
end;
procedure TEncoder.SetQualityAlpha(AQuality: integer);
begin
raise EAvifException.Create('Quality not available in this version of libavif');
end;
function TEncoder.GetQualityAlpha: integer;
begin
result := 0;
raise EAvifException.Create('Quality not available in this version of libavif');
end;
function TEncoder.HasQuality: boolean;
begin
result := false;
end;
function TEncoder.GetMinQuantizer: integer;
begin
result:=FEncoder^.minQuantizer;
end;
function TEncoder.GetMaxQuantizer: integer;
begin
result:=FEncoder^.maxQuantizer;
end;
function TEncoder.GetMinQuantizerAlpha: integer;
begin
result:=FEncoder^.minQuantizerAlpha;
end;
function TEncoder.GetMaxQuantizerAlpha: integer;
begin
result:=FEncoder^.maxQuantizerAlpha;
end;
constructor TAvifImage.Create(aImagePtr: Pointer);
begin
Init(aImagePtr);
end;
procedure TAvifImage.Init(aImagePtr: Pointer);
begin
FImage := T(aImagePtr);
end;
function TAvifImage.GetTransformFlags: longword;
begin
Result := FImage^.transformFlags;
end;
function TAvifImage.GetImirMode: uint8;
begin
Result := FImage^.imir.mode;
end;
procedure TAvifImage.SetColorPrimaries(AColorPrimaries: avifColorPrimaries);
begin
FImage^.colorPrimaries := AColorPrimaries;
end;
procedure TAvifImage.SetTransferCharacteristics(ATC: avifTransferCharacteristics);
begin
FImage^.transferCharacteristics := ATC;
end;
procedure TAvifImage.SetMatrixCoefficients(AMC: avifMatrixCoefficients);
begin
FImage^.matrixCoefficients := AMC;
end;
procedure TAvifImage.SetYuvRange(AYR: avifRange);
begin
FImage^.yuvRange := AYR;
end;
procedure TAvifImage.SetTransformFlags(ATF: avifTransformFlags);
begin
FImage^.transformFlags := ATF;
end;
procedure TAvifImage.SetImirMode(AIM: uint8);
begin
FImage^.imir.mode := AIM;
end;
//aBuffer 12 first bytes of file.
function AvifValidateHeaderSignature(aBuffer: Pointer): boolean;
begin
if CompareMem(aBuffer + 4, pansichar('ftyp'), 4) then
begin
if CompareMem(aBuffer + 8, pansichar('avif'), 4) then
exit(True);
if CompareMem(aBuffer + 8, pansichar('avis'), 4) then
exit(True);
if CompareMem(aBuffer + 8, pansichar('mif1'), 4) then
exit(True);
end;
Result := False;
end;
function avifIOStreamReaderRead(io: PavifIO; readFlags: uint32; offset: uint64; size: size_type; output: PavifROData): avifResult; cdecl;
var
reader: PavifIOStreamReader;
availableSize: uint64;
bytesRead: size_type;
begin
if readFlags <> 0 then
exit(AVIF_RESULT_IO_ERROR); // Unsupported readFlags
reader := PavifIOStreamReader(io);
// Sanitize/clamp incoming request
if offset > reader^.io.sizeHint then
exit(AVIF_RESULT_IO_ERROR); // The offset is past the EOF.
availableSize := reader^.io.sizeHint - offset;
if size > availableSize then
size := availableSize;
if size > 0 then
begin
if (offset > MaxLongInt) then
exit(AVIF_RESULT_IO_ERROR);
if reader^.buffer.size < size then
avifRWDataRealloc(@reader^.buffer, size);
if (reader^.Stream.Seek(offset, soFromBeginning) <> offset) then
exit(AVIF_RESULT_IO_ERROR);
bytesRead := reader^.Stream.Read(reader^.buffer.Data^, size);
if size <> bytesRead then
size := bytesRead;
end;
output^.Data := reader^.buffer.Data;
output^.size := size;
exit(AVIF_RESULT_OK);
end;
procedure avifIOStreamReaderDestroy(io: PavifIO); cdecl;
var
reader: PavifIOStreamReader;
begin
reader := PavifIOStreamReader(io);
avifRWDataFree(@reader^.buffer);
avifFree(io);
end;
function avifIOCreateStreamReader(aStream: TStream): PavifIO; cdecl;
var
reader: PavifIOStreamReader;
filesize: longint;
begin
filesize := aStream.Size;
//aStream.Position:=0;
reader := avifAlloc(sizeof(avifIOStreamReader));
FillChar(reader^, sizeof(avifIOStreamReader), 0);
reader^.Stream := aStream;
reader^.io.Destroy := @avifIOStreamReaderDestroy;
reader^.io.Read := @avifIOStreamReaderRead;
reader^.io.sizeHint := fileSize;
reader^.io.persistent := AVIF_FALSE;
avifRWDataRealloc(@reader^.buffer, 1024);
exit(PavifIO(reader));
end;
function avifDecoderSetIOStream(decoderWrap: TDecoderBase; aStream: TStream): avifResult; cdecl;
var
io: PavifIO;
begin
io := avifIOCreateStreamReader(aStream);
if io = nil then
exit(AVIF_RESULT_IO_ERROR);
avifDecoderSetIO(decoderWrap.GetDecoder, io);
if decoderWrap.GetIo = nil then
raise EAvifException.Create('Failed to set input. Could be due to incompatible version of AVIF library.');
exit(AVIF_RESULT_OK);
end;
procedure AvifImageToBGRABitmap(aAvifImage:PAvifImage; aBitmap: TBGRACustomBitmap);
var
res: avifResult;
imageWrap: TAvifImageBase;
rgbImageWrap: TAvifRgbImageBase;
sourceLineOrder: TRawImageLineOrder;
begin
imageWrap:=nil;
rgbImageWrap:=nil;
try
rgbImageWrap:=TAvifRgbImageFactory();
imageWrap:=TAvifImageFactory(aAvifImage);
avifRGBImageSetDefaults(rgbImageWrap.GetRgbImage, aAvifImage);
//aBitmap.LineOrder:=riloTopToBottom;
aBitmap.SetSize(rgbImageWrap.GetWidth, rgbImageWrap.GetHeight);
rgbImageWrap.SetPixels(PUint8(aBitmap.databyte));
rgbImageWrap.SetDepth(8);
{$push}{$warn 6018 off}//unreachable code
if TBGRAPixel_RGBAOrder then
rgbImageWrap.SetFormat(AVIF_RGB_FORMAT_RGBA)
else
rgbImageWrap.SetFormat(AVIF_RGB_FORMAT_BGRA);
{$pop}
rgbImageWrap.SetRowBytes(rgbImageWrap.GetWidth * 4);
//if aBitmap.LineOrder<>riloTopToBottom then
//begin
// decoder^.image^.transformFlags:=decoder^.image^.transformFlags + Uint32(AVIF_TRANSFORM_IMIR);
// decoder^.image^.imir.mode:=0;
//end;
//decoder^.image^.imir.axis:=0; //vertical mirror
res := avifImageYUVToRGB(aAvifImage, rgbImageWrap.GetRgbImage);
if res <> AVIF_RESULT_OK then
raise EAvifException.Create('Avif Error: ' + avifResultToString(res));
if ( (imageWrap.GetTransformFlags and longword(AVIF_TRANSFORM_IMIR)) <> 0) and
(imageWrap.GetImirMode = 0) then
sourceLineOrder := riloBottomToTop
else sourceLineOrder := riloTopToBottom;
if aBitmap.LineOrder <> sourceLineOrder then
aBitmap.VerticalFlip;
aBitmap.InvalidateBitmap;
finally
imageWrap.Free;
rgbImageWrap.Free;
end;
end;
procedure AvifDecode(decoderWrap: TDecoderBase; aBitmap: TBGRACustomBitmap);
var
res: avifResult;
image:PAvifImage;
begin
res := avifDecoderParse(decoderWrap.GetDecoder);
if res <> AVIF_RESULT_OK then
raise EAvifException.Create('Avif Error: ' + avifResultToString(res));
// Memo1.Lines.Add(Format('Parsed AVIF: %ux%u (%ubpc)', [decoder^.image^.Width, decoder^.image^.Height, decoder^.image^.depth]));
res := avifDecoderNextImage(decoderWrap.GetDecoder);
if res = AVIF_RESULT_OK then
begin
image := decoderWrap.GetImage;
if image = nil then
raise EAvifException.Create('No image data recieved from AVIF library.');
AvifImageToBGRABitmap(image,aBitmap);
end
else
raise EAvifException.Create('Avif Error: ' + avifResultToString(res));
end;
procedure AvifLoadFromStream(AStream: TStream; aBitmap: TBGRACustomBitmap);
var
decoder: PavifDecoder;
res: avifResult;
decoderWrap: TDecoderBase;
begin
decoderWrap:= nil;
decoder := TAvifReader.CreateDecoder;
try
decoderWrap:=TDecoderFactory(decoder);
// Override decoder defaults here (codecChoice, requestedSource, ignoreExif, ignoreXMP, etc)
//decoder^.maxThreads := 1;
// decoder^.codecChoice := AVIF_CODEC_CHOICE_AUTO;
// decoder^.imageSizeLimit := AVIF_DEFAULT_IMAGE_SIZE_LIMIT;
// decoder^.strictFlags := UInt32( AVIF_STRICT_ENABLED);
// decoder^.allowProgressive := AVIF_FALSE;
res := avifDecoderSetIOStream(decoderWrap, aStream);
if res = AVIF_RESULT_OK then
AvifDecode(decoderWrap, aBitmap)
else
raise EAvifException.Create('Avif Error: ' + avifResultToString(res));
finally
decoderWrap.Free;
TAvifReader.DestroyDecoder(decoder);
end;
end;
procedure AvifLoadFromFile(const AFilename: string; aBitmap: TBGRACustomBitmap);
var
Stream: TFileStream;
begin
Stream := TFileStream.Create(AFileName, fmOpenRead);
try
AvifLoadFromStream(Stream,aBitmap);
finally
Stream.Free;
end;
end;
procedure AvifLoadFromFileNative(const AFilename: string; aBitmap: TBGRACustomBitmap);
var
decoder: PavifDecoder;
res: avifResult;
decoderWrap: TDecoderBase;
begin
decoderWrap := nil;
decoder := TAvifReader.CreateDecoder;
try
decoderWrap:=TDecoderFactory(decoder);
// Override decoder defaults here (codecChoice, requestedSource, ignoreExif, ignoreXMP, etc)
//decoder^.maxThreads := 1;
// decoder^.codecChoice := AVIF_CODEC_CHOICE_AUTO;
// decoder^.imageSizeLimit := AVIF_DEFAULT_IMAGE_SIZE_LIMIT;
// decoder^.strictFlags := UInt32( AVIF_STRICT_ENABLED);
// decoder^.allowProgressive := AVIF_FALSE;
res := avifDecoderSetIOFile(decoder, pansichar(AFilename));
if res = AVIF_RESULT_OK then
AvifDecode(decoderWrap, aBitmap)
else
raise EAvifException.Create('Avif Error: ' + avifResultToString(res));
finally
decoderWrap.Free;
TAvifReader.DestroyDecoder(decoder);
end;
end;
procedure AvifLoadFromMemory(AData: Pointer; ASize: cardinal; aBitmap: TBGRACustomBitmap);
var
decoder: PavifDecoder;
res: avifResult;
decoderWrap: TDecoderBase;
begin
decoderWrap := nil;
decoder := TAvifReader.CreateDecoder;
try
decoderWrap:= TDecoderFactory(decoder);
// Override decoder defaults here (codecChoice, requestedSource, ignoreExif, ignoreXMP, etc)
//decoder^.maxThreads := 1;
// decoder^.codecChoice := AVIF_CODEC_CHOICE_AUTO;
// decoder^.imageSizeLimit := AVIF_DEFAULT_IMAGE_SIZE_LIMIT;
// decoder^.strictFlags := UInt32( AVIF_STRICT_ENABLED);
// decoder^.allowProgressive := AVIF_FALSE;
res := avifDecoderSetIOMemory(decoder, AData, ASize);
if res = AVIF_RESULT_OK then
AvifDecode(decoderWrap, aBitmap)
else
raise EAvifException.Create('Avif Error: ' + avifResultToString(res));
finally
decoderWrap.Free;
TAvifReader.DestroyDecoder(decoder);
end;
end;
function Interpolate(x: double; x1, x2: double; v1, v2: double): double;
begin
Result := v1 + (((v2 - v1) / (x2 - x1)) * (x - x1));
end;
function clamp(aValue:integer;aMin:integer;aMax:integer):integer;
begin
result:=aValue;
if result<aMin then
result:=aMin;
if result>aMax then
result:=aMax;
end;
//https://github.com/AOMediaCodec/libavif/issues/545
//https://gitmemory.com/issue/AOMediaCodec/libavif/545/802934788
// aQuality0to100 0 worst quality, 100 best quality ( lossless ).
function AvifSaveToFile(aBitmap: TBGRACustomBitmap; const AFilename: string;
aQuality0to100: integer; aSpeed0to10: integer; aPixelFormat: avifPixelFormat;
aIgnoreAlpha: boolean): NativeUInt;
var
writer: TAvifWriter;
begin
Result := 0;
writer := TAvifWriter.Create( aQuality0to100, aSpeed0to10, aPixelFormat, aIgnoreAlpha);
try
writer.OnlyOneImage := True;
writer.AddImage(aBitmap, 0);
Result := writer.SaveToFile(AFileName);
finally
writer.Free;
end;
end;
function AvifSaveToStream(aBitmap: TBGRACustomBitmap; AStream: TStream;
aQuality0to100: integer; aSpeed0to10: integer; aPixelFormat: avifPixelFormat;
aIgnoreAlpha: boolean): NativeUInt;
var
writer: TAvifWriter;
begin
Result := 0;
writer := TAvifWriter.Create(aQuality0to100, aSpeed0to10, aPixelFormat, aIgnoreAlpha);
try
writer.OnlyOneImage := True;
writer.AddImage(aBitmap, 0);
Result := writer.SaveToStream(AStream);
finally
writer.Free;
end;
end;
//returns the size of the resulting bitmap.
function AvifSaveToMemory(aBitmap: TBGRACustomBitmap; AData: Pointer; ASize: cardinal; aQuality0to100: integer;aSpeed0to10:integer;aPixelFormat:avifPixelFormat;aIgnoreAlpha:boolean): NativeUInt;
var
writer:TAvifWriter;
begin
result:=0;
writer:=TAvifWriter.Create(aQuality0to100, aSpeed0to10, aPixelFormat, aIgnoreAlpha);
try
writer.OnlyOneImage := True;
writer.AddImage(aBitmap,0);
result:=writer.SaveToMemory(AData, ASize);
finally
writer.Free;
end;
end;
function AvifSaveToStream(ABitmap: TBGRACustomBitmap; AStream: TStream;
AIgnoreAlpha: boolean; AQuality0to100: integer; AQualityAlpha0to100: integer;
APixelFormat: avifPixelFormat; ACodec: avifCodecChoice; ASpeed0to10: integer
): nativeuint;
var
writer: TAvifWriter;
begin
Result := 0;
writer := TAvifWriter.Create( AQuality0to100, ASpeed0to10, APixelFormat, AIgnoreAlpha);
try
writer.Encoder := ACodec;
writer.OnlyOneImage := True;
writer.SetQuality(AQuality0to100);
writer.SetQualityAlpha(AQualityAlpha0to100);
writer.AddImage(aBitmap, 0);
Result := writer.SaveToStream(AStream);
finally
writer.Free;
end;
end;
function AvifSaveToFile(ABitmap: TBGRACustomBitmap; const AFilename: string;
AIgnoreAlpha: boolean; AQuality0to100: integer; AQualityAlpha0to100: integer;
APixelFormat: avifPixelFormat; ACodec: avifCodecChoice; ASpeed0to10: integer
): nativeuint;
var
writer: TAvifWriter;
begin
Result := 0;
writer := TAvifWriter.Create( AQuality0to100, ASpeed0to10, APixelFormat, AIgnoreAlpha);
try
writer.Encoder := ACodec;
writer.MaxThreads := 16;
writer.OnlyOneImage := True;
writer.SetQuality(AQuality0to100);
writer.SetQualityAlpha(AQualityAlpha0to100);
writer.AddImage(ABitmap, 0);
Result := writer.SaveToFile(AFileName);
finally
writer.Free;
end;
end;
function AvifSaveToMemory(ABitmap: TBGRACustomBitmap; AData: Pointer;
ASize: nativeuint; AIgnoreAlpha: boolean; AQuality0to100: integer;
AQualityAlpha0to100: integer; APixelFormat: avifPixelFormat;
ACodec: avifCodecChoice; ASpeed0to10: integer): nativeuint;
var
writer: TAvifWriter;
begin
Result := 0;
writer := TAvifWriter.Create( AQuality0to100, ASpeed0to10, APixelFormat, AIgnoreAlpha);
try
writer.Encoder := ACodec;
writer.OnlyOneImage := True;
writer.SetQuality(AQuality0to100);
writer.SetQualityAlpha(AQualityAlpha0to100);
writer.AddImage(ABitmap, 0);
Result := writer.SaveToMemory(AData,ASize);
finally
writer.Free;
end;
end;
{ TAvifReader }
constructor TAvifReader.Create(AFileName: string);
begin
Init(TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite), true);
end;
constructor TAvifReader.Create(AStream: TStream; AStreamOwned: boolean);
begin
Init(AStream, AStreamOwned);
end;
function TAvifReader.GetImageCount: uint32;
begin
result := TDecoderBase(FDecoderWrap).GetImageCount;
end;
function TAvifReader.GetImageIndex: integer;
begin
result := TDecoderBase(FDecoderWrap).GetImageIndex;
end;
function TAvifReader.GetRepetitionCount: integer;
begin
result := TDecoderBase(FDecoderWrap).GetRepetitionCount;
end;
function TAvifReader.GetSequenceDuration: double;
begin
result := TDecoderBase(FDecoderWrap).GetSequenceDuration;
end;
function TAvifReader.GetTimescale: uint64;
begin
result := TDecoderBase(FDecoderWrap).GetTimescale;
end;
procedure TAvifReader.Init(AStream: TStream; AStreamOwned: boolean);
var
res: avifResult;
lDecoderWrap : TDecoderBase;
begin
FStream := AStream;
FStreamOwned:= AStreamOwned;
FDecoder := CreateDecoder;
lDecoderWrap := TDecoderFactory(FDecoder);
FDecoderWrap := lDecoderWrap;
res := avifDecoderSetIOStream(lDecoderWrap, AStream);
if res = AVIF_RESULT_OK then
res := avifDecoderParse(lDecoderWrap.GetDecoder);
if res <> AVIF_RESULT_OK then
begin
Close;
raise EAvifException.Create('Avif Error: ' + avifResultToString(res));
end;
end;
procedure TAvifReader.Close;
begin
DestroyDecoder(FDecoder);
FreeAndNil(FDecoderWrap);
if FStreamOwned then
FreeAndNil(FStream)
else
FStream := nil;
end;
destructor TAvifReader.Destroy;
begin
Close;
inherited Destroy;
end;
class function TAvifReader.CreateDecoder: PavifDecoder;
begin
result := nil;
if not LibAvifLoad then
raise EAvifException.Create('Cannot load libavif');
try
result := avifDecoderCreate();
finally
if not Assigned(result) then
LibAvifUnload;
end;
if not Assigned(result) then
raise EOutOfMemory.Create('Memory allocation failure');
end;
class procedure TAvifReader.DestroyDecoder(var ADecoder: PavifDecoder);
begin
if not Assigned(ADecoder) then exit;
avifDecoderDestroy(ADecoder);
ADecoder := nil;
LibAvifUnload;
end;
function TAvifReader.GetNextImage(AOutBitmap: TBGRACustomBitmap): boolean;
var
image: PAvifImage;
res: avifResult;
begin
Result := False;
FImageDurationSeconds := 0;
FImageDurationTimescales := 0;
if (AOutBitmap = nil) or (ImageIndex >= (ImageCount - 1)) then
Exit;
res := avifDecoderNextImage(TDecoderBase(FDecoderWrap).GetDecoder);
if res = AVIF_RESULT_OK then
begin
image := TDecoderBase(FDecoderWrap).GetImage;
if image = nil then
raise EAvifException.Create('No image data recieved from AVIF library.');
AvifImageToBGRABitmap(image, aOutBitmap);
FImageDurationSeconds := TDecoderBase(FDecoderWrap).GetImageDurationSeconds;
FImageDurationTimescales := TDecoderBase(FDecoderWrap).GetImageDurationTimescales;
if ImageIndex = 0 then
begin
FWidth := aOutBitmap.Width;
FHeight := aOutBitmap.Height;
end;
Result := True;
end
else
raise EAvifException.Create('Avif Error: ' + avifResultToString(res));
end;
function TAvifReader.GetNthImage(AOutBitmap: TBGRACustomBitmap;
AImageIndex: uint32): boolean;
var
image: PAvifImage;
res: avifResult;
begin
Result := False;
FImageDurationSeconds := 0;
FImageDurationTimescales := 0;
if (AOutBitmap = nil) or (aImageIndex >= ImageCount) then
Exit;
res := avifDecoderNthImage(TDecoderBase(FDecoderWrap).GetDecoder, aImageIndex);
if res = AVIF_RESULT_OK then
begin
image := TDecoderBase(FDecoderWrap).GetImage;
if image = nil then
raise EAvifException.Create('No image data recieved from AVIF library.');
AvifImageToBGRABitmap(image, aOutBitmap);
FImageDurationSeconds := TDecoderBase(FDecoderWrap).GetImageDurationSeconds;
FImageDurationTimescales := TDecoderBase(FDecoderWrap).GetImageDurationTimescales;
if ImageIndex = 0 then
begin
FWidth := aOutBitmap.Width;
FHeight := aOutBitmap.Height;
end;
Result := True;
end
else
raise EAvifException.Create('Avif Error: ' + avifResultToString(res));
end;
procedure TAvifReader.SetDecoder(ACodec: avifCodecChoice);
begin
if Assigned(FDecoderWrap) then
TDecoderBase(FDecoderWrap).SetCodecChoice(ACodec);
end;
function TAvifReader.GetDecoder: avifCodecChoice;
begin
if Assigned(FDecoderWrap) then
result := TDecoderBase(FDecoderWrap).GetCodecChoice
else
result := AVIF_CODEC_CHOICE_AUTO;
end;
{ TAvifWriter }
constructor TAvifWriter.Create(AQuality0to100: integer; ASpeed0to10: integer;
APixelFormat: avifPixelFormat; AIgnoreAlpha: boolean);
var
alpha_quantizer, min_quantizer, max_quantizer: integer;
lEncoderWrap: TEncoderBase;
const
AVIF_BGRA_LOSSLESS_QUALITY = 100;
begin
FAvifOutput := AVIF_DATA_EMPTY;
FEncoder := CreateEncoder;
if FEncoder = nil then
raise EAvifException.Create('Avif Error: creating encoder');
FEncoderWrap := TEncoderFactory(FEncoder);
lEncoderWrap := TEncoderBase(FEncoderWrap);
FPixelFormat := APixelFormat;
IgnoreAlpha := AIgnoreAlpha;
// specifying max quality is a shorthand for lossless quality
if AQuality0to100 = AVIF_BGRA_LOSSLESS_QUALITY then
Lossless := true
else
begin
Quality := AQuality0to100;
QualityAlpha := AQuality0to100 + AVIF_BGRA_DEFAULT_QUALITY_ALPHA_DELTA;
end;
Timescale := AVIF_BGRA_DEFAULT_TIMESCALE;
MaxThreads := AVIF_BGRA_DEFAULT_MAX_THREADS;
Speed := ASpeed0to10;
Encoder := AVIF_BGRA_CODEC_CHOICE_AUTO;
// * tileRowsLog2
// * tileColsLog2
// * keyframeInterval
end;
procedure TAvifWriter.Close;
begin
EncoderFinish;
end;
function TAvifWriter.GetLossless: boolean;
begin
result := FLossless;
end;
procedure TAvifWriter.SetLossless(AValue: boolean);
begin
FLossless := AValue;
if AValue then
begin
// lossless quality has an effect on quality
// but also indirectly on pixel format and encoder
Quality := AVIF_BGRA_LOSSLESS_QUALITY;
QualityAlpha := AVIF_BGRA_LOSSLESS_QUALITY;
end;
end;
procedure TAvifWriter.EncoderFinish;
var
finishResult: avifResult;
begin
if Assigned(FEncoder) then
begin
try
if FImagesCount > 0 then
begin
finishResult := avifEncoderFinish(FEncoder, @FAvifOutput);
if finishResult <> AVIF_RESULT_OK then
raise EAvifException.Create('Failed to finish encode: ' + avifResultToString(finishResult));
end;
finally
DestroyEncoder(FEncoder);
FreeAndNil(FEncoderWrap);
end;
end;
end;
procedure TAvifWriter.SetMaxThreads(AMT: integer);
begin
if Assigned(FEncoderWrap) then
TEncoderBase(FEncoderWrap).SetMaxThreads(AMT);
end;
procedure TAvifWriter.SetIgnoreAlpha(AValue: boolean);
begin
FIgnoreAlpha := AValue;
end;
function TAvifWriter.GetMaxThreads: integer;
var
lEncoderWrap:TEncoderBase;
begin
if Assigned(FEncoderWrap) then
result:= TEncoderBase(FEncoderWrap).GetMaxThreads
else
result := AVIF_BGRA_DEFAULT_MAX_THREADS;
end;
destructor TAvifWriter.Destroy;
begin
try
EncoderFinish;
finally
if LibAvifLoaded then
avifRWDataFree(@FAvifOutput);
end;
inherited Destroy;
end;
class function TAvifWriter.CreateEncoder: PAvifEncoder;
begin
result := nil;
if not LibAvifLoad then
raise EAvifException.Create('Cannot load libavif');
try
result := avifEncoderCreate();
finally
if not Assigned(result) then
LibAvifUnload;
end;
if not Assigned(result) then
raise EOutOfMemory.Create('Memory allocation failure');
end;
class procedure TAvifWriter.DestroyEncoder(var AEncoder: PAvifEncoder);
begin
if not Assigned(AEncoder) then exit;
avifEncoderDestroy(AEncoder);
AEncoder := nil;
LibAvifUnload;
end;
procedure TAvifWriter.AddImage(ABitmap: TBGRACustomBitmap; ADurationMs: cardinal
);
var
image: PavifImage;
imageWrap: TAvifImageBase;
rgbImageWrap: TAvifRgbImageBase;
convertResult, addImageResult: avifResult;
durationTimescales: uint64;
imageFlags: uint32;
begin
if (FImagesCount > 0) and FOnlyOneImage then
raise EAvifException.Create('Only one image is allowed. ');
rgbImageWrap := nil;
imageWrap := nil;
try
ApplyQuality;
if Lossless then
image := avifImageCreate(ABitmap.Width, ABitmap.Height, 8, AVIF_PIXEL_FORMAT_YUV444)
else
image := avifImageCreate(ABitmap.Width, ABitmap.Height, 8, FPixelFormat{AVIF_PIXEL_FORMAT_YUV420});
imageWrap := TAvifImageFactory(image);
// these values dictate what goes into the final AVIF
// Configure image here: (see avif/avif.h)
// * colorPrimaries
// * transferCharacteristics
// * matrixCoefficients
// * avifImageSetProfileICC()
// * avifImageSetMetadataExif()
// * avifImageSetMetadataXMP()
// * yuvRange
// * alphaRange
// * alphaPremultiplied
// * transforms (transformFlags, pasp, clap, irot, imir)
imageWrap.SetColorPrimaries(AVIF_COLOR_PRIMARIES_BT709);
imageWrap.SetTransferCharacteristics(AVIF_TRANSFER_CHARACTERISTICS_SRGB);
imageWrap.SetMatrixCoefficients(AVIF_MATRIX_COEFFICIENTS_BT601);
// Override RGB(A)->YUV(A) defaults here: depth, format, chromaUpsampling, ignoreAlpha, alphaPremultiplied, libYUVUsage, etc
// Alternative: set rgb.pixels and rgb.rowBytes yourself, which should match your chosen rgb.format
// Be sure to use uint16_t* instead of uint8_t* for rgb.pixels/rgb.rowBytes if (rgb.depth > 8)
rgbImageWrap := TAvifRgbImageFactory();
// If you have RGB(A) data you want to encode, use this path
avifRGBImageSetDefaults(rgbImageWrap.GetRgbImage, image);
rgbImageWrap.SetWidth(ABitmap.Width);
rgbImageWrap.SetHeight(ABitmap.Height);
{$push}{$warn 6018 off}//unreachable code
if TBGRAPixel_RGBAOrder then
rgbImageWrap.SetFormat(AVIF_RGB_FORMAT_RGBA)
else
rgbImageWrap.SetFormat(AVIF_RGB_FORMAT_BGRA);
{$pop}
if FIgnoreAlpha then
rgbImageWrap.SetIgnoreAlpha(AVIF_TRUE)
else
rgbImageWrap.SetIgnoreAlpha(AVIF_FALSE);
rgbImageWrap.SetPixels(ABitmap.DataByte);
rgbImageWrap.SetRowBytes(ABitmap.Width * 4);
if Lossless then
begin
// https://github.com/xiph/rav1e/issues/151
imageWrap.SetYuvRange(AVIF_RANGE_FULL); // avoid limited range
imageWrap.SetMatrixCoefficients(AVIF_MATRIX_COEFFICIENTS_IDENTITY); // this is key for lossless
end;
if aBitmap.LineOrder <> riloTopToBottom then //vertical mirror.
begin
imageWrap.SetTransformFlags(imageWrap.GetTransformFlags + uint32(AVIF_TRANSFORM_IMIR));
imageWrap.SetImirMode(0);
end;
convertResult := avifImageRGBToYUV(image, rgbImageWrap.GetRgbImage);
if convertResult <> AVIF_RESULT_OK then
raise EAvifException.Create('Failed to convert to YUV(A): ' + avifResultToString(convertResult));
if Timescale <> 0 then
durationTimescales := Trunc(((ADurationMs / 1000) * Timescale) + 0.5)
else
durationTimescales := 1;
if durationTimescales < 1 then
durationTimescales := 1;
imageFlags := uint32(AVIF_ADD_IMAGE_FLAG_NONE);
if FOnlyOneImage then
imageFlags := uint32(AVIF_ADD_IMAGE_FLAG_SINGLE);
addImageResult := avifEncoderAddImage(FEncoder, image, durationTimescales, imageFlags);
if addImageResult <> AVIF_RESULT_OK then
raise EAvifException.Create('Failed to add image to encoder: ' + avifResultToString(addImageResult));
Inc(FImagesCount);
finally
if image <> nil then
avifImageDestroy(image);
imageWrap.Free;
rgbImageWrap.Free;
end;
end;
function TAvifWriter.SaveToFile(AFileName: string): NativeUInt;
var
lStream: TFileStream;
begin
Result := 0;
lStream := TFileStream.Create(AFileName, fmCreate or fmShareExclusive);
try
Result := SaveToStream(lStream);
finally
lSTream.Free;
end;
end;
function TAvifWriter.SaveToStream(AStream: TStream): NativeUInt;
var
p: pbyte;
remain, toWrite: longword;
const
CopySize = 65535;
begin
Result := GetOutputSize;
if FAvifOutput.Data <> nil then
begin
//AStream.WriteBuffer(avifOutput.Data^, avifOutput.size)
remain := FAvifOutput.size;
p := FAvifOutput.Data;
while remain > 0 do
begin
if remain > CopySize then
toWrite := CopySize
else
toWrite := remain;
aStream.WriteBuffer(p^, toWrite);
Inc(p, toWrite);
Dec(remain, toWrite);
end;
end;
end;
//returns the size of the resulting bitmap.
function TAvifWriter.SaveToMemory(AData: Pointer; ASize: NativeUInt
): NativeUInt;
begin
Result := GetOutputSize;
if FAvifOutput.Data <> nil then
Move(FAvifOutput.Data^, AData^, min(ASize, FAvifOutput.size));
end;
function TAvifWriter.GetOutputSize: NativeUInt;
begin
EncoderFinish;
Result := FAvifOutput.Size;
end;
procedure TAvifWriter.SetQuality(AValue: integer);
begin
FQuality0to100 := clamp(AValue, AVIF_QUALITY_WORST, AVIF_QUALITY_BEST);
end;
procedure TAvifWriter.SetQualityAlpha(AValue: integer);
begin
FQualityAlpha0to100 := clamp(AValue, AVIF_QUALITY_WORST, AVIF_QUALITY_BEST);
end;
procedure TAvifWriter.SetEncoder(ACodec: avifCodecChoice);
begin
TEncoderBase(FEncoderWrap).SetCodecChoice(ACodec);
end;
function TAvifWriter.GetEncoder: avifCodecChoice;
begin
result := TEncoderBase(FEncoderWrap).GetCodecChoice;
end;
procedure TAvifWriter.SetTimescale(ATimescale: uint64);
begin
if Assigned(FEncoderWrap) then
TEncoderBase(FEncoderWrap).SetTimescale(ATimescale);
end;
function TAvifWriter.GetTimescale: uint64;
begin
if Assigned(FEncoderWrap) then
result := TEncoderBase(FEncoderWrap).GetTimescale
else
result := AVIF_BGRA_DEFAULT_TIMESCALE;
end;
procedure TAvifWriter.SetSpeed(ASpeed: integer);
begin
if ASpeed <> AVIF_SPEED_DEFAULT then
ASpeed := clamp(ASpeed, AVIF_SPEED_SLOWEST, AVIF_SPEED_FASTEST);
if Assigned(FEncoderWrap) then
TEncoderBase(FEncoderWrap).SetSpeed(ASpeed);
end;
function TAvifWriter.GetSpeed: integer;
begin
if Assigned(FEncoderWrap) then
result := TEncoderBase(FEncoderWrap).GetSpeed
else
result := AVIF_SPEED_DEFAULT;
end;
procedure TAvifWriter.ApplyQuality;
procedure QualityToQuantizerMinMax(AQuality: integer; out AMinQuantizer, AMaxQuantizer: integer);
begin
AMaxQuantizer :=
Trunc(Interpolate(AQuality,
AVIF_QUALITY_WORST, AVIF_QUALITY_BEST,
AVIF_QUANTIZER_WORST_QUALITY, AVIF_QUANTIZER_BEST_QUALITY));
if AMaxQuantizer > 20 then
AMinQuantizer := AMaxQuantizer - 20
else
AMinQuantizer := 0;
end;
var minQ, maxQ: integer;
lEncoder : TEncoderBase;
begin
lEncoder := TEncoderBase(FEncoderWrap);
if Lossless and (Encoder = AVIF_CODEC_CHOICE_AUTO) then
Encoder := AVIF_CODEC_CHOICE_AOM;
if lEncoder.HasQuality then
begin
lEncoder.SetQuality(Quality);
lEncoder.SetQualityAlpha(QualityAlpha);
end
else
begin
QualityToQuantizerMinMax(Quality, minQ, maxQ);
lEncoder.SetMinQuantizer(minQ);
lEncoder.SetMaxQuantizer(maxQ);
QualityToQuantizerMinMax(QualityAlpha, minQ, maxQ);
lEncoder.SetMinQuantizerAlpha(minQ);
lEncoder.SetMaxQuantizerAlpha(maxQ);
end;
end;
end.
================================================
FILE: bgrabitmap/basiccolorspace.inc
================================================
// SPDX-License-Identifier: LGPL-3.0-linking-exception
{$IFDEF INCLUDE_INTERFACE}
{$UNDEF INCLUDE_INTERFACE}
type
{* Possible channels in a bitmap using any RGBA colorspace }
TChannel = (cRed, cGreen, cBlue, cAlpha);
{** Combination of channels }
TChannels = set of TChannel;
const
{** Offsets of the different channels in a pixel }
TBGRAPixel_ChannelByteOffset : array[TChannel] of integer =
(TBGRAPixel_RedByteOffset, TBGRAPixel_GreenByteOffset, TBGRAPixel_BlueByteOffset, TBGRAPixel_AlphaByteOffset);
{ Gamma conversion arrays. Should be used as readonly }
var
{* Equivalence for channel from TBGRAPixel to TExpandedPixel }
GammaExpansionTab: packed array[0..255] of word;
{* Equivalence for channel from TBGRAPixel to TExpandedPixel (for value with offset 0.5) }
GammaExpansionTabHalf: packed array[0..254] of word;
{* Equivalence for channel from TExpandedPixel to TBGRAPixel }
GammaCompressionTab : packed array[0..65535] of byte; //rounded value
{* Sets the gamma value used for the sRGB colorspace }
procedure BGRASetGamma(AGamma: single = 1.7);
{* Gets the gamma value used for the sRGB colorspace }
function BGRAGetGamma: single;
type
{* Pointer to a TExpandedPixel }
PExpandedPixel = ^TExpandedPixel;
{* Stores a gamma expanded RGB color. Values range from 0 to 65535 and are linear. }
TExpandedPixel = packed record
red, green, blue, alpha: word;
class function New(const ARed,AGreen,ABlue,AAlpha:word): TExpandedPixel;overload;static;
class function New(const ARed,AGreen,ABlue:word): TExpandedPixel;overload;static;
end;
{** Array of TExpandedPixel to be used as a buffer }
TExpandedPixelBuffer = packed array of TExpandedPixel;
{** Allocate a buffer of TExpandedPixel }
procedure AllocateExpandedPixelBuffer(var ABuffer: TExpandedPixelBuffer; ASize: integer);
{** Converts a pixel from sRGB to gamma expanded RGB }
function GammaExpansion(c: TBGRAPixel): TExpandedPixel; inline;
{** Converts a pixel from gamma expanded RGB to sRGB }
function GammaCompression(const ec: TExpandedPixel): TBGRAPixel; inline; overload;
{** Converts a pixel from gamma expanded RGB to sRGB }
function GammaCompression(red,green,blue,alpha: word): TBGRAPixel; inline; overload;
{** Apply gamma compression with word values }
function GammaCompressionW(AExpanded: word): word;
{** Apply gamma expansion with word values }
function GammaExpansionW(ACompressed: word): word;
{** Returns the intensity of an gamma-expanded pixel. The intensity is the
maximum value reached by any component }
function GetIntensity(const c: TExpandedPixel): word; inline;
{** Sets the intensity of a gamma-expanded pixel }
function SetIntensity(const c: TExpandedPixel; intensity: word): TExpandedPixel;
{** Returns the lightness of an gamma-expanded pixel. The lightness is the
perceived brightness, 0 being black and 65535 being white }
function GetLightness(const c: TExpandedPixel): word; inline; overload;
{** Sets the lightness of a gamma-expanded pixel }
function SetLightness(const c: TExpandedPixel; lightness: word): TExpandedPixel; overload;
{** Sets the lightness of a gamma expanded pixel, provided you already know the current
value of lightness _curLightness_. It is a bit faster than the previous function }
function SetLightness(const c: TExpandedPixel; lightness: word; curLightness: word): TExpandedPixel; overload;
{** Returns the importance of the color. It is similar to saturation
in HSL colorspace, except it is gamma corrected. A value of zero indicates
a black/gray/white, and a value of 65535 indicates a bright color }
function ColorImportance(ec: TExpandedPixel): word;
{** Merge two gamma expanded pixels (implicit gamma correction) }
function MergeBGRA(ec1, ec2: TExpandedPixel): TExpandedPixel; overload;
{** Merge two gamma expanded pixels with the given weights }
function MergeBGRA(ec1: TExpandedPixel; weight1: integer; ec2: TExpandedPixel; weight2: integer): TExpandedPixel; overload;
{** Computes the difference (with gamma correction) between two pixels,
taking into account all dimensions, including transparency. The
result ranges from 0 to 65535 }
function ExpandedDiff(ec1, ec2: TExpandedPixel): word;
{** Converts from TFPColor to TExpandedPixel (with gamma expansion by default) }
function FPColorToExpanded(AColor: TFPColor; AGammaExpansion: boolean=true): TExpandedPixel;
{** Converts from TExpandedPixel to TFPColor (with gamma compression by default) }
function ExpandedToFPColor(AExpanded: TExpandedPixel; AGammaCompression: boolean=true): TFPColor;
type
{* General purpose color variable with single-precision floating point values.
It can be linear like TExpandedPixel or not, like TBGRAPixel. }
TColorF = packed array[1..4] of single;
{** Array of TColorF }
ArrayOfTColorF = array of TColorF;
{** Creates a TColorF structure }
function ColorF(red,green,blue,alpha: single): TColorF;
{** Creates a TColorF from a TBGRAPixel }
function BGRAToColorF(c: TBGRAPixel; AGammaExpansion: boolean): TColorF; overload;
{** Creates a TColorF array from an array of TBGRAPixel }
function BGRAToColorF(const a: array of TBGRAPixel; AGammaExpansion: boolean): ArrayOfTColorF; overload;
{** Converts a TColorF into a TBGRAPixel }
function ColorFToBGRA(c: TColorF; AGammaCompression: boolean): TBGRAPixel;
{** Applies gamma compression to a TColorF value (yielding non linear values) }
function GammaCompressionF(c: TColorF): TColorF;
{** Applies gamma expansion to a TColorF value (yielding linear values) }
function GammaExpansionF(c: TColorF): TColorF;
{** Subtract each component separately }
operator - (const c1, c2: TColorF): TColorF; inline;
{** Add each component separately }
operator + (const c1, c2: TColorF): TColorF; inline;
{** Multiply each component separately }
operator * (const c1, c2: TColorF): TColorF; inline;
{** Multiply each component by _factor_ }
operator * (const c1: TColorF; factor: single): TColorF; inline;
type
{* @abstract(Pixel color defined in linear HSL colorspace with gamma correction.)
Values range from 0 to 65535. See TGSBAPixel for corrected hue and brightness.
**Example drawing all the colors in HSL colorspace:**
@image(../doc/img/hslapixel_gradient.png)
```pascal
procedure TForm1.FormPaint(Sender: TObject);
var x,y: integer;
p: PBGRAPixel;
image: TBGRABitmap;
hsla: THSLAPixel;
begin
image := TBGRABitmap.Create(ClientWidth,ClientHeight);
hsla.lightness := 32768;
hsla.alpha := 65535;
for y := 0 to image.Height-1 do
begin
p := image.Scanline[y];
hsla.saturation := y*65536 div image.Height;
for x := 0 to image.Width-1 do
begin
hsla.hue := x*65536 div image.Width;
p^:= HSLAToBGRA(hsla);
inc(p);
end;
end;
image.InvalidateBitmap; // changed by direct access
image.Draw(Canvas,0,0,True);
image.free;
end;
```}
THSLAPixel = packed record
{** Hue of the pixel. The 6 primary colors red/yellow/green/cyan/blue/violet are stretched equally.
Extremum values 0 and 65535 are red }
hue: word;
{** Saturation of the color. 0 is gray and 65535 is the brightest color (including white) }
saturation: word;
{** Lightness of the color. 0 is black, 32768 is normal, and 65535 is white }
lightness: word;
{** Opacity of the pixel. 0 is transparent and 65535 is opaque }
alpha: word;
class function New(const AHue,ASaturation,ALightness,AAlpha:word): THSLAPixel;overload;static;
class function New(const AHue,ASaturation,ALightness:word): THSLAPixel;overload;static;
end;
{** Creates a pixel with given HSLA values, where A stands for alpha }
function HSLA(hue, saturation, lightness, alpha: word): THSLAPixel; overload; inline;
{** Creates an opaque pixel with given HSL values }
function HSLA(hue, saturation, lightness: word): THSLAPixel; overload; inline;
{** Converts a pixel from sRGB to HSL color space }
function BGRAToHSLA(c: TBGRAPixel): THSLAPixel;
{** Converts a pixel from gamma expanded RGB to HSL color space }
function ExpandedToHSLA(const ec: TExpandedPixel): THSLAPixel;
{** Converts a pixel from HSL colorspace to sRGB }
function HSLAToBGRA(const c: THSLAPixel): TBGRAPixel;
{** Converts a pixel from HSL colorspace to gamma expanded RGB }
function HSLAToExpanded(const c: THSLAPixel): TExpandedPixel;
{** Computes the hue difference }
function HueDiff(h1, h2: word): word;
{** Returns the hue of a gamma expanded pixel }
function GetHue(ec: TExpandedPixel): word;
type
{* @abstract(Pixel color defined in corrected HSL colorspace.)
G stands for corrected hue and B stands for actual brightness.
Values range from 0 to 65535.
See THSLAPixel for this colorspace without hue and brightness correction.
**Example of drawing a gradient in GSB colorspace:**
@image(../doc/img/gsbapixel_gradient.png)
```pascal
procedure TForm1.FormPaint(Sender: TObject);
var x,y: integer;
p: PBGRAPixel;
image: TBGRABitmap;
gsba: TGSBAPixel;
begin
image := TBGRABitmap.Create(ClientWidth,ClientHeight);
gsba.lightness := 32768;
gsba.alpha := 65535;
for y := 0 to image.Height-1 do
begin
p := image.Scanline[y];
gsba.saturation := y*65536 div image.Height;
for x := 0 to image.Width-1 do
begin
gsba.hue := x*65536 div image.Width;
p^:= GSBAToBGRA(gsba);
inc(p);
end;
end;
image.InvalidateBitmap; // changed by direct access
image.Draw(Canvas,0,0,True);
image.free;
end;
```
}
TGSBAPixel = packed record
{** Corrected hue of the pixel. Extremum values 0 and 65535 are red.
G is corrected in the sense that each segment does not have the same size.
green-cyan and violet-red ranges are shorter, while red-yellow and cyan-blue are wider. }
hue: word;
{** Saturation of the color. 0 is gray and 65535 is the brightest color (excluding white).
Given a certain lightness, it is not always possible to have the full saturation of the color. }
saturation: word;
{** Actual perceived brightness. 0 is black, 32768 is normal, and 65535 is white.
At 32768, depending on the hue, contrary to THSLAPixel, the color may or may not be mixed with black/white.
Blue colors have a lower brightness and thus the full saturation is achieved under 32768.
Conversely yellow colors have higher brightness and thus the full saturation is achieved over 32768. }
lightness: word;
{** Opacity of the pixel. 0 is transparent and 65535 is opaque }
alpha: word;
class function New(const AHue,ASaturation,ABrightness,AAlpha:word): TGSBAPixel;overload;static;
class function New(const AHue,ASaturation,ABrightness:word): TGSBAPixel;overload;static;
end;
{** Converts a pixel from sRGB to correct HSL color space }
function BGRAToGSBA(c: TBGRAPixel): TGSBAPixel;
{** Converts a pixel from gamma expanded RGB to correct HSL color space }
function ExpandedToGSBA(const ec: TExpandedPixel): TGSBAPixel;
{** Converts a G hue (GSBA) to a H hue (HSLA) }
function GtoH(ghue: word): word;
{** Converts a H hue (HSLA) to a G hue (GSBA) }
function HtoG(hue: word): word;
{** Converts a pixel from corrected HSL to sRGB }
function GSBAToBGRA(c: TGSBAPixel): TBGRAPixel; overload;
{** Converts a pixel from corrected HSL to sRGB }
function GSBAToBGRA(const c: THSLAPixel): TBGRAPixel; overload;
{** Converts a pixel from corrected HSL to gamma expanded RGB }
function GSBAToExpanded(c: TGSBAPixel): TExpandedPixel; overload;
{** Converts a pixel from corrected HSL to gamma expanded RGB }
function GSBAToExpanded(const c: THSLAPixel): TExpandedPixel; overload;
{** Converts a pixel from corrected HSL to HSL }
function GSBAToHSLA(const c: TGSBAPixel): THSLAPixel; overload;
{** Converts a pixel from corrected HSL to HSL }
function GSBAToHSLA(const c: THSLAPixel): THSLAPixel; overload;
{** Converts a pixel from HSL to corrected HSL }
function HSLAToGSBA(const c: THSLAPixel): TGSBAPixel;
type
{* Helper for basic conversions of TBGRAPixel }
TBGRAPixelBasicHelper = record helper for TBGRAPixel
{** Converts to TExpandedPixel (linear 16-bit per channel) }
function ToExpanded: TExpandedPixel;
{** Converts from TExpandedPixel (linear 16-bit per channel) }
procedure FromExpanded(const AValue: TExpandedPixel);
{** Converts to THSLAPixel (linear 16-bit per channel) }
function ToHSLAPixel: THSLAPixel;
{** Converts from THSLAPixel (linear 16-bit per channel) }
procedure FromHSLAPixel(const AValue: THSLAPixel);
{** Converts to TGSBAPixel (linear 16-bit per channel) }
function ToGSBAPixel: TGSBAPixel;
{** Converts from TGSBAPixel (linear 16-bit per channel) }
procedure FromGSBAPixel(const AValue: TGSBAPixel); overload;
{** Converts from TGSBAPixel (linear 16-bit per channel) assuming
the THSLAPixel record contains GSBA colorspace }
procedure FromGSBAPixel(const AValue: THSLAPixel); overload;
{** Converts to TColorF, with or without gamma expansion }
function ToColorF(AGammaExpansion: boolean): TColorF;
{** Converts from TColorF, with or without gamma compression }
procedure FromColorF(const AValue: TColorF; AGammaCompression: boolean);
end;
{* Helper for basic conversions of TExpandedPixel }
TExpandedPixelBasicHelper = record helper for TExpandedPixel
{** Converts to TFPColor (16-bit per channel, by default non linear) }
function ToFPColor(AGammaCompression: boolean = true): TFPColor;
{** Converts from TFPColor (16-bit per channel, by default non linear) }
procedure FromFPColor(const AValue: TFPColor; AGammaExpansion: boolean = true);
{** Converts to TColor (non linear 8-bit, without alpha) }
function ToColor: TColor;
{** Converts from TColor (non linear 8-bit ,without alpha) }
procedure FromColor(const AValue: TColor);
{** Converts to TBGRAPixel (non linear 8-bit) }
function ToBGRAPixel: TBGRAPixel;
{** Converts from TBGRAPixel (non linear 8-bit) }
procedure FromBGRAPixel(AValue: TBGRAPixel);
{** Converts to THSLAPixel }
function ToHSLAPixel: THSLAPixel;
{** Converts from THSLAPixel }
procedure FromHSLAPixel(const AValue: THSLAPixel);
{** Converts to TGSBAPixel }
function ToGSBAPixel: TGSBAPixel;
{** Converts from TGSBAPixel }
procedure FromGSBAPixel(const AValue: TGSBAPixel); overload;
{** Converts from TGSBAPixel assuming
the THSLAPixel record contains GSBA colorspace }
procedure FromGSBAPixel(const AValue: THSLAPixel); overload;
end;
{** Implicit conversion of color from TExpandedPixel to TColor }
operator := (const AValue: TExpandedPixel): TColor;
{** Implicit conversion of color from TColor to TExpandedPixel }
operator := (const AValue: TColor): TExpandedPixel;
{** Implicit conversion of color from TExpandedPixel to TBGRAPixel }
Operator := (const Source: TExpandedPixel): TBGRAPixel;
{** Implicit conversion of color from TBGRAPixel to TExpandedPixel }
Operator := (const Source: TBGRAPixel): TExpandedPixel;
type
{* Helper for basic conversions of TFPColor }
TFPColorBasicHelper = record helper for TFPColor
{** Converts to TColor (8-bit without alpha) }
function ToColor: TColor;
{** Converts from TColor (8-bit without alpha) }
procedure FromColor(const AValue: TColor);
{** Converts to TColor (8-bit) }
function ToBGRAPixel: TBGRAPixel;
{** Converts from TColor (8-bit) }
procedure FromBGRAPixel(AValue: TBGRAPixel);
{** Converts to TExpandedPixel (linear) }
function ToExpanded(AGammaExpansion: boolean = true): TExpandedPixel;
{** Converts from TExpandedPixel (linear) }
procedure FromExpanded(const AValue: TExpandedPixel; AGammaCompression: boolean = true);
{** Converts to THSLAPixel (linear) }
function ToHSLAPixel(AGammaExpansion: boolean = true): THSLAPixel;
{** Converts from THSLAPixel (linear) }
procedure FromHSLAPixel(const AValue: THSLAPixel; AGammaCompression: boolean = true);
{** Converts to TGSBAPixel (linear) }
function ToGSBAPixel(AGammaExpansion: boolean = true): TGSBAPixel;
{** Converts from TGSBAPixel (linear) }
procedure FromGSBAPixel(const AValue: TGSBAPixel; AGammaCompression: boolean = true); overload;
{** Converts from TGSBAPixel (linear) assuming
the THSLAPixel record contains GSBA colorspace }
procedure FromGSBAPixel(const AValue: THSLAPixel; AGammaCompression: boolean = true); overload;
end;
{* Helper for basic conversions of THSLAPixel }
THSLAPixelBasicHelper = record helper for THSLAPixel
{** Converts to TColor (non linear 8-bit, without alpha) }
function ToColor: TColor;
{** Converts from TColor (non linear 8-bit, without alpha) }
procedure FromColor(const AValue: TColor);
{** Converts to TBGRAPixel (non linear 8-bit) }
function ToBGRAPixel: TBGRAPixel;
{** Converts from TBGRAPixel (non linear 8-bit) }
procedure FromBGRAPixel(AValue: TBGRAPixel);
{** Converts to TGSBAPixel (corrected hue and brightness) }
function ToGSBAPixel: TGSBAPixel;
{** Converts from TGSBAPixel (corrected hue and brightness) }
procedure FromGSBAPixel(AValue: TGSBAPixel);
{** Converts to TExpandedPixel }
function ToExpanded: TExpandedPixel;
{** Converts from TExpandedPixel }
procedure FromExpanded(AValue: TExpandedPixel);
{** Converts to TFPColor (non linear by default) }
function ToFPColor(AGammaCompression: boolean=true): TFPColor;
{** Converts from TFPColor (non linear by default) }
procedure FromFPColor(AValue: TFPColor; AGammaExpansion: boolean=true);
end;
{** Implicit conversion of color from THSLAPixel to TBGRAPixel }
Operator := (const Source: THSLAPixel): TBGRAPixel;
{** Implicit conversion of color from TBGRAPixel to THSLAPixel }
Operator := (const Source: TBGRAPixel): THSLAPixel;
{** Implicit conversion of color from THSLAPixel to TExpandedPixel }
Operator := (const Source: THSLAPixel): TExpandedPixel;
{** Implicit conversion of color from TExpandedPixel to THSLAPixel }
Operator := (const Source: TExpandedPixel): THSLAPixel;
{** Implicit conversion of color from THSLAPixel to TColor }
operator := (const AValue: TColor): THSLAPixel;
{** Implicit conversion of color from TColor to THSLAPixel }
operator := (const AValue: THSLAPixel): TColor;
type
{* Helper for basic conversion of TGSBAPixel }
TGSBAPixelBasicHelper = record helper for TGSBAPixel
{** Converts to TColor (non linear 8-bit channel, without alpha) }
function ToColor: TColor;
{** Converts from TColor (non linear 8-bit channel, without alpha) }
procedure FromColor(const AValue: TColor);
{** Converts to ToBGRAPixel (non linear 8-bit channel) }
function ToBGRAPixel: TBGRAPixel;
{** Converts from ToBGRAPixel (non linear 8-bit channel) }
procedure FromBGRAPixel(AValue: TBGRAPixel);
{** Converts to THSLAPixel (regular hue and standard lightness) }
function ToHSLAPixel: THSLAPixel;
{** Converts from THSLAPixel (regular hue and standard lightness) }
procedure FromHSLAPixel(AValue: THSLAPixel);
{** Converts to TExpandedPixel }
function ToExpanded: TExpandedPixel;
{** Converts from TExpandedPixel }
procedure FromExpanded(AValue: TExpandedPixel);
{** Converts to TFPColor (by default non linear) }
function ToFPColor(AGammaCompression: boolean=true): TFPColor;
{** Converts from TFPColor (by default non linear) }
procedure FromFPColor(AValue: TFPColor; AGammaExpansion: boolean=true);
end;
{** Implicit conversion of color from TGSBAPixel to TBGRAPixel }
Operator := (const Source: TGSBAPixel): TBGRAPixel;
{** Implicit conversion of color from TBGRAPixel to TGSBAPixel }
Operator := (const Source: TBGRAPixel): TGSBAPixel;
{** Implicit conversion of color from TGSBAPixel to TExpandedPixel }
Operator := (const Source: TGSBAPixel): TExpandedPixel;
{** Implicit conversion of color from TExpandedPixel to TGSBAPixel }
Operator := (const Source: TExpandedPixel): TGSBAPixel;
{** Implicit conversion of color from TColor to TGSBAPixel }
operator := (const AValue: TColor): TGSBAPixel;
{** Implicit conversion of color from TGSBAPixel to TColor }
operator := (const AValue: TGSBAPixel): TColor;
{** Assigns TGSBAPixel to THSLAPixel without conversion,
just copying for backward compatibility (use ToHSLAPixel instead for conversion) }
Operator := (const Source: TGSBAPixel): THSLAPixel;
{** Assigns THSLAPixel to TGSBAPixel,
just copying for backward compatibility (use ToHSLAPixel instead for conversion) }
Operator := (const Source: THSLAPixel): TGSBAPixel;
{ Convert from sRGB the sHSV (byte, lossless). Hue is defined by the sextant and position. }
procedure RGBToByteStdHSV(ARed, AGreen, ABlue: byte; out ASextant, APosition, ASaturation, AValue: byte);
{ Convert from sHSV the sRGB (byte, lossless). Hue is defined by the sextant and position. }
procedure ByteStdHSVToRGB(ASextant, APosition, ASaturation, AValue: byte; out ARed, AGreen, ABlue: byte);
{ Convert from sRGB the sHSL (byte, lossless). Hue is defined by the sextant and position. }
procedure RGBToByteStdHSL(ARed, AGreen, ABlue: byte; out ASextant, APosition, ASaturation, ALightness: byte);
{ Convert from sHSL the sRGB (byte, lossless). Hue is defined by the sextant and position. }
procedure ByteStdHSLToRGB(ASextant, APosition, ASaturation, ALightness: byte; out ARed, AGreen, ABlue: byte);
{ Compute the lightness in sHSL (byte) }
function GetByteStdLightness(ARed, AGreen, ABlue: byte): byte;
{$ENDIF}
{$IFDEF INCLUDE_IMPLEMENTATION}
{$UNDEF INCLUDE_IMPLEMENTATION}
{ TBGRAPixel }
function TBGRAPixel.GetClassIntensity: word;
begin
result := GetIntensity(self);
end;
function TBGRAPixel.GetClassLightness: word;
begin
result := GetLightness(self);
end;
procedure TBGRAPixel.SetClassIntensity(AValue: word);
begin
self := SetIntensity(self, AValue);
end;
procedure TBGRAPixel.SetClassLightness(AValue: word);
begin
self := SetLightness(self, AValue);
end;
class function TBGRAPixel.New(const ARed,AGreen,ABlue,AAlpha:byte): TBGRAPixel;overload;
begin
Result.red := ARed;
Result.green := AGreen;
Result.blue := ABlue;
Result.alpha := AAlpha;
end;
class function TBGRAPixel.New(const ARed,AGreen,ABlue:byte): TBGRAPixel;overload;
begin
Result.red := ARed;
Result.green := AGreen;
Result.blue := ABlue;
Result.alpha := 255;
end;
procedure TBGRAPixel.FromRGB(ARed, AGreen, ABlue: Byte; AAlpha: Byte);
begin
red := ARed;
green := AGreen;
blue := ABlue;
alpha := AAlpha;
end;
procedure TBGRAPixel.FromColor(AColor: TColor; AAlpha: Byte);
begin
if AColor = clNone then
Self := BGRAPixelTransparent
else
begin
RedGreenBlue(ColorToRGB(AColor), red,green,blue);
alpha := AAlpha;
end;
end;
procedure TBGRAPixel.FromString(AStr: string);
begin
Self := StrToBGRA(AStr);
end;
procedure TBGRAPixel.FromFPColor(AColor: TFPColor);
begin
self := FPColorToBGRA(AColor);
end;
procedure TBGRAPixel.ToRGB(out ARed, AGreen, ABlue, AAlpha: Byte);
begin
ARed := red;
AGreen := green;
ABlue := blue;
AAlpha := alpha;
end;
procedure TBGRAPixel.ToRGB(out ARed, AGreen, ABlue: Byte);
begin
ARed := red;
AGreen := green;
ABlue := blue
end;
function TBGRAPixel.ToColor: TColor;
begin
if alpha = 0 then
result := clNone
else
result := RGBToColor(red,green,blue);
end;
function TBGRAPixel.ToString: string;
begin
result := BGRAToStr(Self, CSSColors);
end;
function TBGRAPixel.ToGrayscale(AGammaCorrection: boolean): TBGRAPixel;
begin
if AGammaCorrection then
result := BGRAToGrayscale(self)
else
result := BGRAToGrayscaleLinear(self);
end;
function TBGRAPixel.ToFPColor: TFPColor;
begin
result := BGRAToFPColor(Self);
end;
function TBGRAPixel.EqualsExactly(constref AColor: TBGRAPixel): boolean;
begin
result := PLongWord(@AColor)^ = PLongWord(@self)^;
end;
class operator TBGRAPixel.:=(Source: TBGRAPixel): TColor;
begin
result := Source.ToColor;
end;
class operator TBGRAPixel.:=(Source: TColor): TBGRAPixel;
begin
result.FromColor(Source);
end;
{ TGSBAPixel }
class function TGSBAPixel.New(const AHue,ASaturation,ABrightness,AAlpha:word): TGSBAPixel;overload;
begin
Result.hue := AHue;
Result.saturation := ASaturation;
Result.lightness := ABrightness;
Result.alpha := AAlpha;
end;
class function TGSBAPixel.New(const AHue,ASaturation,ABrightness:word): TGSBAPixel;overload;
begin
Result.hue := AHue;
Result.saturation := ASaturation;
Result.lightness := ABrightness;
Result.alpha := 65535;
end;
{ THSLAPixel }
class function THSLAPixel.New(const AHue,ASaturation,ALightness,AAlpha:word): THSLAPixel;overload;
begin
Result.hue := AHue;
Result.saturation := ASaturation;
Result.lightness := ALightness;
Result.alpha := AAlpha;
end;
class function THSLAPixel.New(const AHue,ASaturation,ALightness:word): THSLAPixel;overload;
begin
Result.hue := AHue;
Result.saturation := ASaturation;
Result.lightness := ALightness;
Result.alpha := 65535;
end;
{ TExpandedPixel }
class function TExpandedPixel.New(const ARed,AGreen,ABlue,AAlpha:word): TExpandedPixel;overload;
begin
Result.red := ARed;
Result.green := AGreen;
Result.blue := ABlue;
Result.alpha := AAlpha;
end;
class function TExpandedPixel.New(const ARed,AGreen,ABlue:word): TExpandedPixel;overload;
begin
Result.red := ARed;
Result.green := AGreen;
Result.blue := ABlue;
Result.alpha := 65535;
end;
{ The gamma correction is approximated here by a power function }
var
GammaExpFactor : single; //exponent
const
redWeightShl10 = 306; // = 0.299
greenWeightShl10 = 601; // = 0.587
blueWeightShl10 = 117; // = 0.114
procedure BGRANoGamma;
var i,j: integer;
prevExp, nextExp: Word;
begin
GammaExpFactor := 1;
prevExp := 0;
for i := 0 to 255 do
begin
GammaExpansionTab[i] := (i shl 8) + i;
if i = 255 then nextExp := 65535
else
begin
nextExp := GammaExpansionTab[i]+128;
GammaExpansionTabHalf[i] := nextExp+1;
end;
for j := prevExp to nextExp do
GammaCompressionTab[j] := i;
if i < 255 then
prevExp := nextExp+1;
end;
end;
procedure BGRASetGamma(AGamma: single);
var
GammaLinearFactor: single;
i,j,prevpos,nextpos,midpos: Int32or64;
begin
if AGamma = 1 then
begin
BGRANoGamma;
exit;
end;
GammaExpFactor := AGamma;
//the linear factor is used to normalize expanded values in the range 0..65535
GammaLinearFactor := 65535 / power(255, GammaExpFactor);
GammaExpansionTab[0] := 0;
nextpos := 0;
for i := 0 to 255 do
begin
prevpos := nextpos;
midpos := round(power(i, GammaExpFactor) * GammaLinearFactor);
if i = 255 then
nextpos := 65536
else
nextpos := round(power(i+0.5, GammaExpFactor) * GammaLinearFactor);
GammaExpansionTab[i] := midpos;
if i < 255 then
GammaExpansionTabHalf[i] := nextpos;
for j := prevpos to midpos-1 do
GammaCompressionTab[j] := i;
for j := midpos to nextpos-1 do
GammaCompressionTab[j] := i;
end;
GammaCompressionTab[0] := 0;
end;
function BGRAGetGamma: single;
begin
result := GammaExpFactor;
end;
procedure AllocateExpandedPixelBuffer(var ABuffer: TExpandedPixelBuffer;
ASize: integer);
begin
if ASize > length(ABuffer) then
setlength(ABuffer, max(length(ABuffer)*2,ASize));
end;
{ Apply gamma correction using conversion tables }
function GammaExpansion(c: TBGRAPixel): TExpandedPixel;
begin
Result.red := GammaExpansionTab[c.red];
Result.green := GammaExpansionTab[c.green];
Result.blue := GammaExpansionTab[c.blue];
Result.alpha := c.alpha shl 8 + c.alpha;
end;
function GammaCompression(const ec: TExpandedPixel): TBGRAPixel;
begin
Result.red := GammaCompressionTab[ec.red];
Result.green := GammaCompressionTab[ec.green];
Result.blue := GammaCompressionTab[ec.blue];
Result.alpha := ec.alpha shr 8;
end;
function GammaCompression(red, green, blue, alpha: word): TBGRAPixel;
begin
Result.red := GammaCompressionTab[red];
Result.green := GammaCompressionTab[green];
Result.blue := GammaCompressionTab[blue];
Result.alpha := alpha shr 8;
end;
function GammaExpansionW(ACompressed: word): word;
const
fracShift = 8;
fracHalf = 1 shl (fracShift-1);
fracQuarter = 1 shl (fracShift-2);
var
intPart, fracPart, half: word;
byteVal: byte;
begin
if ACompressed = 0 then
result := 0
else if ACompressed = $ffff then
result := $ffff
else
begin
//div 257
byteVal := ACompressed shr fracShift;
intPart := (byteVal shl fracShift) + byteVal;
if ACompressed < intPart then
begin
dec(byteVal);
dec(intPart, 257);
end;
fracPart := ACompressed - intPart;
if fracPart >= fracHalf then dec(fracPart); //[0..256] -> [0..255]
if fracPart >= fracHalf then
begin
result := GammaExpansionTab[byteVal+1];
half := GammaExpansionTabHalf[byteVal];
dec(result, ((result-half)*((1 shl fracShift)-fracPart)+fracQuarter) shr (fracShift-1));
end
else
begin
result := GammaExpansionTab[byteVal];
if fracPart > 0 then
begin
half := GammaExpansionTabHalf[byteVal];
inc(result, ((half-result)*fracPart+fracQuarter) shr (fracShift-1));
end;
end;
end;
end;
function GammaCompressionW(AExpanded: word): word;
var
compByte: Byte;
reExp, reExpDelta: Word;
begin
if AExpanded=0 then exit(0) else
if AExpanded=65535 then exit(65535) else
begin
compByte := GammaCompressionTab[AExpanded];
reExp := GammaExpansionTab[compByte];
result := compByte + (compByte shl 8);
if reExp < AExpanded then
begin
reExpDelta := GammaExpansionTabHalf[compByte]-reExp;
if reExpDelta<>0 then
inc(result, ((AExpanded-reExp)*128+(reExpDelta shr 1)) div reExpDelta);
end else
begin
reExpDelta := reExp-GammaExpansionTabHalf[compByte-1];
if reExpDelta<>0 then
dec(result, ((reExp-AExpanded)*128+(reExpDelta shr 1)) div reExpDelta);
end;
end;
end;
{ The intensity is defined here as the maximum value of any color component }
function GetIntensity(const c: TExpandedPixel): word; inline;
begin
Result := c.red;
if c.green > Result then
Result := c.green;
if c.blue > Result then
Result := c.blue;
end;
function SetIntensity(const c: TExpandedPixel; intensity: word): TExpandedPixel;
var
curIntensity: word;
begin
curIntensity := GetIntensity(c);
if curIntensity = 0 then //suppose it's gray if there is no color information
begin
Result.red := intensity;
Result.green := intensity;
Result.blue := intensity;
result.alpha := c.alpha;
end
else
begin
//linear interpolation to reached wanted intensity
Result.red := (c.red * intensity + (curIntensity shr 1)) div curIntensity;
Result.green := (c.green * intensity + (curIntensity shr 1)) div curIntensity;
Result.blue := (c.blue * intensity + (curIntensity shr 1)) div curIntensity;
Result.alpha := c.alpha;
end;
end;
{ The lightness here is defined as the subjective sensation of luminosity, where
blue is the darkest component and green the lightest }
function GetLightness(const c: TExpandedPixel): word; inline;
begin
Result := (c.red * redWeightShl10 + c.green * greenWeightShl10 +
c.blue * blueWeightShl10 + 512) shr 10;
end;
function SetLightness(const c: TExpandedPixel; lightness: word): TExpandedPixel;
var
curLightness: word;
begin
curLightness := GetLightness(c);
if lightness = curLightness then
begin //no change
Result := c;
exit;
end;
result := SetLightness(c, lightness, curLightness);
end;
function SetLightness(const c: TExpandedPixel; lightness: word; curLightness: word): TExpandedPixel;
var
AddedWhiteness, maxBeforeWhite: word;
clip: boolean;
begin
if lightness = curLightness then
begin //no change
Result := c;
exit;
end;
if lightness = 65535 then //set to white
begin
Result.red := 65535;
Result.green := 65535;
Result.blue := 65535;
Result.alpha := c.alpha;
exit;
end;
if lightness = 0 then //set to black
begin
Result.red := 0;
Result.green := 0;
Result.blue := 0;
Result.alpha := c.alpha;
exit;
end;
if curLightness = 0 then //set from black
begin
Result.red := lightness;
Result.green := lightness;
Result.blue := lightness;
Result.alpha := c.alpha;
exit;
end;
if lightness < curLightness then //darker is easy
begin
result.alpha:= c.alpha;
result.red := (c.red * lightness + (curLightness shr 1)) div curLightness;
result.green := (c.green * lightness + (curLightness shr 1)) div curLightness;
result.blue := (c.blue * lightness + (curLightness shr 1)) div curLightness;
exit;
end;
//lighter and grayer
Result := c;
AddedWhiteness := lightness - curLightness;
maxBeforeWhite := 65535 - AddedWhiteness;
clip := False;
if Result.red <= maxBeforeWhite then
Inc(Result.red, AddedWhiteness)
else
begin
Result.red := 65535;
clip := True;
end;
if Result.green <= maxBeforeWhite then
Inc(Result.green, AddedWhiteness)
else
begin
Result.green := 65535;
clip := True;
end;
if Result.blue <= maxBeforeWhite then
Inc(Result.blue, AddedWhiteness)
else
begin
Result.blue := 65535;
clip := True;
end;
if clip then //light and whiter
begin
curLightness := GetLightness(Result);
addedWhiteness := lightness - curLightness;
maxBeforeWhite := 65535 - curlightness;
Result.red := Result.red + addedWhiteness * (65535 - Result.red) div
maxBeforeWhite;
Result.green := Result.green + addedWhiteness * (65535 - Result.green) div
maxBeforeWhite;
Result.blue := Result.blue + addedWhiteness * (65535 - Result.blue) div
maxBeforeWhite;
end;
end;
function ColorImportance(ec: TExpandedPixel): word;
var min,max: word;
begin
min := ec.red;
max := ec.red;
if ec.green > max then
max := ec.green
else
if ec.green < min then
min := ec.green;
if ec.blue > max then
max := ec.blue
else
if ec.blue < min then
min := ec.blue;
result := max - min;
end;
{ Merge two colors of same importance }
function MergeBGRA(ec1, ec2: TExpandedPixel): TExpandedPixel;
var c12: LongWord;
begin
if (ec1.alpha = 0) then
Result := ec2
else
if (ec2.alpha = 0) then
Result := ec1
else
begin
c12 := ec1.alpha + ec2.alpha;
Result.red := (int64(ec1.red) * ec1.alpha + int64(ec2.red) * ec2.alpha + c12 shr 1) div c12;
Result.green := (int64(ec1.green) * ec1.alpha + int64(ec2.green) * ec2.alpha + c12 shr 1) div c12;
Result.blue := (int64(ec1.blue) * ec1.alpha + int64(ec2.blue) * ec2.alpha + c12 shr 1) div c12;
Result.alpha := (c12 + 1) shr 1;
end;
end;
function MergeBGRA(ec1: TExpandedPixel; weight1: integer; ec2: TExpandedPixel;
weight2: integer): TExpandedPixel;
var
f1,f2,f12: int64;
begin
if (weight1 = 0) then
begin
if (weight2 = 0) then
result := BGRAPixelTransparent
else
Result := ec2
end
else
if (weight2 = 0) then
Result := ec1
else
if (weight1+weight2 = 0) then
Result := BGRAPixelTransparent
else
begin
f1 := int64(ec1.alpha)*weight1;
f2 := int64(ec2.alpha)*weight2;
f12 := f1+f2;
if f12 = 0 then
result := BGRAPixelTransparent
else
begin
Result.red := (ec1.red * f1 + ec2.red * f2 + f12 shr 1) div f12;
Result.green := (ec1.green * f1 + ec2.green * f2 + f12 shr 1) div f12;
Result.blue := (ec1.blue * f1 + ec2.blue * f2 + f12 shr 1) div f12;
{$hints off}
Result.alpha := (f12 + ((weight1+weight2) shr 1)) div (weight1+weight2);
{$hints on}
end;
end;
end;
function LessStartSlope65535(value: word): word;
var factor: word;
begin
factor := 4096 - (not value)*3 shr 7;
result := value*factor shr 12;
end;
function ExpandedDiff(ec1, ec2: TExpandedPixel): word;
var
CompRedAlpha1, CompGreenAlpha1, CompBlueAlpha1, CompRedAlpha2,
CompGreenAlpha2, CompBlueAlpha2: integer;
DiffAlpha: word;
ColorDiff: word;
TempHueDiff: word;
begin
if (ec1.alpha = 0) and (ec2.alpha = 0) then exit(0) else
if (ec1.alpha = ec2.alpha) and (ec1.red = ec2.red) and
(ec1.green = ec2.green) and (ec1.blue = ec2.blue) then exit(0);
CompRedAlpha1 := ec1.red * ec1.alpha shr 16; //gives 0..65535
CompGreenAlpha1 := ec1.green * ec1.alpha shr 16;
CompBlueAlpha1 := ec1.blue * ec1.alpha shr 16;
CompRedAlpha2 := ec2.red * ec2.alpha shr 16;
CompGreenAlpha2 := ec2.green * ec2.alpha shr 16;
CompBlueAlpha2 := ec2.blue * ec2.alpha shr 16;
Result := (Abs(CompRedAlpha2 - CompRedAlpha1)*redWeightShl10 +
Abs(CompBlueAlpha2 - CompBlueAlpha1)*blueWeightShl10 +
Abs(CompGreenAlpha2 - CompGreenAlpha1)*greenWeightShl10) shr 10;
ColorDiff := min(ColorImportance(ec1),ColorImportance(ec2));
if ColorDiff > 0 then
begin
TempHueDiff := HueDiff(HtoG(GetHue(ec1)),HtoG(GetHue(ec2)));
if TempHueDiff < 32768 then
TempHueDiff := LessStartSlope65535(TempHueDiff shl 1) shr 4
else
TempHueDiff := TempHueDiff shr 3;
Result := ((Result shr 4)* (not ColorDiff) + TempHueDiff*ColorDiff) shr 12;
end;
DiffAlpha := Abs(integer(ec2.Alpha) - integer(ec1.Alpha));
if DiffAlpha > Result then
Result := DiffAlpha;
end;
function FPColorToExpanded(AColor: TFPColor; AGammaExpansion: boolean): TExpandedPixel;
begin
result.FromFPColor(AColor, AGammaExpansion);
end;
function ExpandedToFPColor(AExpanded: TExpandedPixel; AGammaCompression: boolean): TFPColor;
begin
result.FromExpanded(AExpanded, AGammaCompression);
end;
function ColorF(red, green, blue, alpha: single): TColorF;
begin
result[1] := red;
result[2] := green;
result[3] := blue;
result[4] := alpha;
end;
function BGRAToColorF(c: TBGRAPixel; AGammaExpansion: boolean): TColorF;
const OneOver255 = 1/255;
OneOver65535 = 1/65535;
begin
if not AGammaExpansion then
begin
result[1] := c.red*OneOver255;
result[2] := c.green*OneOver255;
result[3] := c.blue*OneOver255;
result[4] := c.alpha*OneOver255;
end else
with GammaExpansion(c) do
begin
result[1] := red*OneOver65535;
result[2] := green*OneOver65535;
result[3] := blue*OneOver65535;
result[4] := alpha*OneOver65535;
end;
end;
function BGRAToColorF(const a: array of TBGRAPixel; AGammaExpansion: boolean
): ArrayOfTColorF;
var
i: Int32or64;
begin
result := nil;
setlength(result, length(a));
for i := 0 to high(a) do
result[i] := BGRAToColorF(a[i],AGammaExpansion);
end;
function ColorFToBGRA(c: TColorF; AGammaCompression: boolean): TBGRAPixel;
begin
if not AGammaCompression then
begin
result.red := Min(255,Max(0,round(c[1]*255)));
result.green := Min(255,Max(0,round(c[2]*255)));
result.blue := Min(255,Max(0,round(c[3]*255)));
end else
begin
result.red := GammaCompressionTab[Min(65535,Max(0,round(c[1]*65535)))];
result.green := GammaCompressionTab[Min(65535,Max(0,round(c[2]*65535)))];
result.blue := GammaCompressionTab[Min(65535,Max(0,round(c[3]*65535)))];
end;
result.alpha := Min(255,Max(0,round(c[4]*255)));
end;
function GammaCompressionF(c: TColorF): TColorF;
var inv: single;
begin
inv := 1/GammaExpFactor;
result := ColorF(power(c[1],inv),power(c[2],inv),power(c[3],inv),c[4]);
end;
function GammaExpansionF(c: TColorF): TColorF;
begin
result := ColorF(power(c[1],GammaExpFactor),power(c[2],GammaExpFactor),power(c[3],GammaExpFactor),c[4]);
end;
operator-(const c1, c2: TColorF): TColorF;
begin
result[1] := c1[1]-c2[1];
result[2] := c1[2]-c2[2];
result[3] := c1[3]-c2[3];
result[4] := c1[4]-c2[4];
end;
operator+(const c1, c2: TColorF): TColorF;
begin
result[1] := c1[1]+c2[1];
result[2] := c1[2]+c2[2];
result[3] := c1[3]+c2[3];
result[4] := c1[4]+c2[4];
end;
operator*(const c1, c2: TColorF): TColorF;
begin
result[1] := c1[1]*c2[1];
result[2] := c1[2]*c2[2];
result[3] := c1[3]*c2[3];
result[4] := c1[4]*c2[4];
end;
operator*(const c1: TColorF; factor: single): TColorF;
begin
result[1] := c1[1]*factor;
result[2] := c1[2]*factor;
result[3] := c1[3]*factor;
result[4] := c1[4]*factor;
end;
{ THSLAPixel }
function HSLA(hue, saturation, lightness, alpha: word): THSLAPixel;
begin
Result.hue := hue;
Result.saturation := saturation;
Result.lightness := lightness;
Result.alpha := alpha;
end;
function HSLA(hue, saturation, lightness: word): THSLAPixel;
begin
Result.hue := hue;
Result.saturation := saturation;
Result.lightness := lightness;
Result.alpha := $ffff;
end;
{ Conversion from RGB value to HSL colorspace. See : http://en.wikipedia.org/wiki/HSL_color_space }
function BGRAToHSLA(c: TBGRAPixel): THSLAPixel;
begin
result := ExpandedToHSLA(GammaExpansion(c));
end;
procedure ExpandedToHSLAInline(r,g,b: Int32Or64; var dest: THSLAPixel); inline;
const
deg60 = 10922;
deg120 = 21845;
deg240 = 43690;
var
min, max, minMax: Int32or64;
UMinMax,UTwiceLightness: UInt32or64;
begin
if g > r then
begin
max := g;
min := r;
end else
begin
max := r;
min := g;
end;
if b > max then
max := b else
if b < min then
min := b;
minMax := max - min;
if minMax = 0 then
dest.hue := 0
else
if max = r then
{$PUSH}{$RANGECHECKS OFF}
dest.hue := ((g - b) * deg60) div minMax
{$POP}
else
if max = g then
dest.hue := ((b - r) * deg60) div minMax + deg120
else
{max = b} dest.hue := ((r - g) * deg60) div minMax + deg240;
UTwiceLightness := max + min;
if min = max then
dest.saturation := 0 else
begin
UMinMax:= minMax;
if UTwiceLightness < 65536 then
dest.saturation := (UMinMax shl 16) div (UTwiceLightness + 1)
else
dest.saturation := (UMinMax shl 16) div (131072 - UTwiceLightness);
end;
dest.lightness := UTwiceLightness shr 1;
end;
function ExpandedToHSLA(const ec: TExpandedPixel): THSLAPixel;
begin
result.alpha := ec.alpha;
ExpandedToHSLAInline(ec.red,ec.green,ec.blue,result);
end;
{ Conversion from HSL colorspace to RGB. See : http://en.wikipedia.org/wiki/HSL_color_space }
function HSLAToBGRA(const c: THSLAPixel): TBGRAPixel;
var ec: TExpandedPixel;
begin
ec := HSLAToExpanded(c);
Result := GammaCompression(ec);
end;
function HSLAToExpanded(const c: THSLAPixel): TExpandedPixel;
const
deg30 = 4096;
deg60 = 8192;
deg120 = deg60 * 2;
deg180 = deg60 * 3;
deg240 = deg60 * 4;
deg360 = deg60 * 6;
function ComputeColor(p, q: Int32or64; h: Int32or64): Int32or64; inline;
begin
if h < deg180 then
begin
if h < deg60 then
Result := p + ((q - p) * h + deg30) div deg60
else
Result := q
end else
begin
if h < deg240 then
Result := p + ((q - p) * (deg240 - h) + deg30) div deg60
else
Result := p;
end;
end;
var
q, p, L, S, H: Int32or64;
begin
L := c.lightness;
S := c.saturation;
if S = 0 then //gray
begin
result.red := L;
result.green := L;
result.blue := L;
result.alpha := c.alpha;
exit;
end;
{$hints off}
if L < 32768 then
q := (L shr 1) * ((65535 + S) shr 1) shr 14
else
q := L + S - ((L shr 1) *
(S shr 1) shr 14);
{$hints on}
if q > 65535 then q := 65535;
p := (L shl 1) - q;
if p > 65535 then p := 65535;
H := c.hue * deg360 shr 16;
result.green := ComputeColor(p, q, H);
inc(H, deg120);
if H > deg360 then Dec(H, deg360);
result.red := ComputeColor(p, q, H);
inc(H, deg120);
if H > deg360 then Dec(H, deg360);
result.blue := ComputeColor(p, q, H);
result.alpha := c.alpha;
end;
function HueDiff(h1, h2: word): word;
begin
result := abs(integer(h1)-integer(h2));
if result > 32768 then result := 65536-result;
end;
function GetHue(ec: TExpandedPixel): word;
const
deg60 = 8192;
deg120 = deg60 * 2;
deg240 = deg60 * 4;
deg360 = deg60 * 6;
var
min, max, minMax: integer;
r,g,b: integer;
begin
r := ec.red;
g := ec.green;
b := ec.blue;
min := r;
max := r;
if g > max then
max := g
else
if g < min then
min := g;
if b > max then
max := b
else
if b < min then
min := b;
minMax := max - min;
if minMax = 0 then
Result := 0
else
if max = r then
Result := (((g - b) * deg60) div
minMax + deg360) mod deg360
else
if max = g then
Result := ((b - r) * deg60) div minMax + deg120
else
{max = b} Result :=
((r - g) * deg60) div minMax + deg240;
Result := (Result shl 16) div deg360; //normalize
end;
{ TGSBAPixel }
function BGRAToGSBA(c: TBGRAPixel): TGSBAPixel;
var
ec: TExpandedPixel;
begin
ec := GammaExpansion(c);
result := ExpandedToGSBA(ec);
end;
function ExpandedToGSBA(const ec: TExpandedPixel): TGSBAPixel;
var lightness: UInt32Or64;
red,green,blue: Int32or64;
hsla: THSLAPixel;
begin
red := ec.red;
green := ec.green;
blue := ec.blue;
hsla.alpha := ec.alpha;
lightness := (red * redWeightShl10 + green * greenWeightShl10 +
blue * blueWeightShl10 + 512) shr 10;
ExpandedToHSLAInline(red,green,blue,hsla);
result := TGSBAPixel(hsla);
if result.lightness > 32768 then
result.saturation := result.saturation* UInt32or64(not result.lightness) div 32767;
result.lightness := lightness;
result.hue := HtoG(result.hue);
end;
function GtoH(ghue: word): word;
const
segment: array[0..5] of UInt32or64 =
(13653, 10923, 8192, 13653, 10923, 8192);
var g: UInt32or64;
begin
g := ghue;
if g < segment[0] then
result := g * 10923 div segment[0]
else
begin
dec(g, segment[0]);
if g < segment[1] then
result := g * (21845-10923) div segment[1] + 10923
else
begin
dec(g, segment[1]);
if g < segment[2] then
result := g * (32768-21845) div segment[2] + 21845
else
begin
dec(g, segment[2]);
if g < segment[3] then
result := g * (43691-32768) div segment[3] + 32768
else
begin
dec(g, segment[3]);
if g < segment[4] then
result := g * (54613-43691) div segment[4] + 43691
else
begin
dec(g, segment[4]);
result := g * (65536-54613) div segment[5] + 54613;
end;
end;
end;
end;
end;
end;
function HtoG(hue: word): word;
const
segmentDest: array[0..5] of UInt32or64 =
(13653, 10923, 8192, 13653, 10923, 8192);
segmentSrc: array[0..5] of UInt32or64 =
(10923, 10922, 10923, 10923, 10922, 10923);
var
h,g: UInt32or64;
begin
h := hue;
if h < segmentSrc[0] then
g := h * segmentDest[0] div segmentSrc[0]
else
begin
g := segmentDest[0];
dec(h, segmentSrc[0]);
if h < segmentSrc[1] then
inc(g, h * segmentDest[1] div segmentSrc[1])
else
begin
inc(g, segmentDest[1]);
dec(h, segmentSrc[1]);
if h < segmentSrc[2] then
inc(g, h * segmentDest[2] div segmentSrc[2])
else
begin
inc(g, segmentDest[2]);
dec(h, segmentSrc[2]);
if h < segmentSrc[3] then
inc(g, h * segmentDest[3] div segmentSrc[3])
else
begin
inc(g, segmentDest[3]);
dec(h, segmentSrc[3]);
if h < segmentSrc[4] then
inc(g, h * segmentDest[4] div segmentSrc[4])
else
begin
inc(g, segmentDest[4]);
dec(h, segmentSrc[4]);
inc(g, h * segmentDest[5] div segmentSrc[5]);
end;
end;
end;
end;
end;
result := g;
end;
function GSBAToBGRA(c: TGSBAPixel): TBGRAPixel;
var ec: TExpandedPixel;
begin
ec := GSBAToExpanded(c);
result := GammaCompression(ec);
end;
function GSBAToBGRA(const c: THSLAPixel): TBGRAPixel;
begin
result := GSBAToBGRA(TGSBAPixel(c));
end;
function GSBAToExpanded(c: TGSBAPixel): TExpandedPixel;
var lightness: word;
begin
c.hue := GtoH(c.hue);
lightness := c.lightness;
c.lightness := 32768;
result := SetLightness(HSLAToExpanded(THSLAPixel(c)),lightness);
end;
function GSBAToExpanded(const c: THSLAPixel): TExpandedPixel;
begin
result := GSBAToExpanded(TGSBAPixel(c));
end;
function GSBAToHSLA(const c: TGSBAPixel): THSLAPixel;
begin
result := ExpandedToHSLA(GSBAToExpanded(c));
end;
function GSBAToHSLA(const c: THSLAPixel): THSLAPixel;
begin
result := ExpandedToHSLA(GSBAToExpanded(TGSBAPixel(c)));
end;
function HSLAToGSBA(const c: THSLAPixel): TGSBAPixel;
begin
result := ExpandedToGSBA(HSLAToExpanded(c));
end;
{ TBGRAPixelBasicHelper }
function TBGRAPixelBasicHelper.ToExpanded: TExpandedPixel;
begin
result := GammaExpansion(self);
end;
procedure TBGRAPixelBasicHelper.FromExpanded(const AValue: TExpandedPixel);
begin
Self := GammaCompression(AValue);
end;
function TBGRAPixelBasicHelper.ToHSLAPixel: THSLAPixel;
begin
result := BGRAToHSLA(Self);
end;
procedure TBGRAPixelBasicHelper.FromHSLAPixel(const AValue: THSLAPixel);
begin
Self := HSLAToBGRA(AValue);
end;
function TBGRAPixelBasicHelper.ToGSBAPixel: TGSBAPixel;
begin
result := BGRAToGSBA(Self);
end;
procedure TBGRAPixelBasicHelper.FromGSBAPixel(const AValue: TGSBAPixel);
begin
Self := GSBAToBGRA(AValue);
end;
procedure TBGRAPixelBasicHelper.FromGSBAPixel(const AValue: THSLAPixel);
begin
Self := GSBAToBGRA(AValue);
end;
function TBGRAPixelBasicHelper.ToColorF(AGammaExpansion: boolean): TColorF;
begin
result := BGRAToColorF(Self,AGammaExpansion);
end;
procedure TBGRAPixelBasicHelper.FromColorF(const AValue: TColorF;
AGammaCompression: boolean);
begin
Self := ColorFToBGRA(AValue,AGammaCompression);
end;
{ TExpandedPixelBasicHelper }
function TExpandedPixelBasicHelper.ToFPColor(AGammaCompression: boolean): TFPColor;
begin
if AGammaCompression then
begin
result.red := GammaCompressionW(self.red);
result.green := GammaCompressionW(self.green);
result.blue := GammaCompressionW(self.blue);
end else
begin
result.red := self.red;
result.green := self.green;
result.blue := self.blue;
end;
result.alpha := self.alpha;
end;
procedure TExpandedPixelBasicHelper.FromFPColor(const AValue: TFPColor;
AGammaExpansion: boolean);
begin
if AGammaExpansion then
begin
self.red := GammaExpansionW(AValue.red);
self.green := GammaExpansionW(AValue.green);
self.blue := GammaExpansionW(AValue.blue);
end else
begin
self.red := AValue.red;
self.green := AValue.green;
self.blue := AValue.blue;
end;
self.alpha := AValue.alpha;
end;
function TExpandedPixelBasicHelper.ToColor: TColor;
begin
result := BGRAToColor(GammaCompression(self));
end;
procedure TExpandedPixelBasicHelper.FromColor(const AValue: TColor);
begin
self := GammaExpansion(ColorToBGRA(AValue));
end;
function TExpandedPixelBasicHelper.ToBGRAPixel: TBGRAPixel;
begin
result := GammaCompression(Self);
end;
procedure TExpandedPixelBasicHelper.FromBGRAPixel(AValue: TBGRAPixel);
begin
Self := GammaExpansion(AValue);
end;
function TExpandedPixelBasicHelper.ToHSLAPixel: THSLAPixel;
begin
result := ExpandedToHSLA(Self);
end;
procedure TExpandedPixelBasicHelper.FromHSLAPixel(const AValue: THSLAPixel);
begin
Self := HSLAToExpanded(AValue);
end;
function TExpandedPixelBasicHelper.ToGSBAPixel: TGSBAPixel;
begin
result := ExpandedToGSBA(Self);
end;
procedure TExpandedPixelBasicHelper.FromGSBAPixel(const AValue: TGSBAPixel);
begin
Self := GSBAToExpanded(AValue);
end;
procedure TExpandedPixelBasicHelper.FromGSBAPixel(const AValue: THSLAPixel);
begin
Self := GSBAToExpanded(AValue);
end;
operator := (const AValue: TExpandedPixel): TColor;
begin Result := BGRAToColor(GammaCompression(AValue)); end;
operator := (const AValue: TColor): TExpandedPixel;
begin Result := GammaExpansion(ColorToBGRA(AValue)) end;
operator :=(const Source: TExpandedPixel): TBGRAPixel;
begin
result := GammaCompression(Source);
end;
operator :=(const Source: TBGRAPixel): TExpandedPixel;
begin
result := GammaExpansion(Source);
end;
{ TFPColorBasicHelper }
function TFPColorBasicHelper.ToColor: TColor;
begin
result := FPColorToTColor(self);
end;
procedure TFPColorBasicHelper.FromColor(const AValue: TColor);
begin
self := TColorToFPColor(AValue);
end;
function TFPColorBasicHelper.ToBGRAPixel: TBGRAPixel;
begin
result := FPColorToBGRA(self);
end;
procedure TFPColorBasicHelper.FromBGRAPixel(AValue: TBGRAPixel);
begin
self := BGRAToFPColor(AValue);
end;
function TFPColorBasicHelper.ToExpanded(AGammaExpansion: boolean): TExpandedPixel;
begin
result.FromFPColor(self, AGammaExpansion);
end;
procedure TFPColorBasicHelper.FromExpanded(const AValue: TExpandedPixel;
AGammaCompression: boolean);
begin
self := AValue.ToFPColor(AGammaCompression);
end;
function TFPColorBasicHelper.ToHSLAPixel(AGammaExpansion: boolean): THSLAPixel;
begin
result.FromFPColor(self, AGammaExpansion);
end;
procedure TFPColorBasicHelper.FromHSLAPixel(const AValue: THSLAPixel;
AGammaCompression: boolean);
begin
FromExpanded(AValue.ToExpanded, AGammaCompression);
end;
function TFPColorBasicHelper.ToGSBAPixel(AGammaExpansion: boolean): TGSBAPixel;
begin
result.FromFPColor(self, AGammaExpansion);
end;
procedure TFPColorBasicHelper.FromGSBAPixel(const AValue: TGSBAPixel;
AGammaCompression: boolean);
begin
FromExpanded(AValue.ToExpanded, AGammaCompression);
end;
procedure TFPColorBasicHelper.FromGSBAPixel(const AValue: THSLAPixel;
AGammaCompression: boolean);
begin
FromExpanded(AValue.ToExpanded, AGammaCompression);
end;
{ THSLAPixelBasicHelper }
function THSLAPixelBasicHelper.ToColor: TColor;
begin
result := BGRAToColor(HSLAToBGRA(self));
end;
procedure THSLAPixelBasicHelper.FromColor(const AValue: TColor);
begin
self := BGRAToHSLA(ColorToBGRA(AValue));
end;
function THSLAPixelBasicHelper.ToBGRAPixel: TBGRAPixel;
begin
result := HSLAToBGRA(self);
end;
procedure THSLAPixelBasicHelper.FromBGRAPixel(AValue: TBGRAPixel);
begin
self := BGRAToHSLA(AValue);
end;
function THSLAPixelBasicHelper.ToGSBAPixel: TGSBAPixel;
begin
result := HSLAToGSBA(self);
end;
procedure THSLAPixelBasicHelper.FromGSBAPixel(AValue: TGSBAPixel);
begin
self := GSBAToHSLA(AValue);
end;
function THSLAPixelBasicHelper.ToExpanded: TExpandedPixel;
begin
result := HSLAToExpanded(Self);
end;
procedure THSLAPixelBasicHelper.FromExpanded(AValue: TExpandedPixel);
begin
Self := ExpandedToHSLA(AValue);
end;
function THSLAPixelBasicHelper.ToFPColor(AGammaCompression: boolean): TFPColor;
begin
result.FromExpanded(self.ToExpanded, AGammaCompression);
end;
procedure THSLAPixelBasicHelper.FromFPColor(AValue: TFPColor;
AGammaExpansion: boolean);
begin
FromExpanded(AValue.ToExpanded(AGammaExpansion));
end;
operator :=(const Source: THSLAPixel): TBGRAPixel;
begin
result := HSLAToBGRA(Source);
end;
operator :=(const Source: TBGRAPixel): THSLAPixel;
begin
result := BGRAToHSLA(Source);
end;
operator :=(const Source: THSLAPixel): TExpandedPixel;
begin
result := HSLAToExpanded(Source);
end;
operator:=(const Source: TExpandedPixel): THSLAPixel;
begin
result := ExpandedToHSLA(Source);
end;
operator := (const AValue: TColor): THSLAPixel;
begin Result := BGRAToHSLA(ColorToBGRA(AValue)) end;
operator := (const AValue: THSLAPixel): TColor;
begin Result := BGRAToColor(HSLAToBGRA(AValue)) end;
{ @abstract(Converts a color from RGB to Hue/Chroma/Value.)
- Hue is expressed as a Sextant from 0 to 5 and Position from 0 to 255.
- Chroma ranges from 0 to Value.
- Value ranges from 0 to 255.
}
procedure RGBToByteStdHCV(ARed, AGreen, ABlue: byte; out ASextant, APosition, AChroma, AValue: byte);
var mini: Byte;
begin
if (ARed = AGreen) and (AGreen = ABlue) then
begin
ASextant := 0;
APosition := 0;
AChroma := 0;
AValue := ARed;
exit;
end;
AValue := max(max(ARed, AGreen), ABlue);
mini := min(min(ARed, AGreen), ABlue);
AChroma := AValue - mini;
if ARed = AValue then
begin
if AGreen >= ABlue then
begin
ASextant := 0;
APosition := AGreen - mini;
end else
begin
ASextant := 5;
APosition := AValue - ABlue;
end;
end else
if AGreen = AValue then
begin
if ABlue >= ARed then
begin
ASextant := 2;
APosition := ABlue - mini;
end else
begin
ASextant := 1;
APosition := AValue - ARed;
end;
end else // ABlue = AValue
begin
if ARed >= AGreen then
begin
ASextant := 4;
APosition := ARed - mini;
end else
begin
ASextant := 3;
APosition := AValue - AGreen;
end;
end;
// normalize position
APosition := (APosition * 255 + (AChroma shr 1)) div AChroma;
end;
{ @abstract(Converts a color expressed as Hue/Chroma/Value into sRGB.)
- Hue is expressed as a Sextant from 0 to 5 and Position from 0 to 255.
- Chroma ranges from 0 to Value.
- Value ranges from 0 to 255.
}
procedure ByteStdHCVToRGB(ASextant, APosition, AChroma, AValue: byte; out ARed, AGreen, ABlue: byte);
var
mini: Byte;
begin
if AChroma = 0 then
begin
ARed := AValue;
AGreen := AValue;
ABlue := AValue;
exit;
end;
if AChroma > AValue then AChroma := AValue;
// denormalize position
APosition := (APosition * AChroma + 127) div 255;
mini := AValue - AChroma;
case ASextant of
0: begin
ARed := AValue;
AGreen := mini + APosition;
ABlue := mini;
end;
1: begin
ARed := AValue - APosition;
AGreen := AValue;
ABlue := mini;
end;
2: begin
ARed := mini;
AGreen := AValue;
ABlue := mini + APosition;
end;
3: begin
ARed := mini;
AGreen := AValue - APosition;
ABlue := AValue;
end;
4: begin
ARed := mini + APosition;
AGreen := mini;
ABlue := AValue;
end;
5: begin
ARed := AValue;
AGreen := mini;
ABlue := AValue - APosition;
end;
else
raise Exception.Create('Invalid sextant');
end;
end;
procedure RGBToByteStdHSL(ARed, AGreen, ABlue: byte; out ASextant, APosition,
ASaturation, ALightness: byte);
var
value, chroma, maxChroma: byte;
begin
RGBToByteStdHCV(ARed, AGreen, ABlue, ASextant, APosition, chroma, value);
ALightness := max(value - (chroma shr 1), 0);
// normalize chroma
if ALightness >= 128 then
maxChroma := (255 - ALightness) shl 1 + 1
else
maxChroma := ALightness shl 1;
if maxChroma = 0 then
ASaturation := 0
else
ASaturation := (chroma * 255 + (maxChroma shr 1)) div maxChroma;
end;
procedure ByteStdHSLToRGB(ASextant, APosition, ASaturation, ALightness: byte; out
ARed, AGreen, ABlue: byte);
var value, chroma, maxChroma: byte;
begin
// denormalize chroma
if ALightness >= 128 then
maxChroma := (255 - ALightness) shl 1 + 1
else
maxChroma := ALightness shl 1;
chroma := (ASaturation * maxChroma + 127) div 255;
value := min(ALightness + (chroma shr 1), 255);
ByteStdHCVToRGB(ASextant, APosition, chroma, value, ARed, AGreen, ABlue);
end;
procedure RGBToByteStdHSV(ARed, AGreen, ABlue: byte; out ASextant, APosition,
ASaturation, AValue: byte);
var
chroma: byte;
begin
RGBToByteStdHCV(ARed, AGreen, ABlue, ASextant, APosition, chroma, AValue);
// normalize chroma
if AValue = 0 then
ASaturation := 0
else
ASaturation := (chroma * 255 + (AValue shr 1)) div AValue;
end;
procedure ByteStdHSVToRGB(ASextant, APosition, ASaturation, AValue: byte; out
ARed, AGreen, ABlue: byte);
var chroma: byte;
begin
// denormalize chroma
chroma := (ASaturation * AValue + 127) div 255;
ByteStdHCVToRGB(ASextant, APosition, chroma, AValue, ARed, AGreen, ABlue);
end;
function GetByteStdLightness(ARed, AGreen, ABlue: byte): byte;
begin
result := (max(max(ARed, AGreen), ABlue) + min(min(ARed, AGreen), ABlue) + 1) shr 1;
end;
{ TGSBAPixelBasicHelper }
function TGSBAPixelBasicHelper.ToColor: TColor;
begin
result := BGRAToColor(GSBAToBGRA(self));
end;
procedure TGSBAPixelBasicHelper.FromColor(const AValue: TColor);
begin
self := BGRAToGSBA(ColorToBGRA(AValue));
end;
function TGSBAPixelBasicHelper.ToBGRAPixel: TBGRAPixel;
begin
result := GSBAToBGRA(self);
end;
procedure TGSBAPixelBasicHelper.FromBGRAPixel(AValue: TBGRAPixel);
begin
self := BGRAToGSBA(AValue);
end;
function TGSBAPixelBasicHelper.ToHSLAPixel: THSLAPixel;
begin
result := GSBAToHSLA(self);
end;
procedure TGSBAPixelBasicHelper.FromHSLAPixel(AValue: THSLAPixel);
begin
self := HSLAToGSBA(AValue);
end;
function TGSBAPixelBasicHelper.ToExpanded: TExpandedPixel;
begin
result := GSBAToExpanded(self);
end;
procedure TGSBAPixelBasicHelper.FromExpanded(AValue: TExpandedPixel);
begin
self := ExpandedToGSBA(AValue);
end;
function TGSBAPixelBasicHelper.ToFPColor(AGammaCompression: boolean): TFPColor;
begin
result.FromGSBAPixel(self, AGammaCompression);
end;
procedure TGSBAPixelBasicHelper.FromFPColor(AValue: TFPColor;
AGammaExpansion: boolean);
begin
FromExpanded(AValue.ToExpanded(AGammaExpansion));
end;
operator :=(const Source: TGSBAPixel): TBGRAPixel;
begin
result := GSBAToBGRA(Source);
end;
operator :=(const Source: TBGRAPixel): TGSBAPixel;
begin
result := BGRAToGSBA(Source);
end;
operator :=(const Source: TGSBAPixel): TExpandedPixel;
begin
result := GSBAToExpanded(Source);
end;
operator:=(const Source: TExpandedPixel): TGSBAPixel;
begin
result := ExpandedToGSBA(Source);
end;
operator := (const AValue: TColor): TGSBAPixel;
begin Result := BGRAToGSBA(ColorToBGRA(AValue)) end;
operator := (const AValue: TGSBAPixel): TColor;
begin Result := BGRAToColor(GSBAToBGRA(AValue)) end;
operator :=(const Source: TGSBAPixel): THSLAPixel;
begin
result := THSLAPixel(Pointer(@Source)^);
end;
operator:=(const Source: THSLAPixel): TGSBAPixel;
begin
result := TGSBAPixel(Pointer(@Source)^);
end;
{$ENDIF}
================================================
FILE: bgrabitmap/bezier.inc
================================================
// SPDX-License-Identifier: LGPL-3.0-linking-exception
{$IFDEF INCLUDE_INTERFACE}
{$UNDEF INCLUDE_INTERFACE}
{=== Geometry types ===}
{==== Bézier curves ====}
type
{* Definition of a Bézier curve of order 3. It has two control points _c1_ and _c2_.
Those are not reached by the curve in general. }
TCubicBezierCurve = object
private
{** Compute the points using the simple approach of computing for each time value }
function SimpleComputePoints(AAcceptedDeviation: single = 0.1; AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
public
{** Starting point (reached) }
p1: TPointF;
{** First control point (not reached by the curve) }
c1: TPointF;
{** Second control point (not reached by the curve) }
c2: TPointF;
{** Ending point (reached) }
p2: TPointF;
{** Computes the point at time _t_, varying from 0 to 1 }
function ComputePointAt(t: single): TPointF;
{** Split the curve in two such that _ALeft.p2_ = _ARight.p1_ }
procedure Split(out ALeft, ARight: TCubicBezierCurve);
{** Compute an approximation of the length of the curve. _AAcceptedDeviation_ indicates the
maximum orthogonal distance that is ignored and approximated by a straight line. }
function ComputeLength(AAcceptedDeviation: single = 0.1): single;
{** Computes a polygonal approximation of the curve. _AAcceptedDeviation_ indicates the
maximum orthogonal distance that is ignored and approximated by a straight line.
_AIncludeFirstPoint_ indicates if the first point must be included in the array }
function ToPoints(AAcceptedDeviation: single = 0.1; AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
{** Copy the curve to the given path }
procedure CopyToPath(ADest: IBGRAPath);
{** Computes the rectangular bounds }
function GetBounds: TRectF;
end;
{** Creates a structure for a cubic Bézier curve }
function BezierCurve(origin, control1, control2, destination: TPointF) : TCubicBezierCurve; overload;
type
{* Definition of a Bézier curve of order 2. It has one control point }
TQuadraticBezierCurve = object
private
{** Compute the points using the simple approach of computing for each time value }
function SimpleComputePoints(AAcceptedDeviation: single = 0.1; AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
{** Computes the position where the curve has its extremum }
function ComputeExtremumPositionOutsideSegment: single;
public
{** Starting point (reached) }
p1: TPointF;
{** Control point (not reached by the curve) }
c: TPointF;
{** Ending point (reached) }
p2: TPointF;
{** Computes the point at time _t_, varying from 0 to 1 }
function ComputePointAt(t: single): TPointF;
{** Split the curve in two such that _ALeft.p2_ = _ARight.p1_ }
procedure Split(out ALeft, ARight: TQuadraticBezierCurve);
{** Compute the **exact** length of the curve }
function ComputeLength: single;
{** Computes a polygonal approximation of the curve. _AAcceptedDeviation_ indicates the
maximum orthogonal distance that is ignored and approximated by a straight line.
_AIncludeFirstPoint_ indicates if the first point must be included in the array }
function ToPoints(AAcceptedDeviation: single = 0.1; AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
{** Copy the curve to the given path }
procedure CopyToPath(ADest: IBGRAPath);
{** Computes the rectangular bounds }
function GetBounds: TRectF;
end;
{** Creates a structure for a quadratic Bézier curve }
function BezierCurve(origin, control, destination: TPointF) : TQuadraticBezierCurve; overload;
{** Creates a structure for a quadratic Bézier curve without curvature }
function BezierCurve(origin, destination: TPointF) : TQuadraticBezierCurve; overload;
type
{** Array of single-precision floating point values }
ArrayOfSingle = array of single;
{* Quasi-standard rational quadratic Bezier curve. It has one control point _c_ with a weight.
To transform a rational quadratic Bezier curve with an affin transformation, you
only have to transform the three points and leave the weight as it is. }
TRationalQuadraticBezierCurve = object
{** Starting point }
p1: TPointF;
{** Control point }
c: TPointF;
{** End point }
p2 : TPointF;
{** Weight of control point. The curve is an arc of:
- ellipse when _weight_ in ]-1; 1[
- parabola when _weight_ = 1 (classical quadratic Bezier curve)
- hyperbola when _weight_ > 1
A negative weight give the complementary curve for its positive counterpart.
So when _weight_ <= -1 the curve is discontinuous:
- infinite branches of parabola when _weight_ = -1
- infinite branches of hyperbola and symetric hyperbola when _weight_ < -1
}
weight : single;
private
{** Checks whether the curve is infinitely long }
function GetIsInfinite: boolean;
{** Compute points in the general case }
function InternalComputePoints(AInfiniteBounds: TRectF; AAcceptedDeviation: single = 0.1; AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
{** Computes the points relevant to compute bounds }
function GetBoundingPositions(AIncludeFirstAndLast: boolean; ASorted: boolean): ArrayOfSingle;
public
{** Compute a point at the specified time (_t_ in [0; 1]). The curve is defined by:
p = ((1-t)^2 * _p1_ + 2 * t * (1-t) * _weight_ * _c_ + t^2*_p2_) / (1-t)^2 + 2 * t * (1-t) * _weight_ + t^2) }
function ComputePointAt(t: single): TPointF;
{** Compute the length of the curve }
function ComputeLength(AAcceptedDeviation: single = 0.1): single;
{** Computes the points of the curve }
function ToPoints(AAcceptedDeviation: single = 0.1; AIncludeFirstPoint: boolean = true): ArrayOfTPointF; overload;
{** Computes the points of the curve by providing where the infinite curve can stop.
}
function ToPoints(AInfiniteBounds: TRectF; AAcceptedDeviation: single = 0.1; AIncludeFirstPoint: boolean = true): ArrayOfTPointF; overload;
{** Compute the rectangular bounds of the curve }
function GetBounds: TRectF;
{** Split into two curves }
procedure Split(out ALeft, ARight: TRationalQuadraticBezierCurve);
{** Is the curve infinitely long }
property IsInfinite: boolean read GetIsInfinite;
end;
{** Creates a rational Bézier curve }
function BezierCurve(origin, control, destination: TPointF; Aweight:single) : TRationalQuadraticBezierCurve; overload;
type
{* Enumerates modes for handling curves in a Bezier curve sequence }
TEasyBezierCurveMode = (
{** Automatically determines whether to curve or form an angle based on the points' positions }
cmAuto,
{** Forces a curve at the point }
cmCurve,
{** Forces an angle at the point, meaning the point is reached and forms an angle instead of a curve }
cmAngle
);
{* Function type for transforming Bezier curve points }
TEasyBezierPointTransformFunc = function(APoint: PPointF; AData: Pointer): TPointF of object;
{* @abstract(Object representing an easy-to-use Bezier curve.)
Curve is configured with approximate points,
with configurable curve modes and transformation functions }
TEasyBezierCurve = object
private
{** Retrieves the curve mode for a specified point index }
function GetCurveMode(AIndex: integer): TEasyBezierCurveMode;
{** Gets the starting point of the curve }
function GetCurveStartPoint: TPointF;
{** Retrieves the point at a specified index }
function GetPoint(AIndex: integer): TPointF;
{** Gets the total number of points in the curve }
function GetPointCount: integer;
{** Sets whether the curve is closed }
procedure SetClosed(AValue: boolean);
{** Sets the curve mode for a specified point index }
procedure SetCurveMode(AIndex: integer; AValue: TEasyBezierCurveMode);
{** Sets the minimum dot product to form a curve instead of an angle }
procedure SetMinimumDotProduct(AValue: single);
{** Sets the point at a specified index }
procedure SetPoint(AIndex: integer; AValue: TPointF);
protected
{** Computed Bézier control points }
FCurves: array of record
isCurvedToNext,isCurvedToPrevious: boolean;
Center,ControlPoint,NextCenter: TPointF;
end;
{** Whether the curve need to be recomputed }
FInvalidated: boolean;
{** Definition of the curve by the user }
FPoints: array of record
Coord: TPointF;
CurveMode: TEasyBezierCurveMode;
end;
{** Minimum dot product to form a curve instead of an angle }
FMinimumDotProduct: single;
{** Is the curve is closed }
FClosed: boolean;
{** Checks whether two vectors have the minimum dot product to suggest a curve.
_start1_ and _end1_ are the indices for the first vector.
_start2_ and _end2_ for the second vector. }
function MaybeCurve(start1, end1, start2, end2: integer): boolean;
{** Computes the control points for the classical quadratic curve }
procedure ComputeQuadraticCurves;
{** Fonction to apply no transformation }
function PointTransformNone(APoint: PPointF; {%H-}AData: Pointer): TPointF;
{** Fonction to apply an offset }
function PointTransformOffset(APoint: PPointF; AData: Pointer): TPointF;
public
{** Initializes the Bezier curve object }
procedure Init;
{** Clears all points and resets the curve }
procedure Clear;
{** Sets the points and curve mode for the entire curve }
procedure SetPoints(APoints: array of TPointF; ACurveMode: TEasyBezierCurveMode); overload;
{** Sets the points and individual curve modes for each point }
procedure SetPoints(APoints: array of TPointF; ACurveMode: array of TEasyBezierCurveMode); overload;
{** Sets a subset of points and a single curve mode for these points }
procedure SetPoints(APoints: array of TPointF; ACurveMode: TEasyBezierCurveMode; AStart, ACount: integer); overload;
{** Sets a subset of points and individual curve modes for each of these points }
procedure SetPoints(APoints: array of TPointF; ACurveMode: array of TEasyBezierCurveMode; AStart, ACount: integer); overload;
{** Copies the Bezier curve to a path object }
procedure CopyToPath(ADest: IBGRAPath); overload;
{** Copies the Bezier curve to a path object with an offset and optional reversal }
procedure CopyToPath(ADest: IBGRAPath; AOffset: TPointF; AReverse: boolean = false); overload;
{** Copies the Bezier curve to a path object with a custom transformation }
procedure CopyToPath(ADest: IBGRAPath; ATransformFunc: TEasyBezierPointTransformFunc; ATransformData: Pointer; AReverse: boolean = false); overload;
{** Coordinates of the points }
property Point[AIndex: integer]: TPointF read GetPoint write SetPoint;
{** Mode to use for each point }
property CurveMode[AIndex: integer]: TEasyBezierCurveMode read GetCurveMode write SetCurveMode;
{** Number of points }
property PointCount: integer read GetPointCount;
{** Minimum dot product to form a curve rather than an angle when using _cmAuto_ mode }
property MinimumDotProduct: single read FMinimumDotProduct write SetMinimumDotProduct;
{** Gets or sets whether to close the curve }
property Closed: boolean read FClosed write SetClosed;
{** Coordinates of the starting point }
property CurveStartPoint: TPointF read GetCurveStartPoint;
{** Converts the Bezier curve into an array of points }
function ToPoints: ArrayOfTPointF;
{** Computes the total length of the Bezier curve }
function ComputeLength: single;
end;
{** Minimum dot product, corresponding to approximately 45 degrees, to form a curve instead of an angle }
const EasyBezierDefaultMinimumDotProduct = 0.707;
{* Create a TEasyBezierCurve object with only one curve mode }
function EasyBezierCurve(APoints: array of TPointF; AClosed: boolean; ACurveMode: TEasyBezierCurveMode;
AMinimumDotProduct: single = EasyBezierDefaultMinimumDotProduct): TEasyBezierCurve; overload;
{* Create a TEasyBezierCurve object with a curve mode for each point }
function EasyBezierCurve(APoints: array of TPointF; AClosed: boolean; ACurveMode: array of TEasyBezierCurveMode;
AMinimumDotProduct: single = EasyBezierDefaultMinimumDotProduct): TEasyBezierCurve; overload;
{* Create a TEasyBezierCurve object with a subsection of the array of points, with only one curve mode }
function EasyBezierCurve(APoints: array of TPointF; AStart, ACount: integer; AClosed: boolean; ACurveMode: TEasyBezierCurveMode;
AMinimumDotProduct: single = EasyBezierDefaultMinimumDotProduct): TEasyBezierCurve; overload;
{* Create a TEasyBezierCurve object with a subsection of the array of points, with a curve mode for each point }
function EasyBezierCurve(APoints: array of TPointF; AStart, ACount: integer; AClosed: boolean; ACurveMode: array of TEasyBezierCurveMode;
AMinimumDotProduct: single = EasyBezierDefaultMinimumDotProduct): TEasyBezierCurve; overload;
{$ENDIF}
{$IFDEF INCLUDE_IMPLEMENTATION}
{$UNDEF INCLUDE_IMPLEMENTATION}
//-------------- Bézier curves definitions ----------------
// See : http://en.wikipedia.org/wiki/B%C3%A9zier_curve
// Define a Bézier curve with two control points.
function BezierCurve(origin, control1, control2, destination: TPointF): TCubicBezierCurve;
begin
result.p1 := origin;
result.c1 := control1;
result.c2 := control2;
result.p2 := destination;
end;
// Define a Bézier curve with one control point.
function BezierCurve(origin, control, destination: TPointF
): TQuadraticBezierCurve;
begin
result.p1 := origin;
result.c := control;
result.p2 := destination;
end;
//straight line
function BezierCurve(origin, destination: TPointF): TQuadraticBezierCurve;
begin
result.p1 := origin;
result.c := (origin+destination)*0.5;
result.p2 := destination;
end;
// rational Bezier curve
function BezierCurve(origin, control, destination: TPointF; Aweight:single) : TRationalQuadraticBezierCurve;
begin
result.p1 := origin;
result.c := control;
result.p2 := destination;
result.weight := Aweight;
end;
function ComputeBezierCurvePrecision(pt1, pt2, pt3, pt4: TPointF; AAcceptedDeviation: single = 0.1): integer;
var
len: single;
begin
len := sqr(pt1.x - pt2.x) + sqr(pt1.y - pt2.y);
len := max(len, sqr(pt3.x - pt2.x) + sqr(pt3.y - pt2.y));
len := max(len, sqr(pt3.x - pt4.x) + sqr(pt3.y - pt4.y));
Result := round(sqrt(sqrt(len)/ AAcceptedDeviation) * 1);
if Result<=0 then Result:=1;
end;
{ TCubicBezierCurve }
function TCubicBezierCurve.SimpleComputePoints(AAcceptedDeviation: single;
AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
var
t,step: single;
i,nb: Integer;
a,b,c: TpointF;
begin
nb := ComputeBezierCurvePrecision(p1,c1,c2,p2, AAcceptedDeviation/2);
if nb <= 1 then nb := 2;
a:=p2-p1+3*(c1-c2);
b:=3*(p1+c2)-6*c1;
c:=3*(c1-p1);
result := nil;
if AIncludeFirstPoint then
begin
setlength(result,nb);
result[0] := p1;
result[nb-1] := p2;
step := 1/(nb-1);
t := 0;
for i := 1 to nb-2 do
begin
IncF(t, step);
result[i] := p1+t*(c+t*(b+t*a))
end;
end else
begin
setlength(result,nb-1);
result[nb-2] := p2;
step := 1/(nb-1);
t := 0;
for i := 0 to nb-3 do
begin
IncF(t, step);
result[i] := p1+t*(c+t*(b+t*a))
end;
end;
end;
function TCubicBezierCurve.ComputePointAt(t: single): TPointF;
var
f1,f2,f3,f4: single;
begin
f1 := (1-t);
f2 := f1*f1;
f1 := f1 * f2;
f2 := f2 * t*3;
f4 := t*t;
f3 := f4*(1-t)*3;
f4 := f4 * t;
result.x := f1*p1.x + f2*c1.x +
f3*c2.x + f4*p2.x;
result.y := f1*p1.y + f2*c1.y +
f3*c2.y + f4*p2.y;
end;
procedure TCubicBezierCurve.Split(out ALeft, ARight: TCubicBezierCurve);
var midc: TPointF;
begin
ALeft.p1 := p1;
ALeft.c1 := 0.5*(p1+c1);
ARight.p2 := p2;
ARight.c2 := 0.5*(p2+c2);
midc := 0.5*(c1+c2);
ALeft.c2 := 0.5*(ALeft.c1+midc);
ARight.c1 := 0.5*(ARight.c2+midc);
ALeft.p2 := 0.5*(ALeft.c2+ARight.c1);
ARight.p1 := ALeft.p2;
end;
function TCubicBezierCurve.ComputeLength(AAcceptedDeviation: single): single;
var
t,step: single;
i,nb: Integer;
curCoord,nextCoord: TPointF;
begin
nb := ComputeBezierCurvePrecision(p1,c1,c2,p2, AAcceptedDeviation);
if nb <= 1 then nb := 2;
result := 0;
curCoord := p1;
step := 1/(nb-1);
t := 0;
for i := 1 to nb-2 do
begin
IncF(t, step);
nextCoord := ComputePointAt(t);
IncF(result, VectLen(nextCoord-curCoord));
curCoord := nextCoord;
end;
IncF(result, VectLen(p2-curCoord));
end;
function TCubicBezierCurve.ToPoints(AAcceptedDeviation: single;
AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
begin
result := SimpleComputePoints(AAcceptedDeviation, AIncludeFirstPoint);
end;
procedure TCubicBezierCurve.CopyToPath(ADest: IBGRAPath);
begin
ADest.lineTo(p1);
ADest.bezierCurveTo(c1,c2,p2);
end;
{//The following function computes by splitting the curve. It is slower than the simple function.
function TCubicBezierCurve.ToPoints(AAcceptedDeviation: single;
ARelativeDeviation: boolean): ArrayOfTPointF;
function ToPointsRec(const ACurve: TCubicBezierCurve): ArrayOfTPointF;
var simpleLen2: single;
v: TPointF;
left,right: TCubicBezierCurve;
subLeft,subRight: ArrayOfTPointF;
maxDev,dev1,dev2: single;
subLeftLen: integer;
procedure ComputeExtremum;
begin
raise Exception.Create('Not implemented');
result := nil;
end;
begin
v := ACurve.p2-ACurve.p1;
simpleLen2 := v*v;
if simpleLen2 = 0 then
begin
if (ACurve.c1.x = ACurve.p1.x) and (ACurve.c1.y = ACurve.p1.y) and
(ACurve.c2.x = ACurve.p2.x) and (ACurve.c2.y = ACurve.p2.y) then
begin
result := nil;
exit;
end;
ACurve.Split(left,right);
end else
begin
ACurve.Split(left,right);
if not ARelativeDeviation then simpleLen2:= sqrt(simpleLen2);
maxDev := AAcceptedDeviation*simpleLen2;
if abs(PointF(v.y,-v.x) * (left.p2-ACurve.p1)) <= maxDev then
begin
dev1 := PointF(v.y,-v.x) * (ACurve.c1-ACurve.p1);
dev2 := PointF(v.y,-v.x) * (ACurve.c2-ACurve.p2);
if not ((Sign(dev1)<>Sign(dev2)) and ((abs(dev1) > maxDev) or (abs(dev2) > maxDev))) then
begin
result := nil;
if ((ACurve.c1-ACurve.p1)*v < -maxDev) or
((ACurve.c1-ACurve.p2)*v > maxDev) or
((ACurve.c2-ACurve.p1)*v < -maxDev) or
((ACurve.c2-ACurve.p2)*v > maxDev) then
ComputeExtremum;
exit;
end;
end;
end;
subRight := ToPointsRec(right);
subLeft := ToPointsRec(left);
subLeftLen := length(subLeft);
//avoid leaving a gap in memory
result := subLeft;
subLeft := nil;
setlength(result, subLeftLen+1+length(subRight));
result[subLeftLen] := left.p2;
move(subRight[0], result[subLeftLen+1], length(subRight)*sizeof(TPointF));
end;
var
subLen: integer;
begin
if (c1.x = p1.x) and (c1.y = p1.y) and
(c1.x = c2.x) and (c1.y = c2.y) and
(c1.x = p2.x) and (c1.y = p2.y) then
begin
setlength(result,1);
result[0] := c1;
exit;
end else
begin
result := ToPointsRec(self);
subLen := length(result);
setlength(result, length(result)+2);
move(result[0], result[1], subLen*sizeof(TPointF));
result[0] := p1;
result[high(result)] := p2;
end;
end;}
function TCubicBezierCurve.GetBounds: TRectF;
const precision = 1e-5;
procedure Include(pt: TPointF);
begin
if pt.x < result.Left then result.Left := pt.x
else if pt.x > result.Right then result.Right := pt.x;
if pt.y < result.Top then result.Top := pt.y
else if pt.y > result.Bottom then result.Bottom := pt.y;
end;
procedure IncludeT(t: single);
begin
if (t > 0) and (t < 1) then
Include(ComputePointAt(t));
end;
procedure IncludeABC(a,b,c: single);
var b2ac, sqrtb2ac: single;
begin
if abs(a) < precision then
begin
if abs(b) < precision then exit;
IncludeT(-c/b);
end else
begin
b2ac := sqr(b) - 4 * a * c;
if b2ac >= 0 then
begin
sqrtb2ac := sqrt(b2ac);
IncludeT((-b + sqrtb2ac) / (2 * a));
IncludeT((-b - sqrtb2ac) / (2 * a));
end;
end;
end;
var
va, vb, vc: TPointF;
begin
result.TopLeft := p1;
result.BottomRight := p1;
Include(p2);
vb := 6 * p1 - 12 * c1 + 6 * c2;
va := -3 * p1 + 9 * c1 - 9 * c2 + 3 * p2;
vc := 3 * c1 - 3 * p1;
IncludeABC(va.x,vb.x,vc.x);
IncludeABC(va.y,vb.y,vc.y);
end;
{ TQuadraticBezierCurve }
function TQuadraticBezierCurve.SimpleComputePoints(AAcceptedDeviation: single;
AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
var
t,step: single;
i,nb: Integer;
pA,pB : TpointF;
begin
nb := ComputeBezierCurvePrecision(p1,c,c,p2, AAcceptedDeviation);
if nb <= 1 then nb := 2;
pA := p2+p1-2*c; pB := 2*(c-p1);
result := nil;
if AIncludeFirstPoint then
begin
setlength(result,nb);
result[0] := p1;
result[nb-1] := p2;
step := 1/(nb-1);
t := 0;
for i := 1 to nb-2 do
begin
IncF(t, step);
result[i] := p1+t*(pB+t*pA);
end;
end else
begin
setlength(result,nb-1);
result[nb-2] := p2;
step := 1/(nb-1);
t := 0;
for i := 0 to nb-3 do
begin
IncF(t, step);
result[i] := p1+t*(pB+t*pA);
end;
end;
end;
function TQuadraticBezierCurve.ComputeExtremumPositionOutsideSegment: single;
var a,b: single;
v: TPointF;
begin
v := self.p2-self.p1;
a := (self.p1-2*self.c+self.p2)**v;
if a = 0 then //no solution
begin
result := -1;
exit;
end;
b := (self.c-self.p1)**v;
result := -b/a;
end;
function TQuadraticBezierCurve.ComputePointAt(t: single): TPointF;
var
rev_t,f2,t2: single;
begin
rev_t := (1-t);
f2 := rev_t*t*2;
rev_t := rev_t * rev_t;
t2 := t*t;
result.x := rev_t*p1.x + f2*c.x + t2*p2.x;
result.y := rev_t*p1.y + f2*c.y + t2*p2.y;
end;
procedure TQuadraticBezierCurve.Split(out ALeft, ARight: TQuadraticBezierCurve);
begin
ALeft.p1 := p1;
ALeft.c := 0.5*(p1+c);
ARight.p2 := p2;
ARight.c := 0.5*(p2+c);
ALeft.p2 := 0.5*(ALeft.c+ARight.c);
ARight.p1 := ALeft.p2;
end;
function TQuadraticBezierCurve.ComputeLength: single;
var a,b: TPointF;
A_,AB_,B_,Sabc,A_2,A_32,B_2,BA,
divisor: single;
extremumPos: single;
extremum: TPointF;
begin
a := p1 - 2*c + p2;
b := 2*(c - p1);
A_ := 4*(a**a);
B_ := b**b;
if (A_ = 0) or (B_ = 0) then
begin
result := VectLen(p2-p1);
exit;
end;
AB_ := 4*(a**b);
A_2 := sqrt(A_);
B_2 := 2*sqrt(B_);
BA := AB_/A_2;
divisor := BA+B_2;
if divisor <= 0 then
begin
extremumPos:= ComputeExtremumPositionOutsideSegment;
if (extremumPos <= 0) or (extremumPos >= 1) then
result := VectLen(p2-p1)
else
begin
extremum := ComputePointAt(extremumPos);
result := VectLen(extremum-p1)+VectLen(p2-extremum);
end;
exit;
end;
Sabc := 2*sqrt(A_+AB_+B_);
A_32 := 2*A_*A_2;
result := ( A_32*Sabc +
A_2*AB_*(Sabc-B_2) +
(4*B_*A_-AB_*AB_)*ln( (2*A_2+BA+Sabc)/divisor )
)/(4*A_32);
end;
function TQuadraticBezierCurve.ToPoints(AAcceptedDeviation: single;
AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
begin
result := SimpleComputePoints(AAcceptedDeviation, AIncludeFirstPoint);
end;
procedure TQuadraticBezierCurve.CopyToPath(ADest: IBGRAPath);
begin
ADest.lineTo(p1);
ADest.quadraticCurveTo(c,p2);
end;
function TQuadraticBezierCurve.GetBounds: TRectF;
const precision = 1e-5;
procedure Include(pt: TPointF);
begin
if pt.x < result.Left then result.Left := pt.x
else if pt.x > result.Right then result.Right := pt.x;
if pt.y < result.Top then result.Top := pt.y
else if pt.y > result.Bottom then result.Bottom := pt.y;
end;
procedure IncludeT(t: single);
begin
if (t > 0) and (t < 1) then
Include(ComputePointAt(t));
end;
procedure IncludeABC(a,b,c: single);
var denom: single;
begin
denom := a-2*b+c;
if abs(denom) < precision then exit;
IncludeT((a-b)/denom);
end;
begin
result.TopLeft := p1;
result.BottomRight := p1;
Include(p2);
IncludeABC(p1.x,c.x,p2.x);
IncludeABC(p1.y,c.y,p2.y);
end;
{//The following function computes by splitting the curve. It is slower than the simple function
function TQuadraticBezierCurve.ToPoints(AAcceptedDeviation: single; ARelativeDeviation: boolean): ArrayOfTPointF;
function ToPointsRec(const ACurve: TQuadraticBezierCurve): ArrayOfTPointF;
var simpleLen2: single;
v: TPointF;
left,right: TQuadraticBezierCurve;
subLeft,subRight: ArrayOfTPointF;
subLeftLen: Integer;
procedure ComputeExtremum;
var
t: single;
begin
t := ACurve.ComputeExtremumPositionOutsideSegment;
if (t <= 0) or (t >= 1) then
result := nil
else
begin
setlength(result,1);
result[0] := ACurve.ComputePointAt(t);
end;
end;
begin
v := ACurve.p2-ACurve.p1;
simpleLen2 := v*v;
if simpleLen2 = 0 then
begin
if (ACurve.c.x = ACurve.p1.x) and (ACurve.c.y = ACurve.p1.y) then
begin
result := nil;
exit;
end;
ACurve.Split(left,right);
end else
begin
ACurve.Split(left,right);
if not ARelativeDeviation then simpleLen2:= sqrt(simpleLen2);
if abs(PointF(v.y,-v.x) * (left.p2-ACurve.p1))
<= AAcceptedDeviation*simpleLen2 then
begin
result := nil;
if ((ACurve.c-ACurve.p1)*v < -AAcceptedDeviation*simpleLen2) or
((ACurve.c-ACurve.p2)*v > AAcceptedDeviation*simpleLen2) then
ComputeExtremum;
exit;
end;
end;
subRight := ToPointsRec(right);
subLeft := ToPointsRec(left);
subLeftLen := length(subLeft);
//avoid leaving a gap in memory
result := subLeft;
subLeft := nil;
setlength(result, subLeftLen+1+length(subRight));
result[subLeftLen] := left.p2;
move(subRight[0], result[subLeftLen+1], length(subRight)*sizeof(TPointF));
end;
var
subLen: integer;
begin
if (c.x = p1.x) and (c.y = p1.y) and
(c.x = p2.x) and (c.y = p2.y) then
begin
setlength(result,1);
result[0] := c;
exit;
end else
begin
result := ToPointsRec(self);
subLen := length(result);
setlength(result, length(result)+2);
move(result[0], result[1], subLen*sizeof(TPointF));
result[0] := p1;
result[high(result)] := p2;
end;
end;}
{ TRationalQuadraticBezierCurve }
function TRationalQuadraticBezierCurve.GetIsInfinite: boolean;
begin
result:= (weight <= -1);
end;
function TRationalQuadraticBezierCurve.InternalComputePoints(AInfiniteBounds: TRectF; AAcceptedDeviation: single;
AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
var
pA,pB : TpointF;
a1,b1: single;
function InternalComputeAt(t: single): TPointF;
var
den: single;
begin
den := (1+t*(b1+t*a1));
if den <> 0 then
result := (p1+t*(pB+t*pA))*(1/den)
else
result := EmptyPointF
end;
procedure ComputeFactors;
var
c2 : TpointF;
c1: single;
begin
c1 := 2*weight; c2 := c1*c;
pA := p2+p1-c2; pB := -2*p1+c2;
a1 := 2-c1; b1 := -a1;
end;
function ComputeContinuous(t1,t2: single; AIncludeFirstPoint: boolean): ArrayOfTPointF;
var
pointCount: integer;
procedure AddPoint(APoint: TPointF);
begin
if isEmptyPointF(APoint) then exit;
if pointCount >= length(result) then
setlength(result, pointCount*2+4);
result[pointCount] := APoint;
inc(pointCount);
end;
procedure ComputeRec(left: single; constref leftPoint: TPointF; right: single; constref rightPoint: TPointF);
var
middlePoint, u: TPointF;
middle, lenU, deviation: Single;
begin
if rightPoint<>leftPoint then
begin
middle := (left+right)*0.5;
middlePoint := InternalComputeAt(middle);
u := rightPoint-leftPoint;
lenU := VectLen(u);
if lenU>0 then u.Scale(1/lenU);
deviation := abs((middlePoint-leftPoint)**PointF(u.y,-u.x));
if deviation > AAcceptedDeviation then
begin
ComputeRec(left, leftPoint, middle, middlePoint);
AddPoint(middlePoint);
ComputeRec(middle, middlePoint, right, rightPoint);
end else
if deviation > AAcceptedDeviation*0.6 then
AddPoint(middlePoint);
end;
end;
var
startPoint, endPoint: TPointF;
begin
pointCount := 0;
result:= nil;
startPoint := InternalComputeAt(t1);
endPoint := InternalComputeAt(t2);
if AIncludeFirstPoint then AddPoint(startPoint);
if endPoint <> startPoint then
begin
ComputeRec(t1,startPoint,t2,endPoint);
AddPoint(endPoint);
end;
setlength(result,PointCount);
end;
var
tSplitA, tSplitB, tSplit1, tSplit2, delta: single;
leftPart,middlePart,rightPart: array of TPointF;
tList: ArrayOfSingle;
parts: array of ArrayOfTPointF;
i: Integer;
function PointWithinInifiniteBounds(APoint: TPointF): boolean;
begin
result := not isEmptyPointF(APoint) and
(APoint.x > AInfiniteBounds.Left) and (APoint.x < AInfiniteBounds.Right) and
(APoint.y > AInfiniteBounds.Top) and (APoint.y < AInfiniteBounds.Bottom);
end;
begin
if weight = 0 then exit(PointsF([p1,p2]));
ComputeFactors;
if weight > -1 then
begin
tList := GetBoundingPositions(true,true);
setlength(parts, length(tList)-1);
for i := 0 to high(parts) do
parts[i] := ComputeContinuous(tList[i],tList[i+1], AIncludeFirstPoint and (i=0));
result := ConcatPointsF(parts);
end
else
if weight = -1 then
begin
tSplit1 := 0.5;
tSplitA := 0;
while PointWithinInifiniteBounds(InternalComputeAt(tSplitA)) do tSplitA := (tSplitA+tSplit1)*0.5;
tSplitB := 1;
while PointWithinInifiniteBounds(InternalComputeAt(tSplitB)) do tSplitB := (tSplitB+tSplit1)*0.5;
tList := GetBoundingPositions(true,true);
setlength(parts, length(tList)-1);
for i := 0 to high(parts) do
begin
if (tList[i] > tSplitA) and (tList[i+1] <= tSplitB) then parts[i] := nil
else
if (tList[i] <= tSplitA) and (tList[i+1] >= tSplitA) then
begin
parts[i] := ComputeContinuous(tList[i],tSplitA, AIncludeFirstPoint or (i>0));
setlength(parts[i], length(parts[i])+1);
parts[i][high(parts[i])] := EmptyPointF;
if tList[i+1] > tSplitB then
parts[i] := ConcatPointsF([parts[i], ComputeContinuous(tSplitB,tList[i+1], true)])
else
tList[i+1] := tSplitB;
end
else
if (tList[i] < tSplitB) and (tList[i+1] >= tSplitB) then
parts[i] := ComputeContinuous(tSplitB,tList[i+1], AIncludeFirstPoint or (i>0))
else
parts[i] := ComputeContinuous(tList[i],tList[i+1], AIncludeFirstPoint or (i>0));
end;
result := ConcatPointsF(parts);
end else
begin
delta:= 1 - 2/(1-weight);
tSplit1 := (1 - sqrt(delta))/2;
tSplit2 := 1-tSplit1;
tSplitA := 0;
while PointWithinInifiniteBounds(InternalComputeAt(tSplitA)) do tSplitA := (tSplitA+tSplit1)*0.5;
leftPart := ComputeContinuous(0, tSplitA, AIncludeFirstPoint);
tSplitA := (tSplit1+tSplit2)*0.5;
tSplitB := tSplitA;
while PointWithinInifiniteBounds(InternalComputeAt(tSplitA)) do tSplitA := (tSplitA+tSplit1)*0.5;
while PointWithinInifiniteBounds(InternalComputeAt(tSplitB)) do tSplitB := (tSplitB+tSplit2)*0.5;
middlePart := ComputeContinuous(tSplitA, tSplitB, true);
tSplitB := 1;
while PointWithinInifiniteBounds(InternalComputeAt(tSplitB)) do tSplitB := (tSplitB+tSplit2)*0.5;
rightPart:= ComputeContinuous(tSplitB, 1, true);
result := ConcatPointsF([leftPart, PointsF([EmptyPointF]), middlePart, PointsF([EmptyPointF]), rightPart]);
end;
end;
function TRationalQuadraticBezierCurve.GetBoundingPositions(
AIncludeFirstAndLast: boolean; ASorted: boolean): ArrayOfSingle;
const precision = 1e-6;
var a,delta,sqrtDelta,den,invDen: single;
A_,B_,p2_,c_: TPointF;
posCount : integer;
procedure Include(t: single);
var
i: Integer;
begin
if (t < 0) or (t > 1) then exit;
for i := 0 to PosCount-1 do
if result[i] = t then exit;
result[posCount] := t;
inc(posCount);
end;
procedure SortList;
var i,j,k: integer;
temp: single;
begin
for i := 1 to high(result) do
begin
j := i;
while (j > 0) and (result[j-1] > result[i]) do dec(j);
if j <> i then
begin
temp := result[i];
for k := i downto j+1 do
result[k] := result[k-1];
result[j] := temp;
end;
end;
end;
begin
result := nil;
setlength(result, 6);
posCount := 0;
if AIncludeFirstAndLast then
begin
Include(0);
Include(1);
end;
p2_ := p2-p1; c_ := c-p1; //translation with -p1
B_ := 2*weight*c_; A_ := p2_-B_;
a := 2*(1-weight);
//on Ox
den := a*p2_.x;
if abs(den) >= precision then
begin
delta := sqr(A_.x)+den*B_.x;
if delta >= 0 then
begin
invDen := 1/den;
sqrtDelta := sqrt(delta);
Include( (A_.x-sqrtDelta)*invDen );
Include( (A_.x+sqrtDelta)*invDen );
end;
end else //den=0
if abs(A_.x) >= precision then
Include( -B_.x/A_.x*0.5 );
//on Oy
den := a*p2_.y;
if abs(den) >= precision then
begin
delta := sqr(A_.y)+den*B_.y;
if delta >= 0 then
begin
invDen := 1/den;
sqrtDelta := sqrt(delta);
Include( (A_.y-sqrtDelta)*invDen );
Include( (A_.y+sqrtDelta)*invDen );
end;
end else //den=0
if abs(A_.y) >= precision then
Include( -B_.y/A_.y*0.5 );
setlength(result, posCount);
if ASorted then SortList;
end;
function TRationalQuadraticBezierCurve.ComputePointAt(t: single): TPointF;
var
rev_t,f2,t2,den: single;
begin
rev_t := (1-t);
t2 := t*t;
f2 := weight*rev_t*t*2;
rev_t := rev_t * rev_t;
den := rev_t+f2+t2;
if den <> 0 then
begin
result.x := (rev_t*p1.x + f2*c.x + t2*p2.x)/den;
result.y := (rev_t*p1.y + f2*c.y + t2*p2.y)/den;
end
else
result := EmptyPointF
end;
function TRationalQuadraticBezierCurve.ToPoints(AInfiniteBounds: TRectF; AAcceptedDeviation: single;
AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
begin
if weight=1 then
result := BezierCurve(p1,c,p2).ToPoints(AAcceptedDeviation, AIncludeFirstPoint)
else
result := InternalComputePoints(AInfiniteBounds, AAcceptedDeviation, AIncludeFirstPoint)
end;
function TRationalQuadraticBezierCurve.GetBounds: TRectF;
var a: single;
A_,B_,p2_,c_: TPointF;
t: single;
tList: array of Single;
i: Integer;
procedure Include(pt: TPointF);
begin
if pt.x < result.Left then result.Left := pt.x
else if pt.x > result.Right then result.Right := pt.x;
if pt.y < result.Top then result.Top := pt.y
else if pt.y > result.Bottom then result.Bottom := pt.y;
end;
begin
if weight=1 then exit(BezierCurve(p1,c,p2).GetBounds);
if IsInfinite then exit(EmptyRectF);
tList:= GetBoundingPositions(false,false);
result.TopLeft := p1;
result.BottomRight := p1;
Include(p2);
p2_ := p2-p1; c_ := c-p1; //translation with -p1
B_ := 2*weight*c_; A_ := p2_-B_;
a := 2*(1-weight);
for i := 0 to high(tList) do
begin
t := tList[i];
Include( p1+t*(B_+t*A_)*(1/(1+t*(-a+t*a))) );
end;
end;
function TRationalQuadraticBezierCurve.ComputeLength(AAcceptedDeviation: single): single;
var i: Integer;
curCoord,nextCoord: TPointF;
pts: ArrayOfTPointF;
begin
if weight = 1 then exit(BezierCurve(p1,c,p2).ComputeLength);
if weight <= -1 then exit(EmptySingle); // no bounds in this case
pts := InternalComputePoints(EmptyRectF, AAcceptedDeviation, true);
curCoord := p1; result:=0;
for i := 1 to high(pts) do
begin
nextCoord := pts[i];
if (nextCoord <> EmptyPointF) and (curCoord <> EmptyPointF) then
IncF(result, VectLen(nextCoord-curCoord));
curCoord := nextCoord;
end;
finalize(pts)
end;
function TRationalQuadraticBezierCurve.ToPoints(AAcceptedDeviation: single;
AIncludeFirstPoint: boolean): ArrayOfTPointF;
begin
result := ToPoints(RectF(-64,-64, 16384, 16384), AAcceptedDeviation, AIncludeFirstPoint);
end;
procedure TRationalQuadraticBezierCurve.Split(out ALeft, ARight: TRationalQuadraticBezierCurve);
const precision=1E-6;
var M, D, E, H, c1, c2: TPointF;
alpha, sg, w: single;
function Intersec(): TPointF; //dichotomie
var t, t1, t2: single;
U, V: TPointF;
begin
t1 := 0; t2 := 0.5; U := E-c1;
if VectDet(U,p1-c1)>0 then sg := 1 else sg := -1;
while (t2-t1) > precision do //19 iterations
begin
t := (t1+t2)/2;
V := ComputePointAt(t)-c1;
if VectDet(U,V)*sg>0 then t1 := t else t2 := t;
end;
result := ComputePointAt((t1+t2)/2)
end;
begin
if IsInfinite then raise exception.Create('Cannot split an infinite curve');
M := ComputePointAt(0.5);
ALeft.p1 := p1;
ALeft.p2 := M;
ARight.p1 := M;
ARight.p2 := p2;
ALeft.weight := 1;
ARight.weight := 1;
D := 0.5*(p1+p2);
if (weight = 1) or (D = c) then
begin
ALeft.c := 0.5*(p1+c);
ARight.c := 0.5*(p2+c);
exit;
end;
if weight > 0 then
alpha := VectLen(D-M)/VectLen(D-c)
else
alpha := -VectLen(D-M)/VectLen(D-c);
c1 := p1 + alpha*(c-p1);
c2 := p2 + alpha*(c-p2);
ALeft.c := c1;
ARight.c := c2;
E := 0.5*(p1+M);
H := Intersec(); //between [c1;E] and the curve
w := VectLen(E-c1)/VectLen(H-c1)-1; // new weight
ALeft.weight := w;
ARight.weight := w;
end;
{ TEasyBezierCurve }
function EasyBezierCurve(APoints: array of TPointF; AClosed: boolean;
ACurveMode: TEasyBezierCurveMode; AMinimumDotProduct: single): TEasyBezierCurve;
begin
result := EasyBezierCurve(APoints, 0, length(APoints), AClosed, ACurveMode, AMinimumDotProduct);
end;
function EasyBezierCurve(APoints: array of TPointF; AClosed: boolean;
gitextract_smpcvqwr/
├── .github/
│ ├── FUNDING.yml
│ ├── dependabot.yml
│ └── workflows/
│ ├── make.pas
│ └── make.yml
├── .gitignore
├── .gitmodules
├── COPYING.LGPL.txt
├── COPYING.modifiedLGPL.txt
├── Makefile
├── bglcontrols/
│ ├── bglcontrols.lpk
│ ├── bglcontrols.pas
│ ├── bglvirtualscreen.pas
│ └── bglvirtualscreen_icon.lrs
├── bgrabitmap/
│ ├── avifbgra.pas
│ ├── basiccolorspace.inc
│ ├── bezier.inc
│ ├── bgraanimatedgif.pas
│ ├── bgraarrow.pas
│ ├── bgrabitmap.inc
│ ├── bgrabitmap.pas
│ ├── bgrabitmappack.lpk
│ ├── bgrabitmappack.pas
│ ├── bgrabitmappack4android.lpk
│ ├── bgrabitmappack4android.pas
│ ├── bgrabitmappack4android_freetype.lpk
│ ├── bgrabitmappack4android_freetype.pas
│ ├── bgrabitmappack4fpgui.lpk
│ ├── bgrabitmappack4fpgui.pas
│ ├── bgrabitmappack4nogui.lpk
│ ├── bgrabitmappack4nogui.pas
│ ├── bgrabitmappack4nolcl.lpk
│ ├── bgrabitmappack4nolcl.pas
│ ├── bgrabitmappack4nolcl_freetype.lpk
│ ├── bgrabitmappack4nolcl_freetype.pas
│ ├── bgrabitmaptypes.pas
│ ├── bgrablend.pas
│ ├── bgrablurgl.pas
│ ├── bgracanvas.pas
│ ├── bgracanvas2d.pas
│ ├── bgracanvasgl.pas
│ ├── bgraclasses.pas
│ ├── bgracolorint.pas
│ ├── bgracolorquantization.pas
│ ├── bgracompressablebitmap.pas
│ ├── bgracoordpool3d.pas
│ ├── bgracustombitmap.inc
│ ├── bgracustomtextfx.pas
│ ├── bgradefaultbitmap.pas
│ ├── bgradithering.pas
│ ├── bgradnetdeserial.pas
│ ├── bgrafillinfo.pas
│ ├── bgrafilterblur.pas
│ ├── bgrafilters.pas
│ ├── bgrafilterscanner.pas
│ ├── bgrafiltertype.pas
│ ├── bgrafontgl.pas
│ ├── bgrafpcanvas.inc
│ ├── bgrafpgui.inc
│ ├── bgrafpgui_uses.inc
│ ├── bgrafpguibitmap.pas
│ ├── bgrafreetype.pas
│ ├── bgragifformat.pas
│ ├── bgragradientoriginal.pas
│ ├── bgragradients.pas
│ ├── bgragradientscanner.pas
│ ├── bgragraphics.pas
│ ├── bgragrayscalemask.pas
│ ├── bgragtkbitmap.pas
│ ├── bgraiconcursor.pas
│ ├── bgralayeroriginal.pas
│ ├── bgralayers.pas
│ ├── bgralazpaint.pas
│ ├── bgralazresource.pas
│ ├── bgralclbitmap.pas
│ ├── bgralzpcommon.pas
│ ├── bgramacbitmap.pas
│ ├── bgramatrix3d.pas
│ ├── bgramemdirectory.pas
│ ├── bgramsegui.inc
│ ├── bgramsegui_text.inc
│ ├── bgramsegui_uses.inc
│ ├── bgramseguibitmap.pas
│ ├── bgramultifiletype.pas
│ ├── bgranogui.inc
│ ├── bgranogui_uses.inc
│ ├── bgranoguibitmap.pas
│ ├── bgraopengl.pas
│ ├── bgraopengl3d.pas
│ ├── bgraopengltype.pas
│ ├── bgraopenraster.pas
│ ├── bgrapaintnet.pas
│ ├── bgrapalette.pas
│ ├── bgrapapers.pas
│ ├── bgrapath.pas
│ ├── bgrapdf.pas
│ ├── bgrapen.pas
│ ├── bgraphongtypes.pas
│ ├── bgraphoxo.pas
│ ├── bgrapixel.inc
│ ├── bgrapngcomn.pas
│ ├── bgrapolygon.pas
│ ├── bgrapolygonaliased.pas
│ ├── bgraqtbitmap.pas
│ ├── bgrareadavif.pas
│ ├── bgrareadbmp.pas
│ ├── bgrareadbmpmiomap.pas
│ ├── bgrareadgif.pas
│ ├── bgrareadico.pas
│ ├── bgrareadjpeg.pas
│ ├── bgrareadlzp.pas
│ ├── bgrareadpcx.pas
│ ├── bgrareadpng.pas
│ ├── bgrareadpsd.pas
│ ├── bgrareadtga.pas
│ ├── bgrareadtiff.pas
│ ├── bgrareadwebp.pas
│ ├── bgrareadxpm.pas
│ ├── bgrarenderer3d.pas
│ ├── bgraresample.pas
│ ├── bgrascanner.inc
│ ├── bgrascene3d.pas
│ ├── bgrascenetypes.pas
│ ├── bgraslicescaling.pas
│ ├── bgraspritegl.pas
│ ├── bgrasse.inc
│ ├── bgrasse.pas
│ ├── bgrastreamlayers.pas
│ ├── bgrasvg.pas
│ ├── bgrasvgoriginal.pas
│ ├── bgrasvgshapes.pas
│ ├── bgrasvgtype.pas
│ ├── bgratext.pas
│ ├── bgratextbidi.pas
│ ├── bgratextfx.pas
│ ├── bgrathumbnail.pas
│ ├── bgratransform.pas
│ ├── bgratypewriter.pas
│ ├── bgraunicode.pas
│ ├── bgraunicodetext.pas
│ ├── bgraunits.pas
│ ├── bgrautf8.pas
│ ├── bgravectorize.pas
│ ├── bgrawinbitmap.pas
│ ├── bgrawinresource.pas
│ ├── bgrawriteavif.pas
│ ├── bgrawritebmp.pas
│ ├── bgrawritebmpmiomap.pas
│ ├── bgrawritejpeg.pas
│ ├── bgrawritelzp.pas
│ ├── bgrawritepcx.pas
│ ├── bgrawritepng.pas
│ ├── bgrawritetiff.pas
│ ├── bgrawritewebp.pas
│ ├── blendpixelinline.inc
│ ├── blendpixels.inc
│ ├── blendpixelsover.inc
│ ├── blurbox.inc
│ ├── blurfast.inc
│ ├── blurnormal.inc
│ ├── csscolorconst.inc
│ ├── darwinlib.pas
│ ├── density256.inc
│ ├── expandedbitmap.pas
│ ├── extendedcolorspace.inc
│ ├── face3d.inc
│ ├── generatedcolorspace.inc
│ ├── generatedunicode.inc
│ ├── generatedutf8.inc
│ ├── geometrytypes.inc
│ ├── libavif.pas
│ ├── libwebp.pas
│ ├── lightingclasses3d.inc
│ ├── linearrgbabitmap.pas
│ ├── lineartexscan.inc
│ ├── lineartexscan2.inc
│ ├── linuxlib.pas
│ ├── multishapeline.inc
│ ├── object3d.inc
│ ├── paletteformats.inc
│ ├── part3d.inc
│ ├── perspectivecolorscan.inc
│ ├── perspectivescan.inc
│ ├── perspectivescan2.inc
│ ├── phongdraw.inc
│ ├── phongdrawsse.inc
│ ├── phonglight.inc
│ ├── phonglightsse.inc
│ ├── polyaliaspersp.inc
│ ├── readme.txt
│ ├── shapes3d.inc
│ ├── spectraldata.inc
│ ├── unibitmap.inc
│ ├── unibitmapgeneric.inc
│ ├── universaldrawer.pas
│ ├── unzipperext.pas
│ ├── uunittest.pas
│ ├── vertex3d.inc
│ ├── wordxyzabitmap.pas
│ └── xyzabitmap.pas
├── commit.sh
├── dev/
│ ├── assistant/
│ │ └── builddata.py
│ ├── colorspace/
│ │ ├── generatecolorspaces.lpi
│ │ ├── generatecolorspaces.lpr
│ │ └── unitmakerunit.pas
│ ├── makedoc/
│ │ ├── pmakedoc.lpi
│ │ ├── pmakedoc.lpr
│ │ ├── readme.txt
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── parseunicode/
│ │ ├── ArabicShaping.txt
│ │ ├── BidiBrackets.txt
│ │ ├── BidiCharacterTest.result
│ │ ├── BidiCharacterTest.txt
│ │ ├── BidiMirroring.txt
│ │ ├── UnicodeData.txt
│ │ ├── parseunicodeclasses.lpi
│ │ ├── parseunicodeclasses.lpr
│ │ ├── testunicodealgo.lpi
│ │ └── testunicodealgo.lpr
│ ├── readme.txt
│ └── releaser/
│ ├── archiveurl.pas
│ ├── bgrabitmap.logic
│ ├── constfile.pas
│ ├── copyfile.pas
│ ├── macbundle.pas
│ ├── managerfile.pas
│ ├── packagefile.pas
│ ├── projectfile.pas
│ ├── releaser.lpi
│ ├── releaser.lpr
│ ├── releasertypes.pas
│ └── textline.pas
├── doc/
│ ├── dot.bat
│ ├── generate.bat
│ ├── generate.sh
│ ├── introduction.txt
│ ├── navigation.js
│ ├── pasdoc.cfg
│ ├── pasdoc.css
│ ├── readme.md
│ └── units.txt
├── libwebp/
│ └── readme.md
├── readme.md
├── test/
│ ├── bgraaggtest/
│ │ ├── aa_demo.lpi
│ │ ├── aa_demo.lpr
│ │ ├── aa_demo_main.lfm
│ │ ├── aa_demo_main.pas
│ │ ├── alpha_gradient.lpi
│ │ ├── alpha_gradient.lpr
│ │ ├── alpha_gradient_main.lfm
│ │ ├── alpha_gradient_main.pas
│ │ ├── blur.lpi
│ │ ├── blur.lpr
│ │ ├── blur_main.lfm
│ │ ├── blur_main.pas
│ │ ├── bspline.lpi
│ │ ├── bspline.lpr
│ │ ├── bspline_main.lfm
│ │ ├── bspline_main.pas
│ │ ├── distortions.lpi
│ │ ├── distortions.lpr
│ │ ├── distortions_main.lfm
│ │ ├── distortions_main.pas
│ │ ├── gouraud.lpi
│ │ ├── gouraud.lpr
│ │ ├── gouraud_main.lfm
│ │ ├── gouraud_main.pas
│ │ ├── image_filters2.lpi
│ │ ├── image_filters2.lpr
│ │ ├── image_filters2_main.lfm
│ │ ├── image_filters2_main.pas
│ │ ├── image_perspective.lpi
│ │ ├── image_perspective.lpr
│ │ ├── image_perspective_main.lfm
│ │ └── image_perspective_main.pas
│ ├── bgralape/
│ │ ├── basic_functions.inc
│ │ ├── basic_geometry_functions.inc
│ │ ├── bgralapesys.pas
│ │ ├── color_functions.inc
│ │ ├── extended_geometry_functions.inc
│ │ ├── lape.func
│ │ ├── lape.proc
│ │ ├── pbgralape.lpi
│ │ ├── pbgralape.lpr
│ │ ├── tests.pas
│ │ ├── text_functions.inc
│ │ ├── ubgralape.pas
│ │ ├── umain.lfm
│ │ └── umain.pas
│ ├── bgratutorial3d/
│ │ ├── bgratutorial3d.lpi
│ │ ├── bgratutorial3d.lpr
│ │ ├── bgratutorial3dsoftware.lpi
│ │ ├── bgratutorial3dsoftware.lpr
│ │ ├── ex1.pas
│ │ ├── ex2.pas
│ │ ├── ex3.pas
│ │ ├── ex4.pas
│ │ ├── ex5.pas
│ │ ├── obj/
│ │ │ ├── airboat.obj
│ │ │ ├── al.obj
│ │ │ ├── cessna.obj
│ │ │ ├── ciseau.obj
│ │ │ ├── cube.obj
│ │ │ ├── diamond.obj
│ │ │ ├── dodecahedron.obj
│ │ │ ├── fourche.obj
│ │ │ ├── gourd.obj
│ │ │ ├── helice.obj
│ │ │ ├── helico.obj
│ │ │ ├── lampe.obj
│ │ │ ├── magnolia.obj
│ │ │ ├── mario.obj
│ │ │ ├── pelle.obj
│ │ │ ├── roue.obj
│ │ │ ├── sandal.obj
│ │ │ ├── shuttle.obj
│ │ │ ├── teapot.obj
│ │ │ ├── trumpet.obj
│ │ │ └── violin_case.obj
│ │ ├── ubgrasamples.pas
│ │ ├── umain.lfm
│ │ ├── umain.pas
│ │ └── utexture.pas
│ ├── colorspace/
│ │ ├── ColorsDemo.lpi
│ │ ├── ColorsDemo.lpr
│ │ ├── HorseShoe.lpi
│ │ ├── HorseShoe.lpr
│ │ ├── bgracolorex.pas
│ │ ├── colorsdemounit.lfm
│ │ ├── colorsdemounit.pas
│ │ ├── uhorseshoe.lfm
│ │ └── uhorseshoe.pas
│ ├── createbitmap/
│ │ ├── createbitmap.lpi
│ │ ├── createbitmap.lpr
│ │ ├── umain.lfm
│ │ └── umain.pas
│ ├── gammafactor/
│ │ ├── gammafactor.lpi
│ │ ├── gammafactor.lpr
│ │ ├── umain.lfm
│ │ └── umain.pas
│ ├── layeroriginal/
│ │ ├── layeroriginal.lpi
│ │ ├── layeroriginal.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── rationalbezier/
│ │ ├── rationalbezier.lpi
│ │ ├── rationalbezier.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── test4ideu/
│ │ └── fractal_tree/
│ │ ├── fractal_tree.pas
│ │ ├── fractal_tree.prj
│ │ ├── main.mfm
│ │ ├── main.pas
│ │ └── main_mfm.pas
│ ├── test4lcl/
│ │ ├── test4lcl.lpi
│ │ ├── test4lcl.lpr
│ │ ├── umain.lfm
│ │ └── umain.pas
│ ├── test4lcl_opengl/
│ │ ├── opengltest0/
│ │ │ ├── ptestvirtualscreen.lpi
│ │ │ ├── ptestvirtualscreen.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ ├── opengltest1/
│ │ │ ├── opengltest1.lpi
│ │ │ ├── opengltest1.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ ├── opengltest2/
│ │ │ ├── opengltest2.lpi
│ │ │ ├── opengltest2.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ ├── opengltest3/
│ │ │ ├── opengltest3.lpi
│ │ │ ├── opengltest3.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ ├── opengltest4/
│ │ │ ├── opengltest4.lpi
│ │ │ ├── opengltest4.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ ├── opengltest5/
│ │ │ ├── ptestvirtualscreen.lpi
│ │ │ ├── ptestvirtualscreen.lpr
│ │ │ ├── unit1.lfm
│ │ │ └── unit1.pas
│ │ └── tux_game/
│ │ ├── mainunit.lfm
│ │ ├── mainunit.pas
│ │ ├── tux_game.lpi
│ │ ├── tux_game.lpr
│ │ └── ugame.pas
│ ├── test4other/
│ │ ├── test4fpgui.lpi
│ │ ├── test4fpgui.lpr
│ │ ├── test4nogui.lpi
│ │ ├── test4nogui.lpr
│ │ ├── test4nolcl.lpi
│ │ ├── test4nolcl.lpr
│ │ ├── test4nolcl_freetype.lpi
│ │ ├── test4nolcl_freetype.lpr
│ │ └── zengl/
│ │ ├── 06 - Text (BGRABitmap)/
│ │ │ ├── demo06.lpi
│ │ │ ├── demo06.lpr
│ │ │ ├── demo06_macosx.lpi
│ │ │ ├── demo06_macosx.plist
│ │ │ └── macosx_postbuild.sh
│ │ ├── 07 - Sprites (BGRABitmap)/
│ │ │ ├── demo07.lpi
│ │ │ ├── demo07.lpr
│ │ │ ├── demo07_macosx.lpi
│ │ │ ├── demo07_macosx.plist
│ │ │ └── macosx_postbuild.sh
│ │ ├── 08 - Sprite Engine (BGRABitmap)/
│ │ │ ├── demo08.lpi
│ │ │ ├── demo08.lpr
│ │ │ ├── demo08_macosx.lpi
│ │ │ ├── demo08_macosx.plist
│ │ │ └── macosx_postbuild.sh
│ │ ├── bgrazengl.pas
│ │ └── readme.txt
│ ├── testbgrafunc/
│ │ ├── COPYING.LGPL.txt
│ │ ├── COPYING.modifiedLGPL.txt
│ │ ├── readme.txt
│ │ ├── testbgrafunc.lpi
│ │ ├── testbgrafunc.lpr
│ │ ├── ucube3d.pas
│ │ ├── umain.lfm
│ │ ├── umain.lrs
│ │ ├── umain.pas
│ │ ├── utest.pas
│ │ ├── utest1.pas
│ │ ├── utest10.pas
│ │ ├── utest11.pas
│ │ ├── utest14.pas
│ │ ├── utest15.pas
│ │ ├── utest16.pas
│ │ ├── utest17.pas
│ │ ├── utest18.pas
│ │ ├── utest19.pas
│ │ ├── utest2.pas
│ │ ├── utest22.pas
│ │ ├── utest23.pas
│ │ ├── utest24.pas
│ │ ├── utest25.pas
│ │ ├── utest26.pas
│ │ ├── utest27.pas
│ │ ├── utest3.pas
│ │ ├── utest31.pas
│ │ ├── utest32.pas
│ │ ├── utest33.pas
│ │ ├── utest4.pas
│ │ ├── utest5.pas
│ │ ├── utest6.pas
│ │ ├── utest7.pas
│ │ ├── utest8.pas
│ │ ├── utest9.pas
│ │ ├── utestback.pas
│ │ ├── utestpacrect.pas
│ │ ├── utexture.pas
│ │ └── utore3d.pas
│ ├── testbiditext/
│ │ ├── project1.lpi
│ │ ├── project1.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── testbiditext2/
│ │ ├── project1.lpi
│ │ ├── project1.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── testcanvas2d/
│ │ ├── testcanvas2D.lpi
│ │ ├── testcanvas2D.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ ├── testcore/
│ │ ├── arial.glyphs
│ │ ├── createfont.lpi
│ │ ├── createfont.lpr
│ │ ├── testcore.lpi
│ │ └── testcore.lpr
│ ├── testgif/
│ │ ├── project1.lpi
│ │ ├── project1.lpr
│ │ ├── project2.lpi
│ │ ├── project2.lpr
│ │ ├── unit1.lfm
│ │ ├── unit1.pas
│ │ ├── unit2.lfm
│ │ └── unit2.pas
│ ├── testglyph/
│ │ ├── testglyph.lpi
│ │ ├── testglyph.lpr
│ │ ├── umain.lfm
│ │ └── umain.pas
│ ├── testsvg/
│ │ ├── testsvg.lpi
│ │ ├── testsvg.lpr
│ │ ├── unit1.lfm
│ │ ├── unit1.pas
│ │ └── uprofiler.pas
│ ├── testvirtualscreen/
│ │ ├── project1.lpi
│ │ ├── project1.lpr
│ │ ├── unit1.lfm
│ │ └── unit1.pas
│ └── vectorize/
│ ├── umain.lfm
│ ├── umain.pas
│ ├── vectorize.lpi
│ └── vectorize.lpr
├── update_BGRABitmap.json
└── winmake/
├── copyfile.bat
├── remove.bat
└── removedir.bat
SYMBOL INDEX (1 symbols across 1 files) FILE: dev/assistant/builddata.py function gather_method_signatures (line 7) | def gather_method_signatures(source_dir):
Copy disabled (too large)
Download .json
Condensed preview — 497 files, each showing path, character count, and a content snippet. Download the .json file for the full structured content (18,653K chars).
[
{
"path": ".github/FUNDING.yml",
"chars": 772,
"preview": "# These are supported funding model platforms\n\ngithub: # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [u"
},
{
"path": ".github/dependabot.yml",
"chars": 123,
"preview": "---\nversion: 2\nupdates:\n - package-ecosystem: \"github-actions\"\n directory: \"/\"\n schedule:\n interval: \"monthl"
},
{
"path": ".github/workflows/make.pas",
"chars": 5313,
"preview": "program Make;\n{$mode objfpc}{$H+}\n\nuses\n Classes,\n SysUtils,\n StrUtils,\n FileUtil,\n Zipper,\n fphttpclient,\n RegEx"
},
{
"path": ".github/workflows/make.yml",
"chars": 2501,
"preview": "---\nname: Make\n\non:\n schedule:\n - cron: '0 0 1 * *'\n push:\n branches:\n - \"**\"\n pull_request:\n "
},
{
"path": ".gitignore",
"chars": 706,
"preview": "*.bak\n*.dbg\n*.exe\n*.lps\n*.res\n*.lrt\n*.bak1\n*.app\n.DS_Store\nbackup\nlib\nbin\ndebug\n/bgrabitmap/lib4nogui\n/bgrabitmap/lib4fp"
},
{
"path": ".gitmodules",
"chars": 181,
"preview": "[submodule \"use/fpGUI\"]\n path = use/fpGUI\n url = https://github.com/graemeg/fpGUI.git\n[submodule \"use/lape\"]\n p"
},
{
"path": "COPYING.LGPL.txt",
"chars": 7650,
"preview": " GNU LESSER GENERAL PUBLIC LICENSE\n Version 3, 29 June 2007\n\n Copyright (C) 2007"
},
{
"path": "COPYING.modifiedLGPL.txt",
"chars": 1095,
"preview": "This is the file COPYING.modifiedLGPL, it applies to all units of the\nBGRABitmap library.\n\nThese files are distributed u"
},
{
"path": "Makefile",
"chars": 2437,
"preview": "ifeq ($(OS),Windows_NT) # true for Windows_NT or later\n COPY := winmake\\copyfile\n REMOVE := winmake\\remove\n REMOV"
},
{
"path": "bglcontrols/bglcontrols.lpk",
"chars": 1961,
"preview": "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<CONFIG>\n <Package Version=\"4\">\n <PathDelim Value=\"\\\"/>\n <Name Value=\"BGLC"
},
{
"path": "bglcontrols/bglcontrols.pas",
"chars": 383,
"preview": "{ This file was automatically created by Lazarus. Do not edit!\n This source is only used to compile and install the pac"
},
{
"path": "bglcontrols/bglvirtualscreen.pas",
"chars": 12557,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\nunit BGLVirtualScreen;\n\n{$mode objfpc}{$H+}\n\ninterface\n\nuses\n Cl"
},
{
"path": "bglcontrols/bglvirtualscreen_icon.lrs",
"chars": 3640,
"preview": "LazarusResources.Add('TBGLVirtualScreen','PNG',[\n #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#3#0#0#0#215#"
},
{
"path": "bgrabitmap/avifbgra.pas",
"chars": 58702,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\r\n\r\n{ @abstract(Easy to use classes and functions to read/write im"
},
{
"path": "bgrabitmap/basiccolorspace.inc",
"chars": 61738,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\ntype\n {* P"
},
{
"path": "bgrabitmap/bezier.inc",
"chars": 47951,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\n{=== Geomet"
},
{
"path": "bgrabitmap/bgraanimatedgif.pas",
"chars": 57935,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{ Classes to read and write animated GIF and animated PNG files. "
},
{
"path": "bgrabitmap/bgraarrow.pas",
"chars": 16463,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Computation of arrow paths.)\n\n Arrows are appended "
},
{
"path": "bgrabitmap/bgrabitmap.inc",
"chars": 1162,
"preview": "{$DEFINE BGRABITMAP}\n{ You can define the following compiler directives in the package options,\n in tab Compiler option"
},
{
"path": "bgrabitmap/bgrabitmap.pas",
"chars": 22581,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Provides the 32-bit RGBA bitmap type adapted to your"
},
{
"path": "bgrabitmap/bgrabitmappack.lpk",
"chars": 19404,
"preview": "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<CONFIG>\n <Package Version=\"5\">\n <PathDelim Value=\"\\\"/>\n <Name Value=\"BGRA"
},
{
"path": "bgrabitmap/bgrabitmappack.pas",
"chars": 1964,
"preview": "{ This file was automatically created by Lazarus. Do not edit!\n This source is only used to compile and install the pac"
},
{
"path": "bgrabitmap/bgrabitmappack4android.lpk",
"chars": 13951,
"preview": "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<CONFIG>\n <Package Version=\"5\">\n <PathDelim Value=\"\\\"/>\n <Name Value=\"BGRA"
},
{
"path": "bgrabitmap/bgrabitmappack4android.pas",
"chars": 1393,
"preview": "{ This file was automatically created by Lazarus. Do not edit!\n This source is only used to compile and install the pac"
},
{
"path": "bgrabitmap/bgrabitmappack4android_freetype.lpk",
"chars": 14018,
"preview": "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<CONFIG>\n <Package Version=\"5\">\n <PathDelim Value=\"\\\"/>\n <Name Value=\"BGRA"
},
{
"path": "bgrabitmap/bgrabitmappack4android_freetype.pas",
"chars": 1416,
"preview": "{ This file was automatically created by Lazarus. Do not edit!\n This source is only used to compile and install the pac"
},
{
"path": "bgrabitmap/bgrabitmappack4fpgui.lpk",
"chars": 13853,
"preview": "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<CONFIG>\n <Package Version=\"5\">\n <PathDelim Value=\"\\\"/>\n <Name Value=\"BGRA"
},
{
"path": "bgrabitmap/bgrabitmappack4fpgui.pas",
"chars": 1358,
"preview": "{ This file was automatically created by Lazarus. Do not edit!\n This source is only used to compile and install the pac"
},
{
"path": "bgrabitmap/bgrabitmappack4nogui.lpk",
"chars": 14338,
"preview": "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<CONFIG>\n <Package Version=\"5\">\n <PathDelim Value=\"\\\"/>\n <Name Value=\"BGRA"
},
{
"path": "bgrabitmap/bgrabitmappack4nogui.pas",
"chars": 1426,
"preview": "{ This file was automatically created by Lazarus. Do not edit!\n This source is only used to compile and install the pac"
},
{
"path": "bgrabitmap/bgrabitmappack4nolcl.lpk",
"chars": 18733,
"preview": "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<CONFIG>\n <Package Version=\"5\">\n <PathDelim Value=\"\\\"/>\n <Name Value=\"BGRA"
},
{
"path": "bgrabitmap/bgrabitmappack4nolcl.pas",
"chars": 1915,
"preview": "{ This file was automatically created by Lazarus. Do not edit!\r\n This source is only used to compile and install the pa"
},
{
"path": "bgrabitmap/bgrabitmappack4nolcl_freetype.lpk",
"chars": 18908,
"preview": "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<CONFIG>\n <Package Version=\"5\">\n <PathDelim Value=\"\\\"/>\n <Name Value=\"BGRA"
},
{
"path": "bgrabitmap/bgrabitmappack4nolcl_freetype.pas",
"chars": 1901,
"preview": "{ This file was automatically created by Lazarus. Do not edit!\n This source is only used to compile and install the pac"
},
{
"path": "bgrabitmap/bgrabitmaptypes.pas",
"chars": 66199,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Basic types for BGRABitmap.)\n\n This unit is general"
},
{
"path": "bgrabitmap/bgrablend.pas",
"chars": 62392,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Pixel blending functions for 32-bit BGRA/RGBA.)\n\n P"
},
{
"path": "bgrabitmap/bgrablurgl.pas",
"chars": 6771,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Blur effect using OpenGL shaders }\nunit BGRABlurGL;\n\n{$mode ob"
},
{
"path": "bgrabitmap/bgracanvas.pas",
"chars": 55452,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Equivalent of LCL Canvas but with transparency and gamma corre"
},
{
"path": "bgrabitmap/bgracanvas2d.pas",
"chars": 104592,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Equivalent to HTML Canvas (supports affine transform"
},
{
"path": "bgrabitmap/bgracanvasgl.pas",
"chars": 67012,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Canvas that can be used with OpenGL (2D, 3D and lighting shade"
},
{
"path": "bgrabitmap/bgraclasses.pas",
"chars": 7230,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Basic Pascal types regardless of the framework (LCL, no LCL, M"
},
{
"path": "bgrabitmap/bgracolorint.pas",
"chars": 9319,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Colors stored as integers with maximum value 65536 but allowin"
},
{
"path": "bgrabitmap/bgracolorquantization.pas",
"chars": 65567,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Color quantization i.e. the reduction to a palette using dithe"
},
{
"path": "bgrabitmap/bgracompressablebitmap.pas",
"chars": 9554,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Class to temporarily compress bitmaps in memory and serialize "
},
{
"path": "bgrabitmap/bgracoordpool3d.pas",
"chars": 11610,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Pools of coordinates, to be transformed using SSE instructions"
},
{
"path": "bgrabitmap/bgracustombitmap.inc",
"chars": 106571,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\ntype\n{=== T"
},
{
"path": "bgrabitmap/bgracustomtextfx.pas",
"chars": 20881,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Computation of text effects based on a text mask }\nunit BGRACu"
},
{
"path": "bgrabitmap/bgradefaultbitmap.pas",
"chars": 177055,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Implements basic operations on bitmaps (not optimize"
},
{
"path": "bgrabitmap/bgradithering.pas",
"chars": 27309,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implements the dithering algorithms }\nunit BGRADithering;\n\n{$m"
},
{
"path": "bgrabitmap/bgradnetdeserial.pas",
"chars": 45371,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Read .Net serialized classes)\n\n Serialization is a "
},
{
"path": "bgrabitmap/bgrafillinfo.pas",
"chars": 47554,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Generic class to hold a shape to be filled as well as the impl"
},
{
"path": "bgrabitmap/bgrafilterblur.pas",
"chars": 38758,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Various blur tasks implemented with software (using regular CP"
},
{
"path": "bgrabitmap/bgrafilters.pas",
"chars": 33994,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Filters that can be applied to a bitmap. The filters\n take a "
},
{
"path": "bgrabitmap/bgrafilterscanner.pas",
"chars": 26115,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Provide scanners that act as filters. This allows to use them "
},
{
"path": "bgrabitmap/bgrafiltertype.pas",
"chars": 14455,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Generic classes for tasks. Those are computations that can be "
},
{
"path": "bgrabitmap/bgrafontgl.pas",
"chars": 20089,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Font rendering in OpenGL with caching of textures for each gly"
},
{
"path": "bgrabitmap/bgrafpcanvas.inc",
"chars": 7755,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\n\ntype\n {* "
},
{
"path": "bgrabitmap/bgrafpgui.inc",
"chars": 2274,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\ntype\n TCol"
},
{
"path": "bgrabitmap/bgrafpgui_uses.inc",
"chars": 57,
"preview": "uses BGRAClasses, FPImage, FPCanvas, fpg_base, fpg_main;\n"
},
{
"path": "bgrabitmap/bgrafpguibitmap.pas",
"chars": 8702,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of BGRABitmap for fpGUI }\nunit BGRAfpGUIBitmap;"
},
{
"path": "bgrabitmap/bgrafreetype.pas",
"chars": 51380,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Font renderer of FreeType fonts using Lazarus render"
},
{
"path": "bgrabitmap/bgragifformat.pas",
"chars": 35895,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Structure and algorithms to read/write GIF files }\nunit BGRAGi"
},
{
"path": "bgrabitmap/bgragradientoriginal.pas",
"chars": 33558,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Original that renders a gradient. Originals can be used in a l"
},
{
"path": "bgrabitmap/bgragradients.pas",
"chars": 46875,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Helper functions for gradients and shadows, as well as Phong s"
},
{
"path": "bgrabitmap/bgragradientscanner.pas",
"chars": 86965,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Scanners that generate gradients. This allows to use gradients"
},
{
"path": "bgrabitmap/bgragraphics.pas",
"chars": 22643,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Imports type from Graphics, if available, or defines equivalen"
},
{
"path": "bgrabitmap/bgragrayscalemask.pas",
"chars": 48150,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Supplies a linear grayscale bitmap (8-bit per pixel)"
},
{
"path": "bgrabitmap/bgragtkbitmap.pas",
"chars": 17303,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of BGRABitmap for Gtk }\nunit BGRAGtkBitmap;\n{ T"
},
{
"path": "bgrabitmap/bgraiconcursor.pas",
"chars": 26595,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Reading/writing of icon/cursor files (with multiple "
},
{
"path": "bgrabitmap/bgralayeroriginal.pas",
"chars": 76881,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Generic classes to implement originals, to be used in layered "
},
{
"path": "bgrabitmap/bgralayers.pas",
"chars": 123626,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Layered image, each layer being a TBGRABitmap or rendered from"
},
{
"path": "bgrabitmap/bgralazpaint.pas",
"chars": 7268,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Layered image format used in LazPaint }\nunit BGRALazPaint;\n\n{$"
},
{
"path": "bgrabitmap/bgralazresource.pas",
"chars": 11088,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Handles Lazarus resources files and provide tools to create th"
},
{
"path": "bgrabitmap/bgralclbitmap.pas",
"chars": 37751,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Common implementation of BGRABitmap based on LCL (Lazarus Comp"
},
{
"path": "bgrabitmap/bgralzpcommon.pas",
"chars": 21134,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Type and structure definitions for LazPaint image format }\nuni"
},
{
"path": "bgrabitmap/bgramacbitmap.pas",
"chars": 4014,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of BGRABitmap for Mac OS }\nunit BGRAMacBitmap;\n"
},
{
"path": "bgrabitmap/bgramatrix3d.pas",
"chars": 19707,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Matrix transformations in 3D }\nunit BGRAMatrix3D;\n\n{$mode objf"
},
{
"path": "bgrabitmap/bgramemdirectory.pas",
"chars": 21311,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Directory structure stored in memory (can be serialized) }\nuni"
},
{
"path": "bgrabitmap/bgramsegui.inc",
"chars": 10154,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\ntype\n TCol"
},
{
"path": "bgrabitmap/bgramsegui_text.inc",
"chars": 3910,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\nprocedure BitmapTextOut(ABitmap: TBitmap; ACoord: TPoint; AText: "
},
{
"path": "bgrabitmap/bgramsegui_uses.inc",
"chars": 66,
"preview": "uses BGRAClasses, FPimage, msegraphics, msegraphutils, msebitmap;\n"
},
{
"path": "bgrabitmap/bgramseguibitmap.pas",
"chars": 7078,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of BGRABitmap for MSEgui }\nunit BGRAMSEguiBitma"
},
{
"path": "bgrabitmap/bgramultifiletype.pas",
"chars": 14054,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Generic definition of a file containing multiple items }\nunit "
},
{
"path": "bgrabitmap/bgranogui.inc",
"chars": 1886,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\ntype\n TCol"
},
{
"path": "bgrabitmap/bgranogui_uses.inc",
"chars": 48,
"preview": "uses BGRAClasses, FPImage, FPCanvas, FPImgCanv;\n"
},
{
"path": "bgrabitmap/bgranoguibitmap.pas",
"chars": 5897,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of BGRABitmap without graphical user interface "
},
{
"path": "bgrabitmap/bgraopengl.pas",
"chars": 69530,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ OpenGL rendering (bitmap and various other classes). }\nunit BG"
},
{
"path": "bgrabitmap/bgraopengl3d.pas",
"chars": 35843,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ 3D rendering of TCustomRenderer3D scences in OpenGL }\nunit BGR"
},
{
"path": "bgrabitmap/bgraopengltype.pas",
"chars": 70793,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Basic types used with OpenGL }\nunit BGRAOpenGLType;\n\n{$mode ob"
},
{
"path": "bgrabitmap/bgraopenraster.pas",
"chars": 36867,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ OpenRaster layered image format }\nunit BGRAOpenRaster;\n\n{$mode"
},
{
"path": "bgrabitmap/bgrapaintnet.pas",
"chars": 17906,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Paint.NET image format files.)\n\n The unit registers"
},
{
"path": "bgrabitmap/bgrapalette.pas",
"chars": 41212,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Palette of colors for various purposes, loading/saving into va"
},
{
"path": "bgrabitmap/bgrapapers.pas",
"chars": 8312,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{ 2023 Massimo Magnano }\n\n{ List of paper sizes in inches and cm "
},
{
"path": "bgrabitmap/bgrapath.pas",
"chars": 98243,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Implements path and path cursor)\n\n There are differ"
},
{
"path": "bgrabitmap/bgrapdf.pas",
"chars": 4166,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{****************************************************************"
},
{
"path": "bgrabitmap/bgrapen.pas",
"chars": 42454,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Configuration and computation of pen style and width"
},
{
"path": "bgrabitmap/bgraphongtypes.pas",
"chars": 2649,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Types used by Phong shading }\nunit BGRAPhongTypes;\n\n{$mode obj"
},
{
"path": "bgrabitmap/bgraphoxo.pas",
"chars": 18264,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Phoxo layered image format, with .oXo extension. }\nunit BGRAPh"
},
{
"path": "bgrabitmap/bgrapixel.inc",
"chars": 27940,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{=== Pixel types and functions ===}\n\n{$IFDEF INCLUDE_INTERFACE}\n{"
},
{
"path": "bgrabitmap/bgrapngcomn.pas",
"chars": 6137,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Common types for PNG format. This extents PNGComn unit for ani"
},
{
"path": "bgrabitmap/bgrapolygon.pas",
"chars": 57120,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ This unit contains polygon drawing functions and spline functi"
},
{
"path": "bgrabitmap/bgrapolygonaliased.pas",
"chars": 33639,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ This unit provides fast aliased polygon routines. }\nunit BGRAP"
},
{
"path": "bgrabitmap/bgraqtbitmap.pas",
"chars": 4276,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of BGRABitmap for Qt }\nunit BGRAQtBitmap;\n{ Thi"
},
{
"path": "bgrabitmap/bgrareadavif.pas",
"chars": 2413,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Provides a reader for AVIF image format }\nunit BGRAReadAvif;\n\n"
},
{
"path": "bgrabitmap/bgrareadbmp.pas",
"chars": 39301,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{****************************************************************"
},
{
"path": "bgrabitmap/bgrareadbmpmiomap.pas",
"chars": 6851,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Reader implementation for iGo BMP format }\nunit BGRAReadBmpMio"
},
{
"path": "bgrabitmap/bgrareadgif.pas",
"chars": 9673,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Provides reader for GIF format.)\n\n This unit implem"
},
{
"path": "bgrabitmap/bgrareadico.pas",
"chars": 4219,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Provides readers for icons and cursors }\nunit BGRAReadIco;\n\n{$"
},
{
"path": "bgrabitmap/bgrareadjpeg.pas",
"chars": 7104,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{****************************************************************"
},
{
"path": "bgrabitmap/bgrareadlzp.pas",
"chars": 12503,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Provides reader for LazPaint image format }\nunit BGRAReadLzp;\n"
},
{
"path": "bgrabitmap/bgrareadpcx.pas",
"chars": 6987,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{***************************************************************"
},
{
"path": "bgrabitmap/bgrareadpng.pas",
"chars": 50139,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{\n This file is originally part of the Free Pascal run time li"
},
{
"path": "bgrabitmap/bgrareadpsd.pas",
"chars": 29466,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{\n The original file was part of the Free Pascal run time libr"
},
{
"path": "bgrabitmap/bgrareadtga.pas",
"chars": 5893,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{****************************************************************"
},
{
"path": "bgrabitmap/bgrareadtiff.pas",
"chars": 117935,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{\n The original file is part of the Free Pascal run time libra"
},
{
"path": "bgrabitmap/bgrareadwebp.pas",
"chars": 3720,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Provides a reader for WebP format using libwebp }\nunit BGRARea"
},
{
"path": "bgrabitmap/bgrareadxpm.pas",
"chars": 2043,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Reader for XPM format }\nunit BGRAReadXPM;\n\n{$mode objfpc}{$H+}"
},
{
"path": "bgrabitmap/bgrarenderer3d.pas",
"chars": 28317,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Software renderer for 3D scenes }\nunit BGRARenderer3D;\n\n{$mode"
},
{
"path": "bgrabitmap/bgraresample.pas",
"chars": 53865,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ This unit provides resampling functions, i.e. resizing of bitm"
},
{
"path": "bgrabitmap/bgrascanner.inc",
"chars": 9735,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\ntype\n TBGR"
},
{
"path": "bgrabitmap/bgrascene3d.pas",
"chars": 47307,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Definition of a 3D scene }\nunit BGRAScene3D;\n\n{$mode objfpc}{$"
},
{
"path": "bgrabitmap/bgrascenetypes.pas",
"chars": 44069,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Types for 3D scenes }\nunit BGRASceneTypes;\n\n{$mode objfpc}{$H+"
},
{
"path": "bgrabitmap/bgraslicescaling.pas",
"chars": 26323,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Computation of slice scaling of images (to extended bitmap pro"
},
{
"path": "bgrabitmap/bgraspritegl.pas",
"chars": 15997,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Sprites to be rendered with OpenGL }\nunit BGRASpriteGL;\n\n{$mod"
},
{
"path": "bgrabitmap/bgrasse.inc",
"chars": 487,
"preview": "{$IFDEF SSE_LOADV}\n {$UNDEF SSE_LOADV}\n {$ifdef cpux86_64}\n mov rax,v\n movups xmm1,[rax]\n {$else}\n mov eax,v\n mov"
},
{
"path": "bgrabitmap/bgrasse.pas",
"chars": 14029,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of SSE acceleration }\nunit BGRASSE;\n\n{$mode obj"
},
{
"path": "bgrabitmap/bgrastreamlayers.pas",
"chars": 12946,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Routines to stream layers }\nunit BGRAStreamLayers;\n\n{$mode obj"
},
{
"path": "bgrabitmap/bgrasvg.pas",
"chars": 46148,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ SVG format implementation }\nunit BGRASVG;\n\n{$mode objfpc}{$H+}"
},
{
"path": "bgrabitmap/bgrasvgoriginal.pas",
"chars": 21666,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Storage of SVG as an original in a layered bitmap }\nunit BGRAS"
},
{
"path": "bgrabitmap/bgrasvgshapes.pas",
"chars": 148511,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of various SVG shapes }\nunit BGRASVGShapes;\n\n{$"
},
{
"path": "bgrabitmap/bgrasvgtype.pas",
"chars": 81634,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Base type definitions and implementation for SVG }\nunit BGRASV"
},
{
"path": "bgrabitmap/bgratext.pas",
"chars": 76885,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Base implementation of system text rendering.)\n\n Th"
},
{
"path": "bgrabitmap/bgratextbidi.pas",
"chars": 122314,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of bidirectional text layout }\nunit BGRATextBid"
},
{
"path": "bgrabitmap/bgratextfx.pas",
"chars": 31729,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Text effects using system text rendering.)\n\n The si"
},
{
"path": "bgrabitmap/bgrathumbnail.pas",
"chars": 20606,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Computation of thumbnails for all image formats }\nunit BGRAThu"
},
{
"path": "bgrabitmap/bgratransform.pas",
"chars": 61752,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Affine and bitmap transformations }\nunit BGRATransform;\n\n{$mod"
},
{
"path": "bgrabitmap/bgratypewriter.pas",
"chars": 45406,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Cached vectorial font renderer with affine transform }\nunit BG"
},
{
"path": "bgrabitmap/bgraunicode.pas",
"chars": 48152,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of Unicode bidirectional algorithm }\nunit BGRAU"
},
{
"path": "bgrabitmap/bgraunicodetext.pas",
"chars": 36352,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Bidirectional Unicode text analysis }\nunit BGRAUnicodeText;\n\n{"
},
{
"path": "bgrabitmap/bgraunits.pas",
"chars": 25361,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Definition of units of measure (distances) used in CSS }\nunit "
},
{
"path": "bgrabitmap/bgrautf8.pas",
"chars": 45954,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ UTF8 related functions }\nunit BGRAUTF8;\n\n{$mode objfpc}{$H+}\n{"
},
{
"path": "bgrabitmap/bgravectorize.pas",
"chars": 85124,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(This unit provides vectorizers for black'n'white ima"
},
{
"path": "bgrabitmap/bgrawinbitmap.pas",
"chars": 6437,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of BGRABitmap for Windows.\n Notably, it provid"
},
{
"path": "bgrabitmap/bgrawinresource.pas",
"chars": 36338,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implementation of Windows resource file format (RES) }\nunit BG"
},
{
"path": "bgrabitmap/bgrawriteavif.pas",
"chars": 2948,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implements the writer for the AVIF format (relies on external "
},
{
"path": "bgrabitmap/bgrawritebmp.pas",
"chars": 2921,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{****************************************************************"
},
{
"path": "bgrabitmap/bgrawritebmpmiomap.pas",
"chars": 10526,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implements the writer for BMP MioMap (iGO) image format }\nunit"
},
{
"path": "bgrabitmap/bgrawritejpeg.pas",
"chars": 6288,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{****************************************************************"
},
{
"path": "bgrabitmap/bgrawritelzp.pas",
"chars": 12943,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implements the writer for LazPaint image format }\nunit BGRAWri"
},
{
"path": "bgrabitmap/bgrawritepcx.pas",
"chars": 2087,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{****************************************************************"
},
{
"path": "bgrabitmap/bgrawritepng.pas",
"chars": 31854,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{\n The original file is part of the Free Pascal run time libra"
},
{
"path": "bgrabitmap/bgrawritetiff.pas",
"chars": 32737,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{\n The original file FPReadTiff is part of the Free Pascal run"
},
{
"path": "bgrabitmap/bgrawritewebp.pas",
"chars": 3116,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Implements the writer for the WebP format (relies on external "
},
{
"path": "bgrabitmap/blendpixelinline.inc",
"chars": 37265,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\nfunction ByteLinearMultiplyInline(a, b: byte): byte;\nbegin\n if b"
},
{
"path": "bgrabitmap/blendpixels.inc",
"chars": 12795,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\nprocedure FastBlendPixels(pdest: PBGRAPixel; psrc: PBGRAPixel; Co"
},
{
"path": "bgrabitmap/blendpixelsover.inc",
"chars": 34331,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{************************* blend over ***************************"
},
{
"path": "bgrabitmap/blurbox.inc",
"chars": 14225,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\nprocedure IncAcc(var ADest: TAccumulator; ADelta: TAccumulator); "
},
{
"path": "bgrabitmap/blurfast.inc",
"chars": 7041,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\nvar\n blurRowY,blurRowX: packed array of UInt32or64;\n iRadiusX,"
},
{
"path": "bgrabitmap/blurnormal.inc",
"chars": 7341,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\ntype\n PWeightedPixel = ^TWeightedPixel;\n TWeightedPixel = packe"
},
{
"path": "bgrabitmap/csscolorconst.inc",
"chars": 33189,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{=== Color definitions ===}\n\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF I"
},
{
"path": "bgrabitmap/darwinlib.pas",
"chars": 1781,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Search for libraries on MacOS.)\n\n This unit allows "
},
{
"path": "bgrabitmap/density256.inc",
"chars": 2787,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_FILLDENSITY}\n{$UNDEF INCLUDE_FILLDENSITY}\n\n\t{$IFN"
},
{
"path": "bgrabitmap/expandedbitmap.pas",
"chars": 25548,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Supplies a bitmap in linear RGB with word values (16"
},
{
"path": "bgrabitmap/extendedcolorspace.inc",
"chars": 56913,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\n\n{$IFDEF BG"
},
{
"path": "bgrabitmap/face3d.inc",
"chars": 14742,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\ntype\n PBGRAFaceVertexDescription = ^TBGRAFaceVertexDescription;\n"
},
{
"path": "bgrabitmap/generatedcolorspace.inc",
"chars": 506028,
"preview": "{ This file is generated by dev/colorspace/UnitMaker program }\n\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\nty"
},
{
"path": "bgrabitmap/generatedunicode.inc",
"chars": 83613,
"preview": "{ This file is generated by dev/parseunicode/parseunicodeclasses program }\n\nfunction GetUnicodeBidiClassEx(u: LongWord):"
},
{
"path": "bgrabitmap/generatedutf8.inc",
"chars": 42200,
"preview": "{ This file is generated by dev/parseunicode/parseunicodeclasses program }\ntype\n TArabicJoin = (arNone, arInitial, arMe"
},
{
"path": "bgrabitmap/geometrytypes.inc",
"chars": 79302,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{=== Geometry types ===}{}\n\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF IN"
},
{
"path": "bgrabitmap/libavif.pas",
"chars": 109674,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\r\n// Copyright 2019 Joe Drago. All rights reserved (originally as "
},
{
"path": "bgrabitmap/libwebp.pas",
"chars": 30897,
"preview": "{ Dynamic loader for libwebp library that reads and writes the WebP format }\nunit libwebp;\n\n// Copyright 2010 Google Inc"
},
{
"path": "bgrabitmap/lightingclasses3d.inc",
"chars": 5586,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\ntype\n { Directional light for 3D scene }\n TBGRADirectionalLight"
},
{
"path": "bgrabitmap/linearrgbabitmap.pas",
"chars": 20070,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Supplies a bitmap in linear RGB with floating-point "
},
{
"path": "bgrabitmap/lineartexscan.inc",
"chars": 2853,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$i bgrasse.inc}\n\n var\n xLen: single; //horizontal leng"
},
{
"path": "bgrabitmap/lineartexscan2.inc",
"chars": 1508,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n {$IFDEF PARAM_USESSE} {$asmmode intel}\n asm\n x"
},
{
"path": "bgrabitmap/linuxlib.pas",
"chars": 4263,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ This unit allows to find the implementation of a library from "
},
{
"path": "bgrabitmap/multishapeline.inc",
"chars": 2126,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n begin\n for k := 0 to NbShapeRows-1 do\n with s"
},
{
"path": "bgrabitmap/object3d.inc",
"chars": 6911,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{ TBGRAObject3D }\n\nprocedure TBGRAObject3D.AddFace(AFace: IBGRAFa"
},
{
"path": "bgrabitmap/paletteformats.inc",
"chars": 17848,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\nvar\n PaletteFormats : array of record\n formatIndex: TBGRAPale"
},
{
"path": "bgrabitmap/part3d.inc",
"chars": 16679,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\ntype\n { @abstract(Part of a 3D object, that can be moved indepen"
},
{
"path": "bgrabitmap/perspectivecolorscan.inc",
"chars": 3075,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n {$IFDEF PARAM_USESSE} {$asmmode intel}\n minVal := 0;\n "
},
{
"path": "bgrabitmap/perspectivescan.inc",
"chars": 4322,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$i bgrasse.inc}\n\n var\n //loop variables\n pdest: PBGRAPixe"
},
{
"path": "bgrabitmap/perspectivescan2.inc",
"chars": 5945,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$i bgrasse.inc}\n\n{$ifdef BGRASSE_AVAILABLE}{$asmmode intel}{$end"
},
{
"path": "bgrabitmap/phongdraw.inc",
"chars": 8517,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$ifdef PARAM_PHONGSSE}\n {$asmmode intel}\n //SSE rotate singles"
},
{
"path": "bgrabitmap/phongdrawsse.inc",
"chars": 3470,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\nasm\n //vL := vLS- vP*LightDestFactor;\n movups xmm4,"
},
{
"path": "bgrabitmap/phonglight.inc",
"chars": 1683,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$i bgrasse.inc}\nvar\n {%H-}dist2,LdotN,NdotH,lightEnergy,diffuse"
},
{
"path": "bgrabitmap/phonglightsse.inc",
"chars": 2412,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n {$asmmode intel}\n asm\n {$ifdef cpux86_64}\n mov r"
},
{
"path": "bgrabitmap/polyaliaspersp.inc",
"chars": 23271,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{*****************************************TEXTURE WITHOUT SHADING"
},
{
"path": "bgrabitmap/readme.txt",
"chars": 585,
"preview": "BGRABitmap - Drawing routines with transparency and antialiasing with Lazarus. Offers also various transforms.\n\nThese ro"
},
{
"path": "bgrabitmap/shapes3d.inc",
"chars": 2328,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\ntype\n { Spherical object for a 3D scene }\n TBGRASphere3D = clas"
},
{
"path": "bgrabitmap/spectraldata.inc",
"chars": 7202,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\nconst\n { Horseshoe shape of visible colors at 2° (illuminant E)"
},
{
"path": "bgrabitmap/unibitmap.inc",
"chars": 162138,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\n\ntype\n {* "
},
{
"path": "bgrabitmap/unibitmapgeneric.inc",
"chars": 44293,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n{$IFDEF INCLUDE_INTERFACE}\n{$UNDEF INCLUDE_INTERFACE}\n\ntype\n { A"
},
{
"path": "bgrabitmap/universaldrawer.pas",
"chars": 46724,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Base implementation for drawing on a universal bitmap }\nunit U"
},
{
"path": "bgrabitmap/unzipperext.pas",
"chars": 4280,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Proposes a class to unzip files from stream to stream }\nunit U"
},
{
"path": "bgrabitmap/uunittest.pas",
"chars": 2124,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ Some unit testing }\nunit UUnitTest;\n\n{$mode objfpc}{$H+}\n\ninte"
},
{
"path": "bgrabitmap/vertex3d.inc",
"chars": 14829,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\ntype\n { Object in a 3D scene }\n TBGRAObject3D = class(TInterfac"
},
{
"path": "bgrabitmap/wordxyzabitmap.pas",
"chars": 25341,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Supplies a bitmap in XYZ colorspace with word values"
},
{
"path": "bgrabitmap/xyzabitmap.pas",
"chars": 20842,
"preview": "// SPDX-License-Identifier: LGPL-3.0-linking-exception\n\n{ @abstract(Supplies a bitmap in XYZ colorspace with floating-po"
},
{
"path": "commit.sh",
"chars": 237,
"preview": "#!/bin/bash\n#git checkout HEAD~ -- <file to cancel>\ngit add .\ngit status\necho \"Type commit description (or press Enter t"
}
]
// ... and 297 more files (download for full content)
About this extraction
This page contains the full source code of the bgrabitmap/bgrabitmap GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 497 files (17.3 MB), approximately 4.6M tokens, and a symbol index with 1 extracted functions, classes, methods, constants, and types. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.