— Указатели в СтарБейсике видишь?
— …
— А они там есть.

Вступление

Динамические массивы повышают интеграционную адаптивность программ.

Под динамическими массивами здесь и далее понимаем множественные данные, структура и число элементов которых становятся известны и могут меняться на этапе решения вычислительной задачи.

Без претензии на толкование динамических массивов, далее по тексту изложены:

операторы языка StarBasic из Apache OpenOffice для работы с динамическими массивами;
демонстрационные примеры с динамическими массивами на языке StarBasic.

Операторы языка StarBasic

Для практического применения динамических массивов необходимо и достаточно:

создавать собственные структуры данных;
обращаться к данным по‑значению и по‑адресу (ссылке);
произвольно выделять и освобождать блоки памяти в куче.

Язык программирования StarBasic содержит необходимый и достаточный набор операторов:

Оператор объявления пользовательского типа данных:

Type TUserType
	field_1 as EmbeddedType_1
	field_2 as EmbeddedType_2(*)
End Type

(*) Для полиморфных данных применим встроенный тип Variant.

Оператор выделения блока памяти из кучи:

Dim userVar as New TUserType

Оператор возврата блока памяти в кучу:

userVar = Nothing

Оператор присваивания значения:

userVar_1 = userVar_2

Оператор присваивания ссылки:

Set userVar_1 = userVar_2

Передача параметров по-ссылке (ByRef) и по‑значению (ByVal).
Функции пользовательского типа возвращают результат по‑ссылке.

Далее на примерах.

Пример 1. Односвязный список

Главный структурный элемент односвязного списка — это указатель на следующий элемент списка.

Описание элемента односвязного списка на языке «С»:

struct sListItem
{
	int 		item;	//полезная информация элемента
	sListItem	*succ;	//указатель на следующий элемент
};

Структурная схема односвязного списка:

Пример демонстрирует по‑элементное создание и удаление односвязного списка.

Описание структуры односвязного списка на языке StarBasic:

Type TListItem
	n as Integer
	succ as Variant
End Type

Точка запуска демонстрации односвязного списка:

'***************************************************************************
' Тест односвязного списка

Sub list_Test()

Детали и подробности в исходном тексте.
Исходный текст демонстрационного примера в конце статьи.

Пример 2. Двоичное дерево

В структуре элемента двоичного дерева содержится два указателя на предшествующий и последующий элементы.

Описание элемента бинарного дерева на языке «С»:

struct sBTreeItem
{
	int 		item;	//полезная информация элемента
	sBTreeItem	*pred;	//указатель на предыдущий элемент
	sBTreeItem	*succ;	//указатель на следующий элемент
};

Структурная схема двоичного дерева:

Пример демонстрирует адаптивное создание, реструктуризацию, частичное и полное удаление произвольного двоичного дерева согласно набора внутренних и внешних правил.

Описание структуры двоичного дерева на языке StarBasic:

Type BTreeNodeType
	Expression as String
	Left as Variant
	Right as Variant
End Type

Точки запуска демонстрации двоичного дерева

'***************************************************************************
' Функция для формул листа

Public Function BOOLCALC(formula as String) as String

'***************************************************************************
' Тест динамического двоичного дерева

Sub btree_test()

Прикладная часть примера с двоичным деревом — простой логический вычислитель.

На вход вычислителя подаётся строка с логической формулой.

Вычислитель возвращает решение (упрощение) логической формулы, если это возможно. Например:

0 ^ 1 = 1

b | a & b | c = B | C

Словарь вычислителя:
• 0 — FALSE
• 1 — TRUE
• A, D, C, D, E, F, G — произвольные логические функции (всего 7)
• | — логический оператор OR
• & — логический оператор AND
• ^ — логический оператор XOR
• ~ — логический оператор NOT
• () — оператор повышения приоритета

Высший приоритет у оператора отрицания «~».

Другие операторы имеют равный приоритет, выполняются последовательно слева направо.

Оператор повышения приоритета «()» меняет порядок выполнения операторов по правилам арифметики.

Детали и подробности в исходном тексте.

Демонстрационный пример

Демонстрационный пример требует средний уровень безопасности макросов.

Во время открытия файла примера «включить» макросы.

В демонстрационном примере два листа с формулами и два модуля с макросами.

На первом листе таблица основных логических преобразований. Первый лист служит для проверки программы.

На втором листе форма проверки произвольной логической формулы.

Первый модуль макросов содержит демонстрационный пример работы со связным списком.
Во-втором модуле макросов — демонстрационный пример работы с двоичным деревом.

Демонстрационный файл доступен по ссылке:
ApacheOpenOfficeDynarr.ods (zip).

Вместо заключения

Дополнительная информация в завершение темы динамических массивов как средства повышения интеграционной адаптивности программ:

примеры подготовлены в Apache OpenOffice 4.1.11;
допускается применение других офисных пакетов;
условия распространения кода — GNU LGPL v3.

Добавленный текст

Исходный код для Примера 1 - "Связный список"

'******************************************************************************
' Dynamic array example for Apache OpenOffice StarBasic 
' based on singly linked list
'
' Copyright (с) 2022, "Nikolay E. Garbuz" <nik_garbuz@list.ru> 
'
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU Lesser General Public License version 3 as
' published by the Free Software Foundation.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public License
' along with this program.  If not, see <http://www.gnu.org/licenses/>.
'
' Authored by Nikolay Garbuz <nik_garbuz@list.ru>
' Modified by
'
' TAB Size .EQ 4
'******************************************************************************

Option Explicit

'***************************************************************************
' Структура элемента односвязного списка

Type TListItem
	n as Integer
	succ as Variant
End Type

'***************************************************************************
' Тест односвязного динамического списка

Sub list_Test()
	Dim list as TListItem
	Dim i as Integer
	
	list = Nothing
	
	For i = 1 TO 3 
		Set list = newListItem(list)
	Next i
	
	Dim li as TListItem
	
	While Not IsNull(list)
		li = list

		print getItemNumber(li)

		freeListItem(list)
'		Set list = freeListItem(list) ' so it is also possible

	Wend
End Sub

'***************************************************************************
' Добавляет новый элемент в начало

Function newListItem(ByRef Head as TListItem) as TListItem
	Dim newItem as New TListItem
	
	Set newItem.succ = Head
	
	If IsNull (newItem.succ) Then
		newItem.n = 1 
	Else
		newItem.n = newItem.succ.n + 1
	End If
	Set Head = newItem
	newListItem = Head
End Function

'***************************************************************************
' Удаляет первый элемент в списке

Function freeListItem(ByRef Head as TListItem) as TListItem
	Dim Item as TListItem
	
	Set Item = Head
	
	If Not IsNull(Item) Then
		Set Head = Head.succ
		Item = Nothing
	End If
	
	freeListItem = Head
End Function

'***************************************************************************
' Возвращает данные элемента в списке

Function getItemNumber(ByRef Head as TListItem) as Integer
	getItemNumber = 0
	If Not IsNull(Head) Then
		getItemNumber = Head.n
	End If
End Function

Исходный код для Примера 2 - "Двоичное дерево"

'******************************************************************************
' Boolean calculator example for Apache OpenOffice StarBasic,
' based on dynamic B-Tree
'
' Copyright (с) 2010, 2022, "Nikolay E. Garbuz" <nik_garbuz@list.ru> 
'
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU Lesser General Public License version 3 as
' published by the Free Software Foundation.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public License
' along with this program.  If not, see <http://www.gnu.org/licenses/>.
'
' Authored by Nikolay Garbuz <nik_garbuz@list.ru>
' Modified by
'
' TAB Size .EQ 4
'******************************************************************************

'******************************************************************************
'******************************************************************************
' Logical operations
'
' associativity:	a or (b or c) = (a or b) or c				a and (b and c) = (a and b) and c
' commutativity:	a or b = b or a								a and b = b and a
' absorption:		a or (a and b) = a 							a and (a or b) = a
' distributivity:	a or (b and c) = (a or b) and (a or c)		a and (b or c) = (a and b) or (a and c)
' complements:		a or not a = 1 								a and not a = 0
' idempotency:		a or a = a 									a and a = a 	
' boundedness:		a or 0 = a 									a and 1 = a
' 					a or 1 = 1 									a and 0 = 0
'
' 0 and 1 are complements:		not 0 = 1								not 1 = 0
' are not complements:			not a = not a 							not b = not b
' de Morgan's laws:				not (a or b) = not a and not b 			not (a and b) = not a or not b
'
' involution:					not not a = a
'
' exclusive disjunction, XOR:	a xor b = not (a and b) and (a or b)
'								a xor 1 = not (a and 1) and (a or 1)
'										= not a or 1 = not a
'								a xor 0 = not (a and 0) and (a or 0)
'										= not 0 and a = 1 and a = a
'								a xor a = not (a and a) and (a or a)
'										= not a and a = 0
'
'								a xor not a = not (a and not a) and (a or not a)
'												not 0 and a
'												1 and a = a
'
'								not a xor not b = not (not a and not b) and (not a or not b)
'												= (not not a or not not b) and (not a or not b)
'												= (a or b) and not (a and b)
'												= a xor b
'******************************************************************************

Option Explicit
Option Base 0

'***************************************************************************
' Const & Globals

Const OP_OR = "|"
Const OP_AND = "&"
Const OP_XOR = "^"
Const OP_NOT = "~"

Const OP_TRUE = "1"
Const OP_FALSE = "0"

Const OP_A = "A"
Const OP_B = "B"
Const OP_C = "C"
Const OP_D = "D"
Const OP_E = "E"
Const OP_F = "F"
Const OP_G = "G"

Const OP_LBR = "("
Const OP_RBR = ")"

Const OP_SPACE = " "

Dim bOpsArray() as String
Dim bComplementsArray() as String
Dim bConditionsArray() as String

'******************************************************************************
'*** B-Tree structure

Type BTreeNodeType
	Expression as String
	Left as Variant
	Right as Variant
End Type

'******************************************************************************
'******************************************************************************
' small B-Tree test
'******************************************************************************

Sub btree_test()
	Dim formula as String
	Dim Caption as String
	
	btEvaluate_init()

	formula = "1^0"
	Caption = "Condition: " & formula
	
	MsgBox (btEvaluate(formula), 64, Caption) ' 1

	formula = "A&B|B&C"
	Caption = "Condition: " & formula

	MsgBox (btEvaluate(formula), 64,  Caption) ' B|C

	formula = "(A&B)|(B&C)"
	Caption = "Condition: " & formula

	MsgBox (btEvaluate(formula), 64,  Caption) ' B&(A|C)
	
End Sub

'******************************************************************************
'******************************************************************************
' Boolean calculator for worksheet
'******************************************************************************

Public Function BOOLCALC(formula as String) as String
	btEvaluate_init()
	formula = UCase(formula)
	boolCalc = btEvaluate(formula)
End Function

'******************************************************************************
'******************************************************************************
'*** Boolean calculator for StarBasic
'******************************************************************************

Function btEvaluate(ByRef sFormula as String) as String
	Dim bTree as BTreeNodeType

	bTree = Nothing
	
	Dim err_pos as Integer
	err_pos = formula_chkSyntax(sFormula)
	
	If err_pos > 0 Then
		Dim l as String
		Dim r as String
		l = Left(sFormula, err_pos)
		r = Mid(sFormula, err_pos + 1)
		btEvaluate = l & "<!>" & r
		Exit Function
	End If
	
	bTree = btMakeTree(sFormula)
	
	bTree = btOptimizeTree(bTree)
	
	bTree = btCalcTree(bTree)
	
	btEvaluate = btDrawTree(bTree)
	
	btDeleteTree(bTree)
	
End Function

'***************************************************************************
' preparatory subroutine

Sub btEvaluate_init()
	Static ImInit as Boolean
	If NOT ImInit Then
		bOpsArray = Array(OP_NOT, OP_OR, OP_AND, OP_XOR)
		bComplementsArray = Array(OP_TRUE, OP_FALSE)
		bConditionsArray = Array(OP_A, OP_B, OP_C, OP_D, OP_E, OP_F, OP_G)
		ImInit = TRUE
	End If
End Sub

'******************************************************************************
' calculates a boolean formula in a B-Tree view

Function btCalcTree(ByRef bTree as BTreeNodeType) as BTreeNodeType
	Dim treeNode as BTreeNodeType
	Dim rightNode as BTreeNodeType
	Dim leftNode as BTreeNodeType

	Set treeNode = bTree

	If NOT btIsNodeLast(treeNode) Then
		Set leftNode = btCalcTree(treeNode.Left)
		Set rightNode = btCalcTree(treeNode.Right)

		Select Case treeNode.Expression
			Case OP_NOT

				If rightNode.Expression = OP_NOT Then
					Set treeNode = rightNode.Right
				Else
					If rightNode.Expression = OP_TRUE Then
						rightNode.Expression = OP_FALSE

						Set treeNode = rightNode
					Else
						If rightNode.Expression = OP_FALSE Then
							rightNode.Expression = OP_TRUE

							Set treeNode = rightNode
						Else
							Set treeNode.Right = rightNode
						End If
					End If
				End If
					
			Case OP_OR

				If leftNode.Expression = OP_TRUE OR rightNode.Expression = OP_TRUE Then
					treeNode = Nothing
					leftNode = Nothing
					rightNode  = Nothing

					Set treeNode = btMakeNode(OP_TRUE)
				Else
					If leftNode.Expression = OP_FALSE Then
						treeNode = Nothing
						leftNode = Nothing

						Set treeNode = rightNode
					Else
						If rightNode.Expression = OP_FALSE Then
							treeNode = Nothing
							rightNode  = Nothing

							Set treeNode = leftNode
						Else
							If btAreNodesSame(leftNode, rightNode) Then
								treeNode = Nothing
								rightNode  = Nothing

								Set treeNode = leftNode
							Else
								If btAreNodesComplement(leftNode, rightNode) Then
									treeNode = Nothing
									leftNode = Nothing
									rightNode  = Nothing

									Set treeNode = btMakeNode(OP_TRUE)
								Else
									Set treeNode = btMakeNode(treeNode.Expression, leftNode, rightNode)
								End If
							End If
						End If
					End If
				End If

			Case OP_AND

				If leftNode.Expression = OP_FALSE OR rightNode.Expression = OP_FALSE Then
					treeNode = Nothing
					leftNode = Nothing
					rightNode  = Nothing

					Set treeNode = btMakeNode(OP_FALSE)
				Else
					If leftNode.Expression = OP_TRUE Then
						treeNode = Nothing
						leftNode = Nothing

						Set treeNode = rightNode
					Else
						If rightNode.Expression = OP_TRUE Then
							treeNode = Nothing
							rightNode  = Nothing

							Set treeNode = leftNode
						Else
							If btAreNodesSame(leftNode, rightNode) Then
								treeNode = Nothing
								rightNode  = Nothing

								Set treeNode = leftNode
							Else
								If btAreNodesComplement(leftNode, rightNode) Then
									treeNode = Nothing
									leftNode = Nothing
									rightNode  = Nothing

									Set treeNode = btMakeNode(OP_FALSE)
								Else
									Set treeNode = btMakeNode(treeNode.Expression, leftNode, rightNode)
								End If
							End If
						End If
					End If
				End If

			End Select
	End If

	btCalcTree = treeNode
End Function

'******************************************************************************
'*** subroutines for boolean optimization
'******************************************************************************

'******************************************************************************
' optimizes the logical tree

Function btOptimizeTree(ByRef bTree as BTreeNodeType) as BTreeNodeType
	Dim treeNode as New BTreeNodeType
	Dim ChCount as Integer

	Set treeNode = bTree

	Do
		ChCount = 0

		treeNode = btOptimizeAreNot(treeNode, ChCount)
		treeNode = btOptimizeMorgans(treeNode, ChCount)
		treeNode = btOptimizeDistribution(treeNode, ChCount)
		treeNode = btOptimizeAbsorption(treeNode, ChCount)

	Loop Until ChCount = 0

	btOptimizeTree = treeNode
End Function

'******************************************************************************
' optimization for absorption
'	a or (a and b) = a
'	a and (a or b) = a

Function btOptimizeAbsorption(ByRef bTree as BTreeNodeType, ByRef ChCount as Integer) as BTreeNodeType
	Dim freeNode as BTreeNodeType
	Dim treeNode as New BTreeNodeType
	Dim stOR as Boolean
	Dim stAND as Boolean
	Dim lsOR as Boolean
	Dim lsAND as Boolean
	Dim Absorpt as Boolean

	Set treeNode = bTree

	If NOT btIsNodeLast(treeNode) Then
		stOR = treeNode.Expression = OP_OR
		stAND = treeNode.Expression = OP_AND
		If stOR OR stAND Then

			If NOT btIsNodeLast(treeNode.Right) Then
				lsAND = treeNode.Right.Expression = OP_AND
				lsOR = treeNode.Right.Expression = OP_OR

				If (stOR AND lsAND) OR (stAND AND lsOR) Then
					Absorpt = btAreNodesSame(treeNode.Left, treeNode.Right.Left) OR _
								btAreNodesSame(treeNode.Left, treeNode.Right.Right)

					If Absorpt Then
						Set freeNode = treeNode
						Set treeNode = treeNode.Left
						freeNode = Nothing
						
						ChCount = ChCount + 1
					End If
				End If
			End If

			If NOT btIsNodeLast(treeNode.Left) Then
				lsAND = treeNode.Left.Expression = OP_AND
				lsOR = treeNode.Left.Expression = OP_OR

				If (stOR AND lsAND) OR (stAND AND lsOR) Then
					Absorpt = btAreNodesSame(treeNode.Right, treeNode.Left.Left) OR _
								btAreNodesSame(treeNode.Right, treeNode.Left.Right)

					If Absorpt Then
						Set freeNode = treeNode
						Set treeNode = treeNode.Right
						freeNode = Nothing
						
						ChCount = ChCount + 1
					End If
				End If
			End If

		End If
		Set freeNode = treeNode.Left
		Set treeNode.Left = btOptimizeAbsorption(treeNode.Left, ChCount)
		freeNode = Nothing
		
		Set freeNode = treeNode.Right
		Set treeNode.Right = btOptimizeAbsorption(treeNode.Right, ChCount)
		freeNode = Nothing
	End If

	btOptimizeAbsorption = treeNode
End Function

'******************************************************************************
' optimization for distribution
'	(a or b) and (a or c) = a or (b and c)
'	(a and b) or (a and c) = a and (b or c)

Function btOptimizeDistribution(ByRef bTree as BTreeNodeType, ByRef ChCount as Integer) as BTreeNodeType
	Dim freeNode as BTreeNodeType
	Dim treeNode as New BTreeNodeType
	Dim stOR as Boolean
	Dim stAND as Boolean
	Dim lsOR as Boolean
	Dim lsAND as Boolean

	Set treeNode = bTree

	If NOT btIsNodeLast(treeNode) Then
		stOR = treeNode.Expression = OP_OR
		stAND = treeNode.Expression = OP_AND
		If stOR OR stAND Then
			lsOR = treeNode.Left.Expression = OP_OR AND treeNode.Right.Expression = OP_OR
			lsAND = treeNode.Left.Expression = OP_AND AND treeNode.Right.Expression = OP_AND
			If (stOR AND lsAND) OR (stAND AND lsOR) Then
				Dim idx as Integer
				idx = 0
				idx = idx + IIf(btAreNodesSame(treeNode.Left.Left, treeNode.Right.Left), 1, 0)
				idx = idx + IIf(btAreNodesSame(treeNode.Left.Left, treeNode.Right.Right), 2, 0)
				idx = idx + IIf(btAreNodesSame(treeNode.Left.Right, treeNode.Right.Left), 4, 0)
				idx = idx + IIf(btAreNodesSame(treeNode.Left.Right, treeNode.Right.Right), 8, 0)

				Select Case idx
					Case 1: ' left - left
						Set treeNode.Right.Left = treeNode.Left.Right
						Set treeNode.Left = treeNode.Left.Left
					Case 2: ' left - right
						Set treeNode.Right.Right = treeNode.Left.Right
						Set treeNode.Left = treeNode.Left.Left
					Case 4: ' right - left
						Set treeNode.Right.Left = treeNode.Left.Left
						Set treeNode.Left = treeNode.Left.Right
					Case 8: ' right - right
						Set treeNode.Right.Right = treeNode.Left.Left
						Set treeNode.Left = treeNode.Left.Right
					Case Else:
						idx = -1
				End Select
				If idx > 0 Then
					ChCount = ChCount + 1
					If stOR Then
						treeNode.Expression = OP_AND
						treeNode.Right.Expression = OP_OR
					Else
						treeNode.Expression = OP_OR
						treeNode.Right.Expression = OP_AND
					End If
				End If
			End If
		End If

		Set freeNode = treeNode.Left
		Set treeNode.Left = btOptimizeDistribution(treeNode.Left, ChCount)
		freeNode = Nothing
		
		Set freeNode = treeNode.Right
		Set treeNode.Right = btOptimizeDistribution(treeNode.Right, ChCount)
		freeNode = Nothing
		
	End If
	btOptimizeDistribution = treeNode
End Function

'******************************************************************************
' optimization for double 'not' by Morgan
'	not a or not b = not (a and b)
'	not a and not b = not (a or b)
'	not a xor not b = a xor b

Function btOptimizeMorgans(ByRef bTree as BTreeNodeType, ByRef ChCount as Integer) as BTreeNodeType
	Dim freeNode as BTreeNodeType
	Dim treeNode as New BTreeNodeType
	Dim bOR as Boolean
	Dim bAND as Boolean
	Dim bXOR as Boolean
	Dim bNOT as Boolean

	Set treeNode = bTree

	If NOT btIsNodeLast(treeNode) Then

		bOR = treeNode.Expression = OP_OR
		bAND = treeNode.Expression = OP_AND
		bXOR = treeNode.Expression = OP_XOR
		bNOT = NOT (btIsNodeLast(treeNode.Left) OR btIsNodeLast(treeNode.Left))
		If bNOT Then
			bNOT = treeNode.Left.Expression = OP_NOT AND treeNode.Right.Expression = OP_NOT
			If (bOR OR bAND) AND bNOT Then
				Set treeNode.Right.Left = treeNode.Left.Right
				treeNode.Left = Nothing
				If bOR Then
					treeNode.Right.Expression = OP_AND
				Else
					treeNode.Right.Expression = OP_OR
				End If
				treeNode.Expression = OP_NOT
				ChCount = ChCount + 1
			End If
			If bXOR AND bNOT Then
				Set freeNode = treeNode.Left
				Set treeNode.Left = treeNode.Left.Right
				freeNode = Nothing
				
				Set freeNode = treeNode.Right
				Set treeNode.Right = treeNode.Right.Right
				freeNode = Nothing
				
				ChCount = ChCount + 1
			End If
		End If
		Set freeNode = treeNode.Left
		Set treeNode.Left = btOptimizeMorgans(treeNode.Left, ChCount)
		freeNode = Nothing
		
		Set freeNode = treeNode.Right
		Set treeNode.Right = btOptimizeMorgans(treeNode.Right, ChCount)
		freeNode = Nothing
		
	End If
	btOptimizeMorgans = treeNode
End Function

'******************************************************************************
' deleting a simple double "not"
'	not not a = a

Function btOptimizeAreNot(ByRef bTree as BTreeNodeType, ByRef ChCount as Integer) as BTreeNodeType
	Dim freeNode as BTreeNodeType
	Dim treeNode as New BTreeNodeType

	Set treeNode = bTree

	If NOT btIsNodeLast(treeNode) Then
		If treeNode.Expression = OP_NOT Then
			If treeNode.Right.Expression = OP_NOT Then
				Set freeNode = treeNode
				Set treeNode = treeNode.Right.Right
				freeNode = Nothing
				
				ChCount = ChCount + 1
			End If
		End If
		Set freeNode = treeNode.Left
		Set treeNode.Left = btOptimizeAreNot(treeNode.Left, ChCount)
		freeNode = Nothing
		
		Set freeNode = treeNode.Right
		Set treeNode.Right = btOptimizeAreNot(treeNode.Right, ChCount)
		freeNode = Nothing
		
	End If
	btOptimizeAreNot = treeNode
End Function

'******************************************************************************
'*** returns TRUE for the last node in the B-tree

Function btIsNodeLast(Node as BTreeNodeType) as Boolean
	If IsNull(Node) Then
		btIsNodeLast = TRUE
	Else
		btIsNodeLast = IsNull(Node.Left) AND IsNull(Node.Right)
	End If
End Function

'******************************************************************************
' returns TRUE if nodes match

Function btAreNodesSame(FirstNode as BTreeNodeType, SecondNode as BTreeNodeType) as Boolean
	If IsNull(FirstNode) Then
		btAreNodesSame = IsNull(SecondNode)
	Else
		If IsNull(SecondNode) then
			btAreNodesSame = FALSE
		Else
			Dim express as Boolean
			Dim projec as Boolean
			Dim mirror as Boolean

			express = FirstNode.Expression = SecondNode.Expression

			projec = btAreNodesSame(FirstNode.Left, SecondNode.Left) _
				AND btAreNodesSame(FirstNode.Right, SecondNode.Right)

			mirror = btAreNodesSame(FirstNode.Left, SecondNode.Right) _
				AND btAreNodesSame(FirstNode.Right, SecondNode.Left)

			btAreNodesSame =  express AND (projec OR mirror)

		End If
	End If

End Function

'******************************************************************************
' returns TRUE if nodes are complement

Function btAreNodesComplement(FirstNode as BTreeNodeType, SecondNode as BTreeNodeType) as Boolean

	Dim areComplements as Boolean

	areComplements = FALSE

	If NOT (IsNull(FirstNode) AND IsNull(SecondNode)) Then
		If btIsNodeLast(FirstNode) AND btIsNodeLast(SecondNode) Then
			areComplements = btIsComplement(FirstNode.Expression) _
							AND btIsComplement(SecondNode.Expression) _
							AND (FirstNode.Expression <> SecondNode.Expression)
		Else
			areComplements = (FirstNode.Expression = OP_NOT) XOR (SecondNode.Expression = OP_NOT)
			If areComplements Then
				Dim tempF as New BTreeNodeType
				Dim tempS as New BTreeNodeType

				If FirstNode.Expression = OP_NOT Then
					Set tempF = FirstNode
				Else
					Set tempF = btMakeNode(OP_NOT, Nothing, FirstNode)
				End If

				If SecondNode.Expression = OP_NOT Then
					Set tempS = SecondNode
				Else
					Set tempS = btMakeNode(OP_NOT, Nothing, SecondNode)
				End If

				areComplements = btAreNodesSame(tempF, tempS)
			End If
		End If
	End If

	btAreNodesComplement = areComplements
End Function

'******************************************************************************
'*** B-tree building subroutines
'******************************************************************************

'******************************************************************************
' creates a B-Tree from a formula

Function btMakeTree(sFormula as String) as BTreeNodeType
	Dim logicElement as String
	Dim simpleElement as String
	Dim bTree as BTreeNodeType
	
	Do While sFormula <> ""
		 logicElement = formula_logicStructure(sFormula)
		
		Do While logicElement <> ""
			simpleElement = formula_boolElement(logicElement)

			If btIsAtom(simpleElement) Then
				Set bTree = btMakeNode(simpleElement)
			Else
				If btIsOperator(simpleElement) Then
					If simpleElement = OP_NOT Then
						Set bTree = btMakeNode( _
													simpleElement, _
													Nothing, _
													btMakeTree ( _
																	formula_logicStructure(logicElement) _
																) _
												)
					Else
						If simpleElement = OP_XOR Then '  not (a and b) and (a or b)
							Dim leftSubTreeA as BTreeNodeType
							Dim leftSubTreeB as BTreeNodeType
							Dim rightSubTreeA as BTreeNodeType
							Dim rightSubTreeB as BTreeNodeType
								
							Set LeftSubTreeA = btCopyTree(bTree)
							Set LeftSubTreeB = btCopyTree(LeftSubTreeA)
	
							Set rightSubTreeA =  btMakeTree(formula_logicStructure(sFormula))
								
							Set rightSubTreeB =  btCopyTree(rightSubTreeA)
								
							bTree = btDeleteTree(bTree)
								
							Set LeftSubTreeA = btMakeNode( OP_AND, LeftSubTreeA, RightSubTreeA )
							Set LeftSubTreeA = btMakeNode( OP_NOT, Nothing, LeftSubTreeA )
								
							Set RightSubTreeA = btMakeNode( OP_OR, LeftSubTreeB, RightSubTreeB )
								
							Set bTree = btMakeNode( OP_AND, LeftSubTreeA, RightSubTreeA )
						Else
							Set bTree = btMakeNode( _
														simpleElement, _
														bTree, _
														btMakeTree( _
																	formula_logicStructure(sFormula) _
																) _
													)
						End If
					End If
				Else ' btIsOperator(simpleElement) 
					Set bTree = btMakeTree(simpleElement)
				End If
			End If	
		Loop
	Loop
	
	btMakeTree = bTree
End Function

'******************************************************************************
' creates a B-Tree node from a formula

Function btMakeNode(sNode as String, Optional ByVal leftNode as BTreeNodeType, Optional ByVal rightNode as BTreeNodeType) as BTreeNodeType
	Dim treeNode as New BTreeNodeType

	With treeNode
		.Expression = sNode

		If IsMissing(leftNode) Then
			Set .Left = Nothing
		Else
			Set .Left = leftNode
		End If

		If IsMissing(rightNode)	Then
			Set .Right = Nothing
		Else
			Set .Right = rightNode
		End If

	End With

	btMakeNode = treeNode
End Function

'******************************************************************************
' creates a B-Tree copy

Function btCopyTree(ByVal bTree as BTreeNodeType) as BTreeNodeType
	Dim treeNode as New BTreeNodeType
	
	If IsNull(bTree) Then
		btCopyTree = bTree
	Else	
		With treeNode
			.Expression = bTree.Expression
			.Left = btCopyTree(bTree.Left)
			.Right = btCopyTree(bTree.Right)
		End With
		btCopyTree = treeNode
	End If
End Function

'******************************************************************************
' deletes a B-Tree

Function btDeleteTree(ByRef bTree as BTreeNodeType) as BTreeNodeType
	If btIsNodeLast(bTree) Then
		bTree = Nothing
	Else
		bTree.Left = btDeleteTree(bTree.Left)
		bTree.Right = btDeleteTree(bTree.Right)
	End If
	btDeleteTree = bTree
End Function

'******************************************************************************
'*** text parsing subroutines
'******************************************************************************

'******************************************************************************
' returns the logical structure from the formula

Function formula_logicStructure(ByRef sFormula as String) as String
	Dim Element as String
	Dim LogicElement as String

	LogicElement  = ""
	Do
		Element = formula_boolElement(sFormula)
		If Len(Element) > 1 Then
			LogicElement = LogicElement & OP_SPACE & OP_LBR & Element & OP_RBR
		Else
			LogicElement = LogicElement & OP_SPACE & Element
		EndIf
	Loop Until Element <> OP_NOT

	formula_logicStructure = Trim(LogicElement)
End Function

'******************************************************************************
' returns the next boolean from a formula

Function formula_boolElement(ByRef sFormula as String) as String
	Dim i as Integer

	While sFormula <> "" AND Left(sFormula, 1) <= OP_SPACE
		sFormula = Mid(sFormula, 2)
	Wend

	formula_boolElement = ""

	If Len(sFormula) > 0 Then
		Dim splitPos as Integer
		Dim splitNext as Integer
		Dim Element as String

		If Left(sFormula, 1) = OP_LBR Then
			splitPos = formula_pairBracket(sFormula, OP_LBR, OP_RBR)
			Element = Mid(sFormula, 2, splitPos - 2)
			sFormula = Mid(sFormula, splitPos + 1)
		Else
			splitPos = formula_delimPos(sFormula)
			Element = formula_Element(sFormula, splitPos)
		End If

		formula_boolElement = Trim(Element)
	End If

End Function

'******************************************************************************
' returns the position of the first delimiter
' returns 0 if delimiter does not exist

Function formula_delimPos(sFormula as String) as Integer
	Dim i as Integer
	Dim j as Integer
	Dim l as Integer
	
	formula_delimPos = 0
	
	While Left(sFormula, 1) <= OP_SPACE
		sFormula = Mid(sFormula, 2)
	Wend
	
	For i = 1 To Len(sFormula)
		For j = LBound(bOpsArray) To UBound(bOpsArray)
			l = Len(bOpsArray(j))
			If Mid(sFormula, i, l) = bOpsArray(j) Then
				formula_delimPos = i + l - 1
				Exit Function
			End If
		Next j
	Next i
End Function


'******************************************************************************
' check formula syntax
' returns position of syntax error or zero

Function formula_chkSyntax(ByRef sFormula as String) as Integer
	Dim Pos as Integer
	
	sFormula = Trim(sFormula)
	
	' lost Atom
	If NOT (btIsAtom(Right(sFormula, 1)) OR Right(sFormula, 1) = OP_RBR) Then
		formula_chkSyntax = Len(sFormula)
		Exit Function
	End If
	
	' lost brackets
	Pos = formula_chkBrackets(sFormula, OP_LBR, OP_RBR)
	
	If Pos > 0 Then
		formula_chkSyntax = Pos
		Exit Function
	End If
	
	' opetators harmony
	Dim nextOp as Boolean
	Dim ch as String
	nextOp = FALSE
	
	For Pos = 1 To Len(sFormula)
		ch = Mid(sFormula, Pos, 1)
		If ch <> OP_LBR AND ch <> OP_RBR Then
			If nextOp Then
				If btIsOperator(ch) AND ch <> OP_NOT Then
					nextOp = NOT nextOp
				Else
					formula_chkSyntax = Pos
					Exit Function
				End If
			Else
				If ch <> OP_NOT Then
					If btIsAtom(ch) Then
						nextOp = NOT nextOp
					Else
						formula_chkSyntax = Pos
						Exit Function
					End If
				End If
			End If
		Else
			If nextOp AND ch <> OP_RBR AND NOT (btIsOperator(ch) AND ch <> OP_NOT) Then
				formula_chkSyntax = Pos
				Exit Function
			End If		
		End If
	Next Pos
	formula_chkSyntax = 0
End Function

'******************************************************************************
' check formula syntax
' returns position of syntax error or zero

Function formula_chkBrackets(sFormula as String, L_Bra as String, R_Bra as String) as Integer

	Dim balancer as Integer
	Dim i as Integer
	Dim op as String
	balancer = 0

	For i = 1 To Len(sFormula)
		op = Mid(sFormula, i, 1)
		If op = L_Bra Then
			balancer = balancer + 1
		End If
		If op = R_Bra Then
			balancer = balancer - 1
		End If
		If balancer < 0 Then
			formula_chkBrackets = i
			Exit Function
		End If
	Next i

	If balancer > 0 then
		formula_chkBrackets = i
	Else
		formula_chkBrackets = 0
	End If
End Function

'******************************************************************************
' returns the first element

Function formula_Element(ByRef sFormula as String, splitPos as Integer) as String
	Dim Element as String
	Element = ""
	
	If splitPos = 1 Then
		Element = Left(sFormula, splitPos)
		sFormula = Mid(sFormula, splitPos + 1)
	Else
		If splitPos = 0 Then
			Element = sFormula
			sFormula = ""
		Else
			Element = Left(sFormula, splitPos - 1)
			sFormula = Mid(sFormula, splitPos)
		End If
	End If
	formula_Element = Trim(Element)
End Function

'******************************************************************************
' returns the position of the parenthesis

Function formula_pairBracket(ByVal sFormula as String, L_Bra as String, R_Bra as String) as Integer
	Dim lbra_Count as Integer
	Dim rbra_Count as Integer
	Dim pos as Integer

	formula_pairBracket = 0

	For pos = 1 To Len(sFormula)
		lbra_Count = lbra_Count + IIf(Mid(sFormula, pos, 1) = L_Bra, 1, 0)
		rbra_Count = rbra_Count + IIf(Mid(sFormula, pos, 1) = R_Bra, 1, 0)
		If lbra_Count = rbra_Count Then
			formula_pairBracket = pos
			Exit Function
		End If
	Next pos
End Function

'******************************************************************************
'*** routines for data analysis
'******************************************************************************

'******************************************************************************
' returns TRUE if operator

Function btIsOperator(ByVal sElement as String) as Boolean
	Dim i as Integer
	
	btIsOperator  = FALSE
	
	For i = LBound(bOpsArray) To UBound(bOpsArray)
		If sElement = bOpsArray(i) Then
			btIsOperator = TRUE
			Exit Function
		End If
	Next i
End Function

'******************************************************************************
' returns TRUE if atom

Function btIsAtom(ByVal sElement as String) as Boolean

	btIsAtom = btIsComplement(sElement) OR btIsCondition(sElement)

End Function

'******************************************************************************
' returns TRUE if complement

Function btIsComplement(ByVal sElement as String) as Boolean
	Dim i as Integer
	
	btIsComplement  = FALSE
	
	For i = LBound(bComplementsArray) To UBound(bComplementsArray)
		If sElement = bComplementsArray(i) Then
			btIsComplement = TRUE
			Exit Function
		End If
	Next i
End Function

'******************************************************************************
' returns TRUE if condition

Function btIsCondition(ByVal sElement as String) as Boolean
	Dim i as Integer
	
	btIsCondition  = FALSE
	
	For i = LBound(bConditionsArray) To UBound(bConditionsArray)
		If sElement = bConditionsArray(i) Then
			btIsCondition = TRUE
			Exit Function
		End If
	Next i
End Function

'******************************************************************************
'*** other functions
'******************************************************************************

Function btDrawTree(Tree as BTreeNodeType) as String
	Static rec as Integer

	Dim sout as String
	sout = ""

	rec = rec + 1

	If IsNull(Tree) Then
		sout = sout & "()"
	Else
		If btIsNodeLast(Tree) Then
			sout = sout & Tree.Expression
		Else
			If Tree.Expression = OP_NOT Then
				sout = sout & OP_NOT
				sout = sout & btDrawTree(Tree.Right)
			Else
				If rec > 1 Then
					sout = sout & OP_LBR
				End If
				If NOT IsNull(Tree.Left) Then
					sout = sout & btDrawTree(Tree.Left)
				End If
				sout = sout & Tree.Expression
				If NOT IsNull(Tree.Right) Then
					sout = sout & btDrawTree(Tree.Right)
				End If
				If rec > 1 Then
					sout = sout & OP_RBR
				End If
			End If
		End If
	End If
	btDrawTree = Trim(sout)
	rec = rec - 1
End Function

Sub trapExept()
	Dim j as Integer
	j = 0
	j = j / j
End Sub

Apache OpenOffice. Динамические массивы