Imports System.IO

Public Class Form1

  Dim BM As New Bitmap(289, 289)
  Dim Slider As Integer
  Dim Mousex As Integer = 180
  Dim Mousey As Integer = 60
  Dim Array(288, 288) As Integer
  Dim SelectedColour As Color
  Dim HueFunction As String
  Dim ColourModel As String

  Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
    Slider = 255
    PictureBox1.BackgroundImage = BM
    TrackBar1.Value = Slider
    RadioButton18.Checked = True
    RadioButton2.Checked = True
    SetSelectedColour()
  End Sub

  Private Sub UpdateArray()
    For x As Integer = 0 To 288
      For y As Integer = 0 To 288
        Array(x, y) = CalculateBaseColour(x, y)
      Next
    Next
  End Sub

  Private Function CalculateBaseColour(ByVal x, ByVal y)
    Dim f As Integer = 2 * Math.Sqrt((x - 144) ^ 2 + (y - 144) ^ 2)
    'If x < 40 And y < 40 Then Return &H0
    'If x > 248 And y < 40 Then Return &HFFFFFFFF
    If f > 271 Then Return 0
    If f > 255 Then f = 255
    Dim A As Double = ArcTan(x - 144, y - 144) ' A is the angle in hexians from -3 to 3
    Dim r, g, b As Integer
    r = ColourCurve(A, False)
    g = ColourCurve(A + 2, False)
    b = ColourCurve(A - 2, False)
    Return (f << 24) + (r << 16) + (g << 8) + b
  End Function

  Private Function ArcTan(ByVal x, ByVal y)
    ' returns angle in hexians (6 to the circle)
    Select Case True
      Case x = 0 : Return 1.5 * Math.Sign(y)
      Case y = 0 : Return 3 * -(x < 0)
      Case x > 0 : Return Math.Atan(y / x) * 3 / Math.PI
      Case y > 0 : Return 3 + Math.Atan(y / x) * 3 / Math.PI
    End Select
    Return -3 + Math.Atan(y / x) * 3 / Math.PI
  End Function

  Private Function ColourCurve(ByVal A As Double, ByVal f As Boolean) As Integer
    ' A is the normalized angle in hexians from -6 to 6
    If A < 0 Then A = -A ' A is 0-6
    If A > 3 Then A = 6 - A ' A is 0-3
    If A > 2 Then Return 0
    If A < 1 Then Return 255
    If HueFunction = "Linear" Or f Then Return 255 * (2 - A)
    Return 255 * (1 - (A - 1) * (A - 1))
  End Function

  Private Sub UpdateBM()
    Dim x, y, f, r, g, b As Integer
    Select Case ColourModel
      Case "Cube1", "Cube2", "Cube3"
        Dim u, v, p, q As Integer
        Dim flag As Boolean
        Dim r3 As Double = 1 / Math.Sqrt(3)
        Label4.Text = "Intensity (I)"
        For x = 0 To 288
          u = 2 * (x - 144) * 256 / (Slider + 1)
          For y = 0 To 288
            v = 2 * (y - 144) * 256 / (Slider + 1)
            p = u * 2 * r3 : q = 255 - (v + r3 * u)
            flag = True
            If filter(p, q) Then
              p = 255 + 2 * r3 * u : q = 255 - (v - r3 * u)
              If filter(p, q) Then
                p = 255 + r3 * u + v : q = r3 * u - v
                If filter(p, q) Then
                  r = 192 : g = 192 : b = 192 : flag = False
                Else
                  r = p : g = q : b = 255
                End If
              Else
                r = p : g = 0 : b = q
              End If
            Else
              r = 255 : g = p : b = q
            End If
            If flag Then r = r * Slider / 255 : g = g * Slider / 255 : b = b * Slider / 255
            Select Case ColourModel
              Case "Cube1" : BM.SetPixel(x, y, Color.FromArgb(r, g, b))
              Case "Cube2" : BM.SetPixel(x, y, Color.FromArgb(g, b, r))
              Case "Cube3" : BM.SetPixel(x, y, Color.FromArgb(b, r, g))
            End Select
          Next
        Next
      Case "RG - B"
        Label4.Text = "Blueness (B)"
        For x = 0 To 288
          For y = 0 To 288
            r = constrain(x) : g = constrain(288 - y) : b = Slider
            BM.SetPixel(x, y, Color.FromArgb(r, g, b))
          Next
        Next
      Case "GB - R"
        Label4.Text = "Redness (R)"
        For x = 0 To 288
          For y = 0 To 288
            g = constrain(x) : b = constrain(288 - y) : r = Slider
            BM.SetPixel(x, y, Color.FromArgb(r, g, b))
          Next
        Next
      Case "BR - G"
        Label4.Text = "Greenness (G)"
        For x = 0 To 288
          For y = 0 To 288
            b = constrain(x) : r = constrain(288 - y) : g = Slider
            BM.SetPixel(x, y, Color.FromArgb(r, g, b))
          Next
        Next
      Case "HC - X"
        Label4.Text = "Extra (X)"
        For x = 0 To 288
          For y = 0 To 288
            f = Array(x, y) >> 24 And &HFF
            r = ConvertCX(Array(x, y) >> 16 And &HFF, f, Slider)
            g = ConvertCX(Array(x, y) >> 8 And &HFF, f, Slider)
            b = ConvertCX(Array(x, y) And &HFF, f, Slider)
            'CheckBounds(r, g, b)
            BM.SetPixel(x, y, Color.FromArgb(r, g, b))
          Next
        Next
      Case "HX - C"
        Label4.Text = "Contrast (C)"
        For x = 0 To 288
          For y = 0 To 288
            f = Array(x, y) >> 24 And &HFF
            r = ConvertXC(Array(x, y) >> 16 And &HFF, f, Slider)
            g = ConvertXC(Array(x, y) >> 8 And &HFF, f, Slider)
            b = ConvertXC(Array(x, y) And &HFF, f, Slider)
            CheckBounds(r, g, b)
            BM.SetPixel(x, y, Color.FromArgb(r, g, b))
          Next
        Next
      Case "CX - H"
        Label4.Text = "Hue"
        Dim Rbase, Gbase, Bbase, c, d As Integer
        Dim A As Double = 6 * (Slider - 128) / 256
        Rbase = ColourCurve(A, False)
        Gbase = ColourCurve(A + 2, False)
        Bbase = ColourCurve(A - 2, False)
        For x = 0 To 288
          c = x - 16
          For y = 0 To 288
            If x < 16 Or x > 271 Or y < 16 Or y > 271 Then
              BM.SetPixel(x, y, Color.LightGray)
            Else
              d = y - 16
              r = c * Rbase / 255 + d - c / 2
              g = c * Gbase / 255 + d - c / 2
              b = c * Bbase / 255 + d - c / 2
              CheckBounds(r, g, b)
              BM.SetPixel(x, y, Color.FromArgb(r, g, b))
            End If
          Next
        Next
      Case "HS - V"
        Label4.Text = "Value (V)"
        For x = 0 To 288
          For y = 0 To 288
            f = Array(x, y) >> 24 And &HFF
            r = ConvertSV(Array(x, y) >> 16 And &HFF, f, Slider)
            g = ConvertSV(Array(x, y) >> 8 And &HFF, f, Slider)
            b = ConvertSV(Array(x, y) And &HFF, f, Slider)
            BM.SetPixel(x, y, Color.FromArgb(r, g, b))
          Next
        Next
      Case "HV - S"
        Label4.Text = "Saturation (S)"
        For x = 0 To 288
          For y = 0 To 288
            f = Array(x, y) >> 24 And &HFF
            r = ConvertVS(Array(x, y) >> 16 And &HFF, f, Slider)
            g = ConvertVS(Array(x, y) >> 8 And &HFF, f, Slider)
            b = ConvertVS(Array(x, y) And &HFF, f, Slider)
            BM.SetPixel(x, y, Color.FromArgb(r, g, b))
          Next
        Next
      Case "SV - H"
        Label4.Text = "Hue"
        Dim Rbase, Gbase, Bbase, v, s As Integer
        Dim A As Double = 6 * (Slider - 128) / 256
        Rbase = ColourCurve(A, False)
        Gbase = ColourCurve(A + 2, False)
        Bbase = ColourCurve(A - 2, False)
        For x = 0 To 288
          v = x - 16
          For y = 0 To 288
            If x < 16 Or x > 271 Or y < 16 Or y > 271 Then
              BM.SetPixel(x, y, Color.LightGray)
            Else
              s = 271 - y
              r = v * (255 - s * (255 - Rbase) / 255) / 255
              g = v * (255 - s * (255 - Gbase) / 255) / 255
              b = v * (255 - s * (255 - Bbase) / 255) / 255
              BM.SetPixel(x, y, Color.FromArgb(r, g, b))
            End If
          Next
        Next
      Case "HK - L"
        Label4.Text = "Lightness (L)"
        For x = 0 To 288
          For y = 0 To 288
            f = Array(x, y) >> 24 And &HFF
            r = ConvertKL(Array(x, y) >> 16 And &HFF, f, Slider)
            g = ConvertKL(Array(x, y) >> 8 And &HFF, f, Slider)
            b = ConvertKL(Array(x, y) And &HFF, f, Slider)
            BM.SetPixel(x, y, Color.FromArgb(r, g, b))
          Next
        Next
      Case "HL - K"
        Label4.Text = "Colourfulness (K)"
        For x = 0 To 288
          For y = 0 To 288
            f = Array(x, y) >> 24 And &HFF
            r = ConvertLK(Array(x, y) >> 16 And &HFF, f, Slider)
            g = ConvertLK(Array(x, y) >> 8 And &HFF, f, Slider)
            b = ConvertLK(Array(x, y) And &HFF, f, Slider)
            BM.SetPixel(x, y, Color.FromArgb(r, g, b))
          Next
        Next
      Case "KL - H"
        Label4.Text = "Hue"
        Dim Rbase, Gbase, Bbase, k, l, c As Integer
        Dim A As Double = 6 * (Slider - 128) / 256
        Rbase = ColourCurve(A, False)
        Gbase = ColourCurve(A + 2, False)
        Bbase = ColourCurve(A - 2, False)
        For x = 0 To 288
          k = x - 16
          For y = 0 To 288
            If x < 16 Or x > 271 Or y < 16 Or y > 271 Then
              BM.SetPixel(x, y, Color.LightGray)
            Else
              l = y - 16
              c = (Rbase * k) \ 255 : r = l * (255 - c) / 255 + c
              c = (Gbase * k) \ 255 : g = l * (255 - c) / 255 + c
              c = (Bbase * k) \ 255 : b = l * (255 - c) / 255 + c
              BM.SetPixel(x, y, Color.FromArgb(r, g, b))
            End If
          Next
        Next
      Case "HP - Q"
        Label4.Text = "Strength (Q)"
        For x = 0 To 288
          For y = 0 To 288
            f = Array(x, y) >> 24 And &HFF
            r = ConvertPQ(Array(x, y) >> 16 And &HFF, f, Slider)
            g = ConvertPQ(Array(x, y) >> 8 And &HFF, f, Slider)
            b = ConvertPQ(Array(x, y) And &HFF, f, Slider)
            BM.SetPixel(x, y, Color.FromArgb(r, g, b))
          Next
        Next
      Case "HQ - P"
        Label4.Text = "Strength (P)"
        For x = 0 To 288
          For y = 0 To 288
            f = Array(x, y) >> 24 And &HFF
            r = ConvertQP(Array(x, y) >> 16 And &HFF, f, Slider)
            g = ConvertQP(Array(x, y) >> 8 And &HFF, f, Slider)
            b = ConvertQP(Array(x, y) And &HFF, f, Slider)
            BM.SetPixel(x, y, Color.FromArgb(r, g, b))
          Next
        Next
      Case "PQ - H"
        Label4.Text = "Hue"
        Dim Rbase, Gbase, Bbase As Integer
        Dim p, q, c As Double
        Dim A As Double = 6 * (Slider - 128) / 256
        Rbase = ColourCurve(A, False)
        Gbase = ColourCurve(A + 2, False)
        Bbase = ColourCurve(A - 2, False)
        For x = 0 To 288
          p = (x - 16) / 255
          For y = 0 To 288
            If x < 16 Or x > 271 Or y < 16 Or y > 271 Then
              BM.SetPixel(x, y, Color.LightGray)
            Else
              q = (271 - y) / 255
              c = Rbase / 255 : r = 255 * (p * q * c + (p - p * q - q + 1) / 2)
              c = Gbase / 255 : g = 255 * (p * q * c + (p - p * q - q + 1) / 2)
              c = Bbase / 255 : b = 255 * (p * q * c + (p - p * q - q + 1) / 2)
              BM.SetPixel(x, y, Color.FromArgb(r, g, b))
            End If
          Next
        Next
      Case "Cheese slice"
        Dim u, v As Integer
        Dim h, h1, h2 As Double
        Dim s, m As Integer
        s = Slider
        If s > 84 Then s = s - 85 : m += 1
        If s > 84 Then s = s - 85 : m += 1
        If s > 84 Then s = 84
        h = s / 84
        h1 = Math.Sqrt(1 + h * h)
        h2 = Math.Sqrt(1 + (1 - h) * (1 - h))
        Label4.Text = "Hue (H)"
        For x = 0 To 288
          For y = 0 To 288
            If x < 16 Or x > 271 Or y < 16 Or y > 271 Then
              r = 192 : g = 192 : b = 192
            Else
              v = (271 - y) * h2
              u = (x - 16) * h1
              r = u / h1 : b = v / h2
              If m = 1 Then s = b : b = r : r = s ' swap red and blue 
              g = b + h * (r - b)
            End If
            Select Case m
              Case 0 : BM.SetPixel(x, y, Color.FromArgb(r, g, b))
              Case 1 : BM.SetPixel(x, y, Color.FromArgb(g, b, r))
              Case 2 : BM.SetPixel(x, y, Color.FromArgb(b, r, g))
            End Select
          Next
        Next
    End Select
  End Sub

  Private Function filter(ByVal p, ByVal q)
    Return p < 2 Or p > 253 Or q < 2 Or q > 253
  End Function

  Private Function constrain(ByVal x)
    If x < 16 Then Return 0
    If x > 271 Then Return 255
    Return x - 16
  End Function

  Private Sub CheckBounds(ByRef r, ByRef g, ByRef b)
    If r < 0 Or g < 0 Or b < 0 Then r = 0 : g = 0 : b = 0
    If r > 255 Or g > 255 Or b > 255 Then r = 255 : g = 255 : b = 255
  End Sub

  Private Function ConvertCX(ByVal col, ByVal c, ByVal x) As Integer
    If c = 255 Then Return col
    If x < 128 Then c = 2 * c * x / 255 Else c = 2 * c * (255 - x) / 255
    Return c * col \ 255 + x - c \ 2
  End Function

  Private Function ConvertXC(ByVal col, ByVal x, ByVal c) As Integer
    If x = 255 Then Return col
    Return c * col \ 255 + x - c \ 2
    Return col
  End Function

  Private Function ConvertSV(ByVal c, ByVal s, ByVal v) As Integer
    If s = 255 Then Return c
    Return v * (255 - s * (255 - c) / 255) / 255
  End Function

  Private Function ConvertVS(ByVal c, ByVal v, ByVal s) As Integer
    If v = 255 Then Return c
    Return v * (255 - s * (255 - c) / 255) / 255
  End Function

  Private Function ConvertKL(ByVal c, ByVal k, ByVal l) As Integer
    If k = 255 Then Return c
    c = (c * k) \ 255
    Return l * (255 - c) / 255 + c
  End Function

  Private Function ConvertLK(ByVal c, ByVal l, ByVal k) As Integer
    If l = 255 Then Return c
    c = (c * k) \ 255
    Return l * (255 - c) / 255 + c
  End Function

  Private Function ConvertPQ(ByVal c, ByVal p, ByVal q) As Integer
    If p = 255 Then Return c
    p = p / 255 : q = q / 255 : c = c / 255
    Return 255 * (p * q * c + (p - p * q - q + 1) / 2)
  End Function

  Private Function ConvertQP(ByVal c, ByVal q, ByVal p) As Integer
    If q = 255 Then Return c
    p = p / 255 : q = q / 255 : c = c / 255
    Return 255 * (p * q * c + (p - p * q - q + 1) / 2)
  End Function

  Private Sub TrackBar1_Scroll(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles TrackBar1.Scroll
    Slider = TrackBar1.Value
    NumericUpDown1.Value = Slider
    UpdateBM() : PictureBox1.Invalidate()
  End Sub

  Private Sub NumericUpDown1_ValueChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles NumericUpDown1.ValueChanged
    Slider = NumericUpDown1.Value
    TrackBar1.Value = Slider
    UpdateBM()
    PictureBox1.Invalidate()
  End Sub

  Private Sub PictureBox3_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox3.MouseDown
    Slider = 255 * (240 - e.Y) / 240
    NumericUpDown1.Value = Slider
    TrackBar1.Value = Slider
    UpdateBM()
    PictureBox1.Invalidate()
  End Sub

  Private Sub PictureBox1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseDown
    Mousex = e.X : Mousey = e.Y
    SetSelectedColour()
  End Sub

  Private Sub PictureBox1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseMove
    If MouseButtons = Windows.Forms.MouseButtons.Left Then
      Mousex = e.X : Mousey = e.Y
      SetSelectedColour()
    End If
  End Sub

  Private Sub SetSelectedColour()
    If Mousex < 0 Or Mousey < 0 Or Mousex > 288 Or Mousey > 288 Then Exit Sub
    SelectedColour = BM.GetPixel(Mousex, Mousey)
    Label1.Text = "R:" & Str(SelectedColour.R)
    Label2.Text = "G:" & Str(SelectedColour.G)
    Label3.Text = "B:" & Str(SelectedColour.B)
    PictureBox2.Invalidate()
  End Sub

  Private Sub PictureBox2_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles PictureBox2.Paint
    e.Graphics.FillRectangle(Brushes.Black, 0, 0, 64, 64)
    Dim b As New SolidBrush(SelectedColour)
    e.Graphics.FillEllipse(b, 10, 10, 108, 44)
  End Sub

  Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
    Dim t As String = Str(SelectedColour.R) & "," & Str(SelectedColour.G) & "," & Str(SelectedColour.B)
    t &= " : " & Hex(SelectedColour.ToArgb)
    Label5.Text = "Selected colour: " & t
    Clipboard.SetText(t)
  End Sub

  Private Sub HueFunctionChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) _
  Handles RadioButton1.CheckedChanged, RadioButton2.CheckedChanged
    If RadioButton1.Checked Then HueFunction = "Linear" Else HueFunction = "Quadratic"
    UpdateArray()
    UpdateBM() : PictureBox1.Invalidate() : PictureBox3.Invalidate()
  End Sub

  Private Sub ColourModelChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) _
  Handles RadioButton3.CheckedChanged, RadioButton4.CheckedChanged, RadioButton5.CheckedChanged, RadioButton6.CheckedChanged, _
  RadioButton7.CheckedChanged, RadioButton8.CheckedChanged, RadioButton9.CheckedChanged, RadioButton10.CheckedChanged, _
  RadioButton11.CheckedChanged, RadioButton12.CheckedChanged, RadioButton13.CheckedChanged, RadioButton14.CheckedChanged, RadioButton15.CheckedChanged, RadioButton17.CheckedChanged, RadioButton16.CheckedChanged, RadioButton20.CheckedChanged, RadioButton19.CheckedChanged, RadioButton18.CheckedChanged, RadioButton21.CheckedChanged
    For Each c As RadioButton In GroupBox2.Controls
      If c.Checked Then ColourModel = c.Text
    Next
    GroupBox1.Enabled = Not ColourModel.StartsWith("Cube") And Not ColourModel.StartsWith("Cheese")
    UpdateArray() : UpdateBM() : PictureBox1.Invalidate() : PictureBox3.Invalidate()
  End Sub

  Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
    Dim f As String = Application.StartupPath & "\ColourCubeHelp.chm"
    If File.Exists(f) Then
      Process.Start(f)
    Else
      MsgBox("I cannot find a help file")
    End If
  End Sub

  Private Sub PictureBox3_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles PictureBox3.Paint
    Dim A As Double
    Dim p As Pen
    Select Case ColourModel
      Case "RG - B"
        For y As Integer = 0 To 240
          A = 255 * (240 - y) / 240
          p = New Pen(Color.FromArgb(A, 0, 0))
          e.Graphics.DrawLine(p, 0, y, 12, y)
        Next
      Case "GB - R"
        For y As Integer = 0 To 240
          A = 255 * (240 - y) / 240
          p = New Pen(Color.FromArgb(0, 0, A))
          e.Graphics.DrawLine(p, 0, y, 12, y)
        Next
      Case "BR - G"
        For y As Integer = 0 To 240
          A = 255 * (240 - y) / 240
          p = New Pen(Color.FromArgb(0, A, 0))
          e.Graphics.DrawLine(p, 0, y, 12, y)
        Next
      Case "CX - H", "SV - H", "KL - H", "PQ - H"
        For y As Integer = 0 To 240
          A = (120 - y) / 40
          p = New Pen(Color.FromArgb(ColourCurve(A, False), ColourCurve(A + 2, False), ColourCurve(A - 2, False)))
          e.Graphics.DrawLine(p, 0, y, 12, y)
        Next
      Case "Cheese slice"
        For y As Integer = 0 To 240
          A = -(240 - y) / 80
          p = New Pen(Color.FromArgb(ColourCurve(A, True), ColourCurve(A + 2, True), ColourCurve(A - 2, True)))
          e.Graphics.DrawLine(p, 0, y, 6, y)
          p = New Pen(Color.FromArgb(ColourCurve(A + 3, True), ColourCurve(A + 5, True), ColourCurve(A + 1, True)))
          e.Graphics.DrawLine(p, 6, y, 12, y)
        Next
      Case "HX - C", "HV - S", "HL - K", "HP - Q", "HQ - P"
      Case Else
        For y As Integer = 0 To 240
          A = 255 * (240 - y) / 240
          p = New Pen(Color.FromArgb(A, A, A))
          e.Graphics.DrawLine(p, 0, y, 12, y)
        Next
    End Select
  End Sub
End Class
