babaev-an/lasarus_compotents
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Стартовый пул

Browse Source
This commit is contained in:
Александр Бабаев
2024-04-02 08:46:59 +03:00
parent fd57fffd3a
commit 3bb34d000b
5591 changed files with 3291734 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
bgrabitmap/test/colorspace/ColorsDemo.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 134 KiB

77
bgrabitmap/test/colorspace/ColorsDemo.lpi Normal file
View File

@@ -0,0 +1,77 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="10"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="ColorsDemo"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="BGRABitmapPack"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="3">
<Unit0>
<Filename Value="ColorsDemo.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="colorsdemounit.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ColorsDemoUnit"/>
</Unit1>
<Unit2>
<Filename Value="bgracolorex.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="BGRAColorEx"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="ColorsDemo"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

21
bgrabitmap/test/colorspace/ColorsDemo.lpr Normal file
View File

@@ -0,0 +1,21 @@
program ColorsDemo;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, ColorsDemoUnit, BGRAColorEx
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

BIN
bgrabitmap/test/colorspace/HorseShoe.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 134 KiB

79
bgrabitmap/test/colorspace/HorseShoe.lpi Normal file
View File

@@ -0,0 +1,79 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<General>
<Flags>
<CompatibilityMode Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="HorseShoe"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<RequiredPackages Count="3">
<Item1>
<PackageName Value="bgracontrols"/>
</Item1>
<Item2>
<PackageName Value="BGRABitmapPack"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="HorseShoe.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="uhorseshoe.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="HorseShoe"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

21
bgrabitmap/test/colorspace/HorseShoe.lpr Normal file
View File

@@ -0,0 +1,21 @@
program HorseShoe;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, uhorseshoe
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

949
bgrabitmap/test/colorspace/bgracolorex.pas Normal file
View File

@@ -0,0 +1,949 @@
unit BGRAColorEx;
{$mode objfpc}{$H+}
{$MODESWITCH ADVANCEDRECORDS}
interface
uses
Classes, SysUtils, FPimage, BGRAGraphics, BGRABitmapTypes;
type
{ TColorEx }
TColorEx = object
private
FColorspace: TColorspaceAny;
FValue: array[0..31] of byte;
private
function GetAlpha: byte;
function GetAlphaPercent: single;
function GetBlack: single;
function GetBlackPercent: single;
function GetBlue: byte;
function GetBluePercent: single;
function GetCyan: single;
function GetCyanPercent: single;
function GetGreen: byte;
function GetGreenPercent: single;
function GetIsOpaque: boolean;
function GetIsTransparent: boolean;
function GetLightness: single;
function GetLightnessPercent: single;
function GetRed: byte;
function GetRedPercent: single;
function GetSaturation: single;
function GetSaturationPercent: single;
function GetYellow: single;
function GetYellowPercent: single;
function GetHue: single;
function GetHuePercent: single;
function GetMagenta: single;
function GetMagentaPercent: single;
procedure SetYellow(AValue: single);
procedure SetYellowPercent(AValue: single);
procedure SetAlpha(AValue: byte);
procedure SetAlphaPercent(AValue: single);
procedure SetBlack(AValue: single);
procedure SetBlackPercent(AValue: single);
procedure SetBlue(AValue: byte);
procedure SetBluePercent(AValue: single);
procedure SetCyan(AValue: single);
procedure SetCyanPercent(AValue: single);
procedure SetGreen(AValue: byte);
procedure SetGreenPercent(AValue: single);
procedure SetLightness(AValue: single);
procedure SetLightnessPercent(AValue: single);
procedure SetRed(AValue: byte);
procedure SetRedPercent(AValue: single);
procedure SetSaturation(AValue: single);
procedure SetSaturationPercent(AValue: single);
procedure SetHue(AValue: single);
procedure SetHuePercent(AValue: single);
procedure SetMagenta(AValue: single);
procedure SetMagentaPercent(AValue: single);
public
class function New: TColorEx; overload; static;
class function New(const AValue: TColorEx): TColorEx; overload; static;
class function New(const AValue: string): TColorEx; overload; static;
class function New(const AValue: TColor): TColorEx; overload; static;
class function New(const AValue: TBGRAPixel): TColorEx; overload; static;
class function New(const AValue: TExpandedPixel): TColorEx; overload; static;
class function New(const AValue: TStdRGBA): TColorEx; overload; static;
class function New(const AValue: TLinearRGBA): TColorEx; overload; static;
class function New(const AValue: TXYZA): TColorEx; overload; static;
class function New(const AValue: TLabA): TColorEx; overload; static;
class function New(const AValue: TStdHSLA): TColorEx; overload; static;
class function New(const AValue: TStdHSVA): TColorEx; overload; static;
class function New(const AValue: TStdCMYK): TColorEx; overload; static;
class function New(const AValue: TLChA): TColorEx; overload; static;
class function New(const ARed, AGreen, ABlue: byte; const AAlpha: byte = 255): TColorEx; overload; static;
procedure SetValue(const AValue; AColorspace: TColorspaceAny);
procedure GetValue(out AValue; AColorspace: TColorspaceAny);
public
function ToBGRAPixel: TBGRAPixel;
function ToColor: TColor;
function ToDecimal: integer;
function ToGrayscale: TColorEx;
function ToHex: string;
function ToStdRGBA: TStdRGBA;
function ToStdHSLA: TStdHSLA;
function ToStdHSVA: TStdHSVA;
function ToStdCMYK: TStdCMYK;
function ToExpandedPixel: TExpandedPixel;
function ToLinearRGBA: TLinearRGBA;
function ToAdobeRGBA: TAdobeRGBA;
function ToHSLAPixel: THSLAPixel;
function ToGSBAPixel: TGSBAPixel;
function ToXYZA: TXYZA;
function ToLabA: TLabA;
function ToLChA: TLChA;
function ToName: string;
function ToString: string;
function ToInvert: TColorEx;
procedure FromBGRAPixel(AValue: TBGRAPixel);
procedure FromColor(AValue: TColor);
procedure FromDecimal(AValue: integer);
procedure FromHex(AValue: string);
procedure FromStdRGBA(const AValue: TStdRGBA);
procedure FromStdHSLA(const AValue: TStdHSLA);
procedure FromStdHSVA(const AValue: TStdHSVA);
procedure FromStdCMYK(const AValue: TStdCMYK);
procedure FromExpandedPixel(const AValue: TExpandedPixel);
procedure FromLinearRGBA(const AValue: TLinearRGBA);
procedure FromAdobeRGBA(const AValue: TAdobeRGBA);
procedure FromHSLAPixel(const AValue: THSLAPixel);
procedure FromGSBAPixel(const AValue: TGSBAPixel);
procedure FromXYZA(AValue: TXYZA);
procedure FromLabA(AValue: TLabA);
procedure FromLChA(AValue: TLChA);
procedure FromName(AValue: string);
procedure FromString(AValue: string);
public
function Fade(APercent: single): TColorEx;
function Darken(APercent: single): TColorEx;
function Lighten(APercent: single): TColorEx;
function Premultiply: TColorEx;
public
property Colorspace: TColorspaceAny read FColorspace;
property Red: byte read GetRed write SetRed;
property Green: byte read GetGreen write SetGreen;
property Blue: byte read GetBlue write SetBlue;
property Alpha: byte read GetAlpha write SetAlpha;
property Hue: single read GetHue write SetHue;
property Saturation: single read GetSaturation write SetSaturation;
property Lightness: single read GetLightness write SetLightness;
property Cyan: single read GetCyan write SetCyan;
property Magenta: single read GetMagenta write SetMagenta;
property Yellow: single read GetYellow write SetYellow;
property Black: single read GetBlack write SetBlack;
property RedPercent: single read GetRedPercent write SetRedPercent;
property GreenPercent: single read GetGreenPercent write SetGreenPercent;
property BluePercent: single read GetBluePercent write SetBluePercent;
property AlphaPercent: single read GetAlphaPercent write SetAlphaPercent;
property HuePercent: single read GetHuePercent write SetHuePercent;
property SaturationPercent: single read GetSaturationPercent write SetSaturationPercent;
property LightnessPercent: single read GetLightnessPercent write SetLightnessPercent;
property CyanPercent: single read GetCyanPercent write SetCyanPercent;
property MagentaPercent: single read GetMagentaPercent write SetMagentaPercent;
property YellowPercent: single read GetYellowPercent write SetYellowPercent;
property BlackPercent: single read GetBlackPercent write SetBlackPercent;
property Name: string read ToName write FromName;
property AsHex: string read ToHex write FromHex;
property AsDecimal: integer read ToDecimal write FromDecimal;
property AsString: string read ToString write FromString;
property AsColor: TColor read ToColor write FromColor;
property AsBGRAPixel: TBGRAPixel read ToBGRAPixel write FromBGRAPixel;
property AsStdRGBA: TStdRGBA read ToStdRGBA write FromStdRGBA;
property AsStdHSLA: TStdHSLA read ToStdHSLA write FromStdHSLA;
property AsStdHSVA: TStdHSVA read ToStdHSVA write FromStdHSVA;
property AsStdCMYK: TStdCMYK read ToStdCMYK write FromStdCMYK;
property AsExpandedPixel: TExpandedPixel read ToExpandedPixel write FromExpandedPixel;
property AsLinearRGBA: TLinearRGBA read ToLinearRGBA write FromLinearRGBA;
property AsAdobeRGBA: TAdobeRGBA read ToAdobeRGBA write FromAdobeRGBA;
property AsHSLAPixel: THSLAPixel read ToHSLAPixel write FromHSLAPixel;
property AsGSBAPixel: TGSBAPixel read ToGSBAPixel write FromGSBAPixel;
property AsXYZA: TXYZA read ToXYZA write FromXYZA;
property AsLabA: TLabA read ToLabA write FromLabA;
property AsLChA: TLChA read ToLChA write FromLChA;
property AsGrayscale: TColorEx read ToGrayscale;
property AsInvert: TColorEx read ToInvert;
property IsTransparent: boolean read GetIsTransparent;
property IsOpaque: boolean read GetIsOpaque;
end;
function ColorEx(const ARed, AGreen, ABlue: byte; const AAlpha: byte = 255): TColorEx;
function ColorEx(const AValue: string): TColorEx;
function ColorEx(const AValue: string; const AAlpha: single): TColorEx;
function clRandom: TColorEx;
operator := (const AValue: TColorEx): string;
operator := (const AValue: TColorEx): TColor;
operator := (const AValue: TColorEx): TBGRAPixel;
operator := (const AValue: TColorEx): TExpandedPixel;
operator := (const AValue: TColorEx): TStdRGBA;
operator := (const AValue: TColorEx): TLinearRGBA;
operator := (const AValue: TColorEx): TXYZA;
operator := (const AValue: TColorEx): TLabA;
operator := (const AValue: TColorEx): TStdHSLA;
operator := (const AValue: TColorEx): TStdHSVA;
operator := (const AValue: TColorEx): TStdCMYK;
operator := (const AValue: TColorEx): TLChA;
operator := (const AValue: string): TColorEx;
operator := (const AValue: TColor): TColorEx;
operator := (const AValue: TBGRAPixel): TColorEx;
operator := (const AValue: TExpandedPixel): TColorEx;
operator := (const AValue: TStdRGBA): TColorEx;
operator := (const AValue: TLinearRGBA): TColorEx;
operator := (const AValue: TXYZA): TColorEx;
operator := (const AValue: TLabA): TColorEx;
operator := (const AValue: TStdHSLA): TColorEx;
operator := (const AValue: TStdHSVA): TColorEx;
operator := (const AValue: TStdCMYK): TColorEx;
operator := (const AValue: TLChA): TColorEx;
implementation
function ColorEx(const ARed, AGreen, ABlue: byte; const AAlpha: byte): TColorEx;
begin
Result := TColorEx.New(ARed, AGreen, ABlue, AAlpha);
end;
function ColorEx(const AValue: string): TColorEx;
begin
Result := TColorEx.New(AValue);
end;
function ColorEx(const AValue: string; const AAlpha: single): TColorEx;
begin
Result := TColorEx.New(AValue);
Result.AlphaPercent := AAlpha;
end;
function clRandom: TColorEx;
begin
Result := TStdHSLA.New(Random(360), 0.5, 0.5);
end;
operator := (const AValue: TColorEx): string;
begin
Result := AValue.AsString;
end;
operator := (const AValue: TColorEx): TColor;
begin
Result := AValue.AsColor;
end;
operator := (const AValue: TColorEx): TBGRAPixel;
begin
Result := AValue.AsBGRAPixel;
end;
operator := (const AValue: TColorEx): TExpandedPixel;
begin
Result := AValue.AsExpandedPixel;
end;
operator := (const AValue: TColorEx): TStdRGBA;
begin
Result := AValue.AsStdRGBA;
end;
operator := (const AValue: TColorEx): TLinearRGBA;
begin
Result := AValue.AsLinearRGBA;
end;
operator := (const AValue: TColorEx): TXYZA;
begin
Result := AValue.AsXYZA;
end;
operator := (const AValue: TColorEx): TLabA;
begin
Result := AValue.AsLabA;
end;
operator := (const AValue: TColorEx): TStdHSLA;
begin
Result := AValue.AsStdHSLA;
end;
operator := (const AValue: TColorEx): TStdHSVA;
begin
Result := AValue.AsStdHSVA;
end;
operator := (const AValue: TColorEx): TStdCMYK;
begin
Result := AValue.AsStdCMYK;
end;
operator := (const AValue: TColorEx): TLChA;
begin
Result := AValue.AsLChA;
end;
operator := (const AValue: string): TColorEx;
begin
Result.AsString := AValue;
end;
operator := (const AValue: TColor): TColorEx;
begin
Result.AsColor := AValue;
end;
operator := (const AValue: TBGRAPixel): TColorEx;
begin
Result.AsBGRAPixel := AValue;
end;
operator := (const AValue: TExpandedPixel): TColorEx;
begin
Result.AsExpandedPixel := AValue;
end;
operator := (const AValue: TStdRGBA): TColorEx;
begin
Result.AsStdRGBA := AValue;
end;
operator := (const AValue: TLinearRGBA): TColorEx;
begin
Result.AsLinearRGBA := AValue;
end;
operator := (const AValue: TXYZA): TColorEx;
begin
Result.AsXYZA := AValue;
end;
operator := (const AValue: TLabA): TColorEx;
begin
Result.AsLabA := AValue;
end;
operator := (const AValue: TStdHSLA): TColorEx;
begin
Result.AsStdHSLA := AValue;
end;
operator := (const AValue: TStdHSVA): TColorEx;
begin
Result.AsStdHSVA := AValue;
end;
operator := (const AValue: TStdCMYK): TColorEx;
begin
Result.AsStdCMYK := AValue;
end;
operator := (const AValue: TLChA): TColorEx;
begin
Result.AsLChA := AValue;
end;
{ TColorEx }
function TColorEx.GetAlpha: byte;
begin
Result := round(AsStdRGBA.alpha * 255);
end;
function TColorEx.GetAlphaPercent: single;
begin
Result := AsStdRGBA.alpha * 100;
end;
function TColorEx.ToBGRAPixel: TBGRAPixel;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.GetBlack: single;
begin
Result := AsStdCMYK.K;
end;
function TColorEx.GetBlackPercent: single;
begin
Result := Black * 100;
end;
function TColorEx.GetBlue: byte;
begin
Result := round(AsStdRGBA.blue * 255);
end;
function TColorEx.GetBluePercent: single;
begin
Result := AsStdRGBA.blue * 100;
end;
function TColorEx.ToStdCMYK: TStdCMYK;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.ToColor: TColor;
begin
GetValue(result, TColorColorspace);
end;
function TColorEx.GetCyan: single;
begin
Result := AsStdCMYK.C;
end;
function TColorEx.GetCyanPercent: single;
begin
Result := Cyan * 100;
end;
function TColorEx.ToDecimal: integer;
begin
with AsBGRAPixel do
Result := (red shl 16) or (green shl 8) or blue;
end;
function TColorEx.ToExpandedPixel: TExpandedPixel;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.ToGrayscale: TColorEx;
begin
Result.AsStdRGBA := AsBGRAPixel.ToGrayscale(True);
end;
function TColorEx.GetGreen: byte;
begin
Result := round(AsStdRGBA.green * 255);
end;
function TColorEx.GetGreenPercent: single;
begin
Result := AsStdRGBA.green * 100;
end;
function TColorEx.GetIsOpaque: boolean;
begin
Result := AlphaPercent >= 100;
end;
function TColorEx.GetIsTransparent: boolean;
begin
Result := AlphaPercent <= 0;
end;
function TColorEx.ToHex: string;
begin
with AsBGRAPixel do
begin
Result := '#' + IntToHex(red, 2) + IntToHex(green, 2) + IntToHex(blue, 2);
if alpha <> 255 then
Result += IntToHex(alpha, 2);
end;
end;
function TColorEx.ToStdHSLA: TStdHSLA;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.ToStdHSVA: TStdHSVA;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.GetHue: single;
begin
Result := AsStdHSLA.hue * 100;
end;
function TColorEx.GetHuePercent: single;
begin
Result := Hue / 3.6;
end;
function TColorEx.ToInvert: TColorEx;
begin
with AsStdRGBA do
begin
Result.AsStdRGBA := TStdRGBA.New(1 - red, 1 - green, 1 - blue, alpha);
end;
end;
function TColorEx.ToLabA: TLabA;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.ToLChA: TLChA;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.GetLightness: single;
begin
Result := AsStdHSLA.lightness;
end;
function TColorEx.GetLightnessPercent: single;
begin
Result := Lightness * 100;
end;
function TColorEx.ToLinearRGBA: TLinearRGBA;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.ToAdobeRGBA: TAdobeRGBA;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.ToHSLAPixel: THSLAPixel;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.ToGSBAPixel: TGSBAPixel;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.GetMagenta: single;
begin
Result := AsStdCMYK.M;
end;
function TColorEx.GetMagentaPercent: single;
begin
Result := Magenta * 100;
end;
function TColorEx.ToName: string;
var
idx: integer;
c: TBGRAPixel;
begin
Result := '';
c := AsBGRAPixel;
if Assigned(CSSColors) then
begin
idx := CSSColors.IndexOfColor(c, 1000);
if idx <> -1 then
begin
Result := CSSColors.Name[idx];
exit;
end;
end;
end;
function TColorEx.GetRed: byte;
begin
Result := round(AsStdRGBA.red * 255);
end;
function TColorEx.GetRedPercent: single;
begin
Result := AsStdRGBA.red * 100;
end;
function TColorEx.GetSaturation: single;
begin
Result := AsStdHSLA.saturation;
end;
function TColorEx.GetSaturationPercent: single;
begin
Result := Saturation * 100;
end;
function TColorEx.ToStdRGBA: TStdRGBA;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.ToString: string;
begin
Result := BGRAToStr(AsBGRAPixel);
end;
function TColorEx.ToXYZA: TXYZA;
begin
GetValue(result, result.Colorspace);
end;
function TColorEx.GetYellow: single;
begin
Result := AsStdCMYK.Y;
end;
function TColorEx.GetYellowPercent: single;
begin
Result := Yellow * 100;
end;
procedure TColorEx.SetAlpha(AValue: byte);
begin
with AsStdRGBA do
Self.AsStdRGBA := TStdRGBA.New(red, green, blue, AValue / 255);
end;
procedure TColorEx.SetAlphaPercent(AValue: single);
begin
with AsStdRGBA do
Self.AsStdRGBA := TStdRGBA.New(red, green, blue, AValue / 100);
end;
procedure TColorEx.FromBGRAPixel(AValue: TBGRAPixel);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.SetBlack(AValue: single);
begin
with AsStdCMYK do
Self.AsStdCMYK := TStdCMYK.New(C, M, Y, AValue);
end;
procedure TColorEx.SetBlackPercent(AValue: single);
begin
with AsStdCMYK do
Self.AsStdCMYK := TStdCMYK.New(C, M, Y, AValue / 100);
end;
procedure TColorEx.SetBlue(AValue: byte);
begin
with AsStdRGBA do
Self.AsStdRGBA := TStdRGBA.New(red, green, AValue / 255, alpha);
end;
procedure TColorEx.SetBluePercent(AValue: single);
begin
with AsStdRGBA do
Self.AsStdRGBA := TStdRGBA.New(red, green, AValue / 100, alpha);
end;
procedure TColorEx.FromStdCMYK(const AValue: TStdCMYK);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.FromColor(AValue: TColor);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.SetCyan(AValue: single);
begin
with AsStdCMYK do
Self.AsStdCMYK:= TStdCMYK.New(AValue, M, Y, K);
end;
procedure TColorEx.SetCyanPercent(AValue: single);
begin
with AsStdCMYK do
Self.AsStdCMYK := TStdCMYK.New(AValue / 100, M, Y, K);
end;
procedure TColorEx.FromDecimal(AValue: integer);
var
r, g, b: byte;
begin
r := (AValue shr 16) and $000000ff;
g := (AValue shr 8) and $000000ff;
b := AValue and $000000ff;
AsBGRAPixel := TBGRAPixel.New(r, g, b);
end;
procedure TColorEx.FromExpandedPixel(const AValue: TExpandedPixel);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.SetGreen(AValue: byte);
begin
with AsStdRGBA do
Self.AsStdRGBA := TStdRGBA.New(red, AValue / 255, blue, alpha);
end;
procedure TColorEx.SetGreenPercent(AValue: single);
begin
with AsStdRGBA do
Self.AsStdRGBA := TStdRGBA.New(red, AValue / 100, blue, alpha);
end;
procedure TColorEx.FromHex(AValue: string);
var
missingValues, error: boolean;
c: TBGRAPixel;
begin
c := BGRAPixelTransparent;
TryStrToBGRA(AValue, c, missingValues, error);
if not (missingValues or error) then
AsBGRAPixel := c;
end;
procedure TColorEx.FromStdHSLA(const AValue: TStdHSLA);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.FromStdHSVA(const AValue: TStdHSVA);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.FromHSLAPixel(const AValue: THSLAPixel);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.FromGSBAPixel(const AValue: TGSBAPixel);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.SetHue(AValue: single);
begin
with AsStdHSLA do
Self.AsStdHSLA := TStdHSLA.New(AValue, saturation, lightness, alpha);
end;
procedure TColorEx.SetHuePercent(AValue: single);
begin
with AsStdHSLA do
Self.AsStdHSLA := TStdHSLA.New(AValue / 3.6, saturation, lightness, alpha);
end;
procedure TColorEx.FromLabA(AValue: TLabA);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.FromLChA(AValue: TLChA);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.SetLightness(AValue: single);
begin
with AsStdHSLA do
Self.AsStdHSLA := TStdHSLA.New(hue, saturation, AValue, alpha);
end;
procedure TColorEx.SetLightnessPercent(AValue: single);
begin
with AsStdHSLA do
Self.AsStdHSLA := TStdHSLA.New(hue, saturation, AValue / 100, alpha);
end;
procedure TColorEx.FromLinearRGBA(const AValue: TLinearRGBA);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.FromAdobeRGBA(const AValue: TAdobeRGBA);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.SetMagenta(AValue: single);
begin
with AsStdCMYK do
Self.AsStdCMYK := TStdCMYK.New(C, AValue, Y, K);
end;
procedure TColorEx.SetMagentaPercent(AValue: single);
begin
with AsStdCMYK do
Self.AsStdCMYK := TStdCMYK.New(C, AValue / 100, Y, K);
end;
class function TColorEx.New: TColorEx;
begin
Result := BGRAPixelTransparent;
end;
procedure TColorEx.FromName(AValue: string);
var
missingValues, error: boolean;
c: TBGRAPixel;
begin
c := BGRAPixelTransparent;
TryStrToBGRA(AValue, c, missingValues, error);
if not (missingValues or error) then
AsBGRAPixel := c;
end;
procedure TColorEx.SetRed(AValue: byte);
begin
with AsStdRGBA do
Self.AsStdRGBA := TStdRGBA.New(AValue / 255, green, blue, alpha);
end;
procedure TColorEx.SetRedPercent(AValue: single);
begin
with AsStdRGBA do
Self.AsStdRGBA := TStdRGBA.New(AValue / 100, green, blue, alpha);
end;
procedure TColorEx.SetSaturation(AValue: single);
begin
with AsStdHSLA do
Self.AsStdHSLA := TStdHSLA.New(hue, AValue, lightness, alpha);
end;
procedure TColorEx.SetSaturationPercent(AValue: single);
begin
with AsStdHSLA do
Self.AsStdHSLA := TStdHSLA.New(hue, AValue / 100, lightness, alpha);
end;
procedure TColorEx.FromStdRGBA(const AValue: TStdRGBA);
begin
SetValue(AValue, AValue.Colorspace);
end;
procedure TColorEx.FromString(AValue: string);
begin
AsBGRAPixel := StrToBGRA(AValue);
end;
procedure TColorEx.FromXYZA(AValue: TXYZA);
begin
SetValue(AValue, AValue.Colorspace);
end;
function TColorEx.Fade(APercent: single): TColorEx;
begin
Result := Self;
if APercent = 1 then
Exit;
Result.AlphaPercent := Result.AlphaPercent * APercent;
end;
function TColorEx.Darken(APercent: single): TColorEx;
begin
Result := Self;
Result.LightnessPercent := Result.LightnessPercent - APercent;
end;
function TColorEx.Lighten(APercent: single): TColorEx;
begin
Result := Self;
Result.LightnessPercent := Result.LightnessPercent + APercent;
end;
function TColorEx.Premultiply: TColorEx;
begin
with AsStdRGBA do
Self.AsStdRGBA:= TStdRGBA.New(red*alpha,green*alpha,blue*alpha,alpha);
Result:=Self;
end;
procedure TColorEx.SetYellow(AValue: single);
begin
with AsStdCMYK do
Self.AsStdCMYK := TStdCMYK.New(C, M, AValue, K);
end;
procedure TColorEx.SetYellowPercent(AValue: single);
begin
with AsStdCMYK do
Self.AsStdCMYK := TStdCMYK.New(C, M, AValue / 100, K);
end;
class function TColorEx.New(const AValue: TColorEx): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: string): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: TColor): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: TBGRAPixel): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: TExpandedPixel): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: TStdRGBA): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: TLinearRGBA): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: TXYZA): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: TLabA): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: TStdHSLA): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: TStdHSVA): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: TStdCMYK): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const AValue: TLChA): TColorEx;
begin
Result := AValue;
end;
class function TColorEx.New(const ARed, AGreen, ABlue: byte; const AAlpha: byte): TColorEx;
begin
Result := TStdRGBA.New(ARed / 255, AGreen / 255, ABlue / 255, AAlpha / 255);
end;
procedure TColorEx.SetValue(const AValue; AColorspace: TColorspaceAny);
begin
FColorspace:= AColorspace;
move(AValue, FValue, AColorspace.GetSize);
end;
procedure TColorEx.GetValue(out AValue; AColorspace: TColorspaceAny);
begin
if Assigned(FColorspace) then
FColorspace.Convert(FValue, AValue, AColorspace)
else
TBGRAPixelColorspace.Convert(BGRAPixelTransparent, AValue, AColorspace)
end;
end.

1514
bgrabitmap/test/colorspace/colorsdemounit.lfm Normal file
View File

File diff suppressed because it is too large Load Diff

468
bgrabitmap/test/colorspace/colorsdemounit.pas Normal file
View File

@@ -0,0 +1,468 @@
unit ColorsDemoUnit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls, StdCtrls, Spin, ExtCtrls,
BGRABitmap, BGRABitmapTypes, BGRAColorEx;
type
{ TForm1 }
TForm1 = class(TForm)
A_se: TFloatSpinEdit;
lambda1_se: TFloatSpinEdit;
A_tb: TTrackBar;
lambda1_tb: TTrackBar;
B2_se: TFloatSpinEdit;
lambda2_se: TFloatSpinEdit;
B2_tb: TTrackBar;
lambda2_tb: TTrackBar;
Dec_edt: TEdit;
Alpha_se: TFloatSpinEdit;
Alpha_tb: TTrackBar;
reflectance_se: TFloatSpinEdit;
reflectance_tb: TTrackBar;
Label47: TLabel;
Label48: TLabel;
Label49: TLabel;
Label50: TLabel;
Label51: TLabel;
Label52: TLabel;
Label53: TLabel;
Label54: TLabel;
Label55: TLabel;
LIsReal: TLabel;
lB_se1: TFloatSpinEdit;
lB_tb1: TTrackBar;
lG_se1: TFloatSpinEdit;
lG_tb1: TTrackBar;
lH2_se: TFloatSpinEdit;
lH2_tb: TTrackBar;
Label43: TLabel;
Label44: TLabel;
Label45: TLabel;
Label46: TLabel;
lH_se: TFloatSpinEdit;
lH_tb: TTrackBar;
Label31: TLabel;
Label32: TLabel;
Label33: TLabel;
Label34: TLabel;
Label35: TLabel;
Label36: TLabel;
Label37: TLabel;
Label38: TLabel;
Label39: TLabel;
Label40: TLabel;
Label41: TLabel;
Label42: TLabel;
lB_se: TFloatSpinEdit;
Label30: TLabel;
Grayscale_pnl: TPanel;
Invert_pnl: TPanel;
lL_se: TFloatSpinEdit;
lL_tb: TTrackBar;
lR_se1: TFloatSpinEdit;
lR_tb1: TTrackBar;
lS2_se: TFloatSpinEdit;
lS2_tb: TTrackBar;
sB_se: TFloatSpinEdit;
lB_tb: TTrackBar;
sB_tb: TTrackBar;
C2_se: TFloatSpinEdit;
C2_tb: TTrackBar;
C_se: TFloatSpinEdit;
C_tb: TTrackBar;
lG_se: TFloatSpinEdit;
sG_se: TFloatSpinEdit;
lG_tb: TTrackBar;
sG_tb: TTrackBar;
H2_se: TFloatSpinEdit;
H2_tb: TTrackBar;
H3_se: TFloatSpinEdit;
H3_tb: TTrackBar;
Hex_edt: TEdit;
H_se: TFloatSpinEdit;
H_tb: TTrackBar;
K_se: TFloatSpinEdit;
K_tb: TTrackBar;
L2_se: TFloatSpinEdit;
L2_tb: TTrackBar;
L3_se: TFloatSpinEdit;
L3_tb: TTrackBar;
Label1: TLabel;
Label10: TLabel;
Label11: TLabel;
Label12: TLabel;
Label13: TLabel;
Label14: TLabel;
Label15: TLabel;
Label16: TLabel;
Label17: TLabel;
Label18: TLabel;
Label19: TLabel;
Label2: TLabel;
Label20: TLabel;
Label21: TLabel;
Label22: TLabel;
Label23: TLabel;
Label24: TLabel;
Label25: TLabel;
Label26: TLabel;
Label27: TLabel;
Label28: TLabel;
Label29: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
L_se: TFloatSpinEdit;
L_tb: TTrackBar;
M_se: TFloatSpinEdit;
M_tb: TTrackBar;
Name_edt: TEdit;
Color_pnl: TPanel;
lR_se: TFloatSpinEdit;
sR_se: TFloatSpinEdit;
lR_tb: TTrackBar;
sR_tb: TTrackBar;
S2_se: TFloatSpinEdit;
S2_tb: TTrackBar;
S_se: TFloatSpinEdit;
lS_se: TFloatSpinEdit;
S_tb: TTrackBar;
gamma_tb: TTrackBar;
lS_tb: TTrackBar;
V_se: TFloatSpinEdit;
gamma_se: TFloatSpinEdit;
lL2_se: TFloatSpinEdit;
V_tb: TTrackBar;
lL2_tb: TTrackBar;
X_se: TFloatSpinEdit;
X_tb: TTrackBar;
Y2_se: TFloatSpinEdit;
Y2_tb: TTrackBar;
Y_se: TFloatSpinEdit;
Y_tb: TTrackBar;
Z_se: TFloatSpinEdit;
Z_tb: TTrackBar;
procedure FormCreate(Sender: TObject);
procedure gamma_seChange(Sender: TObject);
procedure gamma_tbChange(Sender: TObject);
private
col: TColorEx;
ChangingColors: boolean;
procedure InitControls;
procedure UserInputChange(Sender: TObject);
procedure UpdateColorControls(SourceTag: integer);
function FindComponentByTag(ATag: integer; AClassName: string): TComponent;
public
end;
var
Form1: TForm1;
implementation
uses XYZABitmap;
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
BGRASetGamma(2.2);
XYZToRGBOverflowMax:= xroPreserveHue;
XYZToRGBOverflowMin:= xroPreserveHue;
InitControls;
end;
procedure TForm1.gamma_seChange(Sender: TObject);
begin
if ChangingColors then
exit;
ChangingColors := True;
BGRASetGamma(gamma_se.Value);
gamma_tb.Position := round(gamma_se.Value * 100);
UpdateColorControls(-1);
ChangingColors := False;
end;
procedure TForm1.gamma_tbChange(Sender: TObject);
begin
if ChangingColors then
exit;
ChangingColors := True;
gamma_se.Value := gamma_tb.Position / 100;
BGRASetGamma(gamma_se.Value);
UpdateColorControls(-1);
ChangingColors := False;
end;
procedure TForm1.InitControls;
var
i: integer;
tb: TTrackBar;
fse: TFloatSpinEdit;
procedure SetControlsValues(ca: array of TTrackBar; Mi, Mx, Fr: integer);
var
i: integer;
begin
for i := 0 to Length(ca) - 1 do
begin
with ca[i] do
begin
Max := Mx;
Min := Mi;
Frequency := Fr;
end;
end;
end;
begin
ChangingColors := True;
SetControlsValues([lR_tb, lG_tb, lB_tb], 0, 100, 10);
SetControlsValues([sR_tb, sG_tb, sB_tb], 0, 255, 10);
SetControlsValues([lR_tb1, lG_tb1, lB_tb1], 0, 255, 10);
SetControlsValues([H_tb], 0, 360, 10);
SetControlsValues([S_tb, L_tb], 0, 100, 10);
SetControlsValues([H2_tb], 0, 360, 10);
SetControlsValues([S2_tb, V_tb], 0, 100, 10);
SetControlsValues([Y2_tb], 0, 100, 10);
SetControlsValues([X_tb, Z_tb], 0, 120, 10);
SetControlsValues([L2_tb], 0, 100, 10);
SetControlsValues([A_tb], -160, 160, 10);
SetControlsValues([B2_tb], -140, 140, 10);
SetControlsValues([C_tb, M_tb, Y_tb, K_tb], 0, 100, 10);
SetControlsValues([L3_tb], 0, 100, 10);
SetControlsValues([C2_tb], 0, round(TLChAColorspace.GetMaxValue(1)), 10);
SetControlsValues([H3_tb], 0, 360, 10);
SetControlsValues([Alpha_tb], 0, 100, 10);
SetControlsValues([lH_tb, lH2_tb], 0, 360, 10);
SetControlsValues([lS_tb, lL_tb, lS2_tb, lL2_tb], 0, 100, 10);
SetControlsValues([reflectance_tb], 0, 100, 10);
SetControlsValues([lambda1_tb,lambda2_tb], 360, 830, 10);
for i := 0 to ComponentCount - 1 do
begin
if Components[i] is TTrackBar then
begin
if Components[i].Tag <> 0 then
begin
tb := TTrackBar(Components[i]);
tb.OnChange := @UserInputChange;
fse := TFloatSpinEdit(FindComponentByTag(Components[i].Tag, 'TFloatSpinEdit'));
if (fse <> nil) then
begin
fse.MinValue := tb.Min;
fse.MaxValue := tb.Max;
fse.OnChange := @UserInputChange;
end;
end;
end;
end;
Hex_edt.OnChange := @UserInputChange;
Dec_edt.OnChange := @UserInputChange;
Name_edt.OnChange := @UserInputChange;
gamma_se.Value := BGRAGetGamma;
gamma_tb.Position := round(gamma_se.Value * 100);
col.AsBGRAPixel := BGRABlack;
UpdateColorControls(-1);
ChangingColors := False;
end;
procedure TForm1.UserInputChange(Sender: TObject);
var
t: integer;
v: single;
begin
if ChangingColors then
Exit;
ChangingColors := True;
t := TComponent(Sender).Tag;
if Sender is TFloatSpinEdit then
begin
if not TryStrToFloat(TFloatSpinEdit(Sender).Text, v) then
v := 0;
TTrackBar(FindComponentByTag(t, 'TTrackBar')).Position := round(v);
end;
if Sender is TTrackBar then
TFloatSpinEdit(FindComponentByTag(t, 'TFloatSpinEdit')).Text := IntToStr(TTrackBar(Sender).Position);
UpdateColorControls(t);
ChangingColors := False;
end;
procedure TForm1.UpdateColorControls(SourceTag: integer);
var
i,decVal,errPos: integer;
tb: TTrackBar;
fse: TFloatSpinEdit;
viewBmp: TBGRABitmap;
begin
case SourceTag of
1, 2, 3: col.AsLinearRGBA := TLinearRGBA.New(lR_se.Value / 100, lG_se.Value / 100, lB_se.Value / 100, Alpha_se.Value / 100);
4, 5, 6: col.AsStdHSLA := TStdHSLA.New(H_se.Value, S_se.Value / 100, L_se.Value / 100, Alpha_se.Value / 100);
7, 8, 9: col.AsStdHSVA := TStdHSVA.New(H2_se.Value, S2_se.Value / 100, V_se.Value / 100, Alpha_se.Value / 100);
17, 18, 19: col.AsXYZA := TXYZA.New(X_se.Value / 100, Y2_se.Value / 100, Z_se.Value / 100, Alpha_se.Value / 100);
10, 11, 12: col.AsLabA := TLabA.New(L2_se.Value, A_se.Value, B2_se.Value, Alpha_se.Value / 100);
13, 14, 15, 16: col.AsStdCMYK := TStdCMYK.New(C_se.Value / 100, M_se.Value / 100, Y_se.Value / 100, K_se.Value / 100);
20, 21, 22: col.AsLChA := TLChA.New(L3_se.Value, C2_se.Value, H3_se.Value, Alpha_se.Value / 100);
23: col.AsHex := Hex_edt.Text;
24: begin
val(Dec_edt.Text, decVal, errPos);
if (errPos = 0) and (decVal>=0) then
col.AsDecimal := decVal;
end;
25, 26, 27: col.AsStdRGBA := TStdRGBA.New(sR_se.Value / 255, sG_se.Value / 255, sB_se.Value / 255, Alpha_se.Value / 100);
28: col.Name := Name_edt.Text;
29: col.AlphaPercent := Alpha_se.Value;
50, 51, 52: col.AsHSLAPixel := THSLAPixel.New(round(lH_se.Value/360*65536) and $ffff, round(lS_se.Value / 100*65535), round(lL_se.Value / 100*65535), round(Alpha_se.Value / 100*65535));
53, 54, 55: col.AsGSBAPixel := TGSBAPixel.New(round(lH2_se.Value/360*65536) and $ffff, round(lS2_se.Value / 100*65535), round(lL2_se.Value / 100*65535), round(Alpha_se.Value / 100*65535));
60, 61, 62: col.AsAdobeRGBA := TAdobeRGBA.New(round(lR_se1.Value), round(lG_se1.Value), round(lB_se1.Value), round(Alpha_se.Value / 100 * 255));
70, 71, 72: col.AsXYZA := SpectrumRangeReflectToXYZA(reflectance_se.Value / 100, lambda1_se.Value, lambda2_se.Value, Alpha_se.Value / 100);
end;
if not (SourceTag in [1, 2, 3]) then
with col.AsLinearRGBA do
begin
lR_se.Value := red * 100;
lG_se.Value := green * 100;
lB_se.Value := blue * 100;
end;
if not (SourceTag in [4, 5, 6]) then
with col.AsStdHSLA do
begin
H_se.Value := hue;
S_se.Value := saturation * 100;
L_se.Value := lightness * 100;
end;
if not (SourceTag in [7, 8, 9]) then
with col.AsStdHSVA do
begin
H2_se.Value := hue;
S2_se.Value := saturation * 100;
V_se.Value := value * 100;
end;
if not (SourceTag in [17, 18, 19]) then
with col.AsXYZA do
begin
X_se.Value := X * 100;
Y2_se.Value := Y * 100;
Z_se.Value := Z * 100;
end;
if not (SourceTag in [10, 11, 12]) then
with col.AsLabA do
begin
L2_se.Value := L;
A_se.Value := a;
B2_se.Value := b;
end;
if not (SourceTag in [25, 26, 27]) then
with col.AsStdRGBA do
begin
sR_se.Value := red * 255;
sG_se.Value := green * 255;
sB_se.Value := blue * 255;
end;
if not (SourceTag in [13, 14, 15, 16]) then
with col.AsStdCMYK do
begin
C_se.Value := C * 100;
M_se.Value := M * 100;
Y_se.Value := Y * 100;
K_se.Value := K * 100;
end;
if not (SourceTag in [20, 21, 22]) then
with col.AsLchA do
begin
L3_se.Value := L;
C2_se.Value := c;
H3_se.Value := h;
end;
if SourceTag <> 23 then
Hex_edt.Text := col.AsHex;
if SourceTag <> 24 then
Dec_edt.Text := IntToStr(col.AsDecimal);
if SourceTag <> 28 then
Name_edt.Text := col.Name;
if SourceTag <> 29 then
Alpha_se.Value := col.AlphaPercent;
if not (SourceTag in [50,51,52]) then
with col.AsHSLAPixel do
begin
lH_se.Value := hue/65536 * 360;
lS_se.Value := saturation/65535 * 100;
lL_se.Value := lightness/65535 * 100;
end;
if not (SourceTag in [53,54,55]) then
with col.AsGSBAPixel do
begin
lH2_se.Value := hue/65536 * 360;
lS2_se.Value := saturation/65535 * 100;
lL2_se.Value := lightness/65535 * 100;
end;
if not (SourceTag in [60,61,62]) then
with col.AsAdobeRGBA do
begin
lR_se1.Value := red;
lG_se1.Value := green;
lB_se1.Value := blue;
end;
for i := 0 to ComponentCount - 1 do
begin
if Components[i] is TTrackBar then
begin
if Components[i].Tag <> 0 then
begin
tb := TTrackBar(Components[i]);
tb.OnChange := @UserInputChange;
fse := TFloatSpinEdit(FindComponentByTag(Components[i].Tag, 'TFloatSpinEdit'));
if (fse <> nil) then
tb.Position := round(fse.Value);
end;
end;
end;
viewBmp := TBGRABitmap.Create(3,1, clBtnFace);
viewBmp.DrawPixel(0,0, col.AsBGRAPixel, dmDrawWithTransparency);
viewBmp.DrawPixel(1,0, col.AsGrayscale.AsBGRAPixel, dmDrawWithTransparency);
viewBmp.DrawPixel(2,0, col.AsInvert.AsBGRAPixel, dmDrawWithTransparency);
Color_pnl.Color := viewBmp.GetPixel(0,0);
Grayscale_pnl.Color := viewBmp.GetPixel(1,0);
Invert_pnl.Color := viewBmp.GetPixel(2,0);
viewBmp.Free;
if IsRealColor(col.AsXYZA) then
LIsReal.Caption := 'Real color'
else
LIsReal.Caption := 'Imaginary color';
end;
function TForm1.FindComponentByTag(ATag: integer; AClassName: string): TComponent;
var
i: integer;
begin
Result := nil;
for i := 0 to ComponentCount - 1 do
if (Components[i].Tag = ATag) and (Components[i].ClassName = AClassName) then
Result := Components[i];
end;
end.

235
bgrabitmap/test/colorspace/uhorseshoe.lfm Normal file
View File

@@ -0,0 +1,235 @@
object Form1: TForm1
Left = 257
Height = 622
Top = 140
Width = 1239
Caption = 'XYZ horseshoe'
ClientHeight = 622
ClientWidth = 1239
DesignTimePPI = 144
Font.Height = -20
OnCreate = FormCreate
LCLVersion = '2.1.0.0'
object Panel1: TPanel
Left = 0
Height = 622
Top = 0
Width = 620
Align = alLeft
ClientHeight = 622
ClientWidth = 620
TabOrder = 0
object cbYAxis: TComboBox
Left = 6
Height = 36
Top = 6
Width = 150
ItemHeight = 0
OnChange = cbYAxisChange
TabOrder = 1
Text = 'cbYAxis'
end
object vsGradient: TBGRAVirtualScreen
Left = 6
Height = 408
Top = 48
Width = 602
OnRedraw = vsGradientRedraw
Alignment = taLeftJustify
Anchors = [akTop, akLeft, akRight, akBottom]
Color = clWhite
ParentColor = False
TabOrder = 2
end
object cbXAxis: TComboBox
Left = 458
Height = 36
Top = 462
Width = 150
Anchors = [akRight, akBottom]
ItemHeight = 0
OnChange = cbXAxisChange
TabOrder = 0
Text = 'cbXAxis'
end
object cbColorspace: TComboBox
Left = 452
Height = 36
Top = 6
Width = 160
Anchors = [akTop, akRight]
ItemHeight = 0
OnChange = cbColorspaceChange
TabOrder = 3
Text = 'cbColorspace'
end
object Label1: TLabel
Left = 334
Height = 24
Top = 12
Width = 110
Anchors = [akTop, akRight]
Caption = 'Colorspace'
ParentColor = False
end
object lblMaxY: TLabel
Left = 160
Height = 24
Top = 12
Width = 53
Caption = 'MaxY'
ParentColor = False
end
object lblMaxX: TLabel
Left = 389
Height = 24
Top = 468
Width = 55
Alignment = taRightJustify
Anchors = [akRight, akBottom]
Caption = 'MaxX'
ParentColor = False
end
object lblMin: TLabel
Left = 6
Height = 24
Top = 468
Width = 117
Anchors = [akLeft, akBottom]
Caption = 'MinY / MinX'
ParentColor = False
end
object tbZ: TTrackBar
Left = 120
Height = 68
Top = 491
Width = 488
OnChange = tbZChange
Position = 0
Anchors = [akRight, akBottom]
TabOrder = 4
end
object lblZ: TLabel
Left = 12
Height = 24
Top = 517
Width = 97
Anchors = [akLeft, akBottom]
Caption = 'ChannelZ'
ParentColor = False
end
object lblZ2: TLabel
Left = 12
Height = 24
Top = 577
Width = 110
Anchors = [akLeft, akBottom]
Caption = 'ChannelZ2'
ParentColor = False
end
object tbZ2: TTrackBar
Left = 124
Height = 68
Top = 551
Width = 484
OnChange = tbZChange
Position = 0
Anchors = [akRight, akBottom]
TabOrder = 5
end
object cbFluorescent: TCheckBox
Left = 227
Height = 28
Hint = 'Include fluorescent colors or light sources'
Top = 10
Width = 90
Anchors = [akTop, akLeft, akRight]
Caption = 'Fluo'
OnClick = cbFluorescentClick
ParentFont = False
ParentShowHint = False
ShowHint = True
TabOrder = 6
end
end
object Splitter1: TSplitter
Left = 620
Height = 622
Top = 0
Width = 8
end
object Panel2: TPanel
Left = 628
Height = 622
Top = 0
Width = 611
Align = alClient
ClientHeight = 622
ClientWidth = 611
TabOrder = 2
object vsHorseshoe: TBGRAVirtualScreen
Left = 1
Height = 572
Top = 49
Width = 609
OnRedraw = vsHorseshoeRedraw
Align = alClient
Alignment = taLeftJustify
Color = clWhite
ParentColor = False
TabOrder = 0
end
object Panel3: TPanel
Left = 1
Height = 48
Top = 1
Width = 609
Align = alTop
BevelOuter = bvNone
ClientHeight = 48
ClientWidth = 609
TabOrder = 1
object Label2: TLabel
Left = 8
Height = 24
Top = 9
Width = 98
Caption = 'Ref. white'
ParentColor = False
end
object cbReferenceWhite: TComboBox
Left = 120
Height = 36
Top = 4
Width = 136
ItemHeight = 0
OnChange = cbReferenceWhiteChange
TabOrder = 0
Text = 'cbReferenceWhite'
end
object Label3: TLabel
Left = 264
Height = 24
Top = 9
Width = 89
Caption = 'Overflow'
ParentColor = False
end
object cbOverflow: TComboBox
Left = 360
Height = 34
Top = 4
Width = 240
ItemHeight = 0
Items.Strings = (
'Clip to RGB display'
'Saturate per channel'
'Preserve hue'
)
OnChange = cbOverflowChange
Style = csDropDownList
TabOrder = 1
end
end
end
end

793
bgrabitmap/test/colorspace/uhorseshoe.pas Normal file
View File

@@ -0,0 +1,793 @@
unit uhorseshoe;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls, ComCtrls, BGRAVirtualScreen, BGRABitmap, BGRABitmapTypes,
BGRAGradientScanner;
type
{ TForm1 }
TForm1 = class(TForm)
cbColorspace: TComboBox;
cbReferenceWhite: TComboBox;
cbOverflow: TComboBox;
cbFluorescent: TCheckBox;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
lblZ: TLabel;
lblZ2: TLabel;
lblMaxY: TLabel;
lblMaxX: TLabel;
lblMin: TLabel;
Panel2: TPanel;
Panel3: TPanel;
tbZ: TTrackBar;
tbZ2: TTrackBar;
vsGradient: TBGRAVirtualScreen;
cbYAxis: TComboBox;
cbXAxis: TComboBox;
Panel1: TPanel;
Splitter1: TSplitter;
vsHorseshoe: TBGRAVirtualScreen;
procedure cbColorspaceChange(Sender: TObject);
procedure cbFluorescentClick(Sender: TObject);
procedure cbOverflowChange(Sender: TObject);
procedure cbReferenceWhiteChange(Sender: TObject);
procedure cbXAxisChange(Sender: TObject);
procedure cbYAxisChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure tbZChange(Sender: TObject);
procedure vsGradientRedraw(Sender: TObject; Bitmap: TBGRABitmap);
procedure vsHorseshoeRedraw(Sender: TObject; Bitmap: TBGRABitmap);
procedure UpdateSelectedAxis;
procedure UpdateSelectedColorspace;
procedure UpdateRGBOverlow;
private
ZName, Z2Name: string;
ZFactor, Z2Factor: single;
function SelectedColorspace: TColorspaceAny;
procedure UpdateReferenceWhiteFromCombo;
public
end;
{ THorseShoeScanner }
THorseShoeScanner = class(TBGRACustomScanner)
protected
FOrigin: TPointF;
FWidth,FHeight,FXStep,FYStep: single;
FXYZ: TXYZA;
FHorseShoeGrayAmount,FHorseShoeGrayLevel: single;
public
constructor Create(AOrigin: TPointF; AWidth,AHeight: single;
AHorseShoeGrayAmount,AHorseShoeGrayLevel: single);
procedure AdaptColorToRGBDisplay(var xyz: TXYZA);
function ScanAtXYZ(X,Y: Single): TXYZA;
function ScanAt(X,Y: Single): TBGRAPixel; override;
procedure ScanMoveTo(X,Y: Integer); override;
function ScanNextPixel: TBGRAPixel; override;
end;
var
Form1: TForm1;
implementation
uses XYZABitmap;
const
OptimalReflectStep = 250;
OptimalReflectArraySize = OptimalReflectStep;
OptimalReflectBorderStep = OptimalReflectStep div 10;
var
OptimalReflectXYZ: array[0..OptimalReflectArraySize,0..OptimalReflectArraySize] of record
min,max: single;
end;
{ optimalXYZMin,optimalXYZMax: TXYZA; }
{ labMin,labMax: TLabA;
lchMin,lchMax: TLChA;}
function IsOptimalReflect(xyz: TXYZA): boolean;
begin
with GetReferenceWhite do
begin
xyz.X /= X;
xyz.Y /= Y;
xyz.Z /= Z;
end;
if (xyz.Y >= 0) and (xyz.Y <= 1) and
(xyz.X >= 0) and (xyz.X <= 1) and
(xyz.Z >= 0) and (xyz.Z <= 1) then
begin
xyz.X := sqrt(xyz.X);
xyz.Z := sqrt(xyz.Z);
with OptimalReflectXYZ[round(xyz.X*OptimalReflectStep),round(xyz.Z*OptimalReflectStep)] do
if (min <> EmptySingle) and (xyz.Y >= min) and (xyz.Y <= max) then exit(true);
end;
result := false;
end;
procedure AddOptimalReflect(xyz: TXYZA);
{var
lab: TLabA;
lch: TLChA; }
begin
{ if xyz.X < optimalXYZMin.X then optimalXYZMin.X := xyz.X;
if xyz.Y < optimalXYZMin.Y then optimalXYZMin.Y := xyz.Y;
if xyz.Z < optimalXYZMin.Z then optimalXYZMin.Z := xyz.Z;
if xyz.X > optimalXYZMax.X then optimalXYZMax.X := xyz.X;
if xyz.Y > optimalXYZMax.Y then optimalXYZMax.Y := xyz.Y;
if xyz.Z > optimalXYZMax.Z then optimalXYZMax.Z := xyz.Z; }
{ lab := xyz.ToLabA(ReferenceWhite2E);
if lab.L < labMin.L then labMin.L := lab.L;
if lab.a < labMin.a then labMin.a := lab.a;
if lab.b < labMin.b then labMin.b := lab.b;
if lab.L > labMax.L then labMax.L := lab.L;
if lab.a > labMax.a then labMax.a := lab.a;
if lab.b > labMax.b then labMax.b := lab.b;
lch := lab.ToLChA;
if lch.L < lchMin.L then lchMin.L := lch.L;
if lch.C < lchMin.C then lchMin.C := lch.C;
if lch.h < lchMin.h then lchMin.h := lch.h;
if lch.L > lchMax.L then lchMax.L := lch.L;
if lch.C > lchMax.C then lchMax.C := lch.C;
if lch.h > lchMax.h then lchMax.h := lch.h; }
if (xyz.Y >= 0) and (xyz.Y <= 1) and
(xyz.X >= 0) and (xyz.X <= 1) and
(xyz.Z >= 0) and (xyz.Z <= 1) then
begin
xyz.X := sqrt(xyz.X);
xyz.Z := sqrt(xyz.Z);
with OptimalReflectXYZ[round(xyz.X*OptimalReflectStep),
round(xyz.Z*OptimalReflectStep)] do
begin
if min = EmptySingle then
begin
min := xyz.Y;
max := xyz.Y;
end else
begin
if xyz.Y < min then min := xyz.Y;
if xyz.Y > max then max := xyz.Y;
end;
end;
end;
end;
{$R *.lfm}
{ THorseShoeScanner }
constructor THorseShoeScanner.Create(AOrigin: TPointF; AWidth, AHeight: single;
AHorseShoeGrayAmount,AHorseShoeGrayLevel: single);
begin
FOrigin := AOrigin;
FWidth:= AWidth;
FHeight:= AHeight;
FHorseShoeGrayAmount:= AHorseShoeGrayAmount;
FHorseShoeGrayLevel:= AHorseShoeGrayLevel;
FXStep := 1/FWidth*(1-FHorseShoeGrayAmount);
FYStep := 1/FHeight*(1-FHorseShoeGrayAmount);
end;
procedure THorseShoeScanner.AdaptColorToRGBDisplay(var xyz:TXYZA);
begin
xyz.X := xyz.X*(1-FHorseShoeGrayAmount) + FHorseShoeGrayLevel*FHorseShoeGrayAmount;
xyz.Y := xyz.Y*(1-FHorseShoeGrayAmount) + FHorseShoeGrayLevel*FHorseShoeGrayAmount;
xyz.Z := xyz.Z*(1-FHorseShoeGrayAmount) + FHorseShoeGrayLevel*FHorseShoeGrayAmount;
end;
function THorseShoeScanner.ScanAtXYZ(X, Y: Single): TXYZA;
begin
result := TXYZA.New((X-FOrigin.X)/FWidth,(Y-FOrigin.Y)/FHeight,0);
result.Z := 1-(result.X+result.Y);
AdaptColorToRGBDisplay(result);
end;
function THorseShoeScanner.ScanAt(X, Y: Single): TBGRAPixel;
begin
result := ScanAtXYZ(X,Y).ToBGRAPixel;
end;
procedure THorseShoeScanner.ScanMoveTo(X, Y: Integer);
begin
FXYZ := ScanAtXYZ(X,Y);
end;
function THorseShoeScanner.ScanNextPixel: TBGRAPixel;
begin
result := FXYZ.ToBGRAPixel;
FXYZ.X += FXStep;
FXYZ.Z -= FXStep;
end;
{ TForm1 }
procedure TForm1.vsHorseshoeRedraw(Sender: TObject; Bitmap: TBGRABitmap);
var
squareWidth,squareHeight: single;
squareOrigin: TPointF;
function xyzToPointF(xyz: TXYZA): TPointF;
var
n: single;
begin
n := xyz.X+xyz.Y+xyz.Z;
if (n <= 0) or (xyz.X < 0) or (xyz.Y < 0) or (xyz.Z < 0) then
result := EmptyPointF
else
result := PointF(squareOrigin.x+xyz.X/n*squareWidth,squareOrigin.y+xyz.Y/n*squareHeight);
end;
procedure DrawHorseShoe;
const HorseShoeMargin = 0.02;
var
i,j: Integer;
xyz: TXYZA;
pts: array of TPointF;
scan: THorseShoeScanner;
min,max: TPointF;
marginX,marginY: single;
prevRefWhite: TXYZReferenceWhite;
begin
squareOrigin := PointF(0,0);
squareWidth:= 1;
squareHeight:= 1;
setlength(pts, length(SpectralLocus));
xyz.alpha := 1;
j := 0;
for i := low(SpectralLocus) to high(SpectralLocus) do
begin
xyz.X := SpectralLocus[i].X;
xyz.Y := SpectralLocus[i].Y;
xyz.Z := SpectralLocus[i].Z;
pts[j] := xyzToPointF(xyz);
if i = low(SpectralLocus) then
begin
min := pts[j];
max := pts[j];
end else
begin
if pts[j].x < min.x then min.x := pts[j].x
else if pts[j].x > max.x then max.x := pts[j].x;
if pts[j].y < min.y then min.y := pts[j].y
else if pts[j].y > max.y then max.y := pts[j].y;
end;
inc(j);
end;
marginX := Bitmap.Width * HorseShoeMargin;
marginY := Bitmap.Height * HorseShoeMargin;
squareWidth:= (Bitmap.Width-1-2*marginX)/max.x;
squareHeight := -(Bitmap.Height-1-2*marginY)/max.y;
squareOrigin := PointF(marginX,Bitmap.Height-1-marginY);
for j := 0 to high(pts) do
pts[j] := squareOrigin + PointF(pts[j].x*squareWidth,pts[j].y*squareHeight);
// spectral locus is normalized for equal illuminant
prevRefWhite := GetReferenceWhite;
SetReferenceWhite(2, 'E');
if XYZToRGBOverflowMin = xroClipToTarget then
scan := THorseShoeScanner.Create(squareOrigin, squareWidth, squareHeight, 0.36, 0)
else
scan := THorseShoeScanner.Create(squareOrigin, squareWidth, squareHeight, 0.5, 0.25);
pts := Bitmap.ComputeOpenedSpline(pts, ssCrossingWithEnds);
Bitmap.FillPolyAntialias(pts,scan);
Bitmap.DrawPolygonAntialias(pts,BGRABlack, (Bitmap.Width+Bitmap.Height)/600);
scan.Free;
SetReferenceWhite(prevRefWhite);
end;
procedure DrawColorspace;
const bitsPerChannel = 3;
maxPerChannel = (1 shl bitsPerChannel)-1;
var
xyz: TXYZA;
i,j, channelCount, bitCount: Integer;
colorspace: TColorspaceAny;
colorValue: pointer;
dotSize: single;
pt: TPointF;
min,max: array of single;
begin
dotSize := (Bitmap.Width+Bitmap.Height)/400;
colorspace := SelectedColorspace;
getmem(colorValue, colorspace.GetSize);
channelCount:= colorspace.GetChannelCount;
setlength(min, channelCount);
setlength(max, channelCount);
for j := 0 to channelCount-1 do
begin
min[j] := colorspace.GetMinValue(j);
max[j] := colorspace.GetMaxValue(j);
end;
if colorspace.IndexOfAlphaChannel = channelCount-1 then
begin
colorspace.SetChannel(colorValue, channelCount-1, max[channelCount-1]);
dec(channelCount);
end;
bitCount := channelCount*bitsPerChannel;
for i := 0 to (1 shl bitCount) - 1 do
begin
for j := 0 to channelCount-1 do
colorspace.SetChannel(colorValue, j, min[j] + (max[j]-min[j]) * ((i shr (j*bitsPerChannel)) and maxPerChannel)/maxPerChannel);
colorspace.Convert(colorValue^, xyz, TXYZAColorspace);
pt := xyzToPointF(xyz);
if not isEmptyPointF(pt) then
Bitmap.FillEllipseAntialias(pt.x,pt.y, dotSize,dotSize, BGRA(0,0,0,128));
end;
freemem(colorValue);
end;
begin
Bitmap.Fill(CSSGray);
DrawHorseShoe;
DrawColorspace;
end;
procedure TForm1.UpdateSelectedAxis;
var
colorspace: TColorspaceAny;
procedure UpdateZCombo(zIndex: integer; var ZName: string; var zFactor: single; lblZ: TLabel; tbZ: TTrackBar);
begin
if zIndex = -1 then
begin
lblZ.Caption := '';
tbZ.Enabled := false;
end else
begin
ZName := colorspace.GetChannelName(zIndex);
lblZ.Caption := ZName;
tbZ.Enabled := true;
if colorspace.GetMaxValue(zIndex)-colorspace.GetMinValue(zIndex) < 10 then
zFactor:= 100
else
zFactor := 1;
tbZ.Min := round(colorspace.GetMinValue(zIndex)*zFactor);
tbZ.Max := round(colorspace.GetMaxValue(zIndex)*zFactor);
if ZName = 'Alpha' then
tbZ.Position := tbZ.Max
else
tbZ.Position := (tbZ.Max+tbZ.Min) div 2;
end;
end;
var
i,j: Integer;
zIndex,z2Index: integer;
begin
colorspace := SelectedColorspace;
j := 0;
zIndex := -1;
z2Index:= -1;
for i := 0 to colorspace.GetChannelCount-1 do
begin
if (colorspace.GetChannelName(i) <> cbXAxis.Text) and
(colorspace.GetChannelName(i) <> cbYAxis.Text) then
begin
case j of
0: zIndex := i;
1: z2Index:= i;
end;
inc(j);
end;
end;
UpdateZCombo(zIndex, ZName, zFactor, lblZ, tbZ);
UpdateZCombo(z2Index, Z2Name, z2Factor, lblZ2, tbZ2);
vsGradient.DiscardBitmap;
end;
procedure TForm1.UpdateSelectedColorspace;
var
colorspace: TColorspaceAny;
i: Integer;
begin
colorspace := SelectedColorspace;
cbXAxis.Items.Clear;
cbXAxis.Style := csDropDownList;
for i := 0 to colorspace.GetChannelCount-1 do
cbXAxis.Items.Add(colorspace.GetChannelName(i));
cbYAxis.Items.Clear;
cbYAxis.Style := csDropDownList;
for i := 0 to colorspace.GetChannelCount-1 do
cbYAxis.Items.Add(colorspace.GetChannelName(i));
if (colorspace = TXYZAColorspace) or (colorspace = TWordXYZAColorspace) then
begin
cbXAxis.ItemIndex:= colorspace.IndexOfChannel('X');
cbYAxis.ItemIndex:= colorspace.IndexOfChannel('Z');
end else
if (colorspace = TYCbCr601Colorspace) or (colorspace = TYCbCr601JPEGColorspace) or
(colorspace = TYCbCr709Colorspace) or (colorspace = TYCbCr709JPEGColorspace) then
begin
cbXAxis.ItemIndex:= colorspace.IndexOfChannel('BlueDiff');
cbYAxis.ItemIndex:= colorspace.IndexOfChannel('RedDiff');
end else
if colorspace = TLabAColorspace then
begin
cbXAxis.ItemIndex:= colorspace.IndexOfChannel('a');
cbYAxis.ItemIndex:= colorspace.IndexOfChannel('b');
end else
if colorspace = TLChAColorspace then
begin
cbXAxis.ItemIndex:= colorspace.IndexOfChannel('Hue');
cbYAxis.ItemIndex:= colorspace.IndexOfChannel('Chroma');
end else
begin
cbXAxis.ItemIndex:= 0;
if colorspace.GetChannelCount> 1 then
cbYAxis.ItemIndex:= 1
else
cbYAxis.ItemIndex:= 0;
end;
cbReferenceWhite.Enabled := cfReferenceWhiteIndependent in colorspace.GetFlags;
if (colorspace = TXYZAColorspace) or (colorspace = TWordXYZAColorspace) then SetReferenceWhite(2, 'E')
else UpdateReferenceWhiteFromCombo;
UpdateSelectedAxis;
vsHorseshoe.DiscardBitmap;
end;
procedure TForm1.UpdateRGBOverlow;
begin
XYZToRGBOverflowMin:= TColorspaceOverflow(cbOverflow.ItemIndex);
XYZToRGBOverflowMax:= TColorspaceOverflow(cbOverflow.ItemIndex);
end;
function TForm1.SelectedColorspace: TColorspaceAny;
var
i: Integer;
begin
for i := 0 to ColorspaceCollection.GetCount-1 do
if ColorspaceCollection.GetItem(i).GetName = cbColorspace.Text then
exit(ColorspaceCollection.GetItem(i));
result := TBGRAPixelColorspace;
end;
procedure TForm1.UpdateReferenceWhiteFromCombo;
begin
if cbReferenceWhite.ItemIndex <> -1 then
begin
SetReferenceWhite(GetReferenceWhiteByIndex(cbReferenceWhite.ItemIndex));
vsGradient.DiscardBitmap;
vsHorseshoe.DiscardBitmap;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i: Integer;
csName: String;
begin
cbColorspace.Items.Clear;
cbColorspace.Style := csDropDownList;
for i := 0 to ColorspaceCollection.GetCount-1 do
begin
csName := ColorspaceCollection.GetItem(i).GetName;
if (csName <> 'Color') and (csName <> 'BGRAPixel') and (csName <> 'ExpandedPixel')
and (csName <> 'FPColor') then
cbColorspace.Items.Add(csName);
end;
cbColorspace.ItemIndex := 0;
cbReferenceWhite.Items.Clear;
cbReferenceWhite.Style := csDropDownList;
for i := 0 to GetReferenceWhiteCount-1 do
with GetReferenceWhiteByIndex(i) do
begin
cbReferenceWhite.Items.Add(inttostr(ObserverAngle)+'° '+Illuminant);
if (ObserverAngle = GetReferenceWhite.ObserverAngle) and (Illuminant = GetReferenceWhite.Illuminant) then
cbReferenceWhite.ItemIndex := cbReferenceWhite.Items.Count-1;
end;
UpdateSelectedColorspace;
cbOverflow.ItemIndex:= ord(xroPreserveHue);
UpdateRGBOverlow;
end;
procedure TForm1.tbZChange(Sender: TObject);
begin
vsGradient.DiscardBitmap;
end;
procedure TForm1.cbColorspaceChange(Sender: TObject);
begin
UpdateSelectedColorspace;
end;
procedure TForm1.cbFluorescentClick(Sender: TObject);
begin
vsGradient.DiscardBitmap;
end;
procedure TForm1.cbOverflowChange(Sender: TObject);
begin
vsGradient.DiscardBitmap;
vsHorseshoe.DiscardBitmap;
UpdateRGBOverlow;
end;
procedure TForm1.cbReferenceWhiteChange(Sender: TObject);
begin
UpdateReferenceWhiteFromCombo;
end;
procedure TForm1.cbXAxisChange(Sender: TObject);
begin
UpdateSelectedAxis;
end;
procedure TForm1.cbYAxisChange(Sender: TObject);
begin
UpdateSelectedAxis;
end;
procedure TForm1.vsGradientRedraw(Sender: TObject; Bitmap: TBGRABitmap);
var
colorspace: TColorspaceAny;
rowData, p: PByte;
valueSize, rowDataSize, y, x: integer;
idxAlpha, idxChX, idxChY, idxZ: integer;
maxAlpha, zValue, minChX, minChY, maxChX, maxChY, valX, valXStep, valY: single;
s: string;
temp: TBGRABitmap;
xyzaBuf: array of TXYZA;
begin
colorspace := SelectedColorspace;
valueSize := colorspace.GetSize;
rowDataSize := Bitmap.Width * valueSize;
getmem(rowData, rowDataSize);
fillchar(rowData^, rowDataSize, 0);
idxAlpha := colorspace.IndexOfAlphaChannel;
if idxAlpha <> -1 then
begin
maxAlpha := colorspace.GetMaxValue(idxAlpha);
p := rowData;
for x := 0 to Bitmap.Width-1 do
begin
colorspace.SetChannel(p, idxAlpha, maxAlpha);
inc(p, valueSize);
end;
end;
idxZ := colorspace.IndexOfChannel(ZName);
if idxZ <> -1 then
begin
zValue := tbZ.Position/ZFactor;
p := rowData;
for x := 0 to Bitmap.Width-1 do
begin
colorspace.SetChannel(p, idxZ, zValue);
inc(p, valueSize);
end;
end;
idxZ := colorspace.IndexOfChannel(Z2Name);
if idxZ <> -1 then
begin
zValue := tbZ2.Position/Z2Factor;
p := rowData;
for x := 0 to Bitmap.Width-1 do
begin
colorspace.SetChannel(p, idxZ, zValue);
inc(p, valueSize);
end;
end;
idxChX := cbXAxis.ItemIndex;
minChX := colorspace.GetMinValue(idxChX);
maxChX := colorspace.GetMaxValue(idxChX);
idxChY := cbYAxis.ItemIndex;
if idxChY = -1 then
begin
minChY := 0;
maxChY := 1;
end else
begin
minChY := colorspace.GetMinValue(idxChY);
maxChY := colorspace.GetMaxValue(idxChY);
end;
WriteStr(s, minChY:0:2, '\', minChX:0:2);
lblMin.Caption := s;
if maxChX > 250 then
WriteStr(s, maxChX:0:0)
else
WriteStr(s, maxChX:0:2);
lblMaxX.Caption := s;
if maxChY > 250 then
WriteStr(s, maxChY:0:0)
else
WriteStr(s, maxChY:0:2);
lblMaxY.Caption := s;
temp := TBGRABitmap.Create(Bitmap.Width,Bitmap.Height);
for y := 0 to Bitmap.Height-1 do
begin
valY := (1-y/(Bitmap.Height-1))*(maxChY-minChY) + minChY;
p := rowData;
for x := 0 to Bitmap.Width-1 do
begin
colorspace.SetChannel(p, idxChY, valY);
inc(p, valueSize);
end;
valX := minChX;
valXStep := 1/(Bitmap.Width-1)*(maxChX-minChX);
p := rowData;
for x := 0 to Bitmap.Width-1 do
begin
colorspace.SetChannel(p, idxChX, valX);
valX += valXStep;
if valX>maxChX then valX := maxChX;
inc(p, valueSize);
end;
if (cfHasImaginaryColors in colorspace.GetFlags) and (XYZToRGBOverflowMin <> xroClipToTarget) then
begin
setlength(xyzaBuf, Bitmap.Width);
colorspace.Convert(rowData^, xyzaBuf[0], TXYZAColorspace, Bitmap.Width);
if cbFluorescent.Checked then
begin
for x := 0 to Bitmap.Width-1 do
begin
if not IsRealColor(xyzaBuf[x]) then
xyzaBuf[x] := XYZATransparent;
end;
end else
begin
for x := 0 to Bitmap.Width-1 do
begin
if not IsOptimalReflect(xyzaBuf[x]) then
xyzaBuf[x] := XYZATransparent;
end;
end;
TXYZAColorspace.Convert(xyzaBuf[0], temp.ScanLine[y]^, TBGRAPixelColorspace, Bitmap.Width, @ReferenceWhite2D65);
end else
if (not cbFluorescent.Checked) and ((cfHasImaginaryColors in colorspace.GetFlags) or (colorspace = TAdobeRGBAColorspace)) then
begin
setlength(xyzaBuf, Bitmap.Width);
colorspace.Convert(rowData^, xyzaBuf[0], TXYZAColorspace, Bitmap.Width);
for x := 0 to Bitmap.Width-1 do
begin
if not IsOptimalReflect(xyzaBuf[x]) then
xyzaBuf[x] := XYZATransparent;
end;
TXYZAColorspace.Convert(xyzaBuf[0], temp.ScanLine[y]^, TBGRAPixelColorspace, Bitmap.Width);
end else
colorspace.Convert(rowData^, temp.ScanLine[y]^, TBGRAPixelColorspace, Bitmap.Width);
end;
Bitmap.DrawCheckers(Bitmap.ClipRect, CSSGray, CSSSilver);
Bitmap.PutImage(0,0, temp, dmDrawWithTransparency);
temp.Free;
freemem(rowData, rowDataSize);
end;
var i,j,k,l,m,jMod: integer;
xyz, xyzMax, xyzMain: TXYZA;
spectralLocusNormalizedSum: array[low(SpectralLocus)..high(SpectralLocus)] of TXYZA;
initialization
//writeln('Computing reflective color bounds...');
for i := 0 to OptimalReflectArraySize do
for j := 0 to OptimalReflectArraySize do
OptimalReflectXYZ[i,j].min := EmptySingle;
xyzMax.X := 0;
xyzMax.Y := 0;
xyzMax.Z := 0;
for i := 0 to high(SpectralLocus) do
begin
xyzMax.X += SpectralLocus[i].X;
xyzMax.Y += SpectralLocus[i].Y;
xyzMax.Z += SpectralLocus[i].Z;
end;
for i := 0 to high(SpectralLocus) do
spectralLocusNormalizedSum[i] := TXYZA.New(SpectralLocus[i].X/xyzMax.X/OptimalReflectBorderStep,
SpectralLocus[i].Y/xyzMax.Y/OptimalReflectBorderStep,
SpectralLocus[i].Z/xyzMax.Z/OptimalReflectBorderStep);
{optimalXYZMin := CSSSilver;
optimalXYZMax := CSSSilver;}
{labMin := CSSSilver;
labMax := CSSSilver;
lchMin := CSSSilver;
lchMax := CSSSilver;}
AddOptimalReflect(BGRABlack);
for i := 0 to high(SpectralLocus) do
begin
xyzMain.X := 0;
xyzMain.Y := 0;
xyzMain.Z := 0;
jMod := i;
for k := 1 to length(SpectralLocus) do
begin
if k = 1 then
begin
xyz := xyzMain;
for l := 1 to OptimalReflectBorderStep*8 do
begin
with spectralLocusNormalizedSum[i] do
begin
xyz.X += X*0.125;
xyz.Y += Y*0.125;
xyz.Z += Z*0.125;
end;
AddOptimalReflect(xyz);
end;
end else
for l := 1 to OptimalReflectBorderStep do
begin
xyz := xyzMain;
with spectralLocusNormalizedSum[i] do
begin
xyz.X += l*X;
xyz.Y += l*Y;
xyz.Z += l*Z;
end;
for m := 1 to OptimalReflectBorderStep do
begin
with spectralLocusNormalizedSum[jMod] do
begin
xyz.X += X;
xyz.Y += Y;
xyz.Z += Z;
end;
AddOptimalReflect(xyz);
end;
end;
if k >= 2 then
begin
with spectralLocusNormalizedSum[jMod] do
begin
xyzMain.X += X*OptimalReflectBorderStep;
xyzMain.Y += Y*OptimalReflectBorderStep;
xyzMain.Z += Z*OptimalReflectBorderStep;
end;
end;
inc(jMod);
if jMod = length(SpectralLocus) then jMod := 0;
end;
end;
//writeln('xyz min ',optimalXYZMin.x,', ',optimalXYZMin.y,', ',optimalXYZMin.z);
//writeln('xyz max ',optimalXYZMax.x,', ',optimalXYZMax.y,', ',optimalXYZMax.z);
{writeln('Lab min ',labMin.L,', ',labMin.a,', ',labMin.b);
writeln('Lab max ',labMax.L,', ',labMax.a,', ',labMax.b);
writeln('LCh min ',lChMin.L,', ',lChMin.C,', ',lChMin.h);
writeln('LCh max ',lChMax.L,', ',lChMax.C,', ',lChMax.h);}
end.