KenKen Solver
From the SETL Wiki
There is now an online demo of this program. Unfortunately this has been taken down as the virtual machine that hosts this site did not have enough CPU capacity.
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.
