kolibrios/programs/games/lrl/src/LRLRoutines.pp

969 lines
22 KiB
ObjectPascal
Raw Normal View History

{$codepage utf8}
{$mode objfpc}
{$asmmode intel}
unit LRLRoutines;
interface
procedure ImagePut(var Screen, ImageBuffer; X, Y, WinX1, WinY1, WinX2, WinY2: Integer);
procedure ImagePutTransparent(var Screen, ImageBuffer; X, Y, WinX1, WinY1, WinX2, WinY2: Integer);
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);
function ScanToChar(Code: Word): Char;
procedure KeyboardInitialize;
function Keypressed: Boolean;
function ReadKey: Word;
procedure KeyboardFlush;
procedure MouseInitialize;
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 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 GetInterrupt(Int: Byte): Pointer;
procedure WaitForEvent(Timeout: DWord = 0);
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_CTRL = $1D00;
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;
CtrlDown : 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, WinX1, WinY1, WinX2, WinY2: Integer);
var
Width, Height: Longint;
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;
if X + Width - 1 > WinX2 then
K := WinX2 - X - J + 1 else
K := Width - J;
Move((P + J)^, (@Screen + I * BUFFER_WIDTH + X + J)^, K);
end;
Inc(P, Width);
end;
end;
procedure ImagePutTransparent(var Screen, ImageBuffer; X, Y, WinX1, WinY1, WinX2, WinY2: Integer);
var
Width, Height: Longint;
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;
if X + Width - 1 > WinX2 then
K := WinX2 - X - J + 1 else
K := Width - J;
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;
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 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_CTRL then
begin
CtrlDown := 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 CtrlDown 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;
procedure ProcessKeyboard;
begin
LastKeyEvent := TranslateKey(kos_getkey());
end;
const
MK_LBUTTON = 1;
MK_RBUTTON = 2;
MK_MBUTTON = 4;
MouseButtonsCount = 3;
var
MouseButtonsState : DWord;
MouseButtonsPressed : array[1..MouseButtonsCount] of DWord;
MouseButtonsReleased: array[1..MouseButtonsCount] of DWord;
procedure ProcessMouse;
var
I: Longint;
Buttons, ButtonMask: DWord;
NowPressed, WasPressed: Boolean;
begin
Buttons := kos_getmousebuttons();
for I := 1 to MouseButtonsCount do
begin
ButtonMask := 1 shl (I - 1);
NowPressed := (Buttons and ButtonMask) <> 0;
WasPressed := (MouseButtonsState and ButtonMask) <> 0;
if NowPressed and not WasPressed then Inc(MouseButtonsPressed[I]) else
if not NowPressed and WasPressed then Inc(MouseButtonsReleased[I]);
end;
MouseButtonsState := Buttons;
end;
procedure MouseInitialize;
var
I: Longint;
begin
MouseButtonsState := kos_getmousebuttons();
for I := 1 to MouseButtonsCount do
begin
MouseButtonsPressed[I] := 0;
MouseButtonsReleased[I] := 0;
end;
ProcessMouse;
end;
function MSMouseInArea(x1, y1, x2, y2: Integer): Boolean;
var
X, Y: Integer;
begin
MSMouseGetXY(X, Y);
Result := (X >= x1) and (X <= x2) and (Y >= y1) and (Y <= y2);
end;
function MSMouseDriverExist: Boolean;
begin
Result := True;
end;
procedure MSMouseGetXY(var X, Y: Integer);
var
WinPos: TKosPoint;
begin
WinPos := kos_getmousewinpos();
X := Round(Double(WinPos.X) * BUFFER_WIDTH / ScreenWidth);
if X < 0 then X := 0 else
if X >= BUFFER_WIDTH then X := BUFFER_WIDTH - 1;
Y := Round(Double(WinPos.Y) * BUFFER_HEIGHT / ScreenHeight);
if Y < 0 then Y := 0 else
if Y >= BUFFER_HEIGHT then Y := BUFFER_HEIGHT - 1;
end;
function MSMouseButtonStatusGet: Word;
begin
Result := Word(kos_getmousebuttons());
end;
function MSMouseButtonWasPressed(Button: Word; var x, y: Integer): Boolean;
begin
Inc(Button);
if Button < MouseButtonsCount then
begin
Result := MouseButtonsPressed[Button] > 0;
MouseButtonsPressed[Button] := 0;
end else
Result := False;
MSMouseGetXY(x, y);
end;
function MSMouseButtonWasReleased(Button: Word; var x, y: Integer): Boolean;
begin
Inc(Button);
if Button < MouseButtonsCount then
begin
Result := MouseButtonsReleased[Button] > 0;
MouseButtonsReleased[Button] := 0;
end else
Result := False;
MSMouseGetXY(x, y);
end;
procedure MSMouseSetXY(x, y: Integer);
begin
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 GetInterrupt(Int: Byte): Pointer;
begin
Result := nil;
end;
procedure WaitForEvent(Timeout: DWord = 0);
var
Event: Word;
begin
kos_maskevents(ME_PAINT or ME_KEYBOARD or ME_MOUSE);
Event := kos_waitevent(Timeout);
case Event of
SE_PAINT: Paint;
SE_KEYBOARD: ProcessKeyboard;
SE_MOUSE: ProcessMouse;
end;
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.