|
128
</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]]==
5 3 --- 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>
|