Nonogram solver: Difference between revisions
→{{header|Racket}}: (link to) implementation added |
|||
Line 57: | Line 57: | ||
=={{header|Prolog}}== |
=={{header|Prolog}}== |
||
Works with SWI-Prolog version 6.5.3 <br> |
Works with SWI-Prolog version 6.5.3 <br> |
||
module( |
module(clpfd) is written by '''Markus Triska'''<br> |
||
Solution written by '''Lars Buitinck'''<br> |
|||
Module solve-nonogram.pl |
Module solve-nonogram.pl |
||
<lang Prolog> |
<lang Prolog>/* |
||
* Nonogram/paint-by-numbers solver in SWI-Prolog. Uses CLP(FD), |
|||
:- use_module(library(lambda)). |
|||
* in particular the automaton/3 (finite-state/RE) constraint. |
|||
* Copyright (c) 2011 Lars Buitinck. |
|||
* Do with this code as you like, but don't remove the copyright notice. |
|||
*/ |
|||
:- use_module(library(clpfd)). |
:- use_module(library(clpfd)). |
||
nono(RowSpec, ColSpec, Grid) :- |
|||
rows(RowSpec, Grid), |
|||
transpose(Grid, GridT), |
|||
rows(ColSpec, GridT). |
|||
rows([], []). |
|||
nonogram(Lines, Columns) :- |
|||
rows([C|Cs], [R|Rs]) :- |
|||
length(Lines, L), |
|||
row(C, R), |
|||
rows(Cs, Rs). |
|||
maplist(\X^length(X, C), Nonogram), |
|||
maplist(cree_possibilites(C), Lines, Pos_Lines), |
|||
maplist(cree_possibilites(L), Columns, Pos_Columns), |
|||
transpose(Nonogram, Trans_nonogram), |
|||
loop(Nonogram, Trans_nonogram, L, Pos_Lines, C, Pos_Columns), |
|||
maplist(my_writeln, Nonogram). |
|||
loop(Nonogram, Trans_nonogram, L, Lines, C, Columns):- |
|||
maplist(C+\X^Y^U^fill_row(C, X, Y, U), Nonogram, Lines, M_L), |
|||
maplist(L+\Z^T^V^fill_row(L, Z, T,V), Trans_nonogram, Columns, M_C), |
|||
maplist(nouvelles_contraintes, Lines, M_L, Nouvelles_Lines), |
|||
maplist(nouvelles_contraintes, Columns, M_C, Nouvelles_Columns), |
|||
( \+sumlist(M_L, L) % \+nongram_termine(Nonogram) |
|||
-> loop(Nonogram, Trans_nonogram, L, Nouvelles_Lines, C, Nouvelles_Columns) |
|||
; true). |
|||
nouvelles_contraintes(Lines, 0, Lines). |
|||
nouvelles_contraintes(_Lines, 1, []). |
|||
cree_possibilites(Len, Lst, Pos_Lines) :- |
|||
setof(Value, compute_cases(Len, Lst, Value), Lst_val), |
|||
maplist(mix(Lst), Lst_val, Pos_Lines). |
|||
fill_row(_Len, _Row, [], 1). |
|||
fill_row(Len, Row, Lst, Res) :- |
|||
include(good_values(Row), Lst, Lst_values), |
|||
length(Y_in, Len), |
|||
maplist(init, Row, Y_in), |
|||
% if Max = 1 then line is over |
|||
length(Lst_values, Max), |
|||
foldl(\X^Y^Z^work_space(X,Y,[],Z), Lst_values, Y_in, R), |
|||
maplist(\A^B^(A = Max |
|||
-> B = 1 |
|||
; A = 0 |
|||
-> B = 0 |
|||
; true), |
|||
R, Row), |
|||
( Max = 1 -> Res = 1; Res = 0). |
|||
good_values(Row, Values) :- |
|||
length(Row, Len), |
|||
length(Y_in, Len), |
|||
maplist(=(0), Y_in), |
|||
work_space(Values, Y_in, [], Y_out), |
|||
maplist(\X^Y^(nonvar(X) |
|||
-> X = Y |
|||
; true), Row, Y_out). |
|||
init(X, 0) :- |
|||
var(X), !. |
|||
init(X, X). |
|||
% work_space(Row, In, Current, Final) |
|||
% Row : list [Nbblancs, Nb_noirs, Nb_blancs, Nb_noirs,.., Nb_blancs] |
|||
% In : row already constructed |
|||
% Current : new row in construction |
|||
% Final : new row terminated |
|||
work_space([], [], Z, RZ) :- |
|||
reverse(Z, RZ). |
|||
work_space([0|T], Y_in, Y_out, Z) :- |
|||
work_black(T, Y_in, Y_out, Z). |
|||
work_space([H|T], Y_in, Y_out, Z) :- |
|||
H > 0, |
|||
work_1(0, H, Y_in, Y_out, Y_in_1, Y_out_1), |
|||
work_black(T, Y_in_1, Y_out_1, Z). |
|||
work_black([], [], Y_out, Z) :- |
|||
reverse(Y_out, Z). |
|||
work_black([H | T], Y_in, Y_out, Z) :- |
|||
H > 0, |
|||
work_1(1, H, Y_in, Y_out, Y_in_1, Y_out_1), |
|||
work_space(T, Y_in_1, Y_out_1, Z). |
|||
work_1(_, 0, Y_in, Y_out, Y_in, Y_out). |
|||
work_1(V, N, [H | Y_in], Y_out, Y_in_1, Y_out_1) :- |
|||
H1 is H + V, |
|||
N1 is N - 1, |
|||
work_1(V, N1, Y_in, [H1 | Y_out], Y_in_1, Y_out_1). |
|||
mix([], [Space], [Space]). |
|||
row(Ks, Row) :- |
|||
mix([HB | TB], [HS | TS], [HS, HB | T]) :- |
|||
sum(Ks, #=, Ones), |
|||
sum(Row, #=, Ones), |
|||
arcs(Ks, Arcs, start, Final), |
|||
append(Row, [0], RowZ), |
|||
automaton(RowZ, [source(start), sink(Final)], [arc(start,0,start) | Arcs]). |
|||
% Make list of transition arcs for finite-state constraint. |
|||
arcs([], [], Final, Final). |
|||
arcs([K|Ks], Arcs, CurState, Final) :- |
|||
gensym(state, NextState), |
|||
( K == 0 |
|||
-> Arcs = [arc(CurState,0,CurState), arc(CurState,0,NextState) | Rest], |
|||
arcs(Ks, Rest, NextState, Final) |
|||
; Arcs = [arc(CurState,1,NextState) | Rest], |
|||
K1 #= K-1, |
|||
arcs([K1|Ks], Rest, NextState, Final)). |
|||
make_grid(Grid, X, Y, Vars) :- |
|||
length(Grid,X), |
|||
make_rows(Grid, Y, Vars). |
|||
make_rows([], _, []). |
|||
compute_cases(Len, Lst, Value) :- |
|||
make_rows([R|Rs], Len, Vars) :- |
|||
sum_list(Lst, Val), |
|||
length( |
length(R, Len), |
||
make_rows(Rs, Len, Vars0), |
|||
NbCell is NbC + 1, |
|||
append(R, Vars0, Vars). |
|||
length(Value, NbCell), |
|||
MaxCell is Len - Val, |
|||
append([Head | Tail], [Last], Value), |
|||
Tail ins 1..MaxCell, |
|||
[Head, Last] ins 0..MaxCell, |
|||
sum(Value, #=, MaxCell), |
|||
label(Value). |
|||
print([]). |
|||
print([R|Rs]) :- |
|||
print_row(R), |
|||
print(Rs). |
|||
print_row([]) :- nl. |
|||
print_row([X|R]) :- |
|||
maplist(my_writeln_1, X), |
|||
( X == 0 |
|||
nl. |
|||
-> write(' ') |
|||
; write('x')), |
|||
print_row(R). |
|||
nonogram(Rows, Cols) :- |
|||
my_writeln_1(0) :- write(.). |
|||
length(Rows, X), |
|||
length(Cols, Y), |
|||
make_grid(Grid, X, Y, Vars), |
|||
nono(Rows, Cols, Grid), |
|||
label(Vars), |
|||
print(Grid). |
|||
my_writeln_1(1) :- write(#). |
|||
</lang> |
</lang> |
||
File nonogram.pl, used to read data in a file. |
File nonogram.pl, used to read data in a file. |
Revision as of 17:28, 24 March 2014
Each row and column of a rectangular grid is annotated with the lengths of its distinct runs of occupied cells. Using only these lengths you should find one valid configuration of empty and occupied cells (or show a failure message):
Problem: Solution: . . . . . . . . 3 . # # # . . . . 3 . . . . . . . . 2 1 # # . # . . . . 2 1 . . . . . . . . 3 2 . # # # . . # # 3 2 . . . . . . . . 2 2 . . # # . . # # 2 2 . . . . . . . . 6 . . # # # # # # 6 . . . . . . . . 1 5 # . # # # # # . 1 5 . . . . . . . . 6 # # # # # # . . 6 . . . . . . . . 1 . . . . # . . . 1 . . . . . . . . 2 . . . # # . . . 2 1 3 1 7 5 3 4 3 1 3 1 7 5 3 4 3 2 1 5 1 2 1 5 1
The problem above could be represented by two lists of lists:
x = [[3], [2,1], [3,2], [2,2], [6], [1,5], [6], [1], [2]] y = [[1,2], [3,1], [1,5], [7,1], [5], [3], [4], [3]]
A more compact representation of the same problem uses strings, where the letters represent the numbers, A=1, B=2, etc:
x = "C BA CB BB F AE F A B" y = "AB CA AE GA E C D C"
For this task try to solve the problems read from a "nonogram_problems.txt" file, copied from this:
C BA CB BB F AE F A B AB CA AE GA E C D C F CAC ACAC CN AAA AABB EBB EAA ECCC HCCC D D AE CD AE A DA BBB CC AAB BAA AAB DA AAB AAA BAB AAA CD BBA DA CA BDA ACC BD CCAC CBBAC BBBBB BAABAA ABAD AABB BBH BBBD ABBAAA CCEA AACAAB BCACC ACBH DCH ADBE ADBB DBE ECE DAA DB CC BC CAC CBAB BDD CDBDE BEBDF ADCDFA DCCFB DBCFC ABDBA BBF AAF BADB DBF AAAAD BDG CEF CBDB BBB FC E BCB BEA BH BEK AABAF ABAC BAA BFB OD JH BADCF Q Q R AN AAN EI H G E CB BAB AAA AAA AC BB ACC ACCA AGB AIA AJ AJ ACE AH BAF CAG DAG FAH FJ GJ ADK ABK BL CM
More info:
http://en.wikipedia.org/wiki/Nonogram
This task is the problem n.98 of the "99 Prolog Problems" by Werner Hett (also thanks to Paul Singleton for the idea and the examples):
https://sites.google.com/site/prologsite/prolog-problems
Some Haskell solutions:
http://www.haskell.org/haskellwiki/99_questions/Solutions/98
http://twanvl.nl/blog/haskell/Nonograms
PicoLisp solution:
http://picolisp.com/5000/!wiki?99p98
Bonus Problem: generate nonograms with unique solutions, of desired height and width.
Prolog
Works with SWI-Prolog version 6.5.3
module(clpfd) is written by Markus Triska
Solution written by Lars Buitinck
Module solve-nonogram.pl
<lang Prolog>/*
- Nonogram/paint-by-numbers solver in SWI-Prolog. Uses CLP(FD),
- in particular the automaton/3 (finite-state/RE) constraint.
- Copyright (c) 2011 Lars Buitinck.
- Do with this code as you like, but don't remove the copyright notice.
- /
- - use_module(library(clpfd)).
nono(RowSpec, ColSpec, Grid) :- rows(RowSpec, Grid), transpose(Grid, GridT), rows(ColSpec, GridT).
rows([], []). rows([C|Cs], [R|Rs]) :- row(C, R), rows(Cs, Rs).
row(Ks, Row) :- sum(Ks, #=, Ones), sum(Row, #=, Ones), arcs(Ks, Arcs, start, Final), append(Row, [0], RowZ), automaton(RowZ, [source(start), sink(Final)], [arc(start,0,start) | Arcs]).
% Make list of transition arcs for finite-state constraint. arcs([], [], Final, Final). arcs([K|Ks], Arcs, CurState, Final) :- gensym(state, NextState), ( K == 0 -> Arcs = [arc(CurState,0,CurState), arc(CurState,0,NextState) | Rest], arcs(Ks, Rest, NextState, Final) ; Arcs = [arc(CurState,1,NextState) | Rest], K1 #= K-1, arcs([K1|Ks], Rest, NextState, Final)).
make_grid(Grid, X, Y, Vars) :-
length(Grid,X),
make_rows(Grid, Y, Vars).
make_rows([], _, []). make_rows([R|Rs], Len, Vars) :- length(R, Len), make_rows(Rs, Len, Vars0), append(R, Vars0, Vars).
print([]). print([R|Rs]) :- print_row(R), print(Rs).
print_row([]) :- nl. print_row([X|R]) :- ( X == 0 -> write(' ') ; write('x')), print_row(R).
nonogram(Rows, Cols) :- length(Rows, X), length(Cols, Y), make_grid(Grid, X, Y, Vars), nono(Rows, Cols, Grid), label(Vars), print(Grid).
</lang> File nonogram.pl, used to read data in a file. <lang Prolog>nonogram :- open('C:/Users/Utilisateur/Documents/Prolog/Rosetta/nonogram/nonogram.txt', read, In, []), repeat, read_line_to_codes(In, Line_1), read_line_to_codes(In, Line_2), compute_values(Line_1, [], [], Lines), compute_values(Line_2, [], [], Columns), nonogram(Lines, Columns) , nl, nl, read_line_to_codes(In, end_of_file), close(In).
compute_values([], Current, Tmp, R) :- reverse(Current, R_Current), reverse([R_Current | Tmp], R).
compute_values([32 | T], Current, Tmp, R) :- !, reverse(Current, R_Current), compute_values(T, [], [R_Current | Tmp], R).
compute_values([X | T], Current, Tmp, R) :- V is X - 64, compute_values(T, [V | Current], Tmp, R). </lang>