Word Tools

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

Word Tools

Post by bplus »

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
Post Reply