Solving Japanese Crosswords in Wolfram Mathematica

Japanese crossword puzzle is a famous puzzle, the answer to which is a drawing. What is it and how to solve it, you can read on Wikipedia . I want to show how you can write a program that will solve the Japanese crossword puzzle in the Wolfram Mathematica system by iterating.

Main ideas

The idea of ​​a brute force solution is to create lists of various cell locations for all rows and columns. After that, with the help of the obtained lists to find those cells, information about which will be accurately known. Then weed out those locations that contradict the information found. It is intuitively clear that if the last two procedures are cyclically repeated, then you can find information about any cell. So, the task can be divided into three subtasks:

1. Drawing up all possible arrangements.
2. Search for filled and uncolored cells.
3. Removing conflicting locations.

Since Wolfram Mathematica is designed to work with lists, cell locations will be stored in the program as lists. We will designate information about cells as follows:

• 1 - filled cell;
• 0 - open cell;
• * - a cell about which nothing is known.

For example, the bottom shows the equivalent list and location of cells:

Composing all possible locations

Some theory

Consider a specific example. It is necessary to find all possible locations for such data:

The above shows one of these locations. How to sort through all possible locations?
')
We do this in the following way. Let us assign the following groups of cells to the key (numbers to the left of the field): {{1,0}, {1,1,0}, {1,1,1}} . Now we will create a list that will store the places where we will arrange these groups in order. In places where we will put these groups, we will store zeros. Thus, we obtain a list of places {0,0,0,0,0} . Arranging groups of cells in order by all means to the places obtained, as it is easy to see, we obtain all the required arrangements for the data from the problem. If we put the groups in order in the places with numbers 1, 3, 4, then we get the location from the example above. Thus, it turns out that all the locations are equivalent to combinations of the number of places by the number of groups. Choosing in some way the place where to put the group, we get one of the possible locations. For example data, the number of locations is ten.

The questions “Why is there no zero in the last group at the end?” And “Why are there five places?” The conscious reader must answer himself.

Implementation

It is clear that there is no particular desire to write the function that will perform the search itself, because in Mathematica there is a built-in function Subsets[list, {n}] , which will do this. It takes a list as the set of elements and the number n as parameters and returns a list of subsets of the set of length n . For our example, using it to iterate through all the places will look like this:

In := Subsets[{1,2,3,4,5}, {3}]

Out = {{1,2,3}, {1,2,4}, {1,2,5}, {1,3,4}, {1,3,5}, {1,4,5}, {2,3,4}, {2,3,5}, {2,4,5}, {3,4,5}}


Now we will write our own function, which will take a number ( len field length, for example data - 10 ) and a list ( clue key, for example data - {1,2,3} ) as parameters and return a list of all possible locations. We will do everything consistently. First, create a function that turns a number into a list of units. For this there is a built-in function ConstantArray[c, n] ; c is the element that fills the list, and n is the length of this list.

In := ConstantArray[1, 2]

Out = {1, 1}


Next, we need to append a zero to the end of this list. This is done using Append[expr, elem] . The first parameter is a list, the second is what we will add.

In := Append[{1, 1}, 0]

Out = {1, 1, 0}


Putting these two functions into one using an object such as a pure function. This can be done in two ways: either Function[arg, Append[ConstantArray[1, arg], 0] , or in short, Append[ConstantArray[1, #], 0]& .

Now it remains to apply this function to each element of the list that corresponds to the key. For this there is a very useful function Map[f, expr] . It applies the f function to each item in the expr list. It also has a short version: f /@ expr .

In := Append[ConstantArray[1, #], 0]& /@ {1, 2, 3}

Out = {{1,0}, {1,1,0}, {1,1,1,0}}


It remains only to remove the zero from the last group. Here function Delete[expr, {i, j}] will help. It will remove the item from the expr list with the index {i, j} . Do not forget that the last element has index -1.

In := Delete[{{1,0}, {1,1,0}, {1,1,1,0}}, {-1, -1}]

Out = {{1,0}, {1,1,0}, {1,1,1}}


Collected all together looks like this:

In := groups = Delete[Append[ConstantArray[1, #], 0]& /@ clue, {-1, -1}]

Out = {{1,0}, {1,1,0}, {1,1,1}}


Everything is clear with the list of places, but we need the function Total[list] , which summarizes the elements of the list .

In := positions = ConstantArray[0, len - Total[clue] + 1]

Out = {0,0,0,0,0}


Now the most important thing is to use the Subsets function. Plus, we need the Range[n] function, which returns the list {1, 2, ..., n} and Length[list] , which gives the length of the list .

In := sub = Subsets[Range[len - Total[clue] + 1], {Length[clue]}]

Out = {{1,2,3}, {1,2,4}, {1,2,5}, {1,3,4}, {1,3,5}, {1,4,5}, {2,3,4}, {2,3,5}, {2,4,5}, {3,4,5}}


We received a list of places where to arrange groups of cells. Now we will deal with the arrangement. To do this, we need the ReplacePart[expr, i->new] function; it replaces the element i in the list of expr with the element new . But first we will get a list of replacements, so that it is more convenient to write the code later. The MapThread[f, {a function MapThread[f, {a ₁ , a ₂ , ...}, {b ₁ , b ₂ , ...}] will help us to do this. The result of its execution will be the following: {f[a ₁ , b ₁ ], f[a ₂ , b ₂ ], ...} . So, create a list of replacements:

In := rep = MapThread[Function[{x, y}, x->y], {#, groups}]& /@ sub

Out = {{1->{1,0}, 2->{1,1,0}, 3->{1,1,1}}, {1->{1,0}, 2->{1,1,0}, 4->{1,1,1}}, {1->{1,0}, 2->{1,1,0}, 5->{1,1,1}}, {1->{1,0}, 3->{1,1,0}, 4->{1,1,1}}, {1->{1,0}, 3->{1,1,0}, 5->{1,1,1}}, {1->{1,0}, 4->{1,1,0}, 5->{1,1,1}}, {2->{1,0}, 3->{1,1,0}, 4->{1,1,1}}, {2->{1,0}, 3->{1,1,0}, 5->{1,1,1}}, {2->{1,0}, 4->{1,1,0}, 5->{1,1,1}}, {3->{1,0}, 4->{1,1,0}, 5->{1,1,1}}}


The finale of the whole undertaking is the placement in its place. Here we do Flatten[list] , which will remove the extra brackets:

In := all = Flatten[ReplacePart[positions, #]]& /@ rep

Out = {{1,0,1,1,0,1,1,1,0,0}, {1,0,1,1,0,0,1,1,1,0}, {1,0,1,1,0,0,0,1,1,1}, {1,0,0,1,1,0,1,1,1,0}, {1,0,0,1,1,0,0,1,1,1}, {1,0,0,0,1,1,0,1,1,1}, {0,1,0,1,1,0,1,1,1,0}, {0,1,0,1,1,0,0,1,1,1}, {0,1,0,0,1,1,0,1,1,1}, {0,0,1,0,1,1,0,1,1,1}}


That's all, all arrangements are received. It remains to combine all this into one module for convenience and we will get the required function.

allPositions[len_, clue_] :=

Module[{groups, positions, sub, rep, all},

groups = Delete[Append[ConstantArray[1, #], 0]& /@ clue, {-1, -1}];

positions = ConstantArray[0, len - Total[clue] + 1];

sub = Subsets[Range[len - Total[clue] + 1], {Length[clue]}];

rep = MapThread[Function[{x, y}, x->y], {#, groups}]& /@ sub;

all = Flatten[ReplacePart[positions, #]]& /@ rep;

Return[all];]


Search for filled and uncolored cells

Now, in the midst of all this goodness that we will get, using our function, we need to extract information about the cells. Suppose we have some list of locations. If there is a place where in all arrangements is 1 or 0, then this gives us the right to say that there will always be a shaded cell in this position, or, accordingly, an unfinished cell. In my opinion, the simplest implementation of the function that will do this is as follows: all locations are summed element by element and the resulting list looks for either numbers equal to the number of all locations or zeros. In the first case, these numbers are changed by ones, and in the second, the zeros remain in their places. All other elements are replaced with asterisks. To implement we use the function ReplaceAll[list, rule] . It will replace items in the list according to the rules of the rule . x_ /; x!=0 x_ /; x!=0 means "an element x , such that x ≠ 0 ".

findInformation[list_] := ReplaceAll[Total[list], {x_ /; x!=0 && x!=Length[list] -> "*", x_ /; x==Length[list] -> 1}]

For our example, the function operation looks like this:

In := findInformation[allPositions[len, clue]]

Out = {*,*,*,*,*,*,*,1,*,*}


The eighth cell in all arrangements will be shaded, so in the whole grid it will be painted over. Nothing can be said about the remaining cells.

Removing conflicting locations

The resulting information can be used in order to weed out locations that contradict it. The DeleteCases[expr, pattern] function will be our filter — it removes from the expr list all elements that do not match the pattern . The Except[c] function will also be used, which selects everything except its parameter.

deleteFromList[list_, test_] := DeleteCases[list, Except[ReplaceAll[test, "*"->_]]]


Let us go back to the example, let us get that the location of the cells must satisfy this pattern: {*,*,0,0,*,1,0,*,*,*} . Running our function, we get:

In := deleteFromList[allPositions[len, clue], {"*","*",0,0,"*",1,0,"*","*","*"}]

Out = {{1,0,0,0,1,1,0,1,1,1}, {0,1,0,0,1,1,0,1,1,1}}


It turned out that only two out of ten locations satisfy the pattern.

Putting it all together. Final stage

We have created step by step all the necessary functions for solving a crossword puzzle. Now it is important to gather everything beautifully to get a solution. As an example, I use a crossword puzzle taken from the Kiev magazine of Japanese crossword puzzles Relax. Its author is A. Leut.

Crossword is set in the program as a list of keys for the rows and for the columns.

rows = {{1}, {2}, {4}, {3,1}, {4,1}, {12}, {9}, {4,1}, {1,1,1,1,1}, {1,1,1,1}, {1,3,1}, {2,1,1}, {9,1}, {4,5,1}, {3,4,1}, {3,5,3}, {3,1,5}, {5,1,2}, {7,3}, {4,10}, {4,3,3}, {4,2,3}, {5,2,2}, {5,3,2}, {4,1,1,2}, {3,2,2}, {2,2}, {7}, {10}, {2,6}};

cols = {{3}, {6}, {8}, {13}, {1,12,1}, {2,7,2,1}, {5,2,7,4}, {5,3,12}, {8,2,3,1,1,2}, {8,2,1,3}, {2,3,4,1,4}, {2,2,1,1,5,3,5}, {4,6,7,2}, {2,3,3,8,2}, {1,2,2,2}, {1,4,1}, {2}, {2}, {9}, {1}};


You do not need to enter grid dimensions, because you can define them anyway:

rowlength = Length[cols]

collength = Length[rows]


The drawing will be stored in the program as a list of lists or an ordinary matrix. Before the decision, we have no information at all, so each element of it will be an asterisk.

pic = ConstantArray["*", {collength, rowlength}];


Now the most cumbersome part of solving a crossword puzzle is filling lists of various locations. Here you need to wait a bit.

rowpos = allPositions[rowlength, #]& /@ rows;

colpos = allPositions[collength, #]& /@ cols;


When all the locations are filled, you can proceed to the solution. The idea is this: a search is performed on all the rows of filled cells, and these cells are written into the main grid. Then from the locations for the columns are removed those that contradict the information received and the search is conducted by columns, etc. The search will take place as long as there is at least one asterisk in the grid; I think that the work of the While loop does not need to be explained. MemberQ in the above code returns True if there is an asterisk in the grid and False otherwise. Transpose also used in order to work equally with both rows and columns. To output a picture, there is a built-in function ArrayPlot , which paints the cell with black if it is 1 and white if it is 0 (the asterisk is filled with brown by default). In order to see how the pattern dynamically changes in the process of solving, Dynamic used.

Dynamic[ArrayPlot[pic, Mesh->True]]

While[MemberQ[pic, "*", 2],

pic = findInformation /@ rowpos;

colpos = MapThread[deleteFromList, {colpos, Transpose[pic]}];

pic = Transpose[findInformation /@ colpos];

rowpos = MapThread[deleteFromList, {rowpos, pic}];]


The result is the following picture:

Perhaps someone noticed that the solution is very sub-optimal. Yes, it is, but not in the best case. The purpose of the article is to show that with the help of Wolfram Mathematica you can conveniently and quickly solve this problem. But if we are already talking about optimality, then for this task there are many ways to optimize the algorithm, for example, to filter and search for information only in those columns and rows, information about the cells of which was added at the previous step. In this version of the program, the search is performed in all columns and rows.