User:Klever: Difference between revisions
No edit summary |
|||
Line 115: | Line 115: | ||
128 |
128 |
||
</pre> |
</pre> |
||
==[[Look-and-say sequence]]== |
|||
<lang> |
|||
Public Sub LookAndSay(Optional Niter As Integer = 10) |
|||
'generate "Niter" members of the look-and-say sequence |
|||
'(argument is optional; default is 10) |
|||
Dim s As String 'look-and-say number |
|||
Dim news As String 'next number in sequence |
|||
Dim curdigit As String 'current digit in s |
|||
Dim newdigit As String 'next digit in s |
|||
Dim curlength As Integer 'length of current run |
|||
Dim p As Integer 'position in s |
|||
Dim L As Integer 'length of s |
|||
On Error GoTo Oops |
|||
'start with "1" |
|||
s = "1" |
|||
For i = 1 To Niter |
|||
'initialise |
|||
L = Len(s) |
|||
p = 1 |
|||
curdigit = Left$(s, 1) |
|||
curlength = 1 |
|||
news = "" |
|||
For p = 2 To L |
|||
'check next digit in s |
|||
newdigit = Mid$(s, p, 1) |
|||
If curdigit = newdigit Then 'extend current run |
|||
curlength = curlength + 1 |
|||
Else ' "output" run and start new run |
|||
news = news & CStr(curlength) & curdigit |
|||
curdigit = newdigit |
|||
curlength = 1 |
|||
End If |
|||
Next p |
|||
' "output" last run |
|||
news = news & CStr(curlength) & curdigit |
|||
Debug.Print news |
|||
s = news |
|||
Next i |
|||
Exit Sub |
|||
Oops: |
|||
Debug.Print |
|||
If Err.Number = 6 Then 'overflow |
|||
Debug.Print "Oops - number too long!" |
|||
Else |
|||
Debug.Print "Error: "; Err.Number, Err.Description |
|||
End If |
|||
End Sub |
|||
</lang> |
|||
Output: |
|||
<pre> |
|||
LookAndSay 7 |
|||
11 |
|||
21 |
|||
1211 |
|||
111221 |
|||
312211 |
|||
13112221 |
|||
1113213211 |
|||
</pre> |
|||
(Note: overflow occurs at 38th iteration!) |
|||
==[[Floyd-Warshall algorithm]]== |
==[[Floyd-Warshall algorithm]]== |
||
Line 392: | Line 324: | ||
5 3 --- No path! |
5 3 --- No path! |
||
5 4 --- No path! |
5 4 --- No path! |
||
</pre> |
|||
==[[Sudoku]]== |
|||
This is a version of the "brute force" approach as in the Fortran program |
|||
<lang> |
|||
Dim grid(9, 9) |
|||
Dim gridSolved(9, 9) |
|||
Public Sub Solve(i, j) |
|||
If i > 9 Then |
|||
'exit with gridSolved = Grid |
|||
For r = 1 To 9 |
|||
For c = 1 To 9 |
|||
gridSolved(r, c) = grid(r, c) |
|||
Next c |
|||
Next r |
|||
Exit Sub |
|||
End If |
|||
For n = 1 To 9 |
|||
If isSafe(i, j, n) Then |
|||
nTmp = grid(i, j) |
|||
grid(i, j) = n |
|||
If j = 9 Then |
|||
Solve i + 1, 1 |
|||
Else |
|||
Solve i, j + 1 |
|||
End If |
|||
grid(i, j) = nTmp |
|||
End If |
|||
Next n |
|||
End Sub |
|||
Public Function isSafe(i, j, n) As Boolean |
|||
Dim iMin As Integer |
|||
Dim jMin As Integer |
|||
If grid(i, j) <> 0 Then |
|||
isSafe = (grid(i, j) = n) |
|||
Exit Function |
|||
End If |
|||
'grid(i,j) is an empty cell. Check if n is OK |
|||
'first check the row i |
|||
For c = 1 To 9 |
|||
If grid(i, c) = n Then |
|||
isSafe = False |
|||
Exit Function |
|||
End If |
|||
Next c |
|||
'now check the column j |
|||
For r = 1 To 9 |
|||
If grid(r, j) = n Then |
|||
isSafe = False |
|||
Exit Function |
|||
End If |
|||
Next r |
|||
'finally, check the 3x3 subsquare containing grid(i,j) |
|||
iMin = 1 + 3 * Int((i - 1) / 3) |
|||
jMin = 1 + 3 * Int((j - 1) / 3) |
|||
For r = iMin To iMin + 2 |
|||
For c = jMin To jMin + 2 |
|||
If grid(r, c) = n Then |
|||
isSafe = False |
|||
Exit Function |
|||
End If |
|||
Next c |
|||
Next r |
|||
'all tests were OK |
|||
isSafe = True |
|||
End Function |
|||
Public Sub Sudoku() |
|||
'main routine |
|||
'to use, fill in the grid and |
|||
'type "Sudoku" in the Immediate panel of the Visual Basic for Applications window |
|||
Dim s(9) As String |
|||
'initialise grid using 9 strings,one per row |
|||
s(1) = "001005070" |
|||
s(2) = "920600000" |
|||
s(3) = "008000600" |
|||
s(4) = "090020401" |
|||
s(5) = "000000000" |
|||
s(6) = "304080090" |
|||
s(7) = "007000300" |
|||
s(8) = "000007069" |
|||
s(9) = "010800700" |
|||
For i = 1 To 9 |
|||
For j = 1 To 9 |
|||
grid(i, j) = Int(Val(Mid$(s(i), j, 1))) |
|||
Next j |
|||
Next i |
|||
'solve it! |
|||
Solve 1, 1 |
|||
'print solution |
|||
Debug.Print "Solution:" |
|||
For i = 1 To 9 |
|||
For j = 1 To 9 |
|||
Debug.Print Format$(gridSolved(i, j)); " "; |
|||
Next j |
|||
Debug.Print |
|||
Next i |
|||
End Sub |
|||
</lang> |
|||
Output: |
|||
<pre> |
|||
Sudoku |
|||
Solution: |
|||
6 3 1 2 4 5 9 7 8 |
|||
9 2 5 6 7 8 1 4 3 |
|||
4 7 8 3 1 9 6 5 2 |
|||
7 9 6 5 2 3 4 8 1 |
|||
1 8 2 9 6 4 5 3 7 |
|||
3 5 4 7 8 1 2 9 6 |
|||
8 6 7 4 9 2 3 1 5 |
|||
2 4 3 1 5 7 8 6 9 |
|||
5 1 9 8 3 6 7 2 4 |
|||
</pre> |
|||
==[[Greatest element of a list]]== |
|||
<lang> |
|||
Public Function ListMax(anArray()) |
|||
'return the greatest element in array anArray whose length is unknown to this function |
|||
n0 = LBound(anArray) |
|||
n = UBound(anArray) |
|||
theMax = anArray(n0) |
|||
For i = (n0 + 1) To n |
|||
If anArray(i) > theMax Then theMax = anArray(i) |
|||
Next |
|||
ListMax = theMax |
|||
End Function |
|||
Public Sub ListMaxTest() |
|||
Dim b() |
|||
'test function ListMax |
|||
'fill array b with some numbers: |
|||
b = Array(5992424433449#, 4534344439984#, 551344678, 99800000#) |
|||
'print the greatest element |
|||
Debug.Print "Greatest element is"; ListMax(b()) |
|||
End Sub |
|||
</lang> |
|||
Result: |
|||
<pre> |
|||
ListMaxTest |
|||
Greatest element is 5992424433449 |
|||
</pre> |
|||
==[[Reverse a string]]== |
|||
===Non-recursive version=== |
|||
<lang> |
|||
Public Function Reverse(aString as String) as String |
|||
' returns the reversed string |
|||
dim L as integer 'length of string |
|||
dim newString as string |
|||
newString = "" |
|||
L = len(aString) |
|||
for i = L to 1 step -1 |
|||
newString = newString & mid$(aString, i, 1) |
|||
next |
|||
Reverse = newString |
|||
End Function |
|||
</lang> |
|||
===Recursive version=== |
|||
<lang> |
|||
Public Function RReverse(aString As String) As String |
|||
'returns the reversed string |
|||
'do it recursively: cut the sring in two, reverse these fragments and put them back together in reverse order |
|||
Dim L As Integer 'length of string |
|||
Dim M As Integer 'cut point |
|||
L = Len(aString) |
|||
If L <= 1 Then 'no need to reverse |
|||
RReverse = aString |
|||
Else |
|||
M = Int(L / 2) |
|||
RReverse = RReverse(Right$(aString, L - M)) & RReverse(Left$(aString, M)) |
|||
End If |
|||
End Function |
|||
</lang> |
|||
===Example dialogue=== |
|||
<pre> |
|||
print Reverse("Public Function Reverse(aString As String) As String") |
|||
gnirtS sA )gnirtS sA gnirtSa(esreveR noitcnuF cilbuP |
|||
print RReverse("Sunday Monday Tuesday Wednesday Thursday Friday Saturday Love") |
|||
evoL yadrutaS yadirF yadsruhT yadsendeW yadseuT yadnoM yadnuS |
|||
print RReverse(Reverse("I know what you did last summer")) |
|||
I know what you did last summer |
|||
</pre> |
|||
==[[Ordered words]]== |
|||
<lang> |
|||
Public Sub orderedwords(fname As String) |
|||
' find ordered words in dict file that have the longest word length |
|||
' fname is the name of the input file |
|||
' the words are printed in the immediate window |
|||
' this subroutine uses boolean function IsOrdered |
|||
Dim word As String 'word to be tested |
|||
Dim l As Integer 'length of word |
|||
Dim wordlength As Integer 'current longest word length |
|||
Dim orderedword() As String 'dynamic array holding the ordered words with the current longest word length |
|||
Dim wordsfound As Integer 'length of the array orderedword() |
|||
On Error GoTo NotFound 'catch incorrect/missing file name |
|||
Open fname For Input As #1 |
|||
On Error GoTo 0 |
|||
'initialize |
|||
wordsfound = 0 |
|||
wordlength = 0 |
|||
'process file line per line |
|||
While Not EOF(1) |
|||
Line Input #1, word |
|||
If IsOrdered(word) Then 'found one, is it equal to or longer than current word length? |
|||
l = Len(word) |
|||
If l >= wordlength Then 'yes, so add to list or start a new list |
|||
If l > wordlength Then 'it's longer, we must start a new list |
|||
wordsfound = 1 |
|||
wordlength = l |
|||
Else 'equal length, increase the list size |
|||
wordsfound = wordsfound + 1 |
|||
End If |
|||
'add the word to the list |
|||
ReDim Preserve orderedword(wordsfound) |
|||
orderedword(wordsfound) = word |
|||
End If |
|||
End If |
|||
Wend |
|||
Close #1 |
|||
'print the list |
|||
Debug.Print "Found"; wordsfound; "ordered words of length"; wordlength |
|||
For i = 1 To wordsfound |
|||
Debug.Print orderedword(i) |
|||
Next |
|||
Exit Sub |
|||
NotFound: |
|||
debug.print "Error: Cannot find or open file """ & fname & """!" |
|||
End Sub |
|||
Public Function IsOrdered(someWord As String) As Boolean |
|||
'true if letters in word are in ascending (ascii) sequence |
|||
Dim l As Integer 'length of someWord |
|||
Dim wordLcase As String 'the word in lower case |
|||
Dim ascStart As Integer 'ascii code of first char |
|||
Dim asc2 As Integer 'ascii code of next char |
|||
wordLcase = LCase(someWord) 'convert to lower case |
|||
l = Len(someWord) |
|||
IsOrdered = True |
|||
If l > 0 Then 'this skips empty string - it is considered ordered... |
|||
ascStart = Asc(Left$(wordLcase, 1)) |
|||
For i = 2 To l |
|||
asc2 = Asc(Mid$(wordLcase, i, 1)) |
|||
If asc2 < ascStart Then 'failure! |
|||
IsOrdered = False |
|||
Exit Function |
|||
End If |
|||
ascStart = asc2 |
|||
Next i |
|||
End If |
|||
End Function |
|||
</lang> |
|||
Results: |
|||
<pre> |
|||
OrderedWords("unixdict.txt") |
|||
Found 16 ordered words of length 6 |
|||
abbott |
|||
accent |
|||
accept |
|||
access |
|||
accost |
|||
almost |
|||
bellow |
|||
billow |
|||
biopsy |
|||
chilly |
|||
choosy |
|||
choppy |
|||
effort |
|||
floppy |
|||
glossy |
|||
knotty |
|||
</pre> |
</pre> |
||
Revision as of 12:29, 30 September 2011
My Favorite Languages | |
Language | Proficiency |
Visual Basic | Active (in VB for Applications) |
BASIC | Somewhat Rusty |
Fortran | Stuck in Fortran 77, WATFOR, WATFIV etc. |
Pascal | Rusty |
PHP | Learning |
MATLAB | Learning |
JavaScript | Semi-Active |
SQL | Semi-Active |
APL | is way back |
VBA Examples
Some nontrivial VBA Examples (until there is a separate VBA category).
In MS Office program (Word, Excel, Access...): open the Visual Basic window. Paste the code in a module. Execute it by typing a suitable command in the Immediate Window. Output will be directed to the Immediate Window unless stated otherwise...
Letter frequency
<lang> Public Sub LetterFrequency(fname) 'count number of letters in text file (ASCII-coded) 'note: we count all characters but print only the letter frequencies
Dim Freqs(255) As Long Dim abyte As Byte Dim ascal as Byte 'ascii code for lowercase a Dim ascau as Byte 'ascii code for uppercase a
'try to open the file On Error GoTo CantOpen Open fname For Input As #1 On Error GoTo 0
'initialize For i = 0 To 255
Freqs(i) = 0
Next i
'process file byte-per-byte While Not EOF(1)
abyte = Asc(Input(1, #1)) Freqs(abyte) = Freqs(abyte) + 1
Wend Close #1
'add lower and upper case together and print result Debug.Print "Frequencies:" ascal = Asc("a") ascau = Asc("A") For i = 0 To 25
Debug.Print Chr$(ascal + i), Freqs(ascal + i) + Freqs(ascau + i)
Next i Exit Sub
CantOpen:
Debug.Print "can't find or read the file "; fname Close
End Sub </lang>
Output:
LetterFrequency "d:\largetext.txt" Frequencies: a 24102 b 4985 c 4551 d 19127 e 61276 f 2734 g 10661 h 8243 i 21589 j 4904 k 7186 l 12026 m 7454 n 31963 o 19021 p 4960 q 37 r 21166 s 13403 t 21090 u 6117 v 8612 w 5017 x 168 y 299 z 4159
Horner's rule for polynomial evaluation
Note: this function Horner gets its coefficients in a ParamArray which has no specified length. This array collect all arguments after the first one. This means you must specify x first, then the coefficients.
<lang> Public Function Horner(x, ParamArray coeff()) Dim result As Double Dim ncoeff As Integer
result = 0 ncoeff = UBound(coeff())
For i = ncoeff To 0 Step -1
result = (result * x) + coeff(i)
Next i Horner = result End Function </lang>
Output:
print Horner(3, -19, 7, -4, 6) 128
Floyd-Warshall algorithm
The Floyd algorithm or Floyd-Warshall algorithm finds the shortest path between all pairs of nodes in a weighted, directed graph. It is an example of dynamic programming.
Usage: fill in the number of nodes (n) and the non-zero edge distances or costs in sub Floyd or in sub FloydWithPaths. Then run "Floyd" or "FloydWithPaths".
Floyd: this sub prints the lengths or costs of the shortest paths but not the paths themselves
FloydWithPaths: this sub prints the lengths and the nodes along the paths
<lang> 'Floyd globals Const MaxGraph As Integer = 100 'max. number of vertices in graph Const Infinity = 1E+308 'very large number Dim E(1 To MaxGraph, 1 To MaxGraph) As Double Dim A(1 To MaxGraph, 1 To MaxGraph) As Double Dim Nxt(1 To MaxGraph, 1 To MaxGraph) As Integer
Public Sub SolveFloyd(n)
'Floyd's algorithm: all-pairs shortest-paths cost 'returns the cost (distance) of the least-cost (shortest) path 'between all pairs in a labeled directed graph 'note: this sub returns only the costs, not the paths! ' 'inputs: ' n : number of vertices (maximum value is maxGraph) ' E(i,j) : cost (length,...) of edge from i to j or <=0 if no edge between i and j 'output: ' A(i,j): minimal cost for path from i to j 'constant: ' Infinity : very large number (guaranteed to be larger than largest possible cost of any path) For i = 1 To n For j = 1 To n If E(i, j) > 0 Then A(i, j) = E(i, j) Else A(i, j) = Infinity Next j A(i, i) = 0 Next i For k = 1 To n For i = 1 To n For j = 1 To n If A(i, k) + A(k, j) < A(i, j) Then A(i, j) = A(i, k) + A(k, j) Next j Next i Next k
End Sub
Public Sub SolveFloydWithPaths(n)
'cf. SolveFloyd, but here we 'use matrix "Nxt" to store information about paths For i = 1 To n For j = 1 To n If E(i, j) > 0 Then A(i, j) = E(i, j) Else A(i, j) = Infinity Next j A(i, i) = 0 Next i For k = 1 To n For i = 1 To n For j = 1 To n If A(i, k) + A(k, j) < A(i, j) Then A(i, j) = A(i, k) + A(k, j) Nxt(i, j) = k End If Next j Next i Next k
End Sub
Public Function GetPath(i, j) As String
'recursively reconstruct shortest path from i to j using A and Nxt If A(i, j) = Infinity Then GetPath = "No path!" Else tmp = Nxt(i, j) If tmp = 0 Then GetPath = " " 'there is an edge from i to j Else GetPath = GetPath(i, tmp) & Format$(tmp) & GetPath(tmp, j) End If End If
End Function
Public Sub Floyd() 'main function to apply Floyd's algorithm 'see description in wp:en:Floyd-Warshall algorithm
' define problem: ' number of vertices? n = 5 ' reset connection/cost per edge matrix For i = 1 To n
For j = 1 To n E(i, j) = 0 Next j
Next i ' fill in the edge costs E(1, 2) = 10 E(1, 3) = 50 E(1, 4) = 65 E(2, 3) = 30 E(2, 5) = 4 E(3, 4) = 20 E(3, 5) = 44 E(4, 2) = 7 E(4, 5) = 13
'Solve it SolveFloyd n
'Print solution 'note: for large graphs the output may be too large for the Immediate panel 'in that case you could send the output to a text file Debug.Print "From", "To", "Cost" For i = 1 To n
For j = 1 To n If i <> j Then Debug.Print i, j, IIf(A(i, j) = Infinity, "No path!", A(i, j)) Next j
Next i End Sub
Public Sub FloydWithPaths() 'main function to solve Floyd's algorithm and return shortest path between 'any two vertices
' define problem: ' number of vertices? n = 5 ' reset connection/cost per edge matrix For i = 1 To n
For j = 1 To n E(i, j) = 0 Nxt(i, j) = 0 Next j
Next i ' fill in the edge costs E(1, 2) = 10 E(1, 3) = 50 E(1, 4) = 65 E(2, 3) = 30 E(2, 5) = 4 E(3, 4) = 20 E(3, 5) = 44 E(4, 2) = 7 E(4, 5) = 13
'Solve it SolveFloydWithPaths n
'Print solution 'note: for large graphs the output may be too large for the Immediate panel 'in that case you could send the output to a text file Debug.Print "From", "To", "Cost", "Via" For i = 1 To n
For j = 1 To n If i <> j Then Debug.Print i, j, IIf(A(i, j) = Infinity, "---", A(i, j)), GetPath(i, j) Next j
Next i End Sub </lang>
Output:
Floyd From To Cost 1 2 10 1 3 40 1 4 60 1 5 14 2 1 No path! 2 3 30 2 4 50 2 5 4 3 1 No path! 3 2 27 3 4 20 3 5 31 4 1 No path! 4 2 7 4 3 37 4 5 11 5 1 No path! 5 2 No path! 5 3 No path! 5 4 No path! FloydWithPaths From To Cost Via 1 2 10 1 3 40 2 1 4 60 2 3 1 5 14 2 2 1 --- No path! 2 3 30 2 4 50 3 2 5 4 3 1 --- No path! 3 2 27 4 3 4 20 3 5 31 4 2 4 1 --- No path! 4 2 7 4 3 37 2 4 5 11 2 5 1 --- No path! 5 2 --- No path! 5 3 --- No path! 5 4 --- No path!
Hailstone sequence
<lang> Public Function Hailstone(aNumber As Long, Optional Printit As Boolean = False) As Long 'return length of Hailstone sequence for aNumber 'if optional argument Printit is true, print the sequence in the Immediate window Dim nSteps As Long Const NumbersPerLine = 10 'when printing, start a new line after this much numbers
nSteps = 1 If Printit Then Debug.Print aNumber, While aNumber <> 1
If aNumber Mod 2 = 0 Then aNumber = aNumber / 2 Else aNumber = 3 * aNumber + 1 nSteps = nSteps + 1 If Printit Then Debug.Print aNumber, If Printit And (nSteps Mod NumbersPerLine = 0) Then Debug.Print
Wend If Printit Then Debug.Print "(Length:"; nSteps; ")" Hailstone = nSteps End Function
Public Sub HailstoneTest() Dim theNumber As Long Dim theSequenceLength As Long Dim SeqLength As Long Dim i as Long
'find and print the Hailstone sequence for 27 (note: the whole sequence, not just the first four and last four items!) Debug.Print "Hailstone sequence for 27:" theNumber = Hailstone(27, True)
'find the longest Hailstone sequence for numbers less than 100000. theSequenceLength = 0 For i = 2 To 99999
SeqLength = Hailstone(i) If SeqLength > theSequenceLength Then theNumber = i theSequenceLength = SeqLength End If
Next i Debug.Print theNumber; "has the longest sequence ("; theSequenceLength; ")." End Sub </lang>
Output:
HailstoneTest Hailstone sequence for 27: 27 82 41 124 62 31 94 47 142 71 214 107 322 161 484 242 121 364 182 91 274 137 412 206 103 310 155 466 233 700 350 175 526 263 790 395 1186 593 1780 890 445 1336 668 334 167 502 251 754 377 1132 566 283 850 425 1276 638 319 958 479 1438 719 2158 1079 3238 1619 4858 2429 7288 3644 1822 911 2734 1367 4102 2051 6154 3077 9232 4616 2308 1154 577 1732 866 433 1300 650 325 976 488 244 122 61 184 92 46 23 70 35 106 53 160 80 40 20 10 5 16 8 4 2 1 (Length: 112 ) 77031 has the longest sequence ( 351 ).