How to create m-permutations of n as sequences without repetition on VBScript, using the Johnson-Trotter algorithm


The Johnson–Trotter algorithm was used to create m-permutations of n.

The source of n numbers is the XML file (NumberSetting.xml).
The number m, the name of the source file, the name of the output file, the names of the elements in the XML files are defined in the code as constants.
The result is pre-output in a CSV file, then the output XML is generated.

NumberSetting.xml
<?xml version="1.0" encoding="UTF-8"?>
 
<Numbers>
    <number>01</number>
    <number>02</number>
    <number>03</number>
    <number>04</number>
    <number>05</number>
    <number>06</number>
    <number>07</number>
    <number>08</number>
    <number>09</number>
    <number>10</number>
    <number>11</number>
    <number>12</number>
    <number>13</number>
    <number>14</number>
    <number>15</number>
    <number>16</number>
    <number>17</number>
    <number>18</number>
    <number>19</number>
    <number>20</number>
</Numbers>
NumbersCombination.vbs
Option Explicit
 
' -----------------------------------------------------------
' m-permutations of n
' -----------------------------------------------------------
Const m = 3
Dim n           ' items count config file
'
' Version of the script
Const version = "2017.07.23 18-00 UTC"
 
' -----------------------------------------------------------
' CONFIG
' -----------------------------------------------------------
Const CONFIG_FILENAME = "NumberSetting.xml"
Const CONFIG_XML_ROOT = "Numbers"
Const CONFIG_XML_ELEMENT = "number"
' -----------------------------------------------------------
' RESULT GENERAL
' -----------------------------------------------------------
Const RESULT_FILENAME = "NumberOutput.xml"
Const RESULT_XML_ROOT = "NumbersOutput"
Const RESULT_XML_ELEMENT = "number"
' -----------------------------------------------------------
' TEMP FILE
' -----------------------------------------------------------
Const FILE_CSV = "data.csv"
' -----------------------------------------------------------
Dim PathThisScript, csv_file_name
Dim fso, objCsvFile
 
 
Dim objXMLDocConfig, RootConfig
Dim xmlDoc, objRoot
Dim ConfigFile, ResultFile
Dim arrConfig_Number(), a()
Dim i, ElemConfig, objIntro, sLine
 
Dim ExistsObject
 
Set fso = CreateObject("Scripting.FileSystemObject")
PathThisScript = fso.GetParentFolderName(fso.GetFile(Wscript.ScriptFullName))
PathThisScript = PathThisScript & "\"
 
' ===================================
' file name is the FULL NAME
ConfigFile = PathThisScript & CONFIG_FILENAME
ResultFile = PathThisScript & RESULT_FILENAME
' ===================================
' temp file CSV
csv_file_name = PathThisScript & "\" & FILE_CSV
' ===================================
 
If fso.FileExists(ConfigFile) Then
    '
    ' Get congig data
    Set objXMLDocConfig = CreateObject("Microsoft.XMLDOM")
    objXMLDocConfig.async = False
    objXMLDocConfig.Load (ConfigFile)
    ' get config date, set primary node xml file
    Set RootConfig = objXMLDocConfig.DocumentElement
    If RootConfig.nodeName = CONFIG_XML_ROOT Then
 
        ' ---------------------------------
        ' [NUMBER] for each element in the configuration file are added to the elements in an array
        n = 0
        For Each ElemConfig In RootConfig.ChildNodes
            If ElemConfig.BaseName = CONFIG_XML_ELEMENT Then
                 n = n + 1
                 ' get date from the element xml file
                 ReDim Preserve arrConfig_Number(n)
                 arrConfig_Number(n) = ElemConfig.Text
            End If
        Next
        If n >= m Then
            CreateCsvFile arrConfig_Number, n, m
            MsgBoxUser "Temporary csv file created"
            ' ---------------------------------
            ' [CREATE RESULT FILE]
            Set xmlDoc = CreateObject("Microsoft.XMLDOM")
            xmlDoc.async = False
            ' create element [ROOT]
            Set objRoot = xmlDoc.createElement(RESULT_XML_ROOT)
            xmlDoc.appendChild objRoot
 
            ' ForReading = 1 : Open a file for reading only. You can't write to this file.
            Set objCsvFile = fso.OpenTextFile(csv_file_name, 1)
            Do Until objCsvFile.AtEndOfStream
                sLine = objCsvFile.ReadLine
                If Not Len(Trim(sLine)) = 0 Then
                    InsertItems xmlDoc, objRoot, sLine
                End If
            Loop
            objCsvFile.Close
            fso.DeleteFile csv_file_name, True
 
            Set objIntro = xmlDoc.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8' standalone='yes'")
            xmlDoc.InsertBefore objIntro, xmlDoc.ChildNodes(0)
            xmlDoc.Save ResultFile
            MsgBoxUser "Finish"
        Else
            MsgBoxUser "m (=" & m & ") > numbers count (=" & n & ")"
        End If
    Else
        MsgBoxUser "Invalid configuration file. Node " & CONFIG_XML_ROOT & " not found"
    End If
Else
    MsgBoxUser "Configuration file '" & ConfigFile & "' doesn't exist"
End If
 
Sub InsertItems(xmlDoc, objRoot, ElementText)
 
    Dim objItem
 
    Set objItem = xmlDoc.createElement(RESULT_XML_ELEMENT)
    objRoot.appendChild objItem
    objItem.Text = ElementText
 
End Sub
 
Sub MsgBoxUser(m)
 
    wscript.echo m
End Sub
 
 
' m-permutations of n
'
Sub CreateCsvFile(aInData, n, m)
 
    Dim objFile, lineCheck
    Dim a(), i, j, p, JT()
    Dim mFactorial
 
   ' Factorial
    mFactorial = Factorial(m)
 
    ' TEST n,m. If not correct to do EXIT
    If n < m Or m < 1 Then Exit Sub
    ' set variable p
    If m = n Then p = 1 Else p = m
 
    ReDim a(m)
 
    ' --------------------
    ' To create the array used "Johnson-Trotter"
    ' --------------------
    ReDim JT(mFactorial, m)
    '  execute "Johnson-Trotter"
    GenPermutations m, JT
 
    ' init the array
    For i = 1 To m: a(i) = i: Next
 
    Set objFile = fso.CreateTextFile(csv_file_name, True)
    Do
        For i = 1 To mFactorial
            lineCheck = aInData(a(JT(i, 1))): For j = 2 To m Step 1: lineCheck = lineCheck & "," & aInData(a(JT(i, j))): Next
            objFile.WriteLine lineCheck
        Next
        If a(m) = n Then p = p - 1 Else p = m
        If p Then
            For i = m To p Step -1
                a(i) = a(p) + i - p + 1
            Next
        End If
    Loop While p
    objFile.Close
 
End Sub
 
Function Factorial(m)
 
    Dim i
    Factorial = 1: For i = 1 To m: Factorial = Factorial * i: Next
 
End Function
 
Sub GenPermutations(n, JT)
   '
   ' "Johnson-Trotter" VB6 implementation by MathImagics (Dec 2004)
   '   Each permutation is obtained from the previous by
   '   swapping just ONE pair of adjacent items.
   '
   Dim Item()   ' items to permute
   Dim Link()   ' 0 = link left, 1 = right
   Dim k, kSpot  ' largest mobile K and its position
   Dim p, pSpot  ' iterator value P, its position
   Dim mobile         ' "mobility" test flag
   Dim kLink
   Dim NumberOfLines
   Dim i
   '
   ' 0. Setup initial state
   '
   ReDim Item(n)
   ReDim Link(n)
   For i = 1 To n: Item(i) = i: Next
 
   Do
      ' 1. to result array
      '
      NumberOfLines = NumberOfLines + 1
      For i = 1 To n: JT(NumberOfLines, i) = Item(i): Next
 
      ' 2. select "mobile" position with highest value
      '
      k = 0
      pSpot = 0
 
      Do While pSpot < n
         pSpot = pSpot + 1
         p = Item(pSpot)
 
         mobile = False
 
         If Link(pSpot) = 0 Then
            If pSpot > 1 Then
               If Item(pSpot - 1) < p Then mobile = True
               End If
         ElseIf pSpot < n Then
            If Item(pSpot + 1) < p Then mobile = True
            End If
 
         If mobile Then
            If p > k Then
               k = p
               kSpot = pSpot
               If k = n Then Exit Do ' look no further
               End If
            End If
         Loop
 
       If k = 0 Then Exit Do  ' all done!
 
       '
       ' 3.  Swap item kSpot with "neighbour"
       '
       kLink = Link(kSpot)
       If kLink Then
          Item(kSpot) = Item(kSpot + 1): Link(kSpot) = Link(kSpot + 1)
          Item(kSpot + 1) = k:           Link(kSpot + 1) = 1
       Else
          Item(kSpot) = Item(kSpot - 1): Link(kSpot) = Link(kSpot - 1)
          Item(kSpot - 1) = k:           Link(kSpot - 1) = 0
          End If
       '
       ' 4. Toggle Links for any items > K
       '
       For pSpot = 1 To n
          If Item(pSpot) > k Then Link(pSpot) = 1 - Link(pSpot)
       Next
    Loop
End Sub

Used: The Johnson-Trotter algorithm in VB6 (Lotto Algorithms - Permutations, Combinations).

  • en/m_permutations_of_n_using_johnson_trotter_algorithm_on_vbscript.txt
  • Last modified: 2018/06/27 22:23
  • by 2SRTVF