POWERBASIC
This bisort function required:
#REGISTER NONE
to avoid conflicts between the assembler code and the BASIC compilation.
#COMPILE EXE
#DIM ALL
' SORTIT
' Indexer using a MergeSort and Callbacks
' 7 July 2007
' Charles E V Pegge
' The bisort function is written in assembler, and based on a MergeSort
' which is one of the most efficient sort algorithms available, requiring
' n/2 * log2(n) comparisons.
'
' For example, A database of 1 meg data elements would require 10 meg comparisons
' whereas a simple pick-one sort would take n*n/2 = 500 gig comparisons.
'
' The bisort function requires twice the workspace of the final index, since it
' shuttles the indices from on buffer to the other during the merge sort process.
'
' This function uses a callback Chooser function to make each comparison, so
' it can be applied to any type of data on any criterion. The output is
' an array of 4 byte integers indexing the array of data elements.
' The index array must first be initialised with a set of indices, one for each
' data element. The bisort function then rearranges the order of these indice
' in the array.
' USING POWERBASIC ver 8.x
' test bed for bisort
'FOR CALLBACK CHOOSER FUNCTION
'declare function chooser_callback(byval a as long, byval b as long ) as long
'FOR INDEX AND DATA ARRAYS
' CALLBACK TO MAKE THE CHOICE
' choose between first and second or abort the sorting process
' this is called by the bisort function
'
' Parameters:
' first index number for data element
' second index number for data element
'
' Return:
' 1 for first choice 2 for second choice 0 to abort the bisort function
'
GLOBAL rs() AS STRING
GLOBAL ri() AS LONG
FUNCTION ChooseWhich (BYVAL first AS LONG, BYVAL second AS LONG) AS LONG
'
IF rs(first) > rs(second) THEN FUNCTION = 2 ELSE FUNCTION=1
'function=0 ' to abandon the sort
END FUNCTION
' MERGE SORT
' requires sz*2 work space
'
' parameters
' 1 p pointer to index array
' 2 sz size of index array in bytes ( = data elements *4 )
' 3 cbk address of Choosing function for callback
' Return:
' 0
'
FUNCTION bisort (BYVAL p AS LONG PTR,BYVAL sz AS LONG, BYVAL cbk AS LONG) AS LONG
#REGISTER NONE
DIM blk AS LONG, lmt AS LONG, q AS LONG
DIM ans AS LONG, first AS LONG, second AS LONG
'asm
'========================='
' BINARY SORT '
'========================='
' p sz ' inputs: data base pointer
' blk lmt ' local vars: block_size source limit dest limit
'
'-------------------------'
! mov dword ptr blk,4 ' stating block size as long word
! mov ebx,p ' base pointer to data
! add ebx,sz ' calc base of transfer buffer
'
'========================='
new_pass: ' for each block size
'========================='
'
! mov esi,p ' source pointer
! mov eax,esi ' copy to esi
! add eax,sz ' add entire data length
! mov lmt,eax ' save as source boundary
'-------------------------'
! mov q,ebx '
'-------------------------'
! mov edi,esi ' copy 1st pointer to second pointer
! add edi,blk ' add block to offset second pointer
'
'========================='
set_limits: '
'========================='
! mov edx,blk ' load block size
! mov ecx,edx ' ecx and edx to be used as kimit checks
! add ecx,esi ' add offset block1
! add edx,edi ' add offset block2
! mov eax,lmt ' load source boundary
! cmp ecx,eax ' compare esi block limit with source boundary
! jle okecx ' skip if okay
! mov ecx,eax ' clip ecx to source boundary
okecx: '
! cmp edx,eax ' compare edi block limit with source boundary
! jle okedx ' skip if okay
! mov edx,eax ' clip edx to source boundary
okedx: '
'========================='
block_merging: ' loop
'========================='
! cmp esi,ecx ' check limit for esi
! jl ok1 ' okay procede to check edx
'-------------------------'
tran2: ' otherwise copy the over remainder of edx block
! cmp edi,edx ' any left?
! jge next_block_pair ' if not then next block pair to compare
! mov eax,[edi] ' load second data for transfer
! mov [ebx],eax ' store indexer word
! add edi,4 ' add stride o source
! add ebx,4 ' add stride to dest
! jmp tran2 ' repeat if any left to transfer
'-------------------------'
ok1: '
'-------------------------'
! cmp edi,edx '
! jl ok2 ' then proced to compare
tran1: ' otherwise transfer remainder of 1st
! cmp esi,ecx '
! jge next_block_pair '
! mov eax,[esi] ' load second data for transfer
! mov [ebx],eax ' store indexer word
! add esi,4 ' add stride o source
! add ebx,4 ' add stride to dest
! jmp tran1 ' repeat
'-------------------------'
ok2: ' ready to do comparison
'*************************'
'mov eax,[esi] ' load first data
'cmp eax,[edi] ' compare with second data
'-------------------------'
' The Callback method:
! mov eax,[esi] ' get index in [esi]
! mov first,eax ' save in First
! mov eax,[edi] ' get index in [edi]
! mov second,eax ' save in Second
! push ecx ' save limit reg ecx
! push edx ' save limit reg edx
'end asm ' other registers will be preserved
CALL DWORD cbk USING ChooseWhich(first,second) ' make the callback
'asm ' reenter assembler
'! mov reax,eax ' diagnostic
! pop edx ' recover edx
! pop ecx ' recover ecx
' other registers were preserved except eax
' result expected in eax
! cmp eax,0 ' is it zero ?
! jz xit ' then terminate immediately
! cmp eax,1 ' is it the first choice?
! jz chosen1 ' first is chosen so skip
'*************************'
! mov eax,[edi] ' load second data for transfer
! mov [ebx],eax ' store indexer word
! add edi,4 ' add stride o source
! add ebx,4 ' add stride to dest
! jmp block_merging ' continue sort
'-------------------------'
chosen1: '
'-------------------------'
! mov eax,[esi] ' load second data for transfer
! mov [ebx],eax ' store indexer word
! add esi,4 ' add stride to source
! add ebx,4 ' add stride to dest
! jmp block_merging ' continue sort
'
'========================='
'
next_block_pair: '
'-------------------------'
! mov eax,blk
! add esi,eax ' add for next block comparison
! add edi,eax '
! cmp esi,lmt ' check against data boundary
! jl set_limits ' continue if less
'========================='
next_pass: '
'-------------------------'
! shl dword ptr blk,1 ' double block size
! mov ebx,q ' restore ebx base value
! xchg p,ebx ' swap source and dest pointers
! mov eax,blk '
! cmp eax,sz ' check block size against size of data
! jl new_pass ' repeat with larger blocks
'========================='
buffer_tran: '
' data is now held at p (due to xchg)
' move data back to base
! mov edx,p '
! cmp edx,ebx ' is p less than ebx?
! jl xit ' then no need to transfer
'-------------------------'
! mov ecx,sz ' use ecx as a down counter
'-------------------------'
bt_loop: ' loop
'-------------------------'
! mov eax,[edx] ' get source
! mov [ebx],eax ' move to dest
! add edx,4 ' inc source pointer
! add ebx,4 ' inc dest pointer
! sub ecx,4 ' decrement down counter
! jg bt_loop ' continue loop till zero
'========================='
! mov eax,sz ' get data size
! sub p,eax ' set p to its original value
! mov eax,0 ' return 0 for okay
! jmp xit ' finish
'========================='
serrors: '
'
'========================='
xit: '
! mov function,eax '
'========================='
'end asm
END FUNCTION
FUNCTION PBMAIN () AS LONG
DIM ri(2000) AS GLOBAL LONG ' must be twice the number of data elements
DIM rs(1000) AS GLOBAL STRING ' test sample of random string data
DIM p AS LONG PTR
DIM sz AS LONG
'GET POINTER FOR CHOOSER FUNCTION
DIM cb AS LONG
cb=CODEPTR(ChooseWhich)
'FOR EXAMPLE DATA
DIM i AS LONG, j AS LONG
DIM e AS LONG
DIM r AS LONG
DIM rst AS STRING
'FOR DIAGNOSTICS'
GLOBAL reax AS LONG, rebx AS LONG, recx AS LONG, redx AS LONG, resp AS LONG, rebp AS LONG, resi AS LONG, redi AS LONG
e=532 ' number of data elements
p=VARPTR(ri(0))
'GENERATE RANDOM STRINGS AND INDEX
FOR i=0 TO e-1
ri(i)=i ' this is our initial index for each element in the string array.
rst=STRING$(16," ")
FOR j= 1 TO 16 ' generate a string of 16 random uppercase characters
r=RND(1)*25+65
MID$(rst,j)=CHR$(r)
NEXT
rs(i)=rst ' store a random string in each data element in the string array
'print rst
NEXT
sz=e*4 ' sizr of index block in bytes
bisort(p,sz,cb)
DIM s AS STRING
DIM k AS LONG
s=SPACE$(2000): k=1
' DISPLAY SAMPLES OF RESULT
FOR i=0 TO 15
'print ri(i)
'print ri(i)
MID$(s,k)=rs(ri(i))+$CR:k=k+18
NEXT
IF e>31 THEN
MID$(s,k)="----------------"+$CR:k=k+18
FOR i=e-16 TO e-1
'print ri(i)
'print rs(ri(i))
MID$(s,k)=rs(ri(i))+$CR:k=k+18
NEXT
END IF
'DIAGNOSTICS
'print "eax ";hex$(reax)
'print "ecx ";hex$(recx)
'print "edx ";hex$(redx)
'print "ebx ";hex$(rebx)
'print "esp ";hex$(resp)
'print "ebp ";hex$(rebp)
'print "esi ";hex$(resi)
'print "edi ";hex$(redi)
MSGBOX LEFT$(s,k-1)
END FUNCTION
