Игра Змейка

uses
  GraphABC, ABCButtons;
 
const
  StartLength = 3;
  UpScore = 10;
  MaxScore = 110 * UpScore;
 
type
  Coordianates = (x, y);
  
  RStep = record
    x, y: integer;
  end;
  
  RSegment = record
    x, y: integer;
    Step: RStep;
    Fold: boolean;
  end;
  
  IDraw = interface
    procedure Draw;
  end;
  
  TFood = class(IDraw)
  private 
    x, y: word;
  
  public 
    constructor Create(x, y: word);
    begin
      self.x := x;
      self.y := y;
      Draw;
    end;
    
    procedure Draw;
    begin
      FloodFill(x, y, clAquamarine);
    end;
    
    destructor Death;
    begin
      x := 0;
      y := 0;
    end;
  
  end;
  
  TSnake = class(IDraw)
  private 
    Body: array of RSegment;
  
  public 
    constructor Create;
    begin
      SetLength(Body, StartLength);
      for var i := 0 to High(Body) do
      begin
        Body[i].x := (High(Body) - i) * 50 + 25;
        Body[i].y := 25;
        Body[i].Step.x := 50;
        Body[i].Step.y := 0;
        Body[i].Fold := false;
      end;
      Draw;
    end;
    
    function HeadPath(z: Coordianates): integer;
    begin
      if z = x then
      begin
        Result := Body[0].x + Body[0].Step.x;
        if Result < 25 then
          Result := 525;
        if Result > 525 then
          Result := 25;
      end;
      if z = y then
      begin
        Result := Body[0].y + Body[0].Step.y;
        if Result < 25 then
          Result := 475;
        if Result > 475 then
          Result := 25;
      end;
    end;
    
    procedure Draw;
    begin
      FloodFill(Body[0].x, Body[0].y, clDarkTurquoise);
      for var i := 1 to High(Body) do
        FloodFill(Body[i].x, Body[i].y, clDarkCyan);
    end;
    
    procedure ReDraw;
    begin
      FloodFill(Body[0].x, Body[0].y, clDarkTurquoise);
      FloodFill(Body[1].x, Body[1].y, clDarkCyan);
      FloodFill(Body[High(Body)].x, Body[High(Body)].y, clDarkCyan);
    end;
    
    procedure Growth;
    begin
      SetLength(Body, High(Body) + 2);
      for var i := High(Body) downto 1 do
        Body[i] := Body[i - 1];
      Body[0].x := HeadPath(x);
      Body[0].y := HeadPath(y);
      Body[0].Step := Body[1].Step;
      ReDraw;
    end;
    
    procedure FoldCheck;
    begin
      for var i := 0 to High(Body) - 1 do
        if ((Body[i + 1].Step.x <> Body[i].Step.x) or (Body[i + 1].Step.y <> Body[i].Step.y)) then
          Body[i + 1].Fold := true;
    end;
    
    procedure Twist;
    begin
      FoldCheck;
      for var i := High(Body) downto 1 do
        if Body[i].Fold = true then
        begin
          Body[i].Step := Body[i - 1].Step;
          Body[i].Fold := false;
        end;
    end;
    
    procedure Move;
    begin
      for var i := 0 to High(Body) do
      begin
        if (i = High(Body)) and not ((HeadPath(x) = Body[High(Body)].x) and (HeadPath(y) = Body[High(Body)].y)) then
          FloodFill(Body[i].x, Body[i].y, clBlack);
        Body[i].x += Body[i].Step.x;
        Body[i].y += Body[i].Step.y;
      end;
      for var i := 0 to High(Body) do
      begin
        if Body[i].x < 25 then
          Body[i].x := 525;
        if Body[i].x > 525 then
          Body[i].x := 25;
        if Body[i].y < 25 then
          Body[i].y := 475;
        if Body[i].y > 475 then
          Body[i].y := 25;
      end;
      ReDraw;
      Twist;
      Sleep(200);
    end;
    
    destructor Death;
    begin
      SetLength(Body, 0);
    end;
  
  end;
  
  TStats = class(IDraw)
  private 
    Length, Score: word;
  
  public 
    constructor Create(Length: word);
    begin
      self.Length := Length;
      Score := 0;
      Draw;
    end;
    
    procedure Draw;
    begin
      SetBrushColor(clBlack);
      SetFontColor(clDarkGray);
      TextOut(60, 510, 'Длина: ' + Length.ToString);
      TextOut(390, 510, 'Очки: ' + Score.ToString);
    end;
    
    procedure ScoreUp;
    begin
      Inc(Length);
      Score += UpScore;
      Draw;
    end;
    
    destructor Clear;
    begin
      Length := 0;
      Score := 0;
    end;
  
  end;
  
  TField = class(IDraw)
  private 
    Back: ButtonABC;
  
  public 
    constructor Create;
    begin
      SetWindowSize(550, 550);
      Draw;
    end;
    
    procedure Draw;
    begin
      ClearWindow(clBlack);
      SetPenColor(clGray);
      for var i := 1 to 10 do
      begin
        Line(0, i * 50, 550, i * 50);
        Line(i * 50, 0, i * 50, 500);
      end;
      Back := new ButtonABC(225, 501, 100, 49, 'Назад', clGray);
    end;
    
    destructor Destroy;
    begin
      ClearWindow(clBlack);
      Back.Destroy;
    end;
  
  end;
  
  TMenu = class(IDraw)
  private 
    NewGame, CloseGame: ButtonABC;
  
  public 
    constructor Create;
    begin
      ClearWindow(clBlack);
      Draw;
    end;
    
    procedure Draw;
    begin
      NewGame := new ButtonABC(150, 65, 250, 100, 'Новая игра', clGray);
      CloseGame := new ButtonABC(150, 350, 250, 100, 'Выход', clGray);
      SetBrushColor(clBlack);
      SetFontColor(clGray);
      SetFontStyle(fsBoldItalicUnderline);
      TextOut(175, 210, 'Змейка');
    end;
    
    destructor Destroy;
    begin
      ClearWindow(clBlack);
      NewGame.Destroy;
      CloseGame.Destroy;
    end;
  
  end;
  
  TGame = class
  private 
    Menu: TMenu;
    Field: TField;
    Snake: TSnake;
    Food: TFood;
    Stats: TStats;
    HighScore: word := 0;
  
  public 
    constructor Create;
    begin
      SetWindowTitle('Змейка');
      SetWindowSize(550, 550);
      Window.IsFixedSize := true;
    end;
    
    procedure Start;
    begin
      Menu := new TMenu;
      if HighScore <> 0 then
      begin
        SetBrushColor(clBlack);
        SetFontColor(clGray);
        SetFontStyle(fsBoldItalic);
        SetFontSize(21);
        TextOut(205, 510, 'Рекорд: ' + HighScore.ToString);
      end;
      MenuEvent;
    end;
    
    procedure SetHighScore;
    begin
      if HighScore < Stats.Score then
        HighScore := Stats.Score;
    end;
    
    procedure NewFood;
    var
      x, y: word;
      same: boolean;
    begin
      repeat
        same := false;
        x := Random(1, 10) * 50 + 25;
        y := Random(1, 9) * 50 + 25;
        for var i := 0 to High(Snake.Body) do
          if (x = Snake.Body[i].x) and (y = Snake.Body[i].y) then
          begin
            same := true;
            break;
          end;
      until same = false;
      Food := new TFood(x, y);
    end;
    
    procedure NewGame;
    begin
      Menu.Destroy;
      Field := new TField;
      Snake := new TSnake;
      Stats := new TStats(High(Snake.Body) + 1);
      NewFood;
      GameEvent;
    end;
    
    procedure BackToMenu;
    begin
      SetHighScore;
      Stats.Clear;
      Food.Death;
      Snake.Death;
      Field.Destroy;
      Start;
    end;
    
    procedure MenuEvent;
    begin
      Menu.NewGame.OnClick += NewGame;
      Menu.CloseGame.OnClick += CloseWindow;
    end;
    
    function SnakeFeed: boolean;
    begin
      Result := false;
      if (Snake.HeadPath(x) = Food.x) and (Snake.HeadPath(y) = Food.y) then
      begin
        Result := true;
        Food.Death;
        Snake.Growth;
        Stats.ScoreUp;
        NewFood;
      end;
    end;
    
    procedure Control(Key: integer);
    var
      brake: boolean := true;
    begin
      case Key of
        VK_Up: 
          begin
            if Snake.Body[0].Step.y <> 50 then
            begin
              Snake.Body[0].Step.x := 0;
              Snake.Body[0].Step.y := -50;
              brake := false;
            end;
          end;
        VK_Down:
          begin
            if Snake.Body[0].Step.y <> -50 then
            begin
              Snake.Body[0].Step.x := 0;
              Snake.Body[0].Step.y := 50;
              brake := false;
            end;
          end;
        VK_Right:
          begin
            if Snake.Body[0].Step.x <> -50 then
            begin
              Snake.Body[0].Step.x := 50;
              Snake.Body[0].Step.y := 0;
              brake := false;
            end;
          end;
        VK_Left:
          begin
            if Snake.Body[0].Step.x <> 50 then
            begin
              Snake.Body[0].Step.x := -50;
              Snake.Body[0].Step.y := 0;
              brake := false;
            end;
          end;
      end;
      if not SnakeFeed then
        if not brake then
          if not EndGame then
            Snake.Move;
    end;
    
    procedure GameEvent;
    begin
      OnKeyDown := Control;
      Field.Back.OnClick += BackToMenu;  
    end;
    
    procedure WinGame;
    begin
      OnKeyDown := nil;
      SetHighScore;
      Field.Destroy;
      ClearWindow(clBlack);
      SetBrushColor(clBlack);
      SetFontColor(clDarkGray);
      SetFontStyle(fsBoldItalicUnderline);
      SetFontSize(42);
      TextOut(70, 190, 'Поздравляем!');
      SetFontStyle(fsBoldItalic);
      SetFontSize(27);
      TextOut(30, 290, 'Вы набрали максимальное');
      TextOut(100, 340, 'количество очков!');
      Stats.Clear;
      Sleep(1500);
      Start;
    end;
    
    procedure LoseGame;
    begin
      OnKeyDown := nil;
      SetHighScore;
      Field.Destroy;
      ClearWindow(clBlack);
      SetBrushColor(clBlack);
      SetFontColor(clDarkGray);
      SetFontStyle(fsBoldItalicUnderline);
      SetFontSize(42);
      TextOut(70, 210, 'Игра окончена.');
      SetFontStyle(fsBoldItalic);
      SetFontSize(27);
      TextOut(155, 300, 'Ваши очки: ' + Stats.Score.ToString);
      Stats.Clear;
      Sleep(1500);
      Start;
    end;
    
    function EndGame: boolean;
    begin
      Result := false;
      for var i := 1 to High(Snake.Body) do
        if (Snake.HeadPath(x) = Snake.Body[i].x + Snake.Body[i].Step.x) and (Snake.HeadPath(y) = Snake.Body[i].y + Snake.Body[i].Step.y) then
        begin
          Result := true;
          LoseGame;
        end
          else
        if Stats.Score >= MaxScore - StartLength * UpScore then
        begin
          Result := true;
          WinGame;
        end;
    end;
  end;
 
procedure Main();
var
  Game: TGame := new TGame;
begin
  Game.Start;
end;
 
begin
  Main();
end.