KenKen Solver
From the SETL Wiki
There is now an online demo of this program.
program kenken;
const
operators := {'+', '-', '*', '/', '?', '='};
$ Identities (0 for additive operators, 1 for multiplicative operators)
const
opIdent := {['+', 0], ['-', 0], ['*', 1], ['/', 1], ['?', 0], ['?', 1]};
var size;
var digitsUsed;
var cellXY;
var cellsByX, cellsByXY, cellsByY;
var cellRange: back;
var cages;
var cagesByCell;
var changedCells: back;
var changedRows: back;
var changedCols: back;
var changedCages: back;
var cagesBySize;
var paraPerms: back;
cageFile := command_line(1);
h := open(cageFile, 'TEXT-IN');
reada(cageFile, size);
loop
init
cellXY := {};
cages := [];
cagesByCell := {};
cagesBySize := {};
doing
reada(cageFile, cage);
while
cage /= om
do
[value, oper, cgCoords] := cage;
cgAtoms := {};
(for xy in cgCoords)
cell := newat;
cellXY(cell) := xy;
cgAtoms with:= cell;
cagesByCell with:= [cell, 1 + #cages];
end;
cages with:= [value, oper, cgAtoms];
cagesBySize with:= [#cgCoords, #cages];
end;
close(cageFile);
changedCages := {};
changedRows := {};
changedCols := {};
paraPerms := {};
nrSolutions := 0;
setupBoard(size);
(while ok)
solve();
showBoard();
nrSolutions +:= 1;
fail;
end;
print(nrSolutions, "solutions found");
proc solve();
(until is_smap cellRange and
{changedCells, changedCols, changedRows, changedCages} = {{}})
refine();
end;
end proc;
proc showBoard();
(for y in [1..size])
(for x in [1..size])
digits := {digit: cell in cellsByXY{[x,y]}, digit in cellRange{cell}};
nprint(' ' + arb digits);
end;
print();
end;
print();
end proc;
proc showBoardLong();
(for y in [1..size])
row :=
['' +/ [d in [1..size] |
d in cellRange{cellsByXY([x, y])}]:
x in [1..size]];
(for yy in [1..3])
(for x in [1..size])
cell := row(x);
nprint(rpad('' +/ cell(1..5), 6));
cell(1..5) := '';
row(x) := cell;
end;
print();
end;
end;
print();
end proc;
proc isolateRCPerms(cells, rcIdx, oAxis);
ranges := {cellRange{cell}: cell in cells};
(for r in ranges | #r < size)
cellsInPerm := {cell in cells | cellRange{cell} subset r};
if #cellsInPerm >= #r then
(for cell in cells | not cellRange{cell} subset r)
restrict(cell, digitsUsed - r);
end;
end if;
end;
rngInv := {[d, cell]: cell in cells, d in cellRange{cell}};
rngDII := {[cells, d]: cells = rngInv{d}};
(for digits = rngDII{cells})
if #cells <= #digits and #digits < #digitsUsed then
(for cell in cells)
restrict(cell, digits);
end;
if #cells > 1 then
oCoords := {cellXY(cell)(oAxis): cell in cells};
paraPerms +:= {[[oAxis, oCoords, d], rcIdx]: d in digits};
end if;
end if;
end;
end proc;
proc ppBand(axis, oi);
case axis of
(1):
return [cellsByXY([oi, i]): i in [1..size]];
(2):
return [cellsByXY([i, oi]): i in [1..size]];
end case;
end proc;
proc applyParaPerms(rw changeFlag);
changeFlag ?:= false;
(for ppk in domain paraPerms)
ppi := paraPerms{[axis, oCoords, digit] := ppk};
if #ppi >= #oCoords then
changeFlag := true;
(for oi in oCoords)
band := ppBand(axis, oi);
(for cell = band(i) | i notin ppi)
restrict(cell, digitsUsed less digit);
end;
end;
paraPerms lessf:= ppk;
end;
end;
(for [ppk, aCoord] in paraPerms)
[axis, oCoords, digit] := ppk;
if exists oi in oCoords |
#cellRange{ppBand(axis, oi)(aCoord)} = 1 then
paraPerms lessf:= ppk;
end if;
end;
end proc;
proc refine();
changedCages +:= {} +/ {cagesByCell{c}: c in changedCells};
changedRows +:= {cellXY(c)(2): c in changedCells};
changedCols +:= {cellXY(c)(1): c in changedCells};
changedCells := {};
if exists y in changedRows | true then
isolateRCPerms(cellsByY{y}, y, 1);
changedRows less:= y;
elseif exists x in changedCols | true then
isolateRCPerms(cellsByX{x}, x, 2);
changedCols less:= x;
elseif exists gs in [1..size*size],
g in cagesBySize{gs} |
g in changedCages then
applyCageConstraint(g);
changedCages less:= g;
else
applyParaPerms(ppUsed);
if not is_smap cellRange then
$ No luck narrowing the cell range using the basic rules?
$ We must resort to a brute-force search.
if not ppUsed then
$ Choose an arbitrary cell, preferring cells with fewer possible values
crsm := {[#cellRange{cell}, cell]: cell in domain cellRange};
cell := arb crsm{min/ ((domain crsm) less 1)};
$ Arbitrarily choose a digit for this cell
if exists digit in cellRange{cell} | ok then
restrict(cell, {digit});
else
fail;
end if;
end if;
end if;
end if;
end proc;
proc setupBoard(size);
cellsByX := {};
cellsByY := {};
cellsByXY := {};
cellRange := {};
changedCells := {};
digitsUsed := {1..size};
(for x in digitsUsed, y in digitsUsed)
if [x,y] notin range cellXY then
cell := newat;
cellXY(cell) := [x, y];
end if;
end;
(for [cell, [x, y]] in cellXY)
cellsByXY([x, y]) := cell;
cellsByX{x} with:= cell;
cellsByY{y} with:= cell;
cellRange{cell} := digitsUsed;
changedCells with:= cell;
end;
end proc;
proc applyCageConstraint(cageNr);
[value, opSym, cells] := cages(cageNr);
case opSym of
('+', '-', '*', '/'):
restrictAll(cells, findCombs(opSym, opIdent{opSym}, value, cells, {}));
('?'):
a := operators - {'?', '='};
if #cells /= 2 then
a -:= {'-', '/'};
end if;
combs :=
{} +/ {findCombs(opSym, opIdent{opSym}, value, cells, {}): opSym in a};
restrictAll(cells, combs);
('='):
(for cell in cells)
restrict(cell, {value});
end;
end case;
end proc;
proc restrictAll(cells, cvms);
cvm := {} +/ cvms;
(for cell in cells)
restrict(cell, cvm{cell});
end;
end proc;
proc restrict(cell, ub);
oldRange := cellRange{cell};
newRange := oldRange * ub;
cellRange{cell} := newRange;
if newRange /= oldRange then
changedCells with:= cell;
result := true;
end if;
if #newRange = 0 then
fail;
end if;
end proc;
proc adjust(sum, opSym, trm);
result := {};
case opSym of
('+'):
return {x in {sum - trm} | x >= 0};
('-'):
return {x in {trm + sum, trm - sum} | x >= 0};
('*'):
return {x in {sum div trm} | sum mod trm = 0};
('/'):
return {x in {trm div sum} | trm mod sum = 0} with (trm * sum);
end case;
end proc;
proc findCombs(opSym, identities, value, cells, part);
if #cells > 0 then
result := {};
nextCell := arb cells;
(for ncv in cellRange{nextCell},
newVal in adjust(value, opSym, ncv))
result +:=
{c in findCombs(opSym,
identities,
newVal,
cells less nextCell,
part with [nextCell, ncv]) |
conflictFree(c) and
sufficient(opSym, newVal, cells less nextCell)};
end;
elseif value in identities and conflictFree(part) then
result := {part};
else
result := {};
end if;
$print('findCombs returning', result, 'for', opSym, identities, value, cells, part);
return result;
end proc;
proc sufficient(opSym, value, cells);
case opSym of
('+'):
result := 0 +/ [0 max/ cellRange{cell}: cell in cells] >= value;
('*'):
result := 1 */ [1 max/ cellRange{cell}: cell in cells] >= value;
else
result := true;
end;
$print('sufficient returning', result, 'for', opSym, value, cells);
return result;
end;
proc conflictFree(cvm);
result := is_smap({[[d, cellXY(c)(1)], cellXY(c)(2)]: [c, d] in cvm}) and
is_smap({[[d, cellXY(c)(2)], cellXY(c)(1)]: [c, d] in cvm});
$print('conflictFree returning', result, 'for', cvm);
return result;
end proc;
end program;
Input format:
The input is a text file. The first line contains the grid size/largest digit used. Each subsequent line contains a cage constraint in the following format:
[ value operator {[x1 y1] [x2 y2] ...}]
Where value is the sum/product etc. of the digits in the cage and (x1,y1), (x2,y2) are the coordinates of cells in the cage and operator is the operator to apply (+, -, * or / for known operators, ? to represent an unknown operator or = if the value is simply the digit that goes in the cell.)
Example:
6
[ 11 '+' {[1 1] [1 2]}]
[ 2 '/' {[2 1] [3 1]}]
[ 20 '*' {[4 1] [4 2]}]
[ 6 '*' {[5 1] [6 1] [6 2] [6 3]}]
[ 3 '-' {[2 2] [3 2]}]
[ 3 '/' {[5 2] [5 3]}]
[240 '*' {[1 3] [2 3] [1 4] [2 4]}]
[ 6 '*' {[3 3] [4 3]}]
[ 6 '*' {[3 4] [3 5]}]
[ 7 '+' {[4 4] [4 5] [5 5]}]
[ 30 '*' {[5 4] [6 4]}]
[ 6 '*' {[1 5] [2 5]}]
[ 9 '+' {[6 5] [6 6]}]
[ 8 '+' {[1 6] [2 6] [3 6]}]
[ 2 '/' {[4 6] [5 6]}]
The above file represents the puzzle on the Wikipedia page:
If it is saved as "puzzle1.txt" then the program would be invoked with:
setl kenken.stl -- puzzle1.txt
Notes:
- Uses backtracking. No currently-available stable SETL implementation supports backtracking.
- Tested under fcsetl, which is pre-alpha but has just enough functionality to allow it to run this program.
