摘要：用Basic语言在VS平台的控制台模式下编写一个程序，用来表述三种限制条件下的排列问题。
用Basic语言在VS平台的控制台模式下编写一个程序，用来表述三种限制条件下的排列问题。
这个程序可用于学生的各种排队、座位分配问题。可以用各种团队的分组、编排等问题。数学吗，最抽象。可用于……太多的实际问题描述。其实很早以前在中学数学里就讲了排列组合问题。可见其应用的重要性与普遍意义。后来归为离散数学结构知识体系。
Imports System
Imports System.Collections.Generic
Module Program
Sub Main(args As String)
Console.WriteLine("Hello World!")
Console.WriteLine("排列生成器（支持多种限制条件）")
Console.WriteLine("=".PadRight(40, "="))
Dim elements = GetElements
Console.WriteLine
Dim useFixed = GetYesNo("需要固定特定位置的元素吗？(Y/N)")
Dim useForbidden = GetYesNo("需要设置不能相邻的元素对吗？(Y/N)")
Console.WriteLine
Dim fixedPositions As New Dictionary(Of Integer, Integer)
If useFixed Then
fixedPositions = GetFixedPositions(elements)
Console.WriteLine
End If
Dim forbiddenPairs As New List(Of (Integer, Integer))
If useForbidden Then
forbiddenPairs = GetForbiddenPairs(elements)
Console.WriteLine
End If
Dim allPermutations = GeneratePermutations(elements)
Dim validPermutations = FilterPermutations(allPermutations, fixedPositions, forbiddenPairs)
Console.WriteLine(vbCrLf & "符合条件的排列：")
Console.WriteLine($"总数量：{validPermutations.Count}")
For Each perm In validPermutations
Console.WriteLine(String.Join(" ", perm))
Next
Console.ReadLine
End Sub
Function GetElements As Integer
Console.WriteLine("请输入要排列的元素（用空格分隔，例：1 2 3 4）:")
Dim input = Console.ReadLine
Return input.Split({" "c}, StringSplitOptions.RemoveEmptyEntries) _
.Select(Function(x) Integer.Parse(x)) _
.ToArray
End Function
Function GetYesNo(prompt As String) As Boolean
Console.Write(prompt & " ")
Return Console.ReadLine.Trim.ToUpper = "Y"
End Function
Function GetFixedPositions(elements As Integer) As Dictionary(Of Integer, Integer)
Dim positions As New Dictionary(Of Integer, Integer)
Console.WriteLine("请输入固定位置参数（格式：位置=值，每行一个，空行结束）")
Console.WriteLine($"有效位置：0-{elements.Length - 1}，可用值：{String.Join(",", elements)}")
While True
Console.Write("> ")
Dim input = Console.ReadLine.Trim
If String.IsNullOrEmpty(input) Then Exit While
Try
Dim parts = input.Split("="c)
Dim pos = Integer.Parse(parts(0))
Dim value = Integer.Parse(parts(1))
If pos = elements.Length Then
Console.WriteLine($"错误：位置必须在0-{elements.Length - 1}之间")
ElseIf Not elements.Contains(value) Then
Console.WriteLine($"错误：值{value}不在元素集合中")
Else
positions(pos) = value
End If
Catch
Console.WriteLine("格式错误，请使用 位置=值 的格式（例：1=3）")
End Try
End While
Return positions
End Function
Function GetForbiddenPairs(elements As Integer) As List(Of (Integer, Integer))
Dim pairs As New List(Of (Integer, Integer))
Console.WriteLine("请输入禁止相邻的元素对（用空格分隔，每行一对，空行结束）")
Console.WriteLine($"可用元素：{String.Join(",", elements)}")
While True
Console.Write("> ")
Dim parts = input.Split({" "c}, StringSplitOptions.RemoveEmptyEntries)
If parts.Length 2 Then
Console.WriteLine("需要输入两个元素")
Continue While
End If
Try
Dim a = Integer.Parse(parts(0))
Dim b = Integer.Parse(parts(1))
If Not elements.Contains(a) Or Not elements.Contains(b) Then
Console.WriteLine("包含无效元素")
Else
pairs.Add((a, b))
End If
Catch
Console.WriteLine("请输入有效的整数")
End Try
End While
Return pairs
End Function
Function GeneratePermutations(elements As IEnumerable(Of Integer)) As List(Of Integer)
Dim result As New List(Of Integer)
Permute(elements.ToList, 0, elements.Count - 1, result)
Return result
End Function
Sub Permute(elements As List(Of Integer), start As Integer, [end] As Integer, result As List(Of Integer))
If start = [end] Then
result.Add(elements.ToArray)
Else
For i As Integer = start To [end]
Swap(elements, start, i)
Permute(elements, start + 1, [end], result)
Next
End If
End Sub
Sub Swap(elements As List(Of Integer), i As Integer, j As Integer)
Dim temp = elements(i)
elements(i) = elements(j)
elements(j) = temp
End Sub
Function FilterPermutations(allPermutations As List(Of Integer),
fixedPositions As Dictionary(Of Integer, Integer),
forbiddenPairs As List(Of (Integer, Integer))) As List(Of Integer)
Return allPermutations _
.Where(Function(p) CheckFixedPositions(p, fixedPositions)) _
.Where(Function(p) CheckForbiddenPairs(p, forbiddenPairs)) _
.ToList
End Function
Function CheckFixedPositions(perm As Integer, fixedPositions As Dictionary(Of Integer, Integer)) As Boolean
For Each kvp In fixedPositions
If perm(kvp.Key) kvp.Value Then Return False
Next
Return True
End Function
Function CheckForbiddenPairs(perm As Integer, forbiddenPairs As List(Of (Integer, Integer))) As Boolean
For i As Integer = 0 To perm.Length - 2
For Each pair In forbiddenPairs
If (perm(i) = pair.Item1 AndAlso perm(i + 1) = pair.Item2) OrElse
(perm(i) = pair.Item2 AndAlso perm(i + 1) = pair.Item1) Then
Return False
End If
Next
Next
Return True
End Function
End Module
来源：顺子说