In the following project euler program #56, Considering natural numbers of the form, a^b, where a, b < 100, what is the maximum digital sum?
so I wrote the following code:
Dim num As System.Numerics.BigInteger
Dim s As String
Dim sum As Integer
Dim record As Integer
For a = 2 To 99
For b = 1 To 99
num = a ^ b
s = num.ToString
For i = 0 To s.Length - 1
sum += CInt(s.Substring(i, 1))
Next
sum = 0
Next
Next
The answer I got from the program was not the correct answer, so I wrote the following code so I can see what numbers set a new high value and see if something is wrong.
If sum > record Then
record = sum
Console.WriteLine(a & "," & b)
End If
One of the answers was a=10 b= 81. Obviously that doesn't make sense, because that value is 1 + 81 "0" = 1, but watching the result of 10^81, was 999999999999999921281879895665782741935503249059183851809998224123064148429897728
I searched about the accuracy of BigInteger but couldn't find anything, is there something that I'm missing?
Related
I am trying to write a code which has multiple For and If loops. I will try to explain the problem first where the dataset I have is like the following in column 'AH':
0,0,0,0,1,1,2,2,2,2,2,2,1,1,1,0,0,0,0,0,2,2,2,2,2,0,0,..... where the number of 0s, 1s and 2s in a stretch is unknown. What I am trying to find the number of cycles, where a cycle is defined when there has to be atleast 3 0s in a stretch and then has to be atleast 4 2s consecutively. So, to do that, I wrote the code in the following format
Dim M As Single: Dim Count As Integer: Dim A As Integer: Dim B As Integer
M = 2: Count = 0: A =3: B=4
Dim temp As Integer: Dim temp1 As Integer: temp = 0
For L = M To 50
Sheets("Sheet1").Range("AJ" & M) = M
temp = 0
For L1 = L To L + A
temp = temp + Sheets("Sheet1").Range("AH" & L1)
Next L1
If temp = 0 Then
N = L + A
For N1 = N To 60
If Sheets("Sheet1").Range("AH" & N1) = 2 Then
temp1 = 0
For I1 = N1 To N1 + B
temp1 = temp1 + Sheets("Sheet1").Range("AH" & I1)
Next I1
If temp1 = 2 * B Then
flg = True
Exit For
End If
End If
Next N1
Count = Count + 1: M = I1
Sheets("Sheet1").Range("AJ2") = Count
If flg = True Then Exit For
End If
M = M + 1
Next L
Basically, what I am trying to do is find the first 0 and count the sum of 3 consecutive values. If it is 0, then I am searching for 2. When the first 2 is found, it will add up the next 4 terms and if the sum is equal to 2*4, then I will update the count and the code should start look for 0. However, using the 'Exit For' puts me out of all the loops. And if I don't put Exit, then it keep counting the 2s for more times. I am new to VBA and struck with this problem for a long time. Any help on this will be greatly appreciated. Thank you in advance.
I have a set which has an unknown number of objects. I want to associate a label to each one of these objects. Instead of labeling each object with a number I want to label them with letters.
For example the first object would be labeled A the second B and so on.
When I get to Z, the next object would be labeled AA
AZ? then BA, BB, BC.
ZZ? then AAA, AAB, AAC and so on.
I'm working using Mapbasic (similar to VBA), but I can't seem to wrap my head around a dynamic solution. My solution assumes that there will be a max number of objects that the set may or may not exceed.
label = pos1 & pos2
Once pos2 reaches ASCII "Z" then pos1 will be "A" and pos2 will be "A". However, if there is another object after "ZZ" this will fail.
How do I overcome this static solution?
Basically what I needed was a Base 26 Counter. The function takes a parameter like "A" or "AAA" and determines the next letter in the sequence.
Function IncrementAlpha(ByVal alpha As String) As String
Dim N As Integer
Dim num As Integer
Dim str As String
Do While Len(alpha)
num = num * 26 + (Asc(alpha) - Asc("A") + 1)
alpha = Mid$(alpha, 2,1)
Loop
N = num + 1
Do While N > 0
str = Chr$(Asc("A") + (N - 1) Mod 26) & str
N = (N - 1) \ 26
Loop
IncrementAlpha = str
End Function
If we need to convert numbers to a "letter format" where:
1 = A
26 = Z
27 = AA
702 = ZZ
703 = AAA etc
...and it needs to be in Excel VBA, then we're in luck. Excel's columns are "numbered" the same way!
Function numToLetters(num As Integer) As String
numToLetters = Split(Cells(1, num).Address(, 0), "$")(0)
End Function
Pass this function a number between 1 and 16384 and it will return a string between A and XFD.
Edit:
I guess I misread; you're not using Excel. If you're using VBA you should still be able to do this will the help of an reference to an Excel Object Library.
This should get you going in terms of the logic. Haven't tested it completely, but you should be able to work from here.
Public Function GenerateLabel(ByVal Number As Long) As String
Const TOKENS As String = "ZABCDEFGHIJKLMNOPQRSTUVWXY"
Dim i As Long
Dim j As Long
Dim Prev As String
j = 1
Prev = ""
Do While Number > 0
i = (Number Mod 26) + 1
GenerateLabel = Prev & Mid(TOKENS, i, 1)
Number = Number - 26
If j > 0 Then Prev = Mid(TOKENS, j + 1, 1)
j = j + Abs(Number Mod 26 = 0)
Loop
End Function
I'm trying to write a simple function in VBA that will test a real value and output a string result if it's a perfect cube. Here's my code:
Function PerfectCubeTest(x as Double)
If (x) ^ (1 / 3) = Int(x) Then
PerfectCubeTest = "Perfect"
Else
PerfectCubeTest = "Flawed"
End If
End Function
As you can see, I'm using a simple if statement to test if the cube root of a value is equal to its integer portion (i.e. no remainder). I tried testing the function with some perfect cubes (1, 8, 27, 64, 125), but it only works for the number 1. Any other value spits out the "Flawed" case. Any idea what's wrong here?
You are testing whether the cube is equal to the double supplied.
So for 8 you would be testing whether 2 = 8.
EDIT: Also found a floating point issue. To resolve we will round the decimals a little to try and overcome the issue.
Change to the following:
Function PerfectCubeTest(x As Double)
If Round((x) ^ (1 / 3), 10) = Round((x) ^ (1 / 3), 0) Then
PerfectCubeTest = "Perfect"
Else
PerfectCubeTest = "Flawed"
End If
End Function
Or (Thanks to Ron)
Function PerfectCubeTest(x As Double)
If CDec(x ^ (1 / 3)) = Int(CDec(x ^ (1 / 3))) Then
PerfectCubeTest = "Perfect"
Else
PerfectCubeTest = "Flawed"
End If
End Function
#ScottCraner correctly explains why you were getting incorrect results, but there are a couple other things to point out here. First, I'm assuming that you are taking a Double as input because the range of acceptable numbers is higher. However, by your implied definition of a perfect cube only numbers with an integer cube root (i.e. it would exclude 3.375) need to be evaluated. I'd just test for this up front to allow an early exit.
The next issue you run into is that 1 / 3 can't be represented exactly by a Double. Since you're raising to the inverse power to get your cube root you're also compounding the floating point error. There's a really easy way to avoid this - take the cube root, cube it, and see if it matches the input. You get around the rest of the floating point errors by going back to your definition of a perfect cube as an integer value - just round the cube root to both the next higher and next lower integer before you re-cube it:
Public Function IsPerfectCube(test As Double) As Boolean
'By your definition, no non-integer can be a perfect cube.
Dim rounded As Double
rounded = Fix(test)
If rounded <> test Then Exit Function
Dim cubeRoot As Double
cubeRoot = rounded ^ (1 / 3)
'Round both ways, then test the cube for equity.
If Fix(cubeRoot) ^ 3 = rounded Then
IsPerfectCube = True
ElseIf (Fix(cubeRoot) + 1) ^ 3 = rounded Then
IsPerfectCube = True
End If
End Function
This returned the correct result up to 1E+27 (1 billion cubed) when I tested it. I stopped going higher at that point because the test was taking so long to run and by that point you're probably outside of the range that you would reasonably need it to be accurate.
For fun, here is an implementation of a number-theory based method described here . It defines a Boolean-valued (rather than string-valued) function called PerfectCube() that tests if an integer input (represented as a Long) is a perfect cube. It first runs a quick test which throws away many numbers. If the quick test fails to classify it, it invokes a factoring-based method. Factor the number and check if the multiplicity of each prime factor is a multiple of 3. I could probably optimize this stage by not bothering to find the complete factorization when a bad factor is found, but I had a VBA factoring algorithm already lying around:
Function DigitalRoot(n As Long) As Long
'assumes that n >= 0
Dim sum As Long, digits As String, i As Long
If n < 10 Then
DigitalRoot = n
Exit Function
Else
digits = Trim(Str(n))
For i = 1 To Len(digits)
sum = sum + Mid(digits, i, 1)
Next i
DigitalRoot = DigitalRoot(sum)
End If
End Function
Sub HelperFactor(ByVal n As Long, ByVal p As Long, factors As Collection)
'Takes a passed collection and adds to it an array of the form
'(q,k) where q >= p is the smallest prime divisor of n
'p is assumed to be odd
'The function is called in such a way that
'the first divisor found is automatically prime
Dim q As Long, k As Long
q = p
Do While q <= Sqr(n)
If n Mod q = 0 Then
k = 1
Do While n Mod q ^ k = 0
k = k + 1
Loop
k = k - 1 'went 1 step too far
factors.Add Array(q, k)
n = n / q ^ k
If n > 1 Then HelperFactor n, q + 2, factors
Exit Sub
End If
q = q + 2
Loop
'if we get here then n is prime - add it as a factor
factors.Add Array(n, 1)
End Sub
Function factor(ByVal n As Long) As Collection
Dim factors As New Collection
Dim k As Long
Do While n Mod 2 ^ k = 0
k = k + 1
Loop
k = k - 1
If k > 0 Then
n = n / 2 ^ k
factors.Add Array(2, k)
End If
If n > 1 Then HelperFactor n, 3, factors
Set factor = factors
End Function
Function PerfectCubeByFactors(n As Long) As Boolean
Dim factors As Collection
Dim f As Variant
Set factors = factor(n)
For Each f In factors
If f(1) Mod 3 > 0 Then
PerfectCubeByFactors = False
Exit Function
End If
Next f
'if we get here:
PerfectCubeByFactors = True
End Function
Function PerfectCube(n As Long) As Boolean
Dim d As Long
d = DigitalRoot(n)
If d = 0 Or d = 1 Or d = 8 Or d = 9 Then
PerfectCube = PerfectCubeByFactors(n)
Else
PerfectCube = False
End If
End Function
Fixed the integer division error thanks to #Comintern. Seems to be correct up to 208064 ^ 3 - 2
Function isPerfectCube(n As Double) As Boolean
n = Abs(n)
isPerfectCube = n = Int(n ^ (1 / 3) - (n > 27)) ^ 3
End Function
I'm working on a scorecard at work which has columns representing 4 possible outcomes, for example:
Successful,
unsuccessful,
Exceptional,
Other
Each staff member is assessed 5 times in the month against those ratings. So 1 person might have 3 successful, 2 exceptional, 0 unsuccessful, 0 other.
So the max instances of each outcome is 5 but the total sum of instances can't be more than 5.
I could try to type out all the combinations (and get them wrong) - is there any function/formula/VBA that anyone knows of that will list out all of the possible combinations of outcomes for me?
e.g. 5000,4100,4010,4001,3200,3020,3002,3110,3011, etc...
Since your numbers can range from 0005 to 5000, you could just write a simple loop that tests each number to see if the digits total 5:
Sub GetPermutations()
Dim i As Long
For i = 5 To 5000
If SumDigits(i) = 5 Then Debug.Print Format$(i, "0000")
Next
End Sub
Function SumDigits(s As Variant) As Long
Dim i As Long
For i = 1 To Len(s)
SumDigits = SumDigits + CLng(Mid$(s, i, 1))
Next
End Function
Alternatively:
Dim w As Long, x As Long, y As Long, z As Long
For w = 0 To 5
For x = 0 To 5
For y = 0 To 5
For z = 0 To 5
If w + x + y + z = 5 Then Debug.Print w & x & y & z
Next
Next
Next
Next
c#:
// numbering 1 to 4 - i.e.
// 1 sucessful, 2 unsucessful, 3 exception, 4 other
for(int i=1;i<4;i++)
{
for(int n=1;n<4;n++)
{
for(int d=1;d<4;d++)
{
for(int q=1;q<4;q++)
{
if(i+d+n+q<=5)
Console.WriteLine(i+n+d+q+", ");
}
}
}
}
EDIT: just saw you asked for vba:
For number1 As Integer = 1 To 4 Step 1
For number2 As Integer = 1 To 4 Step 1
For number3 As Integer = 1 To 4 Step 1
For number4 As Integer = 1 To 4 Step 1
if(number1+number2+number3+number4<=5) Then
Debug.WriteLine(number1.ToString & number2.toString &number3.toString &number4.ToString & ",");
End If
Next number4
Next number3
Next number2
Next number1
The most simple solution I could think of, there's probably better though.
Thanks for your help everyone - i managed to use a combination of suggestions by starting with the number 1, auto-filling down to 5000, then "text to columns", fixed width to separate the digits, sum to 5, filter and hey presto! Seems to have produced the right number of possible combinations adding up to 5.
Thanks again for your help!
I am banging my head against the wall for a while now trying different techniques.
None of them are working well.
I have two strings.
I need to compare them and get an exact percentage of match,
ie. "four score and seven years ago" TO "for scor and sevn yeres ago"
Well, I first started by comparing every word to every word, tracking every hit, and percentage = count \ numOfWords. Nope, didn't take into account misspelled words.
("four" <> "for" even though it is close)
Then I started by trying to compare every char in each char, incrementing the string char if not a match (to count for misspellings). But, I would get false hits because the first string could have every char in the second but not in the exact order of the second. ("stuff avail" <> "stu vail" (but it would come back as such, low percentage, but a hit. 9 \ 11 = 81%))
SO, I then tried comparing PAIRS of chars in each string. If string1[i] = string2[k] AND string1[i+1] = string2[k+1], increment the count, and increment the "k" when it doesn't match (to track mispellings. "for" and "four" should come back with a 75% hit.) That doesn't seem to work either. It is getting closer, but even with an exact match it is only returns 94%. And then it really gets screwed up when something is really misspelled. (Code at the bottom)
Any ideas or directions to go?
Code
count = 0
j = 0
k = 0
While j < strTempName.Length - 2 And k < strTempFile.Length - 2
' To ignore non letters or digits '
If Not strTempName(j).IsLetter(strTempName(j)) Then
j += 1
End If
' To ignore non letters or digits '
If Not strTempFile(k).IsLetter(strTempFile(k)) Then
k += 1
End If
' compare pair of chars '
While (strTempName(j) <> strTempFile(k) And _
strTempName(j + 1) <> strTempFile(k + 1) And _
k < strTempFile.Length - 2)
k += 1
End While
count += 1
j += 1
k += 1
End While
perc = count / (strTempName.Length - 1)
Edit: I have been doing some research and I think I initially found the code from here and translated it to vbnet years ago. It uses the Levenshtein string matching algorithm.
Here is the code I use for that, hope it helps:
Sub Main()
Dim string1 As String = "four score and seven years ago"
Dim string2 As String = "for scor and sevn yeres ago"
Dim similarity As Single =
GetSimilarity(string1, string2)
' RESULT : 0.8
End Sub
Public Function GetSimilarity(string1 As String, string2 As String) As Single
Dim dis As Single = ComputeDistance(string1, string2)
Dim maxLen As Single = string1.Length
If maxLen < string2.Length Then
maxLen = string2.Length
End If
If maxLen = 0.0F Then
Return 1.0F
Else
Return 1.0F - dis / maxLen
End If
End Function
Private Function ComputeDistance(s As String, t As String) As Integer
Dim n As Integer = s.Length
Dim m As Integer = t.Length
Dim distance As Integer(,) = New Integer(n, m) {}
' matrix
Dim cost As Integer = 0
If n = 0 Then
Return m
End If
If m = 0 Then
Return n
End If
'init1
Dim i As Integer = 0
While i <= n
distance(i, 0) = System.Math.Max(System.Threading.Interlocked.Increment(i), i - 1)
End While
Dim j As Integer = 0
While j <= m
distance(0, j) = System.Math.Max(System.Threading.Interlocked.Increment(j), j - 1)
End While
'find min distance
For i = 1 To n
For j = 1 To m
cost = (If(t.Substring(j - 1, 1) = s.Substring(i - 1, 1), 0, 1))
distance(i, j) = Math.Min(distance(i - 1, j) + 1, Math.Min(distance(i, j - 1) + 1, distance(i - 1, j - 1) + cost))
Next
Next
Return distance(n, m)
End Function
Did not work for me unless one (or both) of following are done:
1) use option compare statement "Option Compare Text" before any Import declarations and before Class definition (i.e. the very, very first line)
2) convert both strings to lowercase using .tolower
Xavier's code must be correct to:
While i <= n
distance(i, 0) = System.Math.Min(System.Threading.Interlocked.Increment(i), i - 1)
End While
Dim j As Integer = 0
While j <= m
distance(0, j) = System.Math.Min(System.Threading.Interlocked.Increment(j), j - 1)
End While