' in clsPermutation
Public Transpositions As Collection
Sub ActOn(ByRef anArray As Variant)
Dim i As Long
For i = 2 To Transpositions.Count
Transpositions(i).ActOn anArray
Next i
End Sub
Function ActingOn(ByVal anArray As Variant)
Dim Result As Variant
Result = anArray
Me.ActOn Result
ActingOn = Result
End Function
Function AndThen(aPerm As clsPermuation) As clsPermuation
Dim Size As Long
Dim arrNull As Variant, arrResult As Variant
Dim Result As clsPermuation
Size = WorksheetFunction.Max(aPerm.Level, Me.Transpositions(Me.Transpositions.Count).High)
arrNull = OneTo(Size)
arrResult = Me.ActingOn(arrNull)
aPerm.ActOn arrResult
Set Result = New clsPermuation
Result.GetFromArray arrResult, arrNull
Set AndThen = Result
Set Result = Nothing
End Function
Function AndThenOther(aPerm As clsPermuation) As clsPermuation
Dim Result As clsPermuation
Dim xTrans As clsTransposition
Dim arrTrans() As clsTransposition
Dim upTrans As clsTransposition, downTrans As clsTransposition
Dim i As Long, tPointer As Long, tLookAt As Long, j As Long
ReDim arrTrans(1 To Me.Transpositions.Count + aPerm.Transpositions.Count)
For i = 1 To Me.Transpositions.Count
Set xTrans = New clsTransposition
tPointer = tPointer + 1
Set arrTrans(tPointer) = xTrans.SetValue(Me.Transpositions(i).Low, Me.Transpositions(i).High)
Next i
For i = 2 To aPerm.Transpositions.Count
Set xTrans = New clsTransposition
Set xTrans = New clsTransposition
tPointer = tPointer + 1
Set arrTrans(tPointer) = xTrans.SetValue(aPerm.Transpositions(i).Low, aPerm.Transpositions(i).High)
' shift trans to positions
tLookAt = tPointer
Do
Set upTrans = arrTrans(tLookAt)
Set downTrans = arrTrans(tLookAt - 1)
If upTrans.High > downTrans.High Then
Exit Do
End If
If upTrans.High <> downTrans.High And upTrans.High <> downTrans.Low _
And upTrans.Low <> downTrans.High And upTrans.Low <> downTrans.Low Then
Set xTrans = arrTrans(tLookAt)
Set arrTrans(tLookAt) = arrTrans(tLookAt - 1)
Set arrTrans(tLookAt - 1) = xTrans
tLookAt = tLookAt - 1
ElseIf upTrans.High = downTrans.High Then
If upTrans.Low = downTrans.Low Then
For j = tLookAt + 1 To tPointer
Set arrTrans(i - 2) = arrTrans(i)
Next j
tPointer = tPointer - 2
Exit Do
Else
j = downTrans.Low
downTrans.SetValue downTrans.Low, upTrans.Low
upTrans.SetValue upTrans.High, j
Set arrTrans(tLookAt) = upTrans
Set arrTrans(tLookAt - 1) = downTrans
tLookAt = tLookAt - 1
End If
Else
'downtrans.high>uptrans.high
If upTrans.High = downTrans.Low Then
ElseIf upTrans.Low = downTrans.Low Then
End If
End If
Loop While tLookAt > 1
Next i
Set Result = New clsPermuation
For i = 2 To tPointer
If Not (arrTrans(i) Is Nothing) Then
Result.Transpositions.Add Item:=arrTrans(i)
End If
Next i
Set AndThenOther = Result
Set Result = Nothing
Set xTrans = Nothing
End Function
Property Get Display(Optional WithNull) As String
Dim i As Long
For i = 1 To Transpositions.Count
Display = Display & Transpositions(i).Display
Next i
End Property
Sub GetFromArray(ByRef PermutedArray As Variant, Optional Alphabet As Variant)
Dim i As Long, j As Long, temp As Variant
Dim Size As Long
Dim xTrans As clsTransposition
Dim pPermutedArray As Variant, pAlphabet As Variant
Size = UBound(PermutedArray) - LBound(PermutedArray) + 1
If LBound(PermutedArray) = 1 Then
pPermutedArray = PermutedArray
Else
ReDim pPermutedArray(1 To Size)
j = UBound(PermutedArray) - UBound(pPermutedArray)
For i = 1 To Size
pPermutedArray(i) = PermutedArray(i + j)
Next i
End If
If IsMissing(Alphabet) Then
pAlphabet = OneTo(Size)
ElseIf LBound(PermutedArray) = 1 Then
pAlphabet = Alphabet
Else
ReDim pAlphabet(1 To Size)
For i = 1 To Size
pAlphabet(i) = Alphabet(i + j)
Next i
End If
For i = Size To 2 Step -1
If pPermutedArray(i) <> pAlphabet(i) Then
For j = 1 To i - 1
If pPermutedArray(j) = pAlphabet(i) Then
Exit For
End If
Next j
Set xTrans = New clsTransposition
Transpositions.Add Item:=xTrans.SetValue(i, j), after:=1
temp = pPermutedArray(i)
pPermutedArray(i) = PermutedArray(j)
pPermutedArray(j) = temp
End If
Next i
Set xTrans = Nothing
End Sub
Function Inverse() As clsPermuation
Dim Result As clsPermuation
Dim arrNull As Variant, arrPermuted As Variant
arrNull = OneTo(Me.Level)
arrPermuted = Me.ActingOn(arrNull)
Set Result = New clsPermuation
Result.GetFromArray arrNull, arrPermuted
Set Inverse = Result
Set Result = Nothing
End Function
Property Get Level() As Long
With Transpositions
Level = .Item(.Count).High
End With
End Property
Public Function NextPermutation() As clsPermuation
Dim Result As clsPermuation
Dim xTrans As clsTransposition
Dim i As Long
Set xTrans = New clsTransposition
If Transpositions.Count = 1 Then
Set Result = New clsPermuation
Result.Transpositions.Add xTrans.SetValue(1, 2)
Else
Set Result = TruncatedPerm.NextPermutation
With Me.Transpositions(Me.Transpositions.Count)
If Result.Level < Me.Level Then
Result.Transpositions.Add Item:=xTrans.SetValue(.Low, .High)
Else
If .High = .Low + 1 Then
Set Result = New clsPermuation
Result.Transpositions.Add Item:=xTrans.SetValue(1, .High + 1)
Else
Set Result = New clsPermuation
Result.Transpositions.Add Item:=xTrans.SetValue(.Low + 1, .High)
End If
End If
End With
End If
Set NextPermutation = Result
Set Result = Nothing
Set xTrans = Nothing
End Function
Function PreviousPerm() As clsPermuation
Dim Result As clsPermuation
Dim lastTrans As clsTransposition
Dim xTrans As clsTransposition
Dim i As Long
Set lastTrans = Me.Transpositions(Me.Transpositions.Count)
If Me.Transpositions.Count = 1 Then
Rem error,return null
Set Result = New clsPermuation
ElseIf Me.Transpositions.Count = 2 Then
Rem create zoop down
Set Result = New clsPermuation
For i = 2 To Me.Level - 1
Set xTrans = New clsTransposition
Result.Transpositions.Add Item:=xTrans.SetValue(i - 1, i)
Next i
With lastTrans
If 1 < .Low Then
Set xTrans = New clsTransposition
Result.Transpositions.Add Item:=xTrans.SetValue(.Low - 1, .High)
End If
End With
Else
Rem truncatedPerm lastTrans
Set Result = TruncatedPerm.PreviousPerm
Set xTrans = New clsTransposition
Result.Transpositions.Add Item:=xTrans.SetValue(lastTrans.Low, lastTrans.High)
End If
Set PreviousPerm = Result
Set Result = Nothing
Set lastTrans = Nothing
Set xTrans = Nothing
End Function
Sub SetToTranspositions(inLow As Long, inHigh As Long)
Dim xTrans As clsTransposition
Set Transpositions = Nothing
Set Transpositions = New Collection
Set xTrans = New clsTransposition
Transpositions.Add Item:=xTrans
Set xTrans = New clsTransposition
Transpositions.Add Item:=xTrans.SetValue(inLow, inHigh)
Set xTrans = Nothing
End Sub
Property Get strOrder(Optional ByVal ShowSize As Long, Optional Delimiter As String = " ") As String
Dim arrNull As Variant
Dim i As Long
ShowSize = WorksheetFunction.Max(Me.Level, ShowSize)
ReDim arrNull(0 To ShowSize - 1)
For i = 0 To UBound(arrNull): arrNull(i) = (i + 1): Next i
Me.ActOn arrNull
strOrder = Join(arrNull, Delimiter)
End Property
Private Function TruncatedPerm() As clsPermuation
Dim Result As New clsPermuation
Dim xTrans As clsTransposition
Dim i As Long
For i = 2 To Me.Transpositions.Count - 1
Set xTrans = New clsTransposition
With Me.Transpositions(i)
Result.Transpositions.Add Item:=xTrans.SetValue(.Low, .High)
End With
Next i
Set TruncatedPerm = Result
Set Result = Nothing
Set xTrans = Nothing
End Function
Private Sub Class_Initialize()
Dim xTrans As clsTransposition
Set Transpositions = New Collection
Set xTrans = New clsTransposition
Transpositions.Add Item:=xTrans
Set xTrans = Nothing
End Sub