МегаМодератор
СуперМодератор
Регистрация: 09.11.2010
Сообщений: 7,285
|
Код:
uses
crt, graph;
const
n = 2;
n1 = 4;
size = 4;
quadsize = 16;
type
gamearray = array[0..15] of integer;
var
d, m, z: integer;
a: gamearray;
ch: char;
function checksolvable: boolean;
var
i, j, sum: integer;
begin
sum := 0;
for i := 0 to 14 do
if a[i] = 0 then sum := sum + i div 4 + 1
else
for j := i + 1 to 15 do
if a[j] < a[i] then inc(sum);
if sum mod 2 = 0 then checksolvable := true
else
checksolvable := false;
end;
function creategamearray: integer;
var
i, k, zero: integer;
s: set of byte;
begin
repeat
s := [];
for i := 0 to 15 do
begin
repeat
k := random(16);
until not (k in s );
a[i] := k;
if k = 0 then zero := i;
s := s + [k];
end;
until checksolvable;
creategamearray := zero;
{for i:=0 to 13 do
a[i]:=i+1;
a[14]:=0;
a[15]:=15;
creategamearray:=14;}
end;
procedure drawall;
var
i, x, y: integer;
s: string;
begin
setcolor(7);
for i := 0 to size do
begin
line(120 - 1, 40 + i * 100 - 1, 520 - 1, 40 + i * 100 - 1);
line(120 + i * 100 - 1, 40 - 1, 120 + i * 100 - 1, 440 - 1);
end;
for i := 0 to 15 do
if a[i] <> 0 then
begin
str(a[i], s);
x := 170 + 100 * (i mod size) - 1;
y := 90 + 100 * (i div size) - 1;
outtextxy(x - textwidth(s) div 2, y - textheight(s) div 2, s);
end;
end;
procedure square(pos, color: integer);
var
x, y: integer;
s: string;
begin
x := 170 + 100 * (pos mod size) - 1;
y := 90 + 100 * (pos div size) - 1;
setcolor(color);
bar(x - 40, y - 40, x + 40, y + 40);
rectangle(x - 40, y - 40, x + 40, y + 40);
setcolor(7);
if a[pos] <> 0 then
begin
str(a[pos], s);
outtextxy(x - textwidth(s) div 2, y - textheight(s) div 2, s);
end;
end;
procedure swap(var p1, p2: integer; p3: integer);
begin
a[p1] := a[p2];
a[p2] := 0;
p1 := p2;
square(p2, 0);
p2 := p2 + p3;
end;
function equal(a: gamearray): boolean;
var
i: integer;
begin
i := 0;
while (a[i] = i + 1) and (i < quadsize - 1) do
inc(i);
if i < quadsize - 1 then
equal := false
else
equal := true;
end;
procedure game;
var
z, zero: integer;
t, win: boolean;
begin
cleardevice;
setfillstyle(0, 0);
settextstyle(1, 1, n1);
setcolor(4);
outtextxy(10, 240 - textwidth('15-Puzzle') div 2, '15-Puzzle');
settextstyle(1, 0, n1);
randomize;
zero := creategamearray;
drawall;
z := 0;
win := false;
t := false;
square(z, 10);
repeat
repeat
ch := readkey;
if t then
begin
if (ch = #80) and (z + size = zero) then
swap(zero, z, size)
else
if (ch = #72) and (z - size = zero) then
swap(zero, z, -size)
else
if (ch = #75) and (z - 1 = zero) then
swap(zero, z, -1)
else
if (ch = #77) and (z + 1 = zero) then
swap(zero, z, 1);
square(z, 6);
end
else
begin
square(z, 0);
if ch = #80 then z := z + size else
if ch = #72 then z := z - size else
if ch = #75 then dec(z) else
if ch = #77 then inc(z);
square(z, 10);
end;
z := (z mod quadsize + quadsize) mod quadsize;
until (ch = #13) or (ch = #27);
if ch = #13 then
t := not t;
if t then
square(z, 6)
else
square(z, 10);
if equal(a) then
win := true;
until (ch = #27) or win;
if win then
begin
setcolor(4);
settextstyle(1, 0, 9);
outtextxy(320 - textwidth('WIN') div 2 - 1, 240 - textheight('WIN') div 2 - 1, 'WIN');
readln;
end;
end;
procedure action(i: integer);
begin
case i of
1: game;
0: halt;end;
ch := #0;
end;
procedure menu(i: integer; t: boolean);
var
a: byte;
begin
setbkcolor(0);
if t then cleardevice;
settextstyle(1, 0, n1);
setcolor(4);
outtextxy((getmaxx - textwidth('15-Puzzle')) div 2, 10 * n1, '15-Puzzle');
setcolor(7);
outtextxy((getmaxx - textwidth('new game')) div 2, 20 * n1, 'new game');
outtextxy((getmaxx - textwidth('exit')) div 2, 30 * n1, 'exit');
setcolor(10);
case i of
1: outtextxy((getmaxx - textwidth('new game')) div 2, 20 * n1, 'new game');
0: outtextxy((getmaxx - textwidth('exit')) div 2, 30 * n1, 'exit');
end;
end;
begin
d := detect;
m := 2;
initgraph(d, m, 'c:\bp\');
z := 1;
menu(z, false);
repeat
repeat
ch := readkey;
if ch = #80 then inc(z) else
if ch = #72 then dec(z);
z := (z mod n + n) mod n;
menu(z, false);
until (ch = #13) or (ch = #27);
if ch = #13 then
action(z);
menu(z, true);
until ch = #27;
end.
Вот сильно недоделанный код.
Пока только подготавливает массив, рисует поле и двигает рамку.
УПД Заменил код на полностью рабочий.
Теперь можно играть
Правда, пока не смог честно выиграть.
Пишите язык программирования - это форум программистов, а не экстрасенсов. (<= это подпись )
Последний раз редактировалось BDA; 06.06.2012 в 19:26.
|