15,169,069 members
Articles / Programming Languages / Visual Basic
Tip/Trick
Posted 9 Mar 2015

14.5K views
6 bookmarked

# Generating Unique Contrasting Colors (in VB.NET)

Rate me:
Generating Unique Contrasting Colors

## Introduction

Sometimes, it is useful for writing text or graphs to have a sequence of N generated unique contrasting colors. For reading, the background color and contrast not only to the background but to the other colors is important making this even more difficult than a general graph use.

A color search and comparison algorithm must be used which generally also requires an alternate color coordinate system. This example will use the CMC I:c color measurement algorithm with LAB color space as it is far more accurate than RGB (red green blue) which the system uses to draw to the screen or HSV (hue saturation value). Searching is an even more problematic subject as the threshold of comparison requires an exponential matches squared amount of comparisons and finding the optimal closed sequence would ultimately amount to a P=NP coloring problem so using an incremental heuristical searching strategy is required.

## Background

### Taken from Wikipedia

A Lab color space is a color-opponent space with dimension L for lightness and a and b for the color-opponent dimensions, based on nonlinearly compressed (e.g. CIE XYZ color space) coordinates. The terminology originates from the three dimensions of the Hunter 1948 color space, which are L, a, and b.

### CMC l:c (1984)

In 1984, the Colour Measurement Committee of the Society of Dyers and Colourists defined a difference measure, also based on the L*C*h color model. Named after the developing committee, their metric is called CMC l:c. The quasimetric has two parameters: lightness (l) and chroma (c), allowing the users to weight the difference based on the ratio of l:c that is deemed appropriate for the application. Commonly used values are 2:1[15] for acceptability and 1:1 for the threshold of imperceptibility.

The distance of a color $(L^*_2,C^*_2,h_2)$ to a reference $(L^*_1,C^*_1,h_1)$ is:[16]

$\Delta E^*_{CMC} = \sqrt{ \left( \frac{L^*_2-L^*_1}{l S_L} \right)^2 + \left( \frac{C^*_2-C^*_1}{c S_C} \right)^2 + \left( \frac{\Delta H^*_{ab}}{S_H} \right)^2 }$

$S_L=\begin{cases} 0.511 & L^*_1 < 16 \\ \frac{0.040975 L^*_1}{1+0.01765 L^*_1} & L^*_1 \geq 16 \end{cases} \quad S_C=\frac{0.0638 C^*_1}{1+0.0131 C^*_1} + 0.638 \quad S_H=S_C (FT+1-F)$

$F = \sqrt{\frac{C^{*^4}_1}{C^{*^4}_1+1900}} \quad T=\begin{cases} 0.56 + |0.2 \cos (h_1+168^\circ)| & 164^\circ \leq h_1 \leq 345^\circ \\ 0.36 + |0.4 \cos (h_1+35^\circ) | & \mbox{otherwise} \end{cases}$

CMC l:c is designed to be used with D65 and the CIE Supplementary Observer.[17]

## Using the Code

Using the code:

C++
'Call like this for 10 colors, with a minimum threshold of 15 and interleaving of 5
GenerateNDistinctColors(10, 15, 5)

The code:

VB.NET
Public Structure XYZColor
Public X As Double
Public Y As Double
Public Z As Double
End Structure
Public Shared WhiteReference As New XYZColor With {.X = 95.047, .Y = 100.0, .Z = 108.883}
Public Const Epsilon As Double = 0.008856 'Intent is 216/24389
Public Const Kappa As Double = 903.3 'Intent is 24389/27
Public Shared Function PivotRGB(N As Double) As Double
Return If(N > 0.04045, Math.Pow((N + 0.055) / 1.055, 2.4), N / 12.92) * 100.0
End Function
Public Shared Function ToRGB(N As Double) As Double
Dim Result As Double = N * 255.0
If Result < 0 Then Return 0
If Result > 255 Then Return 255
Return Result
End Function
Public Shared Function RGBToXYZ(clr As Color) As XYZColor
Dim r As Double = PivotRGB(clr.R / 255.0)
Dim g As Double = PivotRGB(clr.G / 255.0)
Dim b As Double = PivotRGB(clr.B / 255.0)
Return New XYZColor With {.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 Function
Public Shared Function XYZToRGB(clr As XYZColor) As Color
Dim x As Double = clr.X / 100.0
Dim y As Double = clr.Y / 100.0
Dim z As Double = clr.Z / 100.0
Dim r As Double = x * 3.2406 + y * -1.5372 + z * -0.4986
Dim g As Double = x * -0.9689 + y * 1.8758 + z * 0.0415
Dim b As Double = x * 0.0557 + y * -0.204 + z * 1.057
r = If(r > 0.0031308, 1.055 * Math.Pow(r, 1 / 2.4) - 0.055, 12.92 * r)
g = If(g > 0.0031308, 1.055 * Math.Pow(g, 1 / 2.4) - 0.055, 12.92 * g)
b = If(b > 0.0031308, 1.055 * Math.Pow(b, 1 / 2.4) - 0.055, 12.92 * b)
Return Color.FromArgb(CInt(ToRGB(r)), CInt(ToRGB(g)), CInt(ToRGB(b)))
End Function
Public Structure LABColor
Public L As Double
Public A As Double
Public B As Double
End Structure
Public Shared Function PivotXYZ(N As Double) As Double
Return If(N > Epsilon, Math.Pow(N, 1.0 / 3.0), (Kappa * N + 16) / 116)
End Function
Public Shared Function RGBToLAB(clr As Color) As LABColor
Dim XYZCol As XYZColor = RGBToXYZ(clr)
Dim x As Double = PivotXYZ(XYZCol.X / WhiteReference.X)
Dim y As Double = PivotXYZ(XYZCol.Y / WhiteReference.Y)
Dim z As Double = PivotXYZ(XYZCol.Z / WhiteReference.Z)
Return New LABColor With {.L = Math.Max(0, 116 * y - 16), .A = 500 * (x - y), .B = 200 * (y - z)}
End Function
Public Shared Function LABToRGB(clr As LABColor) As Color
Dim y As Double = (clr.L + 16.0) / 116.0
Dim x As Double = clr.A / 500.0 + y
Dim z As Double = y - clr.B / 200.0
Dim X3 As Double = x * x * x
Dim Z3 As Double = z * z * z
Return XYZToRGB(New XYZColor With {.X = WhiteReference.X * _
If(X3 > Epsilon, X3, (x - 16.0 / 116.0) / 7.787), _
.Y = WhiteReference.Y * _
If(clr.L > (Kappa * Epsilon), _
Math.Pow((clr.L + 16.0) / 116.0, 3), _
clr.L / Kappa), _
.Z = WhiteReference.Z * If(Z3 > _
Epsilon, Z3, (z - 16.0 / 116.0) / 7.787)})
End Function
Public Shared Function CMCCompareColors_
(ColorA As LABColor, ColorB As LABColor, Lightness As Double, Chroma As Double) As Double
Dim deltaL As Double = ColorA.L - ColorB.L
Dim h As Double = Math.Atan2(ColorB.B, ColorA.A)
Dim C1 As Double = Math.Sqrt(ColorA.A * ColorA.A + ColorA.B * ColorA.B)
Dim C2 As Double = Math.Sqrt(ColorB.A * ColorB.A + ColorB.B * ColorB.B)
Dim deltaC As Double = C1 - C2
Dim deltaH As Double = Math.Sqrt((ColorA.A - ColorB.A) * _
(ColorA.A - ColorB.A) + (ColorA.B - ColorB.B) * (ColorA.B - ColorB.B) - deltaC * deltaC)
Dim C1_4 As Double = C1 * C1
C1_4 *= C1_4
Dim t As Double = If(164 <= h Or h >= 345, 0.56 + _
Math.Abs(0.2 * Math.Cos(h + 168.0)), 0.36 + Math.Abs(0.4 * Math.Cos(h + 35.0)))
Dim f As Double = Math.Sqrt(C1_4 / (C1_4 + 1900.0))
Dim sL As Double = If(ColorA.L < 16, 0.511, _
(0.040975 * ColorA.L) / (1.0 + 0.01765 * ColorA.L))
Dim sC As Double = (0.0638 * C1) / (1 + 0.0131 * C1) + 0.638
Dim sH As Double = sC * (f * t + 1 - f)
Return Math.Sqrt(deltaL * deltaL / (Lightness * Lightness * sL * sL) + _
deltaC * deltaC / (Chroma * Chroma * sC * sC) + deltaH * deltaH / (sH * sH))
End Function
Public Shared Function GCD(A As Integer, B As Integer) As Integer 'Euclid's algorithm
If B = 0 Then Return A
Return GCD(B, A Mod B)
End Function
Public Shared Function GenerateNDistinctColors_
(N As Integer, Threshold As Integer, Interleave As Integer) As Color()
'To best support individuals with colorblindness _
(deuteranopia or protanopia) keep a set to 0; vary only L and b.
Dim LABColors As New List(Of LABColor)
Dim LowThresholds As New List(Of Double)
For A = 0 To 200 'Pivot around 0 and move towards 100/-100
For L = 0 To 100 / 2 'dark to light yet for readability do not exceed half of the spectrum
For B = 0 To 200 'Pivot around 0 and move towards 100/-100
Dim CurColCount As Integer
Dim LowThreshold As Double = 100
For CurColCount = 0 To LABColors.Count - 1
LowThreshold = Math.Min(LowThreshold, CMCCompareColors_
(LABColors(CurColCount), New LABColor With {.L = L, .A = ((A \ 2) + _
If((A Mod 2) = 1, 1, 0)) * If((A Mod 2) = 1, 1, -1), .B = ((B \ 2) + _
If((B Mod 2) = 1, 1, 0)) * If((B Mod 2) = 1, 1, -1)}, 1.0, 1.0))
If LowThreshold < Threshold Then Exit For
Next
If CurColCount = LABColors.Count Then
Dim Idx As Integer = LowThresholds.BinarySearch(LowThreshold)
If Idx < 0 Then Idx = Idx Xor -1
If Idx <> 0 Or LowThresholds.Count <> N + 1 Then
LABColors.Insert(Idx, New LABColor With {.L = L, .A = ((A \ 2) + _
If((A Mod 2) = 1, 1, 0)) * If((A Mod 2) = 1, 1, -1), .B = ((B \ 2) + _
If((B Mod 2) = 1, 1, 0)) * If((B Mod 2) = 1, 1, -1)})
LowThresholds.Insert(Idx, LowThreshold)
If LowThresholds.Count > N + 1 Then
LABColors.RemoveAt(0)
LowThresholds.RemoveAt(0)
End If
End If
End If
Next
Next
If LABColors.Count >= N + 1 Then Exit For
Next
LABColors.RemoveAt(N) 'Remove background color
'if less than N colors found then try with lower threshold
If LABColors.Count < N Then Return GenerateNDistinctColors(N, Threshold - 1, Interleave)
Dim Cols(N - 1) As Color
For Count As Integer = 0 To N - 1
'Least Common Multiple LCM = a * b \ GCD(A, B)
Cols((Count * Interleave) \ (N * Interleave \ GCD(N, Interleave)) + _
(Count * Interleave) Mod N) = LABToRGB(LABColors(Count))
Next
Return Cols
End Function


## Example Colorizing Regular Expressions

This topic may be worthy of a separate article but provides a good example of how readability for debugging complex regular expressions would use such a coloring algorithm and the need for it in terms of readability when most uses are for graphing.

VB.NET
Public Class RenderArray
Enum RenderDisplayClass
eNested
eArabic
eTransliteration
eLTR
eRTL
eContinueStop
eRanking
eList
eTag
ePassThru
End Enum
Structure RenderText
Public DisplayClass As RenderDisplayClass
Public Clr As Color
Public Text As Object
Public Font As String
Sub New(ByVal NewDisplayClass As RenderDisplayClass, ByVal NewText As Object)
DisplayClass = NewDisplayClass
Text = NewText
Clr = Color.Black 'default
Font = String.Empty
End Sub
End Structure
End Class
Public Shared Function ColorizeList(Strs As String(), _
bArabic As Boolean) As RenderArray.RenderText()
Dim Cols As Color() = GenerateNDistinctColors(Strs.Length + 1, 15, 5)
Dim Renderers As New List(Of RenderArray.RenderText)
For Count As Integer = 0 To Strs.Length - 1
RenderArray.RenderDisplayClass.eArabic, RenderArray.RenderDisplayClass.eLTR), _
Strs(Count) + If(Not bArabic And (Strs(Count) = String.Empty Or _
Strs(Count) = CStr(ArabicData.LeftToRightMark)), "NULL" + _
CStr(Count), String.Empty)) With {.Clr = Cols(Count + 1)})
If Not bArabic And Count <> Strs.Length - 1 _
(RenderArray.RenderDisplayClass.eLTR, ";"))
Next
Return Renderers.ToArray()
End Function
Public Shared Function ColorizeRegExGroups(Str As String, _
bReplaceGroup As Boolean) As RenderArray.RenderText()
'Define an numeric partial ordering of groups that
'is non-contiguous based on their nearest parent parenthesis
Dim ParenPos As New List(Of Integer)
For Count As Integer = 0 To Str.Length - 1
Next
Dim CurNum As Integer = 0
Dim NumStack As New Stack(Of Integer())
Dim Matches As System.Text.RegularExpressions.MatchCollection = _
System.Text.RegularExpressions.Regex.Matches(Str, If(bReplaceGroup, _
"(\\\$)?(\$\d+)", "(\\$$|\\$$)?($$\??|$$)"))
For MatchCount As Integer = 0 To Matches.Count - 1
If Matches(MatchCount).Groups(2).Value.Chars(0) = "\$" Then
Dim Num As Integer = Integer.Parse(Matches(MatchCount).Groups(2).Value.Substring(1))
CurNum = Math.Max(CurNum, Num)
For Count As Integer = Matches(MatchCount).Groups(2).Index _
To Matches(MatchCount).Groups(2).Index + Matches(MatchCount).Groups(2).Length - 1
ParenPos(Count) = Num
Next
ElseIf Matches(MatchCount).Groups(2).Value.Chars(0) = "("c Then
If Matches(MatchCount).Groups(2).Value.Length = 1 Then CurNum += 1
NumStack.Push(New Integer() {CurNum, _
If(Matches(MatchCount).Groups(2).Value.Length = 1, _
Matches(MatchCount).Groups(2).Index, Str.Length)})
Else
Debug.Assert(NumStack.Count <> 0) 'Misbalance parenthesis is exception
Dim Nums As Integer() = NumStack.Pop()
For Count As Integer = Nums(1) To Matches(MatchCount).Groups(2).Index
If Nums(0) > ParenPos(Count) Then ParenPos(Count) = Nums(0)
Next
End If
Next
Debug.Assert(NumStack.Count = 0) 'Misbalance parenthesis is exception
'Proper coloring requires that parent-child and neighboring siblings have different colors
'yet the current partial ordering does not define either of those relationships
'must maintain neighbor and color list to properly color
Dim Base As Integer = 0
Dim Cols As Color() = GenerateNDistinctColors(CurNum + 1, 15, 5)
Dim Renderers As New List(Of RenderArray.RenderText)
For Count As Integer = 0 To ParenPos.Count - 1
If Count = ParenPos.Count - 1 Then
Str.Substring(Base)) With {.Clr = Cols(ParenPos(Count))})
ElseIf ParenPos(Count) <> ParenPos(Count + 1) Then
Str.Substring(Base, Count - Base + 1)) With {.Clr = Cols(ParenPos(Count))})
Base = Count + 1
End If
Next
Return Renderers.ToArray()
End Function

## Points of Interest

Color searching is a P=NP problem. Incremental heuristical searching can make it feasible. Finding the absolute best most contrasting colors is very time consuming and requires an exhaustive brute force search. It also requires a multiple color comparison judgement as one of colors may have a higher average threshold but individually have some weak links. Multiple color comparison algorithms are not explored.

Color comparison needs to use a good algorithm and can ideally take into account color blindness to start searching with universally easy to decipher colors.

Unique contrasting colors for reading is different than for graphing as the background color must be more strongly contrasted as reading is different from other color usages.

Several coordinate systems from RGB, LAB, XYZ and HSV and conversion between them are useful to have wrapped in a library to make comparison easy.

• Version 1.0

## Share

 Software Developer (Senior) United States
No Biography provided

 First Prev Next
 My Vote of ZERO stars Member 113295295-Sep-19 0:26 Member 11329529 5-Sep-19 0:26
 Add some images Victor Khokhlov11-Mar-15 20:18 Victor Khokhlov 11-Mar-15 20:18
 My vote of 5 jdee5010-Mar-15 23:32 jdee50 10-Mar-15 23:32
 Expected result? jdee5010-Mar-15 6:24 jdee50 10-Mar-15 6:24
 Re: Expected result? Gregory Morse10-Mar-15 7:22 Gregory Morse 10-Mar-15 7:22
 Re: Expected result? Gregory Morse10-Mar-15 9:57 Gregory Morse 10-Mar-15 9:57
 Re: Expected result? jdee5010-Mar-15 23:34 jdee50 10-Mar-15 23:34
 Thanks Gregory - I'll check it out when I get a min. BTW I converted it to C#, with tests comparing results to the VB code
 Last Visit: 31-Dec-99 19:00     Last Update: 18-Jan-22 10:23 Refresh 1