Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example:
#Compiler PBWin 10
#Compile Exe
#Dim All
%Unicode = 1
#Include "Win32API.inc"
Enum Equates Singular
IDC_GetUnique = 500
IDC_RemoveDupes
IDC_StringBuilder
End Enum
Global hDlg As Dword
Global InnerText$, UniqueWords$, Book$
Global qFreq, qStart, qStop As Quad
Function PBMain() As Long
Dialog Default Font "Tahoma", 12, 0
Dialog New Pixels, 0, "Unique Test",300,300,300,200, %WS_OverlappedWindow To hDlg
Open "constitution.txt" For Binary As #1 : Get$ #1, Lof(1), Book$ : Close #1
Control Add Button, hDlg, %IDC_GetUnique,"Get Unique", 20,10,140,25
Control Add Button, hDlg, %IDC_RemoveDupes,"Remove Dupes", 20,50,140,25
Control Add Button, hDlg, %IDC_StringBuilder,"String Builder", 20,90,140,25
QueryPerformanceFrequency qFreq
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Local i As Long
Select Case Cb.Msg
Case %WM_Command
Select Case Cb.Ctl
Case %IDC_GetUnique
UniqueWords$ = String$(Len(InnerText$),$Spc)
QueryPerformanceCounter qStart
For i = 1 To 500
If i Mod 50 = 0 Then Dialog Set Text hDlg, Str$(i) : Dialog DoEvents
InnerText$ = Book$
FMT_GetUnique
Next i
QueryPerformanceCounter qStop
Dialog Set Text hDlg, Format$((qStop-qStart)/qFreq,"###.0000") & " seconds"
ShowResults
Case %IDC_RemoveDupes
Open "constitution.txt" For Binary As #1 : Get$ #1, Lof(1), InnerText$ : Close #1
QueryPerformanceCounter qStart
For i = 1 To 500
If i Mod 50 = 0 Then Dialog Set Text hDlg, Str$(i) : Dialog DoEvents
InnerText$ = Book$
FMT_RemoveDupes
Next i
QueryPerformanceCounter qStop
Dialog Set Text hDlg, Format$((qStop-qStart)/qFreq,"###.0000") & " seconds"
ShowResults
Case %IDC_StringBuilder
Open "constitution.txt" For Binary As #1 : Get$ #1, Lof(1), InnerText$ : Close #1
QueryPerformanceCounter qStart
For i = 1 To 500
If i Mod 50 = 0 Then Dialog Set Text hDlg, Str$(i) : Dialog DoEvents
FMT_StringBuilder
Next i
QueryPerformanceCounter qStop
Dialog Set Text hDlg, Format$((qStop-qStart)/qFreq,"###.0000") & " seconds"
ShowResults
End Select
End Select
End Function
Sub Fmt_GetUnique
Local iLen, iPosA, iPosB, iPos As Long, tmp$
iLen = Len(InnerText$)
UniqueWords$ = String$(iLen,$Spc)
iPos = 1 'position where a word will be placed in B
iPosA = 1 'starting position of search for words
While iPosA < iLen
iPosB = InStr(iPosA+1,InnerText$,$Spc)
If iPosB Then
tmp$ = Mid$(InnerText$, iPosA To iPosB) 'includes the space
If InStr(UniqueWords$,tmp$)=0 Then
Mid$(UniqueWords$,iPos) = tmp$ 'put new word in B
iPos += Len(tmp$) 'next position in B to place a word
End If
Else
tmp$ = Mid$(InnerText$, iPosA) 'the rest of the string (last word)
If InStr(UniqueWords$,tmp$)=0 Then Mid$(UniqueWords$,iPos) = tmp$ 'put last word in B
iPos += Len(tmp$)
Exit Loop 'done
End If
iPosA = iPosB+1
Wend
InnerText$ = Trim$(UniqueWords$)
End Sub
Sub Fmt_RemoveDupes
Local i,iCount As Long
'put Source text into array Words()
i = ParseCount(InnerText$,$Spc)
Dim Words(i-1) As String
Parse InnerText$, Words(), $Spc 'delimiter is a space
'Sorted
Array Sort Words()
For i = UBound(Words) To 1 Step -1 'zero based array
If Words(i) = Words(i-1) Then Array Delete Words(i) : Incr iCount
Next i
ReDim Preserve Words(UBound(Words)-iCount)
InnerText$ = Join$(Words(),$Spc)
End Sub
Sub Fmt_StringBuilder
Local i,iCount As Long
End Sub
Sub ShowResults
Local iCount As Long, temp$
InnerText$ = Shrink$(InnerText$)
iCount = ParseCount(InnerText$,$Spc)
ReDim D(iCount-1) As String
Parse InnerText$, D(), $Spc
Array Sort D()
temp$ = Join$(D(),$CrLf)
? Format$((qStop-qStart)/qFreq,"###.0000") & " seconds" + $CrLf + Left$(temp$,200)
End Sub
http://www.garybeene.com/sw/gbsnippets.htm