SortableCollection

SortableCollection.lss

%REM
	Class SortableCollectionItem
	Enumerable object to be used in sortable collections
	Sort comparison is provided by extending of the method CompareTo
	CompareTo method expects object of the same type as the current
	
	@author Jiri Krakora
	@date 26.06.2012
	@extends CollectionItem 
	@revision 1.0 Release
%END REM
Public Class SortableCollectionItem As CollectionItem
	
	%REM
		Campare current collection item with another one of the same type to do the sorting
		@param SortableCollectionItem and extended objects
		@return true/false
	%END REM
	Public Function CompareTo(collectionItem As Variant) As Boolean
		' in inherited classes implement a comparison
		' param collectionItem should be the same type as current item
	End Function
End Class

%REM
	Class SortableCollection
	Generic objects SortableCollection class
	Can be used any user-defined objects,
		but must extend SortableCollectionItem class
	
	@author Jiri Krakora
	@date 26.06.2012
	@uses Stack, SortableCollectionItem
	@extends Collection
	@revision 1.0 Release
	
	Example
	----------------------------------------------------------------------------
	Public Class TestItemInt As SortableCollectionItem
		Private oI As Integer
		
		Public Property Set I As Integer
			Let Me.oI = I
		End Property
		
		Public Property Get I As Integer
			Let I = Me.oI
		End Property
		
		Public Function CompareTo(collectionItem As Variant) As Boolean
			If collectionItem.I > Me.I Then
				Let CompareTo = True
			End If
		End Function
		
		Public Function ToString As String
			Let ToString = CStr(Me.oI)
		End Function
	End Class
	
	Dim item As TestItemInt
	Dim col As New SortableCollection
	Dim i As Integer
	
	For i = 1 To 10
		Set item = New TestItemInt
		Let item.I = Rnd() * 100
		Call col.Add(item)
	Next
	
	Call col.Sort
	
	While col.MoveNext
		Print col.Current.ToString
	Wend
%END REM
Public Class SortableCollection As Collection
	Private oStack As Stack
	
	%REM
		Only add item into collection
		@param item
		@return true/false
	%END REM
	Private Function AddItemIntoCollection(item As Variant) As Boolean
		On Error 182 GoTo eh182					' when asking for property ID
		On Error GoTo eh
		
		If DataType(item) = 34 Then				' is it user defined object?
			If Not item Is Nothing Then			' is it instantiated?
				If DataType(item.ID) = 8 Then	' is property ID string?
					If item.ID = "" Then		' if ID is empty, create unique one
						Let item.ID = Me.GetUniqueItemID
					End If
					
					If Not IsElement(Me.oCollection(item.ID)) Then
						Set Me.oCollection(item.ID) = item
						Let AddItemIntoCollection = True
					End If
				End If
			End If
		End If
		
es:
		Exit Function
eh182:
		Resume es
eh:
		Resume es
	End Function
	
	%REM
		description
		@param
	%END REM
	Public Sub Sort
		Dim l As Long
		Dim r As Long
		
		Set Me.oStack = New Stack(0)
		
		Let l = 0
		Let r = Me.oUpperBound
		
		Call Me.Quicksort(l, r)
	End Sub
	
	%REM
		description
		@param
	%END REM
	Private Sub Quicksort(ByVal l As Long, ByVal r As Long)
		Dim pivot As Long
		
		Call Me.oStack.Push(l)
		Call Me.oStack.Push(r)
		
		While Not Me.oStack.IsEmpty
			Let r = Me.oStack.Pop()
			Let l = Me.oStack.Pop()
			
			If r > l Then
				Let pivot = Me.SetPivot(l, r)
				
				' sort left side from pivot
				Call Me.oStack.Push(l)
				Call Me.oStack.Push(pivot)
				
				' sort right side from pivot
				Call Me.oStack.Push(pivot + 1)
				Call Me.oStack.Push(r)
			End If
		Wend
	End Sub
	
	%REM
		Set pivot position between smaller items on the left and larger on the right
		@param left bound of the items array
		@return right bound of the items array
	%END REM
	Private Function SetPivot(l As Long, r As Long) As Long
		Dim i As Long
		Dim boundary As Long
		Dim itemI As Variant
		Dim itemL As Variant
		
		Let boundary = l
		
		' get boundary position for pivot
		For i = l + 1 To r
			Set itemI = Me.oCollection(Me.oIndex(i))
			Set itemL = Me.oCollection(Me.oIndex(l))
			
			If itemI.CompareTo(itemL) Then
				Let boundary = boundary  + 1
				Call Swap(i, boundary)
			End If
		Next
		
		' set pivot as a boundary
		Call Me.Swap(l, boundary)
		
		Let SetPivot = boundary
	End Function
	
	%REM
		Swap two values in the collection
		@param array to be sorted
		@param left position
		@param right position
	%END REM
	Private Sub Swap(l As Long, r As Long)
		Dim tmp As String
		
		Let tmp = Me.oIndex(r)
		Let Me.oIndex(r) = Me.oIndex(l)
		Let Me.oIndex(l) = tmp
	End Sub
End Class