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.