- Contents in this wiki are for entertainment purposes only
QAT Code: Whse Class
About ∞ White paper ∞ QuasiMatrix Code ∞ QAT Code ∞ Data Examples ∞ Scatter-Gather Explained ∞ The Plow Share ∞
The Warehouse if Pairs Expansion then Visual Scatter else Visual Cluster redim Bracketing Clusters while Event Chemistry wend SLIP class redim
Option Explicit ' Forces variable declaration in the compile.
' Publicly visible 'Events' raised to callback-functions from within this class. Public Event CommandResponse(ByVal Message As String) ' In-class functions communicate functional-process outcome to interface-code for interface-updates. Public Event DataLoaded(ByRef oFile As clsFile) ' This class instance will call the 'DataLoaded' form module 'event code'. Public Event ConjectureChanged(ByVal ConjColumnAtom As Long, ByVal ConjColumnLink As Long)
Public Event AtomsExtracted() Public Event MartPulled() Public Event PairsExported() Public Event WarehouseUnloaded()
Public Event Progress(ByRef msg As String)
' Properties Private mstrDataFile As String Private mlngDataRowCount As Long Private mlngDataHeaderRowIndex As Long ' An index pointing within a zero-based array to a data row with column-header captions. Private mstrDataRowDelimiter As String Private mstrDataColumnDelimiter As String
Private mlngConjAtomColumn As Long Private mlngConjLinkColumn As Long
Private mbooCancel As Boolean ' Checked in long iterations: Combinatoric generation per Atom-Link conjecture match.
' Class state (code in this class that toggles these state variables also raise an 'event'). Private mbooDataLoaded As Boolean Private mbooConjValid As Boolean Private mbooMartPulled As Boolean Private mbooAtomsExtracted As Boolean Private mbooLinksExtracted As Boolean Private mbooPairsExported As Boolean
' Class data arrays Private mstrDataArray() As String ' array of data rows Private mstrDataHeaderRow() As String ' array of data header-row fields (1st row from file) Private mstrMartArray() As String ' array column data selected by Conjecture options
' Processed data arrays Private mstrPairsArray() As String ' Atom pairs of ColA sharing Links Private mstrLinksArray() As String ' Links of ColB per Atom
Private mcolAtoms() As String ' Hash array of VB String values as a Microsoft VB 6 keyed-collection object.
Private Sub Class_Initialize()
On Error Resume Next
End Sub
Private Sub Class_Terminate()
On Error Resume Next
End Sub
Public Function Combinatorics(ByVal TabularString As String) As String()
' Return a string array loaded with all the combinations of SecNames ' in TabularString, ignoring the first tabular string entry, which is an Atom FirstName Dim maxName As Long Dim maxNdx As Long Dim moduloNdx As Long Dim strCombinations() As String 'array Dim strNames() As String 'array Dim ndxCombination As Long Dim j, k, intLast As Integer On Error Resume Next ' TabularString format (Paired) ' FirName Tab SecName1 Tab SecName2 Tab SecName3... With New clsStopWatch .Reset TrimTrailingCharacters TabularString, vbTab strNames = Split(TabularString, vbTab) 'Note: the first array element is a firstName, not to be combined maxName = UBound(strNames) maxNdx = maxName If maxName > 1 Then ' 0,1 and 2 elements -- 0= FirName; 1,2= Secnames ' Redim to something larger than typically expected ' Redim again later to size used after loading array ReDim strCombinations(maxName * maxName) 'Debug.Print vbCrLf & "Combining FirName: " & strNames(0) If mbooCancel Then Exit Function If maxName > 1 Then ' very key factor ' Key factor: if maxName is larger than two (larger than 1 for zero-based array elements) ' then at least a pair of mart rows matching columns A-Names ' are sharing a B-Name For k = 1 To maxName - 1 ' Start with element 1 of the zero-based strNames() array. DoEvents For j = 1 To (maxName - k) ' Check array size and redim if more elements are needed If ndxCombination > maxNdx Then maxNdx = maxNdx + 1000 ReDim Preserve strCombinations(maxNdx) 'Debug.Print "maxNdx: " & maxNdx End If ' Add the combination to the output array strCombinations(ndxCombination) = strNames(k) & "**" & strNames(k + j) 'Debug.Print "(" & CStr(k) & ")-(" & CStr(k + j) & ") = " & strCombinations(ndxCombination) ndxCombination = ndxCombination + 1 If moduloNdx Mod 5 = 0 Then RaiseEvent Progress("Expanding combinatorics: " & CStr(moduloNdx)) DoEvents If mbooCancel Then Exit Function End If Next moduloNdx = moduloNdx + 1 Next ' Redim the combinations array to the size used ReDim Preserve strCombinations(ndxCombination - 1) ' Return the array Combinatorics = strCombinations End If 'maxName Else 'Debug.Print vbCrLf & "Skipping" End If End With 'New clsStopWatch
End Function
Public Function EnumeratedColumnNames(HeaderArray As Variant) As String
Dim ndx, maxNdx As Integer Dim duplicateArray() As String 'array 'todo: work this out better If Not IsArray(HeaderArray) Then Exit Function maxNdx = UBound(HeaderArray) ReDim duplicateArray(maxNdx) For ndx = 0 To maxNdx duplicateArray(ndx) = CStr(ndx) & vbTab & HeaderArray(ndx) Next ' Return a string transform of array ' elements delimited by CRLF EnumeratedColumnNames = Join(duplicateArray, vbCrLf)
End Function
Public Sub QuickSortVariants( _
vArray As Variant, _ inLow As Long, _ inHi As Long, _ ByRef ndx As Long, _ ByRef maxNdx As Long) Dim pivot As Variant Dim tmpSwap As Variant Dim tmpLow As Long Dim tmpHi As Long tmpLow = inLow tmpHi = inHi ' Increment completion counter ndx = ndx + 1 pivot = vArray((inLow + inHi) \ 2) Me.Cancel = False While (tmpLow <= tmpHi) And Not Me.Cancel While (vArray(tmpLow) < pivot And tmpLow < inHi) tmpLow = tmpLow + 1 Wend While (pivot < vArray(tmpHi) And tmpHi > inLow) tmpHi = tmpHi - 1 Wend
If (tmpLow <= tmpHi) Then tmpSwap = vArray(tmpLow) vArray(tmpLow) = vArray(tmpHi) vArray(tmpHi) = tmpSwap tmpLow = tmpLow + 1 tmpHi = tmpHi - 1 If ndx Mod 100 = 0 Then RaiseEvent Progress("Sort percentage remaining: " & CStr(CInt((1 - (ndx / maxNdx)) * 10000) / 100)) DoEvents End If End If Wend If (inLow < tmpHi) Then QuickSortVariants vArray, inLow, tmpHi, ndx, maxNdx If (tmpLow < inHi) Then QuickSortVariants vArray, tmpLow, inHi, ndx, maxNdx
End Sub
Public Property Get LinkCount() As Long
On Error Resume Next LinkCount = UBound(mstrLinksArray)
End Property
Public Function ConjectureCreate( _
ByVal AtomColumn As Long, _ ByVal LinkColumn As Long _ ) As Boolean ' Return True if columns are in range, and not equal. ' Quietly persist columns set to the INI file. Dim MaxColumn As Integer Dim x() As String On Error Resume Next If Not Me.DataLoaded Then RaiseEvent CommandResponse("Conjecture column cannot be set until the Data is loaded.") Else MaxColumn = UBound(Split(mstrDataArray(0), vbTab)) ' Zero-based array split on the first row in the whse data. ' Validate input (false case) Select Case False Case (AtomColumn >= 0) Case (AtomColumn <= MaxColumn) Case (LinkColumn >= 0) Case (LinkColumn <= MaxColumn) Case (LinkColumn <> AtomColumn) Case Else ' Proceed with validated inputs. ' Store the column indexes. mbooConjValid = True mlngConjAtomColumn = AtomColumn mlngConjLinkColumn = LinkColumn ' Save the conjecture columns. INIWrite "Preferences", "ConjAtomColumnIndex", mlngConjAtomColumn INIWrite "Preferences", "ConjLinkColumnIndex", mlngConjLinkColumn End Select End If 'me.DataLoaded
End Function
'public Function iFnData_ExtractAtoms(Optional ByVal TopicName As String = "A1") As Boolean
' Dim ndx As Long
' Dim lngCount As Long
' Dim strSplitPairs() As String 'array
'
' Dim lngLength As Long
' Dim strAtom As String
' Dim strPairs As String
' Dim intExtractions As Integer
'
' On Error Resume Next
'
' Screen.MousePointer = vbHourglass
'
' RaiseEvent CommandResponse("Extracting unique members from Paired.txt...")
'
'
' ' Flatten the inner and outer delimiters to the same (Replace "**" with CRLF )
' strPairs = Replace(strPairs, "**", vbCrLf)
'
' ' Split the delimited members to an array
' strSplitPairs = Split(strPairs, vbCrLf)
'
' ' Loop through array, checking for new Members from Pairs
' lngCount = UBound(strSplitPairs)
' For ndx = 0 To lngCount
' ' Test that the array element is in the Atoms buffer
If InStr(1, mstrAtomsStringBuffer, strSplitPairs(ndx)) = 0 Then 'not there
' Concatenate the new randomized atom to the buffer at the beginning
mstrAtomsStringBuffer = strSplitPairs(ndx) & vbTab & CStr(Int(Rnd * 360) + 1) & vbCrLf & mstrAtomsStringBuffer
intExtractions = intExtractions + 1
End If
' Next
'
' ' Remove the trailing delimiter
' 'mstrAtomsStringBuffer = Left$(mstrAtomsStringBuffer, Len(mstrAtomsStringBuffer) - 1)
'
' ' The reduced set of Pairs is now a unique set of delimited Atoms in mstrAtomsStringBuffer.
'
' ' Write the fresh Members data to file as the Members of the top Topic named
' ' the value in 'TopicName' in a folder named by the value in 'TopicName'
' With New clsFile
'
' ' Create a new top distribution if non-existant,
' ' or query the user for overwrite permission,
' ' else bail, no persistence -- no existence
' Select Case .FileExists(mstrDataPath & "\" & TopicName & "\Members.txt")
'
' Case True
'
' If MsgBox("Overwrite the Members.txt file for Topic " & TopicName & "?", vbYesNo + vbQuestion + vbDefaultButton2, "Random distribution available") = vbYes Then
' If .Save(mstrAtomsStringBuffer, UseAppend:=False) Then
' ' Create (or err past if existing) a folder for the top node, named A1
' iFnData_ExtractAtoms = True
' Else
' RaiseEvent CommandResponse("Unable to save the Atoms extracted from Paired.txt to " & .Filespec)
' MsgBox "Unable to save the Atoms extracted from Paired.txt to: " & .Filespec
' End If
' End If
'
' Case False
'
' ' Create the new Topic Folder
' MkDir Root.DataPath & "\" & TopicName
'
'
' If .Save(mstrAtomsStringBuffer) Then
' RaiseEvent CommandResponse("Extracted Atoms saved to " & .Filespec)
' iFnData_ExtractAtoms = True
' Else
' RaiseEvent CommandResponse("Unable to save the Atoms extracted from Paired.txt to: " & .Filespec)
' MsgBox "Unable to save the Atoms extracted from Paired.txt to: " & .Filespec
' End If
'
' End Select
' End With
'
' RaiseEvent CommandResponse("Extraction of member atoms complete. " & CStr(intExtractions) & " members extracted.")
'
' Screen.MousePointer = vbDefault
'
'End Function
Public Function TrimTrailingCharacters(ByRef Source As String, ByVal Characters As String) As String
' Remove trailing characters passed by argument Do While StrComp(Right$(Source, Len(Characters)), Characters) = 0 Source = Left$(Source, Len(Source) - Len(Characters)) Loop TrimTrailingCharacters = Source
End Function
Public Function DataLoad(ByRef TabularString As String) As Boolean
On Error GoTo Trap ' String passed by reference, avoiding memory copy. The calling function destroys passed String. ' Remove any trailing row-delimiters while looping. Do While StrComp(Right$(TabularString, 2), vbCrLf) = 0 ' Remove trailing row delimiters. TabularString = Left$(TabularString, Len(TabularString) - 2) Loop ' Split the input String into the Data row-array at the row delimiters. mstrDataArray = Split(TabularString, DataRowDelimiter) mlngDataRowCount = UBound(mstrDataArray) ' Zero-based array index of the last data row read. mbooDataLoaded = CBool(UBound(mstrDataArray) > 0) ' Loaded only if more than header record exists. ' Return outcome. DataLoad = mbooDataLoaded Exit Function
Trap:
Select Case Err.number Case Else MsgBox "DataLoad() Failure: " & formatErrorMsg(Err.number, Err.description, Err.Source), vbExclamation + vbOKOnly, "I/O error" End Select
End Function
Public Property Get ConjAtomColumnIndex() As Long
ConjAtomColumnIndex = mlngConjAtomColumn
End Property Public Property Let ConjAtomColumnIndex(ByVal Value As Long)
mlngConjAtomColumn = Value
End Property
Public Property Get ConjLinkColumnIndex() As Long
ConjLinkColumnIndex = mlngConjLinkColumn
End Property
Public Property Let ConjLinkColumnIndex(ByVal Value As Long)
mlngConjLinkColumn = Value
End Property
Public Property Get ConjValid() As Boolean
ConjValid = mbooConjValid
End Property
Public Property Get DataRowCount() As Long
On Error Resume Next If mbooDataLoaded Then DataRowCount = UBound(mstrDataArray) - mlngDataHeaderRowIndex + 1 ' Zero-based data array.
End Property
Public Function FieldValue(ByVal Row As Long, ByVal Column As Long) As String
On Error Resume Next FieldValue = Split(mstrDataArray(Row), DataColumnDelimiter)(Column)
End Function
Public Property Let DataColumnDelimiter(ByVal Value As String)
mstrDataColumnDelimiter = Value
End Property Public Property Get DataColumnDelimiter() As String
DataColumnDelimiter = mstrDataColumnDelimiter
End Property
Public Property Let DataRowDelimiter(ByVal Value As String)
mstrDataRowDelimiter = Value
End Property Public Property Get DataRowDelimiter() As String
DataRowDelimiter = mstrDataRowDelimiter
End Property
Public Function LoadWarehouse(Optional ByVal FileName As String) As Long
On Error GoTo Trap ' FileName must be a useable filespec (path and filename). ' Return the Data row count on success. If Len(FileName) > 0 Then mstrDataFile = FileName ' Save FileName passed.
With New clsFile If .FileExists(FileName) Then If DataLoad(.ReadAll(mstrDataFile)) Then LoadWarehouse = Me.DataRowCount 'at least 1 more row than header row qualifies as loaded RaiseEvent DataLoaded(.Self) Else RaiseEvent CommandResponse("Unable to load Warehouse data from " & mstrDataFile) End If Else MsgBox "Warehouse Data File Not Found: " & .Filespec, vbInformation RaiseEvent CommandResponse("File not found: " & .Filespec) End If End With End If Exit Function
Trap:
Select Case Err.number Case Else MsgBox "LoadWarehouse: " & formatErrorMsg(Err.number, Err.description, Err.Source) Exit Function Resume ' debugging End Select
End Function
Public Property Get MaxColumn() As Integer
On Error Resume Next If mbooDataLoaded Then MaxColumn = UBound(Split(mstrDataArray(0), vbTab)) End If
End Property
Public Property Let Cancel(ByVal Value As Boolean)
mbooCancel = Value
End Property
Public Property Get Cancel() As Boolean
Cancel = mbooCancel
End Property
Public Function Clear() As Boolean
On Error Resume Next ReDim mstrDataArray(0) ReDim mstrDataHeaderRow(0) ReDim mstrMartArray(0) ReDim mstrPairsArray(0) ReDim mstrLinksArray(0) Clear = CBool(Err.number)
End Function
Public Property Get MartCount() As Long
On Error Resume Next If mbooMartPulled Then MartCount = UBound(mstrMartArray) + 1
End Property
' Enumerate all Warehouse records, pulling the ' combined conjecture columns into the Mart array. Public Function MartPull() As Boolean
Dim ndx As Long Dim maxNdx As Long Dim strField() As String 'array Dim msg As String On Error Resume Next ' Store the max array index for enumeration maxNdx = UBound(mstrDataArray) ' Size the Mart array to the warehouse size ReDim mstrMartArray(maxNdx) ' Check for contextual validity If (mlngConjAtomColumn > -1) And (mlngConjLinkColumn > -1) Then ' Enumerate all Warehouse records, pulling the ' combined conjecture columns into the Mart array. For ndx = 0 To maxNdx 'including header at 0 ' Split the record into strField array at the inner delimiter strField = Split(mstrDataArray(ndx), DataColumnDelimiter) ' Copy into the Mart array the two fields specified by conjecture mstrMartArray(ndx) = strField(mlngConjLinkColumn) & _ DataColumnDelimiter & _ strField(mlngConjAtomColumn) ' B <Tab> A Next ndx ' Sort the new Mart array, now in natural order from Whse QuickSortVariants mstrMartArray, 1, UBound(mstrMartArray), 0, UBound(mstrMartArray) ' Join all array elements into a string with line delimiters streaming to file With New clsFile .Filespec = DataFolder & "\Mart.txt" ' Save the Mart in the data path as a ' Column/Line delimited tabulation of string data. If .Save(Join(SourceArray:=mstrMartArray, delimiter:=mstrDataRowDelimiter)) Then mbooMartPulled = True MartPull = True RaiseEvent CommandResponse("Mart columns pulled, and saved to file") RaiseEvent MartPulled Else msg = "Unable to save the Mart data to file " & .Filespec End If End With Else RaiseEvent CommandResponse("Mart cannot be Pulled until both conjectures are selected, i.e., A = 4 <CR> B = 5 <CR>") End If
End Function
Public Property Get MartPulled() As Long
MartPulled = mbooMartPulled
End Property
Public Function DataRowArray(ByVal Index As Long) As String()
On Error Resume Next DataRowArray = Split(mstrDataArray(Index), DataColumnDelimiter)
End Function
Public Property Get DataColumnHeaders() As String()
On Error Resume Next If mbooDataLoaded Then DataColumnHeaders = Split(mstrDataArray(0), mstrDataColumnDelimiter)
End Property
Public Property Get PairsCount() As Long
On Error Resume Next If mbooPairsExported Then PairsCount = UBound(mstrPairsArray) + 1 'element zero contians column headers
End Property
Public Property Get PairsExported() As Long
PairsExported = mbooPairsExported
End Property
Public Function PairsExport() As Boolean
Dim oFile As clsFile Dim ndx As Long Dim strField() As String 'array Dim colAtoms As Collection Dim colLinks As Collection Dim strPaired As String Dim strJoin As String Dim varX As Variant ' Atom format (Paired) ' FirName Tab SecName1 Tab SecName2 Tab ... SecNameX On Error GoTo Trap mbooCancel = False Set colAtoms = New Collection Set colLinks = New Collection With New clsStopWatch If mbooMartPulled Then .Reset ' Start timer RaiseEvent Progress("Pairs Export beginning...") ' Enumerate through all Mart array row elements ' and construct the Atoms. For ndx = 1 To Me.MartCount - 1 DoEvents 'allowing update of cancellation flag during loop If Not mbooCancel Then ' Split the outer Mart-array row element into an inner field-array strField() = Split(mstrMartArray(ndx), vbTab) ' Add a new firName to colAtoms MergeSecNameByFirName colAtoms, strField(0), strField(1) If ndx Mod 100 = 0 Then RaiseEvent Progress("Assembling atoms: record " & CStr(ndx)) End If Else Exit Function End If 'Not mbooCancelPairs Next ' Enumerate through all Mart array row elements ' and construct the Links. For ndx = 1 To Me.MartCount - 1 DoEvents 'allowing update of cancellation flag during loop If Not mbooCancel Then ' Split the outer Mart-array row element into an inner field-array strField() = Split(mstrMartArray(ndx), vbTab) ' Add a new SecName to colLinks (notice the parameters are switched) MergeSecNameByFirName colLinks, strField(1), strField(0) ' sort when complete
If ndx Mod 100 = 0 Then RaiseEvent Progress("Assembling links: record " & CStr(ndx) & "+") Else Exit Function End If 'Not mbooCancelPairs Next ' Output the Links as tabular data ndx = 0 ReDim mstrLinksArray(colLinks.Count - 1) ' Copy the collection object ' into the module links array ndx = 0 For Each varX In colLinks mstrLinksArray(ndx) = varX ndx = ndx + 1 Next ' Sort the new Links array, purely for human-readability, as order is irrelavant. QuickSortVariants mstrLinksArray, 0, UBound(mstrLinksArray), 0, UBound(mstrLinksArray) ' Store the array as a CR delimited ' tabular file named Links.txt With New clsFile .Save Join(mstrLinksArray, vbCrLf), DataFolder & "\Links.txt" End With RaiseEvent CommandResponse(CStr(ndx) & " Link saved as tabular data to file " & DataFolder & "\Links.txt") ' Create the paired combinatorics ' Enumerate atomics, creating a tabulation ' by string-concatenation of any new combinatrics ' joined from the array returned by the ' transform method producing combinatorics. ndx = 0 For Each varX In colAtoms strJoin = Join(Combinatorics(varX), vbCrLf) If Len(strJoin) Then If Len(strPaired) = 0 Then strPaired = strJoin Else strPaired = strPaired & vbCrLf & strJoin End If End If
If ndx Mod 10 = 0 Then RaiseEvent Progress("Combining atom " & CStr(ndx) & "...") ndx = ndx + 1 Next ' Store the Pairs tabular string data as a string array mstrPairsArray = Split(strPaired, vbCrLf) ' Sort the new Pairs array QuickSortVariants mstrPairsArray, 0, UBound(mstrPairsArray), 0, UBound(mstrPairsArray) RaiseEvent CommandResponse("Pairs sorted") ' Transform the array, now sorted ' to a string for storage to file strPaired = Join(mstrPairsArray, vbCrLf) ' Save the Pairs array to file Set oFile = New clsFile oFile.Filespec = DataFolder & "\Paired.txt" If oFile.Save(Join(mstrPairsArray, vbCrLf)) Then mbooPairsExported = True PairsExport = mbooPairsExported RaiseEvent CommandResponse("Pairs saved as " & DataFolder & "\Paired.txt") RaiseEvent CommandResponse("Combinatoric-pairs Export complete (Process time: " & CStr(.Elapsed / 1000) & ")") End If Else 'mbooMartPulled RaiseEvent CommandResponse("Unable to Export combinatoric-pairs because the Mart Columns have not been pulled") End If 'mbooMartPulled End With 'New clsStopWatch Exit Function
ExitPoint:
Set colAtoms = Nothing Set colLinks = Nothing
Exit Function
Trap:
RaiseEvent CommandResponse("Error in clsWhse.PairsExport: " & Err.description) Resume ExitPoint Resume
End Function
Public Sub MergeSecNameByFirName( _
ByVal col As Collection, _ ByVal FirName As String, _ ByVal SecName As String _ ) ' Note! July 2023, twenty three years later... ' The first parameter 'ByVal' is ignored and the 'col' collection ' is passed by reference. This never threw an error. ' The line should read: ' "ByRef col As Collection, _" ' ' Build a unique collection of Firname record delimitations ' Append uniquely the secname into the Tab-delimited ' string value referenced by the collection member, keyed by Firname ' The collection members delimited format is follows: ' FirName Tab SecName1 Tab SecName2 Tab SecName3 ... Dim strElements As String On Error Resume Next 'Add a new member keyed by FirName... col.Add FirName & vbTab & SecName, Key:=FirName 'This errors if member already exists -used because VB Collection object has no 'exists' function. If Err.number = 457 Then ' Exists already, so concatentate SecName to existing SecNames if not already there strElements = col.Item(CStr(FirName)) ' Append uniquely the secname to the secname delimitation If InStr(1, strElements, SecName) = 0 Then 'secname is not already in strSecNames, so concatenate it strElements = Join(Array(strElements, SecName), vbTab) col.Remove FirName col.Add strElements, FirName End If End If
End Sub
Public Property Get AtomsExtracted() As Boolean
AtomsExtracted = mbooAtomsExtracted
End Property
Public Property Get DataFile() As String
DataFile = mstrDataFile
End Property Public Property Let DataFile(ByVal Value As String)
mstrDataFile = Value
End Property
Public Property Get DataFolder() As String ' r/o
DataFolder = FileFolder(mstrDataFile)
End Property
Public Property Get DataLoaded() As Boolean
DataLoaded = mbooDataLoaded
End Property
Public Property Get DataHeaderRowIndex() As Long
DataHeaderRowIndex = mlngDataHeaderRowIndex
End Property Public Property Let DataHeaderRowIndex(ByVal Value As Long)
mlngDataHeaderRowIndex = Value
End Property