Word Tools

New to FreeBASIC? Post your questions here.
bplus
Posts: 56
Joined: May 01, 2017 15:57

Word Tools

Postby bplus » Jul 02, 2017 17:27

With Width tip for font size, I can see what I am doing! :)

(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

Return to “Beginners”

Who is online

Users browsing this forum: Bing [Bot], Exabot [Bot] and 5 guests