QAT Code: SLIP
Jump to navigation
Jump to search
About ∞ White paper ∞ QuasiMatrix Code ∞ QAT Code ∞ Data Examples ∞ Scatter-Gather Explained ∞ The Plow Share ∞
The QAT Code — VB6 SLIP class module
The Warehouse if Pairs Expansion then Visual Scatter else Visual Cluster redim Bracketing Clusters while Event Chemistry wend SLIP class redim
'--------------------------------------------------------------------------------
' Component : clsSLIP class module
' Project : QAT
' Copyright : DonEMitchell 2001-2011 Sequim, WA - Cottonwood, AZ
'
' Prueitt-Mitchell (2011): Completion of the QAT Ontology engine.
' Version 2.8.X edits opened October 27, 2011
' Modified : 10/27/2011-2:29:30 PM on Developer
'--------------------------------------------------------------------------------
Private mcolTopicTree As Collection ' Holds name-keyed references to clsTopic instances.
Private moTopicSelection As clsTopic ' Reference object of user-selection.
Private moAtoms As clsAtoms
' Change-events called by this class (invokes event code in the user form when 'raised' in this class)
Public Event TopicCreated(ByRef oTopic As clsTopic)
Public Event TopicSelected(ByRef oTopic As clsTopic)
Public Event PairsImported(ByRef oRoot As clsTopic)
Public Event ReportKeyChanged(ByVal KeyColumn As Long)
Public Event AtomRadialDistributionChanged(ByRef oTopic As clsTopic)
Public Event Atom3DDistributionChanged(ByRef oTopic As clsTopic)
Public Event RemarkAppended(ByVal NewLine As String)
Public Event CommandResponse(ByVal Message As String)
Public Event Progress(ByVal Message As String)
Private mstrPairsArray() As String
Private mstrAtomsStringBuffer As String
Private mstrPairsStringBuffer As String
Private mbooSourceLoaded As Boolean
Private mbooPairsImported As Boolean
Private mbooReportGenEnabled As Boolean
Private mintReportSortColumn As Integer
Private mlngReportKeyColumn As Long
Private mintLevelCount() As Integer ' Array stores topics-count per level for spacing the TG nodes.
Private mintMickey As Integer ' Mouse-button flag.
Private mstrDataPath As String
Private mstrEventBrowser As String
' State-flags
Private mbooIterating As Boolean
Private Sub Class_Initialize()
On Error Resume Next
' Data-structure ' Functionality:
Set mcolTopicTree = New Collection ' A collection of topic instances by Name, affording tree-hiearchy-navigation through Parent property of clsTopic.
Set moAtoms = New clsAtoms
Set moTopicSelection = New clsTopic
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Set mcolTopicTree = Nothing
Set moAtoms = Nothing
Set moTopicSelection = Nothing
End Sub
Public Sub INILoadProperties()
On Error Resume Next
mstrDataPath = INIGetString("SLIP", "RootTopicName", cDefTopTopicName)
mbooSaveProperties = INIGetBool("SLIP", "SaveProperties", "1")
End Sub
' Saves the default variables to a private profile (QAT.INI file)
Public Sub INISaveProperties()
Dim lngResult As Long
Dim lngCount As Long
' Save Properties, optionally.
INIWrite "SLIP", "SaveProperties", CStr(mbooSaveProperties)
If mbooSaveProperties Then
INIWrite "SLIP", "RootTopicName", mstrDataPath
End If
End Sub
Public Function IsTopic(ByVal Name As String) As Boolean
' Return True if Name matches at least one name in the Topic collection.
Dim topicX As clsTopic
' Loop through the topic-object collection, comparing names until the first match.
For Each topicX In mcolTopicTree
If StrComp(topicX.Name, Name, vbTextCompare) = 0 Then 'a case-insensitive match (first)
IsTopic = True
Exit For
End If
Next
End Function
Public Function topicFindTopic(ByVal Name As String) As clsTopic
' This assumes all topic names are unique
Dim topicX As clsTopic
On Error Resume Next
For Each topicX In momcolTopicTree
If StrComp(Name, topicX.Name, vbTextCompare) = 0 Then
Set topicFindTopic = topicX
Exit For
End If
Next
End Function
Public Function topicMembersFile(ByVal oTopic As clsTopic) As String
End Function
Public Function topicSortedReport(ByRef oTopic As clsTopic) As String
' Load the Report.txt contents.
' Split into an array.
' Sort by ReportSortColumn.
' Re-concatenate a CR delimited report string and return it.
Dim ndx As Long
Dim ndxDeepest As Long
Dim strFilespec As String
Dim strReport As String
Dim strReportHeader As String
Dim strReportArray() As String 'array
Dim strFirst As String
Dim strSecond As String
Dim strTemp As String
On Error GoTo Trap
' Load the Report.txt file
strFilespec = Root.WhsePath & oTopic.Path & "\Report.txt"
With New clsFile
If .FileExists(strFilespec) Then
' The report now exists by the same filespec, read it into variables
strReportHeader = .ReadLine
strReport = Mid$(.ReadAll, Len(strReportHeader) + 3) ' read everything past the header line
' Remove trailing outer delimiters
TrimTrailingCharacters strReport, vbCrLf
' Split into an array at the outter delimiting CRs
strReportArray = Split(strReport, vbCrLf)
' Sort the Array on ReportSortColumn
DataSortStringArray strReportArray
' Now concatenate an output string from the sorted array
' Start with a header
topicSortedReport = strReportHeader & vbCrLf
' concatenate each array element with CR delimitation
For ndx = 0 To UBound(strReportArray)
topicSortedReport = topicSortedReport & strReportArray(ndx) & vbCrLf
Next ndx
' Remove trailing outer delimiter from concatenation
topicSortedReport = modMain.TrimTrailingCharacters(topicSortedReport, vbCrLf)
.CloseFileRead
' Save to file
If Not .Save(topicSortedReport, strFilespec) Then
RaiseEvent CommandResponse("Unable to save the sorted report to file " & strFilespec)
MsgBox "Unable to save the sorted report to file " & strFilespec, vbExclamation
End If
End If
End With
ExitPoint:
Exit Function
Trap:
topicSortedReport = "Error encountered: Unable to sort " & oTopic.Name & " on column " & DataReportSortColumn & " of columns 0-7"
RaiseEvent CommandResponse("Unable to sort " & oTopic.Name & " on column " & DataReportSortColumn & " of columns 0-7")
Resume ExitPoint
Resume
End Function
Public Function topicTopic(ByVal Path As String) As clsTopic
On Error Resume Next
Set topicTopic = momcolTopicTree.Item(Path)
End Function
Public Function topicTopicRemark(ByVal oTopic As clsTopic) As String
End Function
Public Function ReportWhseRecords(ByRef Atoms As clsAtoms) As String
' Extract all warehouse records that match to any
' atom name in the MatchColumn specified by DataReportKeyColumn
' Return the report-string.
Dim strWhse As String
Dim strRecords() As String 'array
Dim strFields() As String 'array
Dim atomX As clsAtom
Dim ndx, ndxProgress As Long
Dim strReportFilespec As String
Dim strReport As String
On Error Resume Next
RaiseEvent CommandResponse("Generating a warehouse data report...")
' Enable the report loop
mbooReportGenEnabled = True
strReportFilespec = mstrDataPath & "\" & "WhseReport.txt"
With New clsFile
If .FileExists(Root.WhsePath & "\Datawh.txt") Then 'redundant existence test, but validates folder edits
' Read the warehouse data file contents to a working string
strWhse = .ReadAll
' Remove all trailing outer-delimiters from the whse
modMain.TrimTrailingCharacters strWhse, vbCrLf
' Split the warehouse data string into an array at the CRs
strRecords = Split(strWhse, vbCrLf)
' Start the report with the header line from the whse
strReport = strRecords(0) & vbCrLf
' Convention requires the warehouse data file
' contains column names as line one, therefore
' array element zero contains column names.
' Loop through all atoms, using the atom
' name as the look-up key for matches
' of the atom name with the specified key column
For Each atomX In Atoms
' Loop through all records, and
' examine the MatchColumn specified for a match with the Atom name
' Concatenate the matching records as a
' sub-set of the Warehouse, and return the sub-set
If mbooReportGenEnabled Then
ndxProgress = ndxProgress + 1
RaiseEvent Progress(CStr(ndxProgress) & ":" & CStr(ndx))
' Yield to system needs (systemic affordance)
' allowing report cancellation with Stop command
DoEvents
For ndx = 1 To UBound(strRecords) 'skip element zero, the whse column header
If ndx Mod 5000 = 0 Then RaiseEvent Progress(CStr(ndxProgress) & ":" & CStr(ndx))
DoEvents
If Not mbooReportGenEnabled Then Exit Function
' Split the record into an array at the Tabs
strFields = Split(strRecords(ndx), vbTab)
If Len(strRecords(ndx)) Then
' Check for a match with key on the specified MatchColumn
' and concatenate the return as a CR delimited string
If StrComp(strFields(DataReportKeyColumn), atomX.Name) = 0 Then
strReport = strReport & strRecords(ndx) & vbCrLf
End If
End If
Next ndx
' Save the report while in progress of looping through atoms
With New clsFile
If .Save(strReport, strReportFilespec) Then
' Reselect
Set Context.TopicSelection = Context.TopicSelection
RaiseEvent CommandResponse("Unable to save the report on member " & atomX.Name & " to file " & strReport)
End If
End With
Else
MsgBox "Report aborted", vbInformation
RaiseEvent CommandResponse("Report generation aborted")
Exit For
End If ' mbooReportGenEnabled
Next atomX
' Notify interested agencies
RaiseEvent CommandResponse("Report generated from warehouse records for matches in column " & CStr(DataReportKeyColumn) & " (zero-base)")
' Remove the trailing CR
strReport = modMain.TrimTrailingCharacters(strReport, vbCrLf)
Else
RaiseEvent CommandResponse("Data warehouse not available: " & Root.WhsePath & "\Datawh.txt")
MsgBox "Data warehouse not available: " & Root.WhsePath & "\Datawh.txt"
End If
' Return the report
ReportWhseRecords = strReport
End With
End Function
'
'Public Function CreateAttribute(ByVal Name As String, ByVal Value As String) As clsAttribute
' On Error Resume Next
'
' Set CreateAttribute = New clsAttribute
' With CreateAttribute
' .Name = Name
' .Value = Value
' End With
'End Function
' Instance constructors
Public Function CreateTopTopic( _
ByVal Name As String, _
ByVal x As Long, _
ByVal Y As Long) As clsTopic
Dim oNew As clsTopic
On Error Resume Next
Set oNew = New clsTopic 'create a concrete type for return
With oNew
.Name = Name
.MetricsX = x
.MetricsY = Y
.RadialMagnification = 30 'Default
Set .Atoms = DataLoadMembers(Root.WhsePath & "\" & Name & "\Members.txt")
End With
' Add a reference in the TopicSpace
mcolTopicTree.Add oNew, oNew.Path 'keyed by path
' Notify the world
RaiseEvent TopicCreated(oNew)
' Return the new member
Set CreateTopTopic = oNew
Set oNew = Nothing
End Function
Public Function CreateTopic( _
ByVal Name As String, _
ByVal x As Long, _
ByVal Y As Long, _
oParent As clsTopic) As clsTopic
' Construct a concrete clsTopic instance.
Dim oNewTopic As clsTopic
On Error Resume Next
Set oNewTopic = New clsTopic
With oNewTopic
.Name = Name
Set .TopicParent = Me
Set .Atoms = DataLoadMembers( _
MembersFileSpec:=Root.WhsePath & oParent.Path & "\" & Name & "\Members.txt")
.MetricsX = x
.MetricsY = Y
.RadialMagnification = 30 'larger default for non-root levels
End With
' Add a reference to the new topic in the Children
' collection of the Parent Topic, keyed by Name
' This creates parent-child linking
oParent.TopicChildren.Add oNewTopic, oNewTopic.Name
' Add a reference in the TopicSpace keyed by path
mcolTopicTree.Add oNewTopic, oNewTopic.Path 'keyed by path
' Notify the world
RaiseEvent TopicCreated(oNewTopic)
Set CreateTopic = oNewTopic
Set oNewTopic = Nothing
End Function
Public Function DataAppendRemarkFile( _
ByVal NewLine As String, _
ByVal Filespec As String, _
Optional SendEventMsg As Boolean = True) As Boolean
' Save the file and send a RemarkAppended message, maybe
On Error GoTo Trap
With New clsFile
.OpenForAppend Filespec
.WriteLine NewLine
If SendEventMsg Then RaiseEvent RemarkAppended(NewLine)
RaiseEvent CommandResponse("Remark line appended")
End With
DataAppendRemarkFile = True
ExitPoint:
Exit Function
Trap:
'Append contextual information into existing err object Description
Err.Description = "SLIP.clsSLIP.DataAppendRemarkFile: " & Err.Description & " - File: " & Filespec
Err.Raise Err.Number
Resume ExitPoint
End Function
Public Property Get DataAtoms() As clsAtoms
Set DataAtoms = moAtoms
End Property
Public Function DataReadReportKey() As Boolean
Dim strConjecture As String
On Error GoTo Trap
With New clsFile
' Read the conjecture file for the report key column (B)
If .FileExists(mstrDataPath & "\Conjecture.txt") Then
strConjecture = .ReadAll()
DataReportKeyColumn = Split(strConjecture, vbTab)(0)
RaiseEvent CommandResponse("Report key Column set to " & CStr(DataReportKeyColumn))
DataReadReportKey = True
Else
DataReportKeyColumn = 4
RaiseEvent CommandResponse("Conjecture data not found -defaulting report key column to 4")
End If
End With
RaiseEvent CommandResponse("Reading ReportKeyColumn from Conjecture data")
Exit Function
Trap:
RaiseEvent CommandResponse("Report Key Column not set. Error reading " & mstrDataPath & "\Conjecture.txt" & Err.Description)
End Function
Public Property Get DataPairsArray() As String()
DataPairsArray = mstrPairsArray
End Property
Public Property Let DataReportGenerationEnabled(ByVal RHS As Boolean)
mbooReportGenEnabled = RHS
End Property
Public Property Get DataReportGenerationEnabled() As Boolean
DataReportGenerationEnabled = mbooReportGenEnabled
End Property
Public Property Get DataReportKeyColumn() As Long
DataReportKeyColumn = mlngReportKeyColumn
End Property
Public Property Let DataReportKeyColumn(ByVal Value As Long)
mlngReportKeyColumn = Value
RaiseEvent ReportKeyChanged(Value)
End Property
Public Property Let DataReportSortColumn(ByVal RHS As Integer)
mintReportSortColumn = RHS
End Property
Public Property Get DataReportSortColumn() As Integer
DataReportSortColumn = mintReportSortColumn
End Property
Public Sub DataRotateAtoms3DUnused(oTopic As clsTopic, ByVal Rotation As Integer, ByVal Incline As Integer)
' Convert each (x,y,z) point to a vector (angleI, angleR, length)
' Increment the cyphered vector by the passed parameters
' Convert the incremented vector back to a Cartesian coordinates
' and update the atom with the new (x,y,z) coordinates
Dim atomX As clsAtom
Dim x, Y, Z As Single
For Each atomX In oTopic.Atoms
Next
End Sub
Public Sub DataSortStringArray(ByRef SourceArray() As String)
Dim ndx, ndxDeepest As Long
Dim strFirst As String
Dim strSecond As String
Dim strTemp As String
ndx = 0
On Error Resume Next
' Sort the Array on KeyColumn into ordinal rank predicated by string compare method
Do While ndx < UBound(SourceArray) - 1
' Retreive the keycolumn values of two successive array elements which are split by tabs
strFirst = Split(SourceArray(ndx), vbTab)(mintReportSortColumn) 'default to zero, temporal sort
strSecond = Split(SourceArray(ndx + 1), vbTab)(mintReportSortColumn)
Select Case StrComp(strFirst, strSecond)
Case -1, 0 ' ndx1 <= ndx2
ndx = ndxDeepest + 1
ndxDeepest = ndx
Case 1 'ndx1 > ndx2
' Swap the inordinate pair
strTemp = SourceArray(ndx + 1)
SourceArray(ndx + 1) = SourceArray(ndx)
SourceArray(ndx) = strTemp
' Store the deepest progress
If ndx > ndxDeepest Then ndxDeepest = ndx
' Backup the index by one
' to reinspect the prior pair,
' unless its the top element 1
If ndx > 0 Then ndx = ndx - 1
End Select
'Debug.Print CStr(ndx) & String(ndx + 1, "-") & "+"
Loop
End Sub
'Public Property Get DataWarehouseArray() As String()
' DataWarehouseArray = mstrPairsArray
'End Property
'
Public Property Get DataAtomsStringBuffer() As String
DataAtomsStringBuffer = mstrAtomsStringBuffer
End Property
Public Function DataClearTopicGraph() As Boolean
' Clear everything but
' the Functionality Singleton instance
' the GUID, as this instance still exists
' and the TopicMetrics fields, of the top Topic,
' being situated context information.
Set mcolTopicTree = New Collection
Set ContextTopicSelection = Nothing
mbooIterating = False
ReDim mintLevelCount(0)
mstrAtomsStringBuffer = ""
mstrPairsStringBuffer = ""
mbooSourceLoaded = False
mbooPairsImported = False
ReDim mstrPairsArray(0)
mbooIterating = False
mbooReportGenEnabled = True
mintReportSortColumn = cDefWhseRepSortCol
mlngReportKeyColumn = cDefWhseRepKeyCol
ReDim mintLevelCount(0)
mintMickey = 0
mstrDataPath = ""
mstrEventBrowser = ""
' Send a message.
RaiseEvent CommandResponse("Topic Graph Cleared")
End Function
Public Sub DataClusterAtomsRadial(ByRef oTopic As clsTopic, Optional ByVal MaxKiloIters As String = "100")
Dim AtomA As clsAtom
Dim AtomB As clsAtom
Dim intGap As Integer
Dim intDifference As Integer
Dim ndx As Long 'max value past four billion
Dim strPair As String 'holds "**" delimited pair-names of two randomly selected Atoms
Dim atomX As clsAtom
Dim strMember As String
Dim intAngle1 As Integer
Dim intAngle2 As Integer
Dim strTemp As String
Dim strTabulation As String
Dim lngMaxIters As Long
Dim lngStartingIters As Long
Dim col As Collection 'pair counter with hash
'Const cHeat = 0.05
'Const cHeat = 0.3
Const cHeat = 0.67
'Const cHeat = 1
'Const cHeat = 1.33
On Error Resume Next
Set col = New Collection
Screen.MousePointer = vbArrowHourglass ' because DoEvents is in a loop,
' allowing IterationEnabled to be toggled
' while iterating
' Cypher stop point
lngMaxIters = CSng(MaxKiloIters) * 1000
lngStartingIters = oTopic.RadialIters
RaiseEvent CommandResponse("Clustering in progress...")
' Loop until disabled (grammatical Stop)
Randomize ' Randomize the seed of the Rnd statement
DataIterationEnabled = True
While mbooIterating And (ndx < lngMaxIters)
DoEvents 'allowing IterationEnabled to be toggled
With oTopic.Atoms
' Randomly select two atoms
Set AtomA = .Item(CInt(Rnd * (.Count - 1)) + 1) 'retrieve Atom by random ordinal
Set AtomB = .Item(CInt(Rnd * (.Count - 1)) + 1)
End With
' Build a name-pair from randomly selected Atoms
strPair = AtomA.Name & "**" & AtomB.Name
'col.Add strPair, strPair
'If Err = 0 Then
' Debug.Print col.Count; strPair
'End If
Err.Clear
' Seek for the presence of the pair in the tabular pairs buffer
' If found the pair is moved closer together
If PairExists(strPair) Then
'Debug.Print "Pair count: " & CStr(col.Count)
' Move the two atoms closer,
' leaving the separation at
' cHeat portion of the original radial gap
' Store the smaller degree as Angle1 and larger degree as Angle2
If (AtomA.Degree < AtomB.Degree) Then
intAngle1 = AtomA.Degree
intAngle2 = AtomB.Degree
Else
intAngle1 = AtomB.Degree
intAngle2 = AtomA.Degree
End If
' Store the difference in angles
intGap = intAngle2 - intAngle1
Select Case (intGap)
Case Is <= 180
intAngle1 = (cHeat * intGap / 2) + intAngle1
intAngle2 = intAngle2 - (cHeat * intGap / 2)
Case Is > 180
intGap = 360 - intGap
intAngle1 = intAngle1 - (cHeat * intGap / 2)
intAngle2 = (cHeat * intGap / 2) + intAngle2
End Select
' Normalize the RadialAngle, should any have lapsed negative
If intAngle1 < 0 Then intAngle1 = intAngle1 + 360
If intAngle1 > 360 Then intAngle1 = intAngle1 - 360
If intAngle2 < 0 Then intAngle2 = intAngle2 + 360
If intAngle2 > 360 Then intAngle2 = intAngle2 - 360
AtomA.Degree = intAngle1
AtomB.Degree = intAngle2
End If 'PairExists(strPair)
' Increment the index
ndx = ndx + 1
' Every 10000 iterations,
' or every attainment of MaxIters,
' save and update the plot
If (ndx Mod 10000) = 0 Or ndx >= lngMaxIters Then
' Update the memory instance of oTopic
oTopic.RadialIters = lngStartingIters + ndx
'Debug.Print atomA.Name; atomB.Name
'Debug.Print oTopic.RadialIters; ndx
' Send notifacation message
RaiseEvent AtomRadialDistributionChanged(oTopic)
' Save the Members tabulation to file
With New clsFile
' Convert the Atoms object to a string
strTabulation = Tabular.SerializeMembers(oTopic.Atoms)
' Save the string as the current iterated state of members
.Save _
Buffer:=strTabulation, _
Filespec:=mstrDataPath & oTopic.Path & "\Members.txt"
.CloseFileWrite
' Update the user interface.
RaiseEvent AtomRadialDistributionChanged(oTopic)
Stop
End With
End If
Wend
oTopic.RadialIters = lngStartingIters + ndx
DataIterationEnabled = False
RaiseEvent CommandResponse("Clustering iterations completed: " & CStr(ndx))
Screen.MousePointer = vbDefault
End Sub
Public Sub DataClusterAtoms3D(ByRef oTopic As clsTopic, Optional ByVal MaxKiloIters As String = "100")
Dim AtomA As clsAtom
Dim AtomB As clsAtom
Dim intGap As Integer
Dim intDifference As Integer
Dim ndx As Long 'max value past four billion
Dim strPair As String 'holds "**" delimited pair-names of two randomly selected Atoms
Dim atomX As clsAtom
Dim strMember As String
Dim intAngle1 As Integer
Dim intAngle2 As Integer
Dim strTemp As String
Dim strTabulation As String
Dim lngMaxIters As Long
Dim lngStartingIters As Long
Dim intMoves As Integer
'Const cHeat = 0.05
'Const cHeat = 0.3
Const cHeat = 0.67
'Const cHeat = 1
'Const cHeat = 1.33
On Error GoTo Trap
' Cypher stop point
lngMaxIters = CLng(MaxKiloIters) * 1000
lngStartingIters = oTopic.RadialIters
RaiseEvent CommandResponse("Clustering in progress...")
Randomize ' Randomize the seed of the Rnd statement
DataIterationEnabled = True
' Loop until disabled (grammatical Stop)
While mbooIterating And (ndx < lngMaxIters)
DoEvents 'allowing IterationEnabled to be toggled
With oTopic.Atoms
' Randomly select two atoms
Set AtomA = .Item(CInt(Rnd * (.Count - 1)) + 1) 'retrieve Atom by random ordinal
Set AtomB = .Item(CInt(Rnd * (.Count - 1)) + 1)
End With
' Build a name-pair from randomly selected Atoms
strPair = AtomA.Name & "**" & AtomB.Name
' Seek for the presence of the pair in the tabular pairs buffer
' If found the pair is moved closer together
If PairExists(strPair) Then
' Reduce the 3D-space distance between the pair
'newDistance = Metrics.AtomicDistance(AtomA, AtomB) / cHeat
With AtomA
.MetricsX = .MetricsX + cHeat * (AtomB.MetricsX - .MetricsX) / 2
.MetricsY = .MetricsY + cHeat * (AtomB.MetricsY - .MetricsY) / 2
.MetricsZ = .MetricsZ + cHeat * (AtomB.MetricsZ - .MetricsZ) / 2
End With
With AtomB
.MetricsX = .MetricsX - cHeat * (.MetricsX - AtomA.MetricsX) / 2
.MetricsY = .MetricsY - cHeat * (.MetricsY - AtomA.MetricsY) / 2
.MetricsZ = .MetricsZ - cHeat * (.MetricsZ - AtomA.MetricsZ) / 2
End With
End If 'PairExists(strPair)
' Increment the index
ndx = ndx + 1
' Every 10000 iterations,
' or every attainment of MaxIters,
' save and update the plot
If (ndx Mod 10000) = 0 Or ndx >= lngMaxIters Then
' Update the memory instance of oTopic
oTopic.RadialIters = lngStartingIters + ndx
'Debug.Print atomA.Name; atomB.Name
'Debug.Print oTopic.RadialIters; ndx
' Send notifacation message
RaiseEvent Atom3DDistributionChanged(oTopic)
'GoTo fu
' Save the Members tabulation to file
With New clsFile
' Convert the Atoms object to a string tabulation
strTabulation = Tabular.SerializeMembers(oTopic.Atoms)
' Save the Members tabulation to file
.Save _
Buffer:=strTabulation, _
Filespec:=mstrDataPath & oTopic.Path & "\Members.txt"
.CloseFileWrite
' Send notifacation message
RaiseEvent Atom3DDistributionChanged(oTopic)
End With
fu:
End If
Wend
oTopic.RadialIters = lngStartingIters + ndx
RaiseEvent CommandResponse(CStr(ndx) & " 3D Clustering iterations completed")
ExitPoint:
Exit Sub
Trap:
Resume ExitPoint
Resume
End Sub
Function PairExists(ByVal Pair As String) As Boolean
' Pair is compared against the middle, then successive
' binary division of remaining middles on either
' left or right of the compare point,
' until the exact match is found, which returns true,
' or until there are no further records to divide, returning false
' The mstrPairsArray is assumed to be sorted in ascending rank
' The ordination of rank among the array names then become a
' self-index into the array by value of the array element, based on a successive binary division
' of left or right halves, pending a string comparison returning
' a three-state result: less, equal or greater.
Dim lngSmaller As Long
Dim lngMiddle As Long
Dim lngLarger As Long
Dim ndxAttempts As Integer
On Error Resume Next
lngSmaller = 0
lngLarger = UBound(mstrPairsArray)
'Debug.Print "Total Pairs: " & UBound(mstrPairsArray) + 1
Do While lngSmaller < lngLarger
' Place a middle ndx in the current bounded block
lngMiddle = lngSmaller + ((lngLarger - lngSmaller) / 2)
' Based on the case of StrComp,
' Move either the smaller or larger index to the middle
' Until middle locates on a match
Select Case StrComp(Pair, mstrPairsArray(lngMiddle))
Case -1 'Pair < Array middle
' Adjust the block boundaries
lngLarger = lngMiddle - 1
ndxAttempts = ndxAttempts + 1
'Debug.Print ndxAttempts;
Case 0 ' a match
lngSmaller = lngLarger 'satisfies loop
PairExists = True
Case 1 'Pair > Array middle
' Adjust the block boundaries
lngSmaller = lngMiddle + 1
ndxAttempts = ndxAttempts + 1
'Debug.Print ndxAttempts;
End Select
Loop
'Debug.Print String(ndxAttempts, "-") & "+"
Trap:
End Function
Public Function DataExtractAtoms(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
mintMickey = Screen.MousePointer
Screen.MousePointer = vbHourglass
RaiseEvent CommandResponse("Extracting unique members from Paired.txt...")
DoEvents
' Clear Atoms buffer and copy the Pairs to
' strPairs for conditioning
mstrAtomsStringBuffer = ""
strPairs = mstrPairsStringBuffer
' 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
If ndx Mod 100 = 0 Then
RaiseEvent Progress("Extracting atoms... " & CStr(ndx))
DoEvents
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(Root.WhsePath & "\" & 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
DataExtractAtoms = 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.WhsePath & "\" & TopicName
If .Save(mstrAtomsStringBuffer) Then
RaiseEvent CommandResponse("Extracted Atoms saved to " & .Filespec)
DataExtractAtoms = 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("Atoms extracted: " & CStr(intExtractions))
Screen.MousePointer = mintMickey
End Function
Public Function DataExtractSelectedAtoms(ByVal TopicName As String) As Boolean
' On the selected topic,
' Tabulate a string concatenation of Atom names and RadialAngles
' between starting and ending RadialSelection degrees
' and save them into a a new folder created,
' named by the value of TopicName
' Format: AtomCategoryValue vbTab Degree
' where Degree is 1 to 360.
Dim intCount As Integer
Dim strRadialSelection As String
Dim strSplitPairs() As String 'array
Dim lngLength As Long
Dim atomX As clsAtom
On Error Resume Next
mintMickey = Screen.MousePointer
Screen.MousePointer = vbHourglass
RaiseEvent CommandResponse("Extracting selected member atoms from " & Context.TopicSelection.Name)
' Loop through all atoms of the context selected
' and string concatenate a tabular file stream
With Context.TopicSelection
For Each atomX In .Atoms
If atomX.Degree >= RadialSelectionStart Then
If atomX.Degree <= .Meta.SelectEnd Then
strRadialSelection = strRadialSelection & atomX.Name & vbTab & CStr(atomX.Degree) & vbCrLf
intCount = intCount + 1
End If
End If
Next
End With 'Context.TopicSelection
' Remove the trailing delimiter
strRadialSelection = Left$(strRadialSelection, Len(strRadialSelection) - Len(vbCrLf))
' Write the fresh selection Members data to file as the Members of the new Topic named
' the value in 'TopicName' in a folder named by the value in 'TopicName'
With New clsFile
' Create a new Members.txt file if non-existant,
' or query the user for overwrite permission,
' else bail, no persistence -- no existence
Select Case .FileExists(Root.WhsePath & Context.TopicSelection.Path & "\" & 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(strRadialSelection, UseAppend:=False) Then
' Create (or err past if existing) a folder for the top node, named A1
DataExtractSelectedAtoms = True
Else
MsgBox "Unable to save the Atoms Selected to: " & .Filespec
End If
End If
Case False
' Create the new Topic Folder
MkDir Root.WhsePath & Context.TopicSelection.Path & "\" & TopicName 'errors if exists
If Not .Save(strRadialSelection) Then 'any sort of error will cause the next line to execute by default of resume-next
RaiseEvent CommandResponse("Unable to save the extractted members to: " & .Filespec)
MsgBox "Unable to save the Atoms extracted from Paired.txt to: " & .Filespec
Else
DataExtractSelectedAtoms = True
End If
End Select
End With
RaiseEvent CommandResponse("Atom 'Extraction' successful for selected radial-members as " & TopicName & ". " & CStr(intCount) & " radial-members extracted.")
Screen.MousePointer = mintMickey
End Function
Public Function DataExtractResidualAtomsBuggy(Optional ByVal ResidualTopicName As String = "R") As Boolean
' On the selected topic,
' Tabulate a string concatenation of Atom names and RadialAngle
' that are not found in a child,
' and save them into a new folder created,
' named by the value of ResidualTopicName
Dim ndx, ndxDeepest As Long
Dim strResidual As String
Dim strAtoms() As String 'array
Dim lngLength As Long
Dim topicX As clsTopic
Dim atomX As clsAtom
Dim strTemp As String
On Error Resume Next
' Dimension a storage array to hold all of the atoms of all of the child topics
' This number will be no bigger than the atom count of the topic.
ReDim strAtoms(Context.TopicSelection.Atoms.Count)
' Loop through all atoms of all children of the selected context
' and string concatenate a tabular file stream
With Context.TopicSelection
For Each topicX In .Structure.Children
For Each atomX In topicX.Atoms
strAtoms(ndx) = atomX.Name
ndx = ndx + 1
'Debug.Print topicX.Name; ndx
Next
Next
' Redim the atoms array to loose any trailing unused array elements
ReDim Preserve strAtoms(ndx - 1)
ndx = 0
' Sort the Array into ordinal rank predicated by string compare method
Do While ndx < UBound(strAtoms) - 1
Select Case StrComp(strAtoms(ndx), strAtoms(ndx + 1))
Case -1, 0 ' ndx1 <= ndx2
ndx = ndxDeepest + 1
ndxDeepest = ndx
Case 1 'ndx1 > ndx2
' Swap the inordinate pair
strTemp = strAtoms(ndx + 1)
strAtoms(ndx + 1) = strAtoms(ndx)
strAtoms(ndx) = strTemp
' Store the deepest progress
If ndx > ndxDeepest Then ndxDeepest = ndx
' Backup the index by one
' to reinspect the prior pair,
' unless its the top pair
If ndx > 0 Then ndx = ndx - 1
End Select
'Debug.Print CStr(ndx) & String(ndx + 1, "-") & "+"
Loop
Dim ndx2 As Integer
ndx = 0
For Each atomX In .Atoms
' Concatenate a file stream tabulation
' of all atoms that are not in the strAtoms array
If Not ElementExists(strAtoms, atomX.Name) Then
ndx = ndx + 1
strResidual = strResidual & atomX.Name & vbTab & CStr(atomX.Degree) & vbCrLf
Else
ndx2 = ndx2 + 1
End If
Next
'Debug.Print ndx; ndx2
' Remove the trailing delimiter
strResidual = Left$(strResidual, Len(strResidual) - Len(vbCrLf))
End With 'Context.TopicSelection
' Write the fresh selection Members data to file as the Members of the new Topic named
' the value in 'ResidualTopicName' in a folder named by the value in 'ResidualTopicName'
With New clsFile
' Create a new Members.txt file if non-existant,
' or query the user for overwrite permission,
' else bail, no persistence -- no existence
Select Case .FileExists(Root.WhsePath & Context.TopicSelection.Path & "\" & ResidualTopicName & "\Members.txt")
Case True
If MsgBox("Overwrite the Members.txt file for Topic " & ResidualTopicName & "?", vbYesNo + vbQuestion + vbDefaultButton2, "Random distribution available") = vbYes Then
If .Save(strResidual, UseAppend:=False) Then
' Create (or err past if existing) a folder for the top node, named A1
DataExtractResidualAtomsBuggy = True
Else
MsgBox "Unable to save the Atoms Selected to: " & .Filespec
End If
End If
Case False
' Create the new Topic Folder
MkDir Root.WhsePath & Context.TopicSelection.Path & "\" & ResidualTopicName 'errors if exists
If Not .Save(strResidual) Then 'any sort of error will cause the next line to execute by default of resume-next
MsgBox "Unable to save the Atoms extracted from Paired.txt to: " & .Filespec
Else
DataExtractResidualAtomsBuggy = True
End If
End Select
End With
Set atomX = Nothing
Set topicX = Nothing
End Function
Public Function DataExtractResidualAtoms(Optional ByVal ResidualTopicName As String = "R") As Boolean
' On the selected topic,
' Tabulate a string concatenation of Atom names and RadialAngle
' that are not found in a child,
' and save them into a new folder created,
' named by the value of ResidualTopicName
Dim ndx, ndx2, ndxDeepest As Long
Dim strResidual As String
Dim strSiblingAtoms As String
Dim lngLength As Long
Dim topicX As clsTopic
Dim atomX As clsAtom
Dim strTemp As String
On Error Resume Next
mintMickey = Screen.MousePointer
Screen.MousePointer = vbHourglass
RaiseEvent CommandResponse("Extracting residual member atoms from " & Context.TopicSelection.Name)
' Loop through all atoms of all children of the selected context
' and string concatenate a sibling atom delimitation
With Context.TopicSelection
For Each topicX In .Structure.Children
For Each atomX In topicX.Atoms
strSiblingAtoms = strSiblingAtoms & "|" & atomX.Name
ndx = ndx + 1
Next
Next
'Debug.Print "Total Atoms: " & CStr(ndx)
For Each atomX In .Atoms
' Concatenate a file stream tabulation
' of all atoms that are not in the strSiblingAtoms array
'Debug.Print InStr(1, strSiblingAtoms, atomX.Name)
If InStr(1, strSiblingAtoms, atomX.Name) = 0 Then 'residual found
ndx = ndx + 1
strResidual = strResidual & atomX.Name & vbTab & CStr(atomX.Degree) & vbCrLf
Else
ndx2 = ndx2 + 1
End If
Next
'Debug.Print ndx; ndx2
' Remove the trailing delimiter
strResidual = Left$(strResidual, Len(strResidual) - Len(vbCrLf))
End With 'Context.TopicSelection
' Write the fresh selection Members data to file as the Members of the new Topic named
' the value in 'ResidualTopicName' in a folder named by the value in 'ResidualTopicName'
With New clsFile
' Create a new Members.txt file if non-existant,
' or query the user for overwrite permission,
' else bail, no persistence -- no existence
Select Case .FileExists(Root.WhsePath & Context.TopicSelection.Path & "\" & ResidualTopicName & "\Members.txt")
Case True
If MsgBox("Overwrite the Members.txt file for Topic " & ResidualTopicName & "?", vbYesNo + vbQuestion + vbDefaultButton2, "Random distribution available") = vbYes Then
If .Save(strResidual, UseAppend:=False) Then
' Create (or err past if existing) a folder for the top node, named A1
DataExtractResidualAtoms = True
Else
RaiseEvent CommandResponse("Unable to save the residual members to: " & .Filespec)
MsgBox "Unable to save the residual members to: " & .Filespec
End If
End If
Case False
' Create the new Topic Folder
MkDir Root.WhsePath & Context.TopicSelection.Path & "\" & ResidualTopicName 'errors if exists
If Not .Save(strResidual) Then 'any sort of error will cause the next line to execute by default of resume-next
RaiseEvent CommandResponse("Unable to save the residual members to: " & .Filespec)
MsgBox "Unable to save the residual members to: " & .Filespec
Else
DataExtractResidualAtoms = True
End If
End Select
End With
RaiseEvent CommandResponse(CStr(ndx) & " residual members of topic " & Context.TopicSelection.Name & " extracted to topic " & ResidualTopicName)
Screen.MousePointer = mintMickey
Set atomX = Nothing
Set topicX = Nothing
End Function
Function ElementExists(ByRef SourceArray As Variant, ByVal Element As String) As Boolean
' Element is compared against element in the middle,
' then successive binary division of remaining middles
' on either left or right of the compare point,
' until the exact match is found, which returns true,
' or until there are no further element locations to divide, returning false
' The SourceArray is assumed to be sorted in ascending or descending rank
' The ordination of rank among the array names then become a
' self-index into the array, based on a successive binary division
' of left or right halves, pending a string comparison returning
' a three-state result, less, equal, greater.
Dim lngSmaller As Long
Dim lngMiddle As Long
Dim lngLarger As Long
Dim ndxAttempts As Integer
On Error Resume Next
lngSmaller = 0
lngLarger = UBound(SourceArray)
'Debug.Print "Total Pairs: " & UBound(SourceArray) + 1
Do While lngSmaller < lngLarger
' Place a middle ndx in the current bounded block
lngMiddle = lngSmaller + ((lngLarger - lngSmaller) / 2)
' Based on the case of StrComp,
' Move either the smaller or larger index to the middle
' Until middle locates on a match
Select Case StrComp(Element, SourceArray(lngMiddle))
Case -1 'Element < Array middle
' Adjust the block boundaries
lngLarger = lngMiddle - 1
ndxAttempts = ndxAttempts + 1
'Debug.Print ndxAttempts;
Case 0 ' a match
lngSmaller = lngLarger 'satisfies loop
ElementExists = True
Case 1 'Element > Array middle
' Adjust the block boundaries
lngSmaller = lngMiddle + 1
ndxAttempts = ndxAttempts + 1
'Debug.Print ndxAttempts;
End Select
Loop
'Debug.Print String(ndxAttempts, "-") & "*"
Trap:
End Function
Public Function DataExtractAtomsSlow() As Boolean
' Seven times slower
Dim oFile As clsFile
Dim ndx As Long
Dim lngCount As Long
Dim lngLength As Long
Dim strAtom As String
Dim strTemp As String
Const cDelimiter = vbCrLf
' Forward-reductively iterate through all delimited Pairs
' For each Atom, remove all subsequent instances of the Atom.
' The number of reduction-iterations will exactly-maybe equal the number of unique Atoms - 1.
On Error GoTo Trap
' Clear Atoms buffer and copy the Pairs to
' strTemp for reduction searches
mstrAtomsStringBuffer = ""
strTemp = mstrAtomsStringBuffer & cDelimiter ' append cDelimiter to the end of the strTemp,
' enabling pattern matching using the cDelimiter
' including the last atom in the strTemp string
' Flatten the delimiters to one
' Replace CRLF and "**" with cDelimiter
strTemp = Replace(strTemp, "**", cDelimiter)
strTemp = Replace(strTemp, vbCrLf, cDelimiter)
'Debug.Print Left$(strTemp, 120)
' Loop on shrinking length
While Len(strTemp) > 2
DoEvents 'yielding to other apps some time
' Locate first Atom
ndx = InStr(1, strTemp, cDelimiter) 'point to 1st cDelimiter
Select Case ndx
Case 0
Case Is > 0
' Concatenate the atom and delimiter onto the class field
strAtom = Left$(strTemp, ndx - 1)
mstrAtomsStringBuffer = strAtom & cDelimiter
' Remove all occurances of the Atom and trailing cDelimiter from strTemp
strTemp = Replace(strTemp, strAtom & cDelimiter, "")
End Select
lngCount = lngCount + 1
'Debug.Print lngCount
Wend
' The reduced set of Pairs is now a unique set of delimited Atoms in mstrAtomsStringBuffer.
DataExtractAtomsSlow = True
ExitPoint:
Exit Function
Trap:
'Append contextual information into existing err object Description
Err.Description = "SLIP.clsSLIP.DataExtractAtoms: " & Err.Description
Err.Raise Err.Number
Resume ExitPoint
End Function
Public Function DataImportPairs(ByVal Filespec As String) As Boolean
' Pairs.txt will always be expected in the DataPath
' Clear existing Document (object model)
' Load the Pairs into the root buffer
' Split the buffer into the PairsArray
Dim ndx As Long
Dim varX As Variant
Dim strTemp As String
On Error Resume Next
mintMickey = Screen.MousePointer
Screen.MousePointer = vbHourglass
RaiseEvent Progress("Importing pair data from " & mstrDataPath & "\Paired.txt...")
DoEvents
Filespec = mstrDataPath & "\Paired.txt"
' Pairs.txt will always be expected in the DataPath
With New clsFile
Select Case .FileExists(Filespec)
Case True
' Load the Pairs into the root buffer
With New clsFile
mstrPairsStringBuffer = modMain.TrimTrailingCharacters(.ReadAll(Filespec), vbCrLf)
End With
' Parse the PairNames into the class-level string array (module scope)
mstrPairsArray = Split(Trim(mstrPairsStringBuffer), vbCrLf, compare:=vbBinaryCompare)
Case False
MsgBox "Pairs file not found: " & Filespec & vbCrLf & vbCrLf & " Import aborted.", vbInformation
End Select
End With 'New clsFile
' Return success
DataImportPairs = True
mbooPairsImported = True
RaiseEvent CommandResponse("Pairs Imported: " & CStr(UBound(mstrPairsArray) + 1) & " from " & Filespec)
RaiseEvent Progress("")
Screen.MousePointer = mintMickey
Exit Function
Trap:
RaiseEvent CommandResponse("Failure importing pair data from " & Filespec)
End Function
Public Property Let DataIterationEnabled(ByVal Value As Boolean)
mbooIterating = Value
RaiseEvent CommandResponse("Iteration " & IIf(mbooIterating, "enabled", "disabled"))
End Property
Public Property Get DataIterationEnabled() As Boolean
DataIterationEnabled = mbooIterating
End Property
Public Function DataLoadMembers(Optional ByVal MembersFileSpec As String) As clsAtoms
Dim strSplit() As String
Dim ndx As Integer
On Error Resume Next
mintMickey = Screen.MousePointer
Screen.MousePointer = vbHourglass
With New clsFile
.Filespec = MembersFileSpec
' Deserialize and return the file contents as a clsAtoms instance
Set DataLoadMembers = Tabular.DeserializeMembers(.ReadAll) 'returns clsAtoms
End With
Screen.MousePointer = mintMickey
End Function
Public Sub DataLoadNestedTopics(ByVal Name As String, Optional ByRef oParent As clsTopic)
' Construct a Topic and for every sub-folder found, make the topic name the folder name
' Construct a subtopic by recursing this function, passing a topic reference as a parent
' with a the folder name appended to the TopicPath
' Note: this function calls itself for recursing subfolders.
Dim topicX As clsTopic 'stores reference to new Topic node instance
Dim intLevelDepth ' For each recursive entrance in this procedure, this stores the tree-depth
Dim strDir As String
Dim strTopicFolder As String
Dim strFolderItem As String
Dim strSubFolders As String 'delimited concatenation
Dim SplitSubFolders() As String 'array
Dim varX As Variant 'for-each enumerator index
On Error Resume Next
' Determine depth into tree by counting ancestors
Select Case (oParent Is Nothing) ' Boolean test
Case True ' Test reveals a root topic, the top Topic instance, not having a parent
' Reset the LevelCounts for a top node
ReDim mintLevelCount(0)
mintLevelCount(0) = 1 'the top node will always be just one
intLevelDepth = 0
' Create a top Topic class instance
' Note: the Topic instance creates all folders and files.
Set topicX = Construct.CreateTopTopic( _
Name, _
cDefPlotTopX, _
cDefPlotTopY)
Case False ' a non-root topic, having a parent
intLevelDepth = UBound(Split(oParent.Path, "\"))
ReDim Preserve mintLevelCount(intLevelDepth + 1)
' Increment a topic graph node count at this level
mintLevelCount(intLevelDepth) = mintLevelCount(intLevelDepth) + 1
' Create, set properties and set the parent of a new Topic
Set topicX = Construct.CreateTopic( _
Name:=Name, _
oParent:=oParent, _
x:=mintLevelCount(intLevelDepth) * 500, _
Y:=oParent.MetricsY + 700)
End Select
' Enumerate all folders in the topic folder, and create a child Topic
' for each folder found by recursing to this function
' with the topicX parameter as oParent
' Build a string holding the path to the topic folder
strTopicFolder = mstrDataPath & topicX.Path & "\" ' Set the path.
' Read the folder for subfolders
strFolderItem = Dir(strTopicFolder, vbDirectory) ' Retrieve the first entry.
Dim x As String
' Concatenate a tabular list of sub folders in the Topic folder, pipe delimited
Do While strFolderItem <> "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If strFolderItem <> "." And strFolderItem <> ".." Then
' Use bit-masking to test for a directory.
If (GetAttr(strTopicFolder & strFolderItem) And vbDirectory) = vbDirectory Then
' Concatenate the folder name with a pipe
strSubFolders = strSubFolders & strFolderItem & "|"
End If
End If
strFolderItem = Dir ' Get next entry.
'Debug.Print strFolderItem, strSubFolders
Loop
' Remove trailing delimiter
If Len(strSubFolders) > 0 Then
strSubFolders = Left$(strSubFolders, Len(strSubFolders) - 1)
End If
' Enumerate the tabulation of folders, and create a sub-folder for each
SplitSubFolders = Split(strSubFolders, "|")
'Debug.Print topicX.Path
For Each varX In Split(strSubFolders, "|")
' Recursion happens here
' Create a child Topic on topicX with the folder name in strFolderItem
' not working when nested...Dir statement can't terminate by ever returning null.
DataLoadNestedTopics varX, topicX
Next
End Sub
Public Sub DataRandomizeAtoms(ByRef oTopic As clsTopic, ByVal MinMax As Long)
' Random spatial assignment within a cubical volume (X,Y,Z).
Dim atomX As clsAtom
' Reset iteration count
oTopic.RadialIters = 0
For Each atomX In oTopic.Atoms
' Radial assignment
atomX.Degree = CInt(Rnd * 360) + 1
' Random spatial assignment within a cubical volume (X,Y,Z).
atomX.MetricsX = CInt(Rnd * MinMax) - MinMax / 2 + 400
atomX.MetricsY = CInt(Rnd * MinMax) - MinMax / 2 + 400
atomX.MetricsZ = CInt(Rnd * MinMax) - MinMax / 2 + 400
Next
' Save the Members tabulation to file
With New clsFile
' Convert the Atoms object to a string
' Save the tabulation of the current iterated state of members
.Save _
Buffer:=Tabular.SerializeMembers(oTopic.Atoms), _
Filespec:=mstrDataPath & oTopic.Path & "\Members.txt"
.CloseFileWrite
' Send notifacation message
RaiseEvent AtomRadialDistributionChanged(oTopic)
End With
End Sub
Public Function DataSaveMembers(ByRef oAtoms As clsAtoms) As Boolean
On Error GoTo Trap
With New clsFile
.Save DataAtomsStringBuffer, mstrDataPath & "\Members.txt"
End With
DataSaveMembers = True
Exit Function
Trap:
End Function
Public Function MetricsAtomicDistance(AtomA As clsAtom, AtomB As clsAtom) As Long
MetricsAtomicDistance = Abs(( _
(AtomB.MetricsX - AtomA.MetricsX) ^ 3 + _
(AtomB.MetricsY - AtomA.MetricsY) ^ 3 + _
(AtomB.MetricsZ - AtomA.MetricsZ) ^ 3 _
) ^ (1 / 3))
End Function
Public Function MetricsTopicDistance(Topic1 As clsTopic, Topic2 As clsTopic) As Long
MetricsTopicDistance = Abs(( _
(Topic2.MetricsX - Topic1.MetricsX) ^ 3 + _
(Topic2.MetricsY - Topic1.MetricsY) ^ 3 + _
(Topic2.MetricsZ - Topic1.MetricsZ) ^ 3 _
) ^ (1 / 3))
End Function
Public Property Get metricsLabelWidth() As Long
metricsLabelWidth = 2000
End Property
Public Property Get metricsPlotSize() As Long
metricsPlotSize = 4695
End Property
Public Property Get MetricsRadius() As Long
MetricsRadius = 1000
End Property
Public Property Get metricsTopX() As Long
metricsTopX = 500
End Property
Public Property Get metricsTopY() As Long
metricsTopY = 500
End Property
Public Property Get metricsWhiteSpace() As Long
metricsWhiteSpace = 60
End Property
Public Function TabularDeserializeMembers(ByVal Members As String) As clsAtoms
' Transform a serialized string to class instance
Dim strOuterSplit() As String 'array
Dim strInnerSplit() As String 'array
Dim strAtom As String
Dim oAtom As clsAtom
Dim oMembers As clsAtoms
Dim ndx, lastNdx As Integer
Const cOuterDelimiter = vbCrLf
On Error Resume Next
' Split the members string into an array
strOuterSplit = Split(Members, cOuterDelimiter)
' Store the index of the last array element
lastNdx = UBound(strOuterSplit)
' Instance an Atoms class, the return object
Set oMembers = New clsAtoms
' Enumerate the split array
For ndx = 0 To lastNdx
' Instance a new atom
With New clsAtom
strInnerSplit = Split(strOuterSplit(ndx), vbTab)
If UBound(strInnerSplit) = 1 Then '
.Name = strInnerSplit(0) 'left of inner delimiter
.Degree = CInt(strInnerSplit(1)) 'right of inner delimiter
' Add a new reference in the collection class of the parent object
If Len(.Name) Then
oMembers.VBACollection.Add Item:=.Self, Key:=.Name
End If
End If
End With
Next
Set TabularDeserializeMembers = oMembers
Set oMembers = Nothing
Set oAtom = Nothing
End Function
Public Function TabularMembersStringToRadialsString(ByVal Members As String) As String
' Input: Name Tab Degree CR
' Output: RadialAngle Tab Count CR
' The output contains 360 Radial counts, or sum of members per degree
Dim intDegreeCounts(360) As Integer 'ignore zero base element
Dim strOuterSplit() As String 'array
Dim intDegree As Integer
Dim ndx As Integer
Dim intLast As Integer
Const cOuterDelimiter = vbCrLf
Const cInnerDelimiter = vbTab
On Error Resume Next
' Split the members string into an array
strOuterSplit = Split(Members, cOuterDelimiter)
' Store the last array element index
intLast = UBound(strOuterSplit)
' Enumerate the split array summing counts of Members per degree
For ndx = 0 To intLast
' Get the degree by splitting the member, and accessing the 2nd element (1)
intDegree = CInt(Split(strOuterSplit(ndx), cInnerDelimiter)(1)) 'left element of split on outer split, the member degree
' Sum the count per degree
intDegreeCounts(intDegree) = intDegreeCounts(intDegree) + 1
Next
' Concatenate the output text - RadialAngle Tab Count CR
For ndx = 1 To 360
TabularMembersStringToRadialsString = TabularMembersStringToRadialsString & _
CStr(ndx) & vbTab & CStr(intDegreeCounts(ndx)) & vbCrLf
Next
End Function
Public Function TabularSerializeMembers(ByRef Atoms As clsAtoms) As String
Dim atomX As clsAtom
Dim ndx As Integer
On Error Resume Next
' Concatenate Members as - Name Tab Degree CR
For Each atomX In Atoms
TabularSerializeMembers = TabularSerializeMembers & atomX.Name & vbTab & CStr(atomX.Degree) & vbCrLf
Next
End Function
Public Function TabularSerializeRadials(ByRef Atoms As clsAtoms) As String
Dim atomX As clsAtom
Dim intDegreeCounts(360) As Integer 'ignore zero base element
Dim ndx As Integer
On Error Resume Next
' Sum count of Atoms per degree
For Each atomX In Atoms
intDegreeCounts(atomX.Degree) = intDegreeCounts(atomX.Degree) + 1
Next
' Concatenate Degree Tab Count CR
For ndx = 1 To 360
TabularSerializeRadials = _
TabularSerializeRadials & CStr(ndx) & vbTab & CStr(intDegreeCounts(ndx)) & vbCrLf
Next
End Function
Public Property Get DataPath() As String
If Len(DataPath) Then mstrDataPath = DataPath Else DataPath = cDefDataPath
End Property
Public Property Let DataPath(ByVal Value As String)
mstrDataPath = Value
End Property
Public Property Get EventBrowserExecName() As String
EventBrowserExecName = mstrEventBrowserExecName
End Property
Public Property Let EventBrowserExecName(ByVal Value As String)
mstrEventBrowserExecName = Value
End Property
Public Property Get TopicSelection() As clsTopic
On Error Resume Next
Set TopicSelection = moTopicSelection
End Property
Public Property Set TopicSelection(ByVal ref As clsTopic)
On Error Resume Next
Set moTopicSelection = ref
End Property
Public Property Get TopicCount() As Long
TopicCount = mcolTopicTree.Count
End Property