WebSVN – Kolibri OS – /programs/games/lrl/LRLRoutines.pp

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.

Subversion Repositories Kolibri OS

(root)/programs/games/lrl/LRLRoutines.pp – Rev 761