After some research, I've decided to use the Liang-Barsky line clipping algorithm in my 2D game. Google did not deliver on any VB.NET implementations of this algorithm but plenty C/++ ones. Therefore, as I have knowledge in C++, decided to port one found on Skytopia over to VB.Net. Unfortunately, it does not work with:
Public Class PhysicsObject
Public Function CollideRay(ByVal p0 As Point, ByVal p1 As Point, ByRef clip0 As Point, ByRef clip1 As Point) As Boolean
Dim t0 As Double = 0.0
Dim t1 As Double = 1.0
Dim xdelta As Double = p1.X - p0.X
Dim ydelta As Double = p1.Y - p0.Y
Dim p, q, r As Double
For edge = 0 To 3
' Traverse through left, right, bottom, top edges
If (edge = 0) Then
p = -xdelta
q = -(AABB.Left - p0.X)
ElseIf (edge = 1) Then
p = xdelta
q = (AABB.Right - p0.X)
ElseIf (edge = 2) Then
p = -ydelta
q = -(AABB.Bottom - p0.Y)
ElseIf (edge = 3) Then
p = ydelta
q = (AABB.Top - p0.Y)
End If
r = q / p
If p = 0 And q < 0 Then Return False ' Don't draw line at all. (parallel line outside)
If p < 0 Then
If r > t1 Then
Return False ' Don't draw line at all.
ElseIf r > t0 Then
t0 = r ' Line is clipped!
End If
ElseIf p > 0 Then
If r < t0 Then
Return False ' Don't draw line at all.
ElseIf r < t1 Then
t1 = r ' Line is clipped!
End If
End If
Next
clip0.X = p0.X + t0 * xdelta
clip0.Y = p0.Y + t0 * ydelta
clip1.X = p0.X + t1 * xdelta
clip1.Y = p0.Y + t1 * ydelta
Return True ' (clipped) line is drawn
End Function
Public AABB As Rectangle
End Class
I'm using the class/method like:
Dim testPhysics As PhysicsObject = New PhysicsObject
testPhysics.AABB = New Rectangle(30, 30, 20, 20)
Dim p0, p1 As Point
p0 = New Point(0, 0)
p1 = New Point(120, 120)
Dim clip0, clip1 As Point
clip0 = New Point(-1, -1)
clip1 = New Point(-1, -1)
GlobalRenderer.Graphics.DrawLine(Pens.LimeGreen, p0, p1)
If testPhysics.CollideRay(p0, p1, clip0, clip1) Then
GlobalRenderer.Graphics.DrawLine(Pens.Magenta, clip0, clip1)
End If
However, the CollideRay method fails on its 3rd edge iteration (edge = 3), r < t0, therefore the function returns false.
I'm wondering if anyone can spot some issue with my CollideRay function which would result in this behaviour, because I'm well and truly stumped.
Thanks in advance.
The code assumes a different coordinate system, note that topEdge is larger than bottomEdge in the linked web page. Your test works with normal graphics coordinates where Bottom is larger than Top. You have to swap the bottom and top arguments.
Related
I am not sure whether this question was relevant for stackoverflow or cryptography stackexchange, but I thought that I would ask it here as the question might go into programming.
I am trying to generate a public and private keypair using elliptic curve diffie-hellman, I successfully generate a private key that is smaller than the order of the curve but when I calculate the public key by multiplying the base point by the private key I calculate a point that is not on the curve.
The code I am using to generate the keys looks like this:
Public Shared Function generate_Keys(ByVal Param As Domain_Parameters) As Keys
Dim __PrivateKey As BigInteger
Dim __PublicKey As ECPoint
Dim d As BigInteger
Dim rng As New RNGCryptoServiceProvider
Dim bytes(Param.n.ToByteArray.Length) As Byte
Do
rng.GetBytes(bytes)
d = New BigInteger(bytes)
If d.Sign = -1 Then
d = d * -1
End If
Loop While d >= Param.n
__PrivateKey = d
__PublicKey = Point_Operations.Scalar_Mult(Param.Base, Param, d)
Dim Ret As Keys
Ret.PublicKey = __PublicKey
Ret.PrivateKey = __PrivateKey
__PrivateKey = BigInteger.Zero()
d = BigInteger.Zero()
bytes = {0}
Return Ret
End Function
And the code that I have tested and works fine to multiply the base point by the private key looks like this:
Public Class Point_Operations
''' <summary>
''' A structure that contains data returned from Extended_GCD function
''' </summary>
Friend Structure RetGCD
Public x As BigInteger
Public y As BigInteger
Public GCD As BigInteger
End Structure
''' <summary>
''' Perfomrs addition of two points
''' </summary>
Public Shared Function Addition(ByVal P1 As ECPoint, ByVal P2 As ECPoint) As ECPoint
'Details about the maths was found on https://en.wikipedia.org/wiki/Elliptic_curve_point_multiplication
'Tested with the site http://christelbach.com/ECCalculator.aspx
If P1.IsPointInfinity() Then
Return P2
End If
If P2.IsPointInfinity() Then
Return P1
End If
If P1.p <> P2.p Then
Return New ECPoint(-99, -99, -99) 'Add custom errors with ENUM
End If
If P1.x = P2.x And P1.y = P2.y Then
Return New ECPoint(-99, -99, -99)
End If
Dim P3 As New ECPoint(P1)
Dim l, z As BigInteger
z = Inverse((P2.x - P1.x), P1.p)
l = ((P2.y - P1.y) * z) Mod P1.p
P3.x = ((l * l) Mod P1.p - P2.x - P1.x) Mod P1.p
P3.y = (l * (P1.x - P3.x) Mod P1.p - P1.y) Mod P1.p
If P3.x < 0 Then 'Tested the code without the peice below and found that the input (10,10,47) and (20,20,47) returned wrong values found out that the difference between each was the prime number so if its less than zero we add the prime whcih seems to work
P3.x += P1.p
End If
If P3.y < 0 Then
P3.y += P1.p
End If
Return P3
End Function
''' <summary>
''' A way of doubling a EC Point
''' </summary>
Public Shared Function PDouble(ByVal P As ECPoint, ByVal a As Domain_Parameters) As ECPoint
'Details about the maths was found on https://en.wikipedia.org/wiki/Elliptic_curve_point_multiplication
'Tested with the site http://christelbach.com/ECCalculator.aspx
If P.p = 0 And a.Fp.p = 0 Then
Return New ECPoint(-99, -99, -99)
End If
'If a.a = 0 Then
' Return New ECPoint(-99, -99, -99)
'End If
If P.IsPointInfinity() Then
Return P
End If
Dim prime As BigInteger
If P.p = 0 Then
prime = a.Fp.p
Else
prime = P.p
End If
Dim Q As New ECPoint(P)
Dim l, z As BigInteger
z = Inverse(2 * P.y, P.p)
l = ((((3 * P.x * P.x) Mod P.p + a.a) Mod P.p) * z) Mod P.p
Q.x = ((l * l) Mod P.p - 2 * P.x) Mod P.p 'accidental set (2 * p.x) to (2 * P.p)
Q.y = (l * (P.x - Q.x) Mod P.p - P.y) Mod P.p
If Q.x < 0 Then 'This code was tested and the same problem again with negative values for x and y so we must add the prime to p to correct that
Q.x += P.p
End If
If Q.y < 0 Then
Q.y += P.p
End If
Return Q
End Function
''' <summary>
''' Performs point multiplication with a scalar
''' </summary>
Public Shared Function Scalar_Mult(ByVal P As ECPoint, ByVal a As Domain_Parameters, ByVal Scalar As BigInteger) As ECPoint
'Details about the maths was found on https://en.wikipedia.org/wiki/Elliptic_curve_point_multiplication
'Tested with the site http://christelbach.com/ECCalculator.aspx
If P.p = 0 And a.Fp.p = 0 Then
Return New ECPoint(-99, -99, -99)
End If
'If a.a = 0 Then
' Return New ECPoint(-99, -99, -99)
'End If
If P.IsPointInfinity Then
Return P
End If
Dim prime As BigInteger
If P.p = 0 Then
prime = a.Fp.p
Else
prime = P.p
End If
'Dim k As New BigInteger(Scalar.ToByteArray)
Dim N, S As New ECPoint(P)
S = New ECPoint(0, 0, prime) 'Accidentally set S.y = 1 was causing a bad value
'Dim sc As New BigInteger(k.ToByteArray) 'Depreciated as now we can use bits.lenght
'Dim bitlenght As Integer
'While sc / 2 <> 0
' bitlenght += 1
' sc /= 2
'End While
Dim bits As New BitArray(Scalar.ToByteArray)
For i = 0 To bits.Length - 1
If bits(i) = True Then 'Fixed error where BitArray uses True/False instead of 1/0
S = Addition(S, N)
End If
N = PDouble(N, a)
Next
Return S
End Function
''' <summary>
''' Calcualtes the Greatest Common Divisor of two numbers
''' </summary>
Private Shared Function Extended_GCD(ByVal a As BigInteger, b As BigInteger) As RetGCD
'The pseudocode was found on https://en.wikipedia.org/wiki/Extended_Euclidean_algorithm#Pseudocode
'Tested with the site http://planetcalc.com/3298/
Dim r, o_r As BigInteger
Dim t, o_t As BigInteger
Dim s, o_s As BigInteger
Dim p, q As BigInteger
Dim ret As RetGCD
s = 0
t = 1
r = b
o_s = 1
o_t = 0
o_r = a
While r <> 0
q = o_r / r
p = r
r = o_r - q * p
o_r = p
p = s
s = o_s - q * p
o_s = p
p = t
t = o_t - q * p
o_t = p
End While
ret.x = o_s
ret.y = o_t
ret.GCD = o_r
Return ret
End Function
''' <summary>
''' Performs the modular multiplitcative inverse of a number so we can use multiplication instead of division in our arithmetic
''' </summary>
Public Shared Function Inverse(ByVal a As BigInteger, ByVal p As BigInteger) As BigInteger
'Not tested but works
Dim ret As RetGCD
ret = Extended_GCD(a, p)
If ret.GCD <> 1 Then
Return 0
End If
Return ret.x Mod p
End Function
I have a feeling that it is possibly the way I am generating a private key or that I am using the wrong operation when calculating G.d .
Any help would really be appreciated thanks.
===EDIT===
After spending some time check values I have found the problem to be caused by the scalar_mult function not returning the right value. Is this function written correctly because i am unsure I have tested it with values from a site and it has been adapted from the pseudocode on wikipedia. Is that the correct method for adding a point to itself x number of time?
I'm trying to get all pixels in a 382x336 px area of my screen, detect certain colors and click the last detected one of them (for a game).
My problem is that my scan takes a huge amount of time to cover that area, making it impossible for my AI to keep up with the game.
Are there better methods to achieve my goal? Or is there a way I could optimize my code to run faster?
Main code:
Dim LFE, LNE As Point
For YI As Integer = 264 To 600 Step 1
P.Y = YI
LFE = New Point(0, 0)
LNE = New Point(0, 0)
For XI As Integer = 493 To 875 Step 1
P.X = XI
If GetPoint(P) = "ffef3031" OrElse GetPoint(P) = "fff0d381" OrElse GetPoint(P) = "ff19a3ff" OrElse GetPoint(P) = "ff795f14" Then
LNE = P
ElseIf GetPoint(P) = "ffee1600" Then
LFE = P
End If
Next
Next
If LFE = New Point(0, 0) Then
If Not LNE = New Point(0, 0) Then
Cursor.Position = LNE
End If
Else
Cursor.Position = LFE
End If
GetPoint function:
Function GetPoint(ByVal Pnt As Point) As String
Dim a As New Drawing.Bitmap(1, 1)
Dim b As System.Drawing.Graphics = System.Drawing.Graphics.FromImage(a)
b.CopyFromScreen(New Drawing.Point(MousePosition.X, MousePosition.Y), New Drawing.Point(0, 0), a.Size)
Dim c As Drawing.Color = a.GetPixel(0, 0)
PictureBox1.BackColor = c
Return PictureBox1.BackColor.Name
End Function
How can I show I winform that I create in VB.NET just below the active cell?
I have no idea how to solve this. I found the following promising solutions:
Excel addin: Cell absolute position
-The accepted solution seems too complicated to work reliably. I got an error on the first row (Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long)
-The second solution looked promising, but it didn't give me the right positions for my windows form.
The following adaptations of the second proposed solution does not create any errors but does not put the windows form in the correct position:
Public Sub GetScreenPositionFromCell(cell As Excel.Range, excel As Excel.Application)
Dim x As Double
Dim y As Double
If Not excel.ActiveWindow Is Nothing Then
x = excel.ActiveWindow.PointsToScreenPixelsX(cell.Left)
y = excel.ActiveWindow.PointsToScreenPixelsY(cell.Top)
End If
Me.Left = x
Me.Top = y
Me.Show()
Me.TopMost = True
End Sub
EDIT: #Loating, here is how I have used your code. It's great and I am very happy that you are taking your time to help me with a solution. The x-coordinates seems to work while the x-coordinates are a bit off and more or less off depending on the zoom level.
Public Sub ShowMeBelowActiveCell()
Dim ExcelApp As Excel.Application = CType(AddinExpress.MSO.ADXAddinModule.CurrentInstance, AddinModule).ExcelApp
Dim excelWindow = ExcelApp.ActiveWindow
Dim cell = ExcelApp.ActiveCell
Dim zoomFactor As Double = excelWindow.Zoom / 100
Dim ws = cell.Worksheet
' PointsToScreenPixels returns different values if the scroll is not currently 1
' Temporarily set the scroll back to 1 so that PointsToScreenPixels returns a
' value we know how to handle.
Dim origScrollCol = excelWindow.ScrollColumn
Dim origScrollRow = excelWindow.ScrollRow
excelWindow.ScrollColumn = 1
excelWindow.ScrollRow = 1
' (x,y) are screen coordinates for the top left corner of the top left cell
Dim x As Integer = excelWindow.PointsToScreenPixelsX(0)
' e.g. window.x + row header width
Dim y As Integer = excelWindow.PointsToScreenPixelsY(0)
' e.g. window.y + ribbon height + column headers height
Dim dpiX As Single = 0
Dim dpiY As Single = 0
Using g = Drawing.Graphics.FromHwnd(IntPtr.Zero)
dpiX = g.DpiX
dpiY = g.DpiY
End Using
' Note: Each column width / row height has to be calculated individually.
' Before, tried to use this approach:
' var r2 = (Microsoft.Office.Interop.Excel.Range) cell.Worksheet.Cells[origScrollRow, origScrollCol];
' double dw = cell.Left - r2.Left;
' double dh = cell.Top - r2.Top;
' However, that only works when the zoom factor is a whole number.
' A fractional zoom (e.g. 1.27) causes each individual row or column to round to the closest whole number,
' which means having to loop through.
For i As Integer = origScrollCol To cell.Column - 1
Dim col = DirectCast(ws.Cells(cell.Row, i), Microsoft.Office.Interop.Excel.Range)
Dim ww As Double = col.Width * dpiX / 72
Dim newW As Double = zoomFactor * ww
x += CInt(Math.Round(newW))
Next
For i As Integer = origScrollRow To cell.Row - 1
Dim row = DirectCast(ws.Cells(i, cell.Column), Microsoft.Office.Interop.Excel.Range)
Dim hh As Double = row.Height * dpiY / 72
Dim newH As Double = zoomFactor * hh
y += CInt(Math.Round(newH))
Next
excelWindow.ScrollColumn = origScrollCol
excelWindow.ScrollRow = origScrollRow
Me.StartPosition = Windows.Forms.FormStartPosition.Manual
Me.Location = New Drawing.Point(x, y)
Me.Show()
End Sub
End Class
When the ScrollColumn and ScrollRow are both 1, then PointsToScreenPixelsX/Y seems to return the top left point of the top left visible cell in screen coordinates. Using this, the offset width and height to the active cell is calculated, taking into consideration the zoom setting.
var excelApp = Globals.ThisAddIn.Application;
var excelWindow = excelApp.ActiveWindow;
var cell = excelApp.ActiveCell;
double zoomFactor = excelWindow.Zoom / 100;
var ws = cell.Worksheet;
var ap = excelWindow.ActivePane; // might be split panes
var origScrollCol = ap.ScrollColumn;
var origScrollRow = ap.ScrollRow;
excelApp.ScreenUpdating = false;
// when FreezePanes == true, ap.ScrollColumn/Row will only reset
// as much as the location of the frozen splitter
ap.ScrollColumn = 1;
ap.ScrollRow = 1;
// PointsToScreenPixels returns different values if the scroll is not currently 1
// Temporarily set the scroll back to 1 so that PointsToScreenPixels returns a
// value we know how to handle.
// (x,y) are screen coordinates for the top left corner of the top left cell
int x = ap.PointsToScreenPixelsX(0); // e.g. window.x + row header width
int y = ap.PointsToScreenPixelsY(0); // e.g. window.y + ribbon height + column headers height
float dpiX = 0;
float dpiY = 0;
using (var g = Graphics.FromHwnd(IntPtr.Zero)) {
dpiX = g.DpiX;
dpiY = g.DpiY;
}
int deltaRow = 0;
int deltaCol = 0;
int fromCol = origScrollCol;
int fromRow = origScrollRow;
if (excelWindow.FreezePanes) {
fromCol = 1;
fromRow = 1;
deltaCol = origScrollCol - ap.ScrollColumn; // Note: ap.ScrollColumn/Row <> 1
deltaRow = origScrollRow - ap.ScrollRow; // see comment: when FreezePanes == true ...
}
// Note: Each column width / row height has to be calculated individually.
// Before, tried to use this approach:
// var r2 = (Microsoft.Office.Interop.Excel.Range) cell.Worksheet.Cells[origScrollRow, origScrollCol];
// double dw = cell.Left - r2.Left;
// double dh = cell.Top - r2.Top;
// However, that only works when the zoom factor is a whole number.
// A fractional zoom (e.g. 1.27) causes each individual row or column to round to the closest whole number,
// which means having to loop through.
for (int i = fromCol; i < cell.Column; i++) {
// skip the columns between the frozen split and the first visible column
if (i >= ap.ScrollColumn && i < ap.ScrollColumn + deltaCol)
continue;
var col = ((Microsoft.Office.Interop.Excel.Range) ws.Cells[cell.Row, i]);
double ww = col.Width * dpiX / 72;
double newW = zoomFactor * ww;
x += (int) Math.Round(newW);
}
for (int i = fromRow; i < cell.Row; i++) {
// skip the columns between the frozen split and the first visible column
if (i >= ap.ScrollRow && i < ap.ScrollRow + deltaRow)
continue;
var row = ((Microsoft.Office.Interop.Excel.Range) ws.Cells[i, cell.Column]);
double hh = row.Height * dpiY / 72;
double newH = zoomFactor * hh;
y += (int) Math.Round(newH);
}
ap.ScrollColumn = origScrollCol;
ap.ScrollRow = origScrollRow;
excelApp.ScreenUpdating = true;
Form f = new Form();
f.StartPosition = FormStartPosition.Manual;
f.Location = new Point(x, y);
f.Show();
I am fairly new to coding (started early this year) and I'm making a program in VB 2010 express that makes a line chart for values that have been given by the user.
In other words, I ask for values and make the program create rectangles on a canvas, one rectangle for every item added to my ArrayList.
This part of the code works, now I want a gradient color scheme, so another color for every rectangle. To achieve this I tried this:
Dim red As Integer = 254
Dim green As Integer = 141
Dim blue As Integer = 150
calcColor(red, green, blue)
Dim MyBrushColor As Color = Color.FromRgb(red, green, blue)
Private Sub calcColor(ByVal red As Integer, ByVal green As Integer, ByVal blue As Integer)
If (red <= 0 Or green <= 0 Or blue <= 0) Then
red = 254
green = 141
blue = 150
red = red + 8
green = green + 8
blue = blue + 8
End If
If (red >= 254 Or green >= 141 Or blue >= 150) Then
red = 254
green = 141
blue = 150
red = red - 8
green = green - 8
blue = blue - 8
End If
End Sub
Just doing -8 and +8 every time is not going to cut it and once they reach either zero or their inital value they'll have another ratio..
As a very inexperienced coder I have no idea how to calculate this ratio. I just know that it's this kind of code I want.
Don't reinvent the wheel. The GDI+ library provides linear gradient brushes. You define starting point and an end point and colors in between and just use this brush for painting.
Example (will comment below):
Dim bmp As New Bitmap(400, 400)
Using brush As Drawing2D.LinearGradientBrush = New Drawing2D.LinearGradientBrush(New Point(0, 0), _
New Point(400, 400), _
Color.Blue, _
Color.Red)
Using p As New Pen(brush)
Using g As Graphics = Graphics.FromImage(bmp)
For i = 1 To 400 Step 10
g.DrawRectangle(p, i - 5, i - 5, 10, 10)
Next
End Using
End Using
End Using
If PictureBox1.Image IsNot Nothing Then PictureBox1.Image.Dispose()
PictureBox1.Image = bmp
First I create a bitmap as a canvas (bmp).
I then create a new object of the paint class. In the constructor I provide an object of the LinearGradientBrush class, with a start point in the top left corner, and an end point in the lower right with colors blue at the start and red at the end.
I then just paint a row of rectangles along the diagonal with this pen for reference.
This brush can do much more, as well. It can use several points on planes and so on and does the color interpolation for you. You just draw with it. Refer to the MSDN for further details: http://msdn.microsoft.com/de-de/library/system.drawing.drawing2d.lineargradientbrush.aspx
Please only look at this if you get stuck. You will learn more by trying it yourself first. Your teacher has probably seen this.
If you use the HSL colour representation, you should be able to get a nice effect by keeping S (saturation) and L (lightness) constant while varying H (hue). You will need to write functions to convert between RGB and HSL - there are many instances of that on the Internet, so here's another one:
Public Class ColourRepresentation
' Adapted from http://www.geekymonkey.com/Programming/CSharp/RGB2HSL_HSL2RGB.htm
' with conversion from C# to VB.NET by http://www.developerfusion.com/tools/convert/csharp-to-vb/
Public Class HSLcolour
Property H As Double
Property S As Double
Property L As Double
Public Overrides Function ToString() As String
Return String.Format("H={0}, S={1}, L={2}", H, S, L)
End Function
End Class
''' <summary>
''' Convert from HSL to RGB.
''' </summary>
''' <param name="c">An HSLcolour</param>
''' <returns>A System.Drawing.Color with A set to 255.</returns>
''' <remarks>H, S, L in the range [0.0, 1.0].</remarks>
Public Shared Function HSLtoRGB(c As HSLcolour) As Color
Dim r As Double = c.L
Dim g As Double = c.L
Dim b As Double = c.L
Dim v As Double = If((c.L <= 0.5), (c.L * (1.0 + c.S)), (c.L + c.S - c.L * c.S))
If v > 0 Then
Dim m As Double = c.L + c.L - v
Dim sv As Double = (v - m) / v
c.H *= 6.0
Dim sextant As Integer = CInt(Math.Truncate(c.H))
Dim fract As Double = c.H - sextant
Dim vsf As Double = v * sv * fract
Dim mid1 As Double = m + vsf
Dim mid2 As Double = v - vsf
Select Case sextant
Case 0, 6
r = v
g = mid1
b = m
Case 1
r = mid2
g = v
b = m
Case 2
r = m
g = v
b = mid1
Case 3
r = m
g = mid2
b = v
Case 4
r = mid1
g = m
b = v
Case 5
r = v
g = m
b = mid2
End Select
End If
Return Color.FromArgb(255, CByte(r * 255), CByte(g * 255), CByte(b * 255))
End Function
' Given a Color (RGB Struct) in range of 0-255
' Return H,S,L in range of 0-1
''' <summary>
''' Convert from a Color to an HSLcolour.
''' </summary>
''' <param name="rgb">A System.Drawing.Color.</param>
''' <returns>An HSLcolour.</returns>
''' <remarks>Ignores Alpha value in the parameter.</remarks>
Public Shared Function RGBtoHSL(rgb As Color) As HSLcolour
Dim r As Double = rgb.R / 255.0
Dim g As Double = rgb.G / 255.0
Dim b As Double = rgb.B / 255.0
Dim v As Double = Math.Max(r, g)
v = Math.Max(v, b)
Dim m As Double = Math.Min(r, g)
m = Math.Min(m, b)
Dim l As Double = (m + v) / 2.0
If l <= 0.0 Then
Return New HSLcolour With {.H = 0, .L = 0, .S = 0}
End If
Dim vm As Double = v - m
Dim s As Double = vm
If s > 0.0 Then
s /= If((l <= 0.5), (v + m), (2.0 - v - m))
Else
Return New HSLcolour With {.H = 0, .L = 0, .S = 0}
End If
Dim r2 As Double = (v - r) / vm
Dim g2 As Double = (v - g) / vm
Dim b2 As Double = (v - b) / vm
Dim h As Double = 0
If r = v Then
h = (If(g = m, 5.0 + b2, 1.0 - g2))
ElseIf g = v Then
h = (If(b = m, 1.0 + r2, 3.0 - b2))
Else
h = (If(r = m, 3.0 + g2, 5.0 - r2))
End If
h /= 6.0
Return New HSLcolour With {.H = h, .L = l, .S = s}
End Function
End Class
Then you will need a way of varying the hue, which I have used in this crude example of drawing a bar chart (I put one PictureBox on a Form):
Option Strict On
Option Infer On
Public Class Form1
Dim rand As New Random
Dim data As List(Of Double)
Private Function DoubleModOne(value As Double) As Double
While value > 1.0
value -= 1.0
End While
While value < 0.0
value += 1.0
End While
Return value
End Function
Sub DrawBars(sender As Object, e As PaintEventArgs)
Dim target = DirectCast(sender, PictureBox)
e.Graphics.Clear(Color.DarkGray)
' an approximation of the bar width
'TODO: Improve the approximation.
Dim barWidth As Integer = CInt(CDbl(target.Width) / data.Count)
Dim maxBarHeight = target.Height
Using br As New SolidBrush(Color.Black)
Dim r As Rectangle
'TODO: make it work for Color.Gainsboro
Dim startColour = ColourRepresentation.RGBtoHSL(Color.Fuchsia)
' these components are broken out in case something needs to be done to them.
Dim startColourH = startColour.H
Dim startColourS = startColour.S
Dim startColourL = startColour.L
' Using 1.0 as the quotient makes the colours go through the whole spectrum.
Dim colourInc As Double = 1.0 / data.Count
' Only expects data to be in the range (0, 1).
For i = 0 To data.Count - 1
Dim thisHSLcolour As New ColourRepresentation.HSLcolour With {.H = DoubleModOne(startColourH + i * colourInc), .S = startColourS, .L = startColourL}
br.Color = ColourRepresentation.HSLtoRGB(thisHSLcolour)
r = New Rectangle(CInt(i * barWidth), CInt(data(i) * maxBarHeight), barWidth, maxBarHeight)
e.Graphics.FillRectangle(br, r)
Next
End Using
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Dim nBars = 100
data = New List(Of Double)(nBars)
For i = 0 To nBars - 1
data.Add(rand.NextDouble())
Next
AddHandler PictureBox1.Paint, AddressOf DrawBars
End Sub
End Class
Resulting in:
No-one ever accused me of choosing subtle colours, lol.
During some iterative optimization, the following VBA code for the computation of the bivariate normal CDF sometimes throws an Overflow error on the line with z = hx * hy * c inside the while loop of the upper function.
I debugged the code and the overflow occurs when the numbers being multiplied result in a number bigger than what a double can hold.
Can you show me how to handle the problem by ignoring the iterations of the loop with such high values - I guess that's the only feasible solution (?). I tried myself with a On Error Goto nextiteration line before the multiplication and placing the nextiteration jump point before the Wend, but the error persists.
Function tetrachoric(x As Double, y As Double, rho As Double) As Double
Const FACCURACY As Double = 0.0000000000001
Const MinStopK As Integer = 20
Dim k As Integer
Dim c As Double
Dim z As Double
Dim s As Double
Dim hx As Double
Dim hx1 As Double
Dim hx2 As Double
Dim hy As Double
Dim hy1 As Double
Dim hy2 As Double
Dim CheckPass As Integer
hx = 1
hy = 1
hx1 = 0
hy1 = 0
k = 0
c = rho
z = c
s = z
CheckPass = 0
While CheckPass < MinStopK
k = k + 1
hx2 = hx1
hy2 = hy1
hx1 = hx
hy1 = hy
hx = x * hx1 - (k - 1) * hx2
hy = y * hy1 - (k - 1) * hy2
c = c * rho / (k + 1)
z = hx * hy * c
s = s + z
If Abs(z / s) < FACCURACY Then
CheckPass = CheckPass + 1
Else
CheckPass = 0
End If
Wend
tetrachoric = s
End Function
Public Function bivnor(x As Double, y As Double, rho As Double) As Double
'
' bivnor function
' Calculates bivariat normal CDF F(x,y,rho) for a pair of standard normal
' random variables with correlation RHO
'
If rho = 0 Then
bivnor = Application.WorksheetFunction.NormSDist(x) * _
Application.WorksheetFunction.NormSDist(y)
Else
bivnor = Application.WorksheetFunction.NormSDist(x) * _
Application.WorksheetFunction.NormSDist(y) + _
Application.WorksheetFunction.NormDist(x, 0, 1, False) * _
Application.WorksheetFunction.NormDist(y, 0, 1, False) * _
tetrachoric(x, y, rho)
End If
End Function
Source: Available for download at http://michael.marginalq.com/
you're hitting on the limits of the computer architecture. Many complex algorithms can't be implemented 1:1 with their mathematical representation because of performance reasons and/or erroneous behavior when overflowing. There's an exceptionally good blog about these issues - John D. Cook.
Please take a look here for a better implementation.
You can also try binding an external library, that gives you arbitrary precision number handling, of course implemented using very expensive (in terms of CPU time) software algorithms. More can be found here.
Updated code using On Error Resume Next instead of On Error Goto:
While CheckPass < MinStopK
k = k + 1
hx2 = hx1
hy2 = hy1
hx1 = hx
hy1 = hy
hx = x * hx1 - (k - 1) * hx2
hy = y * hy1 - (k - 1) * hy2
c = c * rho / (k + 1)
On Error Resume Next
z = hx * hy * c
If Err.Number = 0 Then
s = s + z
If Abs(z / s) < FACCURACY Then
CheckPass = CheckPass + 1
Else
CheckPass = 0
End If
Else
Err.Clear
End If
Wend
http://www.codeproject.com/KB/recipes/float_point.aspx treats how to "Use Logarithms to Avoid Overflow and Underflow", which is a simple but quite effective way of working around overflow problems. In fact, it's so simple yet logical, why haven't we thought of that solution ourselves? ;)