НИИ МЛЯ
(прокрастинация. профанация. прострация.)
На главную Отдел ИИ Отдел ПА Отдел РП Лаборатория ЕН Лаборатория ЭХ
Лаборатория разработки программ

Free Pascal - Игра "Змейка"

(Принято к публикации 2014-11-26)

Змейка. Просто Змейка. Винтажная Змейка в текстовом терминале. Ну не чудо ли?

PROGRAM snake;

USES SysUtils, Crt, Math;

CONST
    gameWidth  = 40; { ширина игрового поля, включая левую стену }
    gameHeight = 20; { высота игрового поля, включая верхнюю стену }

{ тип данных для хранения змейки - односвязный список }
TYPE
    PZmeikaSegment = ^TZmeikaSegment;
    TZmeikaSegment = record
        x, y :Integer;
        next :PZmeikaSegment;
        end;

VAR
    k, c           :Char;
    Zmeika         :PZmeikaSegment;
    prevz, z       :PZmeikaSegment;
    lastTick       :TDateTime;
    i,
    bonusx, bonusy :Integer;
    timerStop      :Boolean;

{ окончание игры - рисуем гамовер и останавливаем таймер }
PROCEDURE GameOver();
BEGIN
gotoXY(gameWidth div 2 - 4, gameHeight div 2);
TextColor(LightRed);
Write('GAME OVER');
timerStop := True;
gotoXY(1, 1);
END;

{ создание бонуса }
PROCEDURE MakeBonus(restrictedx, restrictedy :Integer);
VAR
    allOk        :Boolean;
    z            :PZmeikaSegment;
    i            :Integer;
BEGIN

{ выбираем новые координаты бонуса }
REPEAT
    bonusx := Floor(Random()*(gameWidth  - 1)) + 2;
    bonusy := Floor(Random()*(gameHeight - 1)) + 2;
UNTIL (bonusx <> restrictedx) or (bonusy <> restrictedy);

{ проверяем, что бонус не попал на змейку, и при необходимости циклически сдвигаем его координаты }
i := 0;
allOk := False;
WHILE not(allOk) and (i < gameWidth * gameHeight) DO
    BEGIN
    allOk := True;
    z := Zmeika;
    WHILE(z <> nil) DO
        BEGIN
        allOk := allOk and ((z^.x <> bonusx) or (z^.y <> bonusy));
        z := z^.next;
        END;
    IF not(allOk) THEN
        BEGIN
        inc(bonusx);
        IF (bonusx > gameWidth) THEN
            BEGIN
            bonusx := 2;
            inc(bonusy);
            END;
        IF (bonusy > gameHeight) THEN
            bonusy := 2;
        END;
    inc(i);
    END;

{ если бонус так и не удалось впихнуть на поле, завершаем игру }
IF i >= gameWidth * gameHeight THEN
    BEGIN
    GameOver();
    Exit;
    END;

{ рисуем вновь созданный бонус на поле }
gotoXY(bonusx, bonusy);
TextColor(Yellow);
Write('B');
END;

{ движение змейки - смещение на dx, dy }
PROCEDURE MoveZmeika(Zmeika :PZmeikaSegment; dx, dy :Integer);
VAR
    nextx, nexty,
    swapx, swapy :Integer;
    z            :PZmeikaSegment;
    allOk        :Boolean;
BEGIN

IF (Zmeika <> nil) THEN
    BEGIN
    nextx := Zmeika^.x + dx;
    nexty := Zmeika^.y + dy;

    { проверяем, что змейка не укусила сама себя }
    IF (dx <> 0) or (dy <> 0) THEN
        BEGIN
        allOk := True;
        z := Zmeika;
        WHILE(z <> nil) DO
            BEGIN
            allOk := allOk and ((nextx <> z^.x) or (nexty <> z^.y));
            z := z^.next;
            END;
        IF not(allOk) THEN
            GameOver();
        END;

    { проверяем, не сожрала ли змейка бонус, и при необходимости удлиняем её }
    IF (bonusx = nextx) and (bonusy = nexty) THEN
        BEGIN
        z := Zmeika;
        WHILE(z^.next <> nil) DO z := z^.next;
        new(z^.next);
        z := z^.next;
        z^.x := -1;
        z^.y := -1;
        z^.next := nil;
        MakeBonus(nextx, nexty);
        END;
    END;

{ смещаем сегменты змейки, при необходимости затирая след }
WHILE(Zmeika <> nil) DO
    BEGIN
    IF (Zmeika^.next = nil) and (Zmeika^.x >= 0) THEN
        BEGIN
        gotoXY(Zmeika^.x, Zmeika^.y);
        Write(' ');
        END;
    swapx := Zmeika^.x;
    swapy := Zmeika^.y;
    Zmeika^.x := nextx;
    Zmeika^.y := nexty;
    nextx := swapx;
    nexty := swapy;
    gotoXY(Zmeika^.x, Zmeika^.y);
    TextColor(LightGreen);
    Write('S');
    Zmeika := Zmeika^.next;
    END;
gotoXY(1, 1);
END;

{ двигаем змейку вверх, проверяя столкновекние с верхней стеной }
PROCEDURE MoveUp();
BEGIN
IF (Zmeika^.y > 1) THEN
    MoveZmeika(Zmeika, 0, -1)
ELSE
    GameOver();
END;

{ двигаем змейку вниз, проверяя столкновекние с нижней стеной }
PROCEDURE MoveDown();
BEGIN
IF (Zmeika^.y < gameHeight) THEN
    MoveZmeika(Zmeika, 0, 1)
ELSE
    GameOver();
END;

{ двигаем змейку влево, проверяя столкновекние с левой стеной }
PROCEDURE MoveLeft();
BEGIN
IF (Zmeika^.x > 1) THEN
    MoveZmeika(Zmeika, -1, 0)
ELSE
    GameOver();
END;

{ двигаем змейку вправо, проверяя столкновекние с правой стеной }
PROCEDURE MoveRight();
BEGIN
IF (Zmeika^.x < gameWidth) THEN
    MoveZmeika(Zmeika, 1, 0)
ELSE
    GameOver();
END;

{ основная программа }
BEGIN

{ очищаем экран }
ClrScr();

{ рисуем стены и пишем подсказку }
textColor(Brown);
FOR i := 1 TO gameWidth + 1 DO
    BEGIN
    gotoXY(i, 1);
    Write('W');
    gotoXY(i, gameHeight+1);
    Write('W');
    END;
FOR i := 1 TO gameHeight + 1 DO
    BEGIN
    gotoXY(1, i);
    Write('W');
    gotoXY(gameWidth+1, i);
    Write('W');
    END;
textColor(LightGray);
gotoXY(1, gameHeight+2);
Write('wasd - move snake, m - quit');

Randomize();

{ создаем змейку }
new(Zmeika);
Zmeika^.x := gameWidth  div 2;
Zmeika^.y := gameHeight div 2;
Zmeika^.next := nil;

{ создаем бонус }
MakeBonus(Zmeika^.x, Zmeika^.y);

{ выводим змейку на экран }
MoveZmeika(Zmeika, 0, 0);

{ организуем основной цикл }
timerStop := False;
lastTick := 0;

k := ' ';

WHILE (k <> 'm') DO
    BEGIN

    { проверяем нажатие клавиш }
    IF KeyPressed() THEN
        BEGIN
        c := ReadKey();
        IF (c in ['w', 'a', 's', 'd', 'm']) THEN
            k := c;
        END;

    { если прошло достаточно времени, двигаем змейку и обрабатываем нажатые клавиши }
    IF (Now() - lastTick > 1.0/(24.0*3600.0*5.0)) and not(timerStop) THEN
        BEGIN

        CASE k OF
        'w' : MoveUp();
        'a' : MoveLeft();
        's' : MoveDown();
        'd' : MoveRight();
        END;
        {k := ' '; - если раскомментировать, игра станет пошаговой}

        lastTick := Now();

        END;

    END;
{ конец основного цикла }

{ очищаем память из-под змейки }
WHILE (Zmeika <> nil) DO
    BEGIN
    z := Zmeika;
    prevz := z;
    WHILE(z^.next <> nil) DO
        BEGIN
        prevz := z;
        z := z^.next;
        END;
    dispose(z);
    IF (prevz <> z) THEN
        prevz^.next := nil
    ELSE
        Zmeika := nil;
    END;

END.