I'm trying to calculate distance in kilometers between two geographical coordinates using the haversine formula.
Code:
Dim dbl_dLat As Double
Dim dbl_dLon As Double
Dim dbl_a As Double
dbl_P = WorksheetFunction.Pi / 180
dbl_dLat = dbl_P * (dbl_Latitude2 - dbl_Latitude1)
dbl_dLon = dbl_P * (dbl_Longitude2 - dbl_Longitude1)
dbl_a = Sin(dbl_dLat / 2) * Sin(dbl_dLat / 2) + Cos(dbl_Latitude1 * dbl_P) * Cos(dbl_Latitude2 * dbl_P) * Sin(dbl_dLon / 2) * Sin(dbl_dLon / 2)
dbl_Distance_KM = 6371 * 2 * WorksheetFunction.Atan2(Sqr(dbl_a), Sqr(1 - dbl_a))
I'm testing with these coordinates:
dbl_Longitude1 = 55.629178
dbl_Longitude2 = 29.846686
dbl_Latitude1 = 37.659466
dbl_Latitude2 = 30.24441
And the code returns 20015.09, which is obviously wrong. It should be 642 km according to Yandex maps.
Where am I wrong? Are the longitude and latitude in wrong format?
As far as I can tell, the issue is that the order of arguments to atan2() varies by language. The following works* for me:
Option Explicit
Public Sub Distance()
Dim dbl_Longitude1 As Double, dbl_Longitude2 As Double, dbl_Latitude1 As Double, dbl_Latitude2 As Double
dbl_Longitude1 = 55.629178
dbl_Longitude2 = 29.846686
dbl_Latitude1 = 37.659466
dbl_Latitude2 = 30.24441
Dim dbl_dLat As Double
Dim dbl_dLon As Double
Dim dbl_a As Double
Dim dbl_P As Double
dbl_P = WorksheetFunction.Pi / 180
dbl_dLat = dbl_P * (dbl_Latitude2 - dbl_Latitude1) 'to radians
dbl_dLon = dbl_P * (dbl_Longitude2 - dbl_Longitude1) 'to radians
dbl_a = Sin(dbl_dLat / 2) * Sin(dbl_dLat / 2) + _
Cos(dbl_Latitude1 * dbl_P) * Cos(dbl_Latitude2 * dbl_P) * Sin(dbl_dLon / 2) * Sin(dbl_dLon / 2)
Dim c As Double
Dim dbl_Distance_KM As Double
c = 2 * WorksheetFunction.Atan2(Sqr(1 - dbl_a), Sqr(dbl_a)) ' *** swapped arguments to Atan2
dbl_Distance_KM = 6371 * c
Debug.Print dbl_Distance_KM
End Sub
*Output: 2507.26205401321, although gcmap.com says the answer is 2512 km. This might be a precision issue --- I think it's close enough to count as working. (Edit it might also be that gcmap uses local earth radii rather than the mean radius; I am not sure.)
Explanation
I found this description of the haversine formula for great-circle distance, which is what you are implementing. The JavaScript implementation on that page gives this computation for c:
var c = 2 * Math.atan2(Math.sqrt(a), Math.sqrt(1-a));
In JavaScript, atan2() takes parameters y, x. However, in Excel VBA, WorksheetFunction.Atan2 takes parameters x, y. Your original code passed Sqr(dbl_a) as the first parameter, as it would be in JavaScript. However, Sqr(dbl_a) needs to be the second parameter in Excel VBA.
A comment on naming
Building on #JohnColeman's point, there are lots of ways to name variables. In this case, I would recommend using the prefixes for unit rather than for type: e.g., deg_Latitude1, RadPerDeg = Pi/180, and rad_dLat = RadPerDeg * (deg_Latitude2 - deg_Latitude1). I personally think that helps avoid unit-conversion mishaps.
My VBA code that returns the answer in feet; However 'd' is the answer in kilometers.
Imports System.Math
Module Haversine
Public Function GlobalAddressDistance(sLat1 As String, sLon1 As String, sLat2 As String, sLon2 As String) As String
Const R As Integer = 6371
Const cMetersToFeet As Single = 3.2808399
Const cKiloMetersToMeters As Integer = 1000
Dim a As Double = 0, c As Double = 0, d As Double = 0
'Convert strings to numberic double values
Dim dLat1 As Double = Val(sLat1)
Dim dLat2 As Double = Val(sLat2)
Dim dLatDiff As Double = DegreesToRadians(CDbl(sLat2) - CDbl(sLat1))
Dim dLonDiff As Double = DegreesToRadians(CDbl(sLon2) - CDbl(sLon1))
a = Pow(Sin(dLatDiff / 2), 2) + Cos(DegreesToRadians(dLat1)) * Cos(DegreesToRadians(dLat2)) * Pow(Sin(dLonDiff / 2), 2)
c = 2 * Atan2(Sqrt(a), Sqrt(1 - a))
d = R * c
'Convert kilometers to feet
Return Format((d * cKiloMetersToMeters * cMetersToFeet), "0.##").ToString
End Function
Private Function DegreesToRadians(ByVal dDegrees As Double) As Double
Return (dDegrees * PI) / 180
End Function
End Module
Related
Introduction
I am somewhat new to using Open GL / Open TK. I have learned how to draw basic shapes, use matrices, lighting, shadowing, etc. I have a function that draws a sphere:
Private Sub drawSphere(r As Double, lats As Integer, longs As Integer)
Dim i As Integer, j As Integer
For i = 0 To lats
Dim lat0 As Double = PI * (-0.5 + CDbl(i - 1) / lats)
Dim z0 As Double = Sin(lat0)
Dim zr0 As Double = Cos(lat0)
Dim lat1 As Double = PI * (-0.5 + CDbl(i) / lats)
Dim z1 As Double = Sin(lat1)
Dim zr1 As Double = Cos(lat1)
GL.Begin(PrimitiveType.QuadStrip)
For j = 0 To longs
Dim lng As Double = 2 * PI * CDbl(j - 1) / longs
Dim x As Double = Cos(lng)
Dim y As Double = Sin(lng)
GL.Normal3(x * zr0 * r, y * zr0 * r, z0 * r)
GL.Vertex3(x * zr0 * r, y * zr0 * r, z0 * r)
GL.Normal3(x * zr1 * r, y * zr1 * r, z1 * r)
GL.Vertex3(x * zr1 * r, y * zr1 * r, z1 * r)
Next
GL.End()
Next
End Sub
I have other code that sets up the lights. I know the other code works because I have a separate function for drawing an STL object:
Dim texture As UInteger() = New UInteger(0) {}
Dim i As Integer = 0
If stl_table.Items.Count > 0 Then
find_center_of_part()
GL.Begin(PrimitiveType.Triangles)
GL.Color3(part_color.R, part_color.G, part_color.B)
Do Until i + 4 >= stl_table.Items.Count
GL.Normal3(Convert.ToSingle(stl_table.Items.Item(i).SubItems(0).Text), Convert.ToSingle(stl_table.Items.Item(i).SubItems(1).Text), Convert.ToSingle(stl_table.Items.Item(i).SubItems(2).Text))
GL.Vertex3(stl_table.Items.Item(i + 1).SubItems(0).Text - avgx, stl_table.Items.Item(i + 1).SubItems(1).Text - avgy, stl_table.Items.Item(i + 1).SubItems(2).Text - avgz)
GL.Vertex3(stl_table.Items.Item(i + 2).SubItems(0).Text - avgx, stl_table.Items.Item(i + 2).SubItems(1).Text - avgy, stl_table.Items.Item(i + 2).SubItems(2).Text - avgz)
GL.Vertex3(stl_table.Items.Item(i + 3).SubItems(0).Text - avgx, stl_table.Items.Item(i + 3).SubItems(1).Text - avgy, stl_table.Items.Item(i + 3).SubItems(2).Text - avgz)
i = i + 4
Loop
GL.End()
End If
This second function basically imports a CAD STL file and draws it as triangles. The normal vectors are simply an input from the CAD file (so they are already computed). This method's lighting works perfectly fine which makes me know my lighting code is correct.
Problem
The problem is that my sphere is not getting light correctly. I know through testing that this is due to my normal vectors.
With the current code, my sphere looks like this:
There is a "spot" of light which makes me think that is simply one of the quadstrips having the normal correct.
Does anybody have any suggestions on setting up the normal vectors correctly inside my function? Also before anybody suggests it, I can't use GLU or GLUT for what I am trying to accomplish, which is why I need the sphere function.
I'm taking apart a very old spreadsheet I wrote and trying to put it back together using VBA. So far I've this, which seems to work:
Sub PipeData()
Dim FlowRate As Single
Dim Density As Single
Dim DynamicViscosity As Single
Dim PipeSize As Single
Dim Pi As Single
Dim ReynoldsNumber As Single
Dim Lamda As Single
Dim EquivalentRoughness As Single
Dim RelativeRoughness As Single
Dim Velocity As Single
Dim PressureDrop As Single
Density = 977.8
DynamicViscosity = 0.0004
PipeSize = 36.1
Pi = WorksheetFunction.Pi()
EquivalentRoughness = 0.046
RelativeRoughness = EquivalentRoughness / PipeSize
FlowRate = Cells(2, 7)
ReynoldsNumber = (4 * FlowRate) / (DynamicViscosity * Pi * (PipeSize / 1000))
If ReynoldsNumber < 2000 Then
Lamda = 64 / ReynoldsNumber
Else
Lamda = ((1 / (-1.8 * WorksheetFunction.Log((6.9 / ReynoldsNumber) + ((RelativeRoughness / 3.71) ^ 1.11)))) ^ 2)
End If
Velocity = ((4 * FlowRate) / (Pi * Density * ((PipeSize / 1000) ^ 2)))
PressureDrop = ((Lamda * Density) * (Velocity ^ 2)) / (2 * (PipeSize / 1000))
End Sub
Some of the constants listed here (for example density, pipe size, etc.) I eventually intend to read from a worksheet or automatically calculate but for now I'm proceeding one step at a time.
Now that I'm satisfied that this works, which I've checked by outputting the numbers generated, I want to use Goal Seek to find the flow rate value at a certain pre-defined flow rate.
So what I want to do is have VBA cycle through different flow rate values until the desired pressure drop value is reached. I will tell VBA the desired pressure drop in a cell in the Excel sheet. I want this calculation to exist entirely inside VBA without any worksheet formulas.
So I've got, in very simplified terms, the following:
(1) A starting flow rate (I guess this should be defined in the VBA code otherwise Goal Seek won't have a starting point)
(2) Some calculations
(3) A resulting pressure drop.
(4) If the resulting pressure drop is not equal to a pre-defined value (located in cell G3) the flow rate value in (1) should be adjusted and the calculations run again.
(5) When the resulting pressure drop equals the pre-defined value tell me what the flow rate value used to calculate this is.
Any ideas?
OK, I took a crack at this..there may be a better way and this assumes a direct relationship (not inverse)..i moved some of your variables into constants and put the pressure calc in a function, and changed data types to double. It is a UDF with you can use in the worksheet.
Const Density As Double = 977.8
Const DynamicViscosity As Double = 0.0004
Const PipeSize As Double = 36.1
Const Pi As Double = 3.14159265358979
Const EquivalentRoughness As Double = 0.046
Const RelativeRoughness As Double = EquivalentRoughness / PipeSize
Const Sig As Double = 0.0000000001 'this indicates how accurate you want your answer
Dim FlowRate As Double
Dim ReynoldsNumber As Double
Dim Lamda As Double
Dim Velocity As Double
Function PipeData(IdealPressureDrop As Long)
FlowRate = 1000 + Sig
Stepper = 100
If PressureDrop(FlowRate) > IdealPressureDrop Then
FlowRateGoal = GoalSeek(FlowRate, Stepper, -1, IdealPressureDrop)
Else
FlowRateGoal = GoalSeek(FlowRate, Stepper, 1, IdealPressureDrop)
End If
PipeData = FlowRateGoal
End Function
Function GoalSeek(FlowRate, Stepper, Direction, IdealPressureDrop)
calcagain:
Select Case Direction
Case 1
Do While PressureDrop(FlowRate) < IdealPressureDrop
oFR = FlowRate
FlowRate = FlowRate + Stepper
Loop
Case -1
Do While PressureDrop(FlowRate) > IdealPressureDrop
oFR = FlowRate
FlowRate = FlowRate - Stepper
Loop
End Select
Stepper = Stepper / 10
If Stepper < Sig Then GoTo getout
FlowRate = oFR
GoTo calcagain
getout:
GoalSeek = FlowRate
End Function
Function PressureDrop(FlowRate)
ReynoldsNumber = (4 * FlowRate) / (DynamicViscosity * Pi * (PipeSize / 1000))
If ReynoldsNumber < 2000 Then
Lamda = 64 / ReynoldsNumber
Else
Lamda = ((1 / (-1.8 * WorksheetFunction.Log((6.9 / ReynoldsNumber) + ((RelativeRoughness / 3.71) ^ 1.11)))) ^ 2)
End If
Velocity = ((4 * FlowRate) / (Pi * Density * ((PipeSize / 1000) ^ 2)))
PressureDrop = ((Lamda * Density) * (Velocity ^ 2)) / (2 * (PipeSize / 1000))
End Function
This can now be referenced in the worksheet with
=PipeData(A3)
Where "A3" is your ideal pressure drop number
I am trying a fairly simple function to calculate an exponentially weighted moving average volatility in Excel VBA, following. However, I think there is some error in my function that I can't pinpoint, because I don't get the correct solution.
Function EWMA(numbers As Range, Lambda As Single) As Double
Dim mean As Double
Dim x As Double
Dim c As Range
Dim n As Integer
mean = WorksheetFunction.Average(numbers)
n = WorksheetFunction.Count(numbers)
For Each c In numbers
x = x + (Lambda ^ (n - c.Count)) * ((c.Value - mean) ^ 2)
Next c
EWMA = (1 - Lambda) * x
End Function
The values I am using and the target volatility (calculated using a spreadsheet EWMA) are here.
What am I doing wrong?
Update: using Ron Rosenfeld's solution:
Option Explicit
Function EWMA(Zero As Range, Lambda As Double) As Double
Dim vZero As Variant
Dim SumWtdRtn As Double
Dim I As Long
Dim vPrices As Variant
Dim LogRtn As Double, RtnSQ As Double, WT As Double, WtdRtn As Double
vZero = Zero
For I = 2 To UBound(vZero, 1)
vPrices = 1 / ((1 + vZero(I, 1)) ^ (3 / 12))
LogRtn = Log(vPrices(I - 1, 1) / vPrices(I, 1))
RtnSQ = LogRtn ^ 2
WT = (1 - Lambda) * Lambda ^ (I - 2)
WtdRtn = WT * RtnSQ
SumWtdRtn = SumWtdRtn + WtdRtn
Next I
EWMA = SumWtdRtn ^ (1 / 2)
End Function
Here's a little bit different way of doing it as a VBA function. The inputs are an array of prices, which is assumed to be in descending order as you show, and Lambda. Hopefully, the names of the variables will let you see the logic:
Option Explicit
Function EWMA2(Prices As Range, Lambda As Double) As Double
Dim vPrices As Variant
Dim dSumWtdRtn As Double
Dim I As Long
Dim dLogRtn As Double, dRtnSQ As Double, dWT As Double, dWtdRtn As Double
vPrices = Prices
For I = 2 To UBound(vPrices, 1)
dLogRtn = Log(vPrices(I - 1, 1) / vPrices(I, 1))
dRtnSQ = dLogRtn ^ 2
dWT = (1 - Lambda) * Lambda ^ (I - 2)
dWtdRtn = dWT * dRtnSQ
dSumWtdRtn = dSumWtdRtn + dWtdRtn
Next I
EWMA2 = dSumWtdRtn ^ (1 / 2)
End Function
With your data, it gives the same results as the spreadsheet calculation (within the limits of precision of the data types)
EDIT
If you want to input the 3M CAD Zero Rates as the range input, and not the pricing, then you could modify the above to compute the two relevant prices from the returns data. In this case, it would be:
Option Explicit
Function EWMAV(Zeros As Range, Lambda As Double) As Double
Dim vZeros() As Variant
Dim dPrice1 As Double, dPrice2 As Double
Dim dSumWtdRtn As Double
Dim I As Long
Dim dLogRtn As Double, dRtnSQ As Double, dWT As Double, dWtdRtn As Double
vZeros = Zeros
For I = 2 To UBound(vZeros, 1)
dPrice1 = 1 / ((1 + vZeros(I - 1, 1)) ^ (3 / 12))
dPrice2 = 1 / ((1 + vZeros(I, 1)) ^ (3 / 12))
dLogRtn = Log(dPrice1 / dPrice2)
dRtnSQ = dLogRtn ^ 2
dWT = (1 - Lambda) * Lambda ^ (I - 2)
dWtdRtn = dWT * dRtnSQ
dSumWtdRtn = dSumWtdRtn + dWtdRtn
Next I
EWMAV = dSumWtdRtn ^ (1 / 2)
End Function
When I generate random numbers, I sometimes get (not always) the following error:
Run-time error '13': type mismatch.
on line Z = Sqr(time) * Application.NormSInv(Rnd()) (and the end of the second for loop).
Why do I get this error?
I think it has something to do with the fact that it contains Rnd().
Sub asiancall()
'defining variables
Dim spot As Double
Dim phi As Integer
Dim rd_cont As Double
Dim rf_cont As Double
Dim lambda As Double
Dim muY As Double
Dim sigmaY As Double
Dim vol As Double
Dim implied_vol As Double
Dim spotnext As Double
Dim time As Double
Dim sum As Double
Dim i As Long
Dim mean As Double
Dim payoff_mean As Double
Dim StDev As Double
Dim K As Double
Dim Egamma0 As Double
Dim mulTv As Double
Dim prod As Double
Dim U As Double
Dim Pois As Double
Dim Q As Double
Dim Z As Long
Dim gamma As Double
Dim payoff As Double
Dim payoff_sum As Double
Dim secondmoment As Double
Dim j As Long
Dim N As Long
Dim mu As Double
Dim sum1 As Double
'read input data
spot = Range("B3")
rd_cont = Range("C5")
rf_cont = Range("C4")
muY = Range("B17")
sigmaY = Range("B18")
lambda = Range("B16")
K = Range("F33")
implied_vol = Range("F35")
N = Range("F34")
vol = Range("B6")
'calculations
sum_BS = 0
payoff_BS = 0
mean_BS = 0
secondmoment_BS = 0
For j = 1 To N
spotnext = spot
spotnext_BS = spot
time = 0
sum1 = 0
time = 184 / (360 * 6)
For i = 1 To 6
' 'Merton uitvoeren
Egamma0 = Exp(muY + sigmaY * sigmaY * 0.5) - 1
mu = rd_cont - rf_cont
mulTv = (mu - lambda * Egamma0 - implied_vol * implied_vol * 0.5) * time
sum = 0
prod = 1
Do While sum <= time
U = Rnd()
Pois = -Log(U) / lambda
sum = sum + Pois
Q = Application.NormInv(Rnd(), muY, sigmaY)
gamma = Exp(Q) - 1
prod = prod * (1 + gamma)
Loop
prod = prod / (1 + gamma)
Z = Sqr(time) * Application.NormSInv(Rnd())
spotnext = spotnext * Exp(mulTv + implied_vol * Z) * prod
sum1 = sum1 + spotnext
Next i
mean = sum1 / 6
payoff = Application.Max(mean - K, 0)
payoff_sum = payoff_sum + payoff
secondmoment = secondmoment + payoff * payoff
Next j
Following up on the community wiki answer I posted, a possible solution is this:
Function RndExcludingZero()
Do
RndExcludingZero = Rnd()
Loop While RndExcludingZero = 0
End Function
Usage:
Z = Sqr(time) * Application.NormSInv(RndExcludingZero())
Rnd() returns values >=0 and <1.
At some point it is bound to return 0. When given 0 as input in Excel, NormSInv returns the #NUM!
Excel error.* When called in VBA via Application.NormSInv(0), it returns a Variant of subtype Error with value "Error 2036" (equivalent to the #NUM! Excel error).
Such Variant/Errors cannot be implicitly coerced to a numerical value (which is what the * operator expects) and thus in this case, you will get the type mismatch error.
You will only get this error when Rnd() happens to return 0, which is consistent with your observation that the error occurs only sometimes.
* This was first remarked by user3964075 in a now defunct comment to the question.
I am trying to implement a 2D Perlin Noise in VB.Net. I've spent the whole day searching for sources that explain the subject and one of the most notable was this article by Hugo Elias
Most of the implementation went well. On the exception of a very important part that did not seem to work in VB.Net, causing overflows.
function Noise1(integer x, integer y)
n = x + y * 57
n = (n<<13) ^ n;
return ( 1.0 - ( (n * (n * n * 15731 + 789221) + 1376312589) & 7fffffff) / 1073741824.0);
end function
In VB.net I translated it to
Private Function Noise(tX As Integer, tY As Integer) As Double
'Return a double between -1 & 1 according to a fixed random seed
Dim n As Integer = tX + tY * 57
n = (n << 13) Xor n
Return (1.0 - ((n * (n * n * 15731 + 789221) + BaseSeed) And &H7FFFFFFF) / 1073741824.0)
End Function
Which cause overflows.
Since the idea seem to be to simply generate a fractional number between -1 and 1. I've made this little function which create a Integer Number based on the coordinates and BaseSeed. BaseSeed(999999) being the base for every noise I'll create in this particular part of my game.
Private Function Noise(tX As Integer, tY As Integer) As Double
Dim tSeed As Integer
tSeed = WrapInteger(789221, BaseSeed, (tX * 1087) + (tY * 2749))
RandomGenerator = New Random(tSeed)
Return (RandomGenerator.Next(-10000, 10001) / 10000)
End Function
WrapInteger simply makes sure that the number will always be in the range of an integer, to avoid overflow errors.
Public Function WrapInteger(ByVal Lenght As Integer, ByVal Position As Integer, ByVal Movement As Integer) As Integer
Lenght += 1
Return ((Position + Movement) + (Lenght * ((Abs(Movement) \ Lenght) + 1))) Mod Lenght
End Function
When I fire it up with a Persistence of 0.25, 6 Octaves and a starting frequency of 2. this is what I get. This is a 128x128 pixel bitmap that I scaled.
Result
Anyone have an idea of why it would be so linear? When I look at this picture I have the feeling that it's not far from the truth, as if it only worked in 1D. All suposition.
Below you will find my entire PerlinNoise Class. I think the rest of it is just fine, but I added it for reference purpose. Beside, I haven't been able to find a single VB implementation of Perlin Noise on the internet. So I guess if I can fix this one, it might help others. There seem to be alot of question about Perlin noise malfunction on StackOverflow
Public Class cdPerlinNoise
Private RandomGenerator As Random
Private BaseSeed As Integer
Private Persistence As Double
Private Frequency As Integer
Private Octaves As Integer
Public Sub New(tSeed As Integer, tPersistence As Double, tOctaves As Integer, tFrequency As Integer)
Frequency = tFrequency
BaseSeed = tSeed
Persistence = tPersistence
Octaves = tOctaves
End Sub
Private Function Noise(tX As Integer, tY As Integer) As Double
Dim tSeed As Integer
tSeed = WrapInteger(789221, BaseSeed, (tX * 1087) + (tY * 2749))
RandomGenerator = New Random(tSeed)
Return (RandomGenerator.Next(-10000, 10001) / 10000)
End Function
Private Function SmoothNoise(tX As Integer, tY As Integer) As Double
Dim Corners As Double = (Noise(tX - 1, tY - 1) + Noise(tX + 1, tY - 1) + Noise(tX - 1, tY + 1) + Noise(tX + 1, tY + 1)) / 16
Dim Sides As Double = (Noise(tX - 1, tY) + Noise(tX + 1, tY) + Noise(tX, tY - 1) + Noise(tX, tY + 1)) / 8
Return (Noise(tX, tY) / 4) + Corners + Sides
End Function
Private Function InterpolateCosine(tA As Double, tB As Double, tX As Double) As Double
Dim f As Double = (1 - Cos(tX * 3.1415927)) * 0.5
Return tA * (1 - f) + tB * f
End Function
Private Function Interpolate2D(tX As Double, tY As Double) As Double
Dim WholeX As Integer = CInt(Fix(tX))
Dim RemainsX As Double = tX - WholeX
Dim WholeY As Integer = CInt(Fix(tY))
Dim RemainsY As Double = tY - WholeY
Dim v1 As Double = SmoothNoise(WholeX, WholeY)
Dim v2 As Double = SmoothNoise(WholeX + 1, WholeY)
Dim v3 As Double = SmoothNoise(WholeX, WholeY + 1)
Dim v4 As Double = SmoothNoise(WholeX + 1, WholeY + 1)
Dim i1 As Double = InterpolateCosine(v1, v2, RemainsX)
Dim i2 As Double = InterpolateCosine(v3, v4, RemainsX)
Return InterpolateCosine(i1, i2, RemainsY)
End Function
Public Function PerlinValue(tX As Double, tY As Double) As Double
Dim Total As Double = 0
Dim Frequency As Double
Dim Amplitude As Double
For i = 0 To Octaves - 1
Frequency = Frequency ^ i
Amplitude = Persistence ^ i
Total = Total + (Interpolate2D(tX * Frequency, tY * Frequency) * Amplitude)
Next
Return Total
End Function
Public Function ScaleNoise(ByVal tX As Double, ByVal tY As Double, ByVal OutputLow As Double, ByVal OutputHigh As Double) As Double
Dim Range1 As Double
Dim Range2 As Double
Dim Result As Double
Range1 = 1 - -1
Range2 = OutputHigh - OutputLow
'(B*C - A*D)/R1 + n1*(R2/R1)
Result = (((1 * OutputLow) - (-1 * OutputHigh)) / Range1) + ((PerlinValue(tX, tY) * (Range2 / Range1)))
If Result < OutputLow Then
Return OutputLow
ElseIf Result > OutputHigh Then
Return OutputHigh
Else
Return Result
End If
End Function
End Class