Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Паскаль, Turbo Pascal, PascalABC.NET
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 06.06.2012, 00:14   #11
BDA
МегаМодератор
СуперМодератор
 
Аватар для BDA
 
Регистрация: 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.
BDA на форуме Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Написать программу, которая считывает текст из файла и выводит на экран только строки, содержащие двузначные числа FredPerry Паскаль, Turbo Pascal, PascalABC.NET 1 26.05.2012 08:17
функция получае на вход строку чисел, выводит строку символов DellOleg Microsoft Office Access 2 18.02.2012 11:17
Почему выводит строку 2 раза?!?!?! Dasharnb777 Assembler - Ассемблер (FASM, MASM, WASM, NASM, GoASM, Gas, RosAsm, HLA) и не рекомендуем TASM 2 17.11.2010 11:06
printf выводит только два %s(строки) Mal4ishnik PHP 1 13.10.2009 00:01
passthru выводит только одну строку motorway PHP 5 07.07.2009 21:27