Subversion Repositories Kolibri OS

Rev

Rev 762 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed

  1. unit LRLRoutines;
  2.  
  3. {$mode objfpc}
  4. {$asmmode intel}
  5.  
  6.  
  7. interface
  8.  
  9.  
  10. procedure ImagePut(var Screen, ImageBuffer; X, Y, WinX1, WinY1, WinX2, WinY2: Integer);
  11. procedure ImagePutTransparent(var Screen, ImageBuffer; X, Y, WinX1, WinY1, WinX2, WinY2: Integer);
  12. procedure ImageFill(var ImageBuffer; SizeX, SizeY: Word; Value: Byte);
  13. function  ImageSizeX(var ImageBuffer): Word;
  14. function  ImageSizeY(var ImageBuffer): Word;
  15. procedure ImageStringGet(Source: String; var FontData, Buffer; ColorOffs: Byte);
  16. procedure ScreenApply(var Buffer);
  17. procedure ImageClear(var Buffer);
  18. procedure ScreenMode(Mode: Integer);
  19.  
  20. function ScanToChar(Code: Word): Char;
  21. procedure KeyboardInitialize;
  22. function Keypressed: Boolean;
  23. function ReadKey: Word;
  24. procedure KeyboardFlush;
  25.  
  26. procedure MouseInitialize;
  27. function MSMouseInArea(x1, y1, x2, y2: Integer): Boolean;
  28. function MSMouseDriverExist: Boolean;
  29. procedure MSMouseGetXY(var x, y: Integer);
  30. function MSMouseButtonStatusGet: Word;
  31. function MSMouseButtonWasPressed(Button: Word; var x, y: Integer): Boolean;
  32. function MSMouseButtonWasReleased(Button: Word; var x, y: Integer): Boolean;
  33. procedure MSMouseSetXY(x, y: Integer);
  34.  
  35. procedure Palette256Set(var Palette256);
  36. procedure Palette256Get(var Palette256);
  37. procedure Palette256Darken(var Palette256; StartElement, EndElement, Decrement, MinValue: Byte);
  38. procedure Palette256Transform(var SourcePalette, DestinationPalette);
  39. function DataByteGet(var Buffer; BufferOffset: Word): Byte;
  40. procedure DataBytePut(var Buffer; BufferOffset: Word; Value: Byte);
  41. function DataWordGet(var Buffer; BufferOffset: Word): Word;
  42. procedure DataWordPut(var Buffer; BufferOffset: Word; Value: Word);
  43. procedure DataMove(var Source, Destination; Count: Word; SourceOffset, DestinationOffset: Word);
  44. procedure DataAdd(var Buffer; Count: Word; Amount: Byte; BufferOffset: Word);
  45. procedure DataFill(var Buffer; Count: Word; Value: Byte; BufferOffset: Word);
  46. function DataIdentical(var Array1, Array2; Count: Word; Array1Offset, Array2Offset: Word): Boolean;
  47. function SetInterrupt(Int: Byte; NewAddress: Pointer): Pointer;
  48. procedure FadeClear;
  49. procedure FadeTo(pal: Pointer);
  50. procedure DecompressRepByte(var InArray, OutArray; InArraySize: Word; var OutArraySize: Word);
  51.  
  52. function GetInterrupt(Int: Byte): Pointer;
  53. procedure WaitForEvent(Timeout: DWord = 0);
  54. procedure AssignFile(var AFile: File; AFileName: String);
  55. function LastDosTick(): Longword;
  56.  
  57.  
  58. const
  59.   KEY_GREY    = $E000;
  60.   KEY_UP_BASE = $8000;
  61.   KEY_ESC   = $0100;
  62.   KEY_1     = $0200;
  63.   KEY_2     = $0300;
  64.   KEY_3     = $0400;
  65.   KEY_4     = $0500;
  66.   KEY_5     = $0600;
  67.   KEY_6     = $0700;
  68.   KEY_7     = $0800;
  69.   KEY_8     = $0900;
  70.   KEY_9     = $0A00;
  71.   KEY_0     = $0B00;
  72.   KEY_SUBTRACT = $0C00;
  73.   KEY_ADD      = $0D00;
  74.   KEY_BACK  = $0E00;
  75.  
  76.   KEY_Q     = $1000;
  77.   KEY_W     = $1100;
  78.   KEY_E     = $1200;
  79.   KEY_R     = $1300;
  80.   KEY_T     = $1400;
  81.   KEY_Y     = $1500;
  82.   KEY_U     = $1600;
  83.   KEY_I     = $1700;
  84.   KEY_O     = $1800;
  85.   KEY_P     = $1900;
  86.   KEY_LBRACKET = $1A00;
  87.   KEY_RBRACKET = $1B00;
  88.   KEY_ENTER = $1C00;
  89.  
  90.   KEY_A     = $1E00;
  91.   KEY_S     = $1F00;
  92.   KEY_D     = $2000;
  93.   KEY_F     = $2100;
  94.   KEY_G     = $2200;
  95.   KEY_H     = $2300;
  96.   KEY_J     = $2400;
  97.   KEY_K     = $2500;
  98.   KEY_L     = $2600;
  99.   KEY_SEMICOLON = $2700;
  100.   KEY_QUOTE     = $2800;
  101.  
  102.   KEY_LSHIFT = $2A00;
  103.   KEY_Z     = $2C00;
  104.   KEY_X     = $2D00;
  105.   KEY_C     = $2E00;
  106.   KEY_V     = $2F00;
  107.   KEY_B     = $3000;
  108.   KEY_N     = $3100;
  109.   KEY_M     = $3200;
  110.   KEY_COMMA = $3300;
  111.   KEY_DECIMAL = $3400;
  112.   KEY_DIVIDE  = $3500;
  113.   KEY_RSHIFT  = $3600;
  114.  
  115.   KEY_ALT   = $3800;
  116.   KEY_CAPITAL = $3600;
  117.   KEY_F1    = $3B00;
  118.   KEY_UP    = $4800;
  119.   KEY_LEFT  = $4B00;
  120.   KEY_GREY5 = $4C00;
  121.   KEY_RIGHT = $4D00;
  122.   KEY_END   = $4F00;
  123.   KEY_DOWN  = $5000;
  124.   KEY_PGDN  = $5100;
  125.  
  126. type
  127.   ScanToCharRecord = record
  128.     Scan: Word;
  129.     CL: Char;
  130.     CU: Char;
  131.     Caps: Boolean;
  132.   end;
  133.  
  134. var
  135.   ScreenTitle: PChar = nil;
  136.   ScanToCharTable: array[1..45] of ScanToCharRecord = (
  137.     (Scan: KEY_0; CL: '0'; CU: ')'; Caps: False), (Scan: KEY_1; CL: '1'; CU: '!'; Caps: False),
  138.     (Scan: KEY_2; CL: '2'; CU: '@'; Caps: False), (Scan: KEY_3; CL: '3'; CU: '#'; Caps: False),
  139.     (Scan: KEY_4; CL: '4'; CU: '$'; Caps: False), (Scan: KEY_5; CL: '5'; CU: '%'; Caps: False),
  140.     (Scan: KEY_6; CL: '6'; CU: '^'; Caps: False), (Scan: KEY_7; CL: '7'; CU: '&'; Caps: False),
  141.     (Scan: KEY_8; CL: '8'; CU: '*'; Caps: False), (Scan: KEY_9; CL: '9'; CU: '('; Caps: False),
  142.     (Scan: KEY_SUBTRACT; CL: '-'; CU: '_'; Caps: False), (Scan: KEY_ADD; CL: '='; CU: '+'; Caps: False),
  143.  
  144.     (Scan: KEY_Q; CL: 'q'; CU: 'Q'; Caps: True), (Scan: KEY_W; CL: 'w'; CU: 'W'; Caps: True),
  145.     (Scan: KEY_E; CL: 'e'; CU: 'E'; Caps: True), (Scan: KEY_R; CL: 'r'; CU: 'R'; Caps: True),
  146.     (Scan: KEY_T; CL: 't'; CU: 'T'; Caps: True), (Scan: KEY_Y; CL: 'y'; CU: 'Y'; Caps: True),
  147.     (Scan: KEY_U; CL: 'u'; CU: 'U'; Caps: True), (Scan: KEY_I; CL: 'i'; CU: 'I'; Caps: True),
  148.     (Scan: KEY_O; CL: 'o'; CU: 'O'; Caps: True), (Scan: KEY_P; CL: 'p'; CU: 'P'; Caps: True),
  149.     (Scan: KEY_LBRACKET; CL: '['; CU: '{'; Caps: False), (Scan: KEY_RBRACKET; CL: ']'; CU: '}'; Caps: False),
  150.  
  151.     (Scan: KEY_A; CL: 'a'; CU: 'A'; Caps: True), (Scan: KEY_S; CL: 's'; CU: 'S'; Caps: True),
  152.     (Scan: KEY_D; CL: 'd'; CU: 'D'; Caps: True), (Scan: KEY_F; CL: 'f'; CU: 'F'; Caps: True),
  153.     (Scan: KEY_G; CL: 'g'; CU: 'G'; Caps: True), (Scan: KEY_H; CL: 'h'; CU: 'H'; Caps: True),
  154.     (Scan: KEY_J; CL: 'j'; CU: 'J'; Caps: True), (Scan: KEY_K; CL: 'k'; CU: 'K'; Caps: True),
  155.     (Scan: KEY_L; CL: 'l'; CU: 'L'; Caps: True),
  156.     (Scan: KEY_SEMICOLON; CL: ';'; CU: ':'; Caps: False), (Scan: KEY_QUOTE; CL: ''''; CU: '"'; Caps: False),
  157.  
  158.     (Scan: KEY_Z; CL: 'z'; CU: 'Z'; Caps: True), (Scan: KEY_X; CL: 'x'; CU: 'X'; Caps: True),
  159.     (Scan: KEY_C; CL: 'c'; CU: 'C'; Caps: True), (Scan: KEY_V; CL: 'v'; CU: 'V'; Caps: True),
  160.     (Scan: KEY_B; CL: 'b'; CU: 'B'; Caps: True), (Scan: KEY_N; CL: 'n'; CU: 'N'; Caps: True),
  161.     (Scan: KEY_M; CL: 'm'; CU: 'M'; Caps: True),
  162.     (Scan: KEY_COMMA; CL: ','; CU: '<'; Caps: False), (Scan: KEY_DECIMAL; CL: '.'; CU: '>'; Caps: False),
  163.     (Scan: KEY_DIVIDE; CL: '/'; CU: '?'; Caps: False)
  164.     );
  165.  
  166.  
  167. implementation
  168.  
  169.  
  170. uses
  171.   SysUtils;
  172.  
  173.  
  174. const
  175.   BUFFER_WIDTH  = 320;
  176.   BUFFER_HEIGHT = 200;
  177.  
  178. type
  179.   PRGBColor = ^TRGBColor;
  180.   TRGBColor = packed record
  181.     R, G, B: Byte;
  182.   end;
  183.  
  184.   PRGBPalette = ^TRGBPalette;
  185.   TRGBPalette = array[Byte] of TRGBColor;
  186.  
  187.  
  188. var
  189.   ScreenRGBPalette: TRGBPalette;
  190.   ScreenRGBBuffer : PRGBColor = nil;
  191.   ScreenRGBTemporary: PRGBColor = nil;
  192.   ScreenPalBuffer : array[0..BUFFER_HEIGHT - 1, 0..BUFFER_WIDTH - 1] of Byte;
  193.  
  194.   WindowWidth : Longint;
  195.   WindowHeight: Longint;
  196.   ScreenWidth : Longword;
  197.   ScreenHeight: Longword;
  198.   CurrentScreenMode: Integer = 0;
  199.  
  200.   LastKeyEvent: Word = $FFFF;
  201.   LastKeyUp  : Boolean = True;
  202.   LastKeyDown: Boolean = False;
  203.   AltDown    : Boolean = False;
  204.   ShiftDown  : Boolean = False;
  205.   LShiftDown : Boolean = False;
  206.   RShiftDown : Boolean = False;
  207.   CapsPressed: Boolean = False;
  208.  
  209.  
  210.  
  211. procedure Paint;
  212. begin
  213.   kos_begindraw();
  214.   kos_definewindow(10, 10, 100, 100, $64000000);
  215.   if CurrentScreenMode <> 0     then
  216.   begin
  217.     kos_setcaption(ScreenTitle);
  218.     if Assigned(ScreenRGBBuffer) then
  219.       kos_drawimage24(0, 0, ScreenWidth, ScreenHeight, ScreenRGBBuffer) else
  220.       kos_drawrect(0, 0, ScreenWidth, ScreenHeight, $FF00FF);
  221.   end;
  222.   kos_enddraw();
  223. end;
  224.  
  225.  
  226. procedure UpdateRGBBuffer;
  227. var
  228.   XStep, YStep: Longword;
  229.  
  230.   procedure Horizontal;
  231.   var
  232.     X, Y, I: Longword;
  233.     B: PByte;
  234.     C: PRGBColor;
  235.   begin
  236.     C := ScreenRGBTemporary;
  237.     for Y := 0 to BUFFER_HEIGHT - 1 do
  238.     begin
  239.       I := 0;
  240.       B := @ScreenPalBuffer[Y, 0];
  241.       for X := 0 to ScreenWidth - 1 do
  242.       begin
  243.         C^ := ScreenRGBPalette[PByte(B + (I shr 16))^];
  244.         Inc(I, XStep);
  245.         Inc(C);
  246.       end;
  247.     end;
  248.   end;
  249.  
  250.   procedure Vertical;
  251.   var
  252.     Y, I: Longword;
  253.     S: PRGBColor;
  254.     C: PRGBColor;
  255.   begin
  256.     I := 0;
  257.     S := ScreenRGBTemporary;
  258.     C := ScreenRGBBuffer;
  259.     for Y := 0 to ScreenHeight - 1 do
  260.     begin
  261.       Move(PRGBColor(S + (I shr 16) * ScreenWidth)^, C^, ScreenWidth * SizeOf(C^));
  262.       Inc(I, YStep);
  263.       Inc(C, ScreenWidth);
  264.     end;
  265.   end;
  266.  
  267. var
  268.   I, J: Longint;
  269.   B: PByte;
  270.   C: PRGBColor;
  271.  
  272. begin
  273.   if (ScreenWidth = BUFFER_WIDTH) and (ScreenHeight = BUFFER_HEIGHT) then
  274.   begin
  275.     {¯¥à¥­®á ®¤¨­ ¢ ®¤¨­}
  276.     B := @ScreenPalBuffer;
  277.     C := ScreenRGBBuffer;
  278.     for I := 0 to BUFFER_HEIGHT - 1 do
  279.     for J := 0 to BUFFER_WIDTH - 1 do
  280.     begin
  281.       C^ := ScreenRGBPalette[B^];
  282.       Inc(B);
  283.       Inc(C);
  284.     end;
  285.   end else
  286.   begin
  287.     {¬ áèâ ¡¨à®¢ ­¨¥}
  288.     XStep := (BUFFER_WIDTH shl 16) div ScreenWidth;
  289.     YStep := (BUFFER_HEIGHT shl 16) div ScreenHeight;
  290.     Horizontal;
  291.     Vertical;
  292.   end;
  293.  
  294.   Paint;
  295. end;
  296.  
  297.  
  298. procedure ImagePut(var Screen, ImageBuffer; X, Y, WinX1, WinY1, WinX2, WinY2: Integer);
  299. var
  300.   Width, Height: Longint;
  301.   I, J, K: Integer;
  302.   P: Pointer;
  303. begin
  304.   Width  := PWord(@ImageBuffer)[0];
  305.   Height := PWord(@ImageBuffer)[1];
  306.  
  307.   P := @ImageBuffer + 4;
  308.   for I := Y to Y + Height - 1 do
  309.   begin
  310.     if (I >= 0) and (I < BUFFER_HEIGHT) and (I >= WinY1) and (I <= WinY2) then
  311.     begin
  312.       if X < WinX1 then
  313.         J := WinX1 - X else
  314.         J := 0;
  315.       if X + Width - 1 > WinX2 then
  316.         K := WinX2 - X - J + 1 else
  317.         K := Width - J;
  318.       Move((P + J)^, (@Screen + I * BUFFER_WIDTH + X + J)^, K);
  319.     end;
  320.     Inc(P, Width);
  321.   end;
  322. end;
  323.  
  324.  
  325. procedure ImagePutTransparent(var Screen, ImageBuffer; X, Y, WinX1, WinY1, WinX2, WinY2: Integer);
  326. var
  327.   Width, Height: Longint;
  328.   I, J, K, L: Integer;
  329.   PI, PO: PByte;
  330. begin
  331.   Width  := PWord(@ImageBuffer)[0];
  332.   Height := PWord(@ImageBuffer)[1];
  333.  
  334.   PI := @ImageBuffer + 4;
  335.  
  336.   for I := Y to Y + Height - 1 do
  337.   begin
  338.     if (I >= 0) and (I < BUFFER_HEIGHT) and (I >= WinY1) and (I <= WinY2) then
  339.     begin
  340.       if X < WinX1 then
  341.         J := WinX1 - X else
  342.         J := 0;
  343.       if X + Width - 1 > WinX2 then
  344.         K := WinX2 - X - J + 1 else
  345.         K := Width - J;
  346.  
  347.       Inc(PI, J);
  348.       PO := @Screen + I * BUFFER_WIDTH + X + J;
  349.       for L := 1 to K do
  350.       begin
  351.                 if PI^ > 0 then
  352.           PO^ := PI^;
  353.         Inc(PI);
  354.         Inc(PO);
  355.       end;
  356.       Dec(PI, J + K);
  357.     end;
  358.     Inc(PI, Width);
  359.   end;
  360. end;
  361.  
  362.  
  363. procedure ImageFill(var ImageBuffer; SizeX, SizeY: Word; Value: Byte);
  364. begin
  365.   PWord(@ImageBuffer)^     := SizeX;
  366.   PWord(@ImageBuffer + 2)^ := SizeY;
  367.   FillChar((@ImageBuffer + 4)^, SizeX * SizeY, Value);
  368. end;
  369.  
  370.  
  371. function ImageSizeX(var ImageBuffer): Word;
  372. begin
  373.   Result := PWord(@ImageBuffer)^;
  374. end;
  375.  
  376.  
  377. function ImageSizeY(var ImageBuffer): Word;
  378. begin
  379.   Result := PWord(@ImageBuffer + 2)^;
  380. end;
  381.  
  382.  
  383. procedure ImageStringGet(Source: String; var FontData, Buffer; ColorOffs: Byte);
  384. var
  385.   Width, Height: Word;
  386.   Table: PWord;
  387.   P, B: PByte;
  388.   X, I, J, K, C: Word;
  389. begin
  390.   Height := PWord(@FontData + 2)^;
  391.   Table  := PWord(@FontData + 4);
  392.  
  393.   { à áç¥â ¤«¨­ë áâப¨ }
  394.   Width := 0;
  395.   for I := 1 to Length(Source) do
  396.   begin
  397.     P := @Table[Ord(Source[I])];
  398.     Inc(Width, PWord(P + PWord(P)^)^);
  399.   end;
  400.  
  401.   PWord(@Buffer)^     := Width;
  402.   PWord(@Buffer + 2)^ := Height;
  403.  
  404.   { ¢ë¢®¤ áâப¨ }
  405.   X := 0;
  406.   for I := 1 to Length(Source) do
  407.   begin
  408.     P := @Table[Ord(Source[I])];
  409.     B := PByte(P + PWord(P)^);
  410.     C := PWord(B)^;
  411.     Inc(B, 2);
  412.  
  413.     P := PByte(@Buffer + 4 + X);
  414.     for K := 0 to Height - 1 do
  415.     begin
  416.       for J := 0 to C - 1 do
  417.       begin
  418.         if B^ = 0 then
  419.           P^ := 0 else
  420.           P^ := B^ + ColorOffs;
  421.         Inc(P);
  422.         Inc(B);
  423.       end;
  424.       Inc(P, Width - C);
  425.     end;
  426.  
  427.     Inc(X, C);
  428.   end;
  429. end;
  430.  
  431. procedure ScreenApply(var Buffer);
  432. begin
  433.   Move(Buffer, ScreenPalBuffer, SizeOf(ScreenPalBuffer));
  434.   UpdateRGBBuffer;
  435. end;
  436.  
  437. procedure ImageClear(var Buffer);
  438. begin
  439.   FillChar(Buffer, BUFFER_WIDTH * BUFFER_HEIGHT, 0);
  440. end;
  441.  
  442. procedure ScreenMode(Mode: Integer);
  443. var
  444.   ThreadInfo: TKosThreadInfo;
  445. begin
  446.   if Mode <> CurrentScreenMode then
  447.   begin
  448.     if Assigned(ScreenRGBBuffer) then FreeMem(ScreenRGBBuffer);
  449.     if Assigned(ScreenRGBTemporary) then FreeMem(ScreenRGBTemporary);
  450.  
  451.     case Mode of
  452.       -2: begin
  453.         ScreenWidth  := BUFFER_WIDTH div 2;
  454.         ScreenHeight := BUFFER_HEIGHT div 2;
  455.       end;
  456.       1..3: begin
  457.         ScreenWidth  := BUFFER_WIDTH * Mode;
  458.         ScreenHeight := BUFFER_HEIGHT * Mode;
  459.       end;
  460.     end;
  461.  
  462.     if CurrentScreenMode = 0 then Paint;
  463.  
  464.     kos_threadinfo(@ThreadInfo);
  465.  
  466.     with ThreadInfo, WindowRect do
  467.     begin
  468.       WindowWidth  := Width - ClientRect.Width + Longint(ScreenWidth);
  469.       WindowHeight := Height - ClientRect.Height + Longint(ScreenHeight);
  470.       kos_movewindow(Left, Top, WindowWidth, WindowHeight);
  471.     end;
  472.  
  473.     CurrentScreenMode := Mode;
  474.  
  475.     ScreenRGBBuffer    := GetMem(ScreenWidth * ScreenHeight * SizeOf(ScreenRGBBuffer^));
  476.     ScreenRGBTemporary := GetMem(ScreenWidth * BUFFER_HEIGHT * SizeOf(ScreenRGBTemporary^));
  477.  
  478.     UpdateRGBBuffer;
  479.   end;
  480. end;
  481.  
  482.  
  483.  
  484. function ScanToChar(Code: Word): Char;
  485. var
  486.   I: Word;
  487. begin
  488.   for I := Low(ScanToCharTable) to High(ScanToCharTable) do
  489.   with ScanToCharTable[I] do
  490.   if Scan = Code then
  491.   begin
  492.     if not CapsPressed then
  493.       if not ShiftDown then
  494.         Result := CL else
  495.         Result := CU
  496.     else
  497.       if not ShiftDown then
  498.         if not Caps then
  499.           Result := CL else
  500.           Result := CU
  501.       else
  502.         if not Caps then
  503.           Result := CL else
  504.           Result := CL;
  505.     Exit;
  506.   end;
  507.   Result := #0;
  508. end;
  509.  
  510. procedure KeyboardInitialize;
  511. begin
  512.   kos_setkeyboardmode(1);
  513. end;
  514.  
  515. function ReadKeyLoop: Word;
  516. var
  517.   Event: Word;
  518. begin
  519.   kos_maskevents(ME_PAINT or ME_KEYBOARD);
  520.   repeat
  521.     Event := kos_getevent();
  522.     if Event = SE_PAINT then Paint;
  523.   until Event = SE_KEYBOARD;
  524.   Result := kos_getkey();
  525. end;
  526.  
  527. function TranslateKey(Key: Word): Word;
  528. begin
  529.   if Key = KEY_GREY then
  530.     Result := kos_getkey() else
  531.     Result := Key;
  532.  
  533.   LastKeyDown := Result < KEY_UP_BASE;
  534.   LastKeyUp   := not LastKeyDown;
  535.   if LastKeyUp then Dec(Result, KEY_UP_BASE);
  536.  
  537.   if Result = KEY_ALT then
  538.   begin
  539.     AltDown := LastKeyDown;
  540.     Result  := $FFFF;
  541.   end else
  542.  
  543.   if Result = KEY_LSHIFT then
  544.   begin
  545.     LShiftDown := LastKeyDown;
  546.     ShiftDown  := LShiftDown or RShiftDown;
  547.     Result     := $FFFF;
  548.   end else
  549.  
  550.   if Result = KEY_RSHIFT then
  551.   begin
  552.     RShiftDown := LastKeyDown;
  553.     ShiftDown  := LShiftDown or RShiftDown;
  554.     Result     := $FFFF;
  555.   end else
  556.  
  557.   if AltDown then
  558.   case Result of
  559.     KEY_1: begin Result := $FFFF; if LastKeyDown then ScreenMode(1); end;
  560.     KEY_2: begin Result := $FFFF; if LastKeyDown then ScreenMode(2); end;
  561.     KEY_3: begin Result := $FFFF; if LastKeyDown then ScreenMode(3); end;
  562.     KEY_9: begin Result := $FFFF; if LastKeyDown then ScreenMode(-2); end;
  563.     KEY_0: begin Result := $FFFF; if LastKeyDown then ScreenMode(100); end;
  564.   end;
  565. end;
  566.  
  567. function Keypressed: Boolean;
  568. begin
  569.   if (LastKeyEvent < KEY_UP_BASE) and LastKeyDown then
  570.     Result := True else
  571.   begin
  572.     kos_maskevents(ME_KEYBOARD);
  573.     if kos_getevent(False) = SE_KEYBOARD then
  574.     begin
  575.       LastKeyEvent := TranslateKey(kos_getkey());
  576.       if LastKeyEvent < KEY_UP_BASE then
  577.         Result := LastKeyDown else
  578.         Result := False;
  579.     end else
  580.     begin
  581.       LastKeyEvent := $FFFF;
  582.       Result := False;
  583.     end;
  584.   end;
  585. end;
  586.  
  587. function ReadKey: Word;
  588. begin
  589.   repeat
  590.     if LastKeyEvent < KEY_UP_BASE then
  591.       Result := LastKeyEvent else
  592.       Result := TranslateKey(ReadKeyLoop);
  593.     LastKeyEvent := $FFFF;
  594.   until (Result < KEY_UP_BASE) and LastKeyDown;
  595. end;
  596.  
  597. procedure KeyboardFlush;
  598. begin
  599. end;
  600.  
  601. procedure ProcessKeyboard;
  602. begin
  603.   LastKeyEvent := TranslateKey(kos_getkey());
  604. end;
  605.  
  606.  
  607.  
  608. const
  609.   MK_LBUTTON = 1;
  610.   MK_RBUTTON = 2;
  611.   MK_MBUTTON = 4;
  612.   MouseButtonsCount = 3;
  613.  
  614. var
  615.   MouseButtonsState   : DWord;
  616.   MouseButtonsPressed : array[1..MouseButtonsCount] of DWord;
  617.   MouseButtonsReleased: array[1..MouseButtonsCount] of DWord;
  618.  
  619.  
  620. procedure ProcessMouse;
  621. var
  622.   I: Longint;
  623.   Buttons, ButtonMask: DWord;
  624.   NowPressed, WasPressed: Boolean;
  625. begin
  626.   Buttons := kos_getmousebuttons();
  627.  
  628.   for I := 1 to MouseButtonsCount do
  629.   begin
  630.     ButtonMask := 1 shl (I - 1);
  631.     NowPressed := (Buttons and ButtonMask) <> 0;
  632.     WasPressed := (MouseButtonsState and ButtonMask) <> 0;
  633.  
  634.     if NowPressed and not WasPressed then Inc(MouseButtonsPressed[I]) else
  635.     if not NowPressed and WasPressed then Inc(MouseButtonsReleased[I]);
  636.   end;
  637.  
  638.   MouseButtonsState := Buttons;
  639. end;
  640.  
  641. procedure MouseInitialize;
  642. var
  643.   I: Longint;
  644. begin
  645.   MouseButtonsState := kos_getmousebuttons();
  646.   for I := 1 to MouseButtonsCount do
  647.   begin
  648.     MouseButtonsPressed[I]  := 0;
  649.     MouseButtonsReleased[I] := 0;
  650.   end;
  651.   ProcessMouse;
  652. end;
  653.  
  654. function MSMouseInArea(x1, y1, x2, y2: Integer): Boolean;
  655. var
  656.   X, Y: Integer;
  657. begin
  658.   MSMouseGetXY(X, Y);
  659.   Result := (X >= x1) and (X <= x2) and (Y >= y1) and (Y <= y2);
  660. end;
  661.  
  662. function MSMouseDriverExist: Boolean;
  663. begin
  664.   Result := True;
  665. end;
  666.  
  667. procedure MSMouseGetXY(var X, Y: Integer);
  668. var
  669.   WinPos: TKosPoint;
  670. begin
  671.   WinPos := kos_getmousewinpos();
  672.  
  673.   X := Round(Double(WinPos.X) * BUFFER_WIDTH / ScreenWidth);
  674.   if X <  0            then X := 0 else
  675.   if X >= BUFFER_WIDTH then X := BUFFER_WIDTH - 1;
  676.  
  677.   Y := Round(Double(WinPos.Y) * BUFFER_HEIGHT / ScreenHeight);
  678.   if Y <  0             then Y := 0 else
  679.   if Y >= BUFFER_HEIGHT then Y := BUFFER_HEIGHT - 1;
  680. end;
  681.  
  682. function MSMouseButtonStatusGet: Word;
  683. begin
  684.   Result := Word(kos_getmousebuttons());
  685. end;
  686.  
  687. function MSMouseButtonWasPressed(Button: Word; var x, y: Integer): Boolean;
  688. begin
  689.   Inc(Button);
  690.   if Button < MouseButtonsCount then
  691.   begin
  692.     Result := MouseButtonsPressed[Button] > 0;
  693.     MouseButtonsPressed[Button] := 0;
  694.   end else
  695.     Result := False;
  696.   MSMouseGetXY(x, y);
  697. end;
  698.  
  699. function MSMouseButtonWasReleased(Button: Word; var x, y: Integer): Boolean;
  700. begin
  701.   Inc(Button);
  702.   if Button < MouseButtonsCount then
  703.   begin
  704.     Result := MouseButtonsReleased[Button] > 0;
  705.     MouseButtonsReleased[Button] := 0;
  706.   end else
  707.     Result := False;
  708.   MSMouseGetXY(x, y);
  709. end;
  710.  
  711. procedure MSMouseSetXY(x, y: Integer);
  712. begin
  713. end;
  714.  
  715.  
  716.  
  717.  
  718. procedure Palette256Set(var Palette256);
  719. var
  720.   I: Longint;
  721.   P: PRGBColor;
  722. begin
  723.   P := @Palette256;
  724.   for I := 0 to 255 do
  725.   with ScreenRGBPalette[I] do
  726.   begin
  727.     R := Round(P^.B / 63 * 255);
  728.     G := Round(P^.G / 63 * 255);
  729.     B := Round(P^.R / 63 * 255);
  730.     Inc(P);
  731.   end;
  732.   UpdateRGBBuffer;
  733. end;
  734.  
  735.  
  736. procedure Palette256Get(var Palette256);
  737. var
  738.   I: Longint;
  739.   P: PRGBColor;
  740. begin
  741.   P := @Palette256;
  742.   for I := 0 to 255 do
  743.   with ScreenRGBPalette[I] do
  744.   begin
  745.     P^.R := Round(B / 255 * 63);
  746.     P^.G := Round(G / 255 * 63);
  747.     P^.B := Round(R / 255 * 63);
  748.     Inc(P);
  749.   end;
  750. end;
  751.  
  752. procedure Palette256Darken(var Palette256; StartElement, EndElement, Decrement, MinValue: Byte);
  753. var
  754.   I, J: Byte;
  755.   PB  : PByte;
  756. begin
  757.   PB := @Palette256;
  758.   Inc(PB, StartElement * 3);
  759.   for I := StartElement to EndElement do
  760.   for J := 1 to 3 do
  761.   begin
  762.     if PB^ > MinValue then
  763.     if PB^ < Decrement then
  764.       PB^ := MinValue else
  765.       Dec(PB^, Decrement);
  766.     Inc(PB);
  767.   end;
  768. end;
  769.  
  770. procedure Palette256Transform(var SourcePalette, DestinationPalette);
  771. var
  772.   I: Longint;
  773.   S, D: PByte;
  774. begin
  775.   S := @SourcePalette;
  776.   D := @DestinationPalette;
  777.   for I := 0 to 767 do
  778.   begin
  779.     if S^ < D^ then Inc(S^) else
  780.     if S^ > D^ then Dec(S^);
  781.     Inc(S);
  782.     Inc(D);
  783.   end;
  784. end;
  785.  
  786.  
  787. function DataByteGet(var Buffer; BufferOffset: Word): Byte;
  788. begin
  789.   Result := PByte(@Buffer + BufferOffset)^;
  790. end;
  791.  
  792. procedure DataBytePut(var Buffer; BufferOffset: Word; Value: Byte);
  793. begin
  794.   PByte(@Buffer + BufferOffset)^ := Value;
  795. end;
  796.  
  797. function DataWordGet(var Buffer; BufferOffset: Word): Word;
  798. begin
  799.   Result := PWord(@Buffer + BufferOffset)^;
  800. end;
  801.  
  802. procedure DataWordPut(var Buffer; BufferOffset: Word; Value: Word);
  803. begin
  804.   PWord(@Buffer + BufferOffset)^ := Value;
  805. end;
  806.  
  807. procedure DataMove(var Source, Destination; Count: Word; SourceOffset, DestinationOffset: Word);
  808. begin
  809.   Move((@Source + SourceOffset)^, (@Destination + DestinationOffset)^, Count);
  810. end;
  811.  
  812. procedure DataFill(var Buffer; Count: Word; Value: Byte; BufferOffset: Word);
  813. begin
  814.   FillChar((@Buffer + BufferOffset)^, Count, Value);
  815. end;
  816.  
  817. function DataIdentical(var Array1, Array2; Count: Word; Array1Offset, Array2Offset: Word): Boolean;
  818. begin
  819.   Result := CompareByte((@Array1 + Array1Offset)^, (@Array2 + Array2Offset)^, Count) = 0;
  820. end;
  821.  
  822. procedure DataAdd(var Buffer; Count: Word; Amount: Byte; BufferOffset: Word);
  823. var
  824.   I: Word;
  825.   PB: PByte;
  826. begin
  827.   PB := @Buffer + BufferOffset;
  828.   for I := 1 to Count do
  829.   begin
  830.     if PB^ > 0 then
  831.       Inc(PB^, Amount);
  832.     Inc(PB);
  833.   end;
  834. end;
  835.  
  836.  
  837. function SetInterrupt(Int: Byte; NewAddress: Pointer): Pointer;
  838. begin
  839.   Result := nil;
  840. end;
  841.  
  842.  
  843. procedure FadeClear;
  844. var
  845.   Pal1, Pal2: Pointer;
  846.   i: Integer;
  847. begin
  848.   GetMem(Pal1, 768);
  849.   GetMem(Pal2, 768);
  850.   Palette256Get(Pal1^);
  851.   for i := 0 to 32 do
  852.   begin
  853.     DataMove(Pal1^, Pal2^, 768, 0, 0);
  854.     Palette256Darken(Pal2^, 0, 255, i * 2, 0);
  855.     Palette256Set(Pal2^);
  856.   end;
  857.   FreeMem(Pal1, 768);
  858.   FreeMem(Pal2, 768);
  859. end;
  860.  
  861. procedure FadeTo(Pal: Pointer);
  862. var
  863.   Pal1: Pointer;
  864.   I: Integer;
  865. begin
  866.   GetMem(Pal1, 768);
  867.   Palette256Get(Pal1^);
  868.   for I := 0 to 32 do
  869.   begin
  870.     Palette256Transform(Pal1^, Pal^);
  871.     Palette256Transform(Pal1^, Pal^);
  872.     Palette256Set(Pal1^);
  873.     kos_delay(1);
  874.   end;
  875.   FreeMem(Pal1, 768);
  876. end;
  877.  
  878.  
  879. procedure DecompressRepByte(var InArray, OutArray; InArraySize: Word; var OutArraySize: Word);
  880. var
  881.   I, J: Word;
  882.   PIn : PByte;
  883.   POut: PByte;
  884. begin
  885.   I := 0;
  886.   PIn  := @InArray;
  887.   POut := @OutArray;
  888.  
  889.   while I < InArraySize do
  890.   begin
  891.     Inc(I);
  892.  
  893.     if PIn^ = 0 then
  894.     begin
  895.       Inc(PIn);
  896.       J := PIn^;
  897.       Inc(I, 2);
  898.       Inc(PIn);
  899.       Inc(OutArraySize, J);
  900.       while J > 0 do
  901.       begin
  902.         POut^ := PIn^;
  903.         Inc(POut);
  904.         Dec(J);
  905.       end;
  906.       Inc(PIn);
  907.     end else
  908.  
  909.     if PIn^ < 4 then
  910.     begin
  911.       J := PIn^;
  912.       Inc(I);
  913.       Inc(PIn);
  914.       Inc(OutArraySize, J);
  915.       while J > 0 do
  916.       begin
  917.         POut^ := PIn^;
  918.         Inc(POut);
  919.         Dec(J);
  920.       end;
  921.       Inc(PIn);
  922.     end else
  923.  
  924.     begin
  925.       POut^ := PIn^;
  926.       Inc(PIn);
  927.       Inc(POut);
  928.       Inc(OutArraySize);
  929.     end;
  930.   end;
  931. end;
  932.  
  933.  
  934. function GetInterrupt(Int: Byte): Pointer;
  935. begin
  936.   Result := nil;
  937. end;
  938.  
  939.  
  940. procedure WaitForEvent(Timeout: DWord = 0);
  941. var
  942.   Event: Word;
  943. begin
  944.   kos_maskevents(ME_PAINT or ME_KEYBOARD or ME_MOUSE);
  945.   Event := kos_waitevent(Timeout);
  946.   case Event of
  947.     SE_PAINT: Paint;
  948.     SE_KEYBOARD: ProcessKeyboard;
  949.     SE_MOUSE: ProcessMouse;
  950.   end;
  951. end;
  952.  
  953.  
  954. procedure AssignFile(var AFile: File; AFileName: String);
  955. begin
  956.   Assign(AFile, IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0))) + AFileName);
  957. end;
  958.  
  959.  
  960. function LastDosTick(): Longword;
  961. begin
  962.   Result := Round(kos_timecounter() * 0.182);
  963. end;
  964.  
  965.  
  966. end.
  967.