Create a new project, create a button named cmdBenchmark, and paste:
Problem: DeltaE(computes the distance between two RGBs) is too slow.
Ideally, I'd like it to remain accurate, but if the speed increase is significant enough I'd be willing to accept a DeltaE that's precise enough(better than RGB, Lab, or Luv, hopefully!*).
The primary goal is being able to compare near and distance colors in an extremely perceptual manner in an extremely short amount of time.
I don't expect this to be done for me... just throw me some advice if you'd think it'd help! Even if it's an entirely different function, please speak up! Questions and comments are also welcome.
Thanks fellas! :wave:
*Perhaps I just need to weight these better?
Code:
Option Explicit
Const Pi As Double = 3.1415926
Const sngPi As Single = 3.141593!
Private Const CIEe As Single = 216! / 24389!
Private Const CIEk As Single = 24389! / 27!
Private Const OneThird As Single = 1! / 3!
Private Const FromDeg As Single = sngPi / 180!
Private Const ToDeg As Single = 180! / sngPi
Private Const TFP7 As Single = 25! ^ 7!
Private Type tRGB
R As Single
G As Single
B As Single
End Type
Private Type tXYZ
x As Single
Y As Single
Z As Single
End Type
Private Type tLAB
L As Single
A As Single
B As Single
End Type
Private Function LABtoXYZ(inLAB As tLAB) As tXYZ
Dim L As Single, A As Single, B As Single
Dim x As Single, Y As Single, Z As Single
'buffer byref variable
L = inLAB.L
A = inLAB.A
B = inLAB.B
'transform
Y = (L + 16!) / 116!
Z = Y - B / 200!
x = A / 500! + Y
If (Z ^ 3!) > CIEe Then Z = Z ^ 3! Else Z = (116! * Z - 16) / CIEk
If L > (CIEk * CIEe) Then Y = ((L + 16!) / 116!) ^ 3! Else Y = L / CIEk
'If (Y ^ 3!) > CIEe Then Y = Y ^ 3! Else Y = (116! * Y - 16) / CIEk
If (x ^ 3!) > CIEe Then x = x ^ 3! Else x = (116! * x - 16) / CIEk
'scale to reference white
LABtoXYZ.x = x * 96.422!
LABtoXYZ.Y = Y * 100!
LABtoXYZ.Z = Z * 82.521!
End Function
Private Function XYZtoLAB(inXYZ As tXYZ) As tLAB
Dim x As Single, Y As Single, Z As Single
'buffer byref variable
x = inXYZ.x
Y = inXYZ.Y
Z = inXYZ.Z
'normalize against reference white D50
x = x / 96.422!
Y = Y / 100!
Z = Z / 82.521!
'transform
If Z > CIEe Then Z = Z ^ OneThird Else Z = (CIEk * Z + 16!) / 116!
If Y > CIEe Then Y = Y ^ OneThird Else Y = (CIEk * Y + 16!) / 116!
If x > CIEe Then x = x ^ OneThird Else x = (CIEk * x + 16!) / 116!
XYZtoLAB.L = (116! * Y) - 16! 'luminance ; 100 = diffuse white
XYZtoLAB.A = 500! * (x - Y) ' - = green; + = magenta(red+blue)
XYZtoLAB.B = 200! * (Y - Z) ' - = blue ; + = yellow(red+green)
End Function
Private Function RGBToXYZ(ByVal RGBValue As Long) As tXYZ
Dim R As Single, G As Single, B As Single
R = (RGBValue And &HFF&) / 255!
G = ((RGBValue And &HFF00&) \ &H100&) / 255!
B = ((RGBValue And &HFF0000) \ &H10000) / 255!
Debug.Print "xyz rgb", R, G, B, Hex(RGBValue)
'gamma/non-linear
If R > 0.04045! Then R = ((R + 0.055!) / 1.055!) ^ 2.4! Else R = R / 12.92!
If G > 0.04045! Then G = ((G + 0.055!) / 1.055!) ^ 2.4! Else G = G / 12.92!
If B > 0.04045! Then B = ((B + 0.055!) / 1.055!) ^ 2.4! Else B = B / 12.92!
'scale
R = R * 100!
G = G * 100!
B = B * 100!
'bradford D50 tristimulus values
RGBToXYZ.x = R * 0.4360747! + G * 0.3850649! + B * 0.1430804!
RGBToXYZ.Y = R * 0.2225045! + G * 0.7168786! + B * 0.0606169!
RGBToXYZ.Z = R * 0.0139322! + G * 0.0971045! + B * 0.7141733!
End Function
Private Function XYZtoRGB(inXYZ As tXYZ) As Long
Dim x As Single, Y As Single, Z As Single
Dim R As Single, G As Single, B As Single
'buffer byref var
x = inXYZ.x / 100!
Y = inXYZ.Y / 100!
Z = inXYZ.Z / 100!
'bradford d50
R = x * 3.133856! + Y * -1.616867! + Z * -0.4906146!
G = x * -0.9787684! + Y * 1.916142! + Z * 0.033454!
B = x * 0.0719453! + Y * -0.2289914! + Z * 1.405243!
If R > 0.0031308! Then R = 1.055! * (R ^ (1! / 2.4!)) - 0.055! Else R = 12.92! * R
If G > 0.0031308! Then G = 1.055! * (G ^ (1! / 2.4!)) - 0.055! Else G = 12.92! * G
If B > 0.0031308! Then B = 1.055! * (B ^ (1! / 2.4!)) - 0.055! Else B = 12.92! * B
'If G < 0 Then G = 0
XYZtoRGB = RGB(R * 255!, G * 255!, B * 255!)
End Function
Private Function RGBtoLAB(ByVal RGBValue As Long) As tLAB
Static Init As Boolean
Static RGB2LABLUT(16777215) As tLAB
If Init = False Then
Dim x As Long
For x = 0& To 16777215
If (x Mod 167772) = 0 Then Form1.Caption = "(1/1) Building RGB to LAB look-up-table " & Round(x / 167772.15, 2) & "%": Form1.Refresh
RGB2LABLUT(x) = XYZtoLAB(RGBToXYZ(x))
Next x
Init = True
Exit Function
End If
RGBtoLAB = RGB2LABLUT(RGBValue)
End Function
Private Sub cmdBenchmark_Click()
Dim x As Long, sTime As Single
sTime = Timer
For x = 0& To 16777215
DeltaE x, &HFFFFFF Xor x
Next x
Form1.Caption = Timer - sTime
End Sub
Private Sub Form_Activate()
Static bInit As Boolean
If bInit = False Then
bInit = True
RGBtoLAB 0
End If
End Sub
Private Function DeltaE(ByVal lColor1 As Long, ByVal lColor2 As Long) As Single
'Delta E (CIE 2000)
'http://www.brucelindbloom.com/index.html?Eqn_DeltaE_CIE2000.html
'http://en.wikipedia.org/wiki/Color_difference
Dim tmpXYZ As tXYZ
Dim LAB1 As tLAB, LAB2 As tLAB
Dim lineL As Single, lineC As Single, lineH As Single
Dim C1 As Single, C2 As Single, G As Single
Dim H1 As Single, H2 As Single
Dim deltaH As Single, deltaC As Single
Dim LCP7 As Single
Dim xNt As Long, timeTransform As Double, timeDifference As Double
Dim sngTmp As Single
LAB1 = RGBtoLAB(lColor1)
LAB2 = RGBtoLAB(lColor2)
lineL = ((LAB1.L + LAB2.L) / 2!) - 50!: lineL = lineL * lineL
C1 = Sqr(LAB1.A * LAB1.A + LAB1.B * LAB1.B)
C2 = Sqr(LAB2.A * LAB2.A + LAB2.B * LAB2.B)
lineC = (C1 + C2) / 2!
LCP7 = lineC ^ 7!
G = 1! + (1! - Sqr(LCP7 / (LCP7 + TFP7))) / 2!
LAB1.A = LAB1.A * G
LAB2.A = LAB2.A * G
C1 = Sqr(LAB1.A * LAB1.A + LAB1.B * LAB1.B)
C2 = Sqr(LAB2.A * LAB2.A + LAB2.B * LAB2.B)
lineC = (C1 + C2) / 2!
LCP7 = lineC ^ 7!
H1 = ArcTangent(LAB1.B, LAB1.A)
H2 = ArcTangent(LAB2.B, LAB2.A)
If Abs(H1 - H2) > 180! Then lineH = (H1 + H2 + 360!) / 2! Else lineH = (H1 + H2) / 2!
If Abs(H2 - H1) > 180! Then
If H2 > H1 Then deltaH = H2 - H1 - 360! Else deltaH = H2 - H1 + 360!
Else
deltaH = H2 - H1
End If
deltaH = 2! * Sqr(C1 * C2) * Sin((deltaH / 2!) * FromDeg) * ToDeg
deltaC = (C2 - C1) / (1! + 0.045! * lineC)
deltaH = deltaH / (1! + 0.015! * lineC * (1! - 0.17! * DegCos(lineH - 30!) + 0.24! * DegCos(2! * lineH) + 0.32! * DegCos(3! * lineH + 6!) - 0.2! * DegCos(4! * lineH - 63!)))
DeltaE = Sqr( _
((LAB2.L - LAB1.L) / (1! + (0.015! * lineL) / (Sqr(20! + lineL)))) ^ 2! + _
deltaC * deltaC + deltaH * deltaH + _
(-(2! * Sqr(LCP7 / (LCP7 + TFP7))) * Sin(2! * (30! * Exp(-((lineH - 275!) / 25!) ^ 2!)) * FromDeg) * ToDeg) * deltaC * deltaH)
End Function
Private Function DegCos(ByVal sngIn As Single) As Single
sngIn = sngIn * sngPi / 180!
DegCos = Cos(sngIn) * 180! / sngPi
End Function
Private Function ArcTangent(ByVal op As Single, ByVal ad As Single) As Single
Dim at As Single
If op = 0! And ad = 0! Then
ArcTangent = 0!
Exit Function
End If
If ad = 0! Then
If op > 0! Then
ArcTangent = sngPi / 2!
Else
ArcTangent = sngPi * 1.5!
End If
Else
at = Atn(op / ad)
If ad < 0! Then
ArcTangent = sngPi + at
ElseIf op < 0! Then
ArcTangent = sngPi + sngPi + at
Else
ArcTangent = at
End If
End If
End FunctionIdeally, I'd like it to remain accurate, but if the speed increase is significant enough I'd be willing to accept a DeltaE that's precise enough(better than RGB, Lab, or Luv, hopefully!*).
The primary goal is being able to compare near and distance colors in an extremely perceptual manner in an extremely short amount of time.
I don't expect this to be done for me... just throw me some advice if you'd think it'd help! Even if it's an entirely different function, please speak up! Questions and comments are also welcome.
Thanks fellas! :wave:
*Perhaps I just need to weight these better?