gh-scrum/src/gohamster.pas

program go_hamster;
uses crt;

{ Implement figure cuts (check CutField) }
{ Implement interface }
    { Implement lifes }
    { Implement bar }
    { Implement score }
{ Implement bonuses }
    { Implement hamster speed up }
    { Implement life up }
{ Implement ghost }
{ Implement creature death }
    { Implement enemy slow }

{ Implement sun }
{ Implement snake }
{ Implement bobr }
{ Implement hamster animation }
{ Implement ghost animation }
{ Implement sun animation }
{ Implement snake animation }
{ Implement bobr animation }

var
    DebugTmp: integer = 2;

const
      ArenaH = 33;
      ArenaW = 41;
      InterfaceH = 6;
      CellSize = 2;
      BorderSize = 1;
      ScreenW = (ArenaW - 1) * CellSize + BorderSize * 2; { 80 }
      ScreenH = (ArenaH + InterfaceH) * CellSize + BorderSize;
      WidthCoefficient = 2;
      MinScreenW = ScreenW * WidthCoefficient; 
      InterfaceBarH = ScreenW - ArenaH * CellSize - BorderSize * 2; { 14 }
      BorderSymbol = '#';
      HamsterSymbol = '*';
      TraceSymbol = '@';
      VoidSymbol = '.';
      DelaySizeMs = 150;
      SpaceOrd = 32;
      EscOrd = 27;
      CtrlCOrd = 3;
      ArrowLeftOrd = -75;
      ArrowRightOrd = -77;
      ArrowDownOrd = -80;
      ArrowUpOrd = -72;
      PreviousTraceIdx = 3;
      HamsterDelta = 2;
      DebugMsg = '==============bObr=kUrwa=============';

type
    creature = record
        curX, curY, dX, dY: integer;
        symbol: char
    end;

    tracePtr = ^trace;

    trace = record
        x, y: integer;
        prev: tracePtr
    end;

    arena = array [1..ArenaW, 1..ArenaH] of boolean;

    cellItemPtr = ^cellItem;

    cellItem = record
        x, y: integer;
        next: cellItemPtr
    end;
    
    QCell = record
        first, last: cellItemPtr
    end;

procedure DebugCell(curCell: cellItemPtr);
begin
    GotoXY(2, DebugTmp);
    writeln('Cur X: ', curCell^.x, ' Cur Y: ', curCell^.y);
    DebugTmp := DebugTmp + 1
end;

procedure DebugOrArenas(var a, b: arena);
var
    i, j: integer;
begin
    for i := 1 to ArenaH do
    begin
        for j := 1 to ArenaW do
            if a[j][i] or b[j][i] then
                write(1, ' ')
            else
                write(0, ' ');
        writeln
    end
end;

procedure DebugPrintArena(var a: arena);
var
    i, j: integer;
begin
    for i := 1 to ArenaH do
    begin
        for j := 1 to ArenaW do
            if a[j][i] then
                write(1, ' ')
            else
                write(0, ' ');
        writeln
    end
end;

function IsTerminalValid: boolean;
begin
    IsTerminalValid := (ScreenWidth >= ScreenW) and (ScreenHeight >= ScreenH)
end;

procedure PrintTerminalHelp;
begin
    writeln('Increase your terminal size and try again.');
    if ScreenWidth < ScreenW then
    begin
        writeln('Your terminal width: ', ScreenWidth,
                '. Required: ', ScreenW, '.')
    end;
    if ScreenHeight < ScreenH then
    begin
        writeln('Your terminal height: ', ScreenHeight,
                '. Required: ', ScreenH, '.')
    end
end;

procedure GetKey(var keyCode: integer);
var 
    c: char;
begin
    c := ReadKey;
    if c = #0 then
    begin
        c := ReadKey;
        keyCode := -ord(c)
    end
    else
    begin
        keyCode := ord(c)
    end
end;

procedure DrawLineX(x, y, len: integer);
var
    i: integer;
begin
    GotoXY(x, y);
    for i := 1 to len do
        write(BorderSymbol);
    GotoXY(1, 1)
end;

procedure DrawLineY(x, y, len: integer);
var
    i: integer;
begin
    for i := 1 to len do
    begin
        GotoXY(x, y + i - 1);
        write(BorderSymbol)
    end;
    GotoXY(1, 1)
end;

procedure DrawRectangle(x0, y0, h, w: integer);
var
    i: integer;
begin
    DrawLineX(x0, y0, w);
    for i := 1 to h - 2 do
    begin
        GotoXY(x0, y0 + i);
        write(BorderSymbol);
        GotoXY(x0 + w - 1, y0 + i);
        write(BorderSymbol)
    end;
    DrawLineX(x0, y0 + h - 1, w);
    GotoXY(1, 1)
end;

procedure DrawInterface;
var
    cellW: integer = ScreenW div 3;
begin
    DrawLineX(1, InterfaceBarH, ScreenW * WidthCoefficient);
    DrawLineY(cellW * WidthCoefficient, 1, InterfaceBarH);
    DrawLineY(cellW * 2 * WidthCoefficient + 1, 1, InterfaceBarH)
end;

procedure DrawInterface(ScreenH, ScreenW: integer);
begin
    DrawRectangle(1, 1, ScreenH, ScreenW * WidthCoefficient);
    DrawInterface
end;

procedure FillArena(var a: arena; val: boolean);
var
    i, j: integer;
begin
    for i := 1 to ArenaW do
        for j := 1 to ArenaH do
            a[i][j] := val
end;

procedure
InitiateCreature(var cr: creature; curX, curY, dX, dY: integer; symbol: char);
begin
    cr.curX := curX;
    cr.curY := curY;
    cr.dX := dX;
    cr.dY := dY;
    cr.symbol := symbol
end;

function IsOnEdge(var cr: creature): boolean;
begin
    IsOnEdge :=
        (cr.curX = 1) or (cr.curX = ArenaW) or (cr.curY = 1) or 
        (cr.curY = ArenaH)
end;

function IsOnBorder(var cr: creature; var borders, captured: arena): boolean;
begin
    IsOnBorder :=  
        borders[cr.curX][cr.curY] and (
            captured[cr.curX - 1][cr.curY + 1] or
            captured[cr.curX - 1][cr.curY - 1] or
            captured[cr.curX + 1][cr.curY + 1] or
            captured[cr.curX + 1][cr.curY - 1]
        )
end;

procedure FillArenaCell(arenaX, arenaY: integer; symbol: char);
var
    i, screenX, screenY: integer;
begin
    screenX := BorderSize + (arenaX - 1) * CellSize * WidthCoefficient;
    screenY := InterfaceBarH + (arenaY - 1) * CellSize;
    GotoXY(screenX, screenY);
    for i := 1 to CellSize * WidthCoefficient  do
        write(symbol);
    GotoXY(screenX, screenY + 1); { later change to nested for }
    for i := 1 to CellSize * WidthCoefficient  do
        write(symbol);
    GotoXY(1, 1)
end;

function GetTraceLength(var t: tracePtr): integer;
begin
    if t = nil then
        GetTraceLength := 0
    else
        GetTraceLength := 1 + GetTraceLength(t^.prev)
end;

function NewCellItem(x, y: integer): cellItemPtr;
var
    newCell: cellItemPtr;
begin
    new(newCell);
    newCell^.x := x;
    newCell^.y := y;
    newCell^.next := nil;
    NewCellItem := newCell
end;

procedure InitCell(var c: cellItem; x, y: integer);
begin
    c.x := x;
    c.y := y;
    c.next := nil
end;

procedure GetFiguresCells(var t: tracePtr; var figure1, figure2: cellItem;
                          var captured: arena);
var
    prevTrace: tracePtr;
begin
    prevTrace := t^.prev;
    {if (t^.x = 1) or (t^.x = ArenaW) or
        (t^.y <> 1) and captured[prevTrace^.x][prevTrace^.y - 1] or
        (t^.y <> ArenaH) and captured[prevTrace^.x][prevTrace^.y + 1] then}
    if t^.y = prevTrace^.y then 
    begin
        InitCell(figure1, prevTrace^.x, prevTrace^.y - 1);
        InitCell(figure2, prevTrace^.x, prevTrace^.y + 1)
    end
    else
    begin
        InitCell(figure1, prevTrace^.x - 1, prevTrace^.y);
        InitCell(figure2, prevTrace^.x + 1, prevTrace^.y)
    end
end;

procedure QCellInit(var q: QCell);
begin
    q.first := nil;
    q.last := nil
end;

procedure QCellPush(var q: QCell; var c: cellItem);
begin
    if q.last = nil then
    begin
        new(q.first);
        q.first^.x := c.x;
        q.first^.y := c.y;
        q.first^.next := nil;
        q.last := q.first
    end
    else
    begin
        new(q.last^.next);
        q.last := q.last^.next;
        q.last^.x := c.x;
        q.last^.y := c.y;
        q.last^.next := nil
    end
end;

function QCellIsEmpty(var q: QCell): boolean;
begin
    QCellIsEmpty := (q.last = nil)
end;

function QCellGet(var q: QCell): cellItemPtr;
begin
    QCellGet := q.first
end;

function IsCellFree(x, y: integer; var borders, captured: arena): boolean;
begin
    IsCellFree := 
        (x <> 0) and (x <> ArenaW + 1) and
        (y <> 0) and (y <> ArenaH + 1) and
        not captured[x][y] and not borders[x][y]
end;

procedure QCellPop(var q: QCell);
var
    removeItem: cellItemPtr;
begin
    removeItem := QCellGet(q);
    q.first := removeItem^.next;
    if q.first = nil then
        q.last := q.first;
    dispose(removeItem)
end;

procedure AddAvailableNeighbours(var q: QCell; var curCell: cellItemPtr;
                                 var borders, captured: arena);
var
    addCell: cellItem;
begin
    if IsCellFree(curCell^.x - 1, curCell^.y, borders, captured) then
    begin
        InitCell(addCell, curCell^.x - 1, curCell^.y);
        captured[addCell.x][addCell.y] := true;
        QCellPush(q, addCell)
    end;
    if IsCellFree(curCell^.x + 1, curCell^.y, borders, captured) then
    begin
        InitCell(addCell, curCell^.x + 1, curCell^.y);
        captured[addCell.x][addCell.y] := true;
        QCellPush(q, addCell)
    end;
    if IsCellFree(curCell^.x, curCell^.y - 1, borders, captured) then
    begin
        InitCell(addCell, curCell^.x, curCell^.y - 1);
        captured[addCell.x][addCell.y] := true;
        QCellPush(q, addCell)
    end;
    if IsCellFree(curCell^.x, curCell^.y + 1, borders, captured) then
    begin
        InitCell(addCell, curCell^.x, curCell^.y + 1);
        captured[addCell.x][addCell.y] := true;
        QCellPush(q, addCell)
    end
end;

{ Kind of bfs algorithm. }
procedure CaptureFigure(var startCell: cellItem; var capturedN: integer;
                        var borders, captured: arena);
var
    curCell: cellItemPtr;
    q: QCell;
begin
    capturedN := 0;
    QCellInit(q);
    QCellPush(q, startCell);
    captured[startCell.x][startCell.y] := true;
    while not QCellIsEmpty(q) do
    begin
        capturedN := capturedN + 1;
        curCell := QCellGet(q);
        AddAvailableNeighbours(q, curCell, borders, captured);
        {
        clrscr;
        writeln('x: ', curCell^.x, ' y: ', curCell^.y);
        DebugOrArenas(borders, captured);
        }
        QCellPop(q)
    end
end;

function IsCellCaptured(x, y: integer; var captured: arena): boolean;
begin
    IsCellCaptured :=
        (x <> 0) and (x <> ArenaW + 1) and
        (y <> 0) and (y <> ArenaH + 1) and
        captured[x][y]
end;

procedure BfsReleaseCell(x, y: integer; var q: QCell; var captured: arena);
var
    addCell: cellItem;
begin
    InitCell(addCell, x, y);
    QCellPush(q, addCell);
    captured[x][y] := false
end;

procedure AddCapturedNeighbours(var q: QCell; var curCell: cellItemPtr;
                                var captured: arena);
var
    addCell: cellItem;
begin
    if IsCellCaptured(curCell^.x - 1, curCell^.y, captured) then
    begin
        InitCell(addCell, curCell^.x - 1, curCell^.y);
        captured[addCell.x][addCell.y] := false;
        QCellPush(q, addCell)
    end;
    if IsCellCaptured(curCell^.x + 1, curCell^.y, captured) then
    begin
        InitCell(addCell, curCell^.x + 1, curCell^.y);
        captured[addCell.x][addCell.y] := false;
        QCellPush(q, addCell)
    end;
    if IsCellCaptured(curCell^.x, curCell^.y - 1, captured) then
    begin
        InitCell(addCell, curCell^.x, curCell^.y - 1);
        captured[addCell.x][addCell.y] := false;
        QCellPush(q, addCell)
    end;
    if IsCellCaptured(curCell^.x, curCell^.y + 1, captured) then
    begin
        InitCell(addCell, curCell^.x, curCell^.y + 1);
        captured[addCell.x][addCell.y] := false;
        QCellPush(q, addCell)
    end
end;

procedure ReleaseFigure(var startCell: cellItem; var captured: arena);
var
    curCell: cellItemPtr;
    q: QCell;
begin
    QCellInit(q);
    QCellPush(q, startCell);
    while not QCellIsEmpty(q) do
    begin
        curCell := QCellGet(q);
        AddCapturedNeighbours(q, curCell, captured);
        QCellPop(q)
    end
end;

procedure FillCaptured(var borders, captured: arena);
var
    i, j: integer;
begin
    for i := 1 to ArenaH do
        for j := 1 to ArenaW do
            if captured[j][i] then
                FillArenaCell(j, i, VoidSymbol)
            else
            if borders[j][i] then
                FillArenaCell(j, i, BorderSymbol)
end;

procedure CutField(var t: tracePtr; var borders, captured: arena);
var
    captured1, captured2: integer;
    figure1, figure2: cellItem;
begin
    GetFiguresCells(t, figure1, figure2, captured);
    if captured[figure1.x][figure1.y] then
    begin
        CaptureFigure(figure2, captured2, borders, captured)
    end
    else
    if captured[figure2.x][figure2.y] then
    begin
        CaptureFigure(figure1, captured1, borders, captured)
    end
    else
    begin
        CaptureFigure(figure1, captured1, borders, captured);
        CaptureFigure(figure2, captured2, borders, captured);
        if captured1 <= captured2 then
            ReleaseFigure(figure2, captured)
        else
            ReleaseFigure(figure1, captured)
    end;

    { Later move to another subroutine }
    FillCaptured(borders, captured)
end;

procedure RemoveCutedBorders(var borders, captured: arena);
var
    i, j: integer;
begin
    for i := 1 to ArenaH do
        for j := 1 to ArenaW do
            if borders[j][i] and
                (((j = 1) or (i = 1) or captured[j - 1][i - 1] or borders[j - 1][i - 1]) and
                ((i = 1) or captured[j + 1][i - 1] or borders[j + 1][i - 1]) and
                ((j = 1) or captured[j - 1][i + 1] or borders[j - 1][i + 1]) and
                (captured[j + 1][i + 1] or borders[j + 1][i + 1])) then
            begin
                borders[j][i] := false;
                captured[j][i] := true;
                FillArenaCell(j, i, VoidSymbol)
            end
end;

procedure DisposeTraces(var t: tracePtr);
var
    tmpT: tracePtr;
begin
    while t <> nil do
    begin
        tmpT := t^.prev;
        dispose(t);
        t := tmpT
    end
end;

function IsTraceExists(var t: tracePtr; x, y: integer): boolean;
begin
    if t = nil then
        IsTraceExists := false
    else
    if (t^.x = x) and (t^.y = y) then
        IsTraceExists := true
    else
        IsTraceExists := IsTraceExists(t^.prev, x, y)
end;

function FindTraceIdx(var t: tracePtr; x, y, curIdx: integer): integer;
begin
    if t = nil then
        FindTraceIdx := -1
    else
    if (t^.x = x) and (t^.y = y) then
        FindTraceIdx := curIdx
    else
        FindTraceIdx := FindTraceIdx(t^.prev, x, y, curIdx + 1)
end;

function Clamp(val, min, max: integer): integer;
begin
    Clamp := val;
    if val < min then
        Clamp := min;
    if val > max then
        Clamp := max
end;

function { continue here }
HamsterMovePossible(var h: creature; var t: tracePtr; var captured: arena):
                                                                     boolean;
var
    nextX, nextY, idx: integer;
begin
    nextX := Clamp(h.curX + h.dX, 1, ArenaW);
    nextY := Clamp(h.curY + h.dY, 1, ArenaH);
    idx := FindTraceIdx(t, nextX, nextY, 1);
    HamsterMovePossible :=
        (idx <= PreviousTraceIdx) and not captured[nextX][nextY]
end;

procedure StopCreature(var cr: creature);
begin
    cr.dX := 0;
    cr.dY := 0
end;

procedure DrawArenaEdge;
begin
    DrawRectangle(1, InterfaceBarH,
                  ScreenH - InterfaceBarH + 1, ScreenW * WidthCoefficient)
end;

procedure DrawArenaBorders(var borders: arena);
var
    i, j: integer;
begin
    for i := 1 to ArenaH do
        for j := 1 to ArenaW do
            if borders[j][i] then
                FillArenaCell(j, i, BorderSymbol)
end;

procedure UpdateDelta(keyCode: integer; var cr: creature); { Refactor later }
begin
    case keyCode of
        ArrowLeftOrd:
        begin
            cr.dX := -HamsterDelta;
            cr.dY := 0
        end;
        ArrowRightOrd:
        begin
            cr.dX := HamsterDelta;
            cr.dY := 0
        end;
        ArrowUpOrd:
        begin
            cr.dX := 0;
            cr.dY := -HamsterDelta
        end;
        ArrowDownOrd:
        begin
            cr.dX := 0;
            cr.dY := HamsterDelta
        end;
        SpaceOrd:
            StopCreature(cr)
    end
end;

procedure MoveCreature(var cr: creature);
begin
    cr.curX := Clamp(cr.curX + cr.dX, 1, ArenaW);
    cr.curY := Clamp(cr.curY + cr.dY, 1, ArenaH)
end;

procedure AddTrace(var t: tracePtr; nextX, nextY: integer);
var
    nextTrace: tracePtr;
begin
    new(nextTrace);
    nextTrace^.x := nextX;
    nextTrace^.y := nextY;
    nextTrace^.prev := t;
    t := nextTrace
end;

procedure
AddBorderTrace(var t: tracePtr; var hamster: creature; var borders: arena);
begin
    if hamster.dX = 2 then
        AddTrace(t, hamster.curX - 2, hamster.curY)
    else
    if hamster.dX = -2 then
        AddTrace(t, hamster.curX + 2, hamster.curY)
    else
    if hamster.dY = 2 then
        AddTrace(t, hamster.curX, hamster.curY - 2)
    else
        AddTrace(t, hamster.curX, hamster.curY + 2);
    FillArenaCell(t^.x, t^.y, TraceSymbol);
    borders[t^.x][t^.y] := true
end;

function IsOnTrace(var t: tracePtr; var cr: creature): boolean;
begin
    if t = nil then
        IsOnTrace := false
    else
    if (t^.x = cr.curX) and (t^.y = cr.curY) then
        IsOnTrace := true
    else
        IsOnTrace := IsOnTrace(t^.prev, cr)
end;

procedure PopTrace(var t: tracePtr);
var
    tmpPrev: tracePtr;
begin
    tmpPrev := t^.prev;
    dispose(t);
    t := tmpPrev
end;

procedure PopHamsterTrace(var t: tracePtr; var a: arena);
begin
    FillArenaCell(t^.x, t^.y, ' ');
    a[t^.x][t^.y] := false;
    PopTrace(t)
end;

procedure
AddHamsterTrace(var t: tracePtr; var h: creature; var borders: arena);
var
    nextX, nextY: integer;
begin
    if h.curX > t^.x then
    begin   { to right }
        nextX := t^.x + 1;
        nextY := t^.y
    end
    else
    if h.curX < t^.x then
    begin   { to left }
        nextX := t^.x - 1;
        nextY := t^.y
    end
    else
    if h.curY > t^.y then
    begin   { to down }
        nextX := t^.x;
        nextY := t^.y + 1
    end
    else
    if h.curY < t^.y then
    begin   { to up }
        nextX := t^.x;
        nextY := t^.y - 1
    end
    else
    begin
        nextX := h.curX;
        nextY := h.curY
    end;
    AddTrace(t, nextX, nextY);
    FillArenaCell(t^.x, t^.y, TraceSymbol);
    borders[t^.x][t^.y] := true
end;

procedure
ChangeHamsterTrace(var t: tracePtr; var h: creature;
                   var borders: arena; var redrawEdge: boolean);
var
    i: integer;
begin
    if IsOnTrace(t, h) then
    begin
        for i := 1 to HamsterDelta do
            PopHamsterTrace(t, borders);
        if GetTraceLength(t) = 1 then
        begin
            PopHamsterTrace(t, borders);
            redrawEdge := true
        end
    end
    else
    begin
        if t = nil then
        begin
            AddBorderTrace(t, h, borders);
            redrawEdge := true
        end;
        for i := 1 to HamsterDelta do
            AddHamsterTrace(t, h, borders)
    end
end;

procedure HandleKey(var hamster: creature; var continueLevel: boolean);
var
    keyCode: integer;
begin
    GetKey(keyCode);
    if (keyCode = ArrowLeftOrd) or (keyCode = ArrowRightOrd) or
        (keyCode = ArrowUpOrd) or (keyCode = ArrowDownOrd) or
        (keyCode = SpaceOrd) then
    begin
        UpdateDelta(keyCode, hamster)
    end;
    if (keyCode = EscOrd) or (keyCode = CtrlCOrd) then
        continueLevel := false
end;

procedure PrintHamsterDebug(var hamster: creature);
var
    i: integer;
begin
    GotoXY(2, 2);
    for i := 1 to 20 do
        write(' ');
    GotoXY(2, 2);
    writeln(hamster.curX, ' ', hamster.curY, ' ', hamster.dX, ' ', hamster.dY)
end;

procedure RunLevel;
var
    hamster: creature;
    captured, borders: arena;
    hamsterTrace: tracePtr = nil;
    continueLevel: boolean = true;
    redrawEdge: boolean = false;
    redrawBorders: boolean = false;
begin
    FillArena(captured, false);
    FillArena(borders, false);
    InitiateCreature(hamster, 5, 1, 0, 0, HamsterSymbol);
    FillArenaCell(hamster.curX, hamster.curY, hamster.symbol);
    while continueLevel do
    begin
        delay(DelaySizeMs);
        if (hamsterTrace <> nil) and 
            (IsOnBorder(hamster, borders, captured) or IsOnEdge(hamster)) and
            (hamsterTrace^.prev <> nil) then
        begin
            CutField(hamsterTrace, borders, captured);
            RemoveCutedBorders(borders, captured);
            DisposeTraces(hamsterTrace);
            DrawArenaBorders(borders);
            DrawArenaEdge;
            FillArenaCell(hamster.curX, hamster.curY, hamster.symbol);
            {debug}
            {
            clrscr;
            DebugOrArenas(borders, captured)
            }
        end;
        if keypressed then
            HandleKey(hamster, continueLevel);
        if not HamsterMovePossible(hamster, hamsterTrace, captured) then
            StopCreature(hamster);
        if (hamster.dX = 0) and (hamster.dY = 0) then
            continue;
        if not IsOnEdge(hamster) and
            not IsOnBorder(hamster, borders, captured) then
        begin
            FillArenaCell(hamster.curX, hamster.curY, TraceSymbol)
        end
        else
        begin
            FillArenaCell(hamster.curX, hamster.curY, ' ')
        end;
        MoveCreature(hamster);
        if IsOnEdge(hamster) and (hamsterTrace = nil) then
            redrawEdge := true
        else
        if IsOnBorder(hamster, borders, captured) and (hamsterTrace = nil) then
            redrawBorders := true
        else
            ChangeHamsterTrace(hamsterTrace, hamster, borders, redrawEdge);
        if redrawEdge then
        begin
            DrawArenaEdge;
            redrawEdge := false
        end;
        if redrawBorders then
        begin
            DrawArenaBorders(borders);
            redrawBorders := false
        end;
        FillArenaCell(hamster.curX, hamster.curY, hamster.symbol)
    end
end;

begin
    if not IsTerminalValid then
    begin
        PrintTerminalHelp;
        exit
    end;
    clrscr;
    DrawInterface(ScreenH, ScreenW);
    RunLevel;
end.