Sudoku(数独) を Mathematicaで解く(7): codes

目次へ

今後、ノートブック上にプログラムを作るために、(6)で説明したグループ化された関数の集まり code1, code2, code3, code4 を整理して以下に示します。

コードの中に書いてある (* begin{Section} *) (* end{Section} *) はノートブックの中ではコメント文です。セルのスタイルをSection に設定すると便利なのでこれを書き入れました。

7.1 code1: plotGame について

 これはゲームを表示する関数です。(1)と(5)で説明した関数をまとめたものです。

(*  code1  : plotGame and plotGameSeq  *)
(* begin{Section} *)

plotGame[ini_?MatrixQ]:=Grid[ini,
  ItemStyle->{Directive[Blue,25,Bold],None},
 ItemSize->{2.5,2.5},Dividers -> {{{Thickness[2],True,True}},{{Thickness[2],True,True}}},
  Background -> {Automatic,Automatic,
  Flatten[Table[{i, j} -> If[EvenQ[Plus @@ Floor[{i - 1, j - 1}/3]], 
  LightGreen, White], {i, 9}, {j, 9}]]},Spacings->{0,0.45}]

plotGameSeq[ini_?MatrixQ,xylist:{{_,_}..}]:=Grid[ini,
  ItemStyle->{Directive[FontSize->25,Darker[Blue],Bold],Automatic,Thread[xylist->Table[Pink,{Length[xylist]}]]},
  ItemSize->{2.5,2.5},Dividers -> {{{Thickness[2],True,True}},{{Thickness[2],True,True}}},
  Background -> {Automatic,Automatic,
  Flatten[Table[{i, j} -> If[EvenQ[Plus @@ Floor[{i - 1, j - 1}/3]], 
  LightGreen, White], {i, 9}, {j, 9}]]},Spacings->{0,0.45}] 

plotGameSeq[ini_?MatrixQ,xylist:{}]:=plotGame[ini]

(* end{Section} *)

7.2 code2: plotMap について

 候補図(map)を描く関数です。(1)と(5)で説明した関数をまとめたものです。

(* code2 : 候補図: plotMapGrid and plotGridsColored   *)
(* begin{Section} *)

gridBox[lst_List]:=Grid[Partition[ReplacePart[Table[blank,{9}],Thread[lst->lst]],3]/.blank->Null]

plotMapGrid[ini_?MatrixQ,mapini_List]:=Module[{numbers,grids,mapgrid},
  numbers=DeleteCases[Flatten[Table[If[ini[[i,j]]=!=Null,{i,j}->ini[[i,j]],"aa"],{i,1,9},{j,1,9}],1],_?StringQ];
  grids=Table[gridBox[mapini[[i,j]]],{i,1,9},{j,1,9}];
  mapgrid=ReplacePart[grids,numbers];
  Grid[mapgrid,
    ItemStyle->{Directive[Blue,13,Bold],Automatic,Thread[numbers[[All,1]]->Table[Directive[Blue,30,Bold],{Length[numbers]}]]},
    ItemSize->{3.0,3.6},Dividers -> {{{Thickness[2],True,True}},{{Thickness[2],True,True}}},
    Background -> {Automatic,Automatic,
    Flatten[Table[{i, j} -> If[EvenQ[Plus @@ Floor[{i - 1, j - 1}/3]], 
    LightGreen, White], {i, 9}, {j, 9}]]}
  ]
]

(* begin{Subsection}: coloring *)

makeGrids[mapini_]:=Table[gridBox[mapini[[i,j]]],{i,1,9},{j,1,9}]

coloring2[grids_,{nums_List,{i_,j_}},bkg_:Green,moji_:Black]:=Module[{tmp},
  tmp=grids;
  tmp[[i,j]]=grids[[i,j]]/.Flatten[{#->Item[Style[#,moji], Background -> bkg]}&/@nums,1];
  tmp
]

makeGridsColored[grids_,colors_,bkg_String]:=Module[{moji},
  Which[bkg=="Green",
    Fold[coloring2[#1,#2,Symbol[bkg],Black]&,grids,colors],bkg=="Yellow",
    Fold[coloring2[#1,#2,Symbol[bkg],Red]&,grids,colors]
  ]
]

plotGridsColored[ini_,grids_]:=Module[{numbers,mapgrid},
  numbers=DeleteCases[Flatten[Table[If[ini[[i,j]]=!=Null,{i,j}->ini[[i,j]],"aa"],{i,1,9},{j,1,9}],1],_?StringQ];
  mapgrid=ReplacePart[grids,numbers];
  Grid[mapgrid,
    ItemStyle->{Directive[Blue,13,Bold],Automatic,Thread[numbers[[All,1]]->Table[Directive[Blue,30,Bold],{Length[numbers]}]]},
    ItemSize->{3.4,3.6},Dividers -> {{{Thickness[2],True,True}},{{Thickness[2],True,True}}},
    Background -> {Automatic,Automatic,
    Flatten[Table[{i, j} -> If[EvenQ[Plus @@ Floor[{i - 1, j - 1}/3]], 
    LightGreen, White], {i, 9}, {j, 9}]]}
  ]
]
(* end{Subsection}  *)
(* end{Section} *)

7.3 code3: makeMap について

各ブランクに入れるべき候補を決める関数 makeMap です。(3)で説明したものと同じです。

(* code3 : makeMap  *)
(* begin{Section} *)

candidates[ini_?MatrixQ,{i_,j_}]:=Module[{f},
  f[k_]:=Which[1<=k<=3, 1;;3,4<=k<=6,4;;6,7<=k<=9,7;;9];
  If[ini[[i,j]]=!=Null,{},
    Complement[Range[9],
    Union[ini[[i]],ini[[All,j]],Flatten[ini[[f[i],f[j]]]]]]
  ]
]

makeMap[ini_?MatrixQ]:=Table[candidates[ini,{i,j}],{i,1,9},{j,1,9}]

(* end{Section} *)

7.4 code4: NakedSingle について

NakedSingle(裸のシングル)を探す関数です。(5)で説明した関数を整理のためまとめたものです。

(* code4 : NakedSingle  *)
(* begin{Section} *)

findNakedSingle[mapini_]:=Module[{p,element},
  p=Position[mapini,{_}];
  element=Map[mapini[[Sequence@@#]]&,p];
  Transpose[{Flatten[element],p}]
]

findNakedSingleColor[mapini_]:=Module[{p,element},
  p=Position[mapini,{_}];
  element=Map[mapini[[Sequence@@#]]&,p];
  Transpose[{element,p}]
]

makeMatrixByNakedSingle[ini_]:=Module[{mapini,singles},
  mapini=makeMap[ini];
  singles=findNakedSingle[mapini];
  rules=Map[Apply[Rule,Reverse[#]]&,singles];
  Fold[ReplacePart[#1,#2]&,ini,rules]
]

(* begin{Subsection} : coloring *)

plotMapGridsColoredByNakedSingle[ini_]:=Module[{mapini,delList,grids},
  mapini=makeMap[ini];
  delList=findNakedSingleColor[mapini];
  grids=makeGridsColored[makeGrids[mapini],delList,"Yellow"];
  plotGridsColored[ini,grids]
]

(* end{Subsection} *)
(* end{Section} *)

 
続く

次は、 Main を説明し、関数 findNakedSingle で答えが見つからない例を示します。

目次へ