program sudoku; const DIGITS = ['1'..'9']; type Check = array[1..9] of boolean; Field = array[0..8, 0..8] of record q: Check; n: integer end; Squares = array[0..2, 0..2] of Check; Lines = array[0..8] of Check; Rows = array[0..8] of Check; var data: field; sq: Squares; ln: Lines; rw: Rows; procedure print(data: Field); var i, j: integer; begin for i := 0 to 8 do begin for j := 0 to 8 do write(data[i, j].n, #9); writeln end; readln end; procedure init(var data: Field; var sq: Squares; var rw: Rows; var ln: Lines); var i, j, d: integer; begin for i := 0 to 8 do for j := 0 to 8 do begin data[i, j].n := 0; for d := 1 to 9 do begin data[i, j].q[d] := true; ln[i][d] := true; rw[j][d] := true; sq[i div 3, j div 3][d] := true end; end; end; procedure update(var data: Field; var sq: Squares; var rw: Rows; var ln: Lines; x, y: integer; num: integer); var i, j, d: integer; begin data[x, y].n := num; ln[x][num] := false; rw[y][num] := false; sq[x div 3, y div 3][num] := false; for d := 1 to 9 do data[x, y].q[d] := false; for i := 0 to 8 do for j := 0 to 8 do for d := 1 to 9 do data[i, j].q[d] := data[i, j].q[d] and ln[i][d] and rw[j][d] and sq[i div 3, j div 3][d] end; procedure load(var data: Field; var sq: Squares; var rw: Rows; var ln: Lines); var c: char; i, j: integer; loadfile: text; begin init(data, sq, rw, ln); assign(loadfile, 'input'); reset(loadfile); for i := 0 to 8 do begin for j := 0 to 8 do begin read(loadfile, c); if c in DIGITS then update(data, sq, rw, ln, i, j, ord(c) - ord('0')) end; readln(loadfile) end; close(loadfile) end; function findMinimal(var x, y: integer; data: Field): boolean; var i, j, d, weight, min: integer; begin x := -1; y := -1; min := 10; for i := 0 to 8 do for j := 0 to 8 do begin weight := 0; for d := 1 to 9 do if data[i, j].q[d] then weight := weight + 1; if (weight < min) and (weight <> 0) then begin min := weight; x := i; y := j end end; findMinimal := min <> 10 end; function existZero(data: Field): boolean; var i, j: integer; begin existZero := false; for i := 0 to 8 do for j := 0 to 8 do if data[i, j].n = 0 then begin existZero := true; exit end end; procedure findSolutions(data: Field; sq: Squares; rw: Rows; ln: Lines); var x, y, d: integer; cd: Field; cs: Squares; cr: Rows; cl: Lines; begin if findMinimal(x, y, data) then begin for d := 1 to 9 do if data[x, y].q[d] then begin cd := data; cs := sq; cr := rw; cl := ln; update(cd, cs, cr, cl, x, y, d); findSolutions(cd, cs, cr, cl) end end else if not existZero(data) then print(data) end; begin load(data, sq, rw, ln); findSolutions(data, sq, rw, ln) end.