' Function obj_heap_insert

' Object heap insert to use the heap algorithm to maintain
' a 'priority queue'.
'
' So, suppose for positive integer n we have x(i) for i =
' 1, 2, ..., n and for positive integer m <= n we want the
' m largest of the x(i). So, we allocate an array y(j), j
' = 1, 2, ..., m.
'
' Suppose we regard y as an ascending heap, e.g., so that
' y(1) <= y(j), j = 2, ..., k <= m where the number of
' locations of y in use so far is integer k where 0 <= k <=
' m.
'
' Then for i = 1, 2, ..., n, we consider inserting x(i)
' into the heap.
'
' If k < m, then we set k = k + 1 and set y(k) = x(i) and
' 'sift' to 'promote' the value in y(k) until we have a
' heap again.
'
' If k = m, then we compare x(i) and y(1). If x(i) <= y(1),
' then we are done with x(i). Else, x(i) > y(1) and y(1) is
' not among the m largest and, to 'remove' value y(1) we
' set y(1) = x(i) and 'sift' the value in y(1) to create a
' heap again.
'
' After i = n, y contains the m largest of x(i), i = 1, 2,
' ..., n.
'
' The advantage of this routine is speed: When k = m, the
' effort to insert x(i) is proportional to log(m). When k
' < m, the effort to insert x(i) may be proportional just
' to k. The worst case would be when the array x was in
' ascending order since then x(i) would have to be inserted
' for each i. Similarly, in the case the array x is in
' descending order, after m inserts, no more inserts will
' be done. For the order of array x 'random', once a
' relatively large fraction of the m largest are in the
' heap, additional inserts become relatively rare.
'
' This routine is to be 'polymorphic', that is, to work for
' essentially any user defined class my_class1 where
'
' Dim m, n As Int32
' Dim x( n ) As my_class1
' Dim y( m ) As my_class1
'
' This routine can build an ascending heap, as discussed
' above, or a descending heap. The only difference is how
' the comparisons are made in the class used for the
' interface.
'
' The interface IComparer is used. If the usual class
' Comparer is used for this interface, then this function
' builds an ascending heap, that is, where upon return
'
' y( 1 ) <= y( j ),
'
' for j = 2, 3, ..., m.

Function obj_heap_insert( _
x As Object, _
y() As Object, _
ByRef k As Int32, _
m As Int32, _
compare As IComparer) As Int32

Dim routine_name As String = "obj_heap_insert"

Dim error_code As Int32
Dim return_code As Int32 = 0
' Dim result_code As Int32
Dim message_tag As Int32

Dim i_father As Int32
Dim i_child0 As Int32
Dim i_child1 As Int32
Dim i_child2 As Int32
Dim i_2 As Int32 = 2

Try

error_code = 1001

message_tag = 1001
If console_msg_level >= console_routine_messages2 Then _
Console.WriteLine( routine_name & " " & message_tag & _
": Started ..." )

error_code = 1002

If m <= 0 Then
return_code = 1001
Goto out
End If
If k < 0 Then
return_code = 1002
Goto out
End If
If k > m Then
return_code = 1003
Goto out
End If
If y.GetUpperBound(0) < m Then
return_code = 1004
Goto out
End If

error_code = 1003
If k < m Then

i_child0 = k + 1
k = i_child0
error_code = 1004
Do ' Sift value of x into correct position.
If i_child0 < 2 Then Exit Do
i_father = i_child0 \ i_2
error_code = 1005
If compare.Compare( x, y( i_father ) ) >= 0 Then Exit Do
y( i_child0 ) = y( i_father )
i_child0 = i_father
Loop ' Sift value of x into correct position.
error_code = 1006
y( i_child0 ) = x
Goto out

End If

error_code = 1007
If compare.Compare( x, y( 1 ) ) <= 0 Then Goto out

i_father = 1

error_code = 1008
Do ' Delete value of y( 1 ) and sift x to correct position
' starting at location y( 1 )
If i_father > m \ i_2 Then Exit Do
i_child1 = i_father + i_father
If i_child1 < m Then
i_child2 = i_child1 + 1
error_code = 1009
If compare.Compare( y( i_child1 ), y( i_child2 ) ) < 0 Then
i_child0 = i_child1
Else
i_child0 = i_child2
End If
Else
i_child0 = i_child1
End If
error_code = 1010
If compare.Compare( x, y( i_child0 ) ) <= 0 Then Exit Do
y( i_father ) = y( i_child0 )
i_father = i_child0
Loop ' Delete value of y( 1 ) and sift x to correct position
' starting at location y( 1 )
y( i_father ) = x

Catch

Console.WriteLine( " " )

message_tag = 1002
Console.WriteLine( routine_name & " " & message_tag & _
": Error condition raised. " & vbCrLf & _
": error_code = " & error_code & vbCrLf & _
": err.number = " & err.number & vbCrLf & _
": err.source = " & err.source & vbCrLf & _
": err.description = " & err.description )

message_tag = 1003

Console.WriteLine( routine_name & " " & message_tag & _
": Raising error condition with error_code = " & error_code )

err.raise(error_code, routine_name)

End Try

out:

message_tag = 1004

If console_msg_level >= console_routine_messages2 Then _
Console.WriteLine( routine_name & " " & message_tag & _
": Returning." )

Return return_code

End Function ' Function obj_heap_insert