Программирование на BASIC / Visual Basic / Visual Basic 6.0 / БВГ / Теория и примеры по сортировкам на VB / Примеры_на_VB6.0 / HEAPPQUE

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "HeapPQueue"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
' ************************************************
' HeapPQue.CLS
'
' Heap-based priority queue class.
' ************************************************
' Copyright (C) 1997 John Wiley & Sons, Inc.
' All rights reserved. See additional copyright
' information in RIGHTS.TXT.
' ************************************************
Option Explicit

Const WANT_FREE_PERCENT = 0.1
Const MIN_FREE = 5

Private PQueue() As Long ' The PQueue array.
Private PQueueSize As Integer ' Largest index in PQueue.
Private NumInPQueue As Integer ' # items in the PQueue

' ************************************************
' Use a preorder traversal to add the nodes below
' position Index in the heap to the string.
' ************************************************
Private Sub AddToText(txt As String, Index As Integer, depth As Integer)
If Index > NumInPQueue Then Exit Sub
txt = txt & Space$(depth) & Format$(PQueue(Index)) & vbCrLf
AddToText txt, Index * 2, depth + 2
AddToText txt, Index * 2 + 1, depth + 2
End Sub
' ************************************************
' Add a new item to the queue.
' ************************************************
Public Sub Push(value As Long)
NumInPQueue = NumInPQueue + 1
If NumInPQueue > PQueueSize Then ResizePQueue

PQueue(NumInPQueue) = value
HeapPushUp PQueue(), NumInPQueue
End Sub
' ************************************************
' Push an item down into the heap.
' ************************************************
Private Sub HeapPushDown(List() As Long, ByVal min As Long, ByVal max As Long)
Dim tmp As Long
Dim j As Long

tmp = List(min)
Do
j = 2 * min
If j <= max Then
' Make j point to the larger of the children.
If j < max Then
If List(j + 1) > List(j) Then _
j = j + 1
End If

If List(j) > tmp Then
' A child is bigger. Swap with the child.
List(min) = List(j)
' Push down beneath that child.
min = j
Else
' The parent is bigger. We're done.
Exit Do
End If
Else
Exit Do
End If
Loop
List(min) = tmp
End Sub

' ************************************************
' Push an item up into the heap from the bottom.
' ************************************************
Private Sub HeapPushUp(List() As Long, ByVal max As Integer)
Dim tmp As Long
Dim j As Integer

tmp = List(max)
Do
j = max \ 2
If j < 1 Then Exit Do
If List(j) < tmp Then
List(max) = List(j)
max = j
Else
Exit Do
End If
Loop
List(max) = tmp
End Sub
' ************************************************
' Remove an item from the priority queue.
' ************************************************
Public Function Pop() As Long
If NumInPQueue < 1 Then Exit Function

' Remove the top item.
Pop = PQueue(1)

' Move the last item to the top.
PQueue(1) = PQueue(NumInPQueue)
NumInPQueue = NumInPQueue - 1

' Make it a heap again.
HeapPushDown PQueue(), 1, NumInPQueue
End Function
' ************************************************
' Resize the queue array.
' ************************************************
Private Sub ResizePQueue()
Dim want_free As Integer

' Resize the array
want_free = WANT_FREE_PERCENT * NumInPQueue
If want_free < MIN_FREE Then want_free = MIN_FREE
PQueueSize = NumInPQueue + want_free

ReDim Preserve PQueue(1 To PQueueSize)
End Sub

' ************************************************
' Return a text representation of the queue.
' ************************************************
Public Function TextValue() As String
Dim txt As String

AddToText txt, 1, 0
TextValue = txt
End Function