forked from KolibriOS/kolibrios
500 lines
11 KiB
ObjectPascal
500 lines
11 KiB
ObjectPascal
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);
|
||
|
||
{ <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><>ப<EFBFBD> }
|
||
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;
|
||
|
||
{ <20>뢮<EFBFBD> <20><>ப<EFBFBD> }
|
||
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.
|