CountInString()

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

Re: CountInString()

Postby dodicat » Jan 14, 2019 12:30

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: 337
Joined: May 05, 2017 19:59
Location: Germany

Re: CountInString()

Postby UEZ » Jan 14, 2019 14:07

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

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 2 guests