QAT Code: Whse Class and Dev:Notes on the Cartesian Product: Difference between pages

From Catcliffe Development
(Difference between pages)
Jump to navigation Jump to search
(Created page with "{{headerQuasiAI|subcat=QAT.code}} {{headerQATcode| —Warehouse Class Code}} Category:QAT.clsWhse <div style="background:azure; border:1px outset azure; margin:1em 2em; padding:0 1em; width:888px;"> 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...")
 
m (XenoEngineer moved page Notes on the Cartesian Product to Dev:Notes on the Cartesian Product without leaving a redirect)
 
Line 1: Line 1:
{{headerQuasiAI|subcat=QAT.code}}
{{headerQuasiAI|subcat=Cartesian product}}
{{headerQATcode| &mdash;Warehouse Class Code}}
[[Category:QAT.clsWhse]]


<div style="background:azure; border:1px outset azure; margin:1em 2em; padding:0 1em; width:888px;">
https://chat.openai.com/share/602bcc98-bc74-4550-9c16-02e79a8a9246
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
 
 
</div>

Latest revision as of 18:57, 17 July 2023

quasiArtifactualIntelligence —a perception from the edge

  About ∞ White paper ∞ QuasiMatrix Code ∞ QAT Code ∞ Data Examples ∞ Scatter-Gather Explained ∞ The Plow Share ∞

https://chat.openai.com/share/602bcc98-bc74-4550-9c16-02e79a8a9246

Retrieved from "http://groupkos.com/dev/index.php?title=QAT_Code:_Whse_Class&oldid=790"