Как найти игру на паскале

К оглавлению | Назад | Вперёд

Все программы, код которых выложен здесь, являются работоспособными. Ниже приведены возможные варианты реализации игр «Крестики-нолики» и «Змейка» на PascalABC.Net 3.0.

Крестики-нолики[править]

Управление:

• Левая кнопка мыши — установить крестик/нолик.

uses GraphABC;
const
  N = 2;
  Z = '0';
  K = 'X';
  Size = 200;
  Border = 1;
  Sx = 1200;
  Sy = 70;

var
  Matrix: array [0..N, 0..N] of char;
  Player1: boolean;

procedure Draw();
  procedure DrawZ(i, j: integer);
  begin
    SetPenColor(clCyan);
    SetPenWidth(4);
    var size2 := Size div 2;
    DrawCircle((i + 1) * Size - size2, (j + 1) * Size - size2, Round(size2 * 0.7));
  end;
  
  procedure DrawK(i, j: integer);
    procedure RLine(x, y, x1, y1: real):=Line(Round(x), Round(y), Round(x1), Round(y1));

  begin
    SetPenColor(clPink);
    SetPenWidth(4);
    var size2 := Size div 2 * 0.3;
    var cx1 := i * Size + size2;
    var cy1 := j * Size + size2;
    var cx2 := (i + 1) * Size - size2;
    var cy2 := (j + 1) * Size - size2;
    RLine(cx1, cy1, cx2, cy2);
    RLine(cx1, cy2, cx2, cy1);
  end;

  begin
    ClearWindow(clBlack);
    if Player1 then SetWindowCaption('Ходит первый игрок') else SetWindowCaption('Ходит второй игрок');
    for var i := 0 to N do
      for var j := 0 to N do
      begin
        SetPenColor(clLightBlue);
        SetPenWidth(1);
        DrawRectangle(i * Size + Border, j * Size + Border, (i + 1) * Size - Border, (j + 1) * Size - Border);
        if Matrix[i, j] = Z then DrawZ(i, j)
        else if Matrix[i, j] = K then DrawK(i, j);
      end;
    Redraw();
  end;

function Won(c: char): boolean;
var
  count: byte;
begin
  Result := false;
  for var i := 0 to N do
  begin
    count := 0;
    for var j := 0 to N do
      if Matrix[i, j] = c then Inc(count);
    if count = 3 then Result := true;
  end;
  
  if not Result then
  begin
    for var i := 0 to N do
    begin
      count := 0;
      for var j := 0 to N do
        if Matrix[j, i] = c then Inc(count);
      if count = 3 then Result := true;
    end;
    
    if not Result then
    begin
      count := 0;
      for var i := 0 to N do
        if Matrix[i, i] = c then Inc(count);
      if count = 3 then Result := true;
      
      if not Result then
      begin
        count := 0;
        for var i := 0 to N do
          if Matrix[N - i, i] = c then Inc(count);
        if count = 3 then Result := true;
      end;
    end;
  end;
end;

function IsFull(): boolean;
begin
  Result := true;
  for var i := 0 to N do
    for var j := 0 to N do
      if (Matrix[i, j] <> Z) and (Matrix[i, j] <> K) then
      begin
        Result := false;
        break;
      end;
end;

procedure MouseDown(x, y, mb: integer);
  procedure ShowWinner(s: string; c: Color);
  begin
    SetWindowCaption('Результат игры');
    Sleep(2000);
    SetWindowSize(Sx, Sy);
    CenterWindow();
    ClearWindow(clBlack);
    
    SetFontSize(16);
    SetFontStyle(fsBold);
    SetFontColor(c);
    DrawTextCentered(0, 0, Sx, Sy, s);
    
    Redraw();
    Sleep(2000);
    Halt();
  end;

begin
  var i := x div Size;
  var j := y div Size;
  if (Matrix[i, j] <> Z) and (Matrix[i, j] <> K) then
  begin
    if Player1 then Matrix[i, j] := Z else Matrix[i, j] := K;
    Draw();
    
    var winnerExists := Won(Z) or Won(K);
    if winnerExists then
      if Player1 then ShowWinner('Игрок первый победил!', clLightBlue) else ShowWinner('Игрок второй победил!', clLightBlue);
    
    if IsFull() and not winnerExists then ShowWinner('Ничья!', clOrange);
    
    Player1 := not Player1;
  end;
end;

begin
  var Size2 := Size * 3;
  SetWindowIsFixedSize(true);
  SetWindowSize(Size2, Size2);
  CenterWindow();
  LockDrawing();
  
  Player1 := true;
  Draw();
  
  OnMouseDown := MouseDown;
end.

Змейка[править]

==Упрощенный вариант== (просто змейка которой можно управлять)

Управление:

• W — вверх.
• S — вниз.
• A — влево.
• D — вправо.

uses GraphABC;
const
  Size = 20;

var
  Snake: List<Point>;

procedure Draw();
begin
  ClearWindow();
  Polyline(Snake.ToArray());
  
  var c := Snake.Count - 1;
  Circle(Snake[c].X, Snake[c].Y, 5);
  Redraw();
end;

procedure KeyDown(Key: integer);
begin
  var c := Snake.Count - 2;
  case Key of
    VK_Left:
      begin
        Snake.RemoveAt(0);
        Snake.Add(new Point(Snake[c].X - Size, Snake[c].Y));
      end;
    VK_Right:
      begin
        Snake.RemoveAt(0);
        Snake.Add(new Point(Snake[c].X + Size, Snake[c].Y));
      end;
    VK_Up:
      begin
        Snake.RemoveAt(0);
        Snake.Add(new Point(Snake[c].X, Snake[c].Y  - Size));
      end;
    VK_Down:
      begin
        Snake.RemoveAt(0);
        Snake.Add(new Point(Snake[c].X, Snake[c].Y  + Size));
      end;
  end;
  Draw();
end;

begin
  LockDrawing();
  SetSmoothingOff();
  
  Snake := new List<Point>();
  for var x := 1 to 30 do
    Snake.Add(new Point(x * Size, Size));
  
  Draw();
  OnKeyDown := KeyDown;
end.

456

Возрастающая последовательность[править]

uses GraphABC, ABCObjects;
const
  Border = 100;


var
  Obj: CircleABC;
  DX, DY: integer;
  Move: boolean;
  Numbers: TCircles;

function IsEqual(L2: TCircles): boolean;8
begin
  Result := true;
  for var i := 0 to L2.Count - 1 do
    if Numbers[i].Number <> L2[i].Number then
    begin
      Result := false;
      break;
    end;
end;

procedure MouseUp(x, y, mb: integer);
procedure MouseMove(x, y, mb: integer);
begin
  if mb = 1 then
    if not Move then
    begin
      for var i := 0 to Numbers.Count - 1 do
        if Numbers[i].PtInside(x, y) then
        begin
          DX := x - Numbers[i].Position.X;
          DY := y - Numbers[i].Position.Y;
          Obj := Numbers[i];
          
          Move := true;
          break;
        end;
    end
    else
      Obj.Position := new Point(x - Dx, y - Dy);
end;

begin
  var W := Window.Width - 2 * Border;
  var H := Window.Height - 2 * Border;
  
  Numbers := new TCircles();
  for var i := 0 to 6 do
  end;
begin
    Numbers.Add(new CircleABC(Border + Random(W), Border + Random(H), 30, clRandom()));
    Numbers.Last().Number := i;
  
  Move := false;
  OnMouseMove := MouseMove;
  OnMouseUp := MouseUp;76
end.

430

uses
  graphABC, ABCobjects, timers;



var
  f, fn: text;
  t,check: Timer;
  base_color, cgr: Color;
  
  ug, time_play_sec,take_speed,time: real;
  login, Str, str2, str3, st1, ch, password, zs, ks: string;
  chapter, level, n, xgr, ygr, rgr, x_power, y_power,spin, time_play_sec2,chapter_test: integer;  
  xb, yb, xg, yg, power, ww, wh, shot, time_play_min, shot_max,level_test: integer;
  
  Basa: RegularPolygonABC;
  show4, target, target_bad: ObjectABC;
  show, show2, show3, registr_but, login_but, status_box: RectangleABC;
  Star, sun: StarABC;
  show_pos: CircleABC;
    
  Average_ugol: array of integer;
  Average_power: array of integer;
  mb: array[1..62] of string;
  ground: array [1..9] of CircleABC;
  panel: array [1..5] of RectangleABC;
  
  lvlup_b, play, Cont, login_next, regist_next, from_0, from_6: boolean;

procedure pfile;
begin
  Assign(fn, login + '.txt');
  append(fn);
  writeln(fn, '0');
  write(fn, '0');
  close(fn);
end;

procedure prewrite;
begin
  Assign(f, login + '.txt');
  Rewrite(f);
  writeln(f, level);
  Write(f, chapter);
  Close(f);
end;

procedure pread;
var
  level_s, chapter_s: string;
begin
  Assign(f, login + '.txt');
  Reset(f);
  repeat
    Readln(f, level_s);
    level := StrToInt(level_s);
    readln(f, chapter_s);
    chapter := StrToInt(chapter_s);
  until Eof(f);
  Close(f);
end;

procedure pgenerate;
begin
  var show_login: RectangleABC := new RectangleABC(0, 51, 150, 35, clorangeRed);
  show_login.Text := 'Ваш логин: ' + Login;
  st1 := 'AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz0123456789.';
  for var it := 1 to st1.length - 1 do 
  begin
    mb[it] := st1[it];
  end;
  status_box.Text := 'Введите пароль: ';
  readln(ch);
  password := ch;
  status_box.text := 'Вы создали нового пользователя!';
  show_login.Destroy; 
  pfile;
end;

procedure pcreate;
begin
  var show_login: RectangleABC := new RectangleABC(0, 51, 150, 25, clorangeRed);
  assign(F, 'users.txt');
  append(f);
  close(f);
  reset(f);
  show_login.text := 'Введите логин: ';
  status_box.Text := 'Введите логин: ';
  readln(login);
  while not eof(f) do
  begin
    if (str <> str2) then eof(f);
    readln(f, str);
    if pos(login, str) > 0 then begin
      str2 := str;
      readln(f, str);
      str3 := str;
      if (str <> str2) then eof(f);
    end;
  end;
  close(f);
  if login = str2 then begin
    status_box.Text := 'Это имя уже занято!';
    regist_next := false;
  end
  else begin
    Append(F);
    status_box.text := 'Помощь: Если ввести /gen, то пароль будет сгенерирован автоматически.';
    pgenerate;
    zs := '';
    ks := ',.!@?-:;+';
    for var i := 1 to password.Length do 
    begin
      n := pos(password[i], ks);
      zs := zs + inttostr(n);
    end; 
    zs := '';
    ks := ',.!@?-:;+Zqazwsxedc90rfvtgbhnu7jAmiklop345QWERTYSXDCyFVG1BUHNMJI2OPKL68';
    for var i := 1 to password.Length do 
    begin
      n := pos(password[i], ks);
      zs := zs + inttostr(n);
    end;
    password := zs;
    writeln(f, login);
    writeln(f, password);
    close(f); 
  end;
  show_login.Destroy;
end;

procedure plogin;
begin
  Assign(f, 'users.txt');
  append(f);
  Close(f);
  Assign(f, 'users.txt');
  reset(f);
  var show_login: RectangleABC := new RectangleABC(0, 51, 150, 35, clorangeRed);
  show_login.Text := 'Ваш логин: ';
  status_box.Text := 'Введите логин';
  readln(Login); 
  show_login.Text += Login;
  while not eof(f) do
  begin
    if (str <> str2) then eof(f);
    readln(f, str);
    if pos(login, str) > 0 then begin
      str2 := str;
      readln(f, str);
      str3 := str;
      if (str <> str2) then eof(f);
    end;
  end;
  status_box.Text := 'введите пароль';
  readln(password);
  zs := '';
  ks := ',.!@?-:;+Zqazwsxedc90rfvtgbhnu7jAmiklop345QWERTYSXDCyFVG1BUHNMJI2OPKL68';
  for var i := 1 to password.Length do 
  begin
    n := pos(password[i], ks);
    zs := zs + inttostr(n);
  end;
  password := zs;
  if (str3 = password) then begin
    status_box.Text := 'Выполнен вход в учетную запись: ' + Login;
  end
  else begin status_box.Text := 'Ошибка входа: Неверный логин или пароль'; login_next := false; end;
  close(f);
  show_login.Destroy;
end;

procedure stats;
var
  x, y, w, h: integer;
begin
  x := 0;
  y := wh - 30;
  w := 160;
  h := 30;
  for var i := 1 to 5 do //Создаем нижнюю панель
  begin
    if i < 5 then panel[i] := new RectangleABC(x, y, w + 1, h, RGB(120 + 15 * i, 50 + level * 5, 100));
    if i = 5 then panel[i] := new RectangleABC(x, y, w, h, RGB(120 + 15 * i, 50 + level * 5, 100));
    panel[i].BorderWidth := 2;
    x += w;
  end;
end;

procedure Start;
begin
  SetWindowSize(800, 600);
  ClearWindow(clWhite);
  wh := WindowHeight;
  ww := WindowWidth;
  if level = 0 then level := 0;
  if chapter = 0 then chapter := 0;
  Window.IsFixedSize := true;
  sun := new StarABC(35, 35, 20, 25, 16, clGold);
  SetLength(Average_power, 0);
  SetLength(Average_ugol, 0);
  shot := 0;
  time_play_min := 0;
  time_play_sec := 0;
end;

procedure basegen(xb, yb: integer);//создаем базу
begin
  Line(xb - 50, yb, xb + 50, yb);
  Line(xb, yb - 50, xb, yb + 50);
  Line(xb - 50, yb - 1, xb + 50, yb - 1);
  Line(xb - 1, yb - 50, xb - 1, yb + 50);
  Line(xb - 50, yb, xb + 50, yb);
  Line(xb, yb - 50, xb, yb + 50);
  Line(xb - 50, yb - 1, xb + 50, yb - 1);
  Line(xb - 1, yb - 50, xb - 1, yb + 50);
  basa := new RegularPolygonABC(xb, yb, 30, 5, base_color);
end;

procedure mapgen(level_p: integer);//генерируем карту
begin
  target_bad := new RectangleABC(0, 0, 0, 0, clWhite);
  shot_max := 5;
  xb := 100;
  yb := 300;
  xgr := 0;
  ygr := 530;
  rgr := 100;
  cgr := clLavender;
  for var i := 1 to 9 do 
  begin
    ground[i] := new CircleABC(xgr, ygr, rgr, cgr);
    ground[i].bordered := false;
    xgr += 100;
  end;
  xgr := 0;
  for var i := 1 to 9 do 
  begin
    Arc(xgr, ygr - 1, 100, 60, 120);
    xgr += 100;
  end;
  basegen(xb, yb);//добавляем базу
  
  if level_p=-2 then begin target := new rectangleABC(650, 100, 10, 300, clRed); end;
  
  
  if level_p = 0 then begin
    from_0 := true;
    show := new RectangleABC(100, 0, ww - 100, 20, clwheat);
    show.Text := 'Кликните в любом месте мышкой и удерживая перетащите в любое другое место, так вы сможете выбрать силу.';
    show2 := new RectangleABC(100, 20, ww - 100, 20, clwheat);
    show2.Text := 'Внизу на панеле отображается ваши текущие угол и сила, При соприкосновении с поверхностью ядро взрывается';
    show3 := new RectangleABC(100, 40, ww - 100, 20, clwheat);
    show4 := new RectangleABC(0, 60, ww, 20, cllime);
    show3.Text := 'На каждом уровне есть ограниченное кол-во выстрелов, если вы не успели попасть в цель, вы переходите на уровень назад';
    show4.text := 'Чтобы пройти уровень надо попадать по красным мишеням. Сейчас попадите в красную стенку';
    show3.TextScale := 0.9;
    target := new rectangleABC(650, 100, 10, 300, clRed);
  end;
  stats;//добавляем нижнюю панель
  panel[3].Text := 'Глава: ' + IntToStr(chapter);
  panel[4].Text := 'Уровень: ' + IntToStr(level); 
  if level_p = 1 then begin
    if (from_0 = true) then begin
      show.Destroy;
      show2.Destroy;
      show3.Destroy;
      show4.Destroy;
    end;
    target := new CircleABC(300, 200, 30, clRed);
  end;
  if level > 1 then panel[5].Text := 'Выстрел ' + IntToStr(shot) + ' из ' + IntToStr(shot_max);  
  if (level_p = 2) then target := new CircleABC(400, 400, 30, clRed);
  if (level_p = 3) then target := new CircleABC(100, 50, 30, clRed);
  if (level_p = 4) then target := new CircleABC(500, 110, 30, clRed);
  if (level_p = 5) and (from_6 = false) then target := new CircleABC(700, 330, 20, clRed);
  if (level_p = 5) and (from_6 = true) then begin show.Destroy; target := new CircleABC(700, 330, 20, clRed); end;
  if (level_p = 6) then begin
    from_6 := true; show := new RectangleABC(100, 0, ww - 100, 20, clwheat);
    show.Text := 'Черные цели перенаправляют вас сразу на уровень назад!';
    target := new CircleABC(720, 350, 30, clred); target_bad := new CircleABC(720, 150, 30, clblack);
  end;
  
  time_play_min := 0;
  time_play_sec := 0;
  if level > 6 then begin
    if (from_6 = true) then begin
      from_6 := false;
      show.Destroy;
    end;
    target := new CircleABC(Random(100, ww - 50), Random(100, wh - 250), 30, clRed);
  end;
end;

procedure lvldown;
begin
  target.Destroy;
  target_bad.Destroy;
  ClearWindow(clWhite);
  var stat_box := new RoundRectABC(10, 10, ww - 20, wh - 20, 15, clslateblue);
  stat_box.BorderWidth := 2;
  var box: array[1..5] of RoundRectABC;
  var x_box, y_box: integer;
  x_box := 20;
  y_box := 20;
  for var i := 1 to 5 do 
  begin
    box[i] := new RoundRectABC(x_box, y_box, ww - 40, 100, 15, RGB(100 + 20 * i, 100, 100));
    box[i].BorderWidth := 2;
    y_box += 105;
    if i = 1 then begin box[i].Color := clred; box[i].Text := 'Вы не прошли уровень: ' + IntToStr(level); end;
    if i = 2 then box[i].Text := 'Средняя сила: ' + IntToStr(Round(Average_power.Average)) + 'p';
    if i = 3 then box[i].Text := 'Средний угол: ' + IntToStr(Round(Average_ugol.Average));
    if i = 4 then box[i].Text := 'Выстрелов: ' + IntToStr(shot); 
    if i = 5 then begin
      if time_play_min = 0 then box[i].Text := 'Время: ' + time_play_sec.ToString + 'c.'
      else box[i].Text := 'Время: ' + time_play_min.ToString + 'm. ' + time_play_sec.ToString + 'c.';
    end;
  end;
  Sleep(5000);
  for var i := 1 to 5 do box[I].Destroy;
  stat_box.destroy;
  level -= 1;
  SetLength(Average_power, 0);
  SetLength(Average_ugol, 0);
  shot := 0;
  prewrite;
  mapgen(level);
  Basa.RedrawNow;
  for var i := 1 to 5 do panel[i].RedrawNow;
  sun.RedrawNow;
  for var i := 1 to 9 do ground[i].RedrawNow;
end;

procedure lvlup;
begin
  lvlup_b := false;
  ClearWindow(clWhite);
  
  target.Destroy;
  target_bad.Destroy;
  var stat_box := new RoundRectABC(10, 10, ww - 20, wh - 20, 15, clslateblue);
  stat_box.BorderWidth := 2;
  var box: array[1..5] of RoundRectABC;
  var x_box, y_box: integer;
  x_box := 20;
  y_box := 20;
  for var i := 1 to 5 do 
  begin
    box[i] := new RoundRectABC(x_box, y_box, ww - 40, 100, 15, RGB(100, 100 + 20 * i, 170));
    box[i].BorderWidth := 2;
    y_box += 105;
    if i = 1 then begin box[i].Color := cllime; box[i].Text := 'Вы прошли уровень: ' + IntToStr(level); end;
    if i = 2 then box[i].Text := 'Средняя сила: ' + IntToStr(Round(Average_power.Average)) + 'p';
    if i = 3 then box[i].Text := 'Средний угол: ' + IntToStr(Round(Average_ugol.Average));
    if i = 4 then box[i].Text := 'Выстрелов: ' + IntToStr(shot); 
    if i = 5 then begin
      if time_play_min = 0 then box[i].Text := 'Время: ' + time_play_sec.ToString + 'c.'
      else box[i].Text := 'Время: ' + time_play_min.ToString + 'm. ' + time_play_sec.ToString + 'c.';
    end;
  end;
  Sleep(5000);
  for var i := 1 to 5 do box[I].Destroy;
  stat_box.destroy;
  level += 1;
  if (level = 1) and (chapter = 0) then chapter += 1;
  if (level mod 6 = 0) and (level > 1) then chapter += 1;
  SetLength(Average_power, 0);
  SetLength(Average_ugol, 0);
  shot := 0;
  prewrite;
  mapgen(level);
  Basa.RedrawNow;
  for var i := 1 to 5 do panel[i].RedrawNow;
  sun.RedrawNow;
  for var i := 1 to 9 do ground[i].RedrawNow;
  
end;

function myfunc(xr, yr, p, ug: real): real;//функция полета
var
  t: real;
begin
  play := true;
  t := 0;//Время
  xg := 0;//Коориданата Х
  yg := 0;//Коориданата У
  Star := new StarABC(Round(xr), Round(yr), 20, 10, 10, clRandom);//Создаем объект-ядро
  if level < 0 then Check.Start;
  repeat
  if level < 0 then TextOut(0,500,'ПРОРИСОВКА: '+time_play_sec2.ToString+' ');
    xg := Round((xr) + ((p * t * cos(ug)) / 2));
    yg := Round((yr) - (p * t * sin(ug) - (9.8 * t * t / 2)));
    xg -= 2;
    Star.MoveTo(xg, yg);//перемещения ядра в (xg,yg)
    Star.Angle += spin;//Вращаем ядро
    MoveTo(xg, yg);
    PutPixel(xg, yg, clRed);//рисуем путь
    t += time;//Прибавляем время
    sleep(2);//Задержка в 2 милисекунды 
    if (Star.Intersect(target) = true) then lvlup_b := true;
    if (Star.Intersect(target_bad) = true) then begin lvlup_b := false; shot += shot_max * 2; end;
    if (Star.Intersect(target) = true) then take_speed := time_play_sec2;
  until (star.Intersect(ground[1]) = true) or (star.Intersect(ground[2]) = true) 
   or (star.Intersect(ground[3]) = true) or (star.Intersect(ground[4]) = true)
    or (star.Intersect(ground[5]) = true) or (star.Intersect(ground[6]) = true)
     or (star.Intersect(ground[8]) = true) or (star.Intersect(ground[8]) = true)
      or (star.Intersect(ground[9]) = true) or (xg > ww + 10) or (Star.Intersect(target) = true)
      or (star.Intersect(target_bad) = true);
     if level < 0 then  check.Stop;
     if level < 0 then  time_play_sec2:=0;
  Star.Destroy;//убираем звезду
  shot += 1;
  if level > 1 then panel[5].Text := 'Выстрел ' + IntToStr(shot) + ' из ' + IntToStr(shot_max);
  
  //подсчет средних
  setLength(Average_ugol, shot);
  Average_ugol[shot - 1] := Round(RadToDeg(ug));
  setLength( Average_power, shot);
  Average_power[shot - 1] := Round(power);
  if (shot > shot_max - 1) and (lvlup_b = false) and (level > 1) then lvldown;
  if (level > 0) then if (lvlup_b = true) and (shot < shot_max + 1) then lvlup;
  if (level < 2) and (lvlup_b = true) then lvlup;
  myfunc := t;
  Play := false;
end;

procedure MouseMove(xm, ym, mb: integer);
var
  a, b, c: real;
begin
  a := Abs(xm - xb);
  b := Abs(ym - yb);
  c := Sqrt(Sqr(a) + Sqr(b));
  ug := (arcsin(b / c));
  panel[1].Text := 'Угол: ' + IntToStr(Round(RadToDeg(ug)));
  if mb = 1 then  panel[2].Text := 'Сила: ' + IntToStr(Round(sqrt(sqr((xm - x_power)) + sqr((ym - y_power))))) + 'p';//Показываем силу
end;

procedure MouseDown(xm, ym, mb: integer);
begin
  show_pos := new CircleABC(xm, ym, 2, clwheat);
  x_power := xm;
  y_power := ym;
end;

procedure MouseUp(xm, ym, mb: integer);
var
  a, b, c: real;
begin
  a := Abs(xm - xb);
  b := Abs(ym - yb);
  c := Sqrt(Sqr(a) + Sqr(b));
  ug := (arcsin(b / c));
  power := Round(sqrt(sqr((xm - x_power)) + sqr((ym - y_power))));//Высчитывем силу
  panel[1].FontColor := clWhite;
  panel[1].text := 'Угол полета: ' + IntToStr(Round(RadToDeg(ug)));
  panel[2].FontColor := clWhite;
  panel[2].text := 'Сила полета: ' + IntToStr(Round(power)) + 'p';
  if (mb = 1) and (play = false) and (power > 0) then myfunc(xb, yb, power, ug);//запускаем ядро
  panel[2].FontColor := clBlack;
  panel[1].FontColor := clBlack;
  panel[2].Text := '';
  show_pos.Destroy;
end;

procedure rotate;
begin
  sun.Angle += 1;
  time_play_sec += 0.5;
  if time_play_sec = 60.0 then begin time_play_min += 1; time_play_sec := 0; end;
end;

procedure MouseDownS(xm, ym, mb: integer);
begin
  if mb = 1 then base_color := GetPixel(xm, ym);
end;

procedure Hello;
begin
  SetWindowSize(800, 600);
  Window.IsFixedSize := true;
  var start1 := new RoundRectABC(8, 8, windowwidth - 16, WindowHeight - 15, 10, clLavender);
  start1.BorderWidth := 3;
  var start1_name := new RoundRectABC(15, 15, windowwidth - 30, 50, 10, clGreenYellow);
  start1_name.BorderWidth := 2;
  start1_name.Text := 'Добро пожаловать, ' + Login + '!';
  Sleep(200);
  var start1_color := new RoundRectABC(15, 70, WindowWidth - 30, 50, 10, clFirebrick);
  start1_color.BorderWidth := 2;
  start1_color.Text := 'Выберите цвет базы';
  for var iy := 1 to 18 do 
  begin
    Rectangle(50, 105 + iy * 25, 151, 135 + iy * 25);
    FloodFill(52, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 1, 105 + iy * 25, 151 + 100 * 1, 135 + iy * 25);
    FloodFill(52 + 100 * 1, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 2, 105 + iy * 25, 151 + 100 * 2, 135 + iy * 25);
    FloodFill(52 + 100 * 2, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 3, 105 + iy * 25, 151 + 100 * 3, 135 + iy * 25);
    FloodFill(52 + 100 * 3, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 4, 105 + iy * 25, 151 + 100 * 4, 135 + iy * 25);
    FloodFill(52 + 100 * 4, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 5, 105 + iy * 25, 151 + 100 * 5, 135 + iy * 25);
    FloodFill(52 + 100 * 5, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 6, 105 + iy * 25, 151 + 100 * 6, 135 + iy * 25);
    FloodFill(52 + 100 * 6, 105 + iy * 25 + 2, clRandom);
  end;
  OnMouseDown := MouseDownS;
  var timerShow := new RoundRectABC(WindowWidth - 55, 70, 40, 50, 10, clcyan);
  timerShow.BorderWidth := 2;
  timerShow.Text := '3';
  Sleep(1000);
  timerShow.Text := '2';
  Sleep(1000);
  timerShow.Text := '1';
  Sleep(1000);
  timerShow.Destroy;
  start1.Destroy;
  start1_color.Destroy;
  start1_name.Destroy;
end;

procedure MouseDownBeg(xm, ym, mb: integer);
begin
  if login_but.PtInside(xm, ym) = true then login_next := true;
  if registr_but.PtInside(xm, ym) = true then regist_next := true;
end;
procedure timer_check;
begin
  time_play_sec2 += 1;
end;

begin
base_color:=clRandom;
  SetWindowCaption('TimeKiller v0.2');
  target_bad := new RectangleABC(0, 0, 0, 0, clWhite);
  SetWindowSize(800, 600);
  cont := false;
  from_0 := false;
  from_6 := false;
  OnMouseDown := MouseDownBeg;
  var main: RectangleABC := new RectangleABC(0, 0, WindowWidth, windowheight, clLavender);
  login_but := new RectangleABC(0, 0, 401, 50, clolive);
  registr_but := new RectangleABC(399, 0, 400, 50, clOliveDrab);
  login_but.BorderWidth := 2;
  registr_but.BorderWidth := 2;
  login_but.FontColor := clwhite;
  registr_but.FontColor := clgold;
  login_but.Text := 'Войти';
  registr_but.Text := 'Зарегистрироваться';
  status_box := new RectangleABC(0, WindowHeight - 30, WindowWidth, 30, clgold);
  status_box.BorderWidth := 2;
  status_box.Color := ARGB(120, 255, 215, 0);
  status_box.Text := 'Вам необходимо войти или зарегистрироваться';
  repeat
    Sleep(1000);
    if login_next = true then begin plogin; end; 
    if regist_next = true then begin pcreate; end; 
  until (login_next = true) or (regist_next = true);
  pread;
  cont := true;
  if Cont = true then begin
    main.Destroy;
    status_box.Destroy;
    login_but.Destroy;
    registr_but.Destroy;
    Hello;
    start;
    
    TextOut(0,0,'Подождите идет загрузка данных. Прорисовка.');
     time := 0.02;
     spin := 1;
    time_play_sec := 0;
    level_test:=level;
    chapter_test:=chapter;
    chapter:=0;
    level:=-2;
    mapgen(level); 
   
    Check := new Timer(1, timer_check);
    
    myfunc(xb, yb, 200, Pi / 10);//Проверка медленной скорости;
   
    if take_speed > 100 then begin time := 0.08; spin := 2; end;
    check.Stop; 
    Check := new Timer(1, timer_check);
    time_play_sec := 0;
    target.Destroy;
    level:=-2;
    mapgen(level);
    TextOut(0,0,'Подождите идет загрузка данных. Прорисовка.');
    myfunc(xb, yb, 200, Pi / 10);//Проверка быстрой скорости;
   
    if take_speed < 50 then begin time := 0.02; spin := 1; end;
    target.Destroy;
    level:=level_test;
    chapter:=chapter_test;
  
    
    mapgen(level); 
    T := new Timer(500, rotate);
    T.Start;
    OnMouseMove := MouseMove; 
    OnMouseDown := MouseDown;
    OnMouseUp := MouseUp;
  end;
end.

Представляю Вашему вниманию пример реализации алгоритмической игры «Жизнь» на языке Паскаль. Игра «Жизнь», она же так называемый клеточный автомат, обязана своим появлением английскому математику Джону Конвейю.

Для начала — относительно простой, но одновременно структурированный вариант текста программы (на Free Pascal в самом простом и совместимом исполнении):

program Life;

uses
  ptcGraph, ptcCrt;

const
  HorSize = 640;
  VerSize = 480;

type
  TMatrix = array [0..VerSize+1, 0..HorSize+1] of Byte;

var
  GraphDriver :Integer;
  GraphMode :Integer;

  NewArr, OldArr :TMatrix;

  { Процедура очистки массива (заполнения нулями) }
  procedure ClearMatrix(var Matrix :TMatrix; VSize, HSize :Integer);
  var
    i, j :Integer;
  begin
    for i := 0 to VSize+1 do
      for j := 0 to HSize+1 do
        Matrix[i, j] := 0;
  end;

  { Процедура "вставки" в массив некоторого прямоугольника из единиц }
  procedure InitMatrix(var Matrix :TMatrix;
                           RVpos, RHPos, RVSize, RHSize :Integer);
  var
    i, j :Integer;
  begin
    for i := 1 to RVSize do
      for j := 1 to RHSize do
        Matrix[RVPos+i-1, RHPos+j-1] := 1;
  end;

  { Процедура "заворачивания" границ массива для эмуляции "бесконечного" поля }
  procedure InfiMatrixEdges(var Matrix :TMatrix; VSize, HSize :Integer);
  var
    i :Integer;
  begin
    Matrix[0, 0] := Matrix[VSize, HSize];
    Matrix[VSize+1, HSize+1] := Matrix[1, 1];
    Matrix[0, HSize+1] := Matrix[VSize, 1];
    Matrix[VSize+1, 0] := Matrix[1, HSize];

    for i := 1 to VSize do
      begin
        Matrix[i, 0] := Matrix[i, HSize];
        Matrix[i, HSize+1] := Matrix[i, 1];
      end;

    for i := 1 to HSize do
      begin
        Matrix[0, i] := Matrix[VSize, i];
        Matrix[VSize+1, i] := Matrix[1, i];
      end;
  end;

  { Процедура реализации игровой логики }
  procedure GameLogic(var Source, Dest :TMatrix; VSize, HSize :Integer);
  var
    i, j :Integer;
    around :Byte;
  begin
    for i := 1 to VSize do
      for j := 1 to HSize do
        begin
          around := Source[i-1, j-1] + Source[i-1, j] + Source[i-1, j+1] +
                    Source[i, j-1] + Source[i, j+1] +
                    Source[i+1, j-1] + Source[i+1, j] + Source[i+1, j+1];

          case Source[i, j] of
            0: if around = 3 then
                 Dest[i, j] := 1
               else
                 Dest[i, j] := 0;
            1: if (around < 2) or (around > 3) then
                 Dest[i, j] := 0
               else
                 Dest[i, j] := 1;
          end;
        end;
  end;

  { Процедура "визуализации" - отрисовывает игровое поле на экран }
  procedure DrawMatrix(var Matrix :TMatrix; VSize, HSize :Integer;
                                            Color, Background :Integer);
  var
    i, j :Integer;
  begin
    for i := 1 to VSize do
      for j := 1 to HSize do
        case Matrix[i, j] of
          0: PutPixel(j-1, i-1, Background);
          1: PutPixel(j-1, i-1, Color);
        end;
  end;

begin

  ClearMatrix(NewArr, VerSize, HorSize);
  ClearMatrix(OldArr, VerSize, HorSize);

  InitMatrix(OldArr, 140, 220, 200, 200);

  { DetectGraph(GraphDriver, GraphMode);
  WriteLn('Driver: ', GraphDriver, ', Mode: ', GraphMode); }

  GraphDriver := VGA;
  GraphMode := VGAHi;
  InitGraph(GraphDriver, GraphMode, '');

  repeat

    GameLogic(OldArr, NewArr, VerSize, HorSize);
    InfiMatrixEdges(NewArr, VerSize, HorSize);

    OldArr := NewArr;

    { Delay(100); }

    DrawMatrix(NewArr, VerSize, HorSize, 15, 0);

  until KeyPressed;

  CloseGraph;

end.

Пояснения по тексту программы ниже, а сейчас — немного о сути игры.

В нашем распоряжении есть игровое поле — двумерный массив ячеек (клеток). Каждая такая ячейка может находиться в одном из двух возможных состояний: «живом» и «неживом». Скажем, пусть состоянию «жив» соответствует численное значение, равное 1, а состоянию «мертв» — численное значение, равное 0. Для образности каждую «живую» ячейку мы можем называть, скажем, бактерией.

В ходе действия игрового алгоритма над игровым полем мы выполняем некоторые манипуляции, результат которых графически отображаем на экране.

Суть игрового алгоритма такова: по очереди «пересматриваем» все клетки и подсчитываем количество «живых соседей» каждой клетки. В зависимости от количества «живых соседей» меняем состояние текущей клетки — «возрождаем» (создаем) нашу «бактерию» либо «убиваем» её. Вот варианты условия:

• если вокруг пустой («мертвой») находятся ровно три непустые («живые») клетки, то данная клетка «оживает» (либо, другими словами, «появляется» — кому как больше нравится);
• состояние непустой («живой») клетки при наличии двух или трех непустых же («живых») соседей не изменяется (клетка продолжает «существовать»);
• если у непустой («живой») клетки меньше двух или больше трех «живых» соседей, то данная клетка «умирает» (перестает «существовать»).

Задав выборочно начальные условия (разместив на игровом поле то или иное количество «живых» клеток) и запустив игровой алгоритм, можно наблюдать за развитием «жизни» в пределах игрового поля — изменением конфигурации и количества «бактерий», их движением. Процесс и результат могут быть довольно любопытными.

И немного по тексту программы-примера. Для реализации игрового поля будем использовать двумерный массив элементов типа Byte, в цикле перебирая все его ячейки (по строкам и столбцам). «Живой» ячейкой будет элемент со значением «1», «мертвой» — со значением «0». Результат работы алгоритма, что естественно, будем помещать в другой идентичного типа двумерный массив, который и отображается графически. После отработки игрового алгоритма в очередном «шаге» первый массив будем обновлять, копируя в него содержимое из второго.

Чтобы сделать игровое поле «бесконечным» (и избавиться от «краевых» эффектов), мы «заворачиваем» края двумерного массива. Для этого добавляем к каждому краю двумерного массива по лишнему элементу, куда копируем значение элемента с противоположенного края. Соответственно, в данном случае каждая ячейка с обычным индексом в массиве «видит» полный набор «соседей» и алгоритм работает корректно (пусть и в «завернутом» пространстве игрового поля).

В тексте программы названия переменных и процедур/функций выбраны таким образом, чтобы можно было максимально быстро понять, для чего они нужны. Например, HorSize и VerSize — задают горизонтальный и вертикальный размеры игрового поля соответственно. Поскольку для реализации применен Free Pascal, графика выполнена с использованием модулей ptcGraph и ptcCrt (последний — для считывания клавиатуры). Но версия Паскаля здесь принципиального значения не имеет — программу легко адаптировать под любой диалект, немного изменится лишь реализация графики.

Скачать текст программы и её модификации с «улучшенной» графикой Вы можете здесь: zip-архив.

Превосходная программа, демонстрирующая возможности графики и алгоритма игры «Жизнь» на торе. Немного пояснений для тех кто только начинает учиться.

Игра «Жизнь» была придумана английским математиком Джоном Конвейем в 1970 году. Впервые описание этой игры опубликовано в октябрьском выпуске (1970) журнала Scientic American, в рубрике «Математические игры» Мартина Гарднера.

Место действия этой игры – «вселенная» – это размеченная на клетки поверхность. Каждая клетка на этой поверхности может находиться в двух состояниях: быть живой или быть мертвой. Клетка имеет восемь соседей. Распределение живых клеток в начале игры называется первым поколением. А дальше все происходит почти как в реальной жизни, потому игра так и называется. Каждое следующее поколение рассчитывается на основе предыдущего по таким правилам:

1) пустая (мертвая) клетка с ровно тремя живыми клетками-соседями оживает;
2) если у живой клетки есть две или три живые соседки, то эта клетка продолжает жить;
3) в противном случае (если соседок меньше двух или больше трех) клетка умирает (от «одиночества» или от «перенаселенности»).

В этой задаче рассматривается игра «Жизнь» на торе. Представим себе прямоугольник размером n строк на m столбцов. Для того, чтобы превратить его в тор мысленно «склеим» его верхнюю сторону с нижней, а левую с правой. Таким образом, у каждой клетки, даже если она раньше находилась на границе прямоугольника, теперь есть ровно восемь соседей.

Ваша задача состоит в том, чтобы найти конфигурацию клеток, которая будет через k поколений от заданного.

А вот код решения задачи. Попробовать программу онлайн можно здесь. Перед переходом по ссылке скопируйте код программы, а затем вставьте в онлайн-компилятор. Программа может даже потянуть на простенькую курсовую.

// Игра "Жизнь" на торе
// Оптимизация хешированием по равномерной сетке
uses Graph;

const 
/// Пауза между поколениями
 delay = 10;
/// Ширина клетки
 w = 10;
/// Количество клеток по ширине
 m = 70;
/// Количество клеток по высоте
 n = 60;
/// Отступ поля от левой границы окна
 x0 = 1;
/// Отступ поля от верхней границы окна
 y0 = 21;
 mm = m + 1;
 nn = n + 1;
/// Количество клеток сетки по горизонтали
 mk = 10;
/// Количество клеток сетки по вертикали
 nk = 5;

var
 a,b,sosedia,sosedib: array [0..nn,0..mm] of byte;
 obnovA,obnovB: array [1..nk,1..mk] of boolean;
 CountCells: integer;
 obn: boolean;
 gen: integer;
 hn,hm: integer;

/// Нарисовать ячейку
procedure DrawCell(i,j: integer);
begin
 SetBrushColor(Color.Black);
 FillRectangle(x0+(j-1)*w,y0+(i-1)*w,x0+j*w-1,y0+i*w-1);
end;

/// Стереть ячейку
procedure ClearCell(i,j: integer);
begin
 SetBrushColor(Color.White);
 FillRectangle(x0+(j-1)*w,y0+(i-1)*w,x0+j*w-1,y0+i*w-1);
end;

/// Нарисовать все изменившиеся ячейки
procedure DrawConfiguration;
begin
 for var i:=1 to n do
 for var j:=1 to m do
 begin
 var bb := b[i,j];
 if a[i,j]<>bb then
 if bb=1 then DrawCell(i,j)
 else ClearCell(i,j);
 end;
end;

/// Нарисовать все ячейки
procedure DrawConfigurationFull;
begin
 for var i:=1 to n do
 for var j:=1 to m do
 if b[i,j]=1 then DrawCell(i,j)
 else ClearCell(i,j);
end;

/// Нарисовать поле
procedure DrawField;
begin
 Pen.Color := Color.LightGray;
 for var i:=0 to m do
 begin
 if i mod hm = 0 then
 Pen.Color := Color.Gray
 else Pen.Color := Color.LightGray;
 Line(x0+i*w-1,y0,x0+i*w-1,y0+n*w-1);
 end;
 for var i:=0 to n do
 begin
 if i mod hn = 0 then
 Pen.Color := Color.Gray
 else Pen.Color := Color.LightGray;
 Line(x0,y0+i*w-1,x0+m*w,y0+i*w-1);
 end;
end;

/// Увеличить массив соседей для данной клетки
procedure IncSosedi(i,j: integer);
var i1,i2,j1,j2: integer;
begin
 if i=1 then i1:=n else i1:=i-1;
 if i=n then i2:=1 else i2:=i+1;
 if j=1 then j1:=m else j1:=j-1;
 if j=m then j2:=1 else j2:=j+1;
 SosediB[i1,j1] += 1;
 SosediB[i1,j] += 1;
 SosediB[i1,j2] += 1;
 SosediB[i,j1] += 1;
 SosediB[i,j2] += 1;
 SosediB[i2,j1] += 1;
 SosediB[i2,j] += 1;
 SosediB[i2,j2] += 1;
end;

/// Уменьшить массив соседей для данной клетки
procedure DecSosedi(i,j: integer);
var i1,i2,j1,j2: integer;
begin
 if i=1 then i1:=n else i1:=i-1;
 if i=n then i2:=1 else i2:=i+1;
 if j=1 then j1:=m else j1:=j-1;
 if j=m then j2:=1 else j2:=j+1;
 SosediB[i1,j1] -= 1;
 SosediB[i1,j] -= 1;
 SosediB[i1,j2] -= 1;
 SosediB[i,j1] -= 1;
 SosediB[i,j2] -= 1;
 SosediB[i2,j1] -= 1;
 SosediB[i2,j] -= 1;
 SosediB[i2,j2] -= 1;
end;

/// Поставить ячейку в клетку (i,j)
procedure SetCell(i,j: integer);
begin
 if b[i,j]=0 then
 begin
 b[i,j] := 1;
 obn := True;
 IncSosedi(i,j);
 end;
 CountCells += 1;
end;

/// Убрать ячейку из клетки (i,j)
procedure UnSetCell(i,j: integer);
begin
 if b[i,j]=1 then
 begin
 b[i,j] := 0;
 obn := True;
 DecSosedi(i,j);
 end;
 CountCells -= 1;
end;

/// Инициализировать массивы и конфигурацию поля
procedure Init;
var 
 xc := n div 2;
 yc := m div 2;
begin
 for var i:=0 to n+1 do
 for var j:=0 to m+1 do
 b[i,j] := 0;
 a := b;
 SosediB := b;
 SosediA := SosediB;
 for var ik:=1 to nk do
 for var jk:=1 to mk do
 obnovB[ik,jk] := True;
 obnovA := obnovB;
 CountCells := 0;

 SetCell(xc,yc);
 SetCell(xc,yc+1);
 SetCell(xc,yc+2);
 SetCell(xc-1,yc+2);
 SetCell(xc+1,yc+1);
end;

/// Обработать ячейку
procedure ProcessCell(i,j: integer);
begin
 case SosediA[i,j] of
0..1,4..9:
 if b[i,j]=1 then
 begin
 b[i,j] := 0;
 obn := True;
 DecSosedi(i,j);
 ClearCell(i,j);
 Dec(CountCells);
 end;
3: if b[i,j]=0 then
 begin
 b[i,j] := 1;
 obn := True;
 IncSosedi(i,j);
 DrawCell(i,j);
 Inc(CountCells);
 end;
 end; {case}
end;

/// Перейти к следующему поколению
procedure NextGen;
var ifirst,jfirst,ilast,jlast: integer;
begin
 for var ik:=1 to nk do
 begin
 for var jk:=1 to mk do
 begin
 obn := False;
 ifirst := (ik-1)*hn+1;
 ilast := (ik-1)*hn+hn;
 jfirst := (jk-1)*hm+1;
 jlast := (jk-1)*hm+hm;
 if obnovA[ik,jk] then
 begin
 for var i:=ifirst to ilast do
 for var j:=jfirst to jlast do
 ProcessCell(i,j);
 end
 else
 begin
 var ik1,jk1,ik2,jk2: integer;
 if ik=1 then ik1:=nk else ik1:=ik-1;
 if ik=nk then ik2:=1 else ik2:=ik+1;
 if jk=1 then jk1:=mk else jk1:=jk-1;
 if jk=mk then jk2:=1 else jk2:=jk+1;
 var l := obnovA[ik,jk1];
 var r := obnovA[ik,jk2];
 var u := obnovA[ik1,jk];
 var d := obnovA[ik2,jk];
 var lu := obnovA[ik1,jk1];
 var ld := obnovA[ik2,jk1];
 var ru := obnovA[ik1,jk2];
 var rd := obnovA[ik2,jk2];
 if u then
 for var j:=jfirst+1 to jlast-1 do
 ProcessCell(ifirst,j);
 if d then
 for var j:=jfirst+1 to jlast-1 do
 ProcessCell(ilast,j);
 if l then
 for var i:=ifirst+1 to ilast-1 do
 ProcessCell(i,jfirst);
 if r then
 for var i:=ifirst+1 to ilast-1 do
 ProcessCell(i,jlast);
 if u or l or lu then
 ProcessCell(ifirst,jfirst);
 if u or r or ru then
 ProcessCell(ifirst,jlast);
 if d or l or ld then
 ProcessCell(ilast,jfirst);
 if d or r or rd then
 ProcessCell(ilast,jlast);
 end;
 obnovB[ik,jk] := obn;
 end;
 end;
end;

/// Перерисовка содержимого окна
procedure LifeRedrawProc;
begin
 DrawConfigurationFull;
end;

/// Вывод номера поколения и количества ячеек
procedure DrawInfo;
begin
 Brush.Color := Color.LightGray;
 FillRectangle(0,0,Window.Width,20);
 Font.Size := 10;
 TextOut(15,5,'Поколение '+IntToStr(gen));
 TextOut(Window.Width - 130,5,'Жителей: '+IntToStr(CountCells)+' ');
end;

begin
 if (m mod mk<>0) or (n mod nk<>0) then
 begin
 writeln('Размер кластера не согласован с размером поля. Программа завершена');
 exit
 end;
 hm := m div mk;
 hn := n div nk;
 Window.SetPos(200,50);
 Window.SetSize(x0+m*w,y0+n*w);
 Window.Title := 'Игра Жизнь';
 Init;
 
 DrawInfo;
 DrawField;
 DrawConfiguration;
 
 var mil := Milliseconds;
 gen := 0;
 Sleep(100);
 DrawField;
 
 while True do
 begin
 gen += 1;
 
// if gen mod 11 = 0 then
 DrawInfo;
 
 SosediA := SosediB;
 obnovA := obnovB;
 NextGen;
 DrawConfiguration;
 Sleep(delay);
 end;
end.

Похожие публикации

2016-01-14 • Просмотров [ 7925 ]