Program Sudoku;
uses Crt, Myunit2;
type
arr = array [1 .. 9, 1 .. 9] of char;
var
ch: char;
A, D: arr;
base: file of arr;
F: file of char;
i, j: 1 .. 9;
Name: string;
x, y: byte;
Line1, Line2: byte;
ex: 1 .. 9;
g: byte;
err: integer;
Color: file of byte;
Color1, Color2: byte;
Procedure Pole1;
var
x, y, z: integer;
begin
Textcolor(Green);
Textbackground(Color1);
window(1, 1, 80, 25);
ClrScr;
if Color1 <> Color2 then
begin
Textbackground(Color2);
GoToXY(WhereX + 13, WhereY + 3);
for x := 1 to 18 do
begin
for y := 1 to 54 do
write(chr(32));
GoToXY(WhereX - 54, WhereY + 1);
end;
GoToXY(1, 1);
end;
GoToXY(WhereX + 12, WhereY + 3);
write(chr(201));
for x := 1 to 8 do
begin
for y := 1 to 5 do
write(chr(205));
write(chr(203));
end;
for y := 1 to 5 do
write(chr(205));
write(chr(187));
for x := 1 to 8 do
begin
GoToXY(WhereX - 55, WhereY + 1);
for y := 1 to 9 do
begin
write(chr(186));
GoToXY(WhereX + 5, WhereY);
end;
write(chr(186));
GoToXY(WhereX - 55, WhereY + 1);
write(chr(204));
for y := 1 to 8 do
begin
for z := 1 to 5 do
write(chr(205));
write(chr(206));
end;
for z := 1 to 5 do
write(chr(205));
write(chr(185));
end;
GoToXY(WhereX - 55, WhereY + 1);
for x := 1 to 9 do
begin
write(chr(186));
GoToXY(WhereX + 5, WhereY);
end;
write(chr(186));
GoToXY(WhereX - 55, WhereY + 1);
write(chr(200));
for x := 1 to 8 do
begin
for y := 1 to 5 do
write(chr(205));
write(chr(202));
end;
for x := 1 to 5 do
write(chr(205));
write(chr(188));
GoToXY(WhereX - 52, WhereY - 17);
end;
Procedure Pole2;
var
x, y, z: integer;
Procedure Line;
var
x, y, z: integer;
begin
for x := 1 to 8 do
begin
write(chr(32));
GoToXY(WhereX - 1, WhereY + 1);
write(chr(205));
GoToXY(WhereX - 1, WhereY + 1);
end;
write(chr(32));
end;
begin
Textbackground(Blue);
GoToXY(WhereX - 3, WhereY - 1);
write(chr(201));
for x := 1 to 8 do
begin
for y := 1 to 5 do
write(chr(205));
write(chr(203));
end;
for x := 1 to 5 do
write(chr(205));
write(chr(187));
for x := 1 to 8 do
begin
GoToXY(WhereX - 1, WhereY + 1);
write(chr(186));
GoToXY(WhereX - 1, WhereY + 1);
write(chr(185));
end;
GoToXY(WhereX - 1, WhereY + 1);
write(chr(186));
GoToXY(WhereX - 1, WhereY + 1);
write(chr(188));
GoToXY(WhereX - 2, WhereY);
for x := 1 to 8 do
begin
for y := 1 to 5 do
begin
write(chr(205));
GoToXY(WhereX - 2, WhereY);
end;
write(chr(202));
GoToXY(WhereX - 2, WhereY);
end;
for x := 1 to 5 do
begin
write(chr(205));
GoToXY(WhereX - 2, WhereY);
end;
write(chr(200));
for x := 1 to 8 do
begin
GoToXY(WhereX - 1, WhereY - 1);
write(chr(186));
GoToXY(WhereX - 1, WhereY - 1);
write(chr(204));
end;
GoToXY(WhereX - 1, WhereY - 1);
write(chr(186));
GoToXY(WhereX, WhereY + 5);
for x := 1 to 2 do
begin
for y := 1 to 8 do
begin
for z := 1 to 5 do
write(chr(205));
write(chr(206));
end;
for y := 1 to 5 do
write(chr(205));
GoToXY(WhereX - 53, WhereY + 6)
end;
GoToXY(WhereX + 17, WhereY - 17);
for x := 1 to 2 do
begin
for y := 1 to 8 do
begin
write(chr(186));
GoToXY(WhereX - 1, WhereY + 1);
write(chr(206));
GoToXY(WhereX - 1, WhereY + 1);
end;
write(chr(186));
GoToXY(WhereX + 17, WhereY - 16);
end;
GoToXY(WhereX - 55, WhereY - 1);
for x := 1 to 19 do
begin
write(chr(32));
GoToXY(WhereX - 1, WhereY + 1);
end;
GoToXY(WhereX + 56, WhereY - 19);
for x := 1 to 19 do
begin
write(chr(32));
GoToXY(WhereX - 1, WhereY + 1);
end;
GoToXY(WhereX - 54, WhereY - 18);
Line;
for x := 1 to 2 do
begin
GoToXY(WhereX + 15, WhereY - 16);
Line;
GoToXY(WhereX + 1, WhereY - 16);
Line;
end;
GoToXY(WhereX + 15, WhereY - 16);
Line;
Textbackground(Color2);
end;
Procedure Screen(var Name: string);
begin
Textbackground(Color1);
window(1, 1, 80, 25);
ClrScr;
wind(4, 2, 77, 4);
Textbackground(Color1);
ClrScr;
write('‚ўҐ¤ЁвҐ Їгвм Є д ©«г: ');
Textcolor(White);
Readln(Name);
end;
Procedure Load;
begin
if (Name[1] = '/') or (Pos('base.sdl', name) <> 0) then
begin
val(copy(Name, Pos('#', Name) + 1, length(Name)), g, err);
Seek(base, g - 1);
read(base, A)
end
else
begin
Assign(F, Name);
Reset(F);
for i := 1 to 9 do
for j := 1 to 9 do
read(F, A[i, j]);
Close(F)
end;
D := A
end;
Function Check(i, j: byte; ch: char; lines: boolean): boolean;
label 1, 2;
var
bool: boolean;
x, y, x1, y1: 1 .. 9;
begin
bool := FALSE;
for x := 1 to 9 do
if (ch = A[x, j]) and (i <> x) then
goto 1;
for y := 1 to 9 do
if (ch = A[i, y]) and (j <> y) then
goto 1;
if lines then
goto 2;
case i of
1 .. 3:
x1 := 1;
4 .. 6:
x1 := 4;
7 .. 9:
x1 := 7;
end;
case j of
1 .. 3:
y1 := 1;
4 .. 6:
y1 := 4;
7 .. 9:
y1 := 7;
end;
for x := x1 to x1 + 2 do
for y := y1 to y1 + 2 do
if (ch = A[x, y]) and (i <> x) and (j <> y) then
goto 1;
2:
bool := TRUE;
1:
Check := bool;
end;
Procedure Create;
var
F: File of char;
i, j: 1 .. 9;
x, y: byte;
Line: byte;
begin
Line := 0;
Pole1;
x := WhereX;
y := WhereY;
Pole2;
GoToXY(x, y);
Textcolor(Yellow);
for i := 1 to 9 do
for j := 1 to 9 do
A[i, j] := chr(32);
i := 1;
j := 1;
repeat
ch := ReadKey;
Case ch of
#75:
if j <> 1 then
begin
GoToXY(WhereX - 6, WhereY);
j := j - 1;
end;
#77:
if j <> 9 then
begin
GoToXY(WhereX + 6, WhereY);
j := j + 1;
end;
#72:
if i <> 1 then
begin
GoToXY(WhereX, WhereY - 2);
i := i - 1;
end;
#80:
if i <> 9 then
begin
GoToXY(WhereX, WhereY + 2);
i := i + 1;
end;
#48:
begin
write(chr(32));
A[i, j] := chr(32);
GoToXY(WhereX - 1, WhereY);
end;
'1' .. '9':
if Check(i, j, ch, FALSE) then
begin
A[i, j] := ch;
write(ch);
GoToXY(WhereX - 1, WhereY);
end;
#27:
begin
Textbackground(Color1);
ClrScr;
repeat
wind(4, 2, 21, 5);
write('‘®еа Ёвм Є Є...');
write('ЌҐ б®еа пвм');
menu(Line, 2, 1);
case Line of
1:
begin
Screen(Name);
if length(Name) <> 0 then
if Name[1] = '/' then
begin
val(copy(Name, Pos('#', Name) + 1, length(Name)), g, err);
Seek(base, g - 1);
write(base, A)
end
else
begin
if Pos('.', Name) = 0 then
Name := Name + '.sud';
Assign(F, Name);
Rewrite(F);
for i := 1 to 9 do
for j := 1 to 9 do
write(F, A[i, j]);
Close(F);
end;
Line := 2;
end;
end;
until Line = 2;
end;
end;
until Line = 2;
ClrScr;
end;
Procedure Edit;
var
F: File of char;
i, j: 1 .. 9;
x, y: byte;
Line: byte;
begin
Line := 0;
Screen(Name);
if length(Name) <> 0 then
begin
if (Name[1] <> '/') and (Pos('.', Name) = 0) then
Name := Name + '.sud';
Pole1;
x := WhereX;
y := WhereY;
Pole2;
GoToXY(x, y);
Load;
Textcolor(Yellow);
for i := 1 to 9 do
begin
for j := 1 to 9 do
begin
write(A[i, j]);
GoToXY(WhereX + 5, WhereY);
end;
GoToXY(WhereX - 54, WhereY + 2);
end;
GoToXY(WhereX, WhereY - 18);
Textcolor(White);
Textcolor(Yellow);
i := 1;
j := 1;
repeat
ch := ReadKey;
Case ch of
#75:
if j <> 1 then
begin
GoToXY(WhereX - 6, WhereY);
j := j - 1;
end;
#77:
if j <> 9 then
begin
GoToXY(WhereX + 6, WhereY);
j := j + 1;
end;
#72:
if i <> 1 then
begin
GoToXY(WhereX, WhereY - 2);
i := i - 1;
end;
#80:
if i <> 9 then
begin
GoToXY(WhereX, WhereY + 2);
i := i + 1;
end;
#48:
begin
write(chr(32));
A[i, j] := chr(32);
GoToXY(WhereX - 1, WhereY);
end;
'1' .. '9':
if Check(i, j, ch, FALSE) then
begin
A[i, j] := ch;
write(ch);
GoToXY(WhereX - 1, WhereY);
end;
#27:
begin
Textbackground(Color1);
ClrScr;
repeat
wind(4, 2, 18, 5);
write('‘®еа Ёвм ўбс');
write('ЌҐ б®еа пвм');
menu(Line, 2, 1);
case Line of
1:
begin
Textbackground(Color1);
window(1, 1, 80, 25);
ClrScr;
if Name[1] = '/' then
begin
Seek(base, g - 1);
write(base, A)
end
else
begin
Assign(F, Name);
Rewrite(F);
for i := 1 to 9 do
for j := 1 to 9 do
write(F, A[i, j]);
Close(F);
end;
Line := 2;
end;
end;
until Line = 2;
end;
end;
until Line = 2;
ClrScr;
end;
end;
Procedure SaveGame(NameSaveFile, NameFile: string);
var
p: byte;
S: char;
begin
Assign(F, NameSaveFile);
Rewrite(F);
if (Pos('/', NameFile) <> 0) and (Pos('base.sdl', NameFile) = 0) then
NameFile := 'base.sdl' + NameFile;
while length(NameFile) < 12 do
NameFile := chr(32) + NameFile;
for p := 1 to length(NameFile) do
write(F, NameFile[p]);
S := chr(58);
write(F, S);
S := chr(32);
for i := 1 to 9 do
for j := 1 to 9 do
if D[i, j] = S then
write(F, A[i, j])
else
write(F, S);
Close(F);
end;
Procedure SaveGameAs;
var
FileName: string;
begin
Screen(FileName);
if (Pos('.', FileName) = 0) and (length(FileName) <> 0) then
FileName := FileName + '.sav';
if length(FileName) <> 0 then
SaveGame(FileName, Name);
end;
Procedure Play;
var
Line: byte;
Message: boolean;
label 1, 2;
Function Checking: boolean;
label 1;
var
i, j: 1 .. 9;
x, y: 1 .. 9;
bool: boolean;
Procedure ErrorMessage;
begin
x := WhereX;
y := WhereY;
GoToXY(61, 24);
Textbackground(Color1);
Textcolor(White + Blink);
write('ђҐиҐЁҐ Ґ ўҐа®!');
Textbackground(Color2);
GoToXY(x, y);
Textcolor(White);
Message := TRUE;
end;
begin
bool := TRUE;
for i := 1 to 9 do
for j := 1 to 9 do
if A[i, j] = chr(32) then
begin
if Message then
begin
x := WhereX;
y := WhereY;
GoToXY(1, 24);
Textbackground(Color1);
DelLine;
GoToXY(x, y);
Textbackground(Color2);
Message := FALSE;
end;
bool := FALSE;
goto 1;
end;
for i := 1 to 9 do
for j := 1 to 9 do
begin
for x := 1 to 9 do
if (x <> i) and (A[x, j] = A[i, j]) then
begin
bool := FALSE;
ErrorMessage;
goto 1;
end;
for y := 1 to 9 do
if (y <> j) and (A[i, y] = A[i, j]) then
begin
bool := FALSE;
ErrorMessage;
goto 1;
end;
end;
1:
Checking := bool;
end;
Procedure Player;
var
x1, y1: 1 .. 3;
i1, j1: 1 .. 9;
ins1, ins2, ins3, ins4: boolean;
k: 0 .. 9;
begin
ins1 := TRUE;
while ins1 do
begin
ins1 := FALSE;
for x1 := 1 to 3 do
begin
case x1 of
1:
i1 := 1;
2:
i1 := 4;
3:
i1 := 7
end;
for y1 := 1 to 3 do
begin
case y1 of
1:
j1 := 1;
2:
j1 := 4;
3:
j1 := 7
end;
ins3 := TRUE;
while ins3 do
ins3 := FALSE;
begin
for ch := '1' to '9' do
begin
ins2 := FALSE;
for i := i1 to i1 + 2 do
for j := j1 to j1 + 2 do
if A[i, j] = ch then
ins2 := TRUE;
if not ins2 then
begin
k := 0;
for i := i1 to i1 + 2 do
for j := j1 to j1 + 2 do
if (A[i, j] = chr(32)) and Check(i, j, ch, TRUE) then
k := k + 1;
if k = 1 then
for i := i1 to i1 + 2 do
for j := j1 to j1 + 2 do
if (A[i, j] = chr(32)) and Check(i, j, ch, TRUE) then
begin
ins1 := TRUE;
ins3 := TRUE;
A[i, j] := ch
end;
end;
end;
end;
end;
end;
ins1 := FALSE;
for i := 1 to 9 do
for j := 1 to 9 do
if A[i, j] = chr(32) then
begin
ins4 := FALSE;
for ch := '1' to '9' do
if Check(i, j, ch, FALSE) and not ins4 then
begin
A[i, j] := ch;
ins4 := TRUE
end
else if Check(i, j, ch, FALSE) and ins4 then
A[i, j] := chr(32);
if A[i, j] <> chr(32) then
ins1 := TRUE;
end;
end;
for i := 1 to 9 do
begin
for j := 1 to 9 do
begin
if D[i, j] = chr(32) then
begin
write(A[i, j]);
GoToXY(WhereX - 1, WhereY);
end;
GoToXY(WhereX + 6, WhereY);
end;
GoToXY(WhereX - 54, WhereY + 2);
end;
GoToXY(WhereX + 48, WhereY - 2);
end;
begin
1:
Message := FALSE;
i := 1;
j := 1;
repeat
if Checking then
begin
x := WhereX;
y := WhereY;
GoToXY(40, 24);
Textbackground(Color1);
Textcolor(Blink + White);
write('ђҐиҐЁҐ ўҐа®! Ќ ¦¬ЁвҐ «оЎго Є« ўЁиг...');
GoToXY(x, y);
ReadKey;
goto 2;
end
else
ch := ReadKey;
Case ch of
#75:
if j <> 1 then
begin
GoToXY(WhereX - 6, WhereY);
j := j - 1;
end;
#77:
if j <> 9 then
begin
GoToXY(WhereX + 6, WhereY);
j := j + 1;
end;
#72:
if i <> 1 then
begin
GoToXY(WhereX, WhereY - 2);
i := i - 1;
end;
#80:
if i <> 9 then
begin
GoToXY(WhereX, WhereY + 2);
i := i + 1;
end;
#48:
if D[i, j] = chr(32) then
begin
A[i, j] := chr(32);
write(chr(32));
GoToXY(WhereX - 1, WhereY);
end;
'1' .. '9':
if (D[i, j] = chr(32)) then
begin
A[i, j] := ch;
write(ch);
GoToXY(WhereX - 1, WhereY);
end;
#13:
begin
A := D;
GoToXY(16, 5);
Player;
GoToXY(16, 5);
goto 1;
end;
end;
until ch = #27;
Textbackground(Color1);
ClrScr;
repeat
wind(4, 2, 21, 6);
writeln('‘®еа Ёвм');
write('‘®еа Ёвм Є Є...');
write('ЌҐ б®еа пвм');
menu(Line, 3, 1);
case Line of
1:
begin
SaveGame('lg.sav', Name);
Line := 3;
end;
2:
begin
SaveGameAs;
Line := 3;
end;
end;
until Line = 3;
2:
window(1, 1, 80, 25);
Textbackground(Color1);
ClrScr;
end;
Procedure PlayGame;
begin
Pole1;
x := WhereX;
y := WhereY;
Pole2;
GoToXY(x, y);
Load;
Textcolor(Yellow);
for i := 1 to 9 do
begin
for j := 1 to 9 do
begin
write(A[i, j]);
GoToXY(WhereX + 5, WhereY);
end;
GoToXY(WhereX - 54, WhereY + 2);
end;
GoToXY(WhereX, WhereY - 18);
Textcolor(White);
Play;
end;
Procedure LoadGame(FileName: string);
var
LoadFile: File of char;
S: char;
begin
Assign(LoadFile, FileName);
Reset(LoadFile);
Name := '';
Read(LoadFile, S);
while S = chr(32) do
read(LoadFile, S);
repeat
Name := Name + S;
Read(LoadFile, S);
until S = chr(58);
Pole1;
x := WhereX;
y := WhereY;
Pole2;
GoToXY(x, y);
Load;
for i := 1 to 9 do
begin
for j := 1 to 9 do
begin
read(LoadFile, S);
if A[i, j] <> chr(32) then
begin
Textcolor(Yellow);
write(A[i, j]);
end
else
begin
A[i, j] := S;
Textcolor(White);
write(A[i, j]);
end;
GoToXY(WhereX + 5, WhereY);
end;
GoToXY(WhereX - 54, WhereY + 2);
end;
GoToXY(WhereX, WhereY - 18);
Textcolor(White);
Close(LoadFile);
Play;
end;
Procedure Game(g: integer);
var
A, b: byte;
Line: byte;
i: byte;
begin
case g of
1:
begin
A := 1;
b := 16;
end;
2:
begin
A := 17;
b := 36;
end;
3:
begin
A := 37;
b := 56;
end;
4:
begin
A := 57;
b := 72;
end;
5:
begin
A := 73;
b := 84;
end;
6:
begin
A := 85;
b := 93;
end;
end;
Textbackground(Color1);
window(1, 1, 80, 25);
ClrScr;
repeat
wind(4, 2, 15, b - A + 5);
for i := A to b do
if i - A + 1 < 10 then
write('‚ аЁ в 0', i - A + 1)
else
write('‚ аЁ в ', i - A + 1);
write('Ќ § ¤');
menu(Line, b - A + 2, 1);
if Line <> b - A + 2 then
begin
str(Line + A - 1, Name);
if length(Name) < 2 then
Name := '0' + Name;
Name := '/#' + Name;
PlayGame;
end;
until Line = b - A + 2;
Textbackground(Color1);
window(1, 1, 80, 25);
ClrScr;
end;
Procedure Reader(FileName: string);
var
F: text;
ch: char;
begin
Assign(F, FileName);
Reset(F);
while not eof(F) do
begin
read(F, ch);
write(ch);
end;
ReadKey;
Close(F);
end;
Procedure Colors;
var
Line: byte;
Procedure Select;
var
Sel: byte;
begin
wind(4, 2, 21, 12);
repeat
writeln('—сал©');
writeln('’с¬®-бЁЁ©');
writeln('’с¬®-§Ґ«сл©');
writeln('ЃЁаўл©');
writeln('Ља бл©');
writeln('”Ё®«Ґв®ўл©');
writeln('Љ®аЁзҐўл©');
writeln('‘ўҐв«®-бҐал©');
write('Ћв¬Ґ ');
menu(Sel, 9, 1);
if Sel < 9 then
case Line of
1:
begin
Color1 := Sel - 1;
Seek(Color, 0);
write(Color, Color1);
Sel := 9
end;
2:
begin
Color2 := Sel - 1;
write(Color, Color2);
Sel := 9
end
end;
until Sel = 9;
window(1, 1, 80, 25);
Textbackground(Color1);
ClrScr
end;
begin
window(4, 2, 46, 11);
Textbackground(Color1);
ClrScr;
Textcolor(Yellow);
ClrScr;
repeat
wind(4, 2, 17, 7);
writeln('–ўҐв д® ');
writeln('–ўҐв п祩ЄЁ');
write('Џ® 㬮«з Ёо');
write('‚л©вЁ');
menu(Line, 4, 1);
case Line of
1, 2:
Select;
3:
begin
Color1 := Blue;
Color2 := Magenta;
Seek(Color, 0);
write(Color, Color1, Color2);
Line := 4
end
end
until Line = 4 end;
{ ----------- }
begin
writeln('26***');
Assign(base, 'base.sdl');
Reset(base);
Assign(Color, 'Sudoku.set');
Reset(Color);
Read(Color, Color1, Color2);
Textbackground(Blue);
Textcolor(White);
ClrScr;
Reader('SUDOKU');
repeat { repeat 1 }
window(1, 1, 80, 25);
Textbackground(Color1);
ClrScr;
wind(4, 2, 46, 11);
writeln('Варианты новой игры');
writeln('Загрузить ранее сохранённую игру');
write('Загрузить ранее сохранённую игру из файла');
writeln('Создать новый вариант игры');
writeln('Редактировать вариант игры');
writeln('Цветовая конфигурация');
writeln('Об игре');
write('Выход');
menu(Line1, 8, 1);
case Line1 of
1:
begin
window(4, 2, 46, 11);
Textbackground(Color1);
ClrScr;
repeat
wind(4, 2, 18, 11);
writeln('Лёгкие');
writeln('Средние');
writeln('Сложные');
write('Очень сложные');
writeln('Суперсложные');
writeln('Разные');
writeln('Другие');
write('Главное меню');
menu(Line2, 8, 1);
case Line2 of
1 .. 6:
Game(Line2);
7:
begin
Screen(Name);
if (Name[1] <> '/') and (Pos('.', Name) = 0) and
(length(Name) <> 0) then
Name := Name + '.sud';
if length(Name) <> 0 then
PlayGame
else
ClrScr;
end;
end; { case Line2 }
until Line2 = 8;
end;
2:
LoadGame('lg.sav');
3:
begin
Screen(Name);
if (Name[1] <> '/') and (Pos('.', Name) = 0) and (length(Name) <> 0)
then
Name := Name + '.sav';
if length(Name) <> 0 then
LoadGame(Name)
else
ClrScr;
end;
4:
Create;
5:
Edit;
6:
Colors;
7:
begin
window(1, 1, 80, 25);
Textbackground(Color1);
ClrScr;
Reader('INFORM');
end;
end; { case Line1 of }
until Line1 = 8; { repeat }
window(1, 1, 80, 25);
Textcolor(LightGray);
Textbackground(Color1);
ClrScr;
Close(base)
end.