(Another go round with leftl and rightl as integer variables, FB did not like.) ;(
OK since this is my first major effort, let me know what you think.
Code: Select all
'Wrd tools.bas for FB (B+=MGA) 2017-07-02
' Translating from work in JB and SmallBASIC, attempt to duplicate JB word function
' then develop tools which are very handy for treating strings as arrays.
Randomize Timer
Const XMAX = 1200
Const YMAX = 720
ScreenRes XMAX, YMAX
Width XMAX\8, YMAX\16 ' Use 8*16 font
Declare Function Wrd(s As String, wNumber As Integer) As String
Declare Function wCnt(s As String) As Integer
Declare Function wIn(s As String, Wrd As String) As Integer
Declare Function wSubst(s As String, first As Integer, last As Integer ,subst As String) As String
Declare Function wPrep(s As String) As String
Declare Function wPut(s As String, p As Integer, sPut As String) As String
Declare Function wCut(s As String , p As Integer) As String
Declare Sub wQsort(ByRef A As String, lo As Integer, hi As Integer)
Declare Sub wShuffle(ByRef A As String)
Dim As Integer t, first, last, i, wc
Dim As String testStr, cont, ts
Dim test(6) As String
test(1) = "The rain in Spain falls mainly on the plain."
test(2) = ""
test(3) = "one"
test(4) = " 1 "
test(5) = " 1 2 3 4 5 6 7 "
test(6) = " Sam Billy Sarah Beth Sid Betty Shelia Bob"
For t = 1 To 6
Cls 0
'test 1 wPrep
testStr = wPrep(test(t))
? "wPrep(testStr) = *"; testStr; "*"
'test 2 wCnt
?:? "Word count of test string is "; wCnt(testStr)
?
'test 3 Wrd the key routine of this group,
' make sure no errors are thrown if outside boundries of source
For i = 0 To 10 'never a word(s, 0) but check that does not error out
ts = Wrd(testStr, i)
Print "word "; Str(i); " of "; testStr; " = "; ts
Next
'test 4 wIn if word is In which position?
?:? "word number in test string of *Spain* is "; wIn(testStr, "Spain") 'good
? "word number in test string of *7* is "; wIn(testStr, "7")
? "word number in test string of *1 * is "; wIn(testStr, "1 ")
? "word number in test string of *1* is "; wIn(testStr, "1")
'test 5 wSubst substitute a word or more for everything between first and last section
' this one is critical for my EVAL function
first = 5 : last = 6
testStr = wSubst(testStr, first, last, "is very cold")
?:? "Testing *is very cold* wSubst at places "; first; " -"; last
? testStr
'test 6 wPut Insert or Append
?:? "Test wPut *InsertMeFirst* at 1st position."
testStr = wPut(testStr, 1, "InsertMeFirst")
Print testStr
testStr = wPut(testStr, 5, "InsertMeFifth")
Print testStr
testStr = wPut(testStr, 20, "AppendMe")
Print testStr
'test 7 wCut remove a word at a position
?:? "Test remove first word:"
testStr = wCut(testStr, 1)
Print testStr
'test 8 wQsort
?:? "Test Case Sensitive Qsort of the mutated string:"
wQsort testStr, 1, wCnt(testStr)
? testStr
?:? "Test word shuffle using Knuth method
wShuffle testStr
? testStr
?:?
'test if want to continue test with next string
Input "Press enter to continue... any + enter quits ", cont
If Len(cont) Then End
Next
'return trimmed source string s with one space between each word
Function wPrep(s As String) As String
Dim p As Integer
s = Trim(s)
If Len(s) = 0 Then wPrep = "" : Exit Function
'remove all double or more spaces
p = InStr(s, " ")
While p > 0
s = Mid(s, 1, p) + Mid(s, p + 2, Len(s) - p - 1)
p = InStr(s, " ")
Wend
wPrep = s
End Function
' This duplicates JB word$(string, wordNumber) base 1, space as default delimiter
' by returning the Nth word of source string s
' this function assumes s has been through wPrep
Function Wrd(s As String, wNumber As Integer) As String
Dim As String w
Dim As Integer i, c
If Len(s) = 0 Then Return ""
w = "" : c = 1
For i = 1 To Len(s)
If Mid(s, i, 1) = " " Then
If c = wNumber Then Return w
w = "" : c += 1
Else
w = w + Mid(s, i, 1)
End If
Next
If c <> wNumber Then Return " " Else Return w
End Function
'This function counts the words in source string s
'this function assumes s has been thru wPrep
Function wCnt(s As String) As Integer
Dim As Integer c, p, ip
If Len(s) = 0 Then wCnt = 0 : Exit Function
c = 1 : p = 1 : ip = InStr(p, s, " ")
While ip
c += 1 : p = ip + 1 : ip = InStr(p, s, " ")
Wend
wCnt = c
End Function
'Where is word In source s, 0 = Not In source
'this function assumes s has been thru wPrep
Function wIn(s As String, wd As String) As Integer
Dim As Integer wc, i
wc = wCnt(s) : wIn = 0
For i = 1 To wc
If Wrd(s, i) = wd Then wIn = i : Exit Function
Next
End Function
' substitute string in s to replace section first to last words inclusive
'this function assumes s has been thru wPrep
Function wSubst(s As String, first As Integer, last As Integer ,subst As String) As String
Dim As Integer wc, i, subF
Dim b As String
wc = wCnt(s) : b = ""
For i = 1 To wc
If first <= i And i <= last Then 'do this only once!
If subF = 0 Then b = b + subst + " " : subF = 1
Else
b = b + Wrd(s, i) + " "
End If
Next
wSubst = Trim(b)
End Function
'insert as Nth word or append into source string s
'this function assumes s has been thru wPrep
Function wPut(s As String, N As Integer, sPut As String) As String
Dim As Integer wc, i
Dim b As String
wc = wCnt(s) : b = ""
If N > wc Then wPut = Trim(s + " " + sPut) : Exit Function
For i = 1 To wc
If i = N Then b = b + sPut + " "
b = b + Wrd(s, i) + " "
Next
wPut = Trim(b)
End Function
'remove Nth word from source string s
'this function assumes s has been thru wPrep
Function wCut(s As String , N As Integer) As String
Dim As Integer wc, i
Dim b As String
wc = wCnt(s) : b = ""
For i = 1 To wc
If i <> N Then b = b + Wrd(s, i) + " "
Next
wCut = Trim(b)
End Function
' recursive Qsort on string, OK this is going to be a case sensitive sort of sort
'this function assumes s has been thru wPrep
Sub wQsort(ByRef A As String, lo As Integer, hi As Integer)
Dim As Integer nleft, nright
Dim As String pivotV, t
'hints from Rosetta Code
If hi - lo >= 1 Then 'are we there yet?
'not there yet
nleft = lo 'first index of sub array
nright = hi 'last index of sub array
pivotV = Wrd( A, ( Int( (hi - lo) / 2 ) + lo + 1 ) ) 'select any element of sub array
While nleft <= nright
While Wrd(A, nleft) < pivotV
nleft = nleft + 1
Wend
While Wrd(A, nright) > pivotV
nright = nright - 1
Wend
If nleft <= nright Then
'swap
t = Wrd(A, nright)
A = wSubst(A, nright, nright, Wrd(A, nleft))
A = wSubst(A, nleft, nleft, t)
nleft = nleft + 1
nright = nright - 1
End If
Wend
wQsort A, lo, nright
wQsort A, nleft, hi
End If
End Sub
' This shuffle based on Fisher-Yates or Knuth Method
' as taught me at JB forum when they didn't like the way I was dealing cards ;)
'this function assumes s has been thru wPrep
Sub wShuffle(ByRef A As String)
Dim As Integer wc, i, r
Dim As String t
wc = wCnt(A)
For i = wc To 2 Step -1
r = Int(Rnd * i) + 1
t = Wrd(A, i)
A = wSubst(A, i, i, Wrd(A, r))
A = wSubst(A, r, r, t)
Next
End Sub