Subversion Repositories Kolibri OS

Compare Revisions

No changes between revisions

Regard whitespace Rev 669 → Rev 670

/programs/games/lrl/LRL.pp
0,0 → 1,83
program LodeRunnerLive;
 
{$apptype gui}
 
 
uses
LRLRoutines,
LRLSprites,
LRLLevels,
LRLMainMenu,
{LRLHighScores,
LRLEditor,}
LRLIntroduction;
 
const
Version: array [1..34] of char = 'Lode Runner LIVE. Version 1.0'#13#10#13#10'$';
 
 
procedure LRLInitialize;
begin
kos_setkeyboardmode(0);
ImagesInitialize;
end;
 
 
procedure LRLDeinitialize;
begin
ImagesDeinitialize;
end;
 
 
procedure LRLGameStart;
var
cl: Integer;
begin
Palette256Set(LRLPalette^);
 
ShowLives := True;
ShowScore := True;
ShowLevel := True;
LRLLives := 5;
LRLScore := 0;
 
cl := 1;
repeat
LRLPlayLevel(cl);
KeyboardFlush;
if GameResult = 10 then
begin
Inc(LRLLives);
LRLScore := LRLScore + 10000 * longint(cl);
Inc(cl);
end else
Dec(LRLLives);
until (LRLLives = 0) or (GameResult = 100);
 
{(GameResult <> 100) and LRLBestScore(LRLScore) then
begin
LRLInsertScore(LRLEnterName, LRLScore);
LRLShowHighScores;
end;}
end;
 
procedure LRLShell;
var
MenuSelection: word;
begin
MenuSelection := 1;
repeat
LRLSelectItem(MenuSelection);
if MenuSelection = 1 then LRLGameStart;
{if MenuSelection = 2 then LRLEditLevels;
if MenuSelection = 3 then LRLShowHighScores;}
until MenuSelection = 4;
end;
 
 
begin
LRLInitialize;
LRLIntro;
LRLShell;
LRLDeinitialize;
end.
/programs/games/lrl/LRLEditor.pp
0,0 → 1,304
unit LRLEditor;
 
interface
 
uses DOSFileAccess, LRLRoutines, LRLSprites, LRLLevels;
 
procedure LRLEditLevels;
 
implementation
 
var
CurrentLevel: word;
CurrentTool: word;
TotalLevels: word;
MouseX, MouseY: integer;
TimeToRefresh: boolean;
RefreshDelay: word;
RefreshRemain: word;
OldTimer: POINTER;
 
procedure LRLRedrawLevel;
var
i, j: integer;
begin
ImageClear(LRLScreen^);
for i := 1 to 16 do
for j := 1 to 30 do
with LRLLevel.Field[j, i] do
ImagePut(LRLScreen^, LRLEnvironment[Image].Image[Count].Data^, j * 10, i * 10, 0, 0, 319, 199);
for i := 1 to 10 do
with LRLLevel.Player[i] do
begin
if Controller <> 0 then
ImagePutTransparent(LRLScreen^, LRLFigure[Colour, SpriteData].Image[Sprite].Data^,
Position.x * 10 + Position.xoffs, Position.y * 10 + Position.yoffs, 0, 0, 319, 199);
end;
ImageFill(LRLFontBuffer^, 12, 12, 252);
ImagePut(LRLScreen^, LRLFontBuffer^, 10, 184, 0, 0, 319, 199);
for i := 1 to 13 do
begin
if i > 9 then
ImagePut(LRLScreen^, LRLFigure[i - 9, 1].Image[1].Data^, i * 15 - 4, 185, 0, 0, 319, 199)
else
ImagePut(LRLScreen^, LRLEnvironment[i].Image[1].Data^, i * 15 - 4, 185, 0, 0, 319, 199);
end;
for i := 1 to 6 do
begin
if LRLEditorButton[i].Lit then
ImagePut(LRLScreen^, LRLEditorButton[i].LightIcon^, LRLEditorButton[i].x1,
LRLEditorButton[i].y1, 0, 0, 319, 199)
else
ImagePut(LRLScreen^, LRLEditorButton[i].DarkIcon^, LRLEditorButton[i].x1,
LRLEditorButton[i].y1, 0, 0, 319, 199);
end;
LRLDrawOrnamental(0, 0, 31, 17, 1);
end;
 
procedure RefreshRunner;
{INTERRUPT;
ASSEMBLER;}
asm
DEC RefreshRemain
JNZ @DoTimer
 
MOV AX,RefreshDelay
MOV RefreshRemain,AX
MOV TimeToRefresh,-1
 
@DoTimer:
PUSHF
CALL OldTimer
end;
 
procedure LRLMoveMouse;
var
s, s2: string[20];
begin
MSMouseGetXY(Mousex, Mousey);
if not MSMouseInArea(200, 180, 325, 205) then
begin
if CurrentTool < 10 then
ImagePut(LRLScreen^, LRLEnvironment[CurrentTool].Image[1].Data^,
Mousex - 5, Mousey - 5, 0, 0, 319, 199)
else
ImagePut(LRLScreen^, LRLFigure[CurrentTool - 9, 1].Image[1].Data^,
Mousex - 5, Mousey - 5, 0, 0, 319, 199);
end;
if not MSMouseInArea(-2, -2, 55, 20) then
begin
ImageFill(LRLFontBuffer^, 50, 15, 0);
ImagePut(LRLScreen^, LRLFontBuffer^, 0, 0, 0, 0, 319, 199);
STR(CurrentLevel, s);
STR(TotalLevels, s2);
ImageStringGet(s + '/' + s2, LRLFont^, LRLFontBuffer^, 251);
ImagePut(LRLScreen^, LRLFontBuffer^, 25 - ImageSizex(LRLFontBuffer^) div 2, 0, 0, 0, 319, 199);
end;
ImagePutTransparent(LRLScreen^, LRLMousePointer^, Mousex, Mousey, 0, 0, 319, 199);
end;
 
procedure RePress;
var
x, y: integer;
begin
MSMouseButtonWasPressed(1, x, y);
MSMouseButtonWasReleased(1, x, y);
MSMouseButtonWasPressed(4, x, y);
MSMouseButtonWasReleased(4, x, y);
end;
 
procedure LRLEditLevels;
var
Keypress: word;
NeedToFade: boolean;
DrawNow: boolean;
i, j: integer;
x, y: integer;
Cmd: word;
begin
if not MSMouseDriverExist then Exit;
Repress;
ShowLives := False;
ShowScore := False;
Palette256Set(LRLPalette^);
OldTimer := SetInterrupt($8, @RefreshRunner);
Keypress := 0;
RefreshDelay := 1;
RefreshRemain := 1;
CurrentLevel := 1;
CurrentTool := 2;
TotalLevels := LRLLevelCount;
TimeToRefresh := True;
DrawNow := False;
MSMouseSetXY(160, 100);
LRLLoadLevel(CurrentLevel);
repeat
if TimeToRefresh then
begin
LRLRedrawLevel;
LRLMoveMouse;
ScreenApply(LRLScreen^);
TimeToRefresh := False;
end;
if Keypressed then
begin
Keypress := Readkey;
end;
if MSMouseButtonWasReleased(1, x, y) then
begin
LRLScore := 0;
FadeClear;
ImageClear(LRLScreen^);
ScreenApply(LRLScreen^);
Palette256Set(LRLPalette^);
LRLPlayLevel(CurrentLevel);
FadeClear;
ImageClear(LRLScreen^);
ScreenApply(LRLScreen^);
Palette256Set(LRLPalette^);
LRLLoadLevel(CurrentLevel);
Repress;
end;
if MSMouseButtonWasPressed(0, x, y) then
begin
DrawNow := True;
end;
if MSMouseButtonWasReleased(0, x, y) then
begin
DrawNow := False;
Cmd := 0;
for i := 1 to 6 do
LRLEditorButton[i].Lit := False;
for i := 1 to 6 do
begin
if MSMouseInArea(LRLEditorButton[i].x1, LRLEditorButton[i].y1,
LRLEditorButton[i].x2, LRLEditorButton[i].y2) then
begin
Cmd := LRLEditorButton[i].Command;
BREAK;
end;
end;
if (Cmd = 1) then
LRLSaveLevel(CurrentLevel);
Repress;
if (Cmd = 2) then
begin
LRLInsertLevel(CurrentLevel);
Inc(CurrentLevel);
TotalLevels := LRLLevelCount;
LRLLoadLevel(CurrentLevel);
Repress;
end;
if (Cmd = 3) and (CurrentLevel < TotalLevels) then
begin
Inc(CurrentLevel);
LRLLoadLevel(CurrentLevel);
Repress;
end;
if (Cmd = 4) then
begin
for i := 1 to 16 do
for j := 1 to 30 do
LRLLevel.Field[j, i].Image := 1;
for i := 1 to 10 do
LRLLevel.Player[i].Controller := 0;
Repress;
end;
if (Cmd = 5) and (TotalLevels > 1) then
begin
LRLDeleteLevel(CurrentLevel);
TotalLevels := LRLLevelCount;
if CurrentLevel > TotalLevels then
CurrentLevel := TotalLevels;
LRLLoadLevel(CurrentLevel);
Repress;
end;
if (Cmd = 6) and (CurrentLevel > 1) then
begin
Dec(CurrentLevel);
LRLLoadLevel(CurrentLevel);
Repress;
end;
MSMouseGetXY(Mousex, Mousey);
if (Mousey > 180) then
begin
for i := 1 to 13 do
begin
if (Mousey > 184) and (Mousey < 195) and (Mousex > i * 15 - 5) and (Mousex < i * 15 + 6) then
begin
CurrentTool := i;
BREAK;
end;
end;
end;
end;
if DrawNow then
begin
for i := 1 to 6 do
LRLEditorButton[i].Lit := False;
for i := 1 to 6 do
begin
if MSMouseInArea(LRLEditorButton[i].x1, LRLEditorButton[i].y1,
LRLEditorButton[i].x2, LRLEditorButton[i].y2) then
begin
LRLEditorButton[i].Lit := True;
BREAK;
end;
end;
MSMouseGetXY(Mousex, Mousey);
x := (Mousex) div 10;
y := (Mousey) div 10;
if (x > 0) and (x < 31) and (y > 0) and (y < 17) then
begin
for i := 1 to 10 do
begin
if (LRLLevel.Player[i].Controller <> 0) and (LRLLevel.Player[i].Position.x = x) and
(LRLLevel.Player[i].Position.y = y) then
begin
if (CurrentTool <> 2) and (CurrentTool <> 3) and (CurrentTool <> 4) and
(CurrentTool <> 7) then
begin
LRLLevel.Player[i].Controller := 0;
BREAK;
end;
end;
end;
if CurrentTool < 10 then
LRLLevel.Field[x, y].Image := CurrentTool
else
begin
if (LRLLevel.Field[x, y].Image = 2) or (LRLLevel.Field[x, y].Image = 3) or
(LRLLevel.Field[x, y].Image = 4) or (LRLLevel.Field[x, y].Image = 1) then
begin
if CurrentTool = 10 then
begin
LRLLevel.Player[1].Controller := 1;
LRLLevel.Player[1].Position.x := x;
LRLLevel.Player[1].Position.y := y;
LRLLevel.Player[1].Colour := 1;
end
else
begin
j := 2;
for i := 2 to 10 do
begin
if LRLLevel.Player[i].Controller = 0 then
begin
j := i;
BREAK;
end;
end;
LRLLevel.Player[j].Controller := 2;
LRLLevel.Player[j].Position.x := x;
LRLLevel.Player[j].Position.y := y;
LRLLevel.Player[j].Colour := CurrentTool - 9;
end;
end;
end;
end;
end;
until (LO(Keypress) = 27);
SetInterrupt($8, OldTimer);
end;
 
end.
/programs/games/lrl/LRLHighScores.pp
0,0 → 1,234
unit LRLHighScores;
 
 
interface
 
 
uses
LRLRoutines, LRLSprites, StrUnit;
 
 
procedure LRLLoadHighScores;
procedure LRLShowHighScores;
function LRLBestScore(Score: longint): boolean;
procedure LRLInsertScore(Name: string; Score: longint);
procedure LRLSaveHighScores;
function LRLEnterName: string;
 
 
implementation
 
 
const
HighsFileName = 'LRL.HSR';
HighsFileHeader: string[29] = 'Lode Runner Live High Scores'#26;
 
type
TSupers = packed record
Name: string[20];
Score: longint;
end;
 
var
MainScreen: POINTER;
HighFrame: POINTER;
HighTable: array[1..5] of TSupers;
 
procedure LoadData;
var
j: word;
begin
GETMEM(MainScreen, 64004);
GETMEM(HighFrame, 45000);
DFAFilePositionSet(ImageFile, LRLImagesFilePosition, DFASeekFromStart);
DFAFileRead(ImageFile, MainScreen^, 7940, j);
DecompressRepByte(MainScreen^, HighFrame^, 7940, j);
DFAFileRead(ImageFile, MainScreen^, 64004, j);
end;
 
procedure DisposeData;
begin
FREEMEM(MainScreen, 64004);
FREEMEM(HighFrame, 45000);
end;
 
procedure LRLShowHighScores;
var
p: POINTER;
i: integer;
s: string;
begin
LRLLoadHighScores;
GETMEM(p, 768);
DataFill(p^, 768, 0, 0);
Palette256Set(p^);
FREEMEM(p, 768);
LoadData;
ImagePut(LRLScreen^, MainScreen^, 0, 0, 0, 0, 319, 199);
ImagePut(LRLScreen^, HighFrame^, 6, 50, 0, 0, 319, 199);
for i := 1 to 5 do
begin
ImageStringGet(CHR(i + 48) + '. ' + HighTable[i].Name, LRLFont^, LRLFontBuffer^, 110);
ImagePut(LRLScreen^, LRLFontBuffer^, 55, 85 + i * 17, 8, 0, 319, 199);
STR(HighTable[i].Score, s);
ImageStringGet(s, LRLFont^, LRLFontBuffer^, 46);
ImagePut(LRLScreen^, LRLFontBuffer^, 260 - ImageSizex(LRLFontBuffer^), 85 + i * 17, 8, 0, 319, 199);
end;
ScreenApply(LRLScreen^);
FadeTo(LRLMenuPalette);
READKEY;
FadeClear;
ImageClear(LRLScreen^);
ScreenApply(LRLScreen^);
DisposeData;
end;
 
procedure LRLLoadHighScores;
var
InFile: TDFAFileHandle;
i, j: word;
high: TSupers;
dummy: string[30];
begin
high.Name := 'Lode Runner';
DFAFileOpen(InFile, HighsFileName, DFAAccessReadWrite);
if DFALastResult(InFile) <> 0 then
begin
DFAFileCreate(InFile, HighsFileName, DFAAttributeArchive);
DFAFileWrite(InFile, HighsFileHeader[1], 29, i);
for i := 1 to 5 do
begin
high.score := 60000 - i * 10000;
DFAFileWrite(InFile, high, SIZEOF(high), j);
end;
end;
DFAFilePositionSet(InFile, 0, DFASeekFromStart);
DFAFileRead(InFile, dummy[1], 29, j);
if (DFALastResult(InFile) <> 0) or
(not DataIdentical(dummy[1], HighsFileHeader[1], 29, 0, 0)) then
begin
WRITELN('Error: Invalid file with high scores! (try to remove LRL.HSR file)');
WRITELN('Žè¨¡ª : ¥¢¥à­ë© ä ©« á ४®à¤ ¬¨! (¯®¯à®¡ã©â¥ 㤠«¨âì ä ©« LRL.HSR)');
Halt(1);
end;
DFAFileRead(InFile, HighTable, SIZEOF(TSupers) * 5, j);
DFAFileClose(InFile);
end;
 
procedure LRLSaveHighScores;
var
InFile: TDFAFileHandle;
i, j: word;
begin
DFAFileOpen(InFile, HighsFileName, DFAAccessReadWrite);
DFAFilePositionSet(InFile, 29, DFASeekFromStart);
DFAFileWrite(InFile, HighTable, SIZEOF(TSupers) * 5, j);
DFAFileClose(InFile);
end;
 
function LRLBestScore(Score: longint): boolean;
var
i: integer;
begin
LRLBestScore := True;
LRLLoadHighScores;
i := 1;
while True do
begin
if Score >= HighTable[i].Score then
EXIT;
Inc(i);
if i > 5 then
begin
LRLBestScore := False;
EXIT;
end;
end;
end;
 
procedure LRLInsertScore(Name: string; Score: longint);
var
i, j: word;
begin
LRLLoadHighScores;
i := 1;
while True do
begin
if Score >= HighTable[i].Score then
begin
for j := 4 downto i do
begin
HighTable[j + 1].Name := HighTable[j].Name;
HighTable[j + 1].Score := HighTable[j].Score;
end;
HighTable[i].Name := Name;
HighTable[i].Score := Score;
LRLSaveHighScores;
EXIT;
end;
Inc(i);
if i > 5 then
begin
EXIT;
end;
end;
end;
 
function LRLEnterName: string;
var
p: POINTER;
i: integer;
RedrawName: boolean;
Keypress: word;
Name: string;
begin
Name := '';
GETMEM(p, 768);
DataFill(p^, 768, 0, 0);
Palette256Set(p^);
FREEMEM(p, 768);
ImageClear(LRLScreen^);
ImagePut(LRLScreen^, LRLLogo^, 3, 3, 0, 0, 319, 199);
ImageStringGet('Congratulations! You are in Top-Five!', LRLFont^, LRLFontBuffer^, 110);
ImagePut(LRLScreen^, LRLFontBuffer^, 160 - ImageSizex(LRLFontBuffer^) shr 1, 85, 0, 0, 319, 199);
ImageStringGet('Enter your name below, Champ', LRLFont^, LRLFontBuffer^, 111);
ImagePut(LRLScreen^, LRLFontBuffer^, 160 - ImageSizex(LRLFontBuffer^) shr
1, 110, 0, 0, 319, 199);
ImageStringGet('---------------------------', LRLFont^, LRLFontBuffer^, 100);
ImagePut(LRLScreen^, LRLFontBuffer^, 160 - ImageSizex(LRLFontBuffer^) shr
1, 155, 0, 0, 319, 199);
ScreenApply(LRLScreen^);
FadeTo(LRLMenuPalette);
RedrawName := True;
repeat
if RedrawName = True then
begin
ImageFill(LRLFontBuffer^, 320, 20, 0);
ImagePut(LRLScreen^, LRLFontBuffer^, 0, 140, 0, 0, 319, 199);
ImageStringGet(Name, LRLFont^, LRLFontBuffer^, 100);
ImagePut(LRLScreen^, LRLFontBuffer^, 160 - ImageSizex(LRLFontBuffer^) shr
1, 140, 0, 0, 319, 199);
ScreenApply(LRLScreen^);
RedrawName := False;
end;
Keypress := READKEY;
if (LO(Keypress) = 8) and (LENGTH(Name) > 0) then
begin
Name[0] := char(Ord(Name[0]) - 1);
RedrawName := True;
end;
if (LO(Keypress) > 31) and (LENGTH(Name) < 20) then
begin
Name := Name + char(LO(Keypress));
RedrawName := True;
end;
until LO(Keypress) = 13;
FadeClear;
Name := StringTrimAll(Name, ' ');
if LENGTH(Name) = 0 then
Name := 'Anonymous';
LRLEnterName := Name;
end;
 
 
end.
/programs/games/lrl/LRLIntroduction.pp
0,0 → 1,135
unit LRLIntroduction;
 
 
interface
 
 
uses
SysUtils,
LRLRoutines, LRLSprites;
 
 
procedure LRLIntro;
 
 
implementation
 
 
const
IntroText: array[1..14] of String = (
'Lode Runner LIVE. FREEWARE Version 1.0',
'KolibriOS port by bw (Vladimir V. Byrgazov)',
'Copyright (c) 1995 Aleksey V. Vaneev',
'Copyright (c) 2007 bw',
'',
'Send comments to Aleksey V. Vaneev',
'2:5003/15@FidoNet',
'ikomi@glas.apc.org',
'',
'Send comments to bw',
'bw@handsdriver.net',
'',
'',
''
);
 
SPACE40 = ' ';
 
 
var
RefreshDelay: Word;
RefreshRemain: Word;
TimeToRefresh: Boolean;
OldTimer: Pointer;
 
 
procedure LRLIntro;
var
i, j, l: Integer;
Count: Word;
k: Word;
MainScreen: Pointer;
begin
RefreshDelay := 1;
RefreshRemain := 1;
GetMem(MainScreen, 64004);
 
Seek(ImageFile, LRLImagesFilePosition + 7940);
BlockRead(ImageFile, MainScreen^, 64004, k);
Palette256Set(LRLMenuPalette^);
ImageFill(LRLFontBuffer^, 320, 55, 0);
ImageClear(LRLScreen^);
 
for i := -50 to 4 do
begin
ImagePut(LRLScreen^, LRLFontBuffer^, 0, 0, 0, 0, 319, 199);
ImagePut(LRLScreen^, LRLLogo^, 3, i, 0, 0, 319, 199);
ScreenApply(LRLScreen^);
if Keypressed then
begin
ReadKey;
FreeMem(MainScreen, 64004);
Exit;
end;
Sleep(10);
end;
 
ImageFill(LRLFontBuffer^, 320, 55, 0);
for i := 0 to 10 do
begin
for k := 0 to 20 do
for j := 0 to 16 do
ImagePutTransparent(LRLScreen^, MainScreen^, 0, 0,
j * 20 - 10 - i, k * 20 - 10 - i,
j * 20 - 10 + i, k * 20 - 10 + i);
 
Sleep(50);
 
ImagePut(LRLScreen^, LRLFontBuffer^, 0, 182, 0, 0, 319, 199);
ScreenApply(LRLScreen^);
if Keypressed then
begin
ReadKey;
FreeMem(MainScreen, 64004);
Exit;
end;
end;
 
Count := 1;
k := 1;
repeat
if TimeToRefresh then
begin
Inc(Count);
TimeToRefresh := False;
end;
 
if Count >= 2 then
begin
ImageStringGet(SPACE40 + IntroText[k] + SPACE40, LRLFont^, LRLFontBuffer^, 110);
for l := 200 downto 184 do
begin
ImagePut(LRLScreen^, LRLFontBuffer^, 160 - ImageSizeX(LRLFontBuffer^) div 2, l, 0, 0, 319, 199);
ScreenApply(LRLScreen^);
Sleep(20);
end;
Inc(k);
if k > Length(IntroText) then k := 1;
Count := 0;
end;
 
for I := 1 to 8 do
if Keypressed then
Break else
Sleep(250);
 
TimeToRefresh := True;
until KeyPressed;
 
ReadKey;
FadeClear;
FreeMem(MainScreen, 64004);
end;
 
 
end.
/programs/games/lrl/LRLLevels.pp
0,0 → 1,1194
unit LRLLevels;
 
{$mode objfpc}
 
 
interface
 
 
uses
SysUtils,
LRLRoutines, LRLSprites;
 
 
type
TLRLPlayerPosition = packed record
x, y: Byte;
xoffs, yoffs: ShortInt;
end;
 
TLRLPlayer = packed record
Command: Byte;
{ pictures:
1 - running left <-
2 - running right ->
3 - climbing up ^
4 - climbing down v
5 - falling
6 - ~~~~~ left <-
7 - ~~~~~ right ->
8 - firing left <-
9 - firing right ->
}
NewCommandWas: Boolean;
NewCommand: Byte;
Position: TLRLPlayerPosition;
Sprite: Byte;
SpriteData: Byte;
Controller: Byte;
{
controllers:
0 - not playing
1 - human/keyboard
2 - computer
}
Prizes: Byte;
{
max 1 if computer player
a) computer player leaves prize if falling into hole
b) takes prize if he has no prizes
}
Colour: Byte;
end;
 
TLRLBrick = packed record
Image: Byte;
Count: Byte;
Flags: Byte;
{ flags:
bit 0 - needed to animate this brick 5 sprites then pause
and then finnally 5 sprites
bit 1 - set if fatal brick
bit 2 - set if allowable to jump
bit 3 - allowable to walk thru
bit 4 - hidden
bit 5 - background
bit 6 - wait now
bit 7 - not draw it
}
IdleCount: Byte;
end;
 
TLRLLevel = packed record
Field: array[1..30, 1..16] of TLRLBrick;
Player: array[1..20] of TLRLPlayer;
end;
 
 
const
BrickFlags: array[1..20] of Byte = (
48, 4 + 8 + 32 + 128,
49, 8 + 32,
50, 4 + 8 + 32,
51, 4 + 8 + 32,
52, 2,
53, 4,
54, 4 + 8,
55, 2,
56, 2,
65, 4 + 8 + 16 + 32);
 
 
const
KeyboardControls: array[1..21] of Word = (
$00B0, 1, 1,
$00B3, 1, 2,
$00B2, 1, 3,
$00B1, 1, 4,
$00B5, 1, 6,
$00B7, 1, 7,
$0037, 1, 5);
ControlNumber = 7;
 
 
var
ShowLives: Boolean;
ShowScore: Boolean;
ShowLevel: Boolean;
LRLLevel: TLRLLevel;
LRLLives: Integer;
LRLScore: Longint;
LRLCLevel: Word;
ComputerTurn: Word;
ComputerReaction: Word;
TimeToRefresh: Boolean;
OldTimer: Pointer;
TotalPrizes: Integer;
GameStarted: Boolean;
EndOfGame: Boolean;
GameResult: Word;
Paused: Boolean;
 
 
procedure LRLLoadLevel(Number: Byte);
procedure LRLUpdatePlayers;
procedure LRLDrawOrnamental(x1, y1, x2, y2, ornament: Byte);
function LRLPlayLevel(Number: Byte): Word;
function LRLLevelCount: Word;
procedure LRLDeleteLevel(Count: Word);
procedure LRLInsertLevel(After: Word);
procedure LRLSaveLevel(Count: Word);
 
 
implementation
 
 
const
LevelFileName = 'LRL.LEV';
LevelFileHeader: String = 'Lode Runner Live Levels'#26;
 
ERR_OPENFILE = '¥¢®§¬®¦­® ®âªàëâì ä ©« ã஢­¥©';
ERR_BADFILE = '¥¢¥à­ë© ¨«¨ ¯®¢à¥¦¤¥­­ë© ä ©« ã஢­¥©';
 
 
function LRLLevelCount: Word;
var
LevelFile: File;
c, k: Word;
begin
c := 0;
AssignFile(LevelFile, LevelFileName);
Reset(LevelFile, 1);
Seek(LevelFile, 24);
BlockRead(LevelFile, c, 1, k);
LRLLevelCount := c;
Close(LevelFile);
end;
 
 
procedure LRLSaveLevel(Count: Word);
var
LevelFile: File;
i, j: Integer;
k: Word;
b: Pointer;
begin
GetMem(b, 480);
if (Count = 0) or (Count > LRLLevelCount) then
Exit;
AssignFile(LevelFile, LevelFileName);
Reset(LevelFile, 1);
Seek(LevelFile, Longint(25 + 520 * (Longint(Count) - 1)));
for i := 1 to 10 do
begin
DataBytePut(b^, (i - 1) * 4, LRLLevel.Player[i].Position.x);
DataBytePut(b^, (i - 1) * 4 + 1, LRLLevel.Player[i].Position.y);
DataBytePut(b^, (i - 1) * 4 + 2, LRLLevel.Player[i].Colour);
DataBytePut(b^, (i - 1) * 4 + 3, LRLLevel.Player[i].Controller);
end;
BlockWrite(LevelFile, b^, 40, k);
for i := 1 to 16 do
for j := 1 to 30 do
DataBytePut(b^, (i - 1) * 30 + j - 1, LRLLevel.Field[j, i].Image + 47);
BlockWrite(LevelFile, b^, 480, k);
Close(LevelFile);
FreeMem(b, 480);
end;
 
 
procedure LRLDeleteLevel(Count: Word);
var
Buffer: Pointer;
LevelFile: File;
i, j: Integer;
l: Longint;
k: Word;
begin
GetMem(Buffer, 1000);
j := LRLLevelCount;
if (j < Count) or (j < 2) or (Count = 0) then
Exit;
AssignFile(LevelFile, LevelFileName);
Reset(LevelFile, 1);
for l := Count + 1 to j do
begin
Seek(LevelFile, Longint(25 + 520 * (Longint(l) - 1)));
BlockRead(LevelFile, Buffer^, 520, k);
Seek(LevelFile, Longint(25 + 520 * (Longint(l - 1) - 1)));
BlockWrite(LevelFile, Buffer^, 520, k);
end;
Seek(LevelFile, 24);
Dec(j);
BlockWrite(LevelFile, j, 1, k);
Seek(LevelFile, FileSize(LevelFile) - 520);
Truncate(LevelFile);
Close(LevelFile);
FreeMem(Buffer, 1000);
end;
 
 
procedure LRLInsertLevel(After: Word);
var
Buffer: Pointer;
LevelFile: File;
i, j: Integer;
l: Longint;
k: Word;
begin
GetMem(Buffer, 1000);
j := LRLLevelCount;
if (After > j) or (After = 0) then
Exit;
AssignFile(LevelFile, LevelFileName);
Reset(LevelFile, 1);
for l := j downto After + 1 do
begin
Seek(LevelFile, Longint(25 + 520 * (Longint(l) - 1)));
BlockRead(LevelFile, Buffer^, 520, k);
Seek(LevelFile, Longint(25 + 520 * (Longint(l + 1) - 1)));
BlockWrite(LevelFile, Buffer^, 520, k);
end;
Seek(LevelFile, 24);
Inc(j);
BlockWrite(LevelFile, j, 1, k);
Seek(LevelFile, Longint(25 + 520 * (Longint(After + 1) - 1)));
DataFill(Buffer^, 40, 0, 0);
DataFill(Buffer^, 480, 48, 40);
BlockWrite(LevelFile, Buffer^, 520, k);
Close(LevelFile);
FreeMem(Buffer, 1000);
end;
 
 
procedure LRLLoadLevel(Number: Byte);
var
LevelFile: File;
InBuffer: Pointer;
i, j, k, l, x, y: Word;
a, b, c: Byte;
begin
TotalPrizes := 0;
GetMem(InBuffer, $FFF0);
 
AssignFile(LevelFile, LevelFileName);
Reset(LevelFile, 1);
if IOResult <> 0 then
raise Exception.Create(ERR_OPENFILE);
 
BlockRead(LevelFile, InBuffer^, 24, k);
BlockRead(LevelFile, c, 1, k);
if (c = 0) or (IOResult <> 0) or (not DataIdentical(InBuffer^, LevelFileHeader[1], 24, 0, 0)) then
raise Exception.Create(ERR_BADFILE);
 
if (Number = 0) or (Number > c) then Number := 1;
Seek(LevelFile, Longint(25 + 520 * (Longint(Number) - 1)));
BlockRead(LevelFile, InBuffer^, 40, k);
 
for i := 1 to 10 do
with LRLLevel.Player[i] do
begin
Command := 10;
NewCommandWas := False;
NewCommand := 10;
Position.x := DataByteGet(InBuffer^, (i - 1) * 4 + 0);
Position.y := DataByteGet(InBuffer^, (i - 1) * 4 + 1);
Position.xoffs := 0;
Position.yoffs := 0;
Sprite := 1;
SpriteData := 1;
Controller := DataByteGet(InBuffer^, (i - 1) * 4 + 3);
Prizes := 0;
Colour := DataByteGet(InBuffer^, (i - 1) * 4 + 2);
end;
 
BlockRead(LevelFile, InBuffer^, 480, k);
for i := 1 to 16 do for j := 1 to 30 do
with LRLLevel.Field[j, i] do
begin
a := DataByteGet(InBuffer^, (i - 1) * 30 + (j - 1));
for b := 1 to 10 do
if BrickFlags[b * 2 - 1] = a then
Flags := BrickFlags[b * 2];
Count := 1;
if a < 64 then
a := a - 47 else
a := a - 63;
Image := a;
IdleCount := 0;
if Image = 4 then Inc(TotalPrizes);
end;
 
BlockRead(LevelFile, InBuffer^, 480, k);
Close(LevelFile);
LRLCLevel := Number;
FreeMem(InBuffer, $FFF0);
end;
 
 
procedure LRLDrawOrnamental(x1, y1, x2, y2, ornament: Byte);
var
i: Integer;
begin
ImagePut(LRLScreen^, LRLDecoration[ornament].Image[6].Data^, x1 * 10, y1 * 10, 0, 0, 319, 199);
ImagePut(LRLScreen^, LRLDecoration[ornament].Image[7].Data^, x2 * 10, y1 * 10, 0, 0, 319, 199);
ImagePut(LRLScreen^, LRLDecoration[ornament].Image[5].Data^, x1 * 10, y2 * 10, 0, 0, 319, 199);
ImagePut(LRLScreen^, LRLDecoration[ornament].Image[8].Data^, x2 * 10, y2 * 10, 0, 0, 319, 199);
for i := x1 + 1 to x2 - 1 do
begin
ImagePut(LRLScreen^, LRLDecoration[ornament].Image[3].Data^, i * 10, y1 * 10, 0, 0, 319, 199);
ImagePut(LRLScreen^, LRLDecoration[ornament].Image[4].Data^, i * 10, y2 * 10, 0, 0, 319, 199);
end;
for i := y1 + 1 to y2 - 1 do
begin
ImagePut(LRLScreen^, LRLDecoration[ornament].Image[2].Data^, x1 * 10, i * 10, 0, 0, 319, 199);
ImagePut(LRLScreen^, LRLDecoration[ornament].Image[1].Data^, x2 * 10, i * 10, 0, 0, 319, 199);
end;
end;
 
 
procedure LRLRedrawLevel;
var
i, j: Integer;
s: string;
begin
ImageClear(LRLScreen^);
for i := 1 to 16 do for j := 1 to 30 do
with LRLLevel.Field[j, i] do
if ((Flags and 128) = 0) and ((Flags and 32) <> 0) and ((Flags and 16) = 0) then
ImagePut(LRLScreen^, LRLEnvironment[Image].Image[Count].Data^,j * 10, i * 10, 0, 0, 319, 199);
 
for i := 1 to 10 do
with LRLLevel.Player[i] do
if Controller <> 0 then
ImagePutTransparent(LRLScreen^, LRLFigure[Colour, SpriteData].Image[Sprite].Data^,Position.x * 10 + Position.xoffs, Position.y * 10 + Position.yoffs, 0, 0, 319, 199);
 
for i := 1 to 16 do for j := 1 to 30 do
with LRLLevel.Field[j, i] do
if ((Flags and 128) = 0) and ((Flags and 32) = 0) and ((Flags and 16) = 0) then
ImagePutTransparent(LRLScreen^, LRLEnvironment[Image].Image[LRLLevel.Field[j, i].Count].Data^, j * 10, i * 10, 0, 0, 319, 199);
 
if not Paused then
begin
if ShowScore then
begin
STR(LRLScore, s);
ImageStringGet(s, LRLFont^, LRLFontBuffer^, 222);
ImagePut(LRLScreen^, LRLFontBuffer^, 56, 185, 0, 0, 319, 199);
ImageStringGet('Score: ', LRLFont^, LRLFontBuffer^, 254);
ImagePut(LRLScreen^, LRLFontBuffer^, 10, 185, 0, 0, 319, 199);
end;
if ShowLives then
begin
STR(LRLLives, s);
ImageStringGet(s, LRLFont^, LRLFontBuffer^, 222);
ImagePut(LRLScreen^, LRLFontBuffer^, 177, 185, 0, 0, 319, 199);
ImageStringGet('Lives: ', LRLFont^, LRLFontBuffer^, 254);
ImagePut(LRLScreen^, LRLFontBuffer^, 135, 185, 0, 0, 319, 199);
end;
if ShowLevel then
begin
Str(LRLCLevel, s);
ImageStringGet(s, LRLFont^, LRLFontBuffer^, 222);
ImagePut(LRLScreen^, LRLFontBuffer^, 292, 185, 0, 0, 319, 199);
ImageStringGet('Level: ', LRLFont^, LRLFontBuffer^, 254);
ImagePut(LRLScreen^, LRLFontBuffer^, 250, 185, 0, 0, 319, 199);
end;
end
else
begin
ImageStringGet('Game now paused', LRLFont^, LRLFontBuffer^, 254);
ImagePut(LRLScreen^, LRLFontBuffer^, 160 - ImageSizex(LRLFontBuffer^) div
2, 185, 0, 0, 319, 199);
end;
LRLDrawOrnamental(0, 0, 31, 17, 1);
end;
 
 
procedure LRLStartSequence;
var
tmpScreen1: Pointer;
tmpScreen2: Pointer;
i: Integer;
begin
GetMem(tmpScreen1, 64000);
GetMem(tmpScreen2, 49000);
ImageFill(tmpScreen2^, 300, 160, 0);
LRLRedrawLevel;
i := 0;
while i < 100 do
begin
DataMove(LRLScreen^, tmpScreen1^, 64000, 0, 0);
ImagePut(tmpScreen1^, tmpScreen2^, 10, 10, 0, i, 319, 199 - i);
ScreenApply(tmpScreen1^);
Sleep(20);
i := i + 4;
end;
ScreenApply(LRLScreen^);
FreeMem(tmpScreen1, 64000);
FreeMem(tmpScreen2, 49000);
end;
 
 
procedure LRLEndSequence;
var
tmpScreen1: Pointer;
tmpScreen2: Pointer;
i: Integer;
begin
GetMem(tmpScreen1, 64000);
GetMem(tmpScreen2, 49000);
ImageFill(tmpScreen2^, 300, 160, 0);
LRLRedrawLevel;
i := 100;
while i > 0 do
begin
DataMove(LRLScreen^, tmpScreen1^, 64000, 0, 0);
ImagePut(tmpScreen1^, tmpScreen2^, 10, 10, 0, i, 319, 199 - i);
ScreenApply(tmpScreen1^);
Sleep(20);
i := i - 4;
end;
ImagePut(LRLScreen^, tmpScreen2^, 10, 10, 0, 0, 319, 199);
ScreenApply(LRLScreen^);
FreeMem(tmpScreen1, 64000);
FreeMem(tmpScreen2, 49000);
end;
 
 
{
game result:
1 - zamurovali
2 - poimali
10 - vse zdelano
50 - no more levels
60 - no human players
100 - esc was pressed
}
procedure LRLUpdatePlayers;
var
i, j, k: Integer;
spd: Word;
begin
for i := 1 to 10 do
begin
with LRLLevel.Player[i] do
begin
if Controller <> 0 then
begin
if (LRLLevel.Field[Position.x, Position.y].Flags and 2 <> 0) then
begin
if i = 1 then
begin
EndOfGame := True;
GameResult := 1;
Exit;
end;
if Prizes <> 0 then
begin
Prizes := 0;
LRLLevel.Field[Position.x, Position.y - 1].Image := 4;
LRLLevel.Field[Position.x, Position.y - 1].Flags := BrickFlags[8];
end;
repeat
Position.y := Random(2) + 1;
Position.x := Random(30) + 1;
until (LRLLevel.Field[Position.x, Position.y].Image = 1) or
(LRLLevel.Field[Position.x, Position.y].Image = 2) or
(LRLLevel.Field[Position.x, Position.y].Image = 3) or
(LRLLevel.Field[Position.x, Position.y].Image = 4);
Command := 10;
Continue;
end;
 
if LRLLevel.Field[Position.x, Position.y].Image = 4 then
if Controller = 2 then
if Prizes = 0 then
begin
Inc(Prizes);
LRLLevel.Field[Position.x, Position.y].Image := 1;
LRLLevel.Field[Position.x, Position.y].Flags := BrickFlags[2];
end else else
begin
Dec(TotalPrizes);
LRLScore := LRLScore + 100 * Longint(LRLCLevel);
LRLLevel.Field[Position.x, Position.y].Image := 1;
LRLLevel.Field[Position.x, Position.y].Flags := BrickFlags[2];
end;
 
if (i = 1) then
begin
if (TotalPrizes = 0) and (Position.y = 1) and
(LRLLevel.Field[Position.x, Position.y].Image = 2) then
begin
EndOfGame := True;
GameResult := 10;
Exit;
end;
for k := 2 to 10 do
if (LRLLevel.Player[k].Controller <> 0) then
if (LRLLevel.Player[k].Position.x = Position.x) and
(LRLLevel.Player[k].Position.y = Position.y) then
begin
EndOfGame := True;
GameResult := 2;
Exit;
end;
end;
if (LRLLevel.Field[Position.x, Position.y].Flags and 1 <> 0) then
begin
if (Controller = 2) then
begin
if Prizes <> 0 then
begin
Prizes := 0;
LRLLevel.Field[Position.x, Position.y - 1].Image := 4;
LRLLevel.Field[Position.x, Position.y - 1].Flags := BrickFlags[8];
end;
end;
end;
if Controller = 2 then
spd := 2
else
spd := 3;
 
if (LRLLevel.Field[Position.x, Position.y + 1].Flags and 4 <> 0) and
(LRLLevel.Field[Position.x, Position.y].Image <> 3) and
((LRLLevel.Field[Position.x, Position.y].Image <> 2) or
(LRLLevel.Field[Position.x, Position.y].Flags and 16 <> 0)) and
(Position.y < 16) then
begin
k := 2;
while k <= 10 do
if (k <> i) and (LRLLevel.Player[k].Controller <> 0) and
(LRLLevel.Player[k].Position.x = Position.x) and
(LRLLevel.Player[k].Position.y = Position.y + 1) and
(Position.y < 16) then
begin
k := 100;
Break;
end else
Inc(k);
 
if k <> 100 then
begin
NewCommand := 5;
NewCommandWas := True;
end;
end;
 
if NewCommandWas then
begin
if (NewCommand <> Command) and (Command <> 5) then
begin
Command := NewCommand;
Sprite := 1;
end;
NewCommandWas := False;
end;
 
if (Command = 1) then
begin
if (LRLLevel.Field[Position.x, Position.y].Image = 3) then
begin
if Position.xoffs < 1 then
begin
if ((LRLLevel.Field[Position.x - 1, Position.y].Flags and 8 = 0) and
(LRLLevel.Field[Position.x - 1, Position.y].Image <> 3)) or
(LRLLevel.Field[Position.x, Position.y].Image <> 3) or (Position.x = 1) then
begin
Command := 10;
Position.xoffs := 0;
end;
end;
if (Command <> 10) and (SpriteData <> 6) then
begin
SpriteData := 6;
Sprite := 1;
end;
end else
begin
if Position.xoffs < 1 then
begin
if (LRLLevel.Field[Position.x - 1, Position.y].Flags and 8 = 0) or (Position.x = 1) then
begin
Command := 10;
Position.xoffs := 0;
end;
end;
if (Command <> 10) and (SpriteData <> 1) then SpriteData := 1;
end;
 
if Command <> 10 then
begin
k := 1;
while (k > 0) do
begin
Inc(k);
if k = 11 then
begin
if (SpriteData = 6) then
begin
if (Sprite = 2) then Dec(Position.xoffs, 5) else
if (Sprite = 3) then Dec(Position.xoffs, 1);
end else
Dec(Position.xoffs, spd);
Break;
end;
if (k <> i) and (i <> 1) and
(LRLLevel.Player[k].Controller <> 0) and
(LRLLevel.Player[k].Position.x = Position.x - 1) and
(LRLLevel.Player[k].Position.y = Position.y) then
begin
Command := 10;
Break;
end;
end;
end;
end;
 
if (Command = 2) then
begin
if (LRLLevel.Field[Position.x, Position.y].Image = 3) then
begin
if Position.xoffs > -1 then
begin
if ((LRLLevel.Field[Position.x + 1, Position.y].Flags and 8 = 0) and
(LRLLevel.Field[Position.x + 1, Position.y].Image <> 3)) or
(LRLLevel.Field[Position.x, Position.y].Image <> 3) or (Position.x = 30) then
begin
Command := 10;
Position.xoffs := 0;
end;
end;
if (Command <> 10) and (SpriteData <> 7) then
begin
SpriteData := 7;
Sprite := 1;
end;
end
else
begin
if Position.xoffs > -1 then
begin
if (LRLLevel.Field[Position.x + 1, Position.y].Flags and 8 = 0) or (Position.x = 30) then
begin
Command := 10;
Position.xoffs := 0;
end;
end;
if (Command <> 10) and (SpriteData <> 2) then
SpriteData := 2;
end;
if Command <> 10 then
begin
k := 1;
while (k > 0) do
begin
Inc(k);
if k = 11 then
begin
if (SpriteData = 7) then
begin
if (Sprite = 2) then
Inc(Position.xoffs, 5);
if (Sprite = 3) then
Inc(Position.xoffs, 1);
end
else
Inc(Position.xoffs, spd);
Break;
end;
if (k <> i) and (i <> 1) and (LRLLevel.Player[k].Controller <> 0) then
if (LRLLevel.Player[k].Position.x = Position.x + 1) and
(LRLLevel.Player[k].Position.y = Position.y) then
begin
Command := 10;
Break;
end;
end;
end;
end;
 
if (Command = 3) then
begin
if Position.yoffs < 1 then
begin
if ((LRLLevel.Field[Position.x, Position.y].Image <> 2) or
(LRLLevel.Field[Position.x, Position.y].Flags and 16 <> 0)) or
((LRLLevel.Field[Position.x, Position.y - 1].Flags and 4 = 0) and
((LRLLevel.Field[Position.x, Position.y - 1].Image <> 2) or
(LRLLevel.Field[Position.x, Position.y - 1].Flags and 16 <> 0))) or
(Position.y < 2) then
begin
Command := 10;
Position.yoffs := 0;
end;
end;
if (Command <> 10) and (SpriteData <> 3) then
SpriteData := 3;
if Command <> 10 then
begin
k := 1;
while (k > 0) do
begin
Inc(k);
if k = 11 then
begin
Dec(Position.yoffs, spd);
Break;
end;
if (k <> i) and (i <> 1) and (LRLLevel.Player[k].Controller <> 0) then
if (LRLLevel.Player[k].Position.y = Position.y - 1) and
(LRLLevel.Player[k].Position.x = Position.x) then
begin
Command := 10;
Break;
end;
end;
end;
end;
 
if (Command = 4) then
begin
if (LRLLevel.Field[Position.x, Position.y].Image = 3) and
((LRLLevel.Field[Position.x, Position.y + 1].Image <> 2) or
(LRLLevel.Field[Position.x, Position.y + 1].Flags and 16 <> 0)) and
(Position.y < 16) then
begin
Command := 5;
Sprite := 1;
if (LRLLevel.Field[Position.x, Position.y + 1].Flags and 4 <> 0) then
Inc(Position.yoffs);
end
else
begin
if Position.yoffs > -1 then
begin
if (((LRLLevel.Field[Position.x, Position.y + 1].Image <> 2) or
(LRLLevel.Field[Position.x, Position.y + 1].Flags and 16 <> 0)) and
(LRLLevel.Field[Position.x, Position.y + 1].Flags and 4 = 0)) or
(Position.y = 16) then
begin
Command := 10;
Position.yoffs := 0;
end;
end;
if (Command <> 10) and (SpriteData <> 4) then
SpriteData := 4;
if Command <> 10 then
begin
k := 1;
while (k > 0) do
begin
Inc(k);
if k = 11 then
begin
Inc(Position.yoffs, spd);
Break;
end;
if (k <> i) and (i <> 1) and (LRLLevel.Player[k].Controller <> 0) then
if (LRLLevel.Player[k].Position.y = Position.y + 1) and
(LRLLevel.Player[k].Position.x = Position.x) then
begin
Command := 10;
Break;
end;
end;
end;
end;
end;
 
if (Command = 5) then
begin
if Position.yoffs < 1 then
begin
if (LRLLevel.Field[Position.x, Position.y + 1].Flags and 4 = 0) or
(Position.y = 16) or (LRLLevel.Field[Position.x, Position.y].Image = 3) or
((LRLLevel.Field[Position.x, Position.y].Flags and 1 <> 0) and (i <> 1)) then
begin
Command := 10;
if (LRLLevel.Field[Position.x, Position.y].Image = 3) then
SpriteData := 5;
Position.yoffs := 0;
Position.xoffs := 0;
end;
for k := 2 to 10 do
if (k <> i) and (LRLLevel.Player[k].Controller <> 0) then
if (LRLLevel.Player[k].Position.x = Position.x) and
(LRLLevel.Player[k].Position.y = Position.y + 1) and
(LRLLevel.Field[Position.x, Position.y + 1].Flags and 1 <> 0) and
(Position.y < 16) then
begin
Command := 10;
Position.yoffs := 0;
Break;
end;
end;
if (Command <> 10) and (SpriteData <> 5) then
begin
SpriteData := 5;
Sprite := 1;
end;
if Command <> 10 then
begin
Inc(Position.yoffs, 2);
end;
end;
 
if (Command = 6) then
begin
if (Position.y < 16) and (Position.x > 1) and
(LRLLevel.Field[Position.x - 1, Position.y + 1].Image = 9) and
(LRLLevel.Field[Position.x - 1, Position.y + 1].Flags and 1 = 0) and
(((LRLLevel.Field[Position.x - 1, Position.y].Image = 1) or
(LRLLevel.Field[Position.x - 1, Position.y].Flags and 1 <> 0)) or
(LRLLevel.Field[Position.x - 1, Position.y].Flags and 16 <> 0)) then
begin
NewCommandWas := True;
for k := 2 to 10 do
if (k <> i) and (LRLLevel.Player[k].Controller <> 0) then
if (LRLLevel.Player[k].Position.x = Position.x - 1) and
(LRLLevel.Player[k].Position.y = Position.y) then
begin
NewCommandWas := False;
Break;
end;
if NewCommandWas then
begin
LRLLevel.Field[Position.x - 1, Position.y + 1].Flags :=
LRLLevel.Field[Position.x - 1, Position.y + 1].Flags or 1;
Position.xoffs := 0;
SpriteData := 8;
NewCommandWas := False;
end;
end;
Command := 10;
end;
 
if (Command = 7) then
begin
if (Position.y < 16) and (Position.x < 30) and
(LRLLevel.Field[Position.x + 1, Position.y + 1].Image = 9) and
(LRLLevel.Field[Position.x + 1, Position.y + 1].Flags and 1 = 0) and
(((LRLLevel.Field[Position.x + 1, Position.y].Image = 1) or
(LRLLevel.Field[Position.x + 1, Position.y].Flags and 1 <> 0)) or
(LRLLevel.Field[Position.x + 1, Position.y].Flags and 16 <> 0)) then
begin
NewCommandWas := True;
for k := 2 to 10 do
if (k <> i) and (LRLLevel.Player[k].Controller <> 0) then
if (LRLLevel.Player[k].Position.x = Position.x + 1) and
(LRLLevel.Player[k].Position.y = Position.y) then
begin
NewCommandWas := False;
Break;
end;
if NewCommandWas then
begin
LRLLevel.Field[Position.x + 1, Position.y + 1].Flags :=
LRLLevel.Field[Position.x + 1, Position.y + 1].Flags or 1;
Position.xoffs := 0;
SpriteData := 9;
NewCommandWas := False;
end;
end;
Command := 10;
end;
 
if (Command = 1) or (Command = 2) then
if Position.yoffs < 0 then Inc(Position.yoffs) else
if Position.yoffs > 0 then Dec(Position.yoffs);
 
if (Command = 3) or (Command = 4) or (Command = 5) then
if Position.xoffs < 0 then Inc(Position.xoffs) else
if Position.xoffs > 0 then Dec(Position.xoffs);
 
if Command < 6 then
begin
Inc(Sprite);
if Sprite > LRLFigure[Colour, SpriteData].ImageCount then Sprite := 1;
if Position.xoffs < -4 then
begin
Dec(Position.x);
Position.xoffs := 10 + Position.xoffs;
end;
if Position.xoffs > 5 then
begin
Inc(Position.x);
Position.xoffs := Position.xoffs - 10;
end;
if Position.yoffs < -4 then
begin
Dec(Position.y);
Position.yoffs := 10 + Position.yoffs;
end;
if Position.yoffs > 5 then
begin
Inc(Position.y);
Position.yoffs := Position.yoffs - 10;
end;
end;
end;
end;
end;
end;
 
 
procedure LRLUpdateBricks;
var
i, j, k: Integer;
begin
for i := 1 to 16 do
for j := 1 to 30 do
begin
if LRLLevel.Field[j, i].Flags and 1 <> 0 then
begin
if LRLLevel.Field[j, i].Count = 1 then
begin
LRLLevel.Field[j, i].Flags := LRLLevel.Field[j, i].Flags and $FF - 2;
LRLLevel.Field[j, i].Flags := LRLLevel.Field[j, i].Flags or 4 + 8;
end;
if LRLLevel.Field[j, i].IdleCount = 0 then
begin
Inc(LRLLevel.Field[j, i].Count);
if LRLLevel.Field[j, i].Count < 6 then
begin
for k := 2 to 10 do
if (LRLLevel.Player[k].Controller <> 0) then
if (LRLLevel.Player[k].Position.x = j) and
(LRLLevel.Player[k].Position.y = i - 1) then
begin
LRLLevel.Field[j, i].Count := 13 - LRLLevel.Field[j, i].Count;
LRLLevel.Field[j, i].Flags := LRLLevel.Field[j, i].Flags or 2;
LRLLevel.Field[j, i].Flags := LRLLevel.Field[j, i].Flags and $FE - 4 - 8;
LRLLevel.Field[j, i].Count := 1;
Break;
end;
end;
if LRLLevel.Field[j, i].Count = 6 then
begin
LRLLevel.Field[j, i].IdleCount := 100;
end;
end
else
Dec(LRLLevel.Field[j, i].IdleCount);
if LRLLevel.Field[j, i].Count = 12 then
begin
LRLLevel.Field[j, i].Flags := LRLLevel.Field[j, i].Flags or 2;
LRLLevel.Field[j, i].Flags := LRLLevel.Field[j, i].Flags and $FE - 4 - 8;
LRLLevel.Field[j, i].Count := 1;
end;
end;
end;
end;
 
 
procedure LRLComputerPlayer;
var
k, l, m, f1, f2, i, j: Integer;
begin
if ComputerTurn >= ComputerReaction then
begin
ComputerTurn := 0;
for k := 1 to 10 do
begin
with LRLLevel.Player[k] do
begin
if Controller = 2 then
begin
NewCommandWas := True;
NewCommand := 10;
if (Position.y > LRLLevel.Player[1].Position.y) then
begin
if ((LRLLevel.Field[Position.x, Position.y].Image = 2) and
(LRLLevel.Field[Position.x, Position.y].Flags and 16 = 0) and
((LRLLevel.Field[Position.x, Position.y - 1].Image = 2) or
(LRLLevel.Field[Position.x, Position.y - 1].Flags and 4 <> 0)) and
(Position.y > 1)) then
begin
NewCommand := 3;
end
else
begin
m := 1;
l := Position.x;
i := 1;
while i <> 0 do
begin
l := l + i;
if ((LRLLevel.Field[l, Position.y].Image = 2) and
(LRLLevel.Field[l, Position.y].Flags and 16 = 0)) and
((LRLLevel.Field[l, Position.y - 1].Image = 2) and
(LRLLevel.Field[l, Position.y - 1].Flags and 16 = 0)) and (Position.y <> 1) then
begin
if m = 0 then
begin
f2 := Position.x - l;
Break;
end;
m := 0;
i := not i + 1;
f1 := l - Position.x;
l := Position.x;
end
else
if (LRLLevel.Field[l, Position.y].Flags and 8 = 0) or (l > 30) or (l < 1) then
begin
if m = 0 then
begin
f2 := 100;
Break;
end;
m := 0;
i := not i + 1;
l := Position.x;
f1 := 100;
end;
end;
if (f1 = 100) and (f2 = 100) then
NewCommand := 10
else
begin
if f1 > f2 then
NewCommand := 1
else
NewCommand := 2;
end;
end;
end
else
if (Position.y < LRLLevel.Player[1].Position.y) then
begin
if (((LRLLevel.Field[Position.x, Position.y + 1].Image = 2) and
(LRLLevel.Field[Position.x, Position.y + 1].Flags and 16 = 0)) or
(LRLLevel.Field[Position.x, Position.y + 1].Flags and 4 <> 0)) and
(Position.y < 16) and (LRLLevel.Field[Position.x, Position.y + 1].Flags and 1 = 0) then
begin
NewCommand := 4;
end
else
begin
m := 1;
l := Position.x;
i := 1;
while i <> 0 do
begin
l := l + i;
if ((LRLLevel.Field[l, Position.y + 1].Image = 2) and
(LRLLevel.Field[l, Position.y + 1].Flags and 16 = 0)) or
((LRLLevel.Field[l, Position.y + 1].Flags and 4 <> 0) and
(LRLLevel.Field[l, Position.y + 1].Flags and 1 = 0)) then
begin
if m = 0 then
begin
f2 := Position.x - l;
Break;
end;
m := 0;
i := not i + 1;
f1 := l - Position.x;
l := Position.x;
end
else
if (LRLLevel.Field[l, Position.y].Flags and 8 = 0) or (l > 30) or (l < 1) then
begin
if m = 0 then
begin
f2 := 100;
Break;
end;
m := 0;
i := not i + 1;
l := Position.x;
f1 := 100;
end;
end;
if (f1 = 100) and (f2 = 100) then
NewCommand := 10
else
begin
if f1 > f2 then
NewCommand := 1
else
NewCommand := 2;
end;
end;
end
else
begin
if (Position.x > LRLLevel.Player[1].Position.x) then
NewCommand := 1;
if (Position.x < LRLLevel.Player[1].Position.x) then
NewCommand := 2;
end;
end;
end;
end;
end
else
Inc(ComputerTurn);
end;
 
 
function LRLPlayLevel(Number: Byte): Word;
var
Keypress: Word;
i: Word;
L, C: Longword;
begin
Randomize;
ComputerReaction := 1;
LRLLoadLevel(Number);
 
if LRLCLevel <> Number then
begin
GameResult := 50;
Exit;
end;
if LRLLevel.Player[1].Controller <> 1 then
begin
GameResult := 60;
Exit;
end;
 
TimeToRefresh := True;
GameStarted := False;
GameResult := 0;
Paused := False;
EndOfGame := False;
 
LRLStartSequence;
 
Keypress := 0;
L := 0;
 
repeat
C := LastDosTick();
if L <> C then
begin
L := C;
if GameStarted and not Paused then
begin
LRLComputerPlayer;
LRLUpdatePlayers;
LRLUpdateBricks;
end;
LRLRedrawLevel;
ScreenApply(LRLScreen^);
end else
Sleep(20);
 
if Keypressed then
begin
Keypress := ReadKey;
GameStarted := True;
Paused := False;
 
for i := 0 to ControlNumber - 1 do
if KeyboardControls[i * 3 + 1] = Keypress then
begin
LRLLevel.Player[KeyboardControls[i * 3 + 2]].NewCommand := KeyboardControls[i * 3 + 3];
LRLLevel.Player[KeyboardControls[i * 3 + 2]].NewCommandWas := True;
end;
 
if (Keypress = $50) or (Keypress = $70) then
Paused := True;
end;
until (Keypress = $1B) or EndOfGame;
 
if EndOfGame then
LRLEndSequence else
GameResult := 100;
end;
 
end.
/programs/games/lrl/LRLMainMenu.pp
0,0 → 1,116
unit LRLMainMenu;
 
 
interface
 
 
uses
LRLRoutines, LRLSprites;
 
 
procedure LRLSelectItem(var Item: Word);
 
 
implementation
 
 
var
MainScreen: Pointer;
Selection: array[1..4] of Pointer;
SelectionDark: array[1..4] of Pointer;
SelectionSize: array[1..4] of Word;
SelectionDarkSize: array[1..4] of Word;
 
 
procedure LoadData;
var
size, j: Word;
i: Integer;
begin
GetMem(MainScreen, 64004);
Seek(ImageFile, LRLImagesFilePosition + 7940);
BlockRead(ImageFile, MainScreen^, 64004, j);
for i := 1 to 4 do
begin
BlockRead(ImageFile, SelectionSize[i], 2, j);
GetMem(Selection[i], SelectionSize[i]);
BlockRead(ImageFile, Selection[i]^, SelectionSize[i], j);
BlockRead(ImageFile, SelectionDarkSize[i], 2, j);
GetMem(SelectionDark[i], SelectionDarkSize[i]);
BlockRead(ImageFile, SelectionDark[i]^, SelectionDarkSize[i], j);
end;
end;
 
 
procedure DisposeData;
var
i: Integer;
begin
FreeMem(MainScreen, 64004);
for i := 1 to 4 do
begin
FreeMem(Selection[i], SelectionSize[i]);
FreeMem(SelectionDark[i], SelectionDarkSize[i]);
end;
end;
 
 
procedure LRLSelectItem(var Item: Word);
var
Keypress: Word;
RedrawAll: Boolean;
NeedToFade: Boolean;
p: Pointer;
i: Integer;
begin
GetMem(p, 768);
DataFill(p^, 768, 0, 0);
Palette256Set(p^);
FreeMem(p, 768);
LoadData;
NeedToFade := True;
ImagePut(LRLScreen^, MainScreen^, 0, 0, 0, 0, 319, 199);
RedrawAll := True;
KeyboardFlush;
 
repeat
if RedrawAll then
begin
for i := 1 to 4 do
if i = Item then
ImagePutTransparent(LRLScreen^, Selection[i]^, 63, 66 + (i - 1) * 30, 0, 0, 319, 199) else
ImagePutTransparent(LRLScreen^, SelectionDark[i]^, 63, 66 + (i - 1) * 30, 0, 0, 319, 199);
 
ScreenApply(LRLScreen^);
 
if NeedToFade then
begin
FadeTo(LRLMenuPalette);
NeedToFade := False;
end;
 
RedrawAll := False;
end;
 
Keypress := ReadKey;
 
if (Keypress = $B1) and (Item < 4) then
begin
Inc(Item);
RedrawAll := True;
end;
if (Keypress = $B2) and (Item > 1) then
begin
Dec(Item);
RedrawAll := True;
end;
until Keypress = $0D;
 
FadeClear;
ImageClear(LRLScreen^);
ScreenApply(LRLScreen^);
DisposeData;
end;
 
 
end.
/programs/games/lrl/LRLRoutines.pp
0,0 → 1,499
unit LRLRoutines;
 
{$mode objfpc}
{$asmmode intel}
 
 
interface
 
 
procedure ImagePut(var Screen, ImageBuffer; X, Y: Integer; Winx1, Winy1, Winx2, Winy2: Word);
procedure ImagePutTransparent(var Screen, ImageBuffer; X, Y: Integer; Winx1, Winy1, Winx2, Winy2: Word);
procedure ImageFill(var ImageBuffer; SizeX, SizeY: Word; Value: Byte);
function ImageSizeX(var ImageBuffer): Word;
function ImageSizeY(var ImageBuffer): Word;
procedure ImageStringGet(Source: String; var FontData, Buffer; ColorOffs: Byte);
procedure ScreenApply(var Buffer);
procedure ImageClear(var Buffer);
 
procedure Palette256Set(var Palette256);
procedure Palette256Get(var Palette256);
procedure Palette256Grayscale(var Palette256; StartElement, EndElement: Byte);
procedure Palette256Darken(var Palette256; StartElement, EndElement, Decrement, MinValue: Byte);
procedure Palette256Transform(var SourcePalette, DestinationPalette);
function DataByteGet(var Buffer; BufferOffset: Word): Byte;
procedure DataBytePut(var Buffer; BufferOffset: Word; Value: Byte);
function DataWordGet(var Buffer; BufferOffset: Word): Word;
procedure DataWordPut(var Buffer; BufferOffset: Word; Value: Word);
procedure DataMove(var Source, Destination; Count: Word; SourceOffset, DestinationOffset: Word);
procedure DataAdd(var Buffer; Count: Word; Amount: Byte; BufferOffset: Word);
procedure DataFill(var Buffer; Count: Word; Value: Byte; BufferOffset: Word);
function DataIdentical(var Array1, Array2; Count: Word; Array1Offset, Array2Offset: Word): Boolean;
function ReadKey: Word;
function Keypressed: Boolean;
function SetInterrupt(Int: Byte; NewAddress: Pointer): Pointer;
procedure FadeClear;
procedure FadeTo(pal: Pointer);
procedure DecompressRepByte(var InArray, OutArray; InArraySize: Word; var OutArraySize: Word);
function MSMouseInArea(x1, y1, x2, y2: Integer): Boolean;
function MSMouseDriverExist: Boolean;
procedure MSMouseGetXY(var x, y: Integer);
function MSMouseButtonStatusGet: Word;
function MSMouseButtonWasPressed(Button: Word; var x, y: Integer): Boolean;
function MSMouseButtonWasReleased(Button: Word; var x, y: Integer): Boolean;
procedure MSMouseSetXY(x, y: Integer);
procedure KeyboardFlush;
function GetInterrupt(Int: Byte): Pointer;
 
procedure AssignFile(var AFile: File; AFileName: String);
function LastDosTick(): Longword;
 
 
implementation
 
 
uses
SysUtils;
 
 
const
SCREEN_WIDTH = 320;
SCREEN_HEIGHT = 200;
 
type
PRGBColor = ^TRGBColor;
TRGBColor = packed record
R, G, B: Byte;
end;
 
PRGBPalette = ^TRGBPalette;
TRGBPalette = array[Byte] of TRGBColor;
 
var
ScreenRGBPalette: TRGBPalette;
ScreenRGBBuffer : array[0..SCREEN_HEIGHT - 1, 0..SCREEN_WIDTH - 1] of TRGBColor;
ScreenBuffer : array[0..SCREEN_WIDTH * SCREEN_HEIGHT - 1] of Byte;
 
AlreadyKeyPressed: Boolean = False;
 
 
procedure Paint;
begin
kos_begindraw();
kos_definewindow(500, 100, SCREEN_WIDTH - 1, SCREEN_HEIGHT - 1, $01000000);
kos_drawimage24(0, 0, SCREEN_WIDTH, SCREEN_HEIGHT, @ScreenRGBBuffer);
kos_enddraw();
end;
 
procedure UpdateRGBBuffer;
var
I, J: Longint;
B: PByte;
begin
B := @ScreenBuffer;
for I := 0 to SCREEN_HEIGHT - 1 do
for J := 0 to SCREEN_WIDTH - 1 do
begin
ScreenRGBBuffer[I, J] := ScreenRGBPalette[B^];
Inc(B);
end;
Paint;
end;
 
 
procedure ImagePut(var Screen, ImageBuffer; X, Y: Integer; WinX1, WinY1, WinX2, WinY2: Word);
var
Width, Height: Word;
I, J, K: Integer;
P: Pointer;
begin
Width := PWord(@ImageBuffer)[0];
Height := PWord(@ImageBuffer)[1];
 
P := @ImageBuffer + 4;
for I := Y to Y + Height - 1 do
begin
if (I >= 0) and (I < SCREEN_HEIGHT) and (I >= WinY1) and (I <= WinY2) then
begin
if X < WinX1 then
J := WinX1 - X else
J := 0;
K := Width - J;
if WinX1 + K - 1 > WinX2 then
K := WinX2 - WinX1 + 1;
Move((P + J)^, (@Screen + I * SCREEN_WIDTH + X + J)^, K);
end;
Inc(P, Width);
end;
end;
 
procedure ImagePutTransparent(var Screen, ImageBuffer; X, Y: Integer; Winx1, Winy1, Winx2, Winy2: Word);
begin
ImagePut(Screen, ImageBuffer, X, Y, Winx1, Winy1, Winx2, Winy2);
end;
 
procedure ImageFill(var ImageBuffer; SizeX, SizeY: Word; Value: Byte);
begin
PWord(@ImageBuffer)^ := SizeX;
PWord(@ImageBuffer + 2)^ := SizeY;
FillChar((@ImageBuffer + 4)^, SizeX * SizeY, Value);
end;
 
function ImageSizeX(var ImageBuffer): Word;
begin
Result := PWord(@ImageBuffer)^;
end;
 
function ImageSizeY(var ImageBuffer): Word;
begin
Result := PWord(@ImageBuffer + 2)^;
end;
 
procedure ImageStringGet(Source: String; var FontData, Buffer; ColorOffs: Byte);
var
Width, Height: Word;
Table: PWord;
P, B: PByte;
X, I, J, K, C: Word;
begin
Height := PWord(@FontData + 2)^;
Table := PWord(@FontData + 4);
 
{ à áç¥â ¤«¨­ë áâப¨ }
Width := 0;
for I := 1 to Length(Source) do
begin
P := @Table[Ord(Source[I])];
Inc(Width, PWord(P + PWord(P)^)^);
end;
 
PWord(@Buffer)^ := Width;
PWord(@Buffer + 2)^ := Height;
 
{ ¢ë¢®¤ áâப¨ }
X := 0;
for I := 1 to Length(Source) do
begin
P := @Table[Ord(Source[I])];
B := PByte(P + PWord(P)^);
C := PWord(B)^;
Inc(B, 2);
 
P := PByte(@Buffer + 4 + X);
for K := 0 to Height - 1 do
begin
for J := 0 to C - 1 do
begin
if B^ = 0 then
P^ := 0 else
P^ := B^ + ColorOffs;
Inc(P);
Inc(B);
end;
Inc(P, Width - C);
end;
 
Inc(X, C);
end;
end;
 
procedure ScreenApply(var Buffer);
begin
Move(Buffer, ScreenBuffer, SizeOf(ScreenBuffer));
UpdateRGBBuffer;
end;
 
 
procedure ImageClear(var Buffer);
begin
FillChar(Buffer, SCREEN_WIDTH * SCREEN_HEIGHT, 0);
end;
 
 
procedure Palette256Set(var Palette256);
var
I: Longint;
P: PRGBColor;
begin
P := @Palette256;
for I := 0 to 255 do
with ScreenRGBPalette[I] do
begin
R := Round(P^.B / 63 * 255);
G := Round(P^.G / 63 * 255);
B := Round(P^.R / 63 * 255);
Inc(P);
end;
UpdateRGBBuffer;
end;
 
procedure Palette256Get(var Palette256);
var
I: Longint;
P: PRGBColor;
begin
P := @Palette256;
for I := 0 to 255 do
with ScreenRGBPalette[I] do
begin
P^.R := Round(B / 255 * 63);
P^.G := Round(G / 255 * 63);
P^.B := Round(R / 255 * 63);
Inc(P);
end;
end;
 
procedure Palette256Grayscale(var Palette256; StartElement, EndElement: Byte);
begin
end;
 
procedure Palette256Darken(var Palette256; StartElement, EndElement, Decrement, MinValue: Byte);
begin
end;
 
procedure Palette256Transform(var SourcePalette, DestinationPalette);
var
I: Longint;
S, D: PByte;
begin
S := @SourcePalette;
D := @DestinationPalette;
for I := 0 to 767 do
begin
if S^ < D^ then Inc(S^) else
if S^ > D^ then Dec(S^);
Inc(S);
Inc(D);
end;
end;
 
function DataByteGet(var Buffer; BufferOffset: Word): Byte;
begin
Result := PByte(@Buffer + BufferOffset)^;
end;
 
procedure DataBytePut(var Buffer; BufferOffset: Word; Value: Byte);
begin
PByte(@Buffer + BufferOffset)^ := Value;
end;
 
function DataWordGet(var Buffer; BufferOffset: Word): Word;
begin
Result := PWord(@Buffer + BufferOffset)^;
end;
 
procedure DataWordPut(var Buffer; BufferOffset: Word; Value: Word);
begin
PWord(@Buffer + BufferOffset)^ := Value;
end;
 
procedure DataMove(var Source, Destination; Count: Word; SourceOffset, DestinationOffset: Word);
begin
Move((@Source + SourceOffset)^, (@Destination + DestinationOffset)^, Count);
end;
 
procedure DataFill(var Buffer; Count: Word; Value: Byte; BufferOffset: Word);
begin
FillChar((@Buffer + BufferOffset)^, Count, Value);
end;
 
function DataIdentical(var Array1, Array2; Count: Word; Array1Offset, Array2Offset: Word): Boolean;
begin
Result := CompareByte((@Array1 + Array1Offset)^, (@Array2 + Array2Offset)^, Count) = 0;
end;
 
procedure DataAdd(var Buffer; Count: Word; Amount: Byte; BufferOffset: Word);
var
I: Word;
begin
for I := 0 to Count do
Inc(PByte(@Buffer + BufferOffset + I)^, Amount);
{if >0 then += amount}
end;
 
function ReadKey: Word;
var
Event: Word;
begin
if not AlreadyKeyPressed then
begin
kos_maskevents(ME_PAINT or ME_KEYBOARD);
repeat
Event := kos_getevent();
if Event = SE_PAINT then Paint;
until Event = SE_KEYBOARD;
end;
Result := kos_getkey() shr 8;
AlreadyKeyPressed := False;
{WriteLn('ReadKey -> ', IntToHex(Result, 2));}
end;
 
function Keypressed: Boolean;
begin
if AlreadyKeyPressed then
Result := True else
begin
kos_maskevents(ME_KEYBOARD);
Result := kos_getevent(False) = SE_KEYBOARD;
AlreadyKeyPressed := Result;
end;
end;
 
procedure KeyboardFlush;
var
Event: Word;
begin
kos_maskevents(ME_KEYBOARD);
repeat
Event := kos_getevent(False);
if Event = SE_KEYBOARD then kos_getkey();
until Event = 0;
AlreadyKeyPressed := False;
end;
 
function SetInterrupt(Int: Byte; NewAddress: Pointer): Pointer;
begin
Result := nil;
end;
 
procedure FadeClear;
var
Pal1, Pal2: Pointer;
i: Integer;
begin
GetMem(Pal1, 768);
GetMem(Pal2, 768);
Palette256Get(Pal1^);
for i := 0 to 32 do
begin
DataMove(Pal1^, Pal2^, 768, 0, 0);
Palette256Darken(Pal2^, 0, 255, i * 2, 0);
Palette256Set(Pal2^);
end;
FreeMem(Pal1, 768);
FreeMem(Pal2, 768);
end;
 
procedure FadeTo(Pal: Pointer);
var
Pal1: Pointer;
I: Integer;
begin
GetMem(Pal1, 768);
Palette256Get(Pal1^);
for I := 0 to 63 do
begin
Palette256Transform(Pal1^, Pal^);
Palette256Set(Pal1^);
kos_delay(1);
end;
FreeMem(Pal1, 768);
end;
 
procedure DecompressRepByte(var InArray, OutArray; InArraySize: Word; var OutArraySize: Word);
begin
{asm
PUSH DS
 
xor DX,DX
xor AX,AX
 
LDS SI,InArray
LES DI,OutArray
 
MOV CX,InArraySize
JCXZ @Done
 
@Loop1:
LODSB
CMP AL,0
JE @VsePonyatno
CMP AL,4
JB @MensheTreh
 
INC DX
STOSB
JMP @DoLoop
 
@MensheTreh:
SUB CX,1
MOV BX,CX
 
MOV CX,AX
ADD DX,AX
LODSB
REP STOSB
 
MOV CX,BX
JMP @DoLoop
 
@VsePonyatno:
LODSB
SUB CX,2
MOV BX,CX
MOV CX,AX
ADD DX,AX
LODSB
REP STOSB
MOV CX,BX
 
@DoLoop:
JCXZ @Done
LOOP @Loop1
 
@Done:
LES DI,OutArraySize
MOV[ES:DI],DX
POP DS}
end;
 
function MSMouseInArea(x1, y1, x2, y2: Integer): Boolean;
begin
Result := False;
end;
 
function MSMouseDriverExist: Boolean;
begin
Result := True;
end;
 
procedure MSMouseGetXY(var x, y: Integer);
begin
end;
 
function MSMouseButtonStatusGet: Word;
begin
Result := 0;
end;
 
function MSMouseButtonWasPressed(Button: Word; var x, y: Integer): Boolean;
begin
Result := False;
end;
 
function MSMouseButtonWasReleased(Button: Word; var x, y: Integer): Boolean;
begin
Result := False;
end;
 
procedure MSMouseSetXY(x, y: Integer);
begin
end;
 
function GetInterrupt(Int: Byte): Pointer;
begin
Result := nil;
end;
 
procedure AssignFile(var AFile: File; AFileName: String);
begin
Assign(AFile, IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0))) + AFileName);
end;
 
function LastDosTick(): Longword;
begin
Result := Round(kos_timecounter() * 0.182);
end;
 
 
end.
/programs/games/lrl/LRLSprites.pp
0,0 → 1,255
unit LRLSprites;
 
{$mode objfpc}
{$i-}
 
 
interface
 
 
uses
SysUtils,
LRLRoutines;
 
{
all coordinates in standard style:
0 +
0 +----------> x
|
|
|
|
+ v
 
y
}
 
type
TLRLImage = packed record
Data: Pointer; { standard 256-colour image data }
Size: Word; { size of image (for destruction) }
end;
 
PLRLSprite = ^TLRLSprite;
 
TLRLSprite = packed record
Image: array[1..12] of TLRLImage; { moving image }
ImageCount: Byte; { how many images there }
end;
 
 
type
TButton = packed record
Lit: Boolean;
DarkIcon: Pointer;
LightIcon: Pointer;
DarkIconSize: Word;
LightIconSize: Word;
x1, y1: Integer;
x2, y2: Integer;
Command: Word;
end;
 
 
var
ImageFile: File;
LRLEnvironment: array[1..20] of TLRLSprite;
LRLFigure: array[1..4, 1..9] of TLRLSprite;
LRLDecoration: array[1..1] of TLRLSprite;
LRLPalette: Pointer;
LRLScreen: Pointer;
LRLMenuPalette: Pointer;
LRLLogo: Pointer;
LRLFont: Pointer;
LRLFontBuffer: Pointer;
LRLMousePointer: Pointer;
LRLImagesFilePosition: longint;
LRLEditorButton: array[1..6] of TButton;
 
 
procedure ImagesInitialize;
procedure ImagesDeinitialize;
 
 
implementation
 
 
const
ImageFileName = 'LRL.IMG';
ImageFileHeader: ShortString = 'Lode Runner Live Images'#26;
 
ERR_OPENFILE = '¥¢®§¬®¦­® ®âªàëâì ä ©« ª à⨭®ª';
ERR_BADFILE = '¥¢¥à­ë© ¨«¨ ¯®¢à¥¦¤¥­­ë© ä ©« ª à⨭®ª';
 
 
procedure LoadImages;
var
InBuffer: Pointer;
i, j, k, l, x, y: Word;
a, b, c: Byte;
begin
GetMem(InBuffer, $FFF0);
 
AssignFile(ImageFile, ImageFileName);
Reset(ImageFile, 1);
if IOResult <> 0 then
raise Exception.Create(ERR_OPENFILE);
 
BlockRead(ImageFile, InBuffer^, 24, k);
if (IOResult <> 0) or not DataIdentical(InBuffer^, ImageFileHeader[1], 24, 0, 0) then
raise Exception.Create(ERR_BADFILE);
 
{ load palette }
GetMem(LRLPalette, 768);
BlockRead(ImageFile, LRLPalette^, 768, k);
 
{ figures loading loop }
for i := 1 to 9 do
begin
BlockRead(ImageFile, a, 1, k);
LRLFigure[1, i].ImageCount := a;
for j := 1 to a do
begin
GetMem(LRLFigure[1, i].Image[j].Data, 104);
BlockRead(ImageFile, LRLFigure[1, i].Image[j].Data^, 104, k);
x := DataWordGet(LRLFigure[1, i].Image[j].Data^, 0);
y := DataWordGet(LRLFigure[1, i].Image[j].Data^, 2);
LRLFigure[1, i].Image[j].Size := x * y + 4;
for l := 2 to 4 do
begin
LRLFigure[l, i].Image[j].Size := LRLFigure[1, i].Image[j].Size;
LRLFigure[l, i].ImageCount := a;
GetMem(LRLFigure[l, i].Image[j].Data, LRLFigure[l, i].Image[j].Size);
DataMove(LRLFigure[1, i].Image[j].Data^, LRLFigure[l, i].Image[j].Data^, LRLFigure[l, i].Image[j].Size, 0, 0);
DataAdd(LRLFigure[l, i].Image[j].Data^, LRLFigure[l, i].Image[j].Size, (l - 1) shl 5, 4);
end;
end;
end;
 
{ decoration loading loop }
for i := 1 to 1 do
begin
BlockRead(ImageFile, a, 1, k);
LRLDecoration[i].ImageCount := a;
for j := 1 to a do
begin
GetMem(LRLDecoration[i].Image[j].Data, 104);
BlockRead(ImageFile, LRLDecoration[i].Image[j].Data^, 104, k);
x := DataWordGet(LRLDecoration[i].Image[j].Data^, 0);
y := DataWordGet(LRLDecoration[i].Image[j].Data^, 2);
LRLDecoration[i].Image[j].Size := x * y + 4;
end;
end;
 
{ environment loading loop }
for i := 1 to 9 do
begin
BlockRead(ImageFile, a, 1, k);
LRLEnvironment[i].ImageCount := a;
for j := 1 to a do
begin
GetMem(LRLEnvironment[i].Image[j].Data, 104);
BlockRead(ImageFile, LRLEnvironment[i].Image[j].Data^, 104, k);
x := DataWordGet(LRLEnvironment[i].Image[j].Data^, 0);
y := DataWordGet(LRLEnvironment[i].Image[j].Data^, 2);
LRLEnvironment[i].Image[j].Size := x * y + 4;
end;
end;
 
y := 181;
x := 212;
 
for i := 1 to 6 do
begin
if i = 4 then
begin
y := 191;
x := 212;
end;
 
LRLEditorButton[i].x1 := x;
LRLEditorButton[i].y1 := y;
LRLEditorButton[i].x2 := x + 32;
LRLEditorButton[i].y2 := y + 9;
LRLEditorButton[i].Lit := False;
LRLEditorButton[i].Command := i;
LRLEditorButton[i].DarkIconSize := 292;
LRLEditorButton[i].LightIconSize := 292;
 
GetMem(LRLEditorButton[i].DarkIcon, LRLEditorButton[i].DarkIconSize);
GetMem(LRLEditorButton[i].LightIcon, LRLEditorButton[i].LightIconSize);
BlockRead(ImageFile, LRLEditorButton[i].LightIcon^, 292, l);
BlockRead(ImageFile, LRLEditorButton[i].DarkIcon^, 292, l);
 
Inc(x, 33);
end;
 
{ load font }
GetMem(LRLFont, 20455);
BlockRead(ImageFile, LRLFont^, 20455, k);
 
{ load Pointer }
GetMem(LRLMousePointer, 174);
BlockRead(ImageFile, LRLMousePointer^, 174, k);
 
{ load palette }
GetMem(LRLMenuPalette, 768);
BlockRead(ImageFile, LRLMenuPalette^, 768, k);
 
{ load logo }
GetMem(LRLLogo, 12524);
BlockRead(ImageFile, LRLLogo^, 12524, k);
 
LRLImagesFilePosition := FilePos(ImageFile);
FreeMem(InBuffer, $FFF0);
end;
 
 
procedure ImagesInitialize;
begin
LoadImages;
GetMem(LRLScreen, 64000);
GetMem(LRLFontBuffer, 32000);
end;
 
 
procedure ImagesDeinitialize;
var
i, j, l: Integer;
begin
FreeMem(LRLPalette, 768);
 
for i := 1 to 9 do
for j := 1 to LRLFigure[1, i].ImageCount do
begin
FreeMem(LRLFigure[1, i].Image[j].Data, 104);
for l := 2 to 4 do
FreeMem(LRLFigure[l, i].Image[j].Data, LRLFigure[l, i].Image[j].Size);
end;
 
for i := 1 to 1 do
for j := 1 to LRLDecoration[i].ImageCount do
FreeMem(LRLDecoration[i].Image[j].Data, 104);
 
for i := 1 to 9 do
for j := 1 to LRLEnvironment[i].ImageCount do
FreeMem(LRLEnvironment[i].Image[j].Data, 104);
 
for i := 1 to 6 do
begin
FreeMem(LRLEditorButton[i].DarkIcon, LRLEditorButton[i].DarkIconSize);
FreeMem(LRLEditorButton[i].LightIcon, LRLEditorButton[i].LightIconSize);
end;
 
FreeMem(LRLFont, 20455);
FreeMem(LRLMousePointer, 174);
FreeMem(LRLMenuPalette, 768);
FreeMem(LRLLogo, 12524);
FreeMem(LRLScreen, 64000);
FreeMem(LRLFontBuffer, 32000);
 
Close(ImageFile);
end;
 
 
end.
/programs/games/lrl/bin/lrl.img
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/programs/games/lrl/bin/lrl.lev
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/programs/games/lrl/build.bat
0,0 → 1,30
@echo off
 
rem „«ï ᡮન ¨£àë ­¥®¡å®¤¨¬® ¢ ¯¥à¥¬¥­­®© UNITS (®¯à¥¤¥«¥­  ­¨¦¥)
rem 㪠§ âì à á¯®«®¦¥­¨¥ ¯ ¯ª¨, ¢ ª®â®à®© ­ å®¤ïâáï ®âª®¬¯¨«¨à®¢ ­­ë¥ ¬®¤ã«¨
rem RTL ¤«ï KolibriOS.  ¯à¨¬¥à, ¥á«¨ ¨á室­¨ª¨ RTL ­ å®¤ïâáï ¢ ¯ ¯ª¥ my/rtl,
rem ⮠ᮡ࠭­ë¥ ¬®¤ã«¨ RTL - ᪮॥ ¢á¥£® ¢ my/units. Œ®¦¥â ®ª § âìáï
rem ¤®áâ â®ç­ë¬ ¯à®áâ® ¯¥à¥­¥á⨠íâã ¯ ¯ªã (lrl) ¢ ¤¨à¥ªâ®à¨î my.
 
rem ’ ª ¦¥, ¤«ï ᡮન, ¢ ¬ ¯®­ ¤®¡¨âáï ã⨫¨â  exe2kos.exe ¨ FreePascal 2.2.0.
 
 
set NAME=lrl
set NAMEEXE=%NAME%.exe
set NAMEKEX=%NAME%.kex
 
set BUILD=-FUbuild
set UNITS=-Fu../units
 
fpc %NAME%.pp -n -Twin32 -Se5 -XXs -Sg -O3pPENTIUM3 -CfSSE -WB0 %BUILD% %UNITS%
if errorlevel 1 goto error
 
exe2kos.exe %NAMEEXE% %NAMEKEX%
del %NAMEEXE%
move %NAMEKEX% bin
goto end
 
:error
echo An error occured while building %NAME%
 
:end
/programs/games/lrl/readme-ru.txt
0,0 → 1,10
 
Lode Runner Live 1.0
====================
 
à®¥ªâ ¯® ¯¥à¥­®áã ¨£àë Lode Runner Live 1.0 á ¯« âä®à¬ë DOS ¢ KolibriOS.
 
—¨â ©â¥ ª®¬¬¥­â à¨¨ ¯® ª®¬¯¨«ï樨 ¢ build.bat.
 
  ¤ ­­ë© ¬®¬¥­â â¥áâ¨à®¢ « áì ªà®áª®¬¯¨«ïæ¨ï ⮫쪮 ¨§ Windows 2000 SP4
­  32å à §à來®© ¬ è¨­¥.