Subversion Repositories Kolibri OS

Rev

Go to most recent revision | Blame | 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: Integer; Winx1, Winy1, Winx2, Winy2: Word);
  11. procedure ImagePutTransparent(var Screen, ImageBuffer; X, Y: Integer; Winx1, Winy1, Winx2, Winy2: Word);
  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.  
  19. procedure Palette256Set(var Palette256);
  20. procedure Palette256Get(var Palette256);
  21. procedure Palette256Grayscale(var Palette256; StartElement, EndElement: Byte);
  22. procedure Palette256Darken(var Palette256; StartElement, EndElement, Decrement, MinValue: Byte);
  23. procedure Palette256Transform(var SourcePalette, DestinationPalette);
  24. function DataByteGet(var Buffer; BufferOffset: Word): Byte;
  25. procedure DataBytePut(var Buffer; BufferOffset: Word; Value: Byte);
  26. function DataWordGet(var Buffer; BufferOffset: Word): Word;
  27. procedure DataWordPut(var Buffer; BufferOffset: Word; Value: Word);
  28. procedure DataMove(var Source, Destination; Count: Word; SourceOffset, DestinationOffset: Word);
  29. procedure DataAdd(var Buffer; Count: Word; Amount: Byte; BufferOffset: Word);
  30. procedure DataFill(var Buffer; Count: Word; Value: Byte; BufferOffset: Word);
  31. function DataIdentical(var Array1, Array2; Count: Word; Array1Offset, Array2Offset: Word): Boolean;
  32. function ReadKey: Word;
  33. function Keypressed: Boolean;
  34. function SetInterrupt(Int: Byte; NewAddress: Pointer): Pointer;
  35. procedure FadeClear;
  36. procedure FadeTo(pal: Pointer);
  37. procedure DecompressRepByte(var InArray, OutArray; InArraySize: Word; var OutArraySize: Word);
  38. function MSMouseInArea(x1, y1, x2, y2: Integer): Boolean;
  39. function MSMouseDriverExist: Boolean;
  40. procedure MSMouseGetXY(var x, y: Integer);
  41. function MSMouseButtonStatusGet: Word;
  42. function MSMouseButtonWasPressed(Button: Word; var x, y: Integer): Boolean;
  43. function MSMouseButtonWasReleased(Button: Word; var x, y: Integer): Boolean;
  44. procedure MSMouseSetXY(x, y: Integer);
  45. procedure KeyboardFlush;
  46. function GetInterrupt(Int: Byte): Pointer;
  47.  
  48. procedure AssignFile(var AFile: File; AFileName: String);
  49. function LastDosTick(): Longword;
  50.  
  51.  
  52. implementation
  53.  
  54.  
  55. uses
  56.   SysUtils;
  57.  
  58.  
  59. const
  60.   SCREEN_WIDTH  = 320;
  61.   SCREEN_HEIGHT = 200;
  62.  
  63. type
  64.   PRGBColor = ^TRGBColor;
  65.   TRGBColor = packed record
  66.     R, G, B: Byte;
  67.   end;
  68.  
  69.   PRGBPalette = ^TRGBPalette;
  70.   TRGBPalette = array[Byte] of TRGBColor;
  71.  
  72. var
  73.   ScreenRGBPalette: TRGBPalette;
  74.   ScreenRGBBuffer : array[0..SCREEN_HEIGHT - 1, 0..SCREEN_WIDTH - 1] of TRGBColor;
  75.   ScreenBuffer    : array[0..SCREEN_WIDTH * SCREEN_HEIGHT - 1] of Byte;
  76.  
  77.   AlreadyKeyPressed: Boolean = False;
  78.  
  79.  
  80. procedure Paint;
  81. begin
  82.   kos_begindraw();
  83.   kos_definewindow(500, 100, SCREEN_WIDTH - 1, SCREEN_HEIGHT - 1, $01000000);
  84.   kos_drawimage24(0, 0, SCREEN_WIDTH, SCREEN_HEIGHT, @ScreenRGBBuffer);
  85.   kos_enddraw();
  86. end;
  87.  
  88. procedure UpdateRGBBuffer;
  89. var
  90.   I, J: Longint;
  91.   B: PByte;
  92. begin
  93.   B := @ScreenBuffer;
  94.   for I := 0 to SCREEN_HEIGHT - 1 do
  95.   for J := 0 to SCREEN_WIDTH - 1 do
  96.   begin
  97.     ScreenRGBBuffer[I, J] := ScreenRGBPalette[B^];
  98.     Inc(B);
  99.   end;
  100.   Paint;
  101. end;
  102.  
  103.  
  104. procedure ImagePut(var Screen, ImageBuffer; X, Y: Integer; WinX1, WinY1, WinX2, WinY2: Word);
  105. var
  106.   Width, Height: Word;
  107.   I, J, K: Integer;
  108.   P: Pointer;
  109. begin
  110.   Width  := PWord(@ImageBuffer)[0];
  111.   Height := PWord(@ImageBuffer)[1];
  112.  
  113.   P := @ImageBuffer + 4;
  114.   for I := Y to Y + Height - 1 do
  115.   begin
  116.     if (I >= 0) and (I < SCREEN_HEIGHT) and (I >= WinY1) and (I <= WinY2) then
  117.     begin
  118.       if X < WinX1 then
  119.         J := WinX1 - X else
  120.         J := 0;
  121.       K := Width - J;
  122.       if WinX1 + K - 1 > WinX2 then
  123.         K := WinX2 - WinX1 + 1;
  124.       Move((P + J)^, (@Screen + I * SCREEN_WIDTH + X + J)^, K);
  125.     end;
  126.     Inc(P, Width);
  127.   end;
  128. end;
  129.  
  130. procedure ImagePutTransparent(var Screen, ImageBuffer; X, Y: Integer; Winx1, Winy1, Winx2, Winy2: Word);
  131. begin
  132.   ImagePut(Screen, ImageBuffer, X, Y, Winx1, Winy1, Winx2, Winy2);
  133. end;
  134.  
  135. procedure ImageFill(var ImageBuffer; SizeX, SizeY: Word; Value: Byte);
  136. begin
  137.   PWord(@ImageBuffer)^     := SizeX;
  138.   PWord(@ImageBuffer + 2)^ := SizeY;
  139.   FillChar((@ImageBuffer + 4)^, SizeX * SizeY, Value);
  140. end;
  141.  
  142. function ImageSizeX(var ImageBuffer): Word;
  143. begin
  144.   Result := PWord(@ImageBuffer)^;
  145. end;
  146.  
  147. function ImageSizeY(var ImageBuffer): Word;
  148. begin
  149.   Result := PWord(@ImageBuffer + 2)^;
  150. end;
  151.  
  152. procedure ImageStringGet(Source: String; var FontData, Buffer; ColorOffs: Byte);
  153. var
  154.   Width, Height: Word;
  155.   Table: PWord;
  156.   P, B: PByte;
  157.   X, I, J, K, C: Word;
  158. begin
  159.   Height := PWord(@FontData + 2)^;
  160.   Table  := PWord(@FontData + 4);
  161.  
  162.   { расчет длины строки }
  163.   Width := 0;
  164.   for I := 1 to Length(Source) do
  165.   begin
  166.     P := @Table[Ord(Source[I])];
  167.     Inc(Width, PWord(P + PWord(P)^)^);
  168.   end;
  169.  
  170.   PWord(@Buffer)^     := Width;
  171.   PWord(@Buffer + 2)^ := Height;
  172.  
  173.   { вывод строки }
  174.   X := 0;
  175.   for I := 1 to Length(Source) do
  176.   begin
  177.     P := @Table[Ord(Source[I])];
  178.     B := PByte(P + PWord(P)^);
  179.     C := PWord(B)^;
  180.     Inc(B, 2);
  181.  
  182.     P := PByte(@Buffer + 4 + X);
  183.     for K := 0 to Height - 1 do
  184.     begin
  185.       for J := 0 to C - 1 do
  186.       begin
  187.         if B^ = 0 then
  188.           P^ := 0 else
  189.           P^ := B^ + ColorOffs;
  190.         Inc(P);
  191.         Inc(B);
  192.       end;
  193.       Inc(P, Width - C);
  194.     end;
  195.  
  196.     Inc(X, C);
  197.   end;
  198. end;
  199.  
  200. procedure ScreenApply(var Buffer);
  201. begin
  202.   Move(Buffer, ScreenBuffer, SizeOf(ScreenBuffer));
  203.   UpdateRGBBuffer;
  204. end;
  205.  
  206.  
  207. procedure ImageClear(var Buffer);
  208. begin
  209.   FillChar(Buffer, SCREEN_WIDTH * SCREEN_HEIGHT, 0);
  210. end;
  211.  
  212.  
  213. procedure Palette256Set(var Palette256);
  214. var
  215.   I: Longint;
  216.   P: PRGBColor;
  217. begin
  218.   P := @Palette256;
  219.   for I := 0 to 255 do
  220.   with ScreenRGBPalette[I] do
  221.   begin
  222.     R := Round(P^.B / 63 * 255);
  223.     G := Round(P^.G / 63 * 255);
  224.     B := Round(P^.R / 63 * 255);
  225.     Inc(P);
  226.   end;
  227.   UpdateRGBBuffer;
  228. end;
  229.  
  230. procedure Palette256Get(var Palette256);
  231. var
  232.   I: Longint;
  233.   P: PRGBColor;
  234. begin
  235.   P := @Palette256;
  236.   for I := 0 to 255 do
  237.   with ScreenRGBPalette[I] do
  238.   begin
  239.     P^.R := Round(B / 255 * 63);
  240.     P^.G := Round(G / 255 * 63);
  241.     P^.B := Round(R / 255 * 63);
  242.     Inc(P);
  243.   end;
  244. end;
  245.  
  246. procedure Palette256Grayscale(var Palette256; StartElement, EndElement: Byte);
  247. begin
  248. end;
  249.  
  250. procedure Palette256Darken(var Palette256; StartElement, EndElement, Decrement, MinValue: Byte);
  251. begin
  252. end;
  253.  
  254. procedure Palette256Transform(var SourcePalette, DestinationPalette);
  255. var
  256.   I: Longint;
  257.   S, D: PByte;
  258. begin
  259.   S := @SourcePalette;
  260.   D := @DestinationPalette;
  261.   for I := 0 to 767 do
  262.   begin
  263.     if S^ < D^ then Inc(S^) else
  264.     if S^ > D^ then Dec(S^);
  265.     Inc(S);
  266.     Inc(D);
  267.   end;
  268. end;
  269.  
  270. function DataByteGet(var Buffer; BufferOffset: Word): Byte;
  271. begin
  272.   Result := PByte(@Buffer + BufferOffset)^;
  273. end;
  274.  
  275. procedure DataBytePut(var Buffer; BufferOffset: Word; Value: Byte);
  276. begin
  277.   PByte(@Buffer + BufferOffset)^ := Value;
  278. end;
  279.  
  280. function DataWordGet(var Buffer; BufferOffset: Word): Word;
  281. begin
  282.   Result := PWord(@Buffer + BufferOffset)^;
  283. end;
  284.  
  285. procedure DataWordPut(var Buffer; BufferOffset: Word; Value: Word);
  286. begin
  287.   PWord(@Buffer + BufferOffset)^ := Value;
  288. end;
  289.  
  290. procedure DataMove(var Source, Destination; Count: Word; SourceOffset, DestinationOffset: Word);
  291. begin
  292.   Move((@Source + SourceOffset)^, (@Destination + DestinationOffset)^, Count);
  293. end;
  294.  
  295. procedure DataFill(var Buffer; Count: Word; Value: Byte; BufferOffset: Word);
  296. begin
  297.   FillChar((@Buffer + BufferOffset)^, Count, Value);
  298. end;
  299.  
  300. function DataIdentical(var Array1, Array2; Count: Word; Array1Offset, Array2Offset: Word): Boolean;
  301. begin
  302.   Result := CompareByte((@Array1 + Array1Offset)^, (@Array2 + Array2Offset)^, Count) = 0;
  303. end;
  304.  
  305. procedure DataAdd(var Buffer; Count: Word; Amount: Byte; BufferOffset: Word);
  306. var
  307.   I: Word;
  308. begin
  309.   for I := 0 to Count do
  310.     Inc(PByte(@Buffer + BufferOffset + I)^, Amount);
  311.     {if >0 then += amount}
  312. end;
  313.  
  314. function ReadKey: Word;
  315. var
  316.   Event: Word;
  317. begin
  318.   if not AlreadyKeyPressed then
  319.   begin
  320.     kos_maskevents(ME_PAINT or ME_KEYBOARD);
  321.     repeat
  322.       Event := kos_getevent();
  323.       if Event = SE_PAINT then Paint;
  324.     until Event = SE_KEYBOARD;
  325.   end;
  326.   Result := kos_getkey() shr 8;
  327.   AlreadyKeyPressed := False;
  328.   {WriteLn('ReadKey -> ', IntToHex(Result, 2));}
  329. end;
  330.  
  331. function Keypressed: Boolean;
  332. begin
  333.   if AlreadyKeyPressed then
  334.     Result := True else
  335.   begin
  336.     kos_maskevents(ME_KEYBOARD);
  337.     Result := kos_getevent(False) = SE_KEYBOARD;
  338.     AlreadyKeyPressed := Result;
  339.   end;
  340. end;
  341.  
  342. procedure KeyboardFlush;
  343. var
  344.   Event: Word;
  345. begin
  346.   kos_maskevents(ME_KEYBOARD);
  347.   repeat
  348.     Event := kos_getevent(False);
  349.     if Event = SE_KEYBOARD then kos_getkey();
  350.   until Event = 0;
  351.   AlreadyKeyPressed := False;
  352. end;
  353.  
  354. function SetInterrupt(Int: Byte; NewAddress: Pointer): Pointer;
  355. begin
  356.   Result := nil;
  357. end;
  358.  
  359. procedure FadeClear;
  360. var
  361.   Pal1, Pal2: Pointer;
  362.   i: Integer;
  363. begin
  364.   GetMem(Pal1, 768);
  365.   GetMem(Pal2, 768);
  366.   Palette256Get(Pal1^);
  367.   for i := 0 to 32 do
  368.   begin
  369.     DataMove(Pal1^, Pal2^, 768, 0, 0);
  370.     Palette256Darken(Pal2^, 0, 255, i * 2, 0);
  371.     Palette256Set(Pal2^);
  372.   end;
  373.   FreeMem(Pal1, 768);
  374.   FreeMem(Pal2, 768);
  375. end;
  376.  
  377. procedure FadeTo(Pal: Pointer);
  378. var
  379.   Pal1: Pointer;
  380.   I: Integer;
  381. begin
  382.   GetMem(Pal1, 768);
  383.   Palette256Get(Pal1^);
  384.   for I := 0 to 63 do
  385.   begin
  386.     Palette256Transform(Pal1^, Pal^);
  387.     Palette256Set(Pal1^);
  388.     kos_delay(1);
  389.   end;
  390.   FreeMem(Pal1, 768);
  391. end;
  392.  
  393. procedure DecompressRepByte(var InArray, OutArray; InArraySize: Word; var OutArraySize: Word);
  394. begin
  395. {asm
  396.   PUSH DS
  397.  
  398.   xor DX,DX
  399.   xor AX,AX
  400.  
  401.   LDS SI,InArray
  402.   LES DI,OutArray
  403.  
  404.   MOV CX,InArraySize
  405.   JCXZ @Done
  406.  
  407.   @Loop1:
  408.   LODSB
  409.   CMP AL,0
  410.   JE @VsePonyatno
  411.   CMP AL,4
  412.   JB @MensheTreh
  413.  
  414.   INC DX
  415.   STOSB
  416.   JMP @DoLoop
  417.  
  418.   @MensheTreh:
  419.   SUB CX,1
  420.   MOV BX,CX
  421.  
  422.   MOV CX,AX
  423.   ADD DX,AX
  424.   LODSB
  425.   REP STOSB
  426.  
  427.   MOV CX,BX
  428.   JMP @DoLoop
  429.  
  430.   @VsePonyatno:
  431.   LODSB
  432.   SUB CX,2
  433.   MOV BX,CX
  434.   MOV CX,AX
  435.   ADD DX,AX
  436.   LODSB
  437.   REP STOSB
  438.   MOV CX,BX
  439.  
  440.   @DoLoop:
  441.   JCXZ @Done
  442.   LOOP @Loop1
  443.  
  444.   @Done:
  445.   LES DI,OutArraySize
  446.   MOV[ES:DI],DX
  447.   POP DS}
  448. end;
  449.  
  450. function MSMouseInArea(x1, y1, x2, y2: Integer): Boolean;
  451. begin
  452.   Result := False;
  453. end;
  454.  
  455. function MSMouseDriverExist: Boolean;
  456. begin
  457.   Result := True;
  458. end;
  459.  
  460. procedure MSMouseGetXY(var x, y: Integer);
  461. begin
  462. end;
  463.  
  464. function MSMouseButtonStatusGet: Word;
  465. begin
  466.   Result := 0;
  467. end;
  468.  
  469. function MSMouseButtonWasPressed(Button: Word; var x, y: Integer): Boolean;
  470. begin
  471.   Result := False;
  472. end;
  473.  
  474. function MSMouseButtonWasReleased(Button: Word; var x, y: Integer): Boolean;
  475. begin
  476.   Result := False;
  477. end;
  478.  
  479. procedure MSMouseSetXY(x, y: Integer);
  480. begin
  481. end;
  482.  
  483. function GetInterrupt(Int: Byte): Pointer;
  484. begin
  485.   Result := nil;
  486. end;
  487.  
  488. procedure AssignFile(var AFile: File; AFileName: String);
  489. begin
  490.   Assign(AFile, IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0))) + AFileName);
  491. end;
  492.  
  493. function LastDosTick(): Longword;
  494. begin
  495.   Result := Round(kos_timecounter() * 0.182);
  496. end;
  497.  
  498.  
  499. end.
  500.