1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350
| {
Petite unité provenant de la traduction en Pascal d'un code en Csharp
trouvé là https://www.codeproject.com/Articles/19045/Manipulating-colors-in-NET-Part
et permettant de convertir des données RGB (par ex. des positions de curseurs 0..255)
vers l'espace de couleurs CIE-L*a*b*, et dans l'autre sens des données CIE-L*a*b*
(encore des curseurs, 0--100 pour L, -128+127 por a et b) vers tout système d'affichage
supportant TColor (facilement adaptable pour utiliser R, G, B).
J'ai rajouté la prise en charge du modèle LCh° (0..100 2 fois et 0--360°)
jipété, décembre 2017 [ donc joyeux Noël ;-) ]
}
unit unit4lablch;
{$mode objfpc}{$H+}
interface
uses
LCLIntf, LCLType, Math, Classes, SysUtils, Graphics;
type
BASERGB = record
R : int64;
G : int64;
B : int64;
end;
TBASERGB = BASERGB;
BASEXYZ = record
X : double;
Y : double;
Z : double;
end;
TBASEXYZ = BASEXYZ;
BASELAB = record
L : double;
a : double;
b : double;
end;
TBASELAB = BASELAB;
BASELCH = record
L : double;
C : double;
h : double;
end;
TBASELCH = BASELCH;
const
CIEXYZ_D65_X = 95.047;
CIEXYZ_D65_Y = 100.000;
CIEXYZ_D65_Z = 108.883;
function RGBtoLab(red,green,blue: integer): TBASELAB;
function LabtoRGB(l,a,b: double; scl: boolean): TColor;
// ajouts jpt ------------------ scl c'est si la cible utilise scanline ou pas
// voir l'exemple d'utilisation en bas de code
function RGBtoLch(red,green,blue: integer): TBASELCH; // non testé ici /!\/!\/!\
function LchtoRGB(l,c,h: double; scl: boolean): TColor;
implementation
{Pour ceux qui fonceraient sur le code original sans lire les commentaires tout en bas
de la page du site, l'avant-dernier a pour titre "bug in XYZ to RGB"
et nous dit :
Clinear[1] = -x*0.9692 + y*1.8760 - z*0.0416; // green
should be
Clinear[1] = -x*0.9692 + y*1.8760 + z*0.0416; // green
et il se trouve que le code du projet N'a PAS été corrigé (*ici* oui).
Donc méfiance avec les copier/coller un peu trop rapides...
Les commentaires in english viennent du code d'origine.
Par ailleurs, les 5 fonctions ci-dessous (conversion RGB -> LAB / LCh)
N'ont PAS été testées...
Plus bas (après les 3 lignes de "////..."),
les 5 fonctions LCh / LAB --> RGB ont été testées, et embarquent
un booléen pour savoir s'il faut inverser ou pas R et B, nécessaire
si l'ihm utilise les fonctions de Scanline pour peindre les surfaces.
}
// 2 ajouts pour Delphi7, provenance Graphics.pas de Lazarus
function RGBToColor(R, G, B: Byte): TColor;
begin
Result := (B shl 16) or (G shl 8) or R;
end;
procedure RedGreenBlue(rgb: TColorRef; out Red, Green, Blue: Byte);
begin
Red := rgb and $000000ff;
Green := (rgb shr 8) and $000000ff;
Blue := (rgb shr 16) and $000000ff;
end;
/// ajout pour LCh°
function LABtoLCH(lab: TBASELAB): TBASELCH; // source easyRGB
var
var_H: double;
begin
with lab do begin
var_H := RadToDeg(arctan2(b, a)); // rajouté R2D, trouvé dans ColorMine
if ( var_H < 0 ) then var_H := var_H +360
else if ( var_H >= 360 ) then var_H := var_H - 360;
result.L := L;
result.C := sqrt( power(a, 2)+power(b, 2) );
result.h := var_H;
end;
end;
/// Converts XYZ to CIELab.
function XYZtoLab(xyz: TBASEXYZ): TBASELAB;
function Fxyz(t: double): double;
begin
if (t > 0.008856)
then result := Power(t, (1.0/3.0))
else result := ( (7.787*t) + (16.0/116.0) );
end;
begin
with Result do begin
L := 116.0 * Fxyz( xyz.y/CIEXYZ_D65_Y ) -16;
A := 500.0 * (Fxyz( xyz.x/CIEXYZ_D65_X ) - Fxyz( xyz.y/CIEXYZ_D65_Y) );
B := 200.0 * (Fxyz( xyz.y/CIEXYZ_D65_Y ) - Fxyz( xyz.z/CIEXYZ_D65_Z) );
end;
end;
/// Converts RGB to XYZ (CIE 1931 color space)
function RGBtoXYZ(red,green,blue: integer): TBASEXYZ;
var
rLinear, gLinear, bLinear: double;
r, g, b: double;
begin
// normalize red, green, blue values
rLinear := red /255.0;
gLinear := green /255.0;
bLinear := blue /255.0;
// convert to a sRGB form
if (rLinear > 0.04045)
then r := Power((rLinear + 0.055)/(1 + 0.055), 2.2)
else r := (rLinear/12.92);
if (gLinear > 0.04045)
then g := Power((gLinear + 0.055)/(1 + 0.055), 2.2)
else g := (gLinear/12.92);
if (bLinear > 0.04045)
then b := Power((bLinear + 0.055)/(1 + 0.055), 2.2)
else b := (bLinear/12.92);
// converts
with Result do begin
X := (r*0.4124 + g*0.3576 + b*0.1805);
Y := (r*0.2126 + g*0.7152 + b*0.0722);
Z := (r*0.0193 + g*0.1192 + b*0.9505);
end;
end;
/// GLUE -- Converts RGB to Lab.
function RGBtoLab(red,green,blue: integer): TBASELAB;
begin
result := XYZtoLab( RGBtoXYZ(red,green,blue) );
end;
/// ajout pour LCh°
function RGBtoLch(red,green,blue: integer): TBASELCH;
begin
result := LABtoLch( XYZtoLab( RGBtoXYZ(red,green,blue) ) );
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
/// Converts XYZ to RGB.
function XYZtoRGB(xyz: TBASEXYZ): TBASERGB;
type
TClinear = array[0..2] of double;
var
Clinear: TClinear;
i: integer;
begin
with xyz do begin
// 3 lignes non existantes dans le code d'origine...
X := X / 100;
Y := Y / 100;
Z := Z / 100;
Clinear[0] := x*3.2410 - y*1.5374 - z*0.4986; // red
Clinear[1] := -x*0.9692 + y*1.8760 + z*0.0416; // green
Clinear[2] := x*0.0556 - y*0.2040 + z*1.0570; // blue
end;
for i := 0 to 2 do // Gamma correction
if ( Clinear[i] <= 0.0031308 )
then Clinear[i] := Clinear[i] * 12.92
else Clinear[i] := (1+0.055) * Power(Clinear[i], 1.0/2.4) -0.055;
with Result do begin
R := round( Clinear[0]*255.0 );
G := round( Clinear[1]*255.0 );
B := round( Clinear[2]*255.0 );
end;
end;
/// Converts Lab to XYZ.
function LabtoXYZ(l,a,b: double): TBASEXYZ;
var
delta, fx,fy,fz: double;
begin
delta := 6.0/29.0;
fy := (l+16)/116.0;
fx := fy + (a/500.0);
fz := fy - (b/200.0);
with Result do begin
if fx > delta
then X := CIEXYZ_D65_X * (fx*fx*fx)
else X := (fx - 16.0/116.0)*3*delta*delta*CIEXYZ_D65_X;
if fy > delta
then Y := CIEXYZ_D65_Y * (fy*fy*fy)
else Y := (fy - 16.0/116.0)*3*delta*delta*CIEXYZ_D65_Y;
if fz > delta
then Z := CIEXYZ_D65_Z * (fz*fz*fz)
else Z := (fz - 16.0/116.0)*3*delta*delta*CIEXYZ_D65_Z;
end;
end;
/// GLUE -- Converts Lab to RGB.
function LabtoRGB(l,a,b: double; scl: boolean): TColor; //TBASERGB;
function Clamp(x, mini, maxi: int64): byte;
begin
if x < mini then x := mini else if x > maxi then x := maxi;
result := byte(x);
end;
var
rgb: TBASERGB;
begin
rgb := XYZtoRGB( LabtoXYZ(l,a,b) );
// Clamping non présent dans le code d'origine
if scl
then Result := RGBtoColor(Clamp(rgb.B,0,255), Clamp(rgb.G,0,255), Clamp(rgb.R,0,255)) // inverser R et B
else Result := RGBtoColor(Clamp(rgb.R,0,255), Clamp(rgb.G,0,255), Clamp(rgb.B,0,255)); // classique
end;
/// ajout pour LCh°
function LchtoLab(lch: TBASELCH): TBASELAB; // source easyRGB
begin // CIE-H° range = 0..360° Getreuer précise "D65"
with lch do begin
result.L := L;
result.a := cos(H * PI / 180) * C;
result.b := sin(H * PI / 180) * C;
end;
end;
/// GLUE -- ajout pour LCh° vers RGB
function LchtoRGB(l,c,h: double; scl: boolean): TColor;
var
lab: TBASELAB;
lch: TBASELCH;
r,g,b: byte;
begin
lch.L:=l; lch.C:=c; lch.h:=h;
lab := LchtoLab(lch);
// Pas de demande d'inversion R<>B puisque faite dessous (suite demande ihm)
RedGreenBlue(LabtoRGB(lab.L,lab.a,lab.b, False), r,g,b);
if scl
then Result := RGBtoColor(b,g,r) // inverser R et B
else Result := RGBtoColor(r,g,b); // classique
end;
end.
{exemple d'utilisation :
1 TButton sur une fiche, et 2 TImage : img360x101 et img4lab (256x256),
sans oublier
uses
unit4lablch;
procedure TForm1.Button1Click(Sender: TObject);
type
TPointeurDeLigneLCH = array[0..359] of TColor;
pPointeurDeLigneLCH = ^TPointeurDeLigneLCH;
TPointeurDeLigneLAB = array[0..255] of TColor;
pPointeurDeLigneLAB = ^TPointeurDeLigneLAB;
var
PointeurDeLigneLCH: pPointeurDeLigneLCH;
PointeurDeLigneLAB: pPointeurDeLigneLAB;
hh,ww: Integer;
aBmp: TBitmap;
Delta : int64;
StartTime : DWORD;
begin
StartTime := GetTickCount;
aBmp := TBitmap.Create;
with aBmp do begin // 4 LCH -- image rectangulaire en haut
try
//PixelFormat := pf24bit; //!\ Linux
PixelFormat := pf32bit; //!\ XP
Width := 360;
Height := 101;
// BeginUpdate; // à commenter pour D7
for hh := 0 to 100 do begin
// PointeurDeLigneLCH := pPointeurDeLigneLCH(RawImage.GetLineStart(hh)); // Lazarus
PointeurDeLigneLCH := pPointeurDeLigneLCH(Scanline[hh]); // Delphi
for ww := 0 to 359 do
PointeurDeLigneLCH^[ww] := LCHtoRGB(hh, 50, ww, true);
// L C h° scanline ?
end;
// EndUpdate(); // à commenter pour D7
img360x101.Picture.Graphic := aBmp;
finally
Free;
end;
end;
aBmp := TBitmap.Create;
with aBmp do begin // 4 LAB -- image carrée en bas
try
//PixelFormat := pf24bit; //!\ Linux
PixelFormat := pf32bit; //!\ XP
Width := 256;
Height := 256;
// BeginUpdate; // à commenter pour D7
for hh := 0 to 255 do begin
// PointeurDeLigneLAB := pPointeurDeLigneLAB(RawImage.GetLineStart(hh)); // Lazarus
PointeurDeLigneLAB := pPointeurDeLigneLAB(Scanline[hh]); // Delphi
for ww := 0 to 255 do
PointeurDeLigneLAB^[ww] := LABtoRGB(50, hh-128, ww-128, true);
// a // b scanline ?
end;
// EndUpdate(); // à commenter pour D7
img4lab.Picture.Graphic := aBmp;
finally
Free;
end;
end;
Delta := GetTickCount - StartTime;
Form1.Caption := IntToStr(Delta) + ' ms';
end;
} |
Partager