Как создать m-перестановок из n без повторений на VBScipt, используя алгоритм Джонсона-Троттера


При создании m-перестановок из n использовался алгоритм Джонсона-Троттера.

Источником n чисел является xml файл (NumberSetting.xml).
Число m, наименование файла-источника, наименование выходного файла, наименование элементов в xml файлах определяется в коде как константы.
Предварительно вывод результата происходит в csv файл, далее, используя csv файл, формируется выходной xml.


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

Использовалось: The Johnson-Trotter algorithm in VB6 (Lotto Algorithms - Permutations, Combinations).

  • ru/m_permutations_of_n_using_johnson_trotter_algorithm_on_vbscript.txt
  • Последние изменения: 2018/06/27 22:09
  • — 2SRTVF