User:Klever: Difference between revisions

From Rosetta Code
Content added Content deleted
 
(21 intermediate revisions by the same user not shown)
Line 1: Line 1:
{{mylangbegin}}
{{mylangbegin}}
{{mylang|Visual Basic|Active (in VB for Applications)}}
{{mylang|VBA|Active}}
{{mylang|BASIC|Somewhat Rusty}}
{{mylang|BASIC|Somewhat Rusty}}
{{mylang|Fortran|Stuck in Fortran 77, WATFOR, WATFIV etc.}}
{{mylang|Fortran|Stuck in Fortran 77, WATFOR, WATFIV etc.}}
Line 12: Line 12:


=VBA Examples=
=VBA Examples=
Some nontrivial VBA Examples (until there is a separate VBA category).
Some nontrivial VBA Examples (to be moved).


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...
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...


==[[Greatest element of a list]]==
==[[Dijkstra algorithm]]==
<lang>
<lang vb>
'Dijkstra globals
Public Function ListMax(anArray())
Const MaxGraph As Integer = 100 'max. number of nodes in graph
'return the greatest element in array anArray whose length is unknown to this function
Const Infinity = 1E+308
n0 = LBound(anArray)
Dim E(1 To MaxGraph, 1 To MaxGraph) As Double 'the edge costs (Infinity if no edge)
n = UBound(anArray)
Dim A(1 To MaxGraph) As Double 'the distances calculated
theMax = anArray(n0)
Dim P(1 To MaxGraph) As Integer 'the previous/path array
For i = (n0 + 1) To n
Dim Q(1 To MaxGraph) As Boolean 'the queue
If anArray(i) > theMax Then theMax = anArray(i)
Next
Public Sub Dijkstra(n, start)
ListMax = theMax
'simple implementation of Dijkstra's algorithm
'n = number of nodes in graph
'start = index of start node
'init distances A
For j = 1 To n
A(j) = Infinity
Next j
A(start) = 0
'init P (path) to "no paths" and Q = set of all nodes
For j = 1 To n
Q(j) = True
P(j) = 0
Next j
Do While True 'loop will exit! (see below)
'find node u in Q with smallest distance to start
dist = Infinity
For i = 1 To n
If Q(i) Then
If A(i) < dist Then
dist = A(i)
u = i
End If
End If
Next i
If dist = Infinity Then Exit Do 'no more nodes available - done!
'remove u from Q
Q(u) = False
'loop over neighbors of u that are in Q
For j = 1 To n
If Q(j) And E(u, j) <> Infinity Then
'check if path to neighbor j via u is shorter than current estimated distance to j
alt = A(u) + E(u, j)
If alt < A(j) Then
'yes, replace with new distance and remember "previous" hop on the path
A(j) = alt
P(j) = u
End If
End If
Next j
Loop
End Sub
Public Function GetPath(source, target) As String
'reconstruct shortest path from source to target
'by working backwards from target using the P(revious) array
Dim path As String
If P(target) = 0 Then
GetPath = "No path"
Else
path = ""
u = target
Do While P(u) > 0
path = Format$(u) & " " & path
u = P(u)
Loop
GetPath = Format$(source) & " " & path
End If
End Function
End Function
Public Sub DijkstraTest()
'main function to solve Dijkstra's algorithm and return shortest path between
'a node and every other node in a digraph
' define problem:
' number of nodes
n = 5
' reset connection/cost per edge
For i = 1 To n
For j = 1 To n
E(i, j) = Infinity
Next j
P(i) = 0
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) = 70
E(4, 5) = 23
E(5, 1) = 6
'Solve it for every node


For v = 1 To n

Dijkstra n, v
Public Sub ListMaxTest()
'Print solution
Dim b()
Debug.Print "From", "To", "Cost", "Path"
'test function ListMax
For j = 1 To n
'fill array b with some numbers:
If v <> j Then Debug.Print v, j, IIf(A(j) = Infinity, "---", A(j)), GetPath(v, j)
b = Array(5992424433449#, 4534344439984#, 551344678, 99800000#)
Next j
'print the greatest element
Debug.Print "Greatest element is"; ListMax(b())
Debug.Print
Next v
End Sub
End Sub
</lang>
</lang>


Output (using the same graph as in the Floyd-Warshall algorithm below):
Result:
<pre>
<pre>
DijkstraTest
ListMaxTest
From To Cost Path
Greatest element is 5992424433449
1 2 10 1 2
</pre>
1 3 40 1 2 3
1 4 60 1 2 3 4
1 5 14 1 2 5


From To Cost Path
==[[Reverse a string]]==
2 1 10 2 5 1
===Non-recursive version===
2 3 30 2 3
<lang>
2 4 50 2 3 4
Public Function Reverse(aString as String) as String
2 5 4 2 5
' returns the reversed string
dim L as integer 'length of string
dim newString as string


From To Cost Path
newString = ""
3 1 49 3 4 5 1
L = len(aString)
3 2 59 3 4 5 1 2
for i = L to 1 step -1
3 4 20 3 4
newString = newString & mid$(aString, i, 1)
3 5 43 3 4 5
next
Reverse = newString
End Function
</lang>


From To Cost Path
===Recursive version===
4 1 29 4 5 1
<lang>
4 2 39 4 5 1 2
Public Function RReverse(aString As String) As String
4 3 69 4 5 1 2 3
'returns the reversed string
4 5 23 4 5
'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


From To Cost Path
L = Len(aString)
5 1 6 5 1
If L <= 1 Then 'no need to reverse
5 2 16 5 1 2
RReverse = aString
5 3 46 5 1 2 3
Else
5 4 66 5 1 2 3 4
M = Int(L / 2)
</pre>
RReverse = RReverse(Right$(aString, L - M)) & RReverse(Left$(aString, M))
End If
End Function
</lang>


==[[Floyd-Warshall algorithm]]==
===Example dialogue===
[[File:FloydGraph.png|thumb|250px|Graph used in this and Dijkstra's algorithm]]
<pre>
The [http://en.wikipedia.org/wiki/Floyd-Warshall_algorithm 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.
print Reverse("Public Function Reverse(aString As String) As String")
gnirtS sA )gnirtS sA gnirtSa(esreveR noitcnuF cilbuP


Usage: fill in the number of nodes (n) and the edge distances or costs in sub Floyd or in sub FloydWithPaths.
print RReverse("Sunday Monday Tuesday Wednesday Thursday Friday Saturday Love")
Then run "Floyd" or "FloydWithPaths".
evoL yadrutaS yadirF yadsruhT yadsendeW yadseuT yadnoM yadnuS


Floyd: this sub prints the lengths or costs of the shortest paths but not the paths themselves
print RReverse(Reverse("I know what you did last summer"))
I know what you did last summer
</pre>


FloydWithPaths: this sub prints the lengths and the nodes along the paths
==[[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()


<lang vb>
On Error GoTo NotFound 'catch incorrect/missing file name
Option Compare Database
Open fname For Input As #1
On Error GoTo 0


'Floyd globals
'initialize
Const MaxGraph As Integer = 100 'max. number of vertices in graph
wordsfound = 0
Const Infinity = 1E+308
wordlength = 0
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 "Infinity" if no edge between i and j
'output:
' A(i,j): minimal cost for path from i to j
'constant:
' Infinity : very large number
For i = 1 To n
For j = 1 To n
If E(i, j) <> Infinity 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) <> Infinity 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) = Infinity
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) = 70
E(4, 5) = 23
E(5, 1) = 6
'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) = Infinity
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) = 70
E(4, 5) = 23
E(5, 1) = 6
'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:
'process file line per line
<pre>Floyd
While Not EOF(1)
From To Cost
Line Input #1, word
1 2 10
If IsOrdered(word) Then 'found one, is it equal to or longer than current word length?
1 3 40
l = Len(word)
If l >= wordlength Then 'yes, so add to list or start a new list
1 4 60
If l > wordlength Then 'it's longer, we must start a new list
1 5 14
wordsfound = 1
2 1 10
wordlength = l
2 3 30
Else 'equal length, increase the list size
2 4 50
wordsfound = wordsfound + 1
2 5 4
3 1 49
End If
'add the word to the list
3 2 59
3 4 20
ReDim Preserve orderedword(wordsfound)
3 5 43
orderedword(wordsfound) = word
4 1 29
End If
4 2 39
End If
4 3 69
Wend
4 5 23
Close #1
5 1 6
5 2 16
5 3 46
5 4 66


FloydWithPaths
'print the list
From To Cost Via
Debug.Print "Found"; wordsfound; "ordered words of length"; wordlength
1 2 10
For i = 1 To wordsfound
1 3 40 2
Debug.Print orderedword(i)
1 4 60 2 3
Next
1 5 14 2
Exit Sub
2 1 10 5
2 3 30
2 4 50 3
2 5 4
3 1 49 4 5
3 2 59 4 5 1
3 4 20
3 5 43 4
4 1 29 5
4 2 39 5 1
4 3 69 5 1 2
4 5 23
5 1 6
5 2 16 1
5 3 46 1 2
5 4 66 1 2 3
</pre>


==[[KWIC index]]==
NotFound:
debug.print "Error: Cannot find or open file """ & fname & """!"
End Sub


<lang vb>
'KWIC index
'assumptions:
' - all titles and catalog numbers can be held in an array in main memory
' - disregard punctuation in titles
' - the KWIC index itself may be too large for main memory - do not store it in memory
' - the KWIC index consists of one line per title/keyword combination and consists of:
' - the catalog number
' - the title with the keyword centered in a line of given length (e.g. 80 or 120)
' (constant-width font assumed)
' note: long titles may be truncated at the beginning or the end of the line


'globals
Const MAXKEYS = 20 'max. number of keywords in a title
Const STOPWORDS = "a an and by for is it of on or the to with " 'that last space is needed!
Dim title() As String 'list of titles to be included in KWIC index
Dim catno() As Integer 'list of catalog numbers
Dim ntitle As Integer 'number of titles
Dim index() As Integer 'holds title number and position of keyword in title
Dim nkeys As Long 'total number of keywords found


Sub ReadTitles()
Public Function IsOrdered(someWord As String) As Boolean
' read or - in this case - set the titles and catalog numbers
'true if letters in word are in ascending (ascii) sequence
ntitle = 10
ReDim title(1 To ntitle)
ReDim catno(1 To ntitle)
title(1) = "Microsoft Visio 2003 User's Guide"
title(2) = "Microsoft Office Excel 2003 Inside Out"
title(3) = "Mastering Excel 2003 Programming with VBA"
title(4) = "Excel 2003 Formulas"
title(5) = "Excel for Scientists and Engineers"
title(6) = "Excel 2003 VBA Programmer's Reference"
title(7) = "Automated Data Analysis Using Excel"
title(8) = "Beginning Excel: What-if Data Analysis Tools"
title(9) = "How to do Everything with Microsoft Office Excel 2003"
title(10) = "Data Analysis Using SQL and Excel"
catno(1) = 10
catno(2) = 13
catno(3) = 3435
catno(4) = 987
catno(5) = 1010
catno(6) = 1244
catno(7) = 709
catno(8) = 9088
catno(9) = 33
catno(10) = 7733
End Sub


Function IsStopword(aword) As Boolean
Dim l As Integer 'length of someWord
'search for aword in stopword list
Dim wordLcase As String 'the word in lower case
'add an extra space to avoid ambiguity
Dim ascStart As Integer 'ascii code of first char
IsStopword = InStr(STOPWORDS, LCase(aword) & " ") > 0
Dim asc2 As Integer 'ascii code of next char
End Function


Sub ProcessTitles()
wordLcase = LCase(someWord) 'convert to lower case
'find positions of keywords in titles, store in index array
l = Len(someWord)
'Note: we cannot use Split here because that function doesn't return
IsOrdered = True
'the positions of the words it finds
If l > 0 Then 'this skips empty string - it is considered ordered...
nkeys = 0
ascStart = Asc(Left$(wordLcase, 1))
For i = 2 To l
For i = 1 To ntitle
atitle = title(i) & " " 'add extra space as sentinel
asc2 = Asc(Mid$(wordLcase, i, 1))
p1 = 1
If asc2 < ascStart Then 'failure!
Do While p1 <= Len(atitle)
IsOrdered = False
Exit Function
'find next word:
'a) find next non-space
While Mid$(atitle, p1, 1) = " ": p1 = p1 + 1: Wend
'b) extend word
p2 = p1
While Mid$(atitle, p2, 1) <> " ": p2 = p2 + 1: Wend
aword = Mid$(atitle, p1, p2 - p1)
'for now we assume there is no punctuation, i.e. no words
'in parentheses, brackets or quotation marks
If Not IsStopword(aword) Then
'remember position of this keyword
'we probably should check for overflow (too many keywords) here!
nkeys = nkeys + 1
index(nkeys, 1) = i
index(nkeys, 2) = p1
End If
End If
ascStart = asc2
'continue searching
p1 = p2 + 1
Next i
Loop
End If
Next i
End Sub

Function Shift(aString, pos)
'return shifted string (part beginning at position "pos" followed by part before it)
Shift = Mid$(aString, pos) & " " & Left$(aString, pos - 1)
End Function
End Function

Sub SortTitles()
' sort the index() array to represent shifted titles in alphabetical order
' more efficient sorting algorithms can be applied here...
switched = True
Do While switched
'scan array for two shifted strings in the wrong order and swap
'(swap the index entries, not the strings)
'use case-insensitive compare
switched = False
For i = 1 To nkeys - 1
string1 = LCase(Shift(title(index(i, 1)), index(i, 2)))
string2 = LCase(Shift(title(index(i + 1, 1)), index(i + 1, 2)))
If string2 < string1 Then 'swap
For j = 1 To 2
temp = index(i, j)
index(i, j) = index(i + 1, j)
index(i + 1, j) = temp
Next
switched = True
End If
Next i
Loop
End Sub

Sub PrintKWIC(linelength)
'print the KWIC index
spaces = Space(linelength / 2)
Debug.Print "Cat. number", "|"; Space((linelength - 10) / 2); "KWIC string"
Debug.Print String(linelength + 15, "-")
For i = 1 To nkeys
atitle = title(index(i, 1))
pos = index(i, 2)
'create shifted string so that keyword is centered in the line
part2 = Mid$(atitle, pos)
part1 = Right$(spaces & Left$(atitle, pos - 1), linelength / 2)
kwicstring = Right$(part1, linelength / 2) & Left$(part2, linelength / 2)
Debug.Print catno(index(i, 1)), "|"; kwicstring
Next
End Sub

Sub KWIC()
'main program for KWIC index
ReadTitles
'set array
ReDim index(ntitle * MAXKEYS, 2)
'index(.,1) is title nr.
'index(.,2) is keyword position in title
ProcessTitles
SortTitles
PrintKWIC 80 'argument is the length of the KWIC lines (excluding catalog numbers)
End Sub
</lang>
</lang>


Output (note that some titles are truncated at the start or the end. An improvement could be to wrap these titles around if there is room on the other end):
Results:
<pre>
<pre>
kwic
OrderedWords("unixdict.txt")
Cat. number | KWIC string
Found 16 ordered words of length 6
-----------------------------------------------------------------------------------------------
abbott
987 | Excel 2003 Formulas
accent
33 | Everything with Microsoft Office Excel 2003
accept
13 | Microsoft Office Excel 2003 Inside Out
access
3435 | Mastering Excel 2003 Programming with VBA
accost
10 | Microsoft Visio 2003 User's Guide
almost
1244 | Excel 2003 VBA Programmer's Reference
bellow
9088 | Beginning Excel: What-if Data Analysis Tools
billow
709 | Automated Data Analysis Using Excel
biopsy
7733 | Data Analysis Using SQL and Excel
chilly
709 | Automated Data Analysis Using Excel
choosy
9088 | Beginning Excel: What-if Data Analysis T
choppy
9088 | Beginning Excel: What-if Data Analysis Tools
effort
709 | Automated Data Analysis Using Excel
floppy
7733 | Data Analysis Using SQL and Excel
glossy
33 | How to do Everything with Microsoft Office Exce
knotty
1010 | Excel for Scientists and Engineers
33 | How to do Everything with Microsoft Office Excel 2
987 | Excel 2003 Formulas
33 | to do Everything with Microsoft Office Excel 2003
13 | Microsoft Office Excel 2003 Inside Out
3435 | Mastering Excel 2003 Programming with VBA
1244 | Excel 2003 VBA Programmer's Reference
709 | Automated Data Analysis Using Excel
7733 | Data Analysis Using SQL and Excel
1010 | Excel for Scientists and Engineers
9088 | Beginning Excel: What-if Data Analysis Tools
987 | Excel 2003 Formulas
10 | Microsoft Visio 2003 User's Guide
33 | How to do Everything with Microsoft Offi
13 | Microsoft Office Excel 2003 Inside Out
3435 | Mastering Excel 2003 Programming with VB
33 | How to do Everything with Microsoft Office Excel 2003
13 | Microsoft Office Excel 2003 Inside Out
10 | Microsoft Visio 2003 User's Guide
33 | How to do Everything with Microsoft Office Excel 2003
13 | Microsoft Office Excel 2003 Inside Out
13 | Microsoft Office Excel 2003 Inside Out
1244 | Excel 2003 VBA Programmer's Reference
3435 | Mastering Excel 2003 Programming with VBA
1244 | Excel 2003 VBA Programmer's Reference
1010 | Excel for Scientists and Engineers
7733 | Data Analysis Using SQL and Excel
9088 | Beginning Excel: What-if Data Analysis Tools
10 | Microsoft Visio 2003 User's Guide
709 | Automated Data Analysis Using Excel
7733 | Data Analysis Using SQL and Excel
3435 | Mastering Excel 2003 Programming with VBA
1244 | Excel 2003 VBA Programmer's Reference
10 | Microsoft Visio 2003 User's Guide
9088 | Beginning Excel: What-if Data Analysis Tools
</pre>
</pre>


Latest revision as of 14:33, 23 November 2011

My Favorite Languages
Language Proficiency
VBA Active
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 (to be moved).

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...

Dijkstra algorithm

<lang vb> 'Dijkstra globals Const MaxGraph As Integer = 100 'max. number of nodes in graph Const Infinity = 1E+308 Dim E(1 To MaxGraph, 1 To MaxGraph) As Double 'the edge costs (Infinity if no edge) Dim A(1 To MaxGraph) As Double 'the distances calculated Dim P(1 To MaxGraph) As Integer 'the previous/path array Dim Q(1 To MaxGraph) As Boolean 'the queue

Public Sub Dijkstra(n, start) 

 'simple implementation of Dijkstra's algorithm
 'n = number of nodes in graph
 'start = index of start node
 'init distances A
   For j = 1 To n
     A(j) = Infinity
   Next j
   A(start) = 0
 'init P (path) to "no paths" and Q = set of all nodes
 For j = 1 To n
   Q(j) = True
   P(j) = 0
 Next j
 
 Do While True 'loop will exit! (see below)
 'find node u in Q with smallest distance to start
   dist = Infinity
   For i = 1 To n
     If Q(i) Then
       If A(i) < dist Then
         dist = A(i)
         u = i
       End If
     End If
   Next i
   If dist = Infinity Then Exit Do 'no more nodes available - done!
   'remove u from Q
   Q(u) = False
   'loop over neighbors of u that are in Q
   For j = 1 To n
     If Q(j) And E(u, j) <> Infinity Then
       'check if path to neighbor j via u is shorter than current estimated distance to j
       alt = A(u) + E(u, j)
       If alt < A(j) Then
         'yes, replace with new distance and remember "previous" hop on the path
         A(j) = alt
         P(j) = u
       End If
     End If
   Next j
 Loop

End Sub

Public Function GetPath(source, target) As String 

'reconstruct shortest path from source to target
'by working backwards from target using the P(revious) array
Dim path As String
If P(target) = 0 Then
  GetPath = "No path"
Else
  path = ""
  u = target
  Do While P(u) > 0
    path = Format$(u) & " " & path
    u = P(u)
  Loop
  GetPath = Format$(source) & " " & path
End If

End Function


Public Sub DijkstraTest() 'main function to solve Dijkstra's algorithm and return shortest path between 'a node and every other node in a digraph

' define problem: ' number of nodes n = 5 ' reset connection/cost per edge For i = 1 To n 

 For j = 1 To n
   E(i, j) = Infinity
 Next j
 P(i) = 0

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) = 70 E(4, 5) = 23 E(5, 1) = 6

'Solve it for every node

For v = 1 To n 

 Dijkstra n, v
 'Print solution
 Debug.Print "From", "To", "Cost", "Path"
 For j = 1 To n
   If v <> j Then Debug.Print v, j, IIf(A(j) = Infinity, "---", A(j)), GetPath(v, j)
 Next j
 Debug.Print

Next v End Sub </lang>

Output (using the same graph as in the Floyd-Warshall algorithm below): 

DijkstraTest
From          To            Cost          Path
 1             2             10           1 2 
 1             3             40           1 2 3 
 1             4             60           1 2 3 4 
 1             5             14           1 2 5 

From          To            Cost          Path
 2             1             10           2 5 1 
 2             3             30           2 3 
 2             4             50           2 3 4 
 2             5             4            2 5 

From          To            Cost          Path
 3             1             49           3 4 5 1 
 3             2             59           3 4 5 1 2 
 3             4             20           3 4 
 3             5             43           3 4 5 

From          To            Cost          Path
 4             1             29           4 5 1 
 4             2             39           4 5 1 2 
 4             3             69           4 5 1 2 3 
 4             5             23           4 5 

From          To            Cost          Path
 5             1             6            5 1 
 5             2             16           5 1 2 
 5             3             46           5 1 2 3 
 5             4             66           5 1 2 3 4

Floyd-Warshall algorithm

Graph used in this and Dijkstra's 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 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 vb> Option Compare Database

'Floyd globals Const MaxGraph As Integer = 100 'max. number of vertices in graph Const Infinity = 1E+308 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 "Infinity" if no edge between i and j
 'output:
 ' A(i,j): minimal cost for path from i to j
 'constant:
 ' Infinity : very large number

 For i = 1 To n
   For j = 1 To n
     If E(i, j) <> Infinity 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) <> Infinity 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) = Infinity
 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) = 70 E(4, 5) = 23 E(5, 1) = 6

'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) = Infinity
   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) = 70 E(4, 5) = 23 E(5, 1) = 6

'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             10 
 2             3             30 
 2             4             50 
 2             5             4 
 3             1             49 
 3             2             59 
 3             4             20 
 3             5             43 
 4             1             29 
 4             2             39 
 4             3             69 
 4             5             23 
 5             1             6 
 5             2             16 
 5             3             46 
 5             4             66 

FloydWithPaths
From          To            Cost          Via
 1             2             10            
 1             3             40            2 
 1             4             60            2 3 
 1             5             14            2 
 2             1             10            5 
 2             3             30            
 2             4             50            3 
 2             5             4             
 3             1             49            4 5 
 3             2             59            4 5 1 
 3             4             20            
 3             5             43            4 
 4             1             29            5 
 4             2             39            5 1 
 4             3             69            5 1 2 
 4             5             23            
 5             1             6             
 5             2             16            1 
 5             3             46            1 2 
 5             4             66            1 2 3

KWIC index

<lang vb> 'KWIC index 'assumptions: ' - all titles and catalog numbers can be held in an array in main memory ' - disregard punctuation in titles ' - the KWIC index itself may be too large for main memory - do not store it in memory ' - the KWIC index consists of one line per title/keyword combination and consists of: ' - the catalog number ' - the title with the keyword centered in a line of given length (e.g. 80 or 120) ' (constant-width font assumed) ' note: long titles may be truncated at the beginning or the end of the line

'globals Const MAXKEYS = 20 'max. number of keywords in a title Const STOPWORDS = "a an and by for is it of on or the to with " 'that last space is needed! Dim title() As String 'list of titles to be included in KWIC index Dim catno() As Integer 'list of catalog numbers Dim ntitle As Integer 'number of titles Dim index() As Integer 'holds title number and position of keyword in title Dim nkeys As Long 'total number of keywords found

Sub ReadTitles() ' read or - in this case - set the titles and catalog numbers ntitle = 10 ReDim title(1 To ntitle) ReDim catno(1 To ntitle) 

 title(1) = "Microsoft Visio 2003 User's Guide"
 title(2) = "Microsoft Office Excel 2003 Inside Out"
 title(3) = "Mastering Excel 2003 Programming with VBA"
 title(4) = "Excel 2003 Formulas"
 title(5) = "Excel for Scientists and Engineers"
 title(6) = "Excel 2003 VBA Programmer's Reference"
 title(7) = "Automated Data Analysis Using Excel"
 title(8) = "Beginning Excel: What-if Data Analysis Tools"
 title(9) = "How to do Everything with Microsoft Office Excel 2003"
 title(10) = "Data Analysis Using SQL and Excel"
 catno(1) = 10
 catno(2) = 13
 catno(3) = 3435
 catno(4) = 987
 catno(5) = 1010
 catno(6) = 1244
 catno(7) = 709
 catno(8) = 9088
 catno(9) = 33
 catno(10) = 7733

End Sub

Function IsStopword(aword) As Boolean 'search for aword in stopword list 'add an extra space to avoid ambiguity IsStopword = InStr(STOPWORDS, LCase(aword) & " ") > 0 End Function

Sub ProcessTitles() 'find positions of keywords in titles, store in index array 'Note: we cannot use Split here because that function doesn't return 'the positions of the words it finds nkeys = 0 For i = 1 To ntitle 

 atitle = title(i) & " " 'add extra space as sentinel
 p1 = 1
 Do While p1 <= Len(atitle)
   'find next word:
   'a) find next non-space
   While Mid$(atitle, p1, 1) = " ": p1 = p1 + 1: Wend
   'b) extend word
   p2 = p1
   While Mid$(atitle, p2, 1) <> " ": p2 = p2 + 1: Wend
   aword = Mid$(atitle, p1, p2 - p1)
   'for now we assume there is no punctuation, i.e. no words
   'in parentheses, brackets or quotation marks
   If Not IsStopword(aword) Then
     'remember position of this keyword
     'we probably should check for overflow (too many keywords) here!
     nkeys = nkeys + 1
     index(nkeys, 1) = i
     index(nkeys, 2) = p1
   End If
   'continue searching
   p1 = p2 + 1
 Loop

Next i End Sub

Function Shift(aString, pos) 'return shifted string (part beginning at position "pos" followed by part before it) 

 Shift = Mid$(aString, pos) & " " & Left$(aString, pos - 1)

End Function

Sub SortTitles() 

 ' sort the index() array to represent shifted titles in alphabetical order
 ' more efficient sorting algorithms can be applied here...
 switched = True
 Do While switched
   'scan array for two shifted strings in the wrong order and swap
   '(swap the index entries, not the strings)
   'use case-insensitive compare
   switched = False
   For i = 1 To nkeys - 1
     string1 = LCase(Shift(title(index(i, 1)), index(i, 2)))
     string2 = LCase(Shift(title(index(i + 1, 1)), index(i + 1, 2)))
     If string2 < string1 Then 'swap
       For j = 1 To 2
         temp = index(i, j)
         index(i, j) = index(i + 1, j)
         index(i + 1, j) = temp
       Next
       switched = True
     End If
   Next i
 Loop

End Sub

Sub PrintKWIC(linelength) 'print the KWIC index 

 spaces = Space(linelength / 2)
 Debug.Print "Cat. number", "|"; Space((linelength - 10) / 2); "KWIC string"
 Debug.Print String(linelength + 15, "-")
 For i = 1 To nkeys
   atitle = title(index(i, 1))
   pos = index(i, 2)
   'create shifted string so that keyword is centered in the line
   part2 = Mid$(atitle, pos)
   part1 = Right$(spaces & Left$(atitle, pos - 1), linelength / 2)
   kwicstring = Right$(part1, linelength / 2) & Left$(part2, linelength / 2)
   Debug.Print catno(index(i, 1)), "|"; kwicstring
 Next

End Sub

Sub KWIC() 

 'main program for KWIC index
 ReadTitles
 'set array
 ReDim index(ntitle * MAXKEYS, 2)
 'index(.,1) is title nr.
 'index(.,2) is keyword position in title
 ProcessTitles
 SortTitles
 PrintKWIC 80 'argument is the length of the KWIC lines (excluding catalog numbers)

End Sub </lang>

Output (note that some titles are truncated at the start or the end. An improvement could be to wrap these titles around if there is room on the other end): 

kwic
Cat. number   |                                   KWIC string
-----------------------------------------------------------------------------------------------
 987          |                                  Excel 2003 Formulas
 33           | Everything with Microsoft Office Excel 2003
 13           |                 Microsoft Office Excel 2003 Inside Out
 3435         |                        Mastering Excel 2003 Programming with VBA
 10           |                        Microsoft Visio 2003 User's Guide
 1244         |                                  Excel 2003 VBA Programmer's Reference
 9088         |          Beginning Excel: What-if Data Analysis Tools
 709          |                         Automated Data Analysis Using Excel
 7733         |                                   Data Analysis Using SQL and Excel
 709          |                                        Automated Data Analysis Using Excel
 9088         |                                        Beginning Excel: What-if Data Analysis T
 9088         |               Beginning Excel: What-if Data Analysis Tools
 709          |                              Automated Data Analysis Using Excel
 7733         |                                        Data Analysis Using SQL and Excel
 33           |                                 How to do Everything with Microsoft Office Exce
 1010         |               Excel for Scientists and Engineers
 33           |                              How to do Everything with Microsoft Office Excel 2
 987          |                                        Excel 2003 Formulas
 33           | to do Everything with Microsoft Office Excel 2003
 13           |                       Microsoft Office Excel 2003 Inside Out
 3435         |                              Mastering Excel 2003 Programming with VBA
 1244         |                                        Excel 2003 VBA Programmer's Reference
 709          |          Automated Data Analysis Using Excel
 7733         |            Data Analysis Using SQL and Excel
 1010         |                                        Excel for Scientists and Engineers
 9088         |                              Beginning Excel: What-if Data Analysis Tools
 987          |                             Excel 2003 Formulas
 10           |            Microsoft Visio 2003 User's Guide
 33           |                                        How to do Everything with Microsoft Offi
 13           |            Microsoft Office Excel 2003 Inside Out
 3435         |                                        Mastering Excel 2003 Programming with VB
 33           |              How to do Everything with Microsoft Office Excel 2003
 13           |                                        Microsoft Office Excel 2003 Inside Out
 10           |                                        Microsoft Visio 2003 User's Guide
 33           |    How to do Everything with Microsoft Office Excel 2003
 13           |                              Microsoft Office Excel 2003 Inside Out
 13           |     Microsoft Office Excel 2003 Inside Out
 1244         |                         Excel 2003 VBA Programmer's Reference
 3435         |                   Mastering Excel 2003 Programming with VBA
 1244         |            Excel 2003 VBA Programmer's Reference
 1010         |                              Excel for Scientists and Engineers
 7733         |                    Data Analysis Using SQL and Excel
 9088         | Beginning Excel: What-if Data Analysis Tools
 10           |                   Microsoft Visio 2003 User's Guide
 709          |                Automated Data Analysis Using Excel
 7733         |                          Data Analysis Using SQL and Excel
 3435         |  Mastering Excel 2003 Programming with VBA
 1244         |                             Excel 2003 VBA Programmer's Reference
 10           |                              Microsoft Visio 2003 User's Guide
 9088         |                       Beginning Excel: What-if Data Analysis Tools

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 ).
Retrieved from "https://rosettacode.org/wiki/User:Klever?oldid=201618"