' Ascending integer (Int32) heap sort.
'
' For i = 1, 2, ..., n, sort components of key_array(i)
' into ascending order using heap sort.
'
' We check parameters for reasonable values and, in case of
' a error, raise the error condition.
'
' Upon return, for i = 1, 2, ..., n - 1,
'
' key_array( i ) <= key_array( i + 1 )
'
' The code here is 'structured' in the sense of E. Dijkstra
' and, thus, is without the GOTO statements of own Watson
' PL/I heap sort code.
'
' The array subscript logic here is done carefully enough
' that it should never overflow even for the largest
' possible value of n.
'
' For some constant k (depending on the computer, compiler,
' etc. but not depending on the parameters) the execution
' time is guaranteed to be closely just
'
' k*n*log(n)
'
' in the worst case.
'
' The code here needs a 'sift' loop in two places; the code
' is the same in both places.
'
' The work here is 'in place', that is, uses no storage
' whose size depends on the passed parameters.
'
Sub ai_heap_sort02( _
ByRef key_array() As Int32, _
ByVal n As Int32 )
Dim routine_name As String = "ai_heap_sort02"
Dim error_code As Int32 = 0
Dim i_2 As Int32 = 2
Dim i_first, i_middle, i_last As Int32
Dim i_father0 As Int32
Dim i_father, i_child1, i_child2, i_max_child As Int32
' We need one working location of data type the same as the
' components of parameter key_array():
Dim key_father As Int32
Try
' Get started:
error_code = 1001
If n <= 0 Then err.raise(error_code, routine_name)
error_code = 1002
If key_array.GetUpperBound(0) < n Then
err.raise(error_code, routine_name)
End If
error_code = 1003
i_first = 1
i_last = n
i_middle = i_last \ i_2
i_father0 = i_middle + 1
' Build heap
Do
i_father0 = i_father0 - 1
If i_father0 < i_first Then Exit Do
key_father = key_array( i_father0 )
i_father = i_father0
' Sift
Do
If i_father < i_middle Then
i_child1 = i_father + i_father
i_child2 = i_child1 + 1
If key_array( i_child1 ) > key_array( i_child2 ) Then
i_max_child = i_child1
Else
i_max_child = i_child2
End If
If key_array( i_max_child ) > key_father Then
key_array( i_father ) = key_array( i_max_child )
i_father = i_max_child
Continue Do
Else
key_array( i_father ) = key_father
Exit Do
End If
Else ' i_father >= i_middle
If i_father > i_middle Then
key_array( i_father ) = key_father
Exit Do
End If
i_child1 = i_father + i_father ' i_father = i_middle
If i_child1 < i_last Then
i_child2 = i_child1 + 1
If key_array( i_child1 ) > key_array( i_child2 ) Then
i_max_child = i_child1
Else
i_max_child = i_child2
End If
Else ' i_child1 = i_last
i_max_child = i_child1
End If
If key_array( i_max_child ) > key_father Then
key_array( i_father ) = key_array( i_max_child )
key_array ( i_max_child ) = key_father
Else
key_array ( i_father ) = key_father
End If
Exit Do
End If
Loop ' End of sift loop
Loop ' End of build heap loop
' Sort heap
i_first = 1
i_last = n
Do
key_father = key_array( i_last )
key_array( i_last ) = key_array( i_first )
key_array( i_first ) = key_father
i_father = i_first
i_last = i_last - 1
If i_last <= i_first Then Exit Do
i_middle = i_last \ 2
' Sift
Do
If i_father < i_middle Then
i_child1 = i_father + i_father
i_child2 = i_child1 + 1
If key_array( i_child1 ) > key_array( i_child2 ) Then
i_max_child = i_child1
Else
i_max_child = i_child2
End If
If key_array( i_max_child ) > key_father Then
key_array( i_father ) = key_array( i_max_child )
i_father = i_max_child
Continue Do
Else
key_array( i_father ) = key_father
Exit Do
End If
Else ' i_father >= i_middle
If i_father > i_middle Then
key_array( i_father ) = key_father
Exit Do
End If
i_child1 = i_father + i_father ' i_father = i_middle
If i_child1 < i_last Then
i_child2 = i_child1 + 1
If key_array( i_child1 ) > key_array( i_child2 ) Then
i_max_child = i_child1
Else
i_max_child = i_child2
End If
Else ' i_child1 = i_last
i_max_child = i_child1
End If
If key_array( i_max_child ) > key_father Then
key_array( i_father ) = key_array( i_max_child )
key_array ( i_max_child ) = key_father
Else
key_array ( i_father ) = key_father
End If
Exit Do
End If
Loop ' End of sift loop
Loop ' End of sort heap loop
Catch
err.raise(error_code, routine_name)
End Try
out:
Return
End Sub