User:Klever: Difference between revisions
Content added Content deleted
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> |
||