Rosetta Code

User:Klever: Difference between revisions

User page Discussion

User:Klever (view source)

Revision as of 14:33, 23 November 2011

10,993 bytes added ,  12 years ago
m
→‎KWIC index
No edit summary
 
(10 intermediate revisions by the same user not shown)
Line 1:
{{mylangbegin}}
{{mylang|Visual BasicVBA|Active (in VB for Applications)}}
{{mylang|BASIC|Somewhat Rusty}}
{{mylang|Fortran|Stuck in Fortran 77, WATFOR, WATFIV etc.}}
Line 12:
 
=VBA Examples=
Some nontrivial VBA Examples (untilto therebe is a separate VBA categorymoved).
 
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...
 
==[[LetterDijkstra frequencyalgorithm]]==
<lang vb>
'Dijkstra globals
Public Sub LetterFrequency(fname)
Const MaxGraph As Integer = 100 'max. number of nodes in graph
'count number of letters in text file (ASCII-coded)
Const Infinity = 1E+308
'note: we count all characters but print only the letter frequencies
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 Freqs(255) As Long
Dim P(1 To MaxGraph) As Integer 'the previous/path array
Dim abyte As Byte
Dim Q(1 To MaxGraph) As Boolean 'the queue
Dim ascal as Byte 'ascii code for lowercase a
Dim ascau as Byte 'ascii code for uppercase a
Public Sub Dijkstra(n, start)
 
'simple implementation of Dijkstra's algorithm
'try to open the file
'n = number of nodes in graph
On Error GoTo CantOpen
'start = index of start node
Open fname For Input As #1
'init distances A
On Error GoTo 0
For j = 1 To n
 
A(j) = Infinity
'initialize
For i = 0 ToNext 255j
Freqs A(istart) = 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
'process file byte-per-byte
Dijkstra n, v
While Not EOF(1)
'Print solution
abyte = Asc(Input(1, #1))
Debug.Print "From", "To", "Cost", "Path"
Freqs(abyte) = Freqs(abyte) + 1
For j = 1 To n
Wend
If v <> j Then Debug.Print v, j, IIf(A(j) = Infinity, "---", A(j)), GetPath(v, j)
Close #1
Next j
 
Debug.Print
'add lower and upper case together and print result
Next v
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 (using the same graph as in the Floyd-Warshall algorithm below):
Output:
<pre>
DijkstraTest
LetterFrequency "d:\largetext.txt"
From To Cost Path
Frequencies:
a 1 2 24102 10 1 2
b 1 3 4985 40 1 2 3
c 1 4 4551 60 1 2 3 4
d 1 5 19127 14 1 2 5
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
</pre>
 
From To Cost Path
==[[Horner's rule for polynomial evaluation]]==
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
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.
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
<lang>
4 1 29 4 5 1
Public Function Horner(x, ParamArray coeff())
4 2 39 4 5 1 2
Dim result As Double
4 3 69 4 5 1 2 3
Dim ncoeff As Integer
4 5 23 4 5
 
From To Cost Path
result = 0
5 1 6 5 1
ncoeff = UBound(coeff())
5 2 16 5 1 2
 
5 3 46 5 1 2 3
For i = ncoeff To 0 Step -1
5 4 66 5 1 2 3 4
result = (result * x) + coeff(i)
Next i
Horner = result
End Function
</lang>
 
Output:
<pre>
print Horner(3, -19, 7, -4, 6)
128
</pre>
 
==[[Floyd-Warshall algorithm]]==
[[File:FloydGraph.png|thumb|250px|Graph used in this and Dijkstra's algorithm]]
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.
 
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".
 
Line 126 ⟶ 173:
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 '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
Line 142 ⟶ 191:
'inputs:
' n : number of vertices (maximum value is maxGraph)
' E(i,j) : cost (length,...) of edge from i to j or <=0"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 (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) <> 0Infinity Then A(i, j) = E(i, j) Else A(i, j) = Infinity
Next j
A(i, i) = 0
Line 162 ⟶ 211:
Next k
End Sub
 
Public Sub SolveFloydWithPaths(n)
'cf. SolveFloyd, but here we
Line 168 ⟶ 217:
For i = 1 To n
For j = 1 To n
If E(i, j) <> 0Infinity Then A(i, j) = E(i, j) Else A(i, j) = Infinity
Next j
A(i, i) = 0
Line 183 ⟶ 232:
Next k
End Sub
 
Public Function GetPath(i, j) As String
'recursively reconstruct shortest path from i to j using A and Nxt
Line 197 ⟶ 246:
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?
Line 208 ⟶ 257:
For i = 1 To n
For j = 1 To n
E(i, j) = 0Infinity
Next j
Next i
Line 219 ⟶ 268:
E(3, 4) = 20
E(3, 5) = 44
E(4, 2) = 770
E(4, 5) = 1323
E(5, 1) = 6
 
'Solve it
SolveFloyd n
 
'Print solution
'note: for large graphs the output may be too large for the Immediate panel
Line 235 ⟶ 285:
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?
Line 246 ⟶ 296:
For i = 1 To n
For j = 1 To n
E(i, j) = 0Infinity
Nxt(i, j) = 0
Next j
Line 258 ⟶ 308:
E(3, 4) = 20
E(3, 5) = 44
E(4, 2) = 770
E(4, 5) = 1323
E(5, 1) = 6
 
'Solve it
SolveFloydWithPaths n
 
'Print solution
'note: for large graphs the output may be too large for the Immediate panel
Line 274 ⟶ 325:
Next i
End Sub
</lang>
 
Output:
<pre>Floyd
Floyd
From To Cost
1 2 10
Line 284 ⟶ 334:
1 4 60
1 5 14
2 1 No path!10
2 3 30
2 4 50
2 5 4
3 1 No path!49
3 2 2759
3 4 20
3 5 3143
4 1 No path!29
4 2 739
4 3 3769
4 5 1123
5 1 No path!6
5 2 No path!16
5 3 No path!46
5 4 No path!66
 
 
FloydWithPaths
Line 308 ⟶ 357:
1 4 60 2 3
1 5 14 2
2 1 --- 10 No path! 5
2 3 30
2 4 50 3
2 5 4
3 1 --- 49 No path! 4 5
3 2 2759 4 5 1
3 4 20
3 5 3143 4 2
4 1 --- 29 No path! 5
4 2 739 5 1
4 3 3769 5 1 2
4 5 1123 2
5 1 --- 6 No path!
5 2 --- 16 No path! 1
5 3 --- 46 No path! 1 2
5 4 --- 66 No path! 1 2 3
</pre>
 
==[[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):
<pre>
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
</pre>
 
Anonymous user
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/201607...201618"