# Solving Puzzle : 4 Pics 1 Word

Posted 10 months ago
1402 Views
|
3 Replies
|
10 Total Likes
|

4 Pics 1 Word is the Android and IOS puzzle that you guess what is the word based on four pictures that have something in common.

For example, the answer of the next screenshot is "TOOL".

## Goal

Solve this puzzle by using Mathematica.

## Recognize Characters

TextRecognize[] cannot recognize characters from full screenshot.

TextRecognize[screenshot, Language -> "English", RecognitionPrior -> "Character"]


Output is Null.

Find 12 box characters areas.

img2 = ImageTrim[screenshot, {{0, 150}, {900, 450}}];
img2b = Binarize[img2];
HighlightImage[img2b, corners]


Trim 12 box characters and assemble them.

c2 = Partition[corners, 8];
rectanglerule = {a_, b_, c_, d_, e_, f_, g_, h_} -> {{a, b, e, f}, {c, d, g, h}};
c3 = Flatten[c2 /. rectanglerule, 1];
asm = ImageTrim[img2b, #] & /@ c3 // ImageAssemble


TextRecognize[] can recognize 12 characters.

TextRecognize[asm, RecognitionPrior -> "Word", Language -> "English"] // Characters


Output is {"L", "T", "K", "W", "J", "M", "H", "D", "U", "O", "O", "I"}.

## Recognize Word Length of the Answer

In this screenshot, the word length of the answer is four.

Trim one line within the input area of the answer(above red line).

img3 = ImageTrim[screenshot, {{0, 555}, {1080, 555}}];
img3b = Binarize[img3]


Output is

The word length of the answer is the number of white area -1 (In this case, 4 = 5-1).

The elements of black line are 0 and the elements of white line are 1.

getWordLength[screenshot_] := Module[{img3, img3b},
img3 = ImageTrim[screenshot, {{0, 555}, {1080, 555}}];
img3b = Binarize[img3];
(ImageData[img3b] //. {x___, a_, a_, y___} -> {x, a, y} // Flatten //
Total) - 1
];

getWordLength[screenshot]


Output is 4.

## Find Candidates

Find candidates using DictionaryLookup[].

getCandidates[string_String, n_] :=
Module[{list},
list = StringJoin /@ Permutations[Sort[Characters[string]], {n}];
Select[list,
Length[DictionaryLookup[#, IgnoreCase -> True]] != 0 &] //
ToUpperCase
];

getCandidates[StringJoin[{"L", "T", "K", "W", "J", "M", "H", "D", "U", "O", "O", "I"}], 4]


Output is {"DHOW", "DOLT", "DOOM", "DOTH", "HILT", "HOLD", "HOLT", "HOOD", "HOOK", "HOOT", "HOWL", "HTML", "HULK", "IDOL", "JILT", "JODI", "JOLT", "JOWL", "JUDO", "KILO", "KILT", "KITH", "KOHL", "LIDO", "LIMO", "LOKI", "LOOK", "LOOM", "LOOT", "LOUD", "LOUT", "LUDO", "MILD", "MILK", "MILO", "MILT", "MOHO", "MOIL", "MOLD", "MOLT", "MOOD", "MOOT", "MOTH", "ODOM", "OHIO", "OMIT", "THOU", "THUD", "TOIL", "TOJO", "TOLD", "TOOK", "TOOL", "WHIM", "WHIT", "WHOM", "WILD", "WILT", "WITH", "WOLD", "WOOD", "WOOL"}.

## Identify Pictures

Identify one of pictures.

ImageTrim[screenshot, {{575, 1215}, {950, 1660}}]
ImageIdentify[%, All, 10]


Trim 4 pictures areas and identify them.

getCommonNames[screenshot_, n_: 10] :=
Module[{img41, img42, img43, img44, entities, cn},
img41 = ImageTrim[screenshot, {{55, 700}, {505, 1145}}];
img42 = ImageTrim[screenshot, {{575, 700}, {950, 1145}}];
img43 = ImageTrim[screenshot, {{55, 1215}, {505, 1660}}];
img44 = ImageTrim[screenshot, {{575, 1215}, {950, 1660}}];
entities = ImageIdentify[#, All, n] & /@ {img41, img42, img43, img44} // Flatten;
cn = CommonName /@ entities;
StringSplit /@ cn // Flatten // Union // Sort // ToUpperCase
];

cns = getCommonNames[screenshot]


Output is {"AIRPLANE", "ALLIGATOR", "ASTRONOMICAL", "BIT", "BOTTLE", "BUFFER", "CARPENTER'S", "CASSEGRAINIAN", "CHUCK", "CHURCHKEY", "CLIP", "COLLET", "COMPOUND", "CUTLERY", "CUTTER", "DRILL", "DRYER", "EDGE", "ELECTRIC", "FASTENING", "HAIR", "HAMMER", "KHUKURI", "KNIFE", "LEVER", "MALLET", "OF", "OPENER", "OPTICAL", "PAIR", "PIPE", "PLIERS", "POCKET", "POWER", "PROPELLER", "REFLECTING", "REGULATOR", "SCISSORS", "SLEDGEHAMMER", "SPIGOT", "TAILPIPE", "TELESCOPE", "TOOL", "TWIST", "VIAL", "WIRE"}.

The answer is the element common to both candidate words and what pictures are.

Intersection[
{"DHOW", "DOLT", "DOOM", "DOTH", "HILT", "HOLD", "HOLT", "HOOD",
"HOOK", "HOOT", "HOWL", "HTML", "HULK", "IDOL", "JILT", "JODI",
"JOLT", "JOWL", "JUDO", "KILO", "KILT", "KITH", "KOHL", "LIDO",
"LIMO", "LOKI", "LOOK", "LOOM", "LOOT", "LOUD", "LOUT", "LUDO",
"MILD", "MILK", "MILO", "MILT", "MOHO", "MOIL", "MOLD", "MOLT",
"MOOD", "MOOT", "MOTH", "ODOM", "OHIO", "OMIT", "THOU", "THUD",
"TOIL", "TOJO", "TOLD", "TOOK", "TOOL", "WHIM", "WHIT", "WHOM",
"WILD", "WILT", "WITH", "WOLD", "WOOD", "WOOL"},
{"AIRPLANE", "ALLIGATOR", "ASTRONOMICAL", "BIT", "BOTTLE", "BUFFER",
"CARPENTER'S", "CASSEGRAINIAN", "CHUCK", "CHURCHKEY", "CLIP",
"COLLET", "COMPOUND", "CUTLERY", "CUTTER", "DRILL", "DRYER", "EDGE",
"ELECTRIC", "FASTENING", "HAIR", "HAMMER", "KHUKURI", "KNIFE",
"LEVER", "MALLET", "OF", "OPENER", "OPTICAL", "PAIR", "PIPE",
"PLIERS", "POCKET", "POWER", "PROPELLER", "REFLECTING", "REGULATOR",
"SCISSORS", "SLEDGEHAMMER", "SPIGOT", "TAILPIPE", "TELESCOPE",
"TOOL", "TWIST", "VIAL", "WIRE"}]


Output is {"TOOL"}.

## Integrate

Get 12 box characters from a screenshot.

getCharacters[screenshot_] :=
Module[{img2, img2b, mask, rectanglerule, corners, c2, c3, asm},
img2 = ImageTrim[screenshot, {{0, 150}, {900, 450}}];
img2b = Binarize[img2];
c2 = Partition[corners, 8];
rectanglerule = {a_, b_, c_, d_, e_, f_, g_, h_} -> {{a, b, e, f}, {c, d, g, h}};
c3 = Flatten[c2 /. rectanglerule, 1];
asm = ImageTrim[img2b, #] & /@ c3 // ImageAssemble;
TextRecognize[asm, RecognitionPrior -> "Word", Language -> "English"] // Characters // ToUpperCase
];


Integrate all functions.

Pics41[screenshot_] := Module[{answer, chars, n, cadidates, cns},
chars = getCharacters[screenshot];
n = getWordLength[screenshot];
Print["Word Length: ", n];
Print["characters: ", chars[[{2, 4, 6, 8, 10, 12, 1, 3, 5, 7, 9, 11}]]];
Print["searching..."];
cns = getCommonNames[screenshot];
];


Another example is

## Finally

I have some problems.

For example, Pics41[] cannot get the answer "COMIC".

• Some manual operations are necessary.
• launch 4 Pics 1 Word
• get screenshot
• mail it to my PC
• import it to Mathematica

I would like that Mathematica can handle 4 Pics 1 Word as directly as possible.

Any ideas very welcome.

Attachments:
3 Replies
Sort By:
Posted 9 months ago
 - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming!
Posted 9 months ago

Hi Kotaro,

This is a great post. I learned a lot, thank you! I have a small improvement to start automating the task of sending the screenshot by email to your pc. You can use our ServiceConnect function to connect Mathematica to your smartphone using the Pushbullet app.

## 4. Connect to Pushbullet from the Wolfram Language

    pb = ServiceConnect["Pushbullet"]


## 5. Import the screenshot

This will import the last pushed image from Pushbullet.

  screenshot =  Import[First[pb["PushHistory"]]["FileURL"]]


You can also import multiple images, e.g. the last 5 pushed screenshots

history = pb["PushHistory"]
Import/@(history[1 ;; 5, "FileURL"]//Normal)


Finally, this is not a suggestion but just another way to write your getWordLength function:

getWordLength[screenshot_] :=
Module[{img3, img3b},
img3 = ImageTrim[screenshot, {{0, 555}, {1080, 555}}];
img3b = Binarize[img3];
Length[Split[PixelValuePositions[img3b, 1][[All, 1]], (#2 - #1) == 1 &]]/2 -1
];


I just like using the PixelValuePositions function ;)