#include Once "window9.bi"

Type THASHDATA
	
	pszKey As Zstring Ptr =0
	
	pszValue As Any Ptr =0
	
End Type

Type THLIST Extends THASHDATA
	
	As THLIST Ptr p =0
	
End Type

Type TGLLIST
	
	As THLIST Ptr pFirst =0
	
	As THLIST Ptr pEnd =0
	
	Declare Sub add_last (pszKey As Zstring Ptr , pszValue As Any Ptr)
	
	Declare Sub delete_element (pszKey As Zstring Ptr , bFlagFreeMemoryStrings As Long = 0)
	
	Declare Function get_element ( pszKey As Zstring Ptr) As THLIST Ptr
	
End Type

Sub TGLLIST.add_last (pszKey As Zstring Ptr , pszValue As Any Ptr)
	
	Dim As THLIST Ptr nw = Allocate(Sizeof(THLIST))
	
	If nw =0 Then 
		
		print "Allocated memory error in TGLLIST.add_last!"
		
		Exit Sub
		
	EndIf
	
	nw->pszKey =pszKey
	
	nw->pszValue =pszValue
	
	nw->p =0
	
	If pFirst =0 Then
		
		pFirst =nw
		
		pEnd =pFirst
		
	Else
		
		pEnd->p =nw
		
		pEnd =nw
		
	Endif
	
End Sub

Sub TGLLIST.delete_element (pszKey As Zstring Ptr , bFlagFreeMemoryStrings As Long = 0)
	
	Dim As THLIST Ptr pTemp =pFirst, pTempOld
	
	pTempOld =pTemp
	
	While pTemp
		
		If pTemp->pszKey andalso *(pTemp->pszKey) =*pszKey Then
			
			If pTemp->p <> 0 Then
				
				If pTemp =pFirst Then
					
					pFirst =pTemp->p
					
				Else
					
					pTempOld->p =pTemp->p
					
				Endif
				
			Else
				
				If pTemp =pFirst Then
					
					pFirst =0
					
					pEnd =0
					
				Else
					
					pTempOld->p =0
					
					pEnd =pTempOld
					
				Endif
				
			Endif
			
			Deallocate(pTemp->pszKey)
			
			If bFlagFreeMemoryStrings Then
				
				If pTemp->pszValue Then
					
					Deallocate(pTemp->pszValue)
					
				Endif
				
			Endif
			
			Deallocate(pTemp)
			
			Exit While
			
		Endif
		
		pTempOld =pTemp
		
		pTemp =pTemp->p
		
	Wend
	
End Sub

Function TGLLIST.get_element ( pszKey As Zstring Ptr) As THLIST Ptr
	
	Dim As THLIST Ptr pTemp =pFirst
	
	Dim As Long iLen =Len(*pszKey)
	
	While pTemp
		
		If Len(*(pTemp->pszKey)) =iLen Andalso *(pTemp->pszKey) =*pszKey Then
			
			Return pTemp
			
		Endif
		
		pTemp =pTemp->p
		
	Wend
	
End Function

Type THASHITEM Extends THASHDATA
	
	pList As TGLLIST Ptr
	
	iFdelete As Long
	
End Type

Type THASHTABLE
	
	pArray As THASHITEM Ptr
	
	iCountItem As Ulong
	
	iSize As Ulong
	
	Declare Constructor()
	
	Declare Sub deleteitem(pszKey As Zstring Ptr, bFlagFreeMemoryStrings As Long = 0)
	
	Declare Sub cleartable(bFlagFreeMemoryStrings As Long = 0)
	
	Declare Sub freetable()
	
	Declare Function count() As Long
	
	Declare Function size() As Long
	
	Declare Sub insert(pszKey As Zstring Ptr , pszValue As Any Ptr , bFlagFreeMemoryStrings As Long = 0)
	
	Declare Sub add_rehash(pNew As THASHITEM Ptr , pszKey As Zstring Ptr , pszValue As Any Ptr)
	
	Declare Function find(pszKey As Zstring Ptr) As Any Ptr
	
	Declare Function hash_horner(psz As Zstring Ptr) As Long
	
	Declare Sub rehash()
	
End Type

Constructor THASHTABLE()
	
	iCountItem =0
	
	iSize =64
	
	pArray =Callocate(Sizeof(THASHITEM)*(iSize+4))
	
	if pArray = 0 then
		
		print "Allocated memory error in Constructor THASHTABLE!"
		
	EndIf
	
End Constructor

Sub THASHTABLE.deleteitem(pszKey As Zstring Ptr, bFlagFreeMemoryStrings As Long = 0)
	
	Dim As Long iIndex =hash_horner(pszKey)
	
	If pArray[iIndex].pszKey Then
		
		If pArray[iIndex].iFdelete =0 Andalso *(pArray[iIndex].pszKey) =*pszKey Then
			
			Deallocate(pArray[iIndex].pszKey)
			
			If bFlagFreeMemoryStrings Then
				
				If pArray[iIndex].pszValue Then
					
					Deallocate(pArray[iIndex].pszValue)
					
				Endif
				
			Endif
			
			pArray[iIndex].iFdelete =1
			
		Else
			
			If pArray[iIndex].pList Then
				
				pArray[iIndex].pList->delete_element(pszKey , bFlagFreeMemoryStrings)
				
			Endif
			
		Endif
		
		iCountItem-=1
		
		If iCountItem*4 <iSize Then
			
			rehash()
			
		Endif
		
	Endif
	
End Sub

Sub THASHTABLE.cleartable(bFlagFreeMemoryStrings As Long = 0)
	
	For i As Long =0 To iSize
		
		If pArray[i].pszKey Then
			
			If pArray[i].iFdelete =0 Then
				
				Deallocate(pArray[i].pszKey)
				
				If bFlagFreeMemoryStrings Then
					
					If pArray[i].pszValue Then
						
						Deallocate(pArray[i].pszValue)
						
					Endif
					
				Endif
				
				pArray[i].pszKey =0
				
				pArray[i].pszValue =0
				
			Endif
			
			If pArray[i].pList Then
				
				Dim As THLIST Ptr pTemp , pTemp2
				
				pTemp =pArray[i].pList->pFirst
				
				pTemp2 =pArray[i].pList->pFirst
				
				While pTemp
					
					pTemp2 =pTemp->P
					
					if pTemp->pszKey then Deallocate(pTemp->pszKey)
					
					If bFlagFreeMemoryStrings Then
						
						If pTemp->pszValue Then
							
							Deallocate(pTemp->pszValue)
							
						Endif
						
					Endif
					
					Deallocate(pTemp)
					
					pTemp =pTemp2
					
				Wend
				
				Deallocate(pArray[i].pList)
				
				pArray[i].pList =0
				
			Endif
			
		Endif
		
	Next
	
	iCountItem =0
	
	rehash()
	
End Sub

Sub THASHTABLE.freetable()
	
	if pArray then Deallocate(pArray)
	
End Sub

Function THASHTABLE.count() As Long
	Return iCountItem
End Function

Function THASHTABLE.size() As Long
	Return iSize
End Function

Sub THASHTABLE.insert(pszKey As Zstring Ptr , pszValue As Any Ptr , bFlagFreeMemoryStrings As Long = 0)
	
	If pszKey =0 Orelse pszValue =0 Then
		
		? "Invalidate value!"
		
		Exit Sub
		
	Endif
	
	If iCountItem >(iSize Shr 1) Andalso iCountItem <32770 Then
		
		reHash()
		
	Endif
	
	Dim As Long iIndex =hash_horner(pszKey)
	
	If pArray[iIndex].pszKey =0 Orelse pArray[iIndex].iFdelete Then
		
		pArray[iIndex].pszKey =Allocate((Len(*pszKey)+1)*Sizeof(Zstring))
		
		if pArray[iIndex].pszKey = 0 then
			
			print "Allocated memory error in THASHTABLE.insert!"
			
			exit sub
			
		EndIf
		
		*(pArray[iIndex].pszKey) =*pszKey
		
		pArray[iIndex].pszValue =pszValue
		
		If pArray[iIndex].iFdelete Then pArray[iIndex].iFdelete =0
		
	Else
		
		If *(pArray[iIndex].pszKey) =*pszKey Then
			
			If bFlagFreeMemoryStrings Andalso pArray[iIndex].pszValue Then
				
				Deallocate(pArray[iIndex].pszValue)
				
			Endif
			
			pArray[iIndex].pszValue =pszValue
			
			Exit Sub
			
		Endif
		
		Dim As THLIST Ptr pPrevData
		
		If pArray[iIndex].pList =0 Then
			
			pArray[iIndex].pList =Callocate(Sizeof(TGLLIST))
			
			if pArray[iIndex].pList = 0 then
				
				print "Allocated memory error in THASHTABLE.insert!"
				
				exit sub
				
			EndIf
			
		Else
			
			pPrevData = pArray[iIndex].pList->get_element(pszKey)
			
			If pPrevData Then
				
				If bFlagFreeMemoryStrings Andalso pPrevData->pszValue Then
					
					Deallocate(pPrevData->pszValue)
					
				Endif
				
				pPrevData->pszValue = pszValue
				
				Exit Sub
				
			Endif
			
		Endif
		
		Dim As Zstring Ptr pTempKey =Allocate((Len(*pszKey)+1)*Sizeof(Zstring))
		
		if pTempKey then
			
			*pTempKey =*pszKey
			
			pArray[iIndex].pList->add_last(pTempKey , pszValue)
			
		else
			
			print "Allocated memory error in THASHTABLE.insert!"
			
			exit sub
			
		endif
		
	Endif
	
	iCountItem+=1
	
End Sub

Sub THASHTABLE.add_rehash(pNew As THASHITEM Ptr , pszKey As Zstring Ptr , pszValue As Any Ptr)
	
	Dim As Long iIndex =hash_horner(pszKey)
	
	If pNew[iIndex].pszKey =0 Then
		
		pNew[iIndex].pszKey =pszKey
		
		pNew[iIndex].pszValue =pszValue
		
	Else
		
		If pNew[iIndex].pList =0 Then
			
			pNew[iIndex].pList =Callocate(Sizeof(TGLLIST))
			
			if pNew[iIndex].pList = 0 then
				
				print "Allocated memory error in THASHTABLE.add_rehash!"
				
				exit sub
				
			EndIf
			
		Endif
		
		pNew[iIndex].pList->add_last(pszKey , pszValue)
		
	Endif
	
End Sub

Function THASHTABLE.find(pszKey As Zstring Ptr) As Any Ptr
	
	If pszKey =0 Then
		
		? "Invalidate value!"
		
		Return 0
		
	Endif
	
	Dim As Long iIndex =hash_horner(pszKey)
	
	If (pArray[iIndex].pszKey Andalso pArray[iIndex].iFdelete =0) Andalso *(pArray[iIndex].pszKey) =*pszKey Then
		
		Return pArray[iIndex].pszValue
		
	Else
		
		If pArray[iIndex].pList Then
			
			Dim As THLIST Ptr p =pArray[iIndex].pList->get_element(pszKey)
			
			If p Then
				
				Return p->pszValue
				
			Else
				
				Return 0
				
			Endif
			
		Endif
		
	Endif
	
End Function

Function THASHTABLE.hash_horner(psz As Zstring Ptr) As Long
	
	Dim As Ulong iResult
	
	For i As Long =0 To Len(*psz)-1
		
		iResult =(11 * iResult + (*psz)[i])
		
	Next
	
	Return iResult Mod iSize
	
End Function

Sub THASHTABLE.rehash()
	
	Dim As Long iOldSize =iSize
	
	If iCountItem >32768 Then
		
		iSize =131072
		
	Elseif iCountItem >16384 Then
		
		iSize =65536
		
	Elseif iCountItem >8192 Then
		
		iSize =32768
		
	Elseif iCountItem >4096 Then
		
		iSize =16384
		
	Elseif iCountItem >2048 Then
		
		iSize =8192
		
	Elseif iCountItem >1024 Then
		
		iSize =4096
		
	Elseif iCountItem >512 Then
		
		iSize =2048
		
	Elseif iCountItem >256 Then
		
		iSize =1024
		
	Elseif iCountItem >128 Then
		
		iSize =512
		
	Elseif iCountItem >64 Then
		
		iSize =256
		
	Elseif iCountItem >32 Then
		
		iSize =128
		
	Elseif iCountItem >16 Then
		
		iSize =64
		
	Endif
	
	Dim As THASHITEM Ptr pNew =Callocate(Sizeof(THASHITEM)*(iSize+4))
	
	if pNew then
		
		For i As Long =0 To iOldSize
			
			If pArray[i].pszKey Then
				
				If pArray[i].iFdelete =0 Then
					
					add_rehash(pNew , pArray[i].pszKey , pArray[i].pszValue)
					
				Endif
				
				If pArray[i].pList Then
					
					Dim As THLIST Ptr pTemp =pArray[i].pList->pFirst , pTemp2
					
					While pTemp
						
						add_rehash(pNew , pTemp->pszKey , pTemp->pszValue)
						
						pTemp2 =pTemp->P
						
						Deallocate(pTemp)
						
						pTemp =pTemp2
						
					Wend
					
					Deallocate(pArray[i].pList)
					
				Endif
				
			Endif
			
		Next
		
		if pArray then Deallocate(pArray)
		
		pArray =pNew
		
	else
		
		print "Allocated memory error in THASHTABLE.rehash!"
		
	endif
	
End Sub

Function CreateHashTable() As Any Ptr
	
	Return New THASHTABLE
	
End Function

Function GetSizeHashTable(p As Any Ptr) As Long
	
	If p Then
		
		Return Cast(THASHTABLE Ptr , p)->iCountItem
		
	Endif
	
End Function

Sub SetValueHashTable(p As Any Ptr , sKey As String , anyValue As Any Ptr)
	
	If p Then
		
		Cast(THASHTABLE Ptr , p)->insert(sKey , anyValue)
		
	Endif
	
End Sub

Sub SetValueStrHashTable(p As Any Ptr , sKey As String , anyValue As USTRING)
	
	If p Then
		
		#ifdef UNICODE
			Dim As Long iLen = Len(anyValue)
		#else
			Dim As Long iLen = Len(anyValue)
		#endif
		
		If iLen Then
			
			#ifdef UNICODE
				
				Dim As Wstring Ptr pws = Allocate(Sizeof(Wstring)*(iLen+1))
				
			#else
				
				Dim As Zstring Ptr pws = Allocate(iLen+1)
				
			#endif
			
			if pws then
				
				*pws = anyValue
				
				(*pws)[iLen] = 0
				
			else
				
				print "Allocated memory error in SetValueStrHashTable!"
				
			endif
			
			Cast(THASHTABLE Ptr , p)->insert(sKey , pws , 1)
			
		Else
			
			Cast(THASHTABLE Ptr , p)->insert(sKey , 0 , 1)
			
		Endif
		
	Endif
	
End Sub

Function GetValueHashTable(p As Any Ptr , sKey As String) As Any Ptr
	
	If p Then
		
		Return Cast(THASHTABLE Ptr , p)->find(sKey)
		
	Endif
	
End Function

Function GetValueStrHashTable(p As Any Ptr , sKey As String) As USTRING
	
	If p Then
		
		Dim As USTRING sRet
		
		#ifdef UNICODE
			Dim As Wstring Ptr pTemp = Cast(THASHTABLE Ptr , p)->find(sKey)
		#else
			Dim As Zstring Ptr pTemp = Cast(THASHTABLE Ptr , p)->find(sKey)
		#endif
		
		If pTemp Then
			
			sRet = *pTemp
			
		Endif
		
		Return sRet
		
	Endif
	
End Function

Sub FreeHashTable(p As Any Ptr , bFlagFreeMemoryStrings As Long = 0)
	
	If p Then
		
		Cast(THASHTABLE Ptr , p)->cleartable(bFlagFreeMemoryStrings)
		
	Endif
	
End Sub

Sub FreeKeyHashTable(p As Any Ptr , sKey As String , bFlagFreeMemoryStrings As Long = 0)
	
	If p Then
		
		Cast(THASHTABLE Ptr , p)->deleteitem(sKey , bFlagFreeMemoryStrings)
		
	Endif
	
End Sub

Sub DeleteHashTable(p As Any Ptr , bFlagFreeMemoryStrings As Long = 0)
	
	If p Then
		
		If Cast(THASHTABLE Ptr , p)->iSize Then
			
			Cast(THASHTABLE Ptr , p)->cleartable(bFlagFreeMemoryStrings)
			
			Cast(THASHTABLE Ptr , p)->freetable()
			
		Endif
		
		Delete Cast(THASHTABLE Ptr , p)
		
	Endif
	
End Sub
