' Function obj_heap_insert ' Object heap insert to use the heap algorithm to maintain ' a 'priority queue'. ' ' So, suppose for

' 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