About the Chromaticity Diagram
The coordinates x, y and z are called the
chromaticity coordinates. These are related to x_bar,
y_bar and z_bar which are called the spectral tristimulus values
(or color matching functions) chosen by the CIE
for reasons of convenience in colorimetric computations. R, G and B are the
red, green and blue tristimulus values. These three sets of three values
(or functions) are all related by matix operations.
Basic Code
Translated by William Lowerre
Sub drawmap()
Dim slope As Single, s1 As Single, s2 As Single, t1 As Single, t2 As Single, zr As Single
Dim zg As Single, zb As Single, zw As Single, xw As Single, yw As Single
Dim xr As Single, yr As Single, xb As Single, yb As Single, xg As Single, yg As Single
Dim rmax As Single
Dim m, n, l
Dim ICV(800, 800, 3)
Dim gam
Dim ii, jj, kk, j
Dim i1
Dim i2
Dim j1
Dim j2
Dim stepper
Dim stepperj
Dim s
Dim jtest
Dim itest
Dim i
Dim r As Single, g As Single, b As Single, xc As Single, yc As Single, zc As Single
' Chromaticity Coodinates (x and y) for wavelenghts in 5 nm
' increments from 380 nm to 780 nm.
Dim wXY(1 To 2, 1 To 82) As Single
wXY(1, 1) = 0.1741
wXY(2, 1) = 0.005
wXY(1, 2) = 0.174
wXY(2, 2) = 0.005
wXY(1, 3) = 0.1738
wXY(2, 3) = 0.0049
wXY(1, 4) = 0.1736
wXY(2, 4) = 0.0049
wXY(1, 5) = 0.1733
wXY(2, 5) = 0.0048
wXY(1, 6) = 0.173
wXY(2, 6) = 0.0048
wXY(1, 7) = 0.1726
wXY(2, 7) = 0.0048
wXY(1, 8) = 0.1721
wXY(2, 8) = 0.0048
wXY(1, 9) = 0.1714
wXY(2, 9) = 0.0051
wXY(1, 10) = 0.1703
wXY(2, 10) = 0.0058
wXY(1, 11) = 0.1689
wXY(2, 11) = 0.0069
wXY(1, 12) = 0.1669
wXY(2, 12) = 0.0086
wXY(1, 13) = 0.1644
wXY(2, 13) = 0.0109
wXY(1, 14) = 0.1611
wXY(2, 14) = 0.0138
wXY(1, 15) = 0.1566
wXY(2, 15) = 0.0177
wXY(1, 16) = 0.151
wXY(2, 16) = 0.0227
wXY(1, 17) = 0.144
wXY(2, 17) = 0.0297
wXY(1, 18) = 0.1355
wXY(2, 18) = 0.0399
wXY(1, 19) = 0.1241
wXY(2, 19) = 0.0578
wXY(1, 20) = 0.1096
wXY(2, 20) = 0.0868
wXY(1, 21) = 0.0913
wXY(2, 21) = 0.1327
wXY(1, 22) = 0.0687
wXY(2, 22) = 0.2007
wXY(1, 23) = 0.0454
wXY(2, 23) = 0.295
wXY(1, 24) = 0.0235
wXY(2, 24) = 0.4127
wXY(1, 25) = 0.0082
wXY(2, 25) = 0.5384
wXY(1, 26) = 0.0039
wXY(2, 26) = 0.6548
wXY(1, 27) = 0.0139
wXY(2, 27) = 0.7502
wXY(1, 28) = 0.0389
wXY(2, 28) = 0.812
wXY(1, 29) = 0.0743
wXY(2, 29) = 0.8338
wXY(1, 30) = 0.1142
wXY(2, 30) = 0.8262
wXY(1, 31) = 0.1547
wXY(2, 31) = 0.8059
wXY(1, 32) = 0.1929
wXY(2, 32) = 0.7816
wXY(1, 33) = 0.2296
wXY(2, 33) = 0.7543
wXY(1, 34) = 0.2658
wXY(2, 34) = 0.7243
wXY(1, 35) = 0.3016
wXY(2, 35) = 0.6923
wXY(1, 36) = 0.3373
wXY(2, 36) = 0.6589
wXY(1, 37) = 0.3731
wXY(2, 37) = 0.6245
wXY(1, 38) = 0.4087
wXY(2, 38) = 0.5896
wXY(1, 39) = 0.4441
wXY(2, 39) = 0.5547
wXY(1, 40) = 0.4788
wXY(2, 40) = 0.5202
wXY(1, 41) = 0.5125
wXY(2, 41) = 0.4866
wXY(1, 42) = 0.5448
wXY(2, 42) = 0.4544
wXY(1, 43) = 0.5752
wXY(2, 43) = 0.4242
wXY(1, 44) = 0.6029
wXY(2, 44) = 0.3965
wXY(1, 45) = 0.627
wXY(2, 45) = 0.3725
wXY(1, 46) = 0.6482
wXY(2, 46) = 0.3514
wXY(1, 47) = 0.6658
wXY(2, 47) = 0.334
wXY(1, 48) = 0.6801
wXY(2, 48) = 0.3197
wXY(1, 49) = 0.6915
wXY(2, 49) = 0.3083
wXY(1, 50) = 0.7006
wXY(2, 50) = 0.2993
wXY(1, 51) = 0.7079
wXY(2, 51) = 0.292
wXY(1, 52) = 0.714
wXY(2, 52) = 0.2859
wXY(1, 53) = 0.719
wXY(2, 53) = 0.2809
wXY(1, 54) = 0.723
wXY(2, 54) = 0.277
wXY(1, 55) = 0.726
wXY(2, 55) = 0.274
wXY(1, 56) = 0.7283
wXY(2, 56) = 0.2717
wXY(1, 57) = 0.73
wXY(2, 57) = 0.27
wXY(1, 58) = 0.7311
wXY(2, 58) = 0.2689
wXY(1, 59) = 0.732
wXY(2, 59) = 0.268
wXY(1, 60) = 0.7327
wXY(2, 60) = 0.2673
wXY(1, 61) = 0.7334
wXY(2, 61) = 0.2666
wXY(1, 62) = 0.734
wXY(2, 62) = 0.266
wXY(1, 63) = 0.7344
wXY(2, 63) = 0.2656
wXY(1, 64) = 0.7346
wXY(2, 64) = 0.2654
wXY(1, 65) = 0.7347
wXY(2, 65) = 0.2653
wXY(1, 66) = 0.7347
wXY(2, 66) = 0.2653
wXY(1, 67) = 0.7347
wXY(2, 67) = 0.2653
wXY(1, 68) = 0.7347
wXY(2, 68) = 0.2653
wXY(1, 69) = 0.7347
wXY(2, 69) = 0.2653
wXY(1, 70) = 0.7347
wXY(2, 70) = 0.2653
wXY(1, 71) = 0.7347
wXY(2, 71) = 0.2653
wXY(1, 72) = 0.7347
wXY(2, 72) = 0.2653
wXY(1, 73) = 0.7347
wXY(2, 73) = 0.2653
wXY(1, 74) = 0.7347
wXY(2, 74) = 0.2653
wXY(1, 75) = 0.7347
wXY(2, 75) = 0.2653
wXY(1, 76) = 0.7347
wXY(2, 76) = 0.2653
wXY(1, 77) = 0.7347
wXY(2, 77) = 0.2653
wXY(1, 78) = 0.7347
wXY(2, 78) = 0.2653
wXY(1, 79) = 0.7347
wXY(2, 79) = 0.2653
wXY(1, 80) = 0.7347
wXY(2, 80) = 0.2653
wXY(1, 81) = 0.7347
wXY(2, 81) = 0.2653
wXY(1, 82) = wXY(1, 1)
wXY(2, 82) = wXY(2, 1)
'c
'c Chromaticity Coordinates for Red, Green, Blue and White
'c
xr = 0.64
yr = 0.33
xg = 0.29
yg = 0.6
xb = 0.15
yb = 0.06
xw = 0.3127
yw = 0.3291
zr = 1 - (xr + yr)
zg = 1 - (xg + yg)
zb = 1 - (xb + yb)
zw = 1 - (xw + yw)
m = 300
n = m
l = 255
gam = 0.8
gam = Val(Text6.Text)
'c
'c Draw tongue outline
'c
For ii = 1 To m
For jj = 1 To n
For kk = 1 To 3
ICV(ii, jj, kk) = 0
Next
Next
Next
On Error Resume Next
For j = 1 To 81
s1 = (m) * wXY(1, j)
s2 = (m) * wXY(1, j + 1)
t1 = (n) * (1 - wXY(2, j))
t2 = (n) * (1 - wXY(2, j + 1))
slope = (t2 - t1) / (s2 - s1)
i1 = Int(s1)
i2 = Int(s2)
stepper = 1
If (i2 < i1) Then stepper = -1
For ii = i1 To i2 Step stepper
s = (ii)
j1 = j2
j2 = Int(t1 + slope * (s - s1))
If ((j1 <> 0) And (j2 <> 0)) Then
stepperj = 1
If j2 < j1 Then stepperj = -1
For jj = j1 To j2 Step stepperj
For kk = 1 To 3
ICV(ii, jj, kk) = 1
Next
'Picturergb.PSet (ii * 2, jj * 2), RGB(255, 255, 255)
Next
End If
Next
Next
'MsgBox ("")
'c Calculate RGB Values for x and y coordinates
'c
For j = 1 To n
jtest = 0
For i = 1 To m
If ((ICV(i, j, 1) = 1) And (ICV(i + 1, j, 1) = 0)) Then jtest = jtest + 1
Next
If (jtest = 2) Then
itest = 0
For i = 1 To m
If ((ICV(i, j, 1) = 1) And (ICV(i + 1, j, 1) = 0)) Then itest = itest + 1
If (itest = 1) Then
xc = i / m
yc = 1 - (j / n)
zc = 1 - (xc + yc)
r = XYZTOR(xr, yr, zr, xg, yg, zg, xb, yb, zb, xc, yc, zc, r, g, b)
g = XYZTOg(xr, yr, zr, xg, yg, zg, xb, yb, zb, xc, yc, zc, r, g, b)
b = XYZTOb(xr, yr, zr, xg, yg, zg, xb, yb, zb, xc, yc, zc, r, g, b)
rmax = 0.000001
If (r > rmax) Then rmax = r
If (g > rmax) Then rmax = g
If (b > rmax) Then rmax = b
'ICV(i, j, 1) = Int((l) * (r / rmax))
'ICV(i, j, 2) = Int((l) * (g / rmax))
'ICV(i, j, 3) = Int((l) * (b / rmax))
r = Int(255 * ((r / rmax) ^ gam))
g = Int(255 * ((g / rmax) ^ gam))
b = Int(255 * ((b / rmax) ^ gam))
Picturergb.PSet (i, j), RGB(r, g, b)
'Picturergb.PSet (i * 2 + 1, j * 2), RGB(r, g, b)
'Picturergb.PSet (i * 2, j * 2 + 1), RGB(r, g, b)
'Picturergb.PSet (i * 2 + 1, j * 2 + 1), RGB(r, g, b)
End If
Next
End If
Next
'Picturergb.Refresh
End Sub
Function XYZTOR(xr As Single, yr As Single, zr As Single, xg As Single, yg As Single, zg As Single, xb As Single, yb As Single, zb As Single, xc As Single, yc As Single, zc As Single, r As Single, g As Single, b As Single) As Single
r = (-(xg * yc * zb) + (xc * yg * zb) + (xg * yb * zc) - (xb * yg * zc) - (xc * yb * zg) + (xb * yc * zg)) / ((xr * yg * zb) - (xg * yr * zb) - (xr * yb * zg) + (xb * yr * zg) + (xg * yb * zr) - (xb * yg * zr))
' g = (xr * yc * zb - xc * yr * zb - xr * yb * zc + xb * yr * zc + xc * yb * zr - xb * yc * zr) / (xr * yg * zb - xg * yr * zb - xr * yb * zg + xb * yr * zg + xg * yb * zr - xb * yg * zr)
' b = (xr * yg * zc - xg * yr * zc - xr * yc * zg + xc * yr * zg + xg * yc * zr - xc * yg * zr) / (xr * yg * zb - xg * yr * zb - xr * yb * zg + xb * yr * zg + xg * yb * zr - xb * yg * zr)
If (r < 0) Then r = 0
' If (g < 0) Then g = 0
' If (b < 0) Then b = 0
If (r > 1) Then r = 1
' If (g > 1) Then g = 1
' If (b > 1) Then b = 1
XYZTOR = r
End Function
Function XYZTOg(xr As Single, yr As Single, zr As Single, xg As Single, yg As Single, zg As Single, xb As Single, yb As Single, zb As Single, xc As Single, yc As Single, zc As Single, r As Single, g As Single, b As Single) As Single
' r = (-xg * yc * zb + xc * yg * zb + xg * yb * zc - xb * yg * zc - xc * yb * zg + xb * yc * zg) / (xr * yg * zb - xg * yr * zb - xr * yb * zg + xb * yr * zg + xg * yb * zr - xb * yg * zr)
g = ((xr * yc * zb) - (xc * yr * zb) - (xr * yb * zc) + (xb * yr * zc) + (xc * yb * zr) - (xb * yc * zr)) / ((xr * yg * zb) - (xg * yr * zb) - (xr * yb * zg) + (xb * yr * zg) + (xg * yb * zr) - (xb * yg * zr))
' b = (xr * yg * zc - xg * yr * zc - xr * yc * zg + xc * yr * zg + xg * yc * zr - xc * yg * zr) / (xr * yg * zb - xg * yr * zb - xr * yb * zg + xb * yr * zg + xg * yb * zr - xb * yg * zr)
' If (r < 0) Then r = 0
If (g < 0) Then g = 0
' If (b < 0) Then b = 0
' If (r > 1) Then r = 1
If (g > 1) Then g = 1
'If (b > 1) Then b = 1
XYZTOg = g
End Function
Function XYZTOb(xr As Single, yr As Single, zr As Single, xg As Single, yg As Single, zg As Single, xb As Single, yb As Single, zb As Single, xc As Single, yc As Single, zc As Single, r As Single, g As Single, b As Single) As Single
' r = (-xg * yc * zb + xc * yg * zb + xg * yb * zc - xb * yg * zc - xc * yb * zg + xb * yc * zg) / (xr * yg * zb - xg * yr * zb - xr * yb * zg + xb * yr * zg + xg * yb * zr - xb * yg * zr)
' g = (xr * yc * zb - xc * yr * zb - xr * yb * zc + xb * yr * zc + xc * yb * zr - xb * yc * zr) / (xr * yg * zb - xg * yr * zb - xr * yb * zg + xb * yr * zg + xg * yb * zr - xb * yg * zr)
b = ((xr * yg * zc) - (xg * yr * zc) - (xr * yc * zg) + (xc * yr * zg) + (xg * yc * zr) - (xc * yg * zr)) / ((xr * yg * zb) - (xg * yr * zb) - (xr * yb * zg) + (xb * yr * zg) + (xg * yb * zr) - (xb * yg * zr))
'If (r < 0) Then r = 0
'If (g < 0) Then g = 0
If (b < 0) Then b = 0
'If (r > 1) Then r = 1
'If (g > 1) Then g = 1
If (b > 1) Then b = 1
XYZTOb = b
End Function