Книга программиста/Книга игр на PascalABC.Net

Материал из Викиучебника — открытых книг для открытого мира
Перейти к навигации Перейти к поиску

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

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

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

Описание алгоритма
  1. Отрисовать игровое поле.
  2. Позволить сделать шаг игроку.
  3. Проверить выиграл ли кто-то.
  4. Если да - выиграл текущий игрок, иначе - вернуться к шагу 1.

Крестики-нолики.png

Управление:

  • Левая кнопка мыши - установить крестик/нолик.
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.

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

Упрощенный вариант[править]

Описание алгоритма
  1. Нарисовать змейку.
  2. Если нажали клавишу - добавить новую точку, в которую перешла голова змейки, в список и удалить первую точку в списке. Перейти к шагу 1.

Управление:

  • 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.

Усложненный вариант[править]

Описание алгоритма
  1. Нарисовать змейку.
  2. Если нажали клавишу - создать новую точку.
  3. Если в списке нет точки с такими координатами - передвинуть голову змейки в эту точку и удалить первую точку в списке.

Управление:

  • 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;

function Exists(p: Point): boolean;
begin
  Result := false;
  var i := 0;
  while not Result and (i < Snake.Count) do
  begin
    if (Snake[i].X = p.X) and (Snake[i].Y = p.Y) then Result := true;
    Inc(i);
  end;
end;

procedure NewPoint(p: Point);
begin
  if not Exists(p) then
  begin
    Snake.RemoveAt(0);
    Snake.Add(p);
  end;
end;

procedure KeyDown(Key: integer);
begin
  var c := Snake.Count - 1;
  case Key of
    VK_Left:
      begin
        var p := new Point(Snake[c].X - Size, Snake[c].Y);
        NewPoint(p);
      end;
    VK_Right:
      begin
        var p := new Point(Snake[c].X + Size, Snake[c].Y);
        NewPoint(p);
      end;
    VK_Up:
      begin
        var p := new Point(Snake[c].X, Snake[c].Y  - Size);
        NewPoint(p);
      end;
    VK_Down:
      begin
        var p := new Point(Snake[c].X, Snake[c].Y  + Size);
        NewPoint(p);
      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.

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

uses GraphABC, ABCObjects;
const
  Border = 100;

type
  TCircles = List<CircleABC>;

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

function IsEqual(L2: TCircles): boolean;
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);
begin
  if mb = 1 then
  begin
    Move := false;
    if IsEqual(Numbers.OrderBy(x -> x.Position.X).ToList()) then
    begin
      SetWindowIsFixedSize(true);
      var A := new RectangleABC(0, 0, Window.Width, Window.Height, clYellow);
      A.Text := 'Вы расставили все числа по местам.';
      Sleep(4000);
      Halt();
    end;
  end;
end;

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
  begin
    Numbers.Add(new CircleABC(Border + Random(W), Border + Random(H), 30, clRandom()));
    Numbers.Last().Number := i;
  end;
  
  Move := false;
  OnMouseMove := MouseMove;
  OnMouseUp := MouseUp;
end.

Игры средней сложности[править]

Составление слова[править]

Константы:

  • DisplacementXleft = 10 - отступ от верхнего левого края окна.
  • DisplacementYleft = 10 - отступ от верхнего левого края окна.
  • DisplacementXright = 10 - отступ от нижнего правого края окна.
  • DisplacementYright = 10 - отступ от нижнего правого края окна.
  • CircleR = 20 - радиус кружка с символом.
  • GameTimeMax = 60 - максимальное время, отводимое на составление одного слова.
  • Words: array of string = ('List', 'class', 'private', 'public', 'override', 'auto class', 'interface', 'constructor', 'implementation') - все слова (количество слов равно количеству уровней).
  • OutcomeF = 'You won {0}/{1} stages.' - форматная строка отображения результата уровня.
  • TimeF = 'Time: {0}/{1}' - форматная строка отображения времени.
  • AbsMax = 4 - максимальная скорость перемещения букв по модулю.

Переменные-флаги:

  • IsPlaying: boolean - играет ли игрок в какой-нибудь уровень или нет.
uses Timers, GraphABC, ABCObjects;
const
  DisplacementXleft = 10;
  DisplacementYleft = 30;
  DisplacementXright = 10;
  DisplacementYright = 10;
  CircleR = 20;
  GameTimeMax = 60;
  
  Words: array of string = ('List', 'class', 'private', 'public', 'override', 'auto class', 'interface', 'constructor', 'implementation');
  
  OutcomeF = 'You won {0}/{1} stages.';
  TimeF = 'Time: {0}/{1}';
  
  AbsMax = 4;
  MaxR = 200;

type
  TVector = Point;
  TCircleChar = class
    Instance: CircleABC;
    CharColor: Color;
    Stopped: boolean;
    Velocity: TVector;
    
    constructor ();
    begin
    end;
  end;

var
  //Флаги
  IsPlaying: boolean;
  
  //Данные
  // Постоянные данные
  W, H: integer;
  
  C: List<TCircleChar>;
  WordsI: integer;
  BG: RectangleABC;
  Message: RectangleABC;
  Stage: integer;
  
  GameTime: integer;
  GameTimeRect: TextABC;
  GameTimeTimer: Timer;
  
  Xleft, Yleft: integer;
  Xright, Yright: integer;
  
  // Временные данные
  MovedChar: TCircleChar;
  ClosestChar: TCircleChar;
  DX, DY: integer;
  SortedByX: List<TCircleChar>;

procedure SetNormalStyle(x: TCircleChar); forward;

function Dist(a, b: TCircleChar) := Sqrt(Sqr(b.Instance.Position.X - a.Instance.Position.X) + Sqr(b.Instance.Position.Y - a.Instance.Position.Y));

function IsEqual(): boolean;
begin
  Result := true;
  var i := 0;
  while (i < C.Count) and (C[i].Instance.Text = SortedByX[i].Instance.Text) do
  begin
    SortedByX[i].CharColor := clDeepSkyBlue;
    SetNormalStyle(SortedByX[i]);
    SortedByX[i].Stopped := true;
    Inc(i);
  end;
  
  Result := (i = C.Count) and SortedByX.Incremental((a, b)-> Dist(a, b)).All(a -> a <= MaxR);
end;

///Инициализация уровня.
procedure Initialize();
begin
  if C.Count > 0 then
    for var i := Objects.Count - 1 downto 0 do
      if (Objects[i] <> Message) and (Objects[i] <> GameTimeRect) and (Objects[i] <> BG) then
        Objects[i].Destroy();
  
  C.Clear();
  for var i := 1 to Words[WordsI].Length do
  begin
    C.Add(new TCircleChar());
    with C.Last() do
    begin
      CharColor := ARGB(100, Random(50, 255), 0, Random(50, 255));
      Instance := new CircleABC(Random(DisplacementXleft + CircleR, W - DisplacementXright - CircleR),
                                Random(DisplacementYleft + CircleR, H - DisplacementYright - CircleR),
                                CircleR, CharColor);
      Instance.Text := Words[WordsI].Chars[i];
    end;
    C.Last().Velocity := new TVector(Random(-AbsMax, AbsMax), Random(-AbsMax, AbsMax));
  end;
  GameTimeTimer.Start();
  GameTimeRect.Visible := true;
end;

procedure ShowMessage(s: string);
begin
  Message.Visible := true;
  Message.ToFront();
  Message.Text := s;
end;

procedure CheckTime();
begin
  if GameTime <= GameTimeMax then
  begin
    GameTimeRect.Text := Format(TimeF, GameTime, GameTimeMax);
    Inc(GameTime);
  end
  else
  begin
    GameTimeTimer.Stop();
    ShowMessage('You lose.');
    Sleep(1000);
    Halt();
  end;
end;

///Подготовка данных для работы игры.
procedure InitializeGame();
begin
  SetWindowIsFixedSize(true);
  SetWindowCaption('Words');
  
  //Настройка флагов
  IsPlaying := false;
  
  //Настройка данных
  W := Window.Width;
  H := Window.Height;
  
  C := new List<TCircleChar>();
  
  BG := new RectangleABC(DisplacementXleft, DisplacementYleft, W - DisplacementXleft - DisplacementXright, H - DisplacementYleft - DisplacementYright, clLemonChiffon);
  
  Message := new RectangleABC(0, 0, W, H, clWhite);
  Message.Text := 'Words (stage 1)';
  
  Stage := 1;
  
  GameTime := 0;
  GameTimeRect := new TextABC(0, 0, 14, '', clBlack);
  GameTimeTimer := new Timer(1000, CheckTime);
  
  Xleft := DisplacementXleft + 1;
  Yleft := DisplacementYleft + 1;
  Xright := W - DisplacementXright - CircleR * 2 - 1;
  Yright := H - DisplacementYright - CircleR * 2 - 1;
  
  MovedChar := new TCircleChar();
  ClosestChar := nil;
  
  SortedByX := new List<TCircleChar>();
end;

procedure SetSelectedStyle(x: TCircleChar);
begin
  x.Instance.Color := ARGB(100, clLightBlue.R, clLightBlue.G, clLightBlue.B);
  x.Instance.BorderColor := clBlue;
  x.Instance.FontColor := clPurple;
end;

procedure SetNormalStyle(x: TCircleChar);
begin
  x.Instance.Color := x.CharColor;
  x.Instance.BorderColor := clBlack;
  x.Instance.FontColor := clBlack;
end;

procedure SetClosestStyle(x: TCircleChar);
begin
  x.Instance.Color := clOrange;
  x.Instance.BorderColor := clRed;
  x.Instance.FontColor := clRed;
end;

procedure SelectClosest(a: TCircleChar);
var
  newClosest: TCircleChar;

begin
  var dMin := MaxR * 1.0;
  
  for var i := 0 to C.Count - 1 do
  begin
    var d := Dist(C[i], a);
    if (C[i].Instance <> a.Instance) and (d < dMin) then
    begin
      dMin := d;
      newClosest := C[i];
    end;
  end;
  
  if (newClosest = nil) and (ClosestChar <> nil) then SetNormalStyle(ClosestChar);
  if newClosest <> nil then
  begin
    if (ClosestChar <> nil) and (ClosestChar <> newClosest) then
      SetNormalStyle(ClosestChar);
    ClosestChar := newClosest;
    SetClosestStyle(ClosestChar);
  end;
end;

procedure MouseMove(x, y, mb: integer);
begin
  if IsPlaying then
    if mb = 1 then
      if MovedChar.Instance = nil then
      begin
        var i := 0;
        while (i < C.Count) and not C[i].Instance.PtInside(x, y) do Inc(i);
        if i < C.Count then
        begin
          MovedChar.CharColor := C[i].CharColor;
          MovedChar.Instance := C[i].Instance;
          
          with MovedChar do
          begin
            DX := x - Instance.Position.X;
            DY := y - Instance.Position.Y;
          end;
          SetSelectedStyle(MovedChar);
          
          ClosestChar := nil;
        end;
      end
      else
      begin
        var cx := x - DX;
        var cy := y - DY;
        
        if cx < DisplacementXleft then cx := Xleft;
        if cy < DisplacementYleft then cy := Yleft;
        
        if cx > Xright + 1 then cx := Xright;
        if cy > Yright + 1 then cy := Yright;
        
        MovedChar.Instance.Position := new Point(cx, cy);
        
        GameTimeRect.ToFront();
      end;
end;

procedure MouseUp(x, y, mb: integer);
begin
  if IsPlaying and (mb = 1) then
  begin
    if MovedChar.Instance <> nil then
    begin
      SetNormalStyle(MovedChar);
      MovedChar.Instance := nil;
      
      if ClosestChar <> nil then
        SetNormalStyle(ClosestChar);
      
      SortedByX := C.OrderBy(a -> a.Instance.Position.X).ToList();
      if Stage <= Words.Length then
        if IsEqual() then
        begin
          IsPlaying := false;
          
          BG.Visible := false;
          
          GameTimeRect.Visible := false;
          GameTimeTimer.Stop();
          
          Inc(WordsI);
          
          ShowMessage(Format(OutcomeF, Stage, Words.Length));
          Inc(Stage);
        end;
      
      if Stage > Words.Length then
      begin
        ShowMessage(Format('You won all {0} stages!', Words.Length));
        Sleep(1000);
        Halt();
      end;
    end;
  end;
end;

procedure KeyDown(key: integer);
begin
  if not IsPlaying then
  begin
    Initialize();
    
    //Флаги
    IsPlaying := true;
    
    //Данные
    Message.Visible := false;
    
    BG.Visible := true;
    
    GameTime := 0;
    GameTimeRect.Text := 'starting...';
    
    MovedChar.CharColor := clTransparent;
    MovedChar.Instance := nil;
  end;
end;

procedure RandomMove();
begin
  if IsPlaying then
    for var i := 0 to C.Count - 1 do
    begin
      if not C[i].Stopped and ((MovedChar.Instance = nil) or (C[i].Instance <> MovedChar.Instance)) then
      begin
        C[i].Instance.MoveOn(C[i].Velocity.X, C[i].Velocity.Y);
        if (C[i].Instance.Position.X <= DisplacementXleft) or (C[i].Instance.Position.X >= W - DisplacementXright - CircleR * 2) then
          C[i].Velocity.X := -C[i].Velocity.X;
        if (C[i].Instance.Position.Y <= DisplacementYleft) or (C[i].Instance.Position.Y >= H - DisplacementYright - CircleR * 2) then
          C[i].Velocity.Y := -C[i].Velocity.Y;
      end;
      Sleep(10);
    end;
end;

begin
  InitializeGame();
  
  OnMouseMove := MouseMove;
  OnMouseUp := MouseUp;
  OnKeyDown := KeyDown;
  
  while true do
  begin
    RandomMove();
    if IsPlaying and (MovedChar.Instance <> nil) then SelectClosest(MovedChar);
  end;
end.