CountInString()

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: CountInString()

Post by dodicat »

jj2007 -- one reason, you could create a new utopia in your own dinner time.

Code: Select all


Function TALLY(SomeString As String,PartString As String) As Long
    Dim As Long LenP=Len(PartString),count
    Dim As Long position=Instr(SomeString,PartString)
    If position=0 Then Return 0
    While position>0
        count+=1
        position=Instr(position+LenP,SomeString,PartString)
    Wend
    Return count
End Function

Function findAndReplace(original As String , find As String , replace As String) As String
    If Len(find) = 0 Then Return original
    Var t = tally(original , find)               'find occurencies of find
    Dim As integer found , n , staid , m
    Var Lf = Len(find) , Lr = Len(replace) , Lo = Len(original)
    Dim As integer x = Len(original) - t * Lf + t * Lr 'length of output string
    dim As String res = String(x , 0)            'output string
    Do
        If original[n] = find[0] Then            'got a possible
            For m = 0 To Lf - 1
                If original[n + m] <> find[m] Then Goto lbl 'nope
            Next m
            found = 1                            'Bingo
        End If
        If found Then
            For m = 0 To Lr - 1
                res[staid] = replace[m]          'load the replacerment
                staid += 1
            Next m
            n += Lf
            found = 0
        End If
        lbl:
        res[staid] = original[n]
        staid += 1
        n += 1
    Loop Until n >= Lo
    Return res
End Function

#Include "file.bi"
Sub savefile(filename As String,p As String)
    Dim As Integer n
    n=Freefile
    If Open (filename For Binary Access Write As #n)=0 Then
        Put #n,,p
        Close
    Else
        Print "Unable to save " + filename
    End If
End Sub
Function loadfile(file as string) as String
	If FileExists(file)=0 Then Print file;" not found":Sleep:end
   var  f=freefile
    Open file For Binary Access Read As #f
    Dim As String text
    If Lof(f) > 0 Then
      text = String(Lof(f), 0)
      Get #f, , text
    End If
    Close #f
    return text
end Function


dim as string n1=loadfile("book.htm")


print tally(n1,"hell")
print tally(n1,"Hell")
n1=findandreplace(n1,"hell","heaven")
n1=findandreplace(n1,"Hell","Heaven")
print "Done"
print tally(n1,"hell")
print tally(n1,"Hell")
savefile("NewBook.htm",n1)
print "OK"
sleep
 
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: CountInString()

Post by UEZ »

Here the function StringCount() returning the occurrence only using RegEx.

Code: Select all

'libpcre.a needed in lib folder!
#Ifdef __Fb_64bit__
	#Libpath "lib\win64\"
#Else
	#Libpath "lib\win32\"
#Endif

#Define PCRE_STATIC
#Include "pcre.bi"

Function StringRegEx(sPattern As String, sString As String, aArr() As String) As Integer 'coded by UEZ
	Const iStrVecCnt = 300

	Dim As Zstring Ptr pErrorStr, pSubStrMatchStr
	Dim As Long iErrOffset, iRegexExec, aStrVec(iStrVecCnt - 1), iResult = 0, i, j = 0, k = 1
	Dim As pcre_extra tRegexStudy
	Dim As pcre Ptr pRegexCompiled
	Dim As pcre_extra Ptr pRegexStudy

	Erase aArr
	Redim aArr(0 To iStrVecCnt)
  
	pRegexCompiled = pcre_compile(sPattern, 0, @pErrorStr, @iErrOffset, NULL)
	If pRegexCompiled = NULL Then
		Return iResult
	End If
	
	pRegexStudy = pcre_study(pRegexCompiled, 0, @pErrorStr)
	If pRegexStudy = NULL Then
		Return iResult
	End If
	
	Do 
		iRegexExec = pcre_exec(pRegexCompiled, pRegexStudy, Strptr(sString), Len(sString), j, 0, @aStrVec(0), iStrVecCnt)
		If iRegexExec > 0 Then
			For i = 0 To iRegexExec - 1
				pcre_get_substring(Strptr(sString), @aStrVec(0), iRegexExec, i, @pSubStrMatchStr)
				If k > Ubound(aArr) Then Redim Preserve aArr(0 To (Ubound(aArr) Shr 1))
				aArr(k) = *pSubStrMatchStr
				k += 1
			Next
			iResult += 1
			j = aStrVec(1)
		Endif
	Loop Until iRegexExec < 1
	Redim Preserve aArr(0 To k - 1)
	pcre_free(pRegexCompiled)
	#Ifdef PCRE_CONFIG_JIT
		pcre_free_study(pRegexStudy)
	#Else
		pcre_free(pRegexStudy)
	#Endif
	aArr(0) = Str(iResult)

	Return iResult
End Function

Function __ArrayToString(aArr() As String) as String
	Dim As String sResult
	For i As Integer = 1 To Ubound(aArr)
		sResult &= aArr(i) & Chr(10, 13)
	Next i
	Return sResult
End Function

Function StringCount(sInput As String, sSearch As String, bCaseSensitive As Boolean = False) As String
	Dim As String aResult()
	If bCaseSensitive Then 
		If StringRegEx(sSearch, sInput, aResult()) = 0 Then Return "0"
	Else
		If StringRegEx("(?i)" & sSearch, sInput, aResult()) = 0 Then Return "0"
	Endif
	Return aResult(0)
End Function

Dim As String sString = "When processing source files, FreeBASIC can parse ASCII files with Unicode escape sequences (\u), or UTF-8, UTF-16LE, UTF-16BE, UTF-32LE and UTF-32BE files, as long as they were saved with Byte Order Mark (BOM)."
? "String to test: "
? sString
?
? "Found all u: " & StringCount(sString, "u")
? "Found U only: " & StringCount(sString, "U", True)
? "Found all UTF: " & StringCount(sString, "UTF")
? "Found numbers only: " & StringCount(sString, "[\d+]+")

Sleep
Output:

Code: Select all

String to test:
When processing source files, FreeBASIC can parse ASCII files with Unicode escape sequences (\u), or UTF-8, UTF-16LE, UT
F-16BE, UTF-32LE and UTF-32BE files, as long as they were saved with Byte Order Mark (BOM).

Found all u: 9
Found U only: 6
Found all UTF: 5
Found numbers only: 5
Post Reply