如何在mathematica中模拟以下场景

Question

假设我有n=6个不同的单体，每个单体都有两个不同的反应性末端。在每轮反应期间，一个随机末端与另一个随机末端结合，或者将单体延长至二聚体或自缔合成环。只要系统中没有自由端，该反应过程就会停止。我想用Mma来模拟反应过程。

我想将单体表示为字符串列表，{'1-2'，'3-4'，'5-6'，'7-8'，'9-10'，'11 - 12'}，然后通过更新列表的内容进行一轮反应，例如{'1-2-1'，'3-4'，'5-6'，'7-8'，' 9-10'，'11 -12'}或{'1-2-3-4'，'5-6'，'7-8'，'9-10'，'11 -12'}。但由于我在Mma中的编程限制，我无法走得很远。有人可以帮忙吗？非常感谢。

Answer 1

将分子表示为列表而不是字符串似乎更为自然。所以从{{1,2}，{3,4}，{5,6}}等开始。那么开链只是更长的列表{1,2,3,4}或者其他什么，并且有一些特殊的循环约定，例如以符号“loop”开头。 {{loop，1,2}，{3,4,5,6}，{7,8}}或其他。

您的模拟实际需要多详细？例如，您是否真正关心哪些单体最终会在哪个单元旁边，或者您只关心链条长度的统计数据？在后一种情况下，您可以大大简化模拟的状态：例如，它可以包含一个循环长度列表（它将从空开始）和一个开链长度列表（它将以一堆1开始） ）。然后一个模拟步骤是：随机选择一个开链;以适当的概率，将其转化为循环或将其与另一个开放链组合。

Mathematica你可能想要查找的东西：RandomInteger，RandomChoice; Prepend，Append，Insert，Delete，ReplacePart，Join;虽然（虽然实际上某种类型的“功能迭代”，例如NestWhile可能会产生更漂亮的代码）。

Answer 2

以下是设置：

Clear[freeVertices];
freeVertices[edgeList_List] := Select[Tally[Flatten[edgeList]], #[[2]] < 2 &][[All, 1]];

ClearAll[setNew, componentsBFLS];
setNew[x_, x_] := Null;
setNew[lhs_, rhs_] := lhs := Function[Null, (#1 := #0[##]); #2, HoldFirst][lhs, rhs];

componentsBFLS[lst_List] := 
 Module[{f}, setNew @@@ Map[f, lst, {2}]; GatherBy[Tally[Flatten@lst][[All, 1]], f]];

这是开始：

In[13]:= start = Partition[Range[12], 2]

Out[13]= {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}}

以下是步骤：

In[51]:= steps = 
NestWhileList[Append[#, RandomSample[freeVertices[#], 2]] &, 
  start, freeVertices[#] =!= {} &]

Out[51]= {{{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}}, {{1, 
2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5, 1}}, {{1, 
2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5, 1}, {3, 
4}}, {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5, 
1}, {3, 4}, {7, 11}}, {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 
10}, {11, 12}, {5, 1}, {3, 4}, {7, 11}, {8, 2}}, {{1, 2}, {3, 
4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5, 1}, {3, 4}, {7, 11}, {8,
2}, {6, 10}}, {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 
12}, {5, 1}, {3, 4}, {7, 11}, {8, 2}, {6, 10}, {9, 12}}}

以下是您可以学习的连接组件（周期等）：

In[52]:= componentsBFLS /@ steps

Out[52]= {{{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}}, {{1, 2,
5, 6}, {3, 4}, {7, 8}, {9, 10}, {11, 12}}, {{1, 2, 5, 6}, {3, 
4}, {7, 8}, {9, 10}, {11, 12}}, {{1, 2, 5, 6}, {3, 4}, {7, 8, 11, 
12}, {9, 10}}, {{1, 2, 5, 6, 7, 8, 11, 12}, {3, 4}, {9, 10}}, {{1, 
2, 5, 6, 7, 8, 9, 10, 11, 12}, {3, 4}}, {{1, 2, 5, 6, 7, 8, 9, 10, 
11, 12}, {3, 4}}}

我们将所有对都视为一个大图中的边，并且如果两个顶点此时最多只有一个连接到另一个边，则会随机添加边。在某些时候，该过程停止。然后，我们将componentsBFLS函数映射到结果图（表示模拟的步骤），以获得图的连接组件（步骤）。当然，您也可以使用其他指标，并编写更多函数来分析循环的步骤等。希望这可以帮助您入门。

Answer 3

这是一个简单的方法。根据问题中给出的示例，我假设单体具有优选的结合，因此只有{1,2} + {3,4} -> {1,2,3,4} OR {1,2,1} + {3,4,3}是可能的，但{1,2} + {3,4} -> {1,2,4,3}是不可能的。一旦您满意，下面的代码应该打包成一个很好的函数/模块。如果你是在统计之后，那么它也可能被编译为增加一些速度。

初​​始化：

In[1]:= monomers=Partition[Range[12],2]
        loops={}
Out[1]= {{1,2},{3,4},{5,6},{7,8},{9,10},{11,12}}
Out[2]= {}

循环：

In[3]:= While[monomers!={},
  choice=RandomInteger[{1,Length[monomers]},2];
  If[Equal@@choice, 
     AppendTo[loops, monomers[[choice[[1]]]]];
       monomers=Delete[monomers,choice[[1]]],
     monomers=Prepend[Delete[monomers,Transpose[{choice}]],
                      Join@@Extract[monomers,Transpose[{choice}]]]];
     Print[monomers,"\t",loops]
   ]
During evaluation of In[3]:= {{7,8,1,2},{3,4},{5,6},{9,10},{11,12}} {}
During evaluation of In[3]:= {{5,6,7,8,1,2},{3,4},{9,10},{11,12}}   {}
During evaluation of In[3]:= {{5,6,7,8,1,2},{3,4},{9,10}}   {{11,12}}
During evaluation of In[3]:= {{3,4,5,6,7,8,1,2},{9,10}} {{11,12}}
During evaluation of In[3]:= {{9,10}}   {{11,12},{3,4,5,6,7,8,1,2}}
During evaluation of In[3]:= {} {{11,12},{3,4,5,6,7,8,1,2},{9,10}}

---

编辑：

如果单体可以在两端结合，您只需添加一个选项来翻转您加入的单体，例如

Do[
  choice=RandomInteger[{1,Length[monomers]},2];
  reverse=RandomChoice[{Reverse,Identity}];
  If[Equal@@choice,
    AppendTo[loops,monomers[[choice[[1]]]]];
      monomers=Delete[monomers,choice[[1]]],
    monomers=Prepend[Delete[monomers,Transpose[{choice}]],
             Join[monomers[[choice[[1]]]],reverse@monomers[[choice[[2]]]]]]];
  Print[monomers,"\t",loops],{Length[monomers]}]

{{7,8,10,9},{1,2},{3,4},{5,6},{11,12}}  {}
{{3,4,5,6},{7,8,10,9},{1,2},{11,12}}    {}
{{3,4,5,6},{7,8,10,9},{11,12}}  {{1,2}}
{{7,8,10,9},{11,12}}    {{1,2},{3,4,5,6}}
{{7,8,10,9,11,12}}  {{1,2},{3,4,5,6}}
{}  {{1,2},{3,4,5,6},{7,8,10,9,11,12}}

Answer 4

我看到我的实施模仿西蒙的密切关注。提醒自己：在发布解决方案之前永远不要睡觉......

simulatePolimerization[originalStuff_] :=
 Module[{openStuff = originalStuff, closedStuff = {}, picks},
  While[Length[openStuff] > 0,
   picks = RandomInteger[{1, Length[openStuff]}, 2];
   openStuff = If[RandomInteger[1] == 1, Reverse[#], #] & /@ openStuff;
   If[Equal @@ picks,
    (* closing *)
    AppendTo[closedStuff,Append[openStuff[[picks[[1]]]], openStuff[[picks[[1]], 1]]]];
    openStuff = Delete[openStuff, picks[[1]]],
    (* merging *)
    AppendTo[openStuff,Join[openStuff[[picks[[1]]]], openStuff[[picks[[2]]]]]];
    openStuff = Delete[openStuff, List /@ picks]
  ]
 ];
 Return[closedStuff]
]

一些结果：