如何在给定元素数的基础上建立随机铁路？

Question

我有许多乐高铁路元素-曲线轨道(图像)，直轨(图像)，点集(图像)和交叉元素(桥)。

我想编写一个程序，它将根据可用元素的数量(可能，最大使用的元素数)生成一条随机的铁路。但我以前从来没有做过这样的工作。铁路生成的算法应该是什么样的？一开始该怎么做？

Answer 1

几年前，我与乐高铁路公司实施了一项类似的任务。

首先，产生一条随机铁路意味着你需要/需要找到有效的铁路。以及找到有效的铁路(其中“有效”指闭环，没有铁路区段重叠等)。需要一个搜索算法；在这种情况下，遍历搜索树的回溯算法可以实现这一点。

• 开始情况:正如前面提到的，算法应该从二维平面上的某个位置开始，并有一个定义的方向(角度)，开始时要有0个元素。
• 回溯算法的一个进步：.包括添加一个铁路元素(例如，一个用作左曲线元素的曲线轨道元素)；当添加一个新元素时，您必须更新您的轨道的头部所在位置以及磁头现在要向哪个方向前进；您必须检查新元素是否与已经存在的轨道重叠。
• 解决方案:基于这个几何位置，您需要检查您的铁路是否完成(意思是:您的轨道的头部连接到您的轨道的起点平稳)。
• 修剪:您必须实现一些启发式，以减少数十亿的可能轨道，例如:不要继续，如果剩余的部分将不足以回到起点的(a)缺失的距离和(b)角度的差异。

[2]补充评论：

• 从结果(一个可能的轨道列表)可以跳过所有的“同构”，例如，12x右曲线的轨道(=一个完美圆)与包含12x左曲线的解基本相同。
• 需要一些三角函数(例如，检查我是否到达了起点)；为了做到这一点没有任何浮点不精确(并加快执行)，可以将(三角学)问题转化为只使用整数系数的方法。

顺便说一句。这个项目找到了我永远不会想到的解决方案.

更新30.10.2022:如所需，这是用VBA编写(如前所述)的代码。

'---------------------------------------------------------------------------------------------------------------
'
' Lego Eisenbahn - Finding all possible closed railway tracks given a number of Lego railway elements
'
' Notes:
' - Written in VBA (Visual Basic for Applications); I used to run it as a macro in an Excel file, but should not
'   be a big problem to port it to other environments.
' - Output will be printed into the first excel worksheet (plus some debug messages into a VBA window)
' - Original version was in German; I changed comments into English but did not change German-like variable names
' - Author: Michael T., 2011-2022
'
' About the algorithm:
' - Input: number of railway elements to be used: variable name 'maxtiefe', see below.
' - Currently it supports:
'    - straight elements (in output shown as "-")
'    - left curve elements ("L")
'    - right curce elements ("R")
' - Output: a list of possible solutions (i. e. list of closed railway tracks)
' - Possible extensions:
'    ° other railway elements (like crossings). Can be done in principle but requires some brain work...
'    ° port to another language in order to increase processing speed: currently you have to be patient if you
'      wanna use more than 22 elements...
'    ° of course, more algorithmic optimization (adding more/better heuristics) is possible.
'
'---------------------------------------------------------------------------------------------------------------

Option Explicit ' each variable needs to be declared

'------- Definitions ---------------------

Type kopf_type
  ' The position of the head of the railway
  mx As Integer    ' For more efficient calculation, the x and y positions are decomposed as follows:
  nx As Integer    '     x = mx * squareroot(3)/4 + nx * 1/4
  my As Integer    '     y = my * squareroot(3)/4 + ny * 1/4
  ny As Integer
  
  ' The direction of the head of the railway
  alpha As Integer ' the direction in degrees (0, 30, ..., 330)
  m As Integer     ' for more efficient calculation, the coefficients m, n, p, q are derived from alpha
  n As Integer     ' and will be used for further calculations. The coefficients fulfil the following equations:
  p As Integer     '     cos(alpha) = m * squareroot(3)/2 + n * 1/2
  q As Integer     '     sin(alpha) = p * squareroot(3)/2 + q * 1/2.
End Type

Const sqrt3 As Double = 3 ^ (1 / 2)
Const mm As Double = sqrt3 / 4
Const nn As Double = 1 / 4
Const h2 As Double = 2 - sqrt3 ' Length of a curved element, (german: Sehne, engl.: chord), squared
Const eps As Double = 0.001 ' The tolerance (because of calculation inaccuracy) which I still concede with the heuristics
Const max_num_solutions As Long = 1000000 ' max. number of solutions

'------- Global declarations --------------------

Dim Loesung(1 To max_num_solutions) As String ' the solutions found by the search algorithm will be stored here
Dim istisomorphievon(1 To max_num_solutions) As Long ' needed for finding isormorphies

Dim anzpruefungen As Long
Dim anzloesungen As Long
Dim anzloesungenohneisomorphie As Long

Dim maxtiefe As Integer
 
Sub eisenbahn()
  ' Main procedure

  Dim done As Boolean
  Dim notfound As Boolean
  Dim tStart As Single, tEnde As Single, tGesamtdauer As Single
  Dim k0 As kopf_type
  Dim i As Long, j As Long, k As Long
  Dim ws As Worksheet
  Dim outputzeile As Integer
  
  Set ws = Worksheets(1)
  ws.Columns("A:Z").Value = ""
  outputzeile = 1
  
  Debug.Print
  Debug.Print "--------------------- Eisenbahn -------------------------------------------------------"

  ' Initialization: Position x=y=0, Direction 0 degrees
  k0.mx = 0
  k0.nx = 0
  k0.my = 0
  k0.ny = 0
  k0.alpha = 0
  Call adjust_mnpq(k0)
  
  ' 1) Find solutions by recursive descend / backtracking
  maxtiefe = 19
  anzpruefungen = 0
  anzloesungen = 0
  done = False
  notfound = False
  tStart = Timer
  Call try(k0, 0, "")
  
  Debug.Print "tiefe="; maxtiefe; "done="; done; " notfound="; notfound; " anzpruefungen="; anzpruefungen; " anzloesungen="; anzloesungen
  
  ' 2) Eliminate isomorphies from the result set
  ' 2a) initialize
  For i = 1 To anzloesungen
    istisomorphievon(i) = -1
  Next i
  
  ' 2b) eliminate
  For i = 1 To anzloesungen
    If istisomorphievon(i) = -1 Then
      ' i denotes in fact an equivalence class
      For j = i + 1 To anzloesungen
        If istisomorphievon(j) = -1 Then
          If istIsomorph(Loesung(i), Loesung(j)) Then
            ' j is an isomorphy of i: mark it and do not use j further
            istisomorphievon(j) = i
          End If
        End If
      Next j
    End If
  Next i
  
  ' 2c) Count num of equivalence classes
  anzloesungenohneisomorphie = 0
  For i = 1 To anzloesungen
    If istisomorphievon(i) = -1 Then
      anzloesungenohneisomorphie = anzloesungenohneisomorphie + 1
    End If
  Next i
  
  ' 2d) print out results
  Debug.Print "Anz. Lsg ohne Isomorphie: "; anzloesungenohneisomorphie
  ws.Cells(outputzeile, 1) = "Nr."
  ws.Cells(outputzeile, 2) = "Solution"
  ws.Cells(outputzeile, 3) = "#L"
  ws.Cells(outputzeile, 4) = "#R"
  ws.Cells(outputzeile, 5) = "#-"
  outputzeile = outputzeile + 1
  k = 1
  For i = 1 To anzloesungen
    If istisomorphievon(i) = -1 Then
      ' Count number of L, R, and -
      Dim le As Integer, nL As Integer, nR As Integer
      le = Len(Loesung(i))
      nL = 0
      nR = 0
      For j = 1 To Len(Loesung(i))
        If Mid(Loesung(i), j, 1) = "L" Then
          nL = nL + 1
        ElseIf Mid(Loesung(i), j, 1) = "R" Then
          nR = nR + 1
        End If
      Next j
      ws.Cells(outputzeile, 1) = k
      ws.Cells(outputzeile, 2) = Loesung(i)
      ws.Cells(outputzeile, 3) = nL
      ws.Cells(outputzeile, 4) = nR
      ws.Cells(outputzeile, 5) = le - (nL + nR)
      k = k + 1
      outputzeile = outputzeile + 1
    End If
  Next i

  tEnde = Timer
  tGesamtdauer = tEnde - tStart    ' Duration in seconds
  Debug.Print "dauer/s="; tGesamtdauer

ende:
Debug.Print "^^^^^^^^^^^^^^^^ END ^^^^^^^^^^^^^^^^^^^^"
End Sub

Sub try(k As kopf_type, tiefe As Integer, weg As String)
  ' Find solutions by recursive descend
  ' k - the current head of the railway, containing position and direction
  ' tiefe (depth) - the current search depth i. e. the current number of elements I have used
  ' weg (track) - the string of elements (L/R/-) currently used
  
  Dim kk As kopf_type
  
  ' check whether we have reached the target
  If tiefe = maxtiefe Then
    anzpruefungen = anzpruefungen + 1
    If k.mx = 0 Then
      If k.nx = 0 Then
        If k.my = 0 Then
          If k.ny = 0 Then
            If k.alpha = 0 Then
              ' we have found a solution
              If anzloesungen = max_num_solutions Then
                ' solution table full
                Debug.Print "Warning: Cannot save new solution since solution table is full."
                GoTo try_ende
              End If
              ' save solution
              anzloesungen = anzloesungen + 1
              Loesung(anzloesungen) = weg
            End If
          End If
        End If
      End If
    End If
    
  Else
    ' maximum depth not yet reached: Search further
      
    ' Heuristics A: Check whether we can reach the target (from a distance point of view) at all with the remaining elements we have
    ' Calculate squared distance to the target (which is (0, 0))
    Dim dist2 As Double, r2 As Double
    dist2 = (k.mx * mm + k.nx * nn) ^ 2 + (k.my * mm + k.ny * nn) ^ 2
    ' Calculate squared remaining distance we could reach with our elements (note that the max. distance can be reached with curved rails)
    r2 = h2 * ((maxtiefe - tiefe) ^ 2)
    If dist2 > r2 + eps Then
      ' Target not reachable anymore: go back
      GoTo try_ende
    End If
    
    ' Heuristics B: Check whether the angle difference to the target can be compensated/reached at all
    If k.alpha = 0 Then
      ' No angle difference to compensate: try further
      GoTo try_weiter
    End If
    Dim beta As Integer ' the angle difference still to be compensated
    Dim ausgleichbarewinkeldifferenz As Integer ' the maximum angle difference we still can compensate
    ausgleichbarewinkeldifferenz = (maxtiefe - tiefe) * 30 ' 30 degrees per remaining element
    If k.alpha <= 180 Then
      beta = k.alpha
    Else ' alpha >180
      beta = 360 - k.alpha
    End If
    If beta > ausgleichbarewinkeldifferenz Then
      ' Target not reachable anymore: go back
      GoTo try_ende
    End If

try_weiter:
    ' Try further
    
    ' 1st possibility: left-curved rail element
    kk = k
    Call ergaenze_bauteil(kk, "bogen links")
    Call try(kk, tiefe + 1, weg + "L")
    
    ' 2nd possibility: right-curved rail element
    kk = k
    Call ergaenze_bauteil(kk, "bogen rechts")
    Call try(kk, tiefe + 1, weg + "R")

    ' 3rd possibility: straight rail element
    kk = k
    Call ergaenze_bauteil(kk, "gerade")
    Call try(kk, tiefe + 1, weg + "-")
  
  End If
  
try_ende:
End Sub

Sub ergaenze_bauteil(k As kopf_type, bauteil As String)
  ' add a railway element ('bauteil') to the current track;
  ' to be more precise: adjust the geometrical parameters of the current head ('k')
  Dim mx1 As Integer
  Dim nx1 As Integer
  Dim my1 As Integer
  Dim ny1 As Integer
  
  Select Case bauteil
  
    Case "gerade"
      ' Straight element: No change in direction; only change the position
      '
      ' Mathematical background:
      ' Length of a straight element is defined here as 1/2.
      ' With direction alpha and using the formulas decribed above,
      ' the change in x direction = 1/2 * cos(alpha) = 1/2 * (m * squareroot(3)/2 + n * 1/2) and
      ' the change in y direction = 1/2 * sin(alpha) = 1/2 * (p * squareroot(3)/2 + q * 1/2).
      ' When taking into account the decomposition of x into mx and nx and y into my and ny (see above):
      '     x = mx * squareroot(3)/4 + nx * 1/4 and
      '     y = my * squareroot(3)/4 + ny * 1/4
      ' then the new coordinates become
      '     x_new = (mx+m) * squareroot(3)/4 + (nx+n) * 1/4 and
      '     y_new = (my+m) * squareroot(3)/4 + (ny+n) * 1/4.
      ' The assignments below update these 4 parameters (mx, nx, my, ny) accordingly.
      ' (Note: for adding left and right curve elements, similar mathematics is being applied.)
      k.mx = k.mx + k.m
      k.nx = k.nx + k.n
      k.my = k.my + k.p
      k.ny = k.ny + k.q
      
    Case "bogen links"
      ' Left curve element
      ' 1) change the position
      mx1 = k.mx + k.m
      nx1 = k.nx + k.n
      my1 = k.my + k.p
      ny1 = k.ny + k.q
      
      k.mx = mx1 - (2 * k.p - k.q)
      k.nx = nx1 - (2 * k.q - 3 * k.p)
      k.my = my1 + (2 * k.m - k.n)
      k.ny = ny1 + (2 * k.n - 3 * k.m)
      
      ' 2) change the direction
      k.alpha = (k.alpha + 30) Mod 360
      Call adjust_mnpq(k)

    Case "bogen rechts"
      ' Right curve element
      ' 1) change the position
      mx1 = k.mx + k.m
      nx1 = k.nx + k.n
      my1 = k.my + k.p
      ny1 = k.ny + k.q
      
      k.mx = mx1 + (2 * k.p - k.q)
      k.nx = nx1 + (2 * k.q - 3 * k.p)
      k.my = my1 - (2 * k.m - k.n)
      k.ny = ny1 - (2 * k.n - 3 * k.m)
      
      ' 2) change the direction
      k.alpha = (k.alpha + 330) Mod 360 ' Attention: -30 mod 360 yields to something different
      Call adjust_mnpq(k)
      
    Case Else
      Debug.Print "Error: Unbekanntes Bauteil"
  End Select

End Sub

Sub adjust_mnpq(k As kopf_type)
  ' Determine the coefficients m, n, p, q from alpha.
  ' See above (definition of this data structure) for more backgroud.
  
  ' determine the cosine parameters of the direction
  Select Case k.alpha
    Case 0
      k.m = 0
      k.n = 2
    Case 30, 330
      k.m = 1
      k.n = 0
    Case 60, 300
      k.m = 0
      k.n = 1
    Case 90, 270
      k.m = 0
      k.n = 0
    Case 120, 240
      k.m = 0
      k.n = -1
    Case 150, 210
      k.m = -1
      k.n = 0
    Case 180
      k.m = 0
      k.n = -2
    Case Else
      Debug.Print "Error: Außerhalb n*30 (cos)"
  End Select
  
  ' determine the sine parameters of the direction
  Select Case k.alpha
    Case 0, 180
      k.p = 0
      k.q = 0
    Case 30, 150
      k.p = 0
      k.q = 1
    Case 60, 120
      k.p = 1
      k.q = 0
    Case 90
      k.p = 0
      k.q = 2
    Case 210, 330
      k.p = 0
      k.q = -1
    Case 240, 300
      k.p = -1
      k.q = 0
    Case 270
      k.p = 0
      k.q = -2
    Case Else
      Debug.Print "Error: Außerhalb n*30 (sin)"
  End Select
End Sub

Function istVerschiebung(a As String, b As String) As Boolean
  ' interprets both strings a and b as loops and determines whether they describe the same loop
  Dim c As String
  Dim lea As Integer, leb As Integer, i As Integer
  lea = Len(a)
  leb = Len(b)
  If lea <> leb Then
    istVerschiebung = False
  Else
    For i = 0 To lea - 1
      ' Compare a with b whereas b is shifted by i
      c = Mid(b, i + 1) + Left(b, i)
      If a = c Then
        istVerschiebung = True
        Exit Function
      End If
    Next i
    ' no shift found which led to the same string
    istVerschiebung = False
  End If
End Function

Function istLRVertauschung(a As String, b As String) As Boolean
  ' checks whether 'b' can simply be constructed by 'a' by swapping all L's and R's
  Dim p As String, q As String
  Dim lea As Integer, leb As Integer, i As Integer
  lea = Len(a)
  leb = Len(b)
  If lea <> leb Then
    istLRVertauschung = False
  Else
    For i = 1 To lea
      p = Mid(a, i, 1)
      q = Mid(b, i, 1)
      If ((p = "L") And (q <> "R")) Or ((p = "R") And (q <> "L")) Or ((p = "-") And (q <> "-")) Then
        istLRVertauschung = False
        Exit Function
      End If
    Next i
    ' swapping seemed to be possible
    istLRVertauschung = True
  End If
End Function

Function LRVertauschung(a As String) As String
  ' returns a string by swapping all L's and R's
  Dim a2 As String, p As String
  Dim lea As Integer, i As Integer
  lea = Len(a)
  a2 = a
  For i = 1 To lea
    p = Mid(a, i, 1)
    If p = "L" Then
      Mid(a2, i, 1) = "R"
    ElseIf p = "R" Then
      Mid(a2, i, 1) = "L"
    End If
  Next i
  LRVertauschung = a2
End Function

Function istIsomorph(a As String, b As String) As Boolean
  ' checks wether 2 strings (i. e. 2 railway tracks) are isomorph and therefore denote the same railway track.
  '
  ' Note: This relation should be an equivalence relation (in a mathematical sense), i. e. (i) reflexive, (ii) symmetrical and (iii) transitive;
  ' Only then equivalence classes can be constructed
  If a = b Then
    ' strings are identical
    istIsomorph = True
  ElseIf istLRVertauschung(a, b) Then
    ' a equals b by simply swapping all L's and R's
    istIsomorph = True
  ElseIf istVerschiebung(a, b) Then
    ' a is a shifted/rotated version of b
    istIsomorph = True
  Else
    Dim a2 As String
    a2 = LRVertauschung(a)
    If istVerschiebung(a2, b) Then
    ' a is a swapped and shifted/rotated version of b
      istIsomorph = True
    Else
      istIsomorph = False
    End If
  End If
End Function

输出(此处:对于可用的19个元素)如下所示：

Nr. Solution            #L  #R  #-
1   LLLLLR-LLLL-LLLRLL- 14  2   3
2   LLLLL-LLRLLL-LLLL-R 14  2   3
3   LLLLRL-LLLL-LLRLLL- 14  2   3
4   LLLL-LLLRLL-LLLL-LR 14  2   3
5   LLLL-LL--LL-LLLL--- 12  0   7
6   LLLL-L-L-LL-LLL-L-- 12  0   7
7   LLLL-L--LLL-LLL--L- 12  0   7
8   LLLL--LL-LL-LL-LL-- 12  0   7
9   LLLL--L-LLL-LL-L-L- 12  0   7
10  LLL-L-LL-LL-L-LLL-- 12  0   7
11  LLL-L-LL-L-LLL-L-L- 12  0   7

Answer 2

我使用的基本方法是从一个简单的轨道开始，可能是空的轨道，然后只是向随机的开放端添加随机元素，禁止非法的组合，比如横过铁轨，或者试图通过用横线代替一个直的部分来使非法的组合合法化。

这可能会造成很少的封闭轨道。如果你想要更多的，你可以尝试一个变体，你不只是在结尾加，而是基本上在任何地方，用一个完整的集合替换一个或多个部分，比如一个圆，一个交叉等等。