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

init

Browse Source
This commit is contained in:
gre-ilya 2025-11-24 20:34:27 +05:00
commit 2f436d8e89
18 changed files with 2616 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored Normal file
View File

@ -0,0 +1,4 @@
*.swp
*.o
*.ppu

14
Makefile Normal file
View File

@ -0,0 +1,14 @@
compile:
fpc src/go
play:
./src/go
# After that you can use in VIM Ctrl-] and Ctrl-^ on functions and procedures
tags:
ctags src/*
cd src/ && ctags *
wc:
cat src/*.pas | wc -l

23
README.md Normal file
View File

@ -0,0 +1,23 @@
# Go Hamster
Это калька на игру с телефона Samsung SGH-S500 под названием Go! Hamster,
играл в неё в далёком детстве :). Решил реализовать в качестве этюда.
Инструментом для реализации выбрал Object Pascal, пишу под терминал UNIX-like
систем. С небольшой правкой в исходниках можно компилить и под Windows, но
библиотека crt слишком медленно там работает, так что ставьте Linux^W^W^W^W^W.
После завершения разработки игры опубликую куда-нибудь в opensource, олды
вспомнят... Для завершения этюда требуется ещё ~10-15 часов работы.
## FAQ
q: Pascal???
a: Антихайп.
## Сборка
```bash
fpc src/go.pas
```
## Запуск:
```bash
./src/go
```

348
src/arena_graphics_m.pas Normal file
View File

@ -0,0 +1,348 @@
unit arena_graphics_m;
interface
uses arena_m, creature_m, graphics_m, trace_m, level_m;
const
ArenaSymbol = ' ';
CaptureSymbol = '.';
procedure DrawAfterEnemyStep(var cr: creature; var a: arena);
procedure DrawAfterStep(var hamster: creature; var t: tracePtr; var a: arena);
procedure DrawArenaBorders(var a: arena);
procedure DrawArenaCell(arenaX, arenaY: integer; symbol: char);
procedure DrawArenaEdges;
procedure DrawCompleteBar; { TODO: IMPLEMENT LATER }
procedure DrawCreature(var cr: creature);
procedure DrawEdge(x, y: integer; var a: arena);
procedure DrawInterface;
procedure DrawLevel(var level: levelState);
procedure DrawLifes(n: integer);
procedure DrawScore(s: integer);
procedure EraseStepTrace(var hamster: creature; t: tracePtr);
procedure EraseTrace(t: tracePtr; var a: arena);
implementation
uses crt, math_m;
const
ArenaPauseLowerMarginY = 14;
ArenaPauseMarginX = 9;
ArenaPauseUpperMarginY = 7;
InterfaceBarH = ScreenW - ArenaW * CellSize - BorderSize * 2; { 14 }
InterfaceCellW = ScreenW div 3;
InterfaceMarginX = InterfaceCellW div 4;
InterfaceMarginY = InterfaceBarH div 4 + BorderSize + 1;
LifeBarX = 33;
MidCellDelimiter = '_';
Notation = 10;
procedure DrawCompleteBar;
begin
end;
procedure DrawCreature(var cr: creature);
begin
DrawArenaCell(cr.curX, cr.curY, cr.symbol)
end;
procedure DrawAfterEnemyStep(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;
procedure DrawStepTrace(t: tracePtr; hamsterDelta: integer);
var
i: integer;
begin
for i := 1 to HamsterDelta do
begin
t := t^.prev;
DrawArenaCell(t^.x, t^.y, TraceSymbol)
end
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 EraseStepTrace(var hamster: creature; t: tracePtr);
var
i: integer;
begin
for i := 1 to hamster.movespeed 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 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, hamster.movespeed);
DrawCreature(hamster);
DrawPreviousCell(hamster, t, a)
end;
procedure FillPauseCells(var a: arena);
var
i, j: integer;
begin
for i := ArenaPauseUpperMarginY to (ArenaW - ArenaPauseLowerMarginY) do
for j := (1 + ArenaPauseMarginX) to (ArenaH - ArenaPauseMarginX) do
if a.borders[j][i] then
DrawArenaCell(j, i, BorderSymbol)
else
if a.captured[j][i] then
DrawArenaCell(j, i, CaptureSymbol)
end;
procedure DrawTrace(t: tracePtr);
begin
if t <> nil then
t := t^.prev;
while t <> nil do
begin
DrawArenaCell(t^.x, t^.y, TraceSymbol);
t := t^.prev
end
end;
type
stackIntPtr = ^stackIntItem;
stackIntItem = record
val: integer;
next: stackIntPtr
end;
StackInt = record
top: stackIntPtr
end;
procedure StackIntInit(var s: StackInt);
begin
s.top := nil
end;
procedure StackPush(var st: StackInt; val: integer);
var
tmp: stackIntPtr;
begin
new(tmp);
tmp^.val := val;
tmp^.next := st.top;
st.top := tmp
end;
procedure StackPop(var st: StackInt);
var
tmp: stackIntPtr;
begin
tmp := st.top;
st.top := st.top^.next;
dispose(tmp)
end;
procedure DrawInterfaceNumber(interfaceX: integer; s: longint);
var
x, y: integer;
i: integer = 0;
st: StackInt;
begin
StackIntInit(st);
if s = 0 then
StackPush(st, 0);
while s <> 0 do
begin
StackPush(st, s mod Notation);
s := s div Notation
end;
x := interfaceX + InterfaceMarginX;
y := InterfaceMarginY;
while st.top <> nil do
begin
DrawDigit(x + (DigitWidth + DigitSpaceWidth) * i, y, st.top^.val);
StackPop(st);
i := i + 1
end
end;
procedure DrawScore(s: integer);
var
killBarX: integer = InterfaceCellW * 2 * WidthCoefficient + BorderSize;
begin
DrawInterfaceNumber(killBarX, s)
end;
procedure DrawLifes(n: integer);
begin
DrawInterfaceNumber(LifeBarX, n)
end;
procedure DrawLevel(var level: levelState);
begin
DrawInterface;
FillPauseCells(level.a);
DrawTrace(level.t);
DrawCreature(level.h);
DrawCreature(level.g);
DrawScore(level.score);
DrawLifes(level.life)
end;
procedure DrawInterface;
begin
DrawLineX(1, InterfaceBarH, ScreenW * WidthCoefficient, BorderSymbol);
{DrawLineX(InterfaceCellW * WidthCoefficient,
InterfaceBarH div 2,
InterfaceCellW * WidthCoefficient + 1, MidCellDelimiter);}
DrawLineY(InterfaceCellW * WidthCoefficient, 1,
InterfaceBarH, BorderSymbol);
DrawLineY(InterfaceCellW * 2 * WidthCoefficient + 1, 1,
InterfaceBarH, BorderSymbol)
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,
BorderSymbol)
end;
procedure DrawLeftEdge(y: integer);
var
terminalY: integer;
begin
y := Clamp(y, 1, ArenaW);
terminalY := InterfaceBarH + (y - 1) * CellSize;
DrawLineY(1, terminalY, CellSize, BorderSymbol)
end;
procedure DrawRightEdge(y: integer);
var
terminalY: integer;
begin
y := Clamp(y, 1, ArenaW);
terminalY := InterfaceBarH + (y - 1) * CellSize;
DrawLineY(ScreenW * WidthCoefficient, terminalY, CellSize, BorderSymbol)
end;
procedure DrawUpperEdge(x: integer);
var
terminalX, sizeX: integer;
begin
x := Clamp(x, 1, ArenaH);
terminalX := (x - 1) * CellSize * WidthCoefficient + 1;
sizeX := CellSize * WidthCoefficient;
DrawLineX(terminalX, InterfaceBarH, sizeX, BorderSymbol)
end;
procedure DrawLowerEdge(x: integer);
var
terminalX, sizeX: integer;
begin
x := Clamp(x, 1, ArenaH);
terminalX := (x - 1) * CellSize * WidthCoefficient + 1;
sizeX := CellSize * WidthCoefficient;
DrawLineX(terminalX, InterfaceBarH + ArenaW * CellSize - 1,
sizeX, BorderSymbol)
end;
procedure DrawArenaBorders(var a: arena);
var
i, j: integer;
begin
for i := 1 to ArenaW do
for j := 1 to ArenaH do
if a.borders[j][i] then
DrawArenaCell(j, i, BorderSymbol)
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 = ArenaH then
DrawRightEdge(y);
if y = 1 then
DrawUpperEdge(x);
if y = ArenaW then
DrawLowerEdge(x)
end;
procedure EraseTrace(t: tracePtr; var a: arena);
begin
while t <> nil do
begin
if t^.prev = nil then
DrawEdge(t^.x, t^.y, a)
else
DrawArenaCell(t^.x, t^.y, ArenaSymbol);
t := t^.prev
end
end;
end.

512
src/arena_m.pas Normal file
View File

@ -0,0 +1,512 @@
unit arena_m;
interface
uses creature_m, trace_m;
const
ArenaW = 33;
ArenaH = 41;
RandomCutThreshold = 20;
RandomOneToOne = 2;
type
arenaMatrix = array [1..ArenaH, 1..ArenaW] of boolean;
arena = record
captured, borders: arenaMatrix;
end;
function ArenaCellCaptured(x, y: integer; var a: arena): boolean;
function ArenaSplited(var h: creature; var t: tracePtr; var a: arena): boolean;
function GhostShouldTurn(var g: creature; var a: arena): boolean;
function
HamsterStepPossible(var h: creature; var t: tracePtr; var a: arena): boolean;
function IsOnBorder(var x, y: integer; var a: arena): boolean;
function IsOnEdge(var cr: creature): boolean;
function IsOnEdge(x, y: integer): boolean;
procedure CutPart(var hamster: creature; var t: tracePtr;
var cutOff: integer; var a: arena);
procedure InitArena(var a: arena);
procedure MakeEnemyStep(var e, h: creature; t: tracePtr; 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 arena_graphics_m, cell_m, crt, graphics_m, math_m;
procedure Fill(var m: arenaMatrix; val: boolean);
var
i, j: integer;
begin
for i := 1 to ArenaH do
for j := 1 to ArenaW do
m[i][j] := val
end;
procedure InitArena(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 <> ArenaH + 1) and
(y <> 0) and (y <> ArenaW + 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
CutChosenPart(var partCell: cellItem; var a: arena; var cutOff: integer);
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;
cutOff := cutOff + 1;
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 = ArenaH)
end;
function OnEdgeY(y: integer): boolean;
begin
OnEdgeY := (y = 1) or (y = ArenaW)
end;
function IsOnEdge(x, y: integer): boolean;
begin
IsOnEdge := (OnEdgeX(x) or OnEdgeY(y))
end;
function YNeighboursCaptured(x, y: integer; var a: arena): boolean;
begin
YNeighboursCaptured :=
not OnEdgeY(y) and a.captured[x][y - 1] and a.captured[x][y + 1]
end;
function XNeighboursCaptured(x, y: integer; var a: arena): boolean;
begin
XNeighboursCaptured :=
not OnEdgeX(x) and a.captured[x + 1][y] and a.captured[x - 1][y]
end;
function DiagonalNeighboursCaptured(x, y: integer; var a: arena): boolean;
begin
DiagonalNeighboursCaptured :=
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 :=
XNeighboursCaptured(x, y, a) or YNeighboursCaptured(x, y, a) or
DiagonalNeighboursCaptured(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; var cutOff: integer); {rename, slow}
var
i, j: integer;
begin
for i := 1 to ArenaW do
for j := 1 to ArenaH do
if a.borders[j][i] and ArenaCellCaptured(j, i, a) then
begin
cutOff := cutOff + 1;
CaptureArenaBorder(j, i, a)
end;
end;
procedure SetArenaBorder(var t: tracePtr; var a: arena);
begin
if t <> nil then
begin
a.borders[t^.x][t^.y] := true;
SetArenaBorder(t^.prev, a)
end
end;
function IsOnEdge(var cr: creature): boolean;
begin
IsOnEdge :=
(cr.curX = 1) or (cr.curX = ArenaH) or (cr.curY = 1) or
(cr.curY = ArenaW)
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 LowerToBiggerRatio(val1, val2: integer): integer;
var
v1, v2, tmp, biggerProcent: real;
begin
v1 := val1;
v2 := val2;
if v1 > v2 then
begin
tmp := v1;
v1 := v2;
v2 := tmp
end;
biggerProcent := v2 / 100;
LowerToBiggerRatio := Round(100 - v1 / biggerProcent)
end;
function StepOnTrace(var hamster: creature; var t: tracePtr): boolean;
var
nextX, nextY, idx: integer;
begin
nextX := Clamp(hamster.curX + hamster.dX, 1, ArenaH);
nextY := Clamp(hamster.curY + hamster.dY, 1, ArenaW);
idx := FindIndex(t, nextX, nextY, 1);
StepOnTrace := idx > PreviousTraceIdx
end;
function StepBeyondEdge(var cr: creature): boolean;
begin
StepBeyondEdge :=
(cr.dX > 0) and (cr.curX = ArenaH) or
(cr.dX < 0) and (cr.curX = 1) or
(cr.dY > 0) and (cr.curY = ArenaW) or
(cr.dY < 0) and (cr.curY = 1)
end;
function RandomBool: boolean;
begin
if Random(RandomOneToOne) = 1 then
RandomBool := true
else
RandomBool := false
end;
function ChooseRandomCell(p1, p2: cellItem): cellItem;
var
rb: boolean;
begin
rb := RandomBool;
if rb then
ChooseRandomCell := p1
else
ChooseRandomCell := p2
end;
{refactor? pass just level later}
procedure CutPart(var hamster: creature; var t: tracePtr;
var cutOff: integer; var a: arena);
var
area1, area2, diffProcent: integer;
part1, part2, cutFigure: cellItem;
begin
GetPartsCells(t, part1, part2, a);
area1 := GetFigureArea(part1, a);
area2 := GetFigureArea(part2, a);
diffProcent := LowerToBiggerRatio(area1, area2);
if diffProcent <= RandomCutThreshold then
cutFigure := ChooseRandomCell(part1, part2)
else
if area1 <= area2 then
cutFigure := part1
else
cutFigure := part2;
CutChosenPart(cutFigure, a, cutOff);
CaptureCutBorders(a, cutOff);
DrawArenaBorders(a);
DrawArenaEdges;
DrawCreature(hamster);
DeleteTrace(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, ArenaH);
nextY := Clamp(h.curY + h.dY, 1, ArenaW);
midX := Clamp(h.curX + (h.dX div 2), 1, ArenaH);
midY := Clamp(h.curY + (h.dY div 2), 1, ArenaW);
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, h: creature; t: tracePtr; var a: arena);
var
prevX, prevY: integer;
begin
prevX := e.curX;
prevY := e.curY;
MakeStep(e);
DrawAfterEnemyStep(e, a);
if TraceCrossed(prevX, prevY, e, t) then
h.alive := false
end;
end.

303
src/ascii_arts_m.pas Normal file
View File

@ -0,0 +1,303 @@
unit ascii_arts_m;
interface
const
DigitHeight = 5;
DigitWidth = 5;
DigitsAscii: array[0..9] of array[1..DigitHeight] of string = (
(
'@@@@@',
'@ @',
'@ @',
'@ @',
'@@@@@'
),
(
' @ ',
' @@ ',
'@ @ ',
' @ ',
'@@@@@'
),
(
'@@@@@',
' @',
'@@@@@',
'@ ',
'@@@@@'
),
(
'@@@@@',
' @',
'@@@@@',
' @',
'@@@@@'
),
(
'@ @',
'@ @',
'@@@@@',
' @',
' @'
),
(
'@@@@@',
'@ ',
'@@@@@',
' @',
'@@@@@'
),
(
'@@@@@',
'@ ',
'@@@@@',
'@ @',
'@@@@@'
),
(
'@@@@@',
' @',
' @',
' @',
' @'
),
(
'@@@@@',
'@ @',
'@@@@@',
'@ @',
'@@@@@'
),
(
'@@@@@',
'@ @',
'@@@@@',
' @',
'@@@@@'
)
);
GameMenuHeight = 44;
GameMenuScreen: array[1..GameMenuHeight] of string = (
' _____ _ _ _ _',
' / ____| | | | | | | | |',
'| | __ ___ | | | |__| | __ _ _ __ ___ ___| |_ ___ _ __',
'| | |_ |/ _ \| | | __ |/ _` | ''_ ` _ \/ __| __/ _ \ ''__|',
'| |__| | (_) |_| | | | | (_| | | | | | \__ \ || __/ |',
' \_____|\___/(_) |_| |_|\__,_|_| |_| |_|___/\__\___|_|',
'',
'',
'',
'',
'',
'',
'',
'',
' _ _ _____',
'| \ | | / ____|',
'| \| | _____ __ | | __ __ _ _ __ ___ ___',
'| . ` |/ _ \ \ /\ / / | | |_ |/ _` | ''_ ` _ \ / _ \',
'| |\ | __/\ V V / | |__| | (_| | | | | | | __/',
'|_| \_|\___| \_/\_/ \_____|\__,_|_| |_| |_|\___|',
'',
'',
' _ _ _ _ _____',
'| | | (_) | | / ____|',
'| |__| |_ __ _| |__ | (___ ___ ___ _ __ ___',
'| __ | |/ _` | ''_ \ \___ \ / __/ _ \| ''__/ _ \',
'| | | | | (_| | | | | ____) | (_| (_) | | | __/',
'|_| |_|_|\__, |_| |_| |_____/ \___\___/|_| \___|',
' __/ |',
' |___/',
' _ __ _____ __',
'| |/ / |_ _| / _|',
'| '' / ___ _ _ | | _ __ | |_ ___',
'| < / _ \ | | | | | | ''_ \| _/ _ \',
'| . \ __/ |_| | _| |_| | | | || (_) |',
'|_|\_\___|\__, | |_____|_| |_|_| \___/',
' __/ |',
' |___/',
' _____ _ _ ',
' / ____| | | (_) ',
'| | ___ _ __ | |_ _ _ __ _ _ ___ ',
'| | / _ \| ''_ \| __| | ''_ \| | | |/ _ \',
'| |___| (_) | | | | |_| | | | | |_| | __/',
' \_____\___/|_| |_|\__|_|_| |_|\__,_|\___|'
);
GameNameHeight = 6;
GameNameWidth = 58;
NewGameHeight = 6;
HighScoreHeight = 8;
MenuInfoHeight = 8;
ContinueHeight = 6;
ContinueWidth = 41;
ExitScreenHeight = 16;
ExitWidth = 70;
ExitHeight = 8;
ExitScreen: array[1..ExitScreenHeight] of string = (
' ______ _ _ _ _ ___',
'| ____| (_) | | | | | |__ \',
'| |__ __ ___| |_ | |_| |__ ___ __ _ __ _ _ __ ___ ___ ) |',
'| __| \ \/ / | __| | __| ''_ \ / _ \ / _` |/ _` | ''_ ` _ \ / _ \/ /',
'| |____ > <| | |_ | |_| | | | __/ | (_| | (_| | | | | | | __/_|',
'|______/_/\_\_|\__| \__|_| |_|\___| \__, |\__,_|_| |_| |_|\___(_)',
' __/ |',
' |___/',
'',
'',
' _ _ ___ ___ _ __ ___',
'| | | |/ _ \/ __| | ''_ \ / _ \',
'| |_| | __/\__ \ | | | | (_) |',
' \__, |\___||___/ |_| |_|\___/',
' __/ |',
' |___/'
);
PauseHeight = 22;
PauseWidth = 76;
{ Too long strings :(, lets following linux styleguide }
PauseAscii: array[1..PauseHeight] of string = (
' _',
' | |',
' _ __ __ _ _ _ ___ ___ __| |',
' | ''_ \ / _` | | | / __|/ _ \/ _` |',
' | |_) | (_| | |_| \__ \ __/ (_| |',
' | .__/ \__,_|\__,_|___/\___|\__,_| ',
' | | ',
' |_| _ _',
' | | (_)',
' ___ _ __ __ _ __ ___ ___ ___ _ __ | |_ _ _ __ _ _ ___',
'/ __| ''_ \ / _` |/ __/ _ \ ______ / __/ _ \| ''_ \| __| | ''_ \| | | |/ _ \',
'\__ \ |_) | (_| | (_| __/ |______| | (_| (_) | | | | |_| | | | | |_| | __/',
'|___/ .__/ \__,_|\___\___| \___\___/|_| |_|\__|_|_| |_|\__,_|\___|',
'====| |===================',
' |_| _ _ _',
' (_) | | |',
' __ _ __ _ _ _ _| |_ | |_ ___ _ __ ___ ___ _ __ _ _',
' / _` | ______ / _` | | | | | __| | __/ _ \ | ''_ ` _ \ / _ \ ''_ \| | | |',
'| (_| | |______| | (_| | |_| | | |_ | || (_) | | | | | | | __/ | | | |_| |',
' \__, | \__, |\__,_|_|\__| \__\___/ |_| |_| |_|\___|_| |_|\__,_|',
'====| |= | |',
' |_| |_|'
);
YesHeight = 6;
NoHeight = 4;
NoWidth = 13;
HamsterHeight = 5;
HamsterWidth = 7;
HamsterStayAscii: array[1..HamsterHeight] of string = (
' (\_/)',
'( 0_0 )',
'/-----\',
' |___|',
' / \'
);
HamsterGGAscii: array[1..HamsterHeight] of string = (
' (\_/)',
'( G_G )',
'/-----\',
' |___|',
' / \'
);
GameOverHeight = 40;
GameOverWidth = 62;
GameOverScreen: array[1..GameOverHeight] of string = (
' _____ __ __ ______ ',
' / ____| /\ | \/ | ____|',
' | | __ / \ | \ / | |__ ',
' | | |_ | / /\ \ | |\/| | __|',
' | |__| |/ ____ \| | | | |____',
' \_____/_/ \_\_| |_|______|',
' ______ ________ _____',
' / __ \ \ / / ____| __ \',
' | | | \ \ / /| |__ | |__) |',
' | | | |\ \/ / | __| | _ /',
' | |__| | \ / | |____| | \ \',
' \____/ \/ |______|_| \_\',
'',
' ____ ____',
' / o@@\ /@@o \',
' / /``\@\ __,-==-,__ /@/``\ \',
' / /` `||//\______/ \||` `\ \',
' | |` // __ __ \\ `| |',
' \ \` (/ /;g\ /g;\ \) `/ |',
' \_\__(( " .. " )____/_/',
' \ " __ " / ',
' @@@@@@(||)@@@@`@@`@@@@(||)@@@@@@@',
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@',
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@',
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@',
' ',
' _ _ ___',
' | | (_) |__ \',
' ___ ___ _ __ | |_ _ _ __ _ _ ___ ) |',
' / __/ _ \| ''_ \| __| | ''_ \| | | |/ _ \ / /',
' | (_| (_) | | | | |_| | | | | |_| | __/ |_|',
' \___\___/|_| |_|\__|_|_| |_|\__,_|\___| (_)',
' ___ ___ __ ___ ___',
'| _| |_ | \ \ | _| |_ |',
'| | _ _ | | ___ ___ \ \ | | _ __ | | ___',
'| | | | | | | |/ _ \/ __| \ \ | | | ''_ \ | |/ _ \',
'| | | |_| | | | __/\__ \ \ \ | | | | | | | | (_) |',
'| |_ \__, | _| |\___||___/ \ \ | |_ |_| |_| _| |\___/',
'|___|=====/ |=|___| \_\ |___|=========|___|',
' |___/'
);
KeyInfoHeight = 42;
KeyInfoWidth = 98;
KeyInfoScreen: array[1..KeyInfoHeight] of string = (
' _',
' | |',
' _ __ ___ _____ _____ | | _____ _ _ ___ _',
' | ''_ ` _ \ / _ \ \ / / _ \ | |/ / _ \ | | / __| (_)',
' | | | | | | (_) \ V / __/ | < __/ |_| \__ \ _',
' |_| |_| |_|\___/ \_/ \___| |_|\_\___|\__, |___/ (_)',
' __/ |',
' _ |___/',
' / \',
' / . \',
' / / \ \',
' /_/| |\_\',
' | |',
' |_|',
' __ ========= __',
' / / (\_/) \ \',
' / /_____ ( 0_0 ) ______\ \ ',
' { ______| /-----\ |_______ }',
' \ \ |___| / /',
' \_\ / \ /_/',
' ========== _ ===========',
' | |',
' _ | | _ ',
' \ \| |/ /',
' \ \ / / ',
' \ ` / ',
' \_/',
' =========',
' _ _ _ ',
' | | | | | |',
' ___ _ __ __ _ ___ ___ ___| |_ ___ _ __ | |__ __ _ _ __ ___ ___| |_ ___ _ __',
' / __| ''_ \ / _` |/ __/ _ \ ______ / __| __/ _ \| ''_ \ | ''_ \ / _` | ''_ ` _ \/ __| __/ _ \ ''__|',
' \__ \ |_) | (_| | (_| __/ |______| \__ \ || (_) | |_) | | | | | (_| | | | | | \__ \ || __/ |',
' |___/ .__/ \__,_|\___\___| |___/\__\___/| .__/ |_| |_|\__,_|_| |_| |_|___/\__\___|_|',
' ====| |=================== | |',
' |_| |_|',
' ___ ___ ___ _ __ __ _ _ _ ___ ___',
' / _ \/ __|/ __| ______ | ''_ \ / _` | | | / __|/ _ \',
'| __/\__ \ (__ |______| | |_) | (_| | |_| \__ \ __/',
' \___||___/\___| | .__/ \__,_|\__,_|___/\___|',
'================ | |',
' |_|'
);
implementation
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.

52
src/creature_m.pas Normal file
View File

@ -0,0 +1,52 @@
unit creature_m;
interface
type
creature = record
curX, curY, dX, dY, moveSpeed: integer;
symbol: char;
alive: boolean
end;
procedure
InitCreature(var cr: creature; curX, curY, movespeed: integer; symbol: char);
procedure KillCreature(var cr: creature);
procedure StopCreature(var cr: creature);
procedure MakeStep(var cr: creature);
implementation
uses arena_graphics_m, arena_m, math_m;
procedure
InitCreature(var cr: creature; curX, curY, movespeed: integer; symbol: char);
begin
cr.curX := curX;
cr.curY := curY;
cr.dX := 0;
cr.dY := 0;
cr.movespeed := moveSpeed;
cr.alive := true;
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, ArenaH);
cr.curY := Clamp(cr.curY + cr.dY, 1, ArenaW)
end;
procedure KillCreature(var cr: creature);
begin
cr.alive := false;
DrawArenaCell(cr.curX, cr.curY, CaptureSymbol)
end;
end.

64
src/debug_m.pas Normal file
View File

@ -0,0 +1,64 @@
unit debug_m;
interface
uses arena_m, cell_m, creature_m;
procedure Debug;
procedure DebugCell(cell: cellItemPtr);
procedure Print(var m: arenaMatrix);
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: arenaMatrix);
var
i, j: integer;
begin
for i := 1 to ArenaW do
begin
for j := 1 to ArenaH 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.

247
src/game_m.pas Normal file
View File

@ -0,0 +1,247 @@
{ MainLoop -- main loop }
unit game_m;
interface
uses level_m;
type
state = (gameExit, gameMenu, gameStartLevel, gameScore, gameKeyInfo,
gamePause, gameContinueLevel, gameOver);
menuState = (menuNewGame, menuHighScore, menuKeyInfo, menuContinue);
exitState = (exitYes, exitNo);
gameState = record
curExit: exitState;
curMenu: menuState;
curState: state;
level: integer;
shutdown, continueAllowed: boolean;
end;
procedure DecreaseLife(var level: levelState);
procedure RunGameOver(var g: gameState; var level: levelState);
procedure InitGame(var g: gameState);
procedure NextExitState(var g: gameState);
procedure PreviousExitState(var g: gameState);
procedure RunExit(var g: gameState);
procedure MainLoop(var g: gameState);
implementation
uses arena_m, arena_graphics_m, crt, creature_m, ghost_m, graphics_m,
hamster_m, keys_m, trace_m;
const
KeyDelayMs = 25;
LevelDelayMs = 100;
procedure DecreaseLife(var level: levelState);
begin
level.life := level.life - 1;
DrawLifes(level.life)
end;
procedure InitGame(var g: gameState);
begin
g.continueAllowed := false;
g.curMenu := menuNewGame;
g.curState := gameMenu;
g.level := 1;
g.shutdown := false;
{
g.slowBonus := StartSlowBonus;
g.speedBonus := StartSpeedBonus
}
end;
procedure RunExit(var g: gameState);
begin
DrawExit(g);
while g.curState = gameExit do
begin
delay(KeyDelayMs);
if keypressed then
HandleExitKey(g)
end;
EraseExit
end;
procedure RunScore(var g: gameState);
begin
{DrawHighScore;}
while g.curState = gameScore do
begin
delay(KeyDelayMs);
if keypressed then
HandleScoreKey(g)
end;
end;
procedure RunKeyInfo(var g: gameState);
begin
DrawKeyInfo;
while g.curState = gameKeyInfo do
begin
delay(KeyDelayMs);
if keypressed then
HandleInfoKey(g)
end;
EraseKeyInfo
end;
procedure RunPause(var g: gameState);
begin
DrawPause(g);
while g.curState = gamePause do
begin
delay(KeyDelayMs);
if keypressed then
HandlePauseKey(g)
end;
if g.curState = gameMenu then
EraseLevel;
if g.curState = gameContinueLevel then
ErasePause(g)
end;
procedure RunGameOver(var g: gameState; var level: levelState);
begin
DrawGameOver;
while g.curState = gameOver do
begin
delay(KeyDelayMs);
if keypressed then
HandleGameOverKey(g)
end;
EraseGameOver;
if g.curState = gameContinueLevel then
InitLevel(level)
end;
procedure LevelLoop(var g: gameState; var level: levelState);
begin
while level.continueLevel do
begin
delay(LevelDelayMs);
if ArenaSplited(level.h, level.t, level.a) then
begin
SetArenaBorder(level.t, level.a);
CutPart(level.h, level.t, level.score, level.a);
DrawScore(level.score)
end;
if level.g.alive then
MakeEnemyStep(level.g, level.h, level.t, level.a);
while level.g.alive and GhostShouldTurn(level.g, level.a) do
TurnGhost(level.g, level.a);
if not level.h.alive then
begin
if level.life <= 0 then
begin
g.curState := gameOver;
EraseLevel;
break
end;
DecreaseLife(level);
KillHamster(level.h, level.t, level.a);
level.h.alive := true
end;
if keypressed then
HandleLevelKey(level.h, level.a, level.t, g);
if not HamsterStepPossible(level.h, level.t, level.a) then
StopCreature(level.h);
if not ((level.h.dX = 0) and (level.h.dY = 0)) then
MakeHamsterStep(level.h, level.t, level.a);
if level.g.alive and
level.a.captured[level.g.curX][level.g.curY] then
begin
KillCreature(level.g)
end;
if g.curState = gamePause then
break
end;
end;
procedure StartLevel(var g: gameState; var level: levelState);
begin
InitLevel(level);
DrawLevel(level);
LevelLoop(g, level)
end;
procedure ContinueLevel(var g: gameState; var level: levelState);
begin
DrawLevel(level);
LevelLoop(g, level)
end;
procedure RunMenu(var g: gameState);
var
prevMenu: boolean = false;
begin
g.curState := gameMenu;
while g.curState = gameMenu do
begin
if (g.curState = gameMenu) and not prevMenu then
begin
DrawMenu(g);
prevMenu := true
end;
delay(KeyDelayMs);
if keypressed then
HandleMenuKey(g);
if (g.curState <> gameMenu) and prevMenu then
begin
EraseMenu;
prevMenu := false
end;
if (g.curState <> gameMenu) then
if g.shutdown then
break
end
end;
procedure MainLoop(var g: gameState);
var
level: levelState;
begin
while not g.shutdown do
begin
case g.curState of
gameExit:
RunExit(g);
gameScore:
RunScore(g);
gameKeyInfo:
RunKeyInfo(g);
gamePause:
RunPause(g);
gameStartLevel:
StartLevel(g, level);
gameContinueLevel: {Maybe here should be gameStartLevel}
ContinueLevel(g, level);
gameOver:
RunGameOver(g, level);
gameMenu:
RunMenu(g)
end
end;
EraseAll
end;
procedure NextExitState(var g: gameState);
begin
if g.curExit = exitNo then
g.curExit := exitYes
else
g.curExit := succ(g.curExit)
end;
procedure PreviousExitState(var g: gameState);
begin
if g.curExit = exitYes then
g.curExit := exitNo
else
g.curExit := pred(g.curExit)
end;
end.

26
src/ghost_m.pas Normal file
View File

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

40
src/go.pas Normal file
View File

@ -0,0 +1,40 @@
program go_hamster;
uses crt, keys_m, arena_graphics_m, graphics_m, game_m, debug_m;
{uses crt, keys_m, arena_graphics_m, graphics_m, game_m, ascii_digits_m, debug_m;}
function IsTerminalValid: boolean;
begin
IsTerminalValid := (
(ScreenWidth >= ScreenW * WidthCoefficient) and
(ScreenHeight >= ScreenH)
)
end;
procedure PrintTerminalHelp;
begin
writeln('Increase your terminal size and try again.');
if ScreenWidth < ScreenW * WidthCoefficient then
begin
writeln('Your terminal width: ', ScreenWidth,
'. Required: ', ScreenW * WidthCoefficient, '.')
end;
if ScreenHeight < ScreenH then
begin
writeln('Your terminal height: ', ScreenHeight,
'. Required: ', ScreenH, '.')
end
end;
var
g: gameState;
begin
if not IsTerminalValid then
begin
PrintTerminalHelp;
exit
end;
InitGame(g);
EraseAll;
MainLoop(g)
end.

304
src/graphics_m.pas Normal file
View File

@ -0,0 +1,304 @@
unit graphics_m;
interface
uses arena_m, creature_m, trace_m, game_m, level_m;
const
BorderSize = 1;
BorderSymbol = '|';
CellSize = 2;
DigitSpaceWidth = 1;
DigitWidth = 6;
InterfaceH = 6;
ScreenH = (ArenaW + InterfaceH) * CellSize + BorderSize;
ScreenW = (ArenaH - 1) * CellSize + BorderSize * 2; { 82 }
WidthCoefficient = 2;
procedure DrawDigit(x, y, digit: integer);
procedure DrawExitState(s: exitState);
procedure DrawExit(var g: gameState);
procedure DrawGameOver;
procedure DrawKeyInfo;
procedure DrawLineX(x, y, len: integer; ch: char);
procedure DrawLineY(x, y, len: integer; ch: char);
procedure DrawRectangle(x0, y0, h, w: integer; ch: char);
procedure DrawMenuState(s: menuState);
procedure DrawMenu(var g: gameState);
procedure DrawPause(var g: gameState);
procedure EraseAll;
procedure EraseExit;
procedure EraseExitState(s: exitState);
procedure EraseGameOver;
procedure EraseKeyInfo;
procedure EraseLevel;
procedure EraseMenu;
procedure EraseMenuState(s: menuState);
procedure ErasePause(var g: gameState);
implementation
uses crt, math_m, ascii_arts_m;
const
BigLetterWidth = 8;
BorderN = 2;
GameNameY = 12;
NameHeightPadding = 8;
NewGameY = GameNameY + GameNameHeight + NameHeightPadding;
MenuHeightPadding = 2;
HighScoreY = NewGameY + NewGameHeight + MenuHeightPadding;
MenuInfoY = HighScoreY + HighScoreHeight;
ContinueY = MenuInfoY + MenuInfoHeight;
ExitGameY = (ScreenH - ExitScreenHeight) div 2 - MenuHeightPadding;
ExitYesY = ExitGameY + ExitHeight - 1 + MenuHeightPadding;
ExitHamsterY = ExitYesY;
GameNameX = ScreenW * WidthCoefficient div 3 + 4;
MenuWidthPadding = 4;
MenuHamsterX = GameNameX - HamsterWidth - MenuWidthPadding;
ExitYesX = MenuHamsterX;
ExitNoX = ScreenW * WidthCoefficient - ExitYesX - NoWidth;
GameOverX = ScreenW * WidthCoefficient div 2 - GameNameWidth div 2;
GameOverY = ScreenH div 2 - GameOverHeight div 2;
HamsterNoX = ExitNoX - HamsterWidth - MenuWidthPadding;
HamsterYesX = ExitYesX - HamsterWidth - MenuWidthPadding;
KeyInfoX = ScreenW * WidthCoefficient div 2 - KeyInfoWidth div 2;
KeyInfoY = ScreenH div 2 - KeyInfoHeight div 2 - 1;
LetterWidth = 5;
PauseXPadding = 3 * WidthCoefficient;
PauseX = (ScreenW * WidthCoefficient - PauseWidth) div 2;
PauseYPadding = 1;
PauseY = (ScreenH - PauseHeight) div 2;
PunctuationWidth = 3;
var
firstMenuDraw: boolean = true;
procedure DrawAscii(x, y, h: integer; var a: array of string);
var
i: integer;
begin
for i := 1 to h do
begin
GotoXY(x, y + i - 1);
write(a[i - 1])
end;
GotoXY(1, 1)
end;
procedure DrawDigit(x, y, digit: integer);
begin
DrawAscii(x, y, DigitHeight, DigitsAscii[digit])
end;
procedure DrawExitState(s: exitState);
begin
case s of
exitYes:
DrawAscii(HamsterYesX, ExitHamsterY,
HamsterHeight, HamsterGGAscii);
exitNo:
DrawAscii(HamsterNoX, ExitHamsterY,
HamsterHeight, HamsterStayAscii)
end
end;
procedure DrawExit(var g: gameState);
var
realX: integer = ScreenW * WidthCoefficient;
begin
DrawAscii((realX - ExitWidth) div 2, ExitGameY,
ExitScreenHeight, ExitScreen);
DrawExitState(g.curExit)
end;
procedure DrawGameOver;
begin
DrawAscii(GameOverX, GameOverY, GameOverHeight, GameOverScreen)
end;
procedure DrawKeyInfo;
begin
DrawAscii(KeyInfoX, KeyInfoY, KeyInfoHeight, KeyInfoScreen)
end;
procedure DrawLineX(x, y, len: integer; ch: char);
var
i: integer;
begin
GotoXY(x, y);
for i := 1 to len do
write(ch);
GotoXY(1, 1)
end;
procedure DrawLineY(x, y, len: integer; ch: char);
var
i: integer;
begin
for i := 1 to len do
begin
GotoXY(x, y + i - 1);
write(ch)
end;
GotoXY(1, 1)
end;
procedure DrawMenuState(s: menuState);
begin
case s of
menuNewGame:
DrawAscii(MenuHamsterX, NewGameY + 1,
HamsterHeight, HamsterStayAscii);
menuHighScore:
DrawAscii(MenuHamsterX, HighScoreY + 1,
HamsterHeight, HamsterStayAscii);
menuKeyInfo:
DrawAscii(MenuHamsterX, MenuInfoY + 1,
HamsterHeight, HamsterStayAscii);
menuContinue:
DrawAscii(MenuHamsterX, ContinueY + 1,
HamsterHeight, HamsterStayAscii)
end
end;
procedure DrawRectangle(x0, y0, h, w: integer; ch: char);
var
i: integer;
begin
DrawLineX(x0, y0, w, ch);
for i := 1 to h - 2 do
begin
GotoXY(x0, y0 + i);
write(ch);
GotoXY(x0 + w - 1, y0 + i);
write(ch)
end;
DrawLineX(x0, y0 + h - 1, w, ch);
GotoXY(1, 1)
end;
procedure DrawMenu(var g: gameState);
var
y: integer = GameNameY;
begin
if firstMenuDraw then { REFACTOR LATER }
begin
DrawRectangle(1, 1, ScreenH, ScreenW * WidthCoefficient, BorderSymbol);
firstMenuDraw := not firstMenuDraw
end;
DrawAscii(GameNameX, y, GameMenuHeight, GameMenuScreen);
if not g.continueAllowed then
DrawLineX(GameNameX, ContinueY + ContinueHeight div 2,
ContinueWidth, '-');
DrawMenuState(g.curMenu)
end;
procedure FillRectangle(x, y, w, h: integer; ch: char);
var
i, j: integer;
begin
for i := 0 to h - 1 do
begin
GotoXY(x, y + i);
for j := 0 to w do
write(ch)
end;
GotoXY(1, 1)
end;
procedure EraseRectangle(x, y, w, h: integer);
begin
FillRectangle(x, y, w, h, ' ')
end;
procedure DrawPause(var g: gameState);
begin
EraseRectangle(PauseX - PauseXPadding,
PauseY - PauseYPadding,
PauseWidth + PauseXPadding * 2 - 1,
PauseHeight + PauseYPadding * 2 + 1);
DrawRectangle(PauseX - PauseXPadding,
PauseY - PauseYPadding,
PauseHeight + PauseYPadding * 2 + 1,
PauseWidth + PauseXPadding * 2,
BorderSymbol);
DrawAscii(PauseX, PauseY, PauseHeight, PauseAscii)
end;
procedure EraseAll;
begin
EraseRectangle(1, 1, ScreenW * WidthCoefficient, ScreenH)
end;
procedure EraseExit;
begin
EraseRectangle(HamsterYesX, ExitGameY,
ExitWidth + HamsterWidth + MenuWidthPadding,
ExitScreenHeight + MenuHeightPadding + YesHeight)
end;
procedure EraseExitState(s: exitState);
begin
case s of
exitYes:
EraseRectangle(HamsterYesX, ExitHamsterY,
HamsterWidth, HamsterHeight);
exitNo:
EraseRectangle(HamsterNoX, ExitHamsterY,
HamsterWidth, HamsterHeight)
end
end;
procedure EraseGameOver;
begin
EraseRectangle(GameOverX, GameOverY, GameOverWidth, GameOverHeight)
end;
procedure EraseKeyInfo;
begin
EraseRectangle(KeyInfoX, KeyInfoY, KeyInfoWidth, KeyInfoHeight)
end;
procedure EraseLevel;
begin
EraseRectangle(2, 2,
ScreenW * WidthCoefficient - BorderSize * BorderN,
ScreenH - BorderSize * BorderN);
DrawRectangle(1, 1, ScreenH, ScreenW * WidthCoefficient, BorderSymbol)
end;
procedure EraseMenu;
begin
EraseRectangle(MenuHamsterX, GameNameY,
GameNameWidth + HamsterWidth + MenuWidthPadding,
ScreenH - GameNameY * 2)
end;
procedure EraseMenuState(s: menuState);
begin
case s of
menuNewGame:
EraseRectangle(MenuHamsterX, NewGameY + 1,
HamsterWidth, HamsterHeight);
menuHighScore:
EraseRectangle(MenuHamsterX, HighScoreY + 1,
HamsterWidth, HamsterHeight);
menuKeyInfo:
EraseRectangle(MenuHamsterX, MenuInfoY + 1,
HamsterWidth, HamsterHeight);
menuContinue:
EraseRectangle(MenuHamsterX, ContinueY + 1,
HamsterWidth, HamsterHeight)
end
end;
procedure ErasePause(var g: gameState);
begin
EraseRectangle(PauseX - PauseXPadding,
PauseY - PauseYPadding,
PauseWidth + PauseXPadding * 2 - 1,
PauseHeight + PauseYPadding * 2 + 1)
end;
end.

50
src/hamster_m.pas Normal file
View File

@ -0,0 +1,50 @@
unit hamster_m;
interface
uses arena_graphics_m, arena_m, creature_m, trace_m;
const
HamsterStartX = 5;
HamsterStartY = 1;
HamsterStartDX = 0;
HamsterStartDY = 0;
HamsterMovespeed = 2;
HamsterSymbol = 'h';
procedure InitHamster(var h: creature);
procedure KillHamster(var h: creature; var t: tracePtr; var a: arena);
implementation
uses graphics_m;
procedure InitHamster(var h: creature);
begin
InitCreature(h, HamsterStartX, HamsterStartY,
HamsterMovespeed, HamsterSymbol);
h.dX := HamsterStartDX;
h.dY := HamsterStartDY
end;
procedure KillHamster(var h: creature; var t: tracePtr; var a: arena);
var
traceStart: tracePtr;
begin
DrawArenaCell(h.curX, h.curY, ArenaSymbol);
EraseTrace(t, a);
if IsOnEdge(h) then
DrawEdge(h.curX, h.curY, a)
else
if a.borders[h.curX][h.curY] then
DrawArenaCell(h.curX, h.curY, BorderSymbol);
GetStart(traceStart, t);
h.curX := traceStart^.x;
h.curY := traceStart^.y;
h.dX := HamsterStartDX;
h.dY := HamsterStartDY;
DeleteTrace(t);
DrawCreature(h)
end;
end.

282
src/keys_m.pas Normal file
View File

@ -0,0 +1,282 @@
unit keys_m;
interface
uses crt, creature_m, arena_m, game_m, trace_m, hamster_m, debug_m;
const
ArrowDownOrd = -80;
ArrowLeftOrd = -75;
ArrowRightOrd = -77;
ArrowUpOrd = -72;
CtrlCOrd = 3;
EnterOrd = 13;
EscOrd = 27;
LowerNOrd = 110;
LowerYOrd = 121;
SpaceOrd = 32;
UpperNOrd = 78;
UpperYOrd = 89;
OneOrd = 49;
TwoOrd = 50;
ThreeOrd = 51;
FourOrd = 52;
UpperQOrd = 81;
LowerQOrd = 113;
{ Debug }
BOrd = 98;
COrd = 99;
LOrd = 108;
{ Debug }
procedure GetKey(var keyCode: integer);
procedure HandleExitKey(var g: gameState);
procedure HandleLevelKey(var h: creature; var a: arena;
var t: tracePtr; var g: gameState);
procedure HandleMenuKey(var g: gameState);
procedure HandleInfoKey(var g: gameState);
procedure HandleGameOverKey(var g: gameState);
procedure HandleScoreKey(var g: gameState);
procedure HandlePauseKey(var g: gameState);
implementation
uses graphics_m;
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(k: integer; var h: creature);
begin
h.dX := 0;
h.dY := 0;
case k of
ArrowLeftOrd:
h.dX := -h.movespeed;
ArrowRightOrd:
h.dX := h.movespeed;
ArrowUpOrd:
h.dY := -h.movespeed;
ArrowDownOrd:
h.dY := h.movespeed;
SpaceOrd:
StopCreature(h)
end
end;
procedure HandleLevelKey(var h: creature; var a: arena;
var t: tracePtr; var g: gameState);
var
k: integer;
begin
GetKey(k);
{DEBUG}
if k = BOrd then
Print(a.borders);
if k = COrd then
Print(a.captured);
if k = LOrd then
begin
GotoXY(2, 60);
write(' ');
GotoXY(2, 60);
writeln(GetLength(t));
GotoXY(1, 1)
end;
{DEBUG}
if (k = ArrowLeftOrd) or (k = ArrowRightOrd) or (k = ArrowUpOrd) or
(k = ArrowDownOrd) or (k = SpaceOrd) then
begin
ChangeHamsterDelta(k, h)
end;
if k = EscOrd then
g.curState := gamePause
{
if k = CtrlCOrd then
continueLevel := false
}
end;
procedure PreviousMenuState(var g: gameState);
begin
if (g.curMenu = menuNewGame) and not g.continueAllowed then
g.curMenu := menuKeyInfo
else
if g.curMenu = menuNewGame then
g.curMenu := menuContinue
else
g.curMenu := pred(g.curMenu)
end;
procedure NextMenuState(var g: gameState);
begin
if (g.curMenu = menuKeyInfo) and not g.continueAllowed or
(g.curMenu = menuContinue) then
begin
g.curMenu := menuNewGame
end
else
begin
g.curMenu := succ(g.curMenu)
end
end;
procedure ChangeMenuState(k: integer; var g: gameState);
begin
case k of
ArrowUpOrd:
PreviousMenuState(g);
ArrowDownOrd:
NextMenuState(g)
end
end;
procedure ChooseMenuNum(k: integer; var g: gameState);
begin
if (k = FourOrd) and not g.continueAllowed then
exit;
case k of
OneOrd:
g.curState := gameStartLevel;
TwoOrd:
g.curState := gameScore;
ThreeOrd:
g.curState := gameKeyInfo;
FourOrd:
g.curState := gameContinueLevel
end
end;
procedure ChooseMenuMarked(var g: gameState);
begin
case g.curMenu of
menuNewGame:
g.curState := gameStartLevel;
menuHighScore:
g.curState := gameScore;
menuKeyInfo:
g.curState := gameKeyInfo;
menuContinue:
g.curState := gameContinueLevel
end
end;
procedure HandleMenuKey(var g: gameState);
var
k: integer;
begin
GetKey(k);
if (k = ArrowUpOrd) or (k = ArrowDownOrd) then
begin
EraseMenuState(g.curMenu);
ChangeMenuState(k, g);
DrawMenuState(g.curMenu)
end;
if (k = OneOrd) or (k = TwoOrd) or (k = ThreeOrd) or (k = FourOrd) then
ChooseMenuNum(k, g);
if (k = EscOrd) or (k = UpperQOrd) or (k = LowerQOrd) then
g.curState := gameExit;
if (k = EnterOrd) or (k = SpaceOrd) then
ChooseMenuMarked(g);
end;
procedure HandleGameOverKey(var g: gameState);
var
k: integer;
begin
GetKey(k);
case k of
UpperYOrd, LowerYOrd:
g.curState := gameContinueLevel;
UpperNOrd, LowerNOrd:
g.curState := gameMenu;
end
end;
procedure ChangeExitState(k: integer; var g: gameState);
begin
case k of
ArrowRightOrd:
NextExitState(g);
ArrowLeftOrd:
PreviousExitState(g)
end
end;
procedure HandleExitKey(var g: gameState);
var
k: integer;
begin
GetKey(k);
if (k = ArrowLeftOrd) or (k = ArrowRightOrd) then
begin
EraseExitState(g.curExit);
ChangeExitState(k, g);
DrawExitState(g.curExit);
exit
end;
if (k = EnterOrd) or (k = SpaceOrd) then
begin
if g.curExit = exitYes then
g.shutdown := true
else
g.curExit := exitYes;
end;
if (k = UpperYOrd) or (k = LowerYOrd) or (k = OneOrd) then
g.shutdown := true;
if (k = UpperNOrd) or (k = LowerNOrd) or (k = EscOrd) or (k = TwoOrd) then
g.curExit := exitYes;
g.curState := gameMenu
end;
procedure HandlePauseKey(var g: gameState);
var
k: integer;
begin
GetKey(k);
if (k = EscOrd) or (k = SpaceOrd) then
g.curState := gameContinueLevel;
if (k = UpperQOrd) or (k = LowerQOrd) then
g.curState := gameMenu;
end;
procedure HandleInfoKey(var g: gameState);
var
k: integer;
begin
GetKey(k);
if (k = EscOrd) or (k = SpaceOrd) or (k = EnterOrd) or
(k = UpperQOrd) or (k = LowerQOrd) then
begin
g.curState := gameMenu;
end
end;
procedure HandleScoreKey(var g: gameState);
var
k: integer;
begin
GetKey(k);
if (k = EscOrd) or (k = SpaceOrd) or (k = EnterOrd) or
(k = UpperQOrd) or (k = LowerQOrd) then
begin
g.curState := gameMenu;
end
end;
end.

43
src/level_m.pas Normal file
View File

@ -0,0 +1,43 @@
unit level_m;
interface
uses arena_m, trace_m, creature_m;
type
levelState = record
a: arena;
t: tracePtr;
levelStarted, continueLevel, hamsterAlive: boolean;
h, g: creature;
life, score: integer
end;
procedure InitLevel(var level: levelState);
implementation
uses hamster_m, ghost_m;
const
StartScore = 0;
StartLifes = 0;
{
BonusTurns = 45;
StartSpeedBonus = 0;
StartSlowBonus = 0;
}
procedure InitLevel(var level: levelState);
begin
InitArena(level.a);
InitHamster(level.h);
InitGhost(level.g);
level.levelStarted := true;
level.continueLevel := true;
level.hamsterAlive := true;
level.t := nil;
level.life := StartLifes;
level.score := StartScore
end;
end.

36
src/math_m.pas Normal file
View File

@ -0,0 +1,36 @@
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;
function Abs(val: integer): integer;
begin
if val < 0 then
val := val * -1;
Abs := val
end;
end.

188
src/trace_m.pas Normal file
View File

@ -0,0 +1,188 @@
unit trace_m;
interface
uses creature_m, math_m;
const
PreviousTraceIdx = 3;
TraceSymbol = '+';
type
tracePtr = ^trace;
trace = record
x, y: integer;
prev: tracePtr
end;
function FindIndex(var t: tracePtr; x, y, curIdx: integer): integer;
function GetLength(var t: tracePtr): integer;
function IsOnTrace(var cr: creature; t: tracePtr): boolean;
function IsOnTrace(x, y: integer; t: tracePtr): boolean;
function
TraceCrossed(prevX, prevY: integer; var cr: creature; t: tracePtr): boolean;
procedure ChangeHamsterTrace(var h: creature; var t: tracePtr);
procedure DecreaseTrace(var hamster: creature; var t: tracePtr);
procedure DeleteTrace(var t: tracePtr);
procedure GetStart(var traceStart: tracePtr; t: tracePtr);
procedure IncreaseTrace(var hamster: creature; var t: tracePtr);
procedure Pop(var t: tracePtr);
implementation
uses arena_graphics_m;
function GetLength(var t: tracePtr): integer;
begin
if t = nil then
GetLength := 0
else
GetLength := 1 + GetLength(t^.prev)
end;
procedure GetStart(var traceStart: tracePtr; t: tracePtr);
begin
while t <> nil do
begin
if t^.prev = nil then
traceStart := t;
t := t^.prev
end
end;
procedure DeleteTrace(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;
function IsOnTrace(x, y: integer; t: tracePtr): boolean;
begin
if t = nil then
IsOnTrace := false
else
if (t^.x = x) and (t^.y = y) then
IsOnTrace := true
else
IsOnTrace := IsOnTrace(x, y, t^.prev)
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; t: tracePtr): boolean;
begin
IsOnTrace := IsOnTrace(cr.curX, cr.curY, t)
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) * hamster.movespeed;
dY := Signum(hamster.curY - hamster.dY, hamster.curY) * hamster.movespeed;
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 hamster.movespeed do
AddStepTrace(hamster, t)
end;
procedure DecreaseTrace(var hamster: creature; var t: tracePtr);
var
i: integer;
begin
for i := 1 to hamster.movespeed 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
EraseStepTrace(h, t);
DecreaseTrace(h, t)
end
else
begin
IncreaseTrace(h, t)
end
end;
function
TraceCrossed(prevX, prevY: integer; var cr: creature; t: tracePtr): boolean;
var
dX, dY: integer;
begin
dX := Signum(cr.curX, prevX);
dY := Signum(cr.curY, prevY);
while (prevX <> cr.curX) and (prevY <> cr.curY) do
begin
if IsOnTrace(prevX, prevY, t) then
begin
TraceCrossed := true;
exit
end;
prevX := prevX + dX;
prevY := prevY + dY
end;
TraceCrossed := false
end;
end.