Nonograms From Pixelization of a Font

Manipulate[With[{gob=makegobelin[k,case,font]} ,With[{m=Length[gob],n=Length[gob[[1]]]},With[{empty=RandomInteger[{0,0},{m,n}],cc=Map[Split,gob],cc1=Map[Split,Transpose[gob]]},With[{row=Map[Length,Table[Select[cc[[i]],MemberQ[#,1]&],{i,1,Length[cc]}],{2}],col=Map[Length,Table[Select[cc1[[i]],MemberQ[#,1]&],{i,1,Length[cc1]}],{2}]},With[{desno=Map[stringfromlist,row],spodaj=Map[Column,col]},Column[{Show[ArrayPlot[If[sh,gob,empty],Mesh->True,Axes->None,ColorRules->{1->GrayLevel[0.6]},MeshStyle->{GrayLevel[0.3]}],Graphics[{Table[Text[Style[desno[[i]],20],{n+0.3,m+0.5-i},{-1,0}],{i,1,m}],Table[Text[Style[spodaj[[i]],20],{i-0.5,-0.1},{0,1}],{i,1,n}]}],ImageSize->{320,420}]}]]]]]],
{{k,1,"letter"},1,26,1},
{{font,"Helvetica","font"},{"Times","Helvetica","Courier"}},{{case,"uppercase","case"},{"uppercase","lowercase"}},
{{sh,False,"show solution"},{False,True}},
SynchronousInitialization->False,
Initialization:>(
makegobelin[i_,case_,font_]:=Module[{rr,tt,zz},rr=Rasterize[
Style[If[case==="lowercase",CharacterRange["a","z"],CharacterRange["A","Z"]][[i]],FontFamily->font],
"Data"];tt=rr/.{{x_,y_,z_}:>0/;x>100 ||y>100||z>100,{x_,y_,z_}:>1/;x<=100 &&y<=100&&z<=100};zz=ImageCrop[Image[tt]];ImageData[zz]/.{1.->1,0.->0}];stringfromlist[list_]:=Module[{len=Length[list],str=""},If[len==0,"",Do[str=StringJoin[str,ToString[list[[i]]],", "],{i,1,len-1}];str=StringJoin[str,ToString[list[[len]]]]]];)]

A grid of squares is given. Each square must be filled in gray or left as white. The numbers to the right of the rows or under the columns are the lengths of the runs of gray squares in that row or column. (For example, 1, 2 means there is one gray square followed by two; the number of white squares separating them, before the first one, or after the last two not given.) The aim is to find all gray squares.

Nonogram, http://en.wikipedia.org/wiki/Nonogram

Contributed by: Izidor Hafner

Using code by: Stephen Wolfram