gre-ilya/gh-scrum
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request 'feat/TD-008-add-enemy-ghost' (#7) from dev into main

Browse Source 
Reviewed-on: #7
This commit is contained in:
gre-ilya 2026-02-28 10:58:13 +00:00
commit 8e319d6e70
12 changed files with 1269 additions and 853 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Makefile
View File

@ -1,6 +1,8 @@
FPC = fpc FPC = fpc
GAME_SRC = gohamster.pas GAME_SRC = gohamster.pas arena_m.pas cell_m.pas creature_m.pas debug_m.pas \
ghost_m.pas graphics_m.pas hamster_m.pas keys_m.pas math_m.pas \
trace_m.pas
all: gohamster all: gohamster
@ -11,4 +13,4 @@ gohamster: $(GAME_SRC)
$(FPC) $@.pas $(FPC) $@.pas
clean: clean:
rm *.o gohamster rm *.o *.ppu gohamster

457
src/arena_m.pas Normal file
View File

@ -0,0 +1,457 @@
unit arena_m;
interface
uses creature_m, trace_m, hamster_m, debug_m;
const
ArenaH = 33;
ArenaW = 41;
CaptureSymbol = '.';
BorderSymbol = '|';
ArenaSymbol = ' ';
type
arenaBooleanMatrix = array [1..ArenaW, 1..ArenaH] of boolean;
arena = record
captured, borders: arenaBooleanMatrix;
end;
function ArenaSplited(var h: creature; var t: tracePtr; var a: arena): boolean;
procedure CutSmallerPart(var hamster: creature; var t: tracePtr; var a: arena);
function GhostShouldTurn(var g: creature; var a: arena): boolean;
function
HamsterStepPossible(var h: creature; var t: tracePtr; var a: arena): boolean;
procedure Init(var a: arena);
function IsOnBorder(var x, y: integer; var a: arena): boolean;
function IsOnEdge(var cr: creature): boolean;
function IsOnEdge(x, y: integer): boolean;
procedure MakeEnemyStep(var e: creature; var a: arena);
procedure MakeHamsterStep(var h: creature; var t: tracePtr; var a: arena);
procedure SetArenaBorder(var t: tracePtr; var a: arena);
procedure TurnGhost(var g: creature; var a: arena);
implementation
uses cell_m, graphics_m, math_m;
procedure Fill(var m: arenaBooleanMatrix; val: boolean);
var
i, j: integer;
begin
for i := 1 to ArenaW do
for j := 1 to ArenaH do
m[i][j] := val
end;
procedure Init(var a: arena);
begin
Fill(a.captured, false);
Fill(a.borders, false)
end;
function IsCellFree(x, y: integer; var a: arena): boolean;
begin
IsCellFree :=
(x <> 0) and (x <> ArenaW + 1) and
(y <> 0) and (y <> ArenaH + 1) and
not a.captured[x][y] and not a.borders[x][y]
end;
procedure ReleaseArenaCells(var q: QCell; var a: arena);
var
cell: cellItemPtr;
begin
while not QCellIsEmpty(q) do
begin
cell := QCellGet(q);
a.captured[cell^.x][cell^.y] := false;
QCellPop(q)
end
end;
procedure TryAddCell(x, y: integer; var q: QCell; var a: arena);
var
cell: cellItem;
begin
if IsCellFree(x, y, a) then
begin
InitCell(cell, x, y);
QCellPush(q, cell)
end
end;
{ bfs algo iteration }
procedure AddAvailableNeighbours(var q: QCell; var curCell: cellItem;
var a: arena);
var
x, y: integer;
begin
x := curCell.x;
y := curCell.y;
TryAddCell(x - 1, y, q, a);
TryAddCell(x + 1, y, q, a);
TryAddCell(x, y - 1, q, a);
TryAddCell(x, y + 1, q, a)
end;
{ Kind of bfs algorithm. }
function GetFigureArea(var partCell: cellItem; var a: arena): integer;
var
cellPtr: cellItemPtr;
cell: cellItem;
captureQ, releaseQ: QCell;
result: integer = 0;
begin
QCellInit(captureQ);
QCellInit(releaseQ);
QCellPush(captureQ, partCell);
while not QCellIsEmpty(captureQ) do
begin
cellPtr := QCellGet(captureQ);
InitCell(cell, cellPtr^.x, cellPtr^.y);
QCellPop(captureQ);
if a.captured[cell.x][cell.y] then
continue;
result := result + 1;
a.captured[cell.x][cell.y] := true;
AddAvailableNeighbours(captureQ, cell, a);
QCellPush(releaseQ, cell)
end;
ReleaseArenaCells(releaseQ, a);
GetFigureArea := result
end;
procedure CutPart(var partCell: cellItem; var a: arena);
var
cellPtr: cellItemPtr;
cell: cellItem;
captureQ: QCell;
begin
QCellInit(captureQ);
QCellPush(captureQ, partCell);
while not QCellIsEmpty(captureQ) do
begin
cellPtr := QCellGet(captureQ);
InitCell(cell, cellPtr^.x, cellPtr^.y);
QCellPop(captureQ);
if a.captured[cell.x][cell.y] then
continue;
a.captured[cell.x][cell.y] := true;
DrawArenaCell(cell.x, cell.y, CaptureSymbol);
AddAvailableNeighbours(captureQ, cell, a)
end
end;
function OnEdgeX(x: integer): boolean;
begin
OnEdgeX := (x = 1) or (x = ArenaW)
end;
function OnEdgeY(y: integer): boolean;
begin
OnEdgeY := (y = 1) or (y = ArenaH)
end;
function IsOnEdge(x, y: integer): boolean;
begin
IsOnEdge := (OnEdgeX(x) or OnEdgeY(y))
end;
function YNeighborsCaptured(x, y: integer; var a: arena): boolean;
begin
YNeighborsCaptured :=
not OnEdgeY(y) and a.captured[x][y - 1] and a.captured[x][y + 1]
end;
function XNeighborsCaptured(x, y: integer; var a: arena): boolean;
begin
XNeighborsCaptured :=
not OnEdgeX(x) and a.captured[x + 1][y] and a.captured[x - 1][y]
end;
function DiagonalNeighborsCaptured(x, y: integer; var a: arena): boolean;
begin
DiagonalNeighborsCaptured :=
not IsOnEdge(x, y) and
a.captured[x - 1][y - 1] and a.captured[x - 1][y + 1] and
a.captured[x + 1][y - 1] and a.captured[x + 1][y + 1]
end;
function ArenaCellCaptured(x, y: integer; var a: arena): boolean;
begin
ArenaCellCaptured :=
XNeighborsCaptured(x, y, a) or YNeighborsCaptured(x, y, a) or
DiagonalNeighborsCaptured(x, y, a)
end;
procedure CaptureArenaBorder(x, y: integer; var a: arena);
begin
a.borders[x][y] := false;
a.captured[x][y] := true;
DrawArenaCell(x, y, CaptureSymbol)
end;
procedure CaptureCutBorders(var a: arena); { rename, slow }
var
i, j: integer;
begin
for i := 1 to ArenaH do
for j := 1 to ArenaW do
if a.borders[j][i] and ArenaCellCaptured(j, i, a) then
CaptureArenaBorder(j, i, a)
end;
procedure SetArenaBorder(var t: tracePtr; var a: arena);
begin
if t = nil then
exit;
a.borders[t^.x][t^.y] := true;
SetArenaBorder(t^.prev, a)
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 x, y: integer; var a: arena): boolean;
begin
IsOnBorder :=
a.borders[x][y] and (
a.captured[x - 1][y + 1] or
a.captured[x - 1][y - 1] or
a.captured[x + 1][y + 1] or
a.captured[x + 1][y - 1]
)
end;
function IsOnBorder(var cr: creature; var a: arena): boolean;
begin
IsOnBorder :=
a.borders[cr.curX][cr.curY] and (
a.captured[cr.curX - 1][cr.curY + 1] or
a.captured[cr.curX - 1][cr.curY - 1] or
a.captured[cr.curX + 1][cr.curY + 1] or
a.captured[cr.curX + 1][cr.curY - 1]
)
end;
function ArenaSplited(var h: creature; var t: tracePtr; var a: arena): boolean;
begin
ArenaSplited :=
(t <> nil) and (IsOnBorder(h, a) or IsOnEdge(h)) and (t^.prev <> nil)
end;
procedure GetPartsCells(var t: tracePtr; var part1, part2: cellItem;
var a: arena);
var
prevTrace: tracePtr;
begin
prevTrace := t^.prev;
if t^.y = prevTrace^.y then
begin
InitCell(part1, prevTrace^.x, prevTrace^.y - 1);
InitCell(part2, prevTrace^.x, prevTrace^.y + 1)
end
else
begin
InitCell(part1, prevTrace^.x - 1, prevTrace^.y);
InitCell(part2, prevTrace^.x + 1, prevTrace^.y)
end
end;
function StepOnTrace(var hamster: creature; var t: tracePtr): boolean;
var
nextX, nextY, idx: integer;
begin
nextX := Clamp(hamster.curX + hamster.dX, 1, ArenaW);
nextY := Clamp(hamster.curY + hamster.dY, 1, ArenaH);
idx := FindIndex(t, nextX, nextY, 1);
StepOnTrace := idx > PreviousTraceIdx
end;
function StepBeyondEdge(var cr: creature): boolean;
begin
StepBeyondEdge :=
(cr.dX > 0) and (cr.curX = ArenaW) or
(cr.dX < 0) and (cr.curX = 1) or
(cr.dY > 0) and (cr.curY = ArenaH) or
(cr.dY < 0) and (cr.curY = 1)
end;
procedure CutSmallerPart(var hamster: creature; var t: tracePtr; var a: arena);
var {refactor?}
area1, area2: integer;
part1, part2, smallerFigure: cellItem;
begin
GetPartsCells(t, part1, part2, a);
area1 := GetFigureArea(part1, a);
area2 := GetFigureArea(part2, a);
if area1 <= area2 then
smallerFigure := part1
else
smallerFigure := part2;
CutPart(smallerFigure, a);
CaptureCutBorders(a);
DrawArenaBorders(a);
DrawArenaEdges;
DrawCreature(hamster);
Delete(t)
end;
function
HamsterStepPossible(var h: creature; var t: tracePtr; var a: arena):
boolean;
var
nextX, nextY, midX, midY: integer;
begin
nextX := Clamp(h.curX + h.dX, 1, ArenaW);
nextY := Clamp(h.curY + h.dY, 1, ArenaH);
midX := Clamp(h.curX + (h.dX div 2), 1, ArenaW);
midY := Clamp(h.curY + (h.dY div 2), 1, ArenaH);
HamsterStepPossible :=
not StepOnTrace(h, t)
and (not a.captured[midX][midY] or IsOnEdge(nextX, nextY))
and not StepBeyondEdge(h)
and not (
not IsOnEdge(h) and a.borders[h.curX][h.curY] and
a.captured[midX][midY]
)
end;
function
FieldToEdge(var hamster: creature; var t: tracePtr; var a: arena): boolean;
var
midX, midY: integer;
begin
midX := hamster.curX - (hamster.dX div 2);
midY := hamster.curY - (hamster.dY div 2);
FieldToEdge :=
IsOnEdge(hamster) and (t = nil) and not a.captured[midX][midY] and
not a.borders[hamster.curX][hamster.curY] and
not (IsOnEdge(midX, midY))
end;
function
IsOnField(var hamster: creature; var t: tracePtr; var a: arena): boolean;
var
midX, midY: integer;
begin
midX := hamster.curX - (hamster.dX div 2);
midY := hamster.curY - (hamster.dY div 2);
IsOnField :=
not (IsOnEdge(hamster) and (t = nil)) and
not a.captured[hamster.curX][hamster.curY] and
not a.borders[midX][midY]
end;
procedure MakeHamsterStep(var h: creature; var t: tracePtr; var a: arena);
begin
MakeStep(h);
if FieldToEdge(h, t, a) or IsOnField(h, t, a) then
ChangeHamsterTrace(h, t);
DrawAfterStep(h, t, a)
end;
function GhostShouldTurn(var g: creature; var a: arena): boolean;
var
nextX, nextY: integer;
begin
nextX := g.curX + g.dX;
nextY := g.curY + g.dY;
GhostShouldTurn := IsOnEdge(nextX, nextY) or a.borders[nextX][nextY]
end;
function BorderY(nextX, nextY: integer; var a: arena): boolean;
begin
BorderY :=
a.borders[nextX][nextY] and
(a.borders[nextX][nextY - 1] or a.borders[nextX][nextY + 1])
end;
function BorderX(nextX, nextY: integer; var a: arena): boolean;
begin
BorderX :=
a.borders[nextX][nextY] and
(a.borders[nextX - 1][nextY] or a.borders[nextX + 1][nextY])
end;
function IsCorner(x, y: integer; var a: arena): boolean;
begin
IsCorner := BorderX(x, y, a) and BorderY(x, y, a)
end;
function IsConcaveCorner(x, y: integer; var a: arena): boolean;
begin
IsConcaveCorner :=
a.borders[x - 1][y] and a.borders[x][y + 1] or
a.borders[x - 1][y] and a.borders[x][y - 1] or
a.borders[x + 1][y] and a.borders[x][y + 1] or
a.borders[x + 1][y] and a.borders[x][y - 1]
end;
function IsConvexCorner(var cr: creature; var a: arena): boolean;
var
x, y, nextX, nextY: integer;
begin
x := cr.curX;
y := cr.curY;
nextX := x + cr.dX;
nextY := y + cr.dY;
IsConvexCorner :=
IsCorner(nextX, nextY, a) and
not IsOnEdge(nextX, nextY) and
not IsConcaveCorner(x, y, a)
end;
procedure CornerTurn(var cr: creature; var a: arena);
var
x, y, nextX, nextY: integer;
begin
x := cr.curX;
y := cr.curY;
nextX := x + cr.dX;
nextY := y + cr.dY;
if not a.borders[nextX][y] and not a.borders[x][nextY] then
begin
cr.dX := cr.dX * -1;
cr.dY := cr.dY * -1
end
else
if a.borders[nextX][y] then
cr.dX := cr.dX * -1
else
cr.dY := cr.dY * -1
end;
procedure TurnGhost(var g: creature; var a: arena);
var
nextX, nextY: integer;
begin
nextX := g.curX + g.dX;
nextY := g.curY + g.dY;
if IsConvexCorner(g, a) then
begin
CornerTurn(g, a)
end
else
begin
if OnEdgeX(nextX) or BorderY(nextX, nextY, a) then
g.dX := g.dX * -1;
if OnEdgeY(nextY) or BorderX(nextX, nextY, a) then
g.dY := g.dY * -1
end
end;
procedure MakeEnemyStep(var e: creature; var a: arena);
begin
MakeStep(e);
DrawAfterStep(e, a)
end;
end.

80
src/cell_m.pas Normal file
View File

@ -0,0 +1,80 @@
unit cell_m;
interface
type
cellItemPtr = ^cellItem;
cellItem = record
x, y: integer;
next: cellItemPtr
end;
QCell = record
first, last: cellItemPtr
end;
procedure InitCell(var c: cellItem; x, y: integer);
procedure QCellInit(var q: QCell);
procedure QCellPush(var q: QCell; var c: cellItem);
function QCellIsEmpty(var q: QCell): boolean;
function QCellGet(var q: QCell): cellItemPtr;
procedure QCellPop(var q: QCell);
implementation
procedure InitCell(var c: cellItem; x, y: integer);
begin
c.x := x;
c.y := y;
c.next := nil
end;
procedure QCellInit(var q: QCell);
begin
q.first := nil;
q.last := nil
end;
procedure QCellPush(var q: QCell; var c: cellItem);
var
tmp: cellItemPtr;
begin
new(tmp);
tmp^.x := c.x;
tmp^.y := c.y;
tmp^.next := nil;
if q.last = nil then
begin
q.first := tmp;
q.last := q.first
end
else
begin
q.last^.next := tmp;
q.last := q.last^.next
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;
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;
end.

42
src/creature_m.pas Normal file
View File

@ -0,0 +1,42 @@
unit creature_m;
interface
type
creature = record
curX, curY, dX, dY: integer;
symbol: char
end;
procedure
InitCreature(var cr: creature; curX, curY, dX, dY: integer; symbol: char);
procedure StopCreature(var cr: creature);
procedure MakeStep(var cr: creature);
implementation
uses arena_m, math_m;
procedure
InitCreature(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;
procedure StopCreature(var cr: creature);
begin
cr.dX := 0;
cr.dY := 0
end;
procedure MakeStep(var cr: creature);
begin
cr.curX := Clamp(cr.curX + cr.dX, 1, ArenaW);
cr.curY := Clamp(cr.curY + cr.dY, 1, ArenaH)
end;
end.

66
src/debug_m.pas Normal file
View File

@ -0,0 +1,66 @@
unit debug_m;
interface
uses {arena_m,} cell_m, creature_m;
procedure Debug;
procedure DebugCell(cell: cellItemPtr);
{procedure Print(var m: arenaBooleanMatrix);}
procedure PrintCreatureDebug(var cr: creature);
implementation
uses crt;
const
DebugMsg = '===============DEBUG===============';
var
DebugTmp: integer = 2;
procedure Debug;
begin
GotoXY(2, DebugTmp);
writeln(DebugMsg);
DebugTmp := DebugTmp + 1
end;
procedure DebugCell(cell: cellItemPtr);
begin
GotoXY(2, DebugTmp);
writeln('Cur X: ', cell^.x, ' Cur Y: ', cell^.y);
DebugTmp := DebugTmp + 1
end;
{
procedure Print(var m: arenaBooleanMatrix);
var
i, j: integer;
begin
for i := 1 to ArenaH do
begin
for j := 1 to ArenaW do
if m[j][i] then
write(1, ' ')
else
write(0, ' ');
writeln
end;
GotoXY(1, 1)
end;
}
procedure PrintCreatureDebug(var cr: creature);
var
i: integer;
begin
GotoXY(2, 2);
for i := 1 to 20 do
write(' ');
GotoXY(2, 2);
writeln(cr.curX, ' ', cr.curY, ' ', cr.dX, ' ', cr.dY)
end;
end.

25
src/ghost_m.pas Normal file
View File

@ -0,0 +1,25 @@
unit ghost_m;
interface
uses creature_m;
const
GhostStartX = 5;
GhostStartY = 5;
GhostDelta = 1;
GhostStartDX = GhostDelta;
GhostStartDY = GhostDelta;
GhostSymbol = 'g';
procedure InitGhost(var g: creature);
implementation
procedure InitGhost(var g: creature);
begin
InitCreature(g, GhostStartX, GhostStartY,
GhostStartDX, GhostStartDY, GhostSymbol)
end;
end.

875
src/gohamster.pas
View File

@ -1,867 +1,39 @@
program go_hamster; program go_hamster;
uses crt; uses crt, arena_m, trace_m, creature_m, graphics_m, hamster_m, keys_m, ghost_m,
debug_m;
{ 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 const
ArenaH = 33; DelaySizeMs = 75;
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; procedure RunLevel;
var var
hamster: creature; h, g: creature;
captured, borders: arena; a: arena;
hamsterTrace: tracePtr = nil; t: tracePtr = nil;
continueLevel: boolean = true; continueLevel: boolean = true;
redrawEdge: boolean = false;
redrawBorders: boolean = false;
begin begin
FillArena(captured, false); Init(a);
FillArena(borders, false); InitHamster(h);
InitiateCreature(hamster, 5, 1, 0, 0, HamsterSymbol); InitGhost(g);
FillArenaCell(hamster.curX, hamster.curY, hamster.symbol); DrawCreature(h);
DrawCreature(g);
while continueLevel do while continueLevel do
begin begin
delay(DelaySizeMs); delay(DelaySizeMs);
if (hamsterTrace <> nil) and if ArenaSplited(h, t, a) then
(IsOnBorder(hamster, borders, captured) or IsOnEdge(hamster)) and
(hamsterTrace^.prev <> nil) then
begin begin
CutField(hamsterTrace, borders, captured); SetArenaBorder(t, a);
RemoveCutedBorders(borders, captured); CutSmallerPart(h, t, a)
DisposeTraces(hamsterTrace);
DrawArenaBorders(borders);
DrawArenaEdge;
FillArenaCell(hamster.curX, hamster.curY, hamster.symbol);
{debug}
{
clrscr;
DebugOrArenas(borders, captured)
}
end; end;
if keypressed then if keypressed then
HandleKey(hamster, continueLevel); HandleKey(h, continueLevel, a, t);
if not HamsterMovePossible(hamster, hamsterTrace, captured) then if not HamsterStepPossible(h, t, a) then
StopCreature(hamster); StopCreature(h);
if (hamster.dX = 0) and (hamster.dY = 0) then if not ((h.dX = 0) and (h.dY = 0)) then
continue; MakeHamsterStep(h, t, a);
if not IsOnEdge(hamster) and MakeEnemyStep(g, a);
not IsOnBorder(hamster, borders, captured) then if GhostShouldTurn(g, a) then
begin TurnGhost(g, a)
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
end; end;
@ -872,6 +44,7 @@ begin
exit exit
end; end;
clrscr; clrscr;
DrawInterface(ScreenH, ScreenW); DrawLevel;
RunLevel; RunLevel;
clrscr
end. end.

277
src/graphics_m.pas Normal file
View File

@ -0,0 +1,277 @@
unit graphics_m;
interface
uses arena_m, creature_m, hamster_m, trace_m;
procedure DrawAfterStep(var hamster: creature; var t: tracePtr; var a: arena);
procedure DrawAfterStep(var cr: creature; var a: arena);
procedure DrawArenaBorders(var a: arena);
procedure DrawArenaCell(arenaX, arenaY: integer; symbol: char);
procedure DrawArenaEdges;
procedure DrawCreature(var cr: creature);
procedure DrawLevel;
procedure EraseTrace(var hamster: creature; t: tracePtr);
function IsTerminalValid: boolean;
procedure PrintTerminalHelp;
implementation
uses crt, math_m;
const
InterfaceH = 6;
CellSize = 2;
BorderSize = 1;
ScreenW = (ArenaW - 1) * CellSize + BorderSize * 2; { 79 }
ScreenH = (ArenaH + InterfaceH) * CellSize + BorderSize;
WidthCoefficient = 2;
InterfaceBarH = ScreenW - ArenaH * CellSize - BorderSize * 2; { 14 }
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 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 DrawLevel;
begin
DrawRectangle(1, 1, ScreenH, ScreenW * WidthCoefficient);
DrawInterface
end;
procedure DrawArenaCell(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;
procedure DrawArenaEdges;
begin
DrawRectangle(1, InterfaceBarH,
ScreenH - InterfaceBarH + 1, ScreenW * WidthCoefficient)
end;
procedure DrawLeftEdge(y: integer);
var
terminalY: integer;
begin
y := Clamp(y, 1, ArenaH);
terminalY := InterfaceBarH + (y - 1) * CellSize;
DrawLineY(1, terminalY, CellSize)
end;
procedure DrawRightEdge(y: integer);
var
terminalY: integer;
begin
y := Clamp(y, 1, ArenaH);
terminalY := InterfaceBarH + (y - 1) * CellSize;
DrawLineY(ScreenW * WidthCoefficient, terminalY, CellSize)
end;
procedure DrawUpperEdge(x: integer);
var
terminalX, sizeX: integer;
begin
x := Clamp(x, 1, ArenaW);
terminalX := (x - 1) * CellSize * WidthCoefficient + 1;
sizeX := CellSize * WidthCoefficient;
DrawLineX(terminalX, InterfaceBarH, sizeX)
end;
procedure DrawLowerEdge(x: integer);
var
terminalX, sizeX: integer;
begin
x := Clamp(x, 1, ArenaW);
terminalX := (x - 1) * CellSize * WidthCoefficient + 1;
sizeX := CellSize * WidthCoefficient;
DrawLineX(terminalX, InterfaceBarH + ArenaH * CellSize - 1, sizeX)
end;
procedure DrawArenaBorders(var a: arena);
var
i, j: integer;
begin
for i := 1 to ArenaH do
for j := 1 to ArenaW do
if a.borders[j][i] then
DrawArenaCell(j, i, BorderSymbol)
end;
procedure EraseTrace(var hamster: creature; t: tracePtr);
var
i: integer;
begin
for i := 1 to HamsterDelta do
begin
DrawArenaCell(t^.x, t^.y, ArenaSymbol);
t := t^.prev
end;
if GetLength(t) = 1 then
begin
if IsOnEdge(hamster) then
DrawArenaCell(t^.x, t^.y, ArenaSymbol)
else
DrawArenaCell(t^.x, t^.y, BorderSymbol)
end
end;
procedure EraseCell(x, y: integer);
begin
DrawArenaCell(x, y, ArenaSymbol)
end;
procedure DrawEdge(x, y: integer; var a: arena);
begin
if a.captured[x][y] then
DrawArenaCell(x, y, CaptureSymbol)
else
DrawArenaCell(x, y, ArenaSymbol);
if x = 1 then
DrawLeftEdge(y);
if x = ArenaW then
DrawRightEdge(y);
if y = 1 then
DrawUpperEdge(x);
if y = ArenaH then
DrawLowerEdge(x)
end;
procedure DrawCreature(var cr: creature);
begin
DrawArenaCell(cr.curX, cr.curY, cr.symbol)
end;
procedure
DrawPreviousCell(var hamster: creature; var t: tracePtr; var a: arena);
var
prevX, prevY: integer;
begin
prevX := hamster.curX - hamster.dX;
prevY := hamster.curY - hamster.dY;
if t = nil then
DrawEdge(prevX, prevY, a);
if (a.borders[prevX][prevY]) and (t = nil) then
DrawArenaCell(prevX, prevY, BorderSymbol)
end;
procedure DrawStepTrace(t: tracePtr);
var
i: integer;
begin
for i := 1 to HamsterDelta do
begin
t := t^.prev;
DrawArenaCell(t^.x, t^.y, TraceSymbol)
end
end;
procedure DrawAfterStep(var hamster: creature; var t: tracePtr; var a: arena);
var
prevX, prevY: integer;
begin
prevX := hamster.curX - hamster.dX;
prevY := hamster.curY - hamster.dY;
if IsOnEdge(prevX, prevY) and a.captured[prevX][prevY] then
DrawArenaCell(prevX, prevY, CaptureSymbol)
else
if IsOnBorder(prevX, prevY, a) then
DrawArenaCell(prevX, prevY, BorderSymbol)
else
DrawArenaCell(prevX, prevY, ArenaSymbol);
if t <> nil then
DrawStepTrace(t);
DrawCreature(hamster);
DrawPreviousCell(hamster, t, a)
end;
procedure DrawAfterStep(var cr: creature; var a: arena);
var
prevX, prevY: integer;
begin
prevX := cr.curX - cr.dX;
prevY := cr.curY - cr.dY;
if IsOnEdge(prevX, prevY) and a.captured[prevX][prevY] then
DrawArenaCell(prevX, prevY, CaptureSymbol)
else
if IsOnBorder(prevX, prevY, a) then
DrawArenaCell(prevX, prevY, BorderSymbol)
else
DrawArenaCell(prevX, prevY, ArenaSymbol);
DrawCreature(cr)
end;
end.

25
src/hamster_m.pas Normal file
View File

@ -0,0 +1,25 @@
unit hamster_m;
interface
uses creature_m;
const
HamsterStartX = 5;
HamsterStartY = 1;
HamsterStartDX = 0;
HamsterStartDY = 0;
HamsterDelta = 2;
HamsterSymbol = 'h';
procedure InitHamster(var h: creature);
implementation
procedure InitHamster(var h: creature);
begin
InitCreature(h, HamsterStartX, HamsterStartY,
HamsterStartDX, HamsterStartDY, HamsterSymbol)
end;
end.

91
src/keys_m.pas Normal file
View File

@ -0,0 +1,91 @@
unit keys_m;
interface
uses crt, creature_m, arena_m, trace_m, hamster_m, debug_m;
const
SpaceOrd = 32;
EscOrd = 27;
CtrlCOrd = 3;
ArrowLeftOrd = -75;
ArrowRightOrd = -77;
ArrowDownOrd = -80;
ArrowUpOrd = -72;
{ Debug }
BOrd = 98;
COrd = 99;
LOrd = 108;
{ Debug }
procedure GetKey(var keyCode: integer);
procedure HandleKey(var h: creature; var continueLevel: boolean;
var a: arena; var t: tracePtr);
implementation
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 ChangeHamsterDelta(keyCode: integer; var h: creature);
begin
h.dX := 0;
h.dY := 0;
case keyCode of
ArrowLeftOrd:
h.dX := -HamsterDelta;
ArrowRightOrd:
h.dX := HamsterDelta;
ArrowUpOrd:
h.dY := -HamsterDelta;
ArrowDownOrd:
h.dY := HamsterDelta;
SpaceOrd:
StopCreature(h)
end
end;
procedure HandleKey(var h: creature; var continueLevel: boolean;
var a: arena; var t: tracePtr);
var
keyCode: integer;
begin
GetKey(keyCode);
{
if keyCode = BOrd then
Print(a.borders);
if keyCode = COrd then
Print(a.captured);
if keyCode = LOrd then
begin
GotoXY(2, 60);
write(' ');
GotoXY(2, 60);
writeln(GetLength(t));
GotoXY(1, 1)
end;
}
if (keyCode = ArrowLeftOrd) or (keyCode = ArrowRightOrd) or
(keyCode = ArrowUpOrd) or (keyCode = ArrowDownOrd) or
(keyCode = SpaceOrd) then
begin
ChangeHamsterDelta(keyCode, h)
end;
if (keyCode = EscOrd) or (keyCode = CtrlCOrd) then
continueLevel := false
end;
end.

29
src/math_m.pas Normal file
View File

@ -0,0 +1,29 @@
unit math_m;
interface
function Clamp(val, min, max: integer): integer;
function Signum(a, b: integer): integer;
implementation
function Clamp(val, min, max: integer): integer;
begin
Clamp := val;
if val < min then
Clamp := min;
if val > max then
Clamp := max
end;
function Signum(a, b: integer): integer;
begin
if a < b then
Signum := -1
else
if a > b then
Signum := 1
else
Signum := 0
end;
end.

149
src/trace_m.pas Normal file
View File

@ -0,0 +1,149 @@
unit trace_m;
interface
uses creature_m, math_m, hamster_m;
const
PreviousTraceIdx = 3;
TraceSymbol = '+';
type
tracePtr = ^trace;
trace = record
x, y: integer;
prev: tracePtr
end;
procedure ChangeHamsterTrace(var h: creature; var t: tracePtr);
procedure DecreaseTrace(var hamster: creature; var t: tracePtr);
procedure Delete(var t: tracePtr);
function FindIndex(var t: tracePtr; x, y, curIdx: integer): integer;
function GetLength(var t: tracePtr): integer;
procedure IncreaseTrace(var hamster: creature; var t: tracePtr);
function IsOnTrace(var cr: creature; var t: tracePtr): boolean;
procedure Pop(var t: tracePtr);
implementation
uses graphics_m;
function GetLength(var t: tracePtr): integer;
begin
if t = nil then
GetLength := 0
else
GetLength := 1 + GetLength(t^.prev)
end;
procedure Delete(var t: tracePtr);
var
tmpT: tracePtr;
begin
while t <> nil do
begin
tmpT := t^.prev;
dispose(t);
t := tmpT
end
end;
function FindIndex(var t: tracePtr; x, y, curIdx: integer): integer;
begin
if t = nil then
FindIndex := -1
else
if (t^.x = x) and (t^.y = y) then
FindIndex := curIdx
else
FindIndex := FindIndex(t^.prev, x, y, curIdx + 1)
end;
procedure Add(var t: tracePtr; x, y: integer);
var
nextTrace: tracePtr;
begin
new(nextTrace);
nextTrace^.x := x;
nextTrace^.y := y;
nextTrace^.prev := t;
t := nextTrace
end;
procedure Pop(var t: tracePtr);
var
tmpPrev: tracePtr;
begin
tmpPrev := t^.prev;
dispose(t);
t := tmpPrev
end;
function IsOnTrace(var cr: creature; var t: tracePtr): 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(cr, t^.prev)
end;
procedure AddStepTrace(var h: creature; var t: tracePtr);
var
nextX, nextY, dX, dY: integer;
begin
dX := Signum(h.curX, t^.x);
dY := Signum(h.curY, t^.y);
nextX := t^.x + dX;
nextY := t^.y + dY;
Add(t, nextX, nextY)
end;
procedure AddFirstTrace(var hamster: creature; var t: tracePtr);
var
traceX, traceY, dX, dY: integer;
begin
dX := Signum(hamster.curX - hamster.dX, hamster.curX) * HamsterDelta;
dY := Signum(hamster.curY - hamster.dY, hamster.curY) * HamsterDelta;
traceX := hamster.curX + dX;
traceY := hamster.curY + dY;
Add(t, traceX, traceY)
end;
procedure IncreaseTrace(var hamster: creature; var t: tracePtr);
var
i: integer;
begin
if t = nil then
AddFirstTrace(hamster, t);
for i := 1 to HamsterDelta do
AddStepTrace(hamster, t)
end;
procedure DecreaseTrace(var hamster: creature; var t: tracePtr);
var
i: integer;
begin
for i := 1 to HamsterDelta do
Pop(t);
if GetLength(t) = 1 then
Pop(t)
end;
procedure ChangeHamsterTrace(var h: creature; var t: tracePtr);
begin
if IsOnTrace(h, t) then
begin
EraseTrace(h, t);
DecreaseTrace(h, t)
end
else
begin
IncreaseTrace(h, t)
end
end;
end.