Subversion Repositories Kolibri OS

Compare Revisions

Regard whitespace Rev 761 → Rev 762

/programs/games/lrl/src/LRL.pp
0,0 → 1,86
program LodeRunnerLive;
 
{$apptype gui}
 
 
uses
LRLRoutines,
LRLSprites,
LRLLevels,
LRLMainMenu,
LRLHighScores,
{LRLEditor,}
LRLIntroduction;
 
const
Version: PChar = 'Lode Runner LIVE. Version 1.4b';
 
 
procedure LRLInitialize;
begin
ImagesInitialize;
KeyboardInitialize;
ScreenMode(1);
ScreenTitle := Version;
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);
 
if (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/src/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/src/LRLHighScores.pp
0,0 → 1,264
unit LRLHighScores;
 
{$mode objfpc}
{$i-}
 
 
interface
 
 
uses
SysUtils,
LRLRoutines, LRLSprites;
 
 
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);
Seek(ImageFile, LRLImagesFilePosition);
BlockRead(ImageFile, MainScreen^, 7940, j);
DecompressRepByte(MainScreen^, HighFrame^, 7940, j);
BlockRead(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: File;
i, j: Word;
Dummy: String[30];
begin
FileMode := 0;
AssignFile(InFile, HighsFileName);
Reset(InFile, 1);
 
if IOResult <> 0 then
begin
for i := 1 to 5 do
begin
HighTable[i].Name := 'Lode Runner';
HighTable[i].score := 60000 - i * 10000;
end;
AssignFile(InFile, HighsFileName);
Rewrite(InFile, 1);
BlockWrite(InFile, HighsFileHeader[1], 29, i);
BlockWrite(InFile, HighTable, SizeOf(TSupers) * 5, j);
end else
begin
Seek(InFile, 0);
BlockRead(InFile, Dummy[1], 29, j);
if (IOResult <> 0) or (not DataIdentical(Dummy[1], HighsFileHeader[1], 29, 0, 0)) then
raise Exception.Create('Error: Invalid file with high scores! (try to remove LRL.HSR file)');
BlockRead(InFile, HighTable, SizeOf(TSupers) * 5, j);
end;
 
Close(InFile);
end;
 
 
procedure LRLSaveHighScores;
var
InFile: File;
j: Word;
begin
FileMode := 2;
AssignFile(InFile, HighsFileName);
Reset(InFile, 1);
Seek(InFile, 29);
BlockWrite(InFile, HighTable, SizeOf(TSupers) * 5, j);
Close(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;
RedrawName: Boolean;
Keypress: Word;
Name: String;
C: Char;
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 (Keypress = KEY_BACK) and (Length(Name) > 0) then
begin
SetLength(Name, Length(Name) - 1);
RedrawName := True;
end;
 
C := ScanToChar(Keypress);
if (C > #31) and (Length(Name) < 20) then
begin
Name := Name + C;
RedrawName := True;
end;
 
until Keypress = KEY_ENTER;
FadeClear;
 
Name := Trim(Name);
if Length(Name) = 0 then
Name := 'Anonymous';
LRLEnterName := Name;
end;
 
 
end.
/programs/games/lrl/src/LRLIntroduction.pp
0,0 → 1,129
unit LRLIntroduction;
 
 
interface
 
 
uses
SysUtils,
LRLRoutines, LRLSprites;
 
 
procedure LRLIntro;
 
 
implementation
 
 
const
IntroText: array[1..14] of String = (
'Lode Runner LIVE. FREEWARE Version 1.4b',
'KolibriOS port by bw (Vladimir V. Byrgazov)',
'Copyright (c) 1995 Aleksey V. Vaneev',
'Copyright (c) 2008 bw',
'',
'Send comments to Aleksey V. Vaneev',
'2:5003/15@FidoNet',
'ikomi@glas.apc.org',
'',
'Send comments to bw',
'bw@handsdriver.net',
'',
'',
'');
 
SPACE40 = ' ';
 
 
var
TimeToRefresh: Boolean;
 
 
procedure LRLIntro;
var
i, j, l: Integer;
Count: Word;
k: Word;
MainScreen: Pointer;
begin
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/src/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 = (
KEY_LEFT, 1, 1,
KEY_RIGHT, 1, 2,
KEY_UP, 1, 3,
KEY_DOWN, 1, 4,
KEY_GREY5, 1, 5,
KEY_END, 1, 6,
KEY_PGDN, 1, 7);
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);
procedure LRLPlayLevel(Number: Byte);
function LRLLevelCount: Word;
procedure LRLDeleteLevel(Count: Word);
procedure LRLInsertLevel(After: Word);
procedure LRLSaveLevel(Count: Word);
 
 
implementation
 
 
const
LevelFileName = 'LRL.LEV';
LevelFileHeader: ShortString = '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;
FileMode := 2;
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;
j: Integer;
l: Longint;
k: Word;
begin
GetMem(Buffer, 1000);
j := LRLLevelCount;
if (j < Count) or (j < 2) or (Count = 0) then
Exit;
FileMode := 2;
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;
j: Integer;
l: Longint;
k: Word;
begin
GetMem(Buffer, 1000);
j := LRLLevelCount;
if (After > j) or (After = 0) then
Exit;
FileMode := 2;
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: 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;
 
 
{ GameResult:
1 - § ¬ã஢ «¨
2 - ¯®©¬ «¨
10 - ¢á¥ ᤥ« ­®
50 - ­¥â ¡®«ìè¥ ã஢­¥©
60 - ­¥â 祫®¢¥ç¥áª¨å ⮢
100 - ­ ¦ â  Esc }
 
procedure LRLUpdatePlayers;
var
i, 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) and
(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: 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;
 
 
procedure LRLPlayLevel(Number: Byte);
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 = KEY_P then
Paused := True;
end;
until (Keypress = KEY_ESC) or EndOfGame;
 
if EndOfGame then
LRLEndSequence else
GameResult := 100;
end;
 
 
end.
/programs/games/lrl/src/LRLMainMenu.pp
0,0 → 1,117
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
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 = KEY_DOWN) and (Item < 4) then
begin
Inc(Item);
RedrawAll := True;
end else
if (Keypress = KEY_UP) and (Item > 1) then
begin
Dec(Item);
RedrawAll := True;
end;
until Keypress = KEY_ENTER;
 
FadeClear;
ImageClear(LRLScreen^);
ScreenApply(LRLScreen^);
DisposeData;
end;
 
 
end.
/programs/games/lrl/src/LRLRoutines.pp
0,0 → 1,865
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 ScreenMode(Mode: Integer);
 
procedure KeyboardInitialize;
function Keypressed: Boolean;
function ReadKey: Word;
procedure KeyboardFlush;
function ScanToChar(Code: Word): Char;
 
procedure Palette256Set(var Palette256);
procedure Palette256Get(var Palette256);
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 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);
function GetInterrupt(Int: Byte): Pointer;
 
procedure AssignFile(var AFile: File; AFileName: String);
function LastDosTick(): Longword;
 
 
const
KEY_GREY = $E000;
KEY_UP_BASE = $8000;
KEY_ESC = $0100;
KEY_1 = $0200;
KEY_2 = $0300;
KEY_3 = $0400;
KEY_4 = $0500;
KEY_5 = $0600;
KEY_6 = $0700;
KEY_7 = $0800;
KEY_8 = $0900;
KEY_9 = $0A00;
KEY_0 = $0B00;
KEY_SUBTRACT = $0C00;
KEY_ADD = $0D00;
KEY_BACK = $0E00;
 
KEY_Q = $1000;
KEY_W = $1100;
KEY_E = $1200;
KEY_R = $1300;
KEY_T = $1400;
KEY_Y = $1500;
KEY_U = $1600;
KEY_I = $1700;
KEY_O = $1800;
KEY_P = $1900;
KEY_LBRACKET = $1A00;
KEY_RBRACKET = $1B00;
KEY_ENTER = $1C00;
 
KEY_A = $1E00;
KEY_S = $1F00;
KEY_D = $2000;
KEY_F = $2100;
KEY_G = $2200;
KEY_H = $2300;
KEY_J = $2400;
KEY_K = $2500;
KEY_L = $2600;
KEY_SEMICOLON = $2700;
KEY_QUOTE = $2800;
 
KEY_LSHIFT = $2A00;
KEY_Z = $2C00;
KEY_X = $2D00;
KEY_C = $2E00;
KEY_V = $2F00;
KEY_B = $3000;
KEY_N = $3100;
KEY_M = $3200;
KEY_COMMA = $3300;
KEY_DECIMAL = $3400;
KEY_DIVIDE = $3500;
KEY_RSHIFT = $3600;
 
KEY_ALT = $3800;
KEY_CAPITAL = $3600;
KEY_F1 = $3B00;
KEY_UP = $4800;
KEY_LEFT = $4B00;
KEY_GREY5 = $4C00;
KEY_RIGHT = $4D00;
KEY_END = $4F00;
KEY_DOWN = $5000;
KEY_PGDN = $5100;
 
type
ScanToCharRecord = record
Scan: Word;
CL: Char;
CU: Char;
Caps: Boolean;
end;
 
var
ScreenTitle: PChar = nil;
ScanToCharTable: array[1..45] of ScanToCharRecord = (
(Scan: KEY_0; CL: '0'; CU: ')'; Caps: False), (Scan: KEY_1; CL: '1'; CU: '!'; Caps: False),
(Scan: KEY_2; CL: '2'; CU: '@'; Caps: False), (Scan: KEY_3; CL: '3'; CU: '#'; Caps: False),
(Scan: KEY_4; CL: '4'; CU: '$'; Caps: False), (Scan: KEY_5; CL: '5'; CU: '%'; Caps: False),
(Scan: KEY_6; CL: '6'; CU: '^'; Caps: False), (Scan: KEY_7; CL: '7'; CU: '&'; Caps: False),
(Scan: KEY_8; CL: '8'; CU: '*'; Caps: False), (Scan: KEY_9; CL: '9'; CU: '('; Caps: False),
(Scan: KEY_SUBTRACT; CL: '-'; CU: '_'; Caps: False), (Scan: KEY_ADD; CL: '='; CU: '+'; Caps: False),
 
(Scan: KEY_Q; CL: 'q'; CU: 'Q'; Caps: True), (Scan: KEY_W; CL: 'w'; CU: 'W'; Caps: True),
(Scan: KEY_E; CL: 'e'; CU: 'E'; Caps: True), (Scan: KEY_R; CL: 'r'; CU: 'R'; Caps: True),
(Scan: KEY_T; CL: 't'; CU: 'T'; Caps: True), (Scan: KEY_Y; CL: 'y'; CU: 'Y'; Caps: True),
(Scan: KEY_U; CL: 'u'; CU: 'U'; Caps: True), (Scan: KEY_I; CL: 'i'; CU: 'I'; Caps: True),
(Scan: KEY_O; CL: 'o'; CU: 'O'; Caps: True), (Scan: KEY_P; CL: 'p'; CU: 'P'; Caps: True),
(Scan: KEY_LBRACKET; CL: '['; CU: '{'; Caps: False), (Scan: KEY_RBRACKET; CL: ']'; CU: '}'; Caps: False),
 
(Scan: KEY_A; CL: 'a'; CU: 'A'; Caps: True), (Scan: KEY_S; CL: 's'; CU: 'S'; Caps: True),
(Scan: KEY_D; CL: 'd'; CU: 'D'; Caps: True), (Scan: KEY_F; CL: 'f'; CU: 'F'; Caps: True),
(Scan: KEY_G; CL: 'g'; CU: 'G'; Caps: True), (Scan: KEY_H; CL: 'h'; CU: 'H'; Caps: True),
(Scan: KEY_J; CL: 'j'; CU: 'J'; Caps: True), (Scan: KEY_K; CL: 'k'; CU: 'K'; Caps: True),
(Scan: KEY_L; CL: 'l'; CU: 'L'; Caps: True),
(Scan: KEY_SEMICOLON; CL: ';'; CU: ':'; Caps: False), (Scan: KEY_QUOTE; CL: ''''; CU: '"'; Caps: False),
 
(Scan: KEY_Z; CL: 'z'; CU: 'Z'; Caps: True), (Scan: KEY_X; CL: 'x'; CU: 'X'; Caps: True),
(Scan: KEY_C; CL: 'c'; CU: 'C'; Caps: True), (Scan: KEY_V; CL: 'v'; CU: 'V'; Caps: True),
(Scan: KEY_B; CL: 'b'; CU: 'B'; Caps: True), (Scan: KEY_N; CL: 'n'; CU: 'N'; Caps: True),
(Scan: KEY_M; CL: 'm'; CU: 'M'; Caps: True),
(Scan: KEY_COMMA; CL: ','; CU: '<'; Caps: False), (Scan: KEY_DECIMAL; CL: '.'; CU: '>'; Caps: False),
(Scan: KEY_DIVIDE; CL: '/'; CU: '?'; Caps: False)
);
 
 
implementation
 
 
uses
SysUtils;
 
 
const
BUFFER_WIDTH = 320;
BUFFER_HEIGHT = 200;
 
type
PRGBColor = ^TRGBColor;
TRGBColor = packed record
R, G, B: Byte;
end;
 
PRGBPalette = ^TRGBPalette;
TRGBPalette = array[Byte] of TRGBColor;
 
 
var
ScreenRGBPalette: TRGBPalette;
ScreenRGBBuffer : PRGBColor = nil;
ScreenRGBTemporary: PRGBColor = nil;
ScreenPalBuffer : array[0..BUFFER_HEIGHT - 1, 0..BUFFER_WIDTH - 1] of Byte;
 
WindowWidth : Longint;
WindowHeight: Longint;
ScreenWidth : Longword;
ScreenHeight: Longword;
CurrentScreenMode: Integer = 0;
 
LastKeyEvent: Word = $FFFF;
LastKeyUp : Boolean = True;
LastKeyDown: Boolean = False;
AltDown : Boolean = False;
ShiftDown : Boolean = False;
LShiftDown : Boolean = False;
RShiftDown : Boolean = False;
CapsPressed: Boolean = False;
 
 
 
procedure Paint;
begin
kos_begindraw();
kos_definewindow(10, 10, 100, 100, $64000000);
if CurrentScreenMode <> 0 then
begin
kos_setcaption(ScreenTitle);
if Assigned(ScreenRGBBuffer) then
kos_drawimage24(0, 0, ScreenWidth, ScreenHeight, ScreenRGBBuffer) else
kos_drawrect(0, 0, ScreenWidth, ScreenHeight, $FF00FF);
end;
kos_enddraw();
end;
 
 
procedure UpdateRGBBuffer;
var
XStep, YStep: Longword;
 
procedure Horizontal;
var
X, Y, I: Longword;
B: PByte;
C: PRGBColor;
begin
C := ScreenRGBTemporary;
for Y := 0 to BUFFER_HEIGHT - 1 do
begin
I := 0;
B := @ScreenPalBuffer[Y, 0];
for X := 0 to ScreenWidth - 1 do
begin
C^ := ScreenRGBPalette[PByte(B + (I shr 16))^];
Inc(I, XStep);
Inc(C);
end;
end;
end;
 
procedure Vertical;
var
Y, I: Longword;
S: PRGBColor;
C: PRGBColor;
begin
I := 0;
S := ScreenRGBTemporary;
C := ScreenRGBBuffer;
for Y := 0 to ScreenHeight - 1 do
begin
Move(PRGBColor(S + (I shr 16) * ScreenWidth)^, C^, ScreenWidth * SizeOf(C^));
Inc(I, YStep);
Inc(C, ScreenWidth);
end;
end;
 
var
I, J: Longint;
B: PByte;
C: PRGBColor;
 
begin
if (ScreenWidth = BUFFER_WIDTH) and (ScreenHeight = BUFFER_HEIGHT) then
begin
{¯¥à¥­®á ®¤¨­ ¢ ®¤¨­}
B := @ScreenPalBuffer;
C := ScreenRGBBuffer;
for I := 0 to BUFFER_HEIGHT - 1 do
for J := 0 to BUFFER_WIDTH - 1 do
begin
C^ := ScreenRGBPalette[B^];
Inc(B);
Inc(C);
end;
end else
begin
{¬ áèâ ¡¨à®¢ ­¨¥}
XStep := (BUFFER_WIDTH shl 16) div ScreenWidth;
YStep := (BUFFER_HEIGHT shl 16) div ScreenHeight;
Horizontal;
Vertical;
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 < BUFFER_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 * BUFFER_WIDTH + X + J)^, K);
end;
Inc(P, Width);
end;
end;
 
 
procedure ImagePutTransparent(var Screen, ImageBuffer; X, Y: Integer; Winx1, Winy1, Winx2, Winy2: Word);
var
Width, Height: Word;
I, J, K, L: Integer;
PI, PO: PByte;
begin
Width := PWord(@ImageBuffer)[0];
Height := PWord(@ImageBuffer)[1];
PI := @ImageBuffer + 4;
 
for I := Y to Y + Height - 1 do
begin
if (I >= 0) and (I < BUFFER_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;
 
Inc(PI, J);
PO := @Screen + I * BUFFER_WIDTH + X + J;
for L := 1 to K do
begin
if PI^ > 0 then
PO^ := PI^;
Inc(PI);
Inc(PO);
end;
Dec(PI, J + K);
end;
Inc(PI, Width);
end;
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, ScreenPalBuffer, SizeOf(ScreenPalBuffer));
UpdateRGBBuffer;
end;
 
procedure ImageClear(var Buffer);
begin
FillChar(Buffer, BUFFER_WIDTH * BUFFER_HEIGHT, 0);
end;
 
procedure ScreenMode(Mode: Integer);
var
ThreadInfo: TKosThreadInfo;
begin
if Mode <> CurrentScreenMode then
begin
if Assigned(ScreenRGBBuffer) then FreeMem(ScreenRGBBuffer);
if Assigned(ScreenRGBTemporary) then FreeMem(ScreenRGBTemporary);
 
case Mode of
-2: begin
ScreenWidth := BUFFER_WIDTH div 2;
ScreenHeight := BUFFER_HEIGHT div 2;
end;
1..3: begin
ScreenWidth := BUFFER_WIDTH * Mode;
ScreenHeight := BUFFER_HEIGHT * Mode;
end;
end;
 
if CurrentScreenMode = 0 then Paint;
 
kos_threadinfo(@ThreadInfo);
 
with ThreadInfo, WindowRect do
begin
WindowWidth := Width - ClientRect.Width + Longint(ScreenWidth);
WindowHeight := Height - ClientRect.Height + Longint(ScreenHeight);
kos_movewindow(Left, Top, WindowWidth, WindowHeight);
end;
 
CurrentScreenMode := Mode;
 
ScreenRGBBuffer := GetMem(ScreenWidth * ScreenHeight * SizeOf(ScreenRGBBuffer^));
ScreenRGBTemporary := GetMem(ScreenWidth * BUFFER_HEIGHT * SizeOf(ScreenRGBTemporary^));
 
UpdateRGBBuffer;
end;
end;
 
 
 
procedure KeyboardInitialize;
begin
kos_setkeyboardmode(1);
end;
 
function ReadKeyLoop: Word;
var
Event: Word;
begin
kos_maskevents(ME_PAINT or ME_KEYBOARD);
repeat
Event := kos_getevent();
if Event = SE_PAINT then Paint;
until Event = SE_KEYBOARD;
Result := kos_getkey();
end;
 
function TranslateKey(Key: Word): Word;
begin
if Key = KEY_GREY then
Result := kos_getkey() else
Result := Key;
 
LastKeyDown := Result < KEY_UP_BASE;
LastKeyUp := not LastKeyDown;
if LastKeyUp then Dec(Result, KEY_UP_BASE);
 
if Result = KEY_ALT then
begin
AltDown := LastKeyDown;
Result := $FFFF;
end else
 
if Result = KEY_LSHIFT then
begin
LShiftDown := LastKeyDown;
ShiftDown := LShiftDown or RShiftDown;
Result := $FFFF;
end else
 
if Result = KEY_RSHIFT then
begin
RShiftDown := LastKeyDown;
ShiftDown := LShiftDown or RShiftDown;
Result := $FFFF;
end else
 
if AltDown then
case Result of
KEY_1: begin Result := $FFFF; if LastKeyDown then ScreenMode(1); end;
KEY_2: begin Result := $FFFF; if LastKeyDown then ScreenMode(2); end;
KEY_3: begin Result := $FFFF; if LastKeyDown then ScreenMode(3); end;
KEY_9: begin Result := $FFFF; if LastKeyDown then ScreenMode(-2); end;
KEY_0: begin Result := $FFFF; if LastKeyDown then ScreenMode(100); end;
end;
end;
 
function Keypressed: Boolean;
begin
if (LastKeyEvent < KEY_UP_BASE) and LastKeyDown then
Result := True else
begin
kos_maskevents(ME_KEYBOARD);
if kos_getevent(False) = SE_KEYBOARD then
begin
LastKeyEvent := TranslateKey(kos_getkey());
if LastKeyEvent < KEY_UP_BASE then
Result := LastKeyDown else
Result := False;
end else
begin
LastKeyEvent := $FFFF;
Result := False;
end;
end;
end;
 
function ReadKey: Word;
begin
repeat
if LastKeyEvent < KEY_UP_BASE then
Result := LastKeyEvent else
Result := TranslateKey(ReadKeyLoop);
LastKeyEvent := $FFFF;
until (Result < KEY_UP_BASE) and LastKeyDown;
end;
 
procedure KeyboardFlush;
begin
end;
 
function ScanToChar(Code: Word): Char;
var
I: Word;
begin
for I := Low(ScanToCharTable) to High(ScanToCharTable) do
with ScanToCharTable[I] do
if Scan = Code then
begin
if not CapsPressed then
if not ShiftDown then
Result := CL else
Result := CU
else
if not ShiftDown then
if not Caps then
Result := CL else
Result := CU
else
if not Caps then
Result := CL else
Result := CL;
Exit;
end;
Result := #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 Palette256Darken(var Palette256; StartElement, EndElement, Decrement, MinValue: Byte);
var
I, J: Byte;
PB : PByte;
begin
PB := @Palette256;
Inc(PB, StartElement * 3);
for I := StartElement to EndElement do
for J := 1 to 3 do
begin
if PB^ > MinValue then
if PB^ < Decrement then
PB^ := MinValue else
Dec(PB^, Decrement);
Inc(PB);
end;
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;
PB: PByte;
begin
PB := @Buffer + BufferOffset;
for I := 1 to Count do
begin
if PB^ > 0 then
Inc(PB^, Amount);
Inc(PB);
end;
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 32 do
begin
Palette256Transform(Pal1^, Pal^);
Palette256Transform(Pal1^, Pal^);
Palette256Set(Pal1^);
kos_delay(1);
end;
FreeMem(Pal1, 768);
end;
 
 
procedure DecompressRepByte(var InArray, OutArray; InArraySize: Word; var OutArraySize: Word);
var
I, J: Word;
PIn : PByte;
POut: PByte;
begin
I := 0;
PIn := @InArray;
POut := @OutArray;
 
while I < InArraySize do
begin
Inc(I);
 
if PIn^ = 0 then
begin
Inc(PIn);
J := PIn^;
Inc(I, 2);
Inc(PIn);
Inc(OutArraySize, J);
while J > 0 do
begin
POut^ := PIn^;
Inc(POut);
Dec(J);
end;
Inc(PIn);
end else
 
if PIn^ < 4 then
begin
J := PIn^;
Inc(I);
Inc(PIn);
Inc(OutArraySize, J);
while J > 0 do
begin
POut^ := PIn^;
Inc(POut);
Dec(J);
end;
Inc(PIn);
end else
 
begin
POut^ := PIn^;
Inc(PIn);
Inc(POut);
Inc(OutArraySize);
end;
end;
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/src/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: 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.