Subversion Repositories Kolibri OS

Rev

Rev 775 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed

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