src/gohamster.pas

@@ -22,6 +22,9 @@ uses crt;
 { Implement snake animation }
 { Implement bobr animation }
 
+var
+    DebugTmp: integer = 2;
+
 const
       ArenaH = 33;
       ArenaW = 41;
@@ -36,6 +39,7 @@ const
       BorderSymbol = '#';
       HamsterSymbol = '*';
       TraceSymbol = '@';
+      VoidSymbol = '.';
       DelaySizeMs = 150;
       SpaceOrd = 32;
       EscOrd = 27;
@@ -57,11 +61,51 @@ type
     tracePtr = ^trace;
 
     trace = record
-        curX, curY: integer;
+        x, y: integer;
         prev: tracePtr
     end;
 
-    arena = array [1..ArenaH, 1..ArenaW] of boolean;
+    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 Debug;
+begin
+    GotoXY(2, DebugTmp);
+    writeln(DebugMsg);
+    DebugTmp := DebugTmp + 1
+end;
+
+procedure DebugCell(curCell: cellItemPtr);
+begin
+    GotoXY(2, DebugTmp);
+    writeln('Cur X: ', curCell^.x, ' Cur Y: ', curCell^.y);
+    DebugTmp := DebugTmp + 1
+end;
+
+procedure DebugPrintArena(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;
 
 function IsTerminalValid: boolean;
 begin
@@ -153,6 +197,15 @@ begin
     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
@@ -185,20 +238,256 @@ begin
     GotoXY(1, 1)
 end;
 
-procedure CutField(var t: tracePtr);
+function GetTraceLength(var t: tracePtr): integer;
-var
+begin
-    traceTmp: tracePtr;
+    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);
+begin
+    if (t^.x = 1) or (t^.x = ArenaW) then
+    begin
+        InitCell(figure1, t^.x, t^.y - 1);
+        InitCell(figure2, t^.x, t^.y + 1)
+    end
+    else
+    begin
+        InitCell(figure1, t^.x - 1, t^.y);
+        InitCell(figure2, t^.x + 1, t^.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 areaCaptured: integer;
+                        var borders, captured: arena);
+var
+    curCell: cellItemPtr;
+    q: QCell;
+begin
+    areaCaptured := 0;
+    QCellInit(q);
+    QCellPush(q, startCell);
+    captured[startCell.x][startCell.y] := true;
+    while not QCellIsEmpty(q) do
+    begin
+        areaCaptured := areaCaptured + 1;
+        curCell := QCellGet(q);
+        AddAvailableNeighbours(q, curCell, borders, captured);
+        {
+        clrscr;
+        writeln('x: ', curCell^.x, ' y: ', curCell^.y);
+        DebugPrintArena(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 borders[j][i] or captured[j][i] then
+                FillArenaCell(j, i, VoidSymbol)
+end;
+
+procedure CutField(var t: tracePtr; var arenaBorders, arenaCaptured: arena);
+var
+    areaCaptured1, areaCaptured2: integer;
+    figure1, figure2: cellItem;
+begin
+    GetFiguresCells(t, figure1, figure2);
+    CaptureFigure(figure1, areaCaptured1, arenaBorders, arenaCaptured);
+    CaptureFigure(figure2, areaCaptured2, arenaBorders, arenaCaptured);
+    if areaCaptured1 <= areaCaptured2 then
+        ReleaseFigure(figure2, arenaCaptured)
+    else
+        ReleaseFigure(figure1, arenaCaptured);
+
+    { Later move to another subroutine }
+    FillCaptured(arenaBorders, arenaCaptured)
+end;
+
+procedure RemoveTraceData(var t: tracePtr);
+var
+    tmpT: tracePtr;
 begin
-    GotoXY(2, 2);
-    writeln('        ');
-    GotoXY(2, 2);
-    writeln(t^.curX, ' ', t^.curY);
     while t <> nil do
     begin
-        FillArenaCell(t^.curX, t^.curY, ' ');
+        tmpT := t^.prev;
-        traceTmp := t^.prev;
         dispose(t);
-        t := traceTmp
+        t := tmpT
     end
 end;
 
@@ -207,7 +496,7 @@ begin
     if t = nil then
         IsTraceExists := false
     else
-    if (t^.curX = x) and (t^.curY = y) then
+    if (t^.x = x) and (t^.y = y) then
         IsTraceExists := true
     else
         IsTraceExists := IsTraceExists(t^.prev, x, y)
@@ -218,13 +507,15 @@ begin
     if t = nil then
         FindIdx := -1
     else
-    if (t^.curX = x) and (t^.curY = y) then
+    if (t^.x = x) and (t^.y = y) then
         FindIdx := curIdx
     else
         FindIdx := FindIdx(t^.prev, x, y, curIdx + 1)
 end;
 
-function HamsterMovePossible(var h: creature; var t: tracePtr): boolean;
+function { continue here }
+HamsterMovePossible(var h: creature; var t: tracePtr; var captured: arena):
+                                                                     boolean;
 var
     nextX, nextY, idx: integer;
 begin
@@ -294,13 +585,14 @@ var
     nextTrace: tracePtr;
 begin
     new(nextTrace);
-    nextTrace^.curX := nextX;
+    nextTrace^.x := nextX;
-    nextTrace^.curY := nextY;
+    nextTrace^.y := nextY;
     nextTrace^.prev := t;
     t := nextTrace
 end;
 
-procedure AddBorderTrace(var t: tracePtr; var hamster: creature; var a: arena);
+procedure
+AddBorderTrace(var t: tracePtr; var hamster: creature; var arenaBorders: arena);
 begin
     if hamster.dX = 2 then
         AddTrace(t, hamster.curX - 2, hamster.curY)
@@ -312,25 +604,19 @@ begin
         AddTrace(t, hamster.curX, hamster.curY - 2)
     else
         AddTrace(t, hamster.curX, hamster.curY + 2);
-    FillArenaCell(t^.curX, t^.curY, TraceSymbol);
+    FillArenaCell(t^.x, t^.y, TraceSymbol);
-    a[t^.curX][t^.curY] := true
+    arenaBorders[t^.x][t^.y] := true
 end;
 
 function IsOnTrace(var t: tracePtr; var cr: creature): boolean;
-var
-    tmp: tracePtr;
 begin
-    tmp := t;
+    if t = nil then
-    IsOnTrace := false;
+        IsOnTrace := false
-    while tmp <> nil do
+    else
-    begin
+    if (t^.x = cr.curX) and (t^.y = cr.curY) then
-        if (tmp^.curX = cr.curX) and (tmp^.curY = cr.curY) then
+        IsOnTrace := true
-        begin
+    else
-            IsOnTrace := true;
+        IsOnTrace := IsOnTrace(t^.prev, cr)
-            break
-        end;
-        tmp := tmp^.prev
-    end
 end;
 
 procedure PopTrace(var t: tracePtr);
@@ -344,37 +630,38 @@ end;
 
 procedure PopHamsterTrace(var t: tracePtr; var a: arena);
 begin
-    FillArenaCell(t^.curX, t^.curY, ' ');
+    FillArenaCell(t^.x, t^.y, ' ');
-    a[t^.curY][t^.curX] := false;
+    a[t^.x][t^.y] := false;
     PopTrace(t)
 end;
 
-procedure AddHamsterTrace(var t: tracePtr; var h: creature; var a: arena);
+procedure
+AddHamsterTrace(var t: tracePtr; var h: creature; var arenaBorders: arena);
 var
     nextX, nextY: integer;
 begin
-    if h.curX > t^.curX then
+    if h.curX > t^.x then
     begin   { to right }
-        nextX := t^.curX + 1;
+        nextX := t^.x + 1;
-        nextY := t^.curY
+        nextY := t^.y
     end
     else
-    if h.curX < t^.curX then
+    if h.curX < t^.x then
     begin   { to left }
-        nextX := t^.curX - 1;
+        nextX := t^.x - 1;
-        nextY := t^.curY
+        nextY := t^.y
     end
     else
-    if h.curY > t^.curY then
+    if h.curY > t^.y then
     begin   { to down }
-        nextX := t^.curX;
+        nextX := t^.x;
-        nextY := t^.curY + 1
+        nextY := t^.y + 1
     end
     else
-    if h.curY < t^.curY then
+    if h.curY < t^.y then
     begin   { to up }
-        nextX := t^.curX;
+        nextX := t^.x;
-        nextY := t^.curY - 1
+        nextY := t^.y - 1
     end
     else
     begin
@@ -382,33 +669,35 @@ begin
         nextY := h.curY
     end;
     AddTrace(t, nextX, nextY);
-    FillArenaCell(t^.curX, t^.curY, TraceSymbol);
+    FillArenaCell(t^.x, t^.y, TraceSymbol);
-    a[t^.curY][t^.curX] := true
+    arenaBorders[t^.x][t^.y] := true
 end;
 
 procedure
 ChangeHamsterTrace(var t: tracePtr; var h: creature;
-                   var a: arena; var redrawArena: boolean);
+                   var arenaBorders: arena; var redrawArena: boolean);
 var
     i: integer;
 begin
     if IsOnTrace(t, h) then
     begin
-        if t^.prev = nil then       { Hamster backed to border }
+        for i := 1 to HamsterDelta do
-            PopHamsterTrace(t, a)
+            PopHamsterTrace(t, arenaBorders);
-        else
+        if GetTraceLength(t) = 1 then
-            for i := 1 to HamsterDelta do
+        begin
-                PopHamsterTrace(t, a)
+            PopHamsterTrace(t, arenaBorders);
+            redrawArena := true
+        end
     end
     else
     begin
         if t = nil then
         begin
-            AddBorderTrace(t, h, a);
+            AddBorderTrace(t, h, arenaBorders);
             redrawArena := true
         end;
         for i := 1 to HamsterDelta do
-            AddHamsterTrace(t, h, a)
+            AddHamsterTrace(t, h, arenaBorders)
     end
 end;
 
@@ -441,11 +730,13 @@ end;
 procedure RunLevel;
 var
     hamster: creature;
-    arenaCells: arena;
+    arenaCaptured, arenaBorders: arena;
     hamsterTrace: tracePtr = nil;
     continueLevel: boolean = true;
     redrawArena: boolean = false;
 begin
+    FillArena(arenaCaptured, false);
+    FillArena(arenaBorders, false);
     InitiateCreature(hamster, 5, 1, 0, 0, HamsterSymbol);
     FillArenaCell(hamster.curX, hamster.curY, hamster.symbol);
     while continueLevel do
@@ -454,11 +745,14 @@ begin
         if (hamsterTrace <> nil) and IsOnBorder(hamster) and
             (hamsterTrace^.prev <> nil) then
         begin
-            CutField(hamsterTrace)
+            CutField(hamsterTrace, arenaBorders, arenaCaptured);
+            RemoveTraceData(hamsterTrace);
+            DrawArena;
+            FillArenaCell(hamster.curX, hamster.curY, hamster.symbol)
         end;
         if keypressed then
             HandleKey(hamster, continueLevel);
-        if not HamsterMovePossible(hamster, hamsterTrace) then
+        if not HamsterMovePossible(hamster, hamsterTrace, arenaCaptured) then
             StopCreature(hamster);
         if (hamster.dX = 0) and (hamster.dY = 0) then
             continue;
@@ -470,7 +764,7 @@ begin
         if IsOnBorder(hamster) and (hamsterTrace = nil) then
             redrawArena := true
         else
-            ChangeHamsterTrace(hamsterTrace, hamster, arenaCells, redrawArena);
+            ChangeHamsterTrace(hamsterTrace, hamster, arenaBorders, redrawArena);
         if redrawArena then
         begin
             DrawArena;