969 lines
22 KiB
ObjectPascal
969 lines
22 KiB
ObjectPascal
{$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.
|