Subversion Repositories Kolibri OS

Rev

Rev 775 | Go to most recent revision | Details | Last modification | View Log | RSS feed

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