Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
#Compiler PBWin 10
#Compile Exe
#Dim All
%Unicode=1
#Include "Win32API.inc"
Type TestType
s As String * 5
a As Long
b As Long
c As Long
End Type
%IDC_Array = 500
%IDC_Disk = 501
%IDC_Textbox = 502
Global hDlg As Dword, WordList(), tData As TestType
Global qStart, qStop, qFreq As Quad, fName$, varLen As Long
Function PBMain() As Long
Dialog New Pixels, 0, "Test Code",300,300,200,200, %WS_OverlappedWindow To hDlg
Control Add Button, hDlg, %IDC_Array, "Search_Array", 50,10,100,20
Control Add Button, hDlg, %IDC_Disk, "Search_Disk", 50,40,100,20
Control Add TextBox, hDlg, %IDC_TextBox, "47500", 50,70,100,20
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Local sTerm$, iPos&, iResult As Long
Select Case Cb.Msg
Case %WM_InitDialog
QueryPerformanceFrequency qFreq
fName$ = Exe.Path$ + "tempsearch.dat"
CreateFakeData
varLen = Len(WordList(0))
Case %WM_Command
Select Case Cb.Ctl
Case %IDC_Array
Control Get Text hDlg, %IDC_TextBox To sTerm$
QueryPerformanceCounter qStart
iResult = Search_Array(sTerm$,iPos)
QueryPerformanceCounter qStop
? IIf$(iResult, "Found at " + Str$(iPos), "Not found.") + " " + Format$((qStop-qStart)/qFreq,"###.000") & " seconds"
? WordList(iPos).s + Str$(WordList(iPos).a) + Str$(WordList(iPos).b) + Str$(WordList(iPos).c)
Case %IDC_Disk
Control Get Text hDlg, %IDC_TextBox To sTerm$
QueryPerformanceCounter qStart
iResult = Search_Disk(sTerm$,iPos)
QueryPerformanceCounter qStop
? IIf$(iResult, "Found at " + Str$(iPos), "Not found.") + " " + Format$((qStop-qStart)/qFreq,"###.000") & " seconds"
? WordList(iPos).s + Str$(WordList(iPos).a) + Str$(WordList(iPos).b) + Str$(WordList(iPos).c)
End Select
End Select
End Function
Sub CreateFakeData
Local i As Long
'Array data
ReDim WordList(99998)
For i = 0 To 700 : WordList(i).s = Format$(i,"00000") : Next i '699 ... 700 ... 702 ... 703
For i = 701 To 99998 : WordList(i).s = Format$(i+1,"00000") : Next i '701 missing
WordList(47499).a = 9 : WordList(47499).b = 8 : WordList(47499).c = 7
WordList(47500).a = 5 : WordList(47500).b = 4 : WordList(47500).c = 3
WordList(47501).a = 3 : WordList(47501).b = 2 : WordList(47501).c = 1
'File data
If IsFile(fName$) Then Kill fName$
Open fName$ For Binary As #1 : Put #1, , WordList() : Close #1
End Sub
Function Search_Array(sTerm As String, iPos As Long) As Long
'Function returns 1=found 0=notfound
'iPos is position found (value means nothing if sTerm not found)
Local Upper As Long, Lower As Long
Lower = LBound(WordList) : Upper = UBound(WordList)
'test boundary values
If sTerm < WordList(Lower).s Then Exit Function
If sTerm > WordList(Upper).s Then Exit Function
If sTerm = WordList(Lower).s Then iPos = Lower : Function = 1 : Exit Function
If sTerm = WordList(Upper).s Then iPos = Upper : Function = 1 : Exit Function
'search through remaining entries
Do Until (Upper <= (Lower+1))
iPos = (Lower + Upper) / 2
If sTerm > WordList(iPos).s Then
Lower = iPos
ElseIf sTerm < WordList(iPos).s Then
Upper = iPos
Else
Function = 1 : Exit Function 'found
End If
Loop
End Function
Function Search_Disk(sTerm As String, iPos As Long) As Long
'Function returns 1=found 0=notfound
'iPos is position found (value means nothing if sTerm not found)
Open fName$ For Binary As #77 Base = 0
Local Upper As Long, Lower As Long
Lower = LBound(WordList) : Upper = UBound(WordList)
'test boundary values
If sTerm < dWordList(Lower) Then Exit Function
If sTerm > dWordList(Upper) Then Exit Function
If sTerm = dWordList(Lower) Then iPos& = Lower : Function = 1 : Exit Function
If sTerm = dWordList(Upper) Then iPos& = Upper : Function = 1 : Exit Function
'search through remaining entries
Do Until (Upper <= (Lower+1))
iPos = (Lower + Upper) / 2
If sTerm > dWordList(iPos) Then
Lower = iPos
ElseIf sTerm < dWordList(iPos) Then
Upper = iPos
Else
Function = 1 : Exit Function 'found
End If
Loop
Close #77
End Function
Function dWordList(iPos As Long) As String 'returns String * 5 at iPos
Get #77, iPos * varLen, tData 'get complete TestType
Function = tData.s
End Function
'gbs_01217
'Date: 05-11-2013
http://www.garybeene.com/sw/gbsnippets.htm