Sweetbread/kolibrios
1
0
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests Activity

LRL 1.4b

Browse Source 
git-svn-id: svn://kolibrios.org@762 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
bw 2008-02-29 17:36:25 +00:00
parent 119066a890
commit a5131135c4
16 changed files with 1335 additions and 688 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

499
programs/games/lrl/LRLRoutines.pp
View File

@ -1,499 +0,0 @@
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.

49
programs/games/lrl/Makefile.fpc Normal file
View File

@ -0,0 +1,49 @@
# <20>¥à¥¬¥­­ ï ®ªà㦥­¨ï FPCDIR ¤®«¦­  㪠§ë¢ âì ­  ¯ ¯ªã á FreePascal,
# «¨¡® ¢ ᥪ樨 default ¢ ¯¥à¥¬¥­­®© fpcdir 㪠¦¨â¥ â®ç­ë© ¯ãâì ª ­¥©.
# <20>ãâì 㪠§ë¢ ¥âáï ¡¥§ § ¢¥àè î饣® á«íè  (¨«¨ ®¡à â­®£® á«íè ).
# <20>¥à¥¬¥­­ ï ®ªà㦥­¨ï KFPCDIR ¤®«¦­  㪠§ë¢ âì ­  ¯ ¯ªã á ¯à®¥ªâ®¬
# KolibriOS FreePascal.
# <20>ãâì 㪠§ë¢ ¥âáï ¡¥§ § ¢¥àè î饣® á«íè  (¨«¨ ®¡à â­®£® á«íè ).
[target]
programs=LRL
[default]
target=win32
cpu=i386
[compiler]
options=-dKOLIBRI
unittargetdir=build
targetdir=bin
sourcedir=src
[prerules]
ifdef KFPCDIR
override KFPCDIR:=$(subst \,/,$(KFPCDIR))
ifeq ($(wildcard $(KFPCDIR)/bin),)
override KFPCDIR=wrong
endif
else
override KFPCDIR=wrong
endif
ifeq ($(KFPCDIR),wrong)
$(error The KFPCDIR environment is wrong)
endif
UNITSDIR:=$(wildcard $(FPCDIR)/units/$(CPU_TARGET)-kolibri)
KOSEXT=.kex
EXE2KEX=$(KFPCDIR)/bin/exe2kos
[rules]
ifneq ($(TARGET_PROGRAMS),)
KOSFILES=$(addsuffix $(KOSEXT),$(TARGET_PROGRAMS))
endif
fpc_all: $(KOSFILES)
%$(KOSEXT): %$(EXEEXT)
@$(EXE2KEX) $(COMPILER_TARGETDIR)/$^ $(COMPILER_TARGETDIR)/$@
@$(DEL) $(COMPILER_TARGETDIR)/$^

BIN
programs/games/lrl/bin/LRL.HSR Normal file
View File

Binary file not shown.

222
programs/games/lrl/bin/LRL.MAN Normal file
View File

@ -0,0 +1,222 @@
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ
ÜÜ ÜÜÜÜ ÜÜÜÜÜ ÜÜÜÜÜÜ ÜÜÜÜÜ ÜÜ ÜÜ ÜÜ ÜÜ ÜÜ ÜÜ ÜÜÜÜÜÜ ÜÜÜÜÜ
ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ
ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛÛÜÛÛ ÛÛÛÜÛÛ ÛÛ ÛÛ ÛÛ
ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛßßß ÛÛßßÛÜ ÛÛ ÛÛ ÛÛ ßÛÛ ÛÛ ßÛÛ ÛÛßßß ÛÛßßÛÜ
ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ
ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ
ßßßßßß ßßßß ßßßßß ßßßßßß ßß ßß ßßßß ßß ßß ßß ßß ßßßßßß ßß ßß
ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
ÄÄÄÄÄÍÍÍÍ Û Û Û Û Ûßß ÍÍÍÍÄÄÄÄÄ
ÄÄÄÄÄÄÍÍÍÍÍ Û Û Û Û Ûß ÍÍÍÍÍÄÄÄÄÄÄ
FREEWARE ÄÄÄÄÄÄÄÍÍÍÍÍÍ ÛÜÜ Û ßÜß ÛÜÜ ÍÍÍÍÍÍÄÄÄÄÄÄÄ version 1.0
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ
USER'S MANUAL
ÚÂÂÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
³³³³ DISCLAIMER AND LICENSING
Lode Runner Live version 1.0 is provided on "AS IS" basis without
warranty of any kind, either expressed or implied, including, but not
limited to, fitness for a particular purpose. In no event will
the authors or copyright holder be liable for any damages caused by the
use or inablility to use, of Lode Runner Live version 1.0.
Lode Runner Live version 1.0 is a FREEWARE program. It is illegal
to copy, distribute this program for any commercial profit except fee
for shipping and handling (no more than $2 USD). It is illegal to
inverse assemble this program in whole or partially.
Lode Runner Live version 1.0 can be included in PD-Disks, CD-ROMs,
shareware disks only with permission from the author. See last part for
details.
All trademarks, registered trademarks mentioned in this text belongs to
their respective owners and included only for informative purposes.
ÚÂÂÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
³³³³ GETTING STARTED
GAME REQUIREMENTS:
Intel 80386 or higher processor,
VGA,
MS-DOS 4.0 or higher,
About 340k of conventional memory.
OPTION:
100%-compatible Microsoft mouse and driver installed.
To start the game, simply go to directory where you copy this game,
type LRL at DOS prompt (e.g. C:\GAMES\LRL>) and press ENTER.
If your current system configuration enough for this game,
game immediately starts.
On game start you see an intro. Press any key to enter to main menu.
ÚÂÂÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
³³³³ MAIN MENU
After you bypass intro section you can see four menu options.
Current selected option lit.
START GAME
EDIT LEVELS
HIGH SCORES
EXIT TO DOS
Use arrow keys to select desired option and ENTER key to accept
selection.
ÚÂÂÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
³³³³ START GAME
When you accept START GAME option from main menu, the game starts.
Green Runner is Your Runner. Your goal is to gather all the prizes
(gold-coloured boxes) and after that reach top of level to finish it.
Bottom part of screen shows your current status:
"Score:" keyword shows your game points. For each prize you receive
100 points multiplied by current level number. After you finish
level you receive 10000 points multiplied by finished level number.
If game is over and your point status is great enough you will be
prompted to enter your name (or handle) and after you type and press
ENTER, high scores will be shown with your entry.
"Lives:" keyword shows actual number of lives. If "Lives:" shows "1"
and you died then the game is over. After you finish level you
receive one life.
"Level:" keyword shows number of level you currently playing.
During gameplay you can use following keys:
"<" and ">" to fire left and right.
Arrow keys to move Runner.
"P" key to pause game.
ESC key to cancel game and return to main menu.
ÚÂÂÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
³³³³ EDIT LEVELS
If you immediately returned to main menu then you don't have a
Microsoft-compatible mouse and driver installed.
If you have Microsoft-compatible mouse and driver installed then read
along.
All manipulations are done with mouse. Mouse cursor appears on screen
as a white arrow.
After you selected EDIT LEVELS from main menu and pressed ENTER, edit
screen will appear. It consists of three parts. First part is a
level-screen. It looks like an ordinary game. Second functional part
located in left-bottom part of screen. There you can see therteen
images. Third part is a button-pad and is located in right-bottom part
of screen.
You can use second part to select bricks or Runners to be put on
level-screen. Just move mouse cursor to desired image an press left
mouse button. To put selected image to level-screen move your mouse to
desired location on level-screen and press left mouse button. You can
draw on level-screen using current image not releasing left mouse
button.
Third functional part of screen is a button-pad. Buttons are:
SAVE INS NEXT
DEL REM PREV
After you finished designing level you need to save your work. Using
mouse cursor, press and release SAVE button. Current level will be
written to disk. (Current level and overall level count shown in
left-top part of level-screen).
If you need to fully redraw current level, DEL button can be handy.
Press DEL button to remove all bricks and players from the
level-screen.
You can insert new level by pressing INS button. REM button fully
removes current level. NEXT and PREV buttons used to select level to
modify.
Right mouse button used to test current level. Press right mouse
button to execute test. During test all looks and functions like in
ordinary game, except you can't see "Score:" and "Lives:". If your
Runner died you immediately return to edit mode. You can also press
ESC key to cancel test.
USEFUL ADVICES:
Before any operation (NEXT, PREV, test) it is clever to SAVE your
work, other way all modifications will not be saved!
When designing level you must leave first and second lines of
level maximally clear. Because dead Enemy Runner randomly appears in
these lines. If all places in these lines are used (not clear) game
can hang!
Also you need to make first line of level reachable to Green Runner by
putting Stairs in right places.
Good luck at this point!
ÚÂÂÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
³³³³ HIGH SCORES
By selecting HIGH SCORES from main menu you activate "High Scores"
screen. Press any key to return to main menu.
ÚÂÂÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
³³³³ EXIT TO DOS
This option is so standard! No explanation.
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ
ÚÂÂÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
³³³³ GAME CONSISTENCE
Game packet must have following files:
LRL.EXE - main executable file
LRL.IMG - images data file
LRL.LEV - levels data file
LRL.MAN - text you are reading now
OPTION:
LRL.HSR - file with high scores
FILE_ID.DIZ - BBS description file
ÚÂÂÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
³³³³ CONTACTING THE AUTHOR
If you want to publish this game in any way contact author via E-mail:
ikomi@glas.apc.org
you can write in English (but preferably in Russian!)
for FidoNet-users: 2:5003/15.
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ
Lode Runner Live version 1.0 Copyright (c) 1995 Aleksey V. Vaneev
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ
END OF TEXT.

30
programs/games/lrl/build.bat
View File

@ -1,30 +0,0 @@
@echo off
rem „«ï ᡮન ¨£àë ­¥®¡å®¤¨¬® ¢ ¯¥à¥¬¥­­®© UNITS (®¯à¥¤¥«¥­  ­¨¦¥)
rem 㪠§ âì à á¯®«®¦¥­¨¥ ¯ ¯ª¨, ¢ ª®â®à®© ­ å®¤ïâáï ®âª®¬¯¨«¨à®¢ ­­ë¥ ¬®¤ã«¨
rem RTL ¤«ï KolibriOS. <20> ¯à¨¬¥à, ¥á«¨ ¨á室­¨ª¨ 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

3
programs/games/lrl/build.sh Executable file
View File

@ -0,0 +1,3 @@
#!/bin/sh
fpcmake -Twin32
make

19
programs/games/lrl/dist.sh Executable file
View File

@ -0,0 +1,19 @@
#!/bin/sh
BIN="`pwd`/bin"
DIST="dist"
if ! [ -d $DIST ]; then
mkdir $DIST; fi
cd $DIST
rm -rf *
mkdir lrl
for name in $BIN/*; do
cp "$name" "lrl/`echo \`basename \"$name\"\` | tr [A-Z] [a-z]`"; done
tar cf - lrl | bzip2 -9f > lrl.tar.bz2
cd ..

10
programs/games/lrl/readme-ru.txt
View File

@ -1,10 +0,0 @@
Lode Runner Live 1.0
====================
<EFBFBD>஥ªâ ¯® ¯¥à¥­®áã ¨£àë Lode Runner Live 1.0 á ¯« âä®à¬ë DOS ¢ KolibriOS.
—¨â ©â¥ ª®¬¬¥­â à¨¨ ¯® ª®¬¯¨«ï樨 ¢ build.bat.
<EFBFBD>  ¤ ­­ë© ¬®¬¥­â â¥áâ¨à®¢ « áì ªà®áª®¬¯¨«ïæ¨ï ⮫쪮 ¨§ Windows 2000 SP4
­  32å à §à來®© ¬ è¨­¥.

21
programs/games/lrl/LRL.pp → programs/games/lrl/src/LRL.pp
View File

@ -8,18 +8,20 @@ uses
LRLSprites,
LRLLevels,
LRLMainMenu,
{LRLHighScores,
LRLEditor,}
LRLHighScores,
{LRLEditor,}
LRLIntroduction;
const
Version: array [1..34] of char = 'Lode Runner LIVE. Version 1.0'#13#10#13#10'$';
Version: PChar = 'Lode Runner LIVE. Version 1.4b';
procedure LRLInitialize;
begin
kos_setkeyboardmode(0);
ImagesInitialize;
KeyboardInitialize;
ScreenMode(1);
ScreenTitle := Version;
end;
@ -45,20 +47,21 @@ begin
repeat
LRLPlayLevel(cl);
KeyboardFlush;
if GameResult = 10 then
begin
Inc(LRLLives);
LRLScore := LRLScore + 10000 * longint(cl);
LRLScore := LRLScore + 10000 * Longint(cl);
Inc(cl);
end else
Dec(LRLLives);
until (LRLLives = 0) or (GameResult = 100);
{(GameResult <> 100) and LRLBestScore(LRLScore) then
if (GameResult <> 100) and LRLBestScore(LRLScore) then
begin
LRLInsertScore(LRLEnterName, LRLScore);
LRLShowHighScores;
end;}
end;
end;
procedure LRLShell;
@ -69,8 +72,8 @@ begin
repeat
LRLSelectItem(MenuSelection);
if MenuSelection = 1 then LRLGameStart;
{if MenuSelection = 2 then LRLEditLevels;
if MenuSelection = 3 then LRLShowHighScores;}
{if MenuSelection = 2 then LRLEditLevels;}
if MenuSelection = 3 then LRLShowHighScores;
until MenuSelection = 4;
end;

0
programs/games/lrl/LRLEditor.pp → programs/games/lrl/src/LRLEditor.pp
View File

186
programs/games/lrl/LRLHighScores.pp → programs/games/lrl/src/LRLHighScores.pp
View File

@ -1,19 +1,23 @@
unit LRLHighScores;
{$mode objfpc}
{$i-}
interface
uses
LRLRoutines, LRLSprites, StrUnit;
SysUtils,
LRLRoutines, LRLSprites;
procedure LRLLoadHighScores;
procedure LRLShowHighScores;
function LRLBestScore(Score: longint): boolean;
procedure LRLInsertScore(Name: string; Score: longint);
function LRLBestScore(Score: Longint): Boolean;
procedure LRLInsertScore(Name: String; Score: Longint);
procedure LRLSaveHighScores;
function LRLEnterName: string;
function LRLEnterName: String;
implementation
@ -21,114 +25,130 @@ implementation
const
HighsFileName = 'LRL.HSR';
HighsFileHeader: string[29] = 'Lode Runner Live High Scores'#26;
HighsFileHeader: String[29] = 'Lode Runner Live High Scores'#26;
type
TSupers = packed record
Name: string[20];
Score: longint;
Name: String[20];
Score: Longint;
end;
var
MainScreen: POINTER;
HighFrame: POINTER;
MainScreen: Pointer;
HighFrame: Pointer;
HighTable: array[1..5] of TSupers;
procedure LoadData;
var
j: word;
j: Word;
begin
GETMEM(MainScreen, 64004);
GETMEM(HighFrame, 45000);
DFAFilePositionSet(ImageFile, LRLImagesFilePosition, DFASeekFromStart);
DFAFileRead(ImageFile, MainScreen^, 7940, j);
GetMem(MainScreen, 64004);
GetMem(HighFrame, 45000);
Seek(ImageFile, LRLImagesFilePosition);
BlockRead(ImageFile, MainScreen^, 7940, j);
DecompressRepByte(MainScreen^, HighFrame^, 7940, j);
DFAFileRead(ImageFile, MainScreen^, 64004, j);
BlockRead(ImageFile, MainScreen^, 64004, j);
end;
procedure DisposeData;
begin
FREEMEM(MainScreen, 64004);
FREEMEM(HighFrame, 45000);
FreeMem(MainScreen, 64004);
FreeMem(HighFrame, 45000);
end;
procedure LRLShowHighScores;
var
p: POINTER;
i: integer;
s: string;
p: Pointer;
i: Integer;
s: String;
begin
LRLLoadHighScores;
GETMEM(p, 768);
GetMem(p, 768);
DataFill(p^, 768, 0, 0);
Palette256Set(p^);
FREEMEM(p, 768);
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);
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);
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;
ReadKey;
FadeClear;
ImageClear(LRLScreen^);
ScreenApply(LRLScreen^);
DisposeData;
end;
procedure LRLLoadHighScores;
var
InFile: TDFAFileHandle;
i, j: word;
high: TSupers;
dummy: string[30];
InFile: File;
i, j: Word;
Dummy: String[30];
begin
high.Name := 'Lode Runner';
DFAFileOpen(InFile, HighsFileName, DFAAccessReadWrite);
if DFALastResult(InFile) <> 0 then
FileMode := 0;
AssignFile(InFile, HighsFileName);
Reset(InFile, 1);
if IOResult <> 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);
HighTable[i].Name := 'Lode Runner';
HighTable[i].score := 60000 - i * 10000;
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
AssignFile(InFile, HighsFileName);
Rewrite(InFile, 1);
BlockWrite(InFile, HighsFileHeader[1], 29, i);
BlockWrite(InFile, HighTable, SizeOf(TSupers) * 5, j);
end else
begin
WRITELN('Error: Invalid file with high scores! (try to remove LRL.HSR file)');
WRITELN('Žè¨¡ª : <20>¥¢¥à­ë© ä ©« á ४®à¤ ¬¨! (¯®¯à®¡ã©â¥ 㤠«¨âì ä ©« LRL.HSR)');
Halt(1);
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;
DFAFileRead(InFile, HighTable, SIZEOF(TSupers) * 5, j);
DFAFileClose(InFile);
Close(InFile);
end;
procedure LRLSaveHighScores;
var
InFile: TDFAFileHandle;
i, j: word;
InFile: File;
j: Word;
begin
DFAFileOpen(InFile, HighsFileName, DFAAccessReadWrite);
DFAFilePositionSet(InFile, 29, DFASeekFromStart);
DFAFileWrite(InFile, HighTable, SIZEOF(TSupers) * 5, j);
DFAFileClose(InFile);
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;
function LRLBestScore(Score: Longint): Boolean;
var
i: integer;
i: Integer;
begin
LRLBestScore := True;
LRLLoadHighScores;
@ -136,19 +156,20 @@ begin
while True do
begin
if Score >= HighTable[i].Score then
EXIT;
Exit;
Inc(i);
if i > 5 then
begin
LRLBestScore := False;
EXIT;
Exit;
end;
end;
end;
procedure LRLInsertScore(Name: string; Score: longint);
procedure LRLInsertScore(Name: String; Score: Longint);
var
i, j: word;
i, j: Word;
begin
LRLLoadHighScores;
i := 1;
@ -164,29 +185,32 @@ begin
HighTable[i].Name := Name;
HighTable[i].Score := Score;
LRLSaveHighScores;
EXIT;
Exit;
end;
Inc(i);
if i > 5 then
begin
EXIT;
Exit;
end;
end;
end;
function LRLEnterName: string;
function LRLEnterName: String;
var
p: POINTER;
i: integer;
RedrawName: boolean;
Keypress: word;
Name: string;
p: Pointer;
RedrawName: Boolean;
Keypress: Word;
Name: String;
C: Char;
begin
Name := '';
GETMEM(p, 768);
GetMem(p, 768);
DataFill(p^, 768, 0, 0);
Palette256Set(p^);
FREEMEM(p, 768);
FreeMem(p, 768);
ImageClear(LRLScreen^);
ImagePut(LRLScreen^, LRLLogo^, 3, 3, 0, 0, 319, 199);
ImageStringGet('Congratulations! You are in Top-Five!', LRLFont^, LRLFontBuffer^, 110);
@ -199,6 +223,7 @@ begin
1, 155, 0, 0, 319, 199);
ScreenApply(LRLScreen^);
FadeTo(LRLMenuPalette);
RedrawName := True;
repeat
if RedrawName = True then
@ -206,26 +231,31 @@ 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);
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
Keypress := ReadKey;
if (Keypress = KEY_BACK) and (Length(Name) > 0) then
begin
Name[0] := char(Ord(Name[0]) - 1);
SetLength(Name, Length(Name) - 1);
RedrawName := True;
end;
if (LO(Keypress) > 31) and (LENGTH(Name) < 20) then
C := ScanToChar(Keypress);
if (C > #31) and (Length(Name) < 20) then
begin
Name := Name + char(LO(Keypress));
Name := Name + C;
RedrawName := True;
end;
until LO(Keypress) = 13;
until Keypress = KEY_ENTER;
FadeClear;
Name := StringTrimAll(Name, ' ');
if LENGTH(Name) = 0 then
Name := Trim(Name);
if Length(Name) = 0 then
Name := 'Anonymous';
LRLEnterName := Name;
end;

12
programs/games/lrl/LRLIntroduction.pp → programs/games/lrl/src/LRLIntroduction.pp
View File

@ -17,10 +17,10 @@ implementation
const
IntroText: array[1..14] of String = (
'Lode Runner LIVE. FREEWARE Version 1.0',
'Lode Runner LIVE. FREEWARE Version 1.4b',
'KolibriOS port by bw (Vladimir V. Byrgazov)',
'Copyright (c) 1995 Aleksey V. Vaneev',
'Copyright (c) 2007 bw',
'Copyright (c) 2008 bw',
'',
'Send comments to Aleksey V. Vaneev',
'2:5003/15@FidoNet',
@ -30,17 +30,13 @@ const
'bw@handsdriver.net',
'',
'',
''
);
'');
SPACE40 = ' ';
var
RefreshDelay: Word;
RefreshRemain: Word;
TimeToRefresh: Boolean;
OldTimer: Pointer;
procedure LRLIntro;
@ -50,8 +46,6 @@ var
k: Word;
MainScreen: Pointer;
begin
RefreshDelay := 1;
RefreshRemain := 1;
GetMem(MainScreen, 64004);
Seek(ImageFile, LRLImagesFilePosition + 7940);

94
programs/games/lrl/LRLLevels.pp → programs/games/lrl/src/LRLLevels.pp
View File

@ -91,13 +91,13 @@ const
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);
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;
@ -123,7 +123,7 @@ var
procedure LRLLoadLevel(Number: Byte);
procedure LRLUpdatePlayers;
procedure LRLDrawOrnamental(x1, y1, x2, y2, ornament: Byte);
function LRLPlayLevel(Number: Byte): Word;
procedure LRLPlayLevel(Number: Byte);
function LRLLevelCount: Word;
procedure LRLDeleteLevel(Count: Word);
procedure LRLInsertLevel(After: Word);
@ -135,7 +135,7 @@ implementation
const
LevelFileName = 'LRL.LEV';
LevelFileHeader: String = 'Lode Runner Live Levels'#26;
LevelFileHeader: ShortString = 'Lode Runner Live Levels'#26;
ERR_OPENFILE = '<27>¥¢®§¬®¦­® ®âªàëâì ä ©« ã஢­¥©';
ERR_BADFILE = '<27>¥¢¥à­ë© ¨«¨ ¯®¢à¥¦¤¥­­ë© ä ©« ã஢­¥©';
@ -166,6 +166,7 @@ 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)));
@ -178,8 +179,8 @@ begin
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);
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);
@ -190,7 +191,7 @@ procedure LRLDeleteLevel(Count: Word);
var
Buffer: Pointer;
LevelFile: File;
i, j: Integer;
j: Integer;
l: Longint;
k: Word;
begin
@ -198,6 +199,7 @@ begin
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
@ -221,7 +223,7 @@ procedure LRLInsertLevel(After: Word);
var
Buffer: Pointer;
LevelFile: File;
i, j: Integer;
j: Integer;
l: Longint;
k: Word;
begin
@ -229,6 +231,7 @@ begin
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
@ -254,7 +257,7 @@ procedure LRLLoadLevel(Number: Byte);
var
LevelFile: File;
InBuffer: Pointer;
i, j, k, l, x, y: Word;
i, j, k: Word;
a, b, c: Byte;
begin
TotalPrizes := 0;
@ -445,18 +448,17 @@ begin
end;
{
game result:
1 - zamurovali
2 - poimali
10 - vse zdelano
50 - no more levels
60 - no human players
100 - esc was pressed
}
{ GameResult:
1 - § ¬ã஢ «¨
2 - ¯®©¬ «¨
10 - ¢á¥ ᤥ« ­®
50 - ­¥â ¡®«ìè¥ ã஢­¥©
60 - ­¥â 祫®¢¥ç¥áª¨å ⮢
100 - ­ ¦ â  Esc }
procedure LRLUpdatePlayers;
var
i, j, k: Integer;
i, k: Integer;
spd: Word;
begin
for i := 1 to 10 do
@ -508,21 +510,21 @@ begin
if (i = 1) then
begin
if (TotalPrizes = 0) and (Position.y = 1) and
(LRLLevel.Field[Position.x, Position.y].Image = 2) then
(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;
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
@ -703,12 +705,10 @@ begin
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
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;
@ -975,7 +975,7 @@ end;
procedure LRLComputerPlayer;
var
k, l, m, f1, f2, i, j: Integer;
k, l, m, f1, f2, i: Integer;
begin
if ComputerTurn >= ComputerReaction then
begin
@ -1045,8 +1045,8 @@ begin
NewCommand := 2;
end;
end;
end
else
end else
if (Position.y < LRLLevel.Player[1].Position.y) then
begin
if (((LRLLevel.Field[Position.x, Position.y + 1].Image = 2) and
@ -1114,13 +1114,12 @@ begin
end;
end;
end;
end
else
end else
Inc(ComputerTurn);
end;
function LRLPlayLevel(Number: Byte): Word;
procedure LRLPlayLevel(Number: Byte);
var
Keypress: Word;
i: Word;
@ -1181,14 +1180,15 @@ begin
LRLLevel.Player[KeyboardControls[i * 3 + 2]].NewCommandWas := True;
end;
if (Keypress = $50) or (Keypress = $70) then
if Keypress = KEY_P then
Paused := True;
end;
until (Keypress = $1B) or EndOfGame;
until (Keypress = KEY_ESC) or EndOfGame;
if EndOfGame then
LRLEndSequence else
GameResult := 100;
end;
end.

11
programs/games/lrl/LRLMainMenu.pp → programs/games/lrl/src/LRLMainMenu.pp
View File

@ -24,7 +24,7 @@ var
procedure LoadData;
var
size, j: Word;
j: Word;
i: Integer;
begin
GetMem(MainScreen, 64004);
@ -67,6 +67,7 @@ begin
DataFill(p^, 768, 0, 0);
Palette256Set(p^);
FreeMem(p, 768);
LoadData;
NeedToFade := True;
ImagePut(LRLScreen^, MainScreen^, 0, 0, 0, 0, 319, 199);
@ -94,17 +95,17 @@ begin
Keypress := ReadKey;
if (Keypress = $B1) and (Item < 4) then
if (Keypress = KEY_DOWN) and (Item < 4) then
begin
Inc(Item);
RedrawAll := True;
end;
if (Keypress = $B2) and (Item > 1) then
end else
if (Keypress = KEY_UP) and (Item > 1) then
begin
Dec(Item);
RedrawAll := True;
end;
until Keypress = $0D;
until Keypress = KEY_ENTER;
FadeClear;
ImageClear(LRLScreen^);

865
programs/games/lrl/src/LRLRoutines.pp Normal file
View File

@ -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.

2
programs/games/lrl/LRLSprites.pp → programs/games/lrl/src/LRLSprites.pp
View File

@ -86,7 +86,7 @@ procedure LoadImages;
var
InBuffer: Pointer;
i, j, k, l, x, y: Word;
a, b, c: Byte;
a: Byte;
begin
GetMem(InBuffer, $FFF0);