Subversion Repositories Kolibri OS

Rev

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

Rev Author Line No. Line
1007 bw 1
{$codepage utf8}
762 bw 2
{$mode objfpc}
3
{$asmmode intel}
4
 
1007 bw 5
unit LRLRoutines;
762 bw 6
 
1007 bw 7
 
762 bw 8
interface
9
 
10
 
775 bw 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);
762 bw 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
 
775 bw 21
function ScanToChar(Code: Word): Char;
762 bw 22
procedure KeyboardInitialize;
23
function Keypressed: Boolean;
24
function ReadKey: Word;
25
procedure KeyboardFlush;
26
 
775 bw 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
 
762 bw 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);
775 bw 52
 
762 bw 53
function GetInterrupt(Int: Byte): Pointer;
775 bw 54
procedure WaitForEvent(Timeout: DWord = 0);
762 bw 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;
1007 bw 90
  KEY_CTRL  = $1D00;
762 bw 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;
1007 bw 205
  CtrlDown   : Boolean = False;
762 bw 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
1007 bw 277
    {перенос один в один}
762 bw 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
1007 bw 289
    {масштабирование}
762 bw 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
 
775 bw 300
procedure ImagePut(var Screen, ImageBuffer; X, Y, WinX1, WinY1, WinX2, WinY2: Integer);
762 bw 301
var
775 bw 302
  Width, Height: Longint;
762 bw 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;
775 bw 317
      if X + Width - 1 > WinX2 then
318
        K := WinX2 - X - J + 1 else
319
        K := Width - J;
762 bw 320
      Move((P + J)^, (@Screen + I * BUFFER_WIDTH + X + J)^, K);
321
    end;
322
    Inc(P, Width);
323
  end;
324
end;
325
 
326
 
775 bw 327
procedure ImagePutTransparent(var Screen, ImageBuffer; X, Y, WinX1, WinY1, WinX2, WinY2: Integer);
762 bw 328
var
775 bw 329
  Width, Height: Longint;
762 bw 330
  I, J, K, L: Integer;
331
  PI, PO: PByte;
332
begin
333
  Width  := PWord(@ImageBuffer)[0];
334
  Height := PWord(@ImageBuffer)[1];
1007 bw 335
 
762 bw 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;
775 bw 345
      if X + Width - 1 > WinX2 then
346
        K := WinX2 - X - J + 1 else
347
        K := Width - J;
762 bw 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
 
1007 bw 395
  { расчет длины строки }
762 bw 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
 
1007 bw 406
  { вывод строки }
762 bw 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
 
775 bw 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
 
762 bw 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
 
1007 bw 539
  if Result = KEY_CTRL then
762 bw 540
  begin
1007 bw 541
    CtrlDown := LastKeyDown;
542
    Result   := $FFFF;
762 bw 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
 
1007 bw 559
  if CtrlDown then
762 bw 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
 
775 bw 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
 
762 bw 616
var
775 bw 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;
762 bw 627
begin
775 bw 628
  Buttons := kos_getmousebuttons();
629
 
630
  for I := 1 to MouseButtonsCount do
762 bw 631
  begin
775 bw 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]);
762 bw 638
  end;
1007 bw 639
 
775 bw 640
  MouseButtonsState := Buttons;
762 bw 641
end;
642
 
775 bw 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;
762 bw 655
 
775 bw 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
 
762 bw 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
 
775 bw 936
function GetInterrupt(Int: Byte): Pointer;
762 bw 937
begin
775 bw 938
  Result := nil;
762 bw 939
end;
940
 
941
 
775 bw 942
procedure WaitForEvent(Timeout: DWord = 0);
943
var
944
  Event: Word;
762 bw 945
begin
775 bw 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;
762 bw 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
 
775 bw 961
 
762 bw 962
function LastDosTick(): Longword;
963
begin
964
  Result := Round(kos_timecounter() * 0.182);
965
end;
966
 
967
 
968
end.