- 积分
- 12
- 注册时间
- 2008-7-11
- 仿真币
-
- 最后登录
- 1970-1-1
|
本帖最后由 FreddyMusic 于 2009-11-16 03:11 编辑
八数码的Mathematica实现。应用了Recursive Best-FirstSearching,也就是递归最优搜索。关于递归最优搜索算法请参考Nils J.Nilsson写的《人工智能:新合成》。书里面对RBFS只是简单说了一下,但是讲的非常明白。这个算法比较新颖,但却很容易理解。这本书对现有的启发式搜索算法都进行了比较全面的描述并进行了比较,当然有可能的话更应该看看书中引用的文献,不过那些文献通常要交钱……回头潜进老师的实验室上SpringerLink找找。
Black block means the empty position.
- ClearSystemCache[];
- EightEntropy[lis_List]:=Inversions[Flatten[lis]];
- EightEntropy2=Function[x,Plus@@Flatten@Abs@(Flatten[Position[x,#]&/@Range[9],1]-Flatten[Position[Partition[Range[9],3],#]&/@Range[9],1])];
- (*I use the inversion of permutation as the cost,the inversion of original state is 0,The Manhattan Distance is another option,which people said it is not satisfying,but I haven't try it.*)
- (*EightEntropy2 is the destance of the current position of every number to their original position,which works for ALL legal state! WAHAHAHAHA*)
- Swap={{p___,{9,a_,b_},s___}:>{p,{a,9,b},s},{p___,{a_,9,b_},s___}:>{p,{9,a,b},s},{p___,{a_,9,b_},s___}:>{p,{a,b,9},s},{p___,{a_,b_,9},s___}:>{p,{a,9,b},s}};
- Move=Join[ReplaceList[#,Swap],Transpose/@ReplaceList[Transpose[#],Swap]]&;
- (*Generate all possible moves.Swap can only affect horizonal triple,for vertical ones,apply swap on a transposed matrix and transpose it back.*)
- UpdateWeight={ent_,state_?MatrixQ,sub_}:>{Min@@First/@sub,state,sub}/;ent!=Min@@First/@sub;
- (*Replace all values of non-leaf node to the minimal value of its subnodes.*)
- ExpandBranch={ent_,state1_,{Prev___,{ent_,state2_?MatrixQ},Succ___}}:>{ent,state1,{Prev,{ent,state2,{EightEntropy2[#],#}&/@Complement[Move[state2],{state1}]},Succ}};
- (*Complement can eliminate the repeated state in the new generated states*)
- DeleteBranch={ent1_,state1_,{Prev___,{ent2_,state2_?MatrixQ,sub_},Succ___}}:>{ent1,state1,{Prev,{ent2,state2},Succ}}/;ent1!=ent2;
- (*Delete all subtree if the value of the node is not equal to its subnodes'*)
- Original=Nest[RandomChoice[Move[#]]&,Partition[Range[9],3],20];
- Original={EightEntropy2[#],#,Function[x,{EightEntropy2[x],x}]/@Move[#]}&[Original]//.UpdateWeight
- (*Initializing*)
- While[First[Original]!=0,Original=Original//.ExpandBranch//.UpdateWeight//.DeleteBranch//.UpdateWeight]
- (*work work*)
- Grid[Join[Partition[#,10],{Part[#,-Mod[Length[#],10];;-1]}]&[ArrayPlot/@Cases[DeleteCases[Original,{ent_/;ent!=0,state_?MatrixQ},Infinity],_?MatrixQ,Infinity]]]
- (*Show the path*)
复制代码 |
本帖子中包含更多资源
您需要 登录 才可以下载或查看,没有账号?注册
×
评分
-
1
查看全部评分
-
|