mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-15 23:59:30 +02:00
+ added required units to compile IDE
they're a total mess ATM, under fixing/cleanup, but IDE start up at least git-svn-id: trunk@6086 -
This commit is contained in:
Károly Balogh
parent
90a6bdcdd4
commit
7f0f0d4287
4
.gitattributes
vendored
4
.gitattributes
vendored
@ -4769,7 +4769,10 @@ rtl/morphos/graphics.pas svneol=native#text/plain
|
||||
rtl/morphos/hardware.pas svneol=native#text/plain
|
||||
rtl/morphos/inputevent.pas svneol=native#text/plain
|
||||
rtl/morphos/intuition.pas svneol=native#text/plain
|
||||
rtl/morphos/keyboard.pp svneol=native#text/plain
|
||||
rtl/morphos/kvm.pp svneol=native#text/plain
|
||||
rtl/morphos/layers.pas svneol=native#text/plain
|
||||
rtl/morphos/mouse.pp svneol=native#text/plain
|
||||
rtl/morphos/mui.pas -text
|
||||
rtl/morphos/muihelper.pas -text
|
||||
rtl/morphos/prt0.as -text
|
||||
@ -4791,6 +4794,7 @@ rtl/morphos/utild2.inc svneol=native#text/plain
|
||||
rtl/morphos/utilf.inc svneol=native#text/plain
|
||||
rtl/morphos/utility.pp svneol=native#text/plain
|
||||
rtl/morphos/varutils.pp svneol=native#text/plain
|
||||
rtl/morphos/video.pp svneol=native#text/plain
|
||||
rtl/nds/Makefile svneol=native#text/plain
|
||||
rtl/nds/Makefile.fpc -text
|
||||
rtl/nds/classes.pp -text
|
||||
|
||||
@ -14,8 +14,10 @@ units=$(SYSTEMUNIT) objpas macpas strings \
|
||||
variants types rtlconsts sysconst dateutil objects \
|
||||
exec timer doslib utility hardware inputevent graphics layers \
|
||||
intuition aboxlib mui \
|
||||
# these units are here, because they depend on system interface units above
|
||||
kvm video keyboard mouse \
|
||||
# these can be moved to packages later
|
||||
clipboard datatypes asl ahi tinygl get9 muihelper \
|
||||
clipboard datatypes asl ahi tinygl get9 muihelper
|
||||
rsts=math rtlconsts varutils typinfo variants classes sysconst dateutil
|
||||
|
||||
[require]
|
||||
@ -222,3 +224,15 @@ tinygl$(PPUEXT): tinygl.pp exec$(PPUEXT)
|
||||
get9$(PPUEXT): get9.pas exec$(PPUEXT)
|
||||
|
||||
muihelper$(PPUEXT): muihelper.pas intuition$(PPUEXT) mui$(PPUEXT) doslib$(PPUEXT) utility$(PPUEXT)
|
||||
|
||||
|
||||
kvm$(PPUEXT) : kvm.pp
|
||||
|
||||
video$(PPUEXT) : video.pp
|
||||
#windows$(PPUEXT) dos$(PPUEXT)
|
||||
|
||||
mouse$(PPUEXT) : mouse.pp
|
||||
#windows$(PPUEXT) dos$(PPUEXT) winevent$(PPUEXT)
|
||||
|
||||
keyboard$(PPUEXT) : keyboard.pp
|
||||
#windows$(PPUEXT) dos$(PPUEXT) winevent$(PPUEXT)
|
||||
|
||||
998
rtl/morphos/keyboard.pp
Normal file
998
rtl/morphos/keyboard.pp
Normal file
@ -0,0 +1,998 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by Florian Klaempfl
|
||||
member of the Free Pascal development team
|
||||
|
||||
Keyboard unit for Win32
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
unit Keyboard;
|
||||
interface
|
||||
{$ifdef DEBUG}
|
||||
//uses
|
||||
// windows;
|
||||
|
||||
//var
|
||||
// last_ir : Input_Record;
|
||||
{$endif DEBUG}
|
||||
|
||||
{$i keybrdh.inc}
|
||||
|
||||
implementation
|
||||
|
||||
{ WARNING: Keyboard-Drivers (i.e. german) will only work under WinNT.
|
||||
95 and 98 do not support keyboard-drivers other than us for win32
|
||||
console-apps. So we always get the keys in us-keyboard layout
|
||||
from Win9x.
|
||||
}
|
||||
|
||||
//uses
|
||||
{ifndef DEBUG}
|
||||
// Windows,
|
||||
{endif DEBUG}
|
||||
// Dos,
|
||||
// WinEvent;
|
||||
uses
|
||||
video,
|
||||
exec,intuition;
|
||||
|
||||
{$i keyboard.inc}
|
||||
|
||||
{*
|
||||
const MaxQueueSize = 120;
|
||||
FrenchKeyboard = $040C040C;
|
||||
|
||||
var
|
||||
keyboardeventqueue : array[0..maxqueuesize] of TKeyEventRecord;
|
||||
nextkeyevent,nextfreekeyevent : longint;
|
||||
newKeyEvent : THandle; {sinaled if key is available}
|
||||
lockVar : TCriticalSection; {for queue access}
|
||||
lastShiftState : byte; {set by handler for PollShiftStateEvent}
|
||||
altNumActive : boolean; {for alt+0..9}
|
||||
altNumBuffer : string [3];
|
||||
{ used for keyboard specific stuff }
|
||||
KeyBoardLayout : HKL;
|
||||
Inited : Boolean;
|
||||
HasAltGr : Boolean = false;
|
||||
|
||||
|
||||
|
||||
procedure incqueueindex(var l : longint);
|
||||
|
||||
begin
|
||||
inc(l);
|
||||
{ wrap around? }
|
||||
if l>maxqueuesize then
|
||||
l:=0;
|
||||
end;
|
||||
|
||||
function keyEventsInQueue : boolean;
|
||||
begin
|
||||
keyEventsInQueue := (nextkeyevent <> nextfreekeyevent);
|
||||
end;
|
||||
|
||||
function rightistruealt(dw:cardinal):boolean; // inline ?
|
||||
// used to wrap checks for right alt/altgr.
|
||||
begin
|
||||
rightistruealt:=true;
|
||||
if hasaltgr then
|
||||
rightistruealt:=(dw and RIGHT_ALT_PRESSED)=0;
|
||||
end;
|
||||
|
||||
|
||||
{ gets or peeks the next key from the queue, does not wait for new keys }
|
||||
function getKeyEventFromQueue (VAR t : TKeyEventRecord; Peek : boolean) : boolean;
|
||||
begin
|
||||
if not Inited then
|
||||
begin
|
||||
getKeyEventFromQueue := false;
|
||||
exit;
|
||||
end;
|
||||
EnterCriticalSection (lockVar);
|
||||
if keyEventsInQueue then
|
||||
begin
|
||||
t := keyboardeventqueue[nextkeyevent];
|
||||
if not peek then incqueueindex (nextkeyevent);
|
||||
getKeyEventFromQueue := true;
|
||||
if not keyEventsInQueue then ResetEvent (newKeyEvent);
|
||||
end else
|
||||
begin
|
||||
getKeyEventFromQueue := false;
|
||||
ResetEvent (newKeyEvent);
|
||||
end;
|
||||
LeaveCriticalSection (lockVar);
|
||||
end;
|
||||
|
||||
|
||||
{ gets the next key from the queue, does wait for new keys }
|
||||
function getKeyEventFromQueueWait (VAR t : TKeyEventRecord) : boolean;
|
||||
begin
|
||||
if not Inited then
|
||||
begin
|
||||
getKeyEventFromQueueWait := false;
|
||||
exit;
|
||||
end;
|
||||
WaitForSingleObject (newKeyEvent, dword(INFINITE));
|
||||
getKeyEventFromQueueWait := getKeyEventFromQueue (t, false);
|
||||
end;
|
||||
|
||||
{ translate win32 shift-state to keyboard shift state }
|
||||
function transShiftState (ControlKeyState : dword) : byte;
|
||||
var b : byte;
|
||||
begin
|
||||
b := 0;
|
||||
if ControlKeyState and SHIFT_PRESSED <> 0 then { win32 makes no difference between left and right shift }
|
||||
b := b or kbShift;
|
||||
if (ControlKeyState and LEFT_CTRL_PRESSED <> 0) or
|
||||
(ControlKeyState and RIGHT_CTRL_PRESSED <> 0) then
|
||||
b := b or kbCtrl;
|
||||
if (ControlKeyState and LEFT_ALT_PRESSED <> 0) or
|
||||
(ControlKeyState and RIGHT_ALT_PRESSED <> 0) then
|
||||
b := b or kbAlt;
|
||||
transShiftState := b;
|
||||
end;
|
||||
|
||||
{ The event-Handler thread from the unit event will call us if a key-event
|
||||
is available }
|
||||
|
||||
procedure HandleKeyboard(var ir:INPUT_RECORD);
|
||||
var
|
||||
i : longint;
|
||||
c : word;
|
||||
altc : char;
|
||||
addThis: boolean;
|
||||
begin
|
||||
with ir.Event.KeyEvent do
|
||||
begin
|
||||
{ key up events are ignored (except alt) }
|
||||
if bKeyDown then
|
||||
begin
|
||||
EnterCriticalSection (lockVar);
|
||||
for i:=1 to wRepeatCount do
|
||||
begin
|
||||
addThis := true;
|
||||
if (dwControlKeyState and LEFT_ALT_PRESSED <> 0) or
|
||||
(dwControlKeyState and RIGHT_ALT_PRESSED <> 0) then {alt pressed}
|
||||
if ((wVirtualKeyCode >= $60) and (wVirtualKeyCode <= $69)) or
|
||||
((dwControlKeyState and ENHANCED_KEY = 0) and
|
||||
(wVirtualKeyCode in [$C{VK_CLEAR generated by keypad 5},
|
||||
$21 {VK_PRIOR (PgUp) 9},
|
||||
$22 {VK_NEXT (PgDown) 3},
|
||||
$23 {VK_END 1},
|
||||
$24 {VK_HOME 7},
|
||||
$25 {VK_LEFT 4},
|
||||
$26 {VK_UP 8},
|
||||
$27 {VK_RIGHT 6},
|
||||
$28 {VK_DOWN 2},
|
||||
$2D {VK_INSERT 0}])) then {0..9 on NumBlock}
|
||||
begin
|
||||
if length (altNumBuffer) = 3 then
|
||||
delete (altNumBuffer,1,1);
|
||||
case wVirtualKeyCode of
|
||||
$60..$69 : altc:=char (wVirtualKeyCode-48);
|
||||
$c : altc:='5';
|
||||
$21 : altc:='9';
|
||||
$22 : altc:='3';
|
||||
$23 : altc:='1';
|
||||
$24 : altc:='7';
|
||||
$25 : altc:='4';
|
||||
$26 : altc:='8';
|
||||
$27 : altc:='6';
|
||||
$28 : altc:='2';
|
||||
$2D : altc:='0';
|
||||
end;
|
||||
altNumBuffer := altNumBuffer + altc;
|
||||
altNumActive := true;
|
||||
addThis := false;
|
||||
end else
|
||||
begin
|
||||
altNumActive := false;
|
||||
altNumBuffer := '';
|
||||
end;
|
||||
if addThis then
|
||||
begin
|
||||
keyboardeventqueue[nextfreekeyevent]:=
|
||||
ir.Event.KeyEvent;
|
||||
incqueueindex(nextfreekeyevent);
|
||||
end;
|
||||
end;
|
||||
|
||||
lastShiftState := transShiftState (dwControlKeyState); {save it for PollShiftStateEvent}
|
||||
SetEvent (newKeyEvent); {event that a new key is available}
|
||||
LeaveCriticalSection (lockVar);
|
||||
end
|
||||
else
|
||||
begin
|
||||
lastShiftState := transShiftState (dwControlKeyState); {save it for PollShiftStateEvent}
|
||||
{for alt-number we have to look for alt-key release}
|
||||
if altNumActive then
|
||||
begin
|
||||
if (wVirtualKeyCode = $12) then {alt-released}
|
||||
begin
|
||||
if altNumBuffer <> '' then {numbers with alt pressed?}
|
||||
begin
|
||||
Val (altNumBuffer, c, i);
|
||||
if (i = 0) and (c <= 255) then {valid number?}
|
||||
begin {add to queue}
|
||||
fillchar (ir, sizeof (ir), 0);
|
||||
bKeyDown := true;
|
||||
AsciiChar := char (c);
|
||||
{and add to queue}
|
||||
EnterCriticalSection (lockVar);
|
||||
keyboardeventqueue[nextfreekeyevent]:=ir.Event.KeyEvent;
|
||||
incqueueindex(nextfreekeyevent);
|
||||
SetEvent (newKeyEvent); {event that a new key is available}
|
||||
LeaveCriticalSection (lockVar);
|
||||
end;
|
||||
end;
|
||||
altNumActive := false; {clear alt-buffer}
|
||||
altNumBuffer := '';
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
*}
|
||||
|
||||
{*
|
||||
procedure CheckAltGr;
|
||||
|
||||
var ahkl : HKL;
|
||||
i : integer;
|
||||
|
||||
begin
|
||||
HasAltGr:=false;
|
||||
|
||||
ahkl:=GetKeyboardLayout(0);
|
||||
i:=$20;
|
||||
while i<$100 do
|
||||
begin
|
||||
// <MSDN>
|
||||
// For keyboard layouts that use the right-hand ALT key as ashift key
|
||||
// (for example, the French keyboard layout), the shift state is
|
||||
// represented by the value 6, because the right-hand ALT key is
|
||||
// converted internally into CTRL+ALT.
|
||||
// </MSDN>
|
||||
if (HIBYTE(VkKeyScanEx(chr(i),ahkl))=6) then
|
||||
begin
|
||||
HasAltGr:=true;
|
||||
break;
|
||||
end;
|
||||
inc(i);
|
||||
end;
|
||||
end;
|
||||
*}
|
||||
|
||||
|
||||
|
||||
procedure SysInitKeyboard;
|
||||
begin
|
||||
writeln('sysinitkeyboard');
|
||||
{*
|
||||
KeyBoardLayout:=GetKeyboardLayout(0);
|
||||
lastShiftState := 0;
|
||||
FlushConsoleInputBuffer(StdInputHandle);
|
||||
newKeyEvent := CreateEvent (nil, // address of security attributes
|
||||
true, // flag for manual-reset event
|
||||
false, // flag for initial state
|
||||
nil); // address of event-object name
|
||||
if newKeyEvent = INVALID_HANDLE_VALUE then
|
||||
begin
|
||||
// what to do here ????
|
||||
RunError (217);
|
||||
end;
|
||||
InitializeCriticalSection (lockVar);
|
||||
altNumActive := false;
|
||||
altNumBuffer := '';
|
||||
|
||||
nextkeyevent:=0;
|
||||
nextfreekeyevent:=0;
|
||||
checkaltgr;
|
||||
SetKeyboardEventHandler (@HandleKeyboard);
|
||||
Inited:=true;
|
||||
*}
|
||||
end;
|
||||
|
||||
procedure SysDoneKeyboard;
|
||||
begin
|
||||
{*
|
||||
SetKeyboardEventHandler(nil); {hangs???}
|
||||
DeleteCriticalSection (lockVar);
|
||||
FlushConsoleInputBuffer(StdInputHandle);
|
||||
closeHandle (newKeyEvent);
|
||||
Inited:=false;
|
||||
*}
|
||||
end;
|
||||
|
||||
{$define USEKEYCODES}
|
||||
|
||||
{Translatetable Win32 -> Dos for Special Keys = Function Key, Cursor Keys
|
||||
and Keys other than numbers on numblock (to make fv happy) }
|
||||
{combinations under dos: Shift+Ctrl: same as Ctrl
|
||||
Shift+Alt : same as alt
|
||||
|
||||
{* Ctrl+Alt : nothing (here we get it like alt)}
|
||||
{ifdef USEKEYCODES}
|
||||
{ use positive values for ScanCode we want to set
|
||||
0 for key where we should leave the scancode
|
||||
-1 for OEM specifc keys
|
||||
-2 for unassigned
|
||||
-3 for Kanji systems ???
|
||||
}
|
||||
|
||||
const
|
||||
Unassigned = -2;
|
||||
Kanji = -3;
|
||||
OEM_specific = -1;
|
||||
KeyToQwertyScan : array [0..255] of integer =
|
||||
(
|
||||
{ 00 } 0,
|
||||
{ 01 VK_LBUTTON } 0,
|
||||
{ 02 VK_RBUTTON } 0,
|
||||
{ 03 VK_CANCEL } 0,
|
||||
{ 04 VK_MBUTTON } 0,
|
||||
{ 05 unassigned } -2,
|
||||
{ 06 unassigned } -2,
|
||||
{ 07 unassigned } -2,
|
||||
{ 08 VK_BACK } $E,
|
||||
{ 09 VK_TAB } $F,
|
||||
{ 0A unassigned } -2,
|
||||
{ 0B unassigned } -2,
|
||||
{ 0C VK_CLEAR ?? } 0,
|
||||
{ 0D VK_RETURN } 0,
|
||||
{ 0E unassigned } -2,
|
||||
{ 0F unassigned } -2,
|
||||
{ 10 VK_SHIFT } 0,
|
||||
{ 11 VK_CONTROL } 0,
|
||||
{ 12 VK_MENU (Alt key) } 0,
|
||||
{ 13 VK_PAUSE } 0,
|
||||
{ 14 VK_CAPITAL (Caps Lock) } 0,
|
||||
{ 15 Reserved for Kanji systems} -3,
|
||||
{ 16 Reserved for Kanji systems} -3,
|
||||
{ 17 Reserved for Kanji systems} -3,
|
||||
{ 18 Reserved for Kanji systems} -3,
|
||||
{ 19 Reserved for Kanji systems} -3,
|
||||
{ 1A unassigned } -2,
|
||||
{ 1B VK_ESCAPE } $1,
|
||||
{ 1C Reserved for Kanji systems} -3,
|
||||
{ 1D Reserved for Kanji systems} -3,
|
||||
{ 1E Reserved for Kanji systems} -3,
|
||||
{ 1F Reserved for Kanji systems} -3,
|
||||
{ 20 VK_SPACE} 0,
|
||||
{ 21 VK_PRIOR (PgUp) } 0,
|
||||
{ 22 VK_NEXT (PgDown) } 0,
|
||||
{ 23 VK_END } 0,
|
||||
{ 24 VK_HOME } 0,
|
||||
{ 25 VK_LEFT } 0,
|
||||
{ 26 VK_UP } 0,
|
||||
{ 27 VK_RIGHT } 0,
|
||||
{ 28 VK_DOWN } 0,
|
||||
{ 29 VK_SELECT ??? } 0,
|
||||
{ 2A OEM specific !! } -1,
|
||||
{ 2B VK_EXECUTE } 0,
|
||||
{ 2C VK_SNAPSHOT } 0,
|
||||
{ 2D VK_INSERT } 0,
|
||||
{ 2E VK_DELETE } 0,
|
||||
{ 2F VK_HELP } 0,
|
||||
{ 30 VK_0 '0' } 11,
|
||||
{ 31 VK_1 '1' } 2,
|
||||
{ 32 VK_2 '2' } 3,
|
||||
{ 33 VK_3 '3' } 4,
|
||||
{ 34 VK_4 '4' } 5,
|
||||
{ 35 VK_5 '5' } 6,
|
||||
{ 36 VK_6 '6' } 7,
|
||||
{ 37 VK_7 '7' } 8,
|
||||
{ 38 VK_8 '8' } 9,
|
||||
{ 39 VK_9 '9' } 10,
|
||||
{ 3A unassigned } -2,
|
||||
{ 3B unassigned } -2,
|
||||
{ 3C unassigned } -2,
|
||||
{ 3D unassigned } -2,
|
||||
{ 3E unassigned } -2,
|
||||
{ 3F unassigned } -2,
|
||||
{ 40 unassigned } -2,
|
||||
{ 41 VK_A 'A' } $1E,
|
||||
{ 42 VK_B 'B' } $30,
|
||||
{ 43 VK_C 'C' } $2E,
|
||||
{ 44 VK_D 'D' } $20,
|
||||
{ 45 VK_E 'E' } $12,
|
||||
{ 46 VK_F 'F' } $21,
|
||||
{ 47 VK_G 'G' } $22,
|
||||
{ 48 VK_H 'H' } $23,
|
||||
{ 49 VK_I 'I' } $17,
|
||||
{ 4A VK_J 'J' } $24,
|
||||
{ 4B VK_K 'K' } $25,
|
||||
{ 4C VK_L 'L' } $26,
|
||||
{ 4D VK_M 'M' } $32,
|
||||
{ 4E VK_N 'N' } $31,
|
||||
{ 4F VK_O 'O' } $18,
|
||||
{ 50 VK_P 'P' } $19,
|
||||
{ 51 VK_Q 'Q' } $10,
|
||||
{ 52 VK_R 'R' } $13,
|
||||
{ 53 VK_S 'S' } $1F,
|
||||
{ 54 VK_T 'T' } $14,
|
||||
{ 55 VK_U 'U' } $16,
|
||||
{ 56 VK_V 'V' } $2F,
|
||||
{ 57 VK_W 'W' } $11,
|
||||
{ 58 VK_X 'X' } $2D,
|
||||
{ 59 VK_Y 'Y' } $15,
|
||||
{ 5A VK_Z 'Z' } $2C,
|
||||
{ 5B unassigned } -2,
|
||||
{ 5C unassigned } -2,
|
||||
{ 5D unassigned } -2,
|
||||
{ 5E unassigned } -2,
|
||||
{ 5F unassigned } -2,
|
||||
{ 60 VK_NUMPAD0 NumKeyPad '0' } 11,
|
||||
{ 61 VK_NUMPAD1 NumKeyPad '1' } 2,
|
||||
{ 62 VK_NUMPAD2 NumKeyPad '2' } 3,
|
||||
{ 63 VK_NUMPAD3 NumKeyPad '3' } 4,
|
||||
{ 64 VK_NUMPAD4 NumKeyPad '4' } 5,
|
||||
{ 65 VK_NUMPAD5 NumKeyPad '5' } 6,
|
||||
{ 66 VK_NUMPAD6 NumKeyPad '6' } 7,
|
||||
{ 67 VK_NUMPAD7 NumKeyPad '7' } 8,
|
||||
{ 68 VK_NUMPAD8 NumKeyPad '8' } 9,
|
||||
{ 69 VK_NUMPAD9 NumKeyPad '9' } 10,
|
||||
{ 6A VK_MULTIPLY } 0,
|
||||
{ 6B VK_ADD } 0,
|
||||
{ 6C VK_SEPARATOR } 0,
|
||||
{ 6D VK_SUBSTRACT } 0,
|
||||
{ 6E VK_DECIMAL } 0,
|
||||
{ 6F VK_DIVIDE } 0,
|
||||
{ 70 VK_F1 'F1' } $3B,
|
||||
{ 71 VK_F2 'F2' } $3C,
|
||||
{ 72 VK_F3 'F3' } $3D,
|
||||
{ 73 VK_F4 'F4' } $3E,
|
||||
{ 74 VK_F5 'F5' } $3F,
|
||||
{ 75 VK_F6 'F6' } $40,
|
||||
{ 76 VK_F7 'F7' } $41,
|
||||
{ 77 VK_F8 'F8' } $42,
|
||||
{ 78 VK_F9 'F9' } $43,
|
||||
{ 79 VK_F10 'F10' } $44,
|
||||
{ 7A VK_F11 'F11' } $57,
|
||||
{ 7B VK_F12 'F12' } $58,
|
||||
{ 7C VK_F13 } 0,
|
||||
{ 7D VK_F14 } 0,
|
||||
{ 7E VK_F15 } 0,
|
||||
{ 7F VK_F16 } 0,
|
||||
{ 80 VK_F17 } 0,
|
||||
{ 81 VK_F18 } 0,
|
||||
{ 82 VK_F19 } 0,
|
||||
{ 83 VK_F20 } 0,
|
||||
{ 84 VK_F21 } 0,
|
||||
{ 85 VK_F22 } 0,
|
||||
{ 86 VK_F23 } 0,
|
||||
{ 87 VK_F24 } 0,
|
||||
{ 88 unassigned } -2,
|
||||
{ 89 VK_NUMLOCK } 0,
|
||||
{ 8A VK_SCROLL } 0,
|
||||
{ 8B unassigned } -2,
|
||||
{ 8C unassigned } -2,
|
||||
{ 8D unassigned } -2,
|
||||
{ 8E unassigned } -2,
|
||||
{ 8F unassigned } -2,
|
||||
{ 90 unassigned } -2,
|
||||
{ 91 unassigned } -2,
|
||||
{ 92 unassigned } -2,
|
||||
{ 93 unassigned } -2,
|
||||
{ 94 unassigned } -2,
|
||||
{ 95 unassigned } -2,
|
||||
{ 96 unassigned } -2,
|
||||
{ 97 unassigned } -2,
|
||||
{ 98 unassigned } -2,
|
||||
{ 99 unassigned } -2,
|
||||
{ 9A unassigned } -2,
|
||||
{ 9B unassigned } -2,
|
||||
{ 9C unassigned } -2,
|
||||
{ 9D unassigned } -2,
|
||||
{ 9E unassigned } -2,
|
||||
{ 9F unassigned } -2,
|
||||
{ A0 unassigned } -2,
|
||||
{ A1 unassigned } -2,
|
||||
{ A2 unassigned } -2,
|
||||
{ A3 unassigned } -2,
|
||||
{ A4 unassigned } -2,
|
||||
{ A5 unassigned } -2,
|
||||
{ A6 unassigned } -2,
|
||||
{ A7 unassigned } -2,
|
||||
{ A8 unassigned } -2,
|
||||
{ A9 unassigned } -2,
|
||||
{ AA unassigned } -2,
|
||||
{ AB unassigned } -2,
|
||||
{ AC unassigned } -2,
|
||||
{ AD unassigned } -2,
|
||||
{ AE unassigned } -2,
|
||||
{ AF unassigned } -2,
|
||||
{ B0 unassigned } -2,
|
||||
{ B1 unassigned } -2,
|
||||
{ B2 unassigned } -2,
|
||||
{ B3 unassigned } -2,
|
||||
{ B4 unassigned } -2,
|
||||
{ B5 unassigned } -2,
|
||||
{ B6 unassigned } -2,
|
||||
{ B7 unassigned } -2,
|
||||
{ B8 unassigned } -2,
|
||||
{ B9 unassigned } -2,
|
||||
{ BA OEM specific } 0,
|
||||
{ BB OEM specific } 0,
|
||||
{ BC OEM specific } 0,
|
||||
{ BD OEM specific } 0,
|
||||
{ BE OEM specific } 0,
|
||||
{ BF OEM specific } 0,
|
||||
{ C0 OEM specific } 0,
|
||||
{ C1 unassigned } -2,
|
||||
{ C2 unassigned } -2,
|
||||
{ C3 unassigned } -2,
|
||||
{ C4 unassigned } -2,
|
||||
{ C5 unassigned } -2,
|
||||
{ C6 unassigned } -2,
|
||||
{ C7 unassigned } -2,
|
||||
{ C8 unassigned } -2,
|
||||
{ C9 unassigned } -2,
|
||||
{ CA unassigned } -2,
|
||||
{ CB unassigned } -2,
|
||||
{ CC unassigned } -2,
|
||||
{ CD unassigned } -2,
|
||||
{ CE unassigned } -2,
|
||||
{ CF unassigned } -2,
|
||||
{ D0 unassigned } -2,
|
||||
{ D1 unassigned } -2,
|
||||
{ D2 unassigned } -2,
|
||||
{ D3 unassigned } -2,
|
||||
{ D4 unassigned } -2,
|
||||
{ D5 unassigned } -2,
|
||||
{ D6 unassigned } -2,
|
||||
{ D7 unassigned } -2,
|
||||
{ D8 unassigned } -2,
|
||||
{ D9 unassigned } -2,
|
||||
{ DA unassigned } -2,
|
||||
{ DB OEM specific } 0,
|
||||
{ DC OEM specific } 0,
|
||||
{ DD OEM specific } 0,
|
||||
{ DE OEM specific } 0,
|
||||
{ DF OEM specific } 0,
|
||||
{ E0 OEM specific } 0,
|
||||
{ E1 OEM specific } 0,
|
||||
{ E2 OEM specific } 0,
|
||||
{ E3 OEM specific } 0,
|
||||
{ E4 OEM specific } 0,
|
||||
{ E5 unassigned } -2,
|
||||
{ E6 OEM specific } 0,
|
||||
{ E7 unassigned } -2,
|
||||
{ E8 unassigned } -2,
|
||||
{ E9 OEM specific } 0,
|
||||
{ EA OEM specific } 0,
|
||||
{ EB OEM specific } 0,
|
||||
{ EC OEM specific } 0,
|
||||
{ ED OEM specific } 0,
|
||||
{ EE OEM specific } 0,
|
||||
{ EF OEM specific } 0,
|
||||
{ F0 OEM specific } 0,
|
||||
{ F1 OEM specific } 0,
|
||||
{ F2 OEM specific } 0,
|
||||
{ F3 OEM specific } 0,
|
||||
{ F4 OEM specific } 0,
|
||||
{ F5 OEM specific } 0,
|
||||
{ F6 unassigned } -2,
|
||||
{ F7 unassigned } -2,
|
||||
{ F8 unassigned } -2,
|
||||
{ F9 unassigned } -2,
|
||||
{ FA unassigned } -2,
|
||||
{ FB unassigned } -2,
|
||||
{ FC unassigned } -2,
|
||||
{ FD unassigned } -2,
|
||||
{ FE unassigned } -2,
|
||||
{ FF unassigned } -2
|
||||
);
|
||||
{$endif USEKEYCODES}
|
||||
type TTEntryT = packed record
|
||||
n,s,c,a : byte; {normal,shift, ctrl, alt, normal only for f11,f12}
|
||||
end;
|
||||
*}
|
||||
{*
|
||||
CONST
|
||||
DosTT : ARRAY [$3B..$58] OF TTEntryT =
|
||||
((n : $3B; s : $54; c : $5E; a: $68), {3B F1}
|
||||
(n : $3C; s : $55; c : $5F; a: $69), {3C F2}
|
||||
(n : $3D; s : $56; c : $60; a: $6A), {3D F3}
|
||||
(n : $3E; s : $57; c : $61; a: $6B), {3E F4}
|
||||
(n : $3F; s : $58; c : $62; a: $6C), {3F F5}
|
||||
(n : $40; s : $59; c : $63; a: $6D), {40 F6}
|
||||
(n : $41; s : $5A; c : $64; a: $6E), {41 F7}
|
||||
(n : $42; s : $5B; c : $65; a: $6F), {42 F8}
|
||||
(n : $43; s : $5C; c : $66; a: $70), {43 F9}
|
||||
(n : $44; s : $5D; c : $67; a: $71), {44 F10}
|
||||
(n : $45; s : $00; c : $00; a: $00), {45 ???}
|
||||
(n : $46; s : $00; c : $00; a: $00), {46 ???}
|
||||
(n : $47; s : $47; c : $77; a: $97), {47 Home}
|
||||
(n : $48; s : $00; c : $8D; a: $98), {48 Up}
|
||||
(n : $49; s : $49; c : $84; a: $99), {49 PgUp}
|
||||
(n : $4A; s : $00; c : $8E; a: $4A), {4A -}
|
||||
(n : $4B; s : $4B; c : $73; a: $9B), {4B Left}
|
||||
(n : $4C; s : $00; c : $00; a: $00), {4C ???}
|
||||
(n : $4D; s : $4D; c : $74; a: $9D), {4D Right}
|
||||
(n : $4E; s : $00; c : $90; a: $4E), {4E +}
|
||||
(n : $4F; s : $4F; c : $75; a: $9F), {4F End}
|
||||
(n : $50; s : $50; c : $91; a: $A0), {50 Down}
|
||||
(n : $51; s : $51; c : $76; a: $A1), {51 PgDown}
|
||||
(n : $52; s : $52; c : $92; a: $A2), {52 Insert}
|
||||
(n : $53; s : $53; c : $93; a: $A3), {53 Del}
|
||||
(n : $54; s : $00; c : $00; a: $00), {54 ???}
|
||||
(n : $55; s : $00; c : $00; a: $00), {55 ???}
|
||||
(n : $56; s : $00; c : $00; a: $00), {56 ???}
|
||||
(n : $85; s : $87; c : $89; a: $8B), {57 F11}
|
||||
(n : $86; s : $88; c : $8A; a: $8C)); {58 F12}
|
||||
|
||||
DosTT09 : ARRAY [$02..$0F] OF TTEntryT =
|
||||
((n : $00; s : $00; c : $00; a: $78), {02 1 }
|
||||
(n : $00; s : $00; c : $00; a: $79), {03 2 }
|
||||
(n : $00; s : $00; c : $00; a: $7A), {04 3 }
|
||||
(n : $00; s : $00; c : $00; a: $7B), {05 4 }
|
||||
(n : $00; s : $00; c : $00; a: $7C), {06 5 }
|
||||
(n : $00; s : $00; c : $00; a: $7D), {07 6 }
|
||||
(n : $00; s : $00; c : $00; a: $7E), {08 7 }
|
||||
(n : $00; s : $00; c : $00; a: $7F), {09 8 }
|
||||
(n : $00; s : $00; c : $00; a: $80), {0A 9 }
|
||||
(n : $00; s : $00; c : $00; a: $81), {0B 0 }
|
||||
(n : $00; s : $00; c : $00; a: $82), {0C ß }
|
||||
(n : $00; s : $00; c : $00; a: $00), {0D}
|
||||
(n : $00; s : $09; c : $00; a: $00), {0E Backspace}
|
||||
(n : $00; s : $0F; c : $94; a: $00)); {0F Tab }
|
||||
|
||||
*}
|
||||
|
||||
{*
|
||||
function TranslateKey (t : TKeyEventRecord) : TKeyEvent;
|
||||
var key : TKeyEvent;
|
||||
ss : byte;
|
||||
{$ifdef USEKEYCODES}
|
||||
ScanCode : byte;
|
||||
{$endif USEKEYCODES}
|
||||
b : byte;
|
||||
begin
|
||||
Key := 0;
|
||||
if t.bKeyDown then
|
||||
begin
|
||||
{ ascii-char is <> 0 if not a specal key }
|
||||
{ we return it here otherwise we have to translate more later }
|
||||
if t.AsciiChar <> #0 then
|
||||
begin
|
||||
if (t.dwControlKeyState and ENHANCED_KEY <> 0) and
|
||||
(t.wVirtualKeyCode = $DF) then
|
||||
begin
|
||||
t.dwControlKeyState:=t.dwControlKeyState and not ENHANCED_KEY;
|
||||
t.wVirtualKeyCode:=VK_DIVIDE;
|
||||
t.AsciiChar:='/';
|
||||
end;
|
||||
{drivers needs scancode, we return it here as under dos and linux
|
||||
with $03000000 = the lowest two bytes is the physical representation}
|
||||
{$ifdef USEKEYCODES}
|
||||
Scancode:=KeyToQwertyScan[t.wVirtualKeyCode AND $00FF];
|
||||
If ScanCode>0 then
|
||||
t.wVirtualScanCode:=ScanCode;
|
||||
Key := byte (t.AsciiChar) + (t.wVirtualScanCode shl 8) + $03000000;
|
||||
ss := transShiftState (t.dwControlKeyState);
|
||||
key := key or (ss shl 16);
|
||||
if (ss and kbAlt <> 0) and rightistruealt(t.dwControlKeyState) then
|
||||
key := key and $FFFFFF00;
|
||||
{$else not USEKEYCODES}
|
||||
Key := byte (t.AsciiChar) + ((t.wVirtualScanCode AND $00FF) shl 8) + $03000000;
|
||||
{$endif not USEKEYCODES}
|
||||
end else
|
||||
begin
|
||||
{$ifdef USEKEYCODES}
|
||||
Scancode:=KeyToQwertyScan[t.wVirtualKeyCode AND $00FF];
|
||||
If ScanCode>0 then
|
||||
t.wVirtualScanCode:=ScanCode;
|
||||
{$endif not USEKEYCODES}
|
||||
translateKey := 0;
|
||||
{ ignore shift,ctrl,alt,numlock,capslock alone }
|
||||
case t.wVirtualKeyCode of
|
||||
$0010, {shift}
|
||||
$0011, {ctrl}
|
||||
$0012, {alt}
|
||||
$0014, {capslock}
|
||||
$0090, {numlock}
|
||||
$0091, {scrollock}
|
||||
{ This should be handled !! }
|
||||
{ these last two are OEM specific
|
||||
this is not good !!! }
|
||||
$00DC, {^ : next key i.e. a is modified }
|
||||
{ Strange on my keyboard this corresponds to double point over i or u PM }
|
||||
$00DD: exit; {´ and ` : next key i.e. e is modified }
|
||||
end;
|
||||
|
||||
key := $03000000 + (t.wVirtualScanCode shl 8); { make lower 8 bit=0 like under dos }
|
||||
end;
|
||||
{ Handling of ~ key as AltGr 2 }
|
||||
{ This is also French keyboard specific !! }
|
||||
{ but without this I can not get a ~ !! PM }
|
||||
{ MvdV: not rightruealtised, since it already has frenchkbd guard}
|
||||
if (t.wVirtualKeyCode=$32) and
|
||||
(KeyBoardLayout = FrenchKeyboard) and
|
||||
(t.dwControlKeyState and RIGHT_ALT_PRESSED <> 0) then
|
||||
key:=(key and $ffffff00) or ord('~');
|
||||
{ ok, now add Shift-State }
|
||||
ss := transShiftState (t.dwControlKeyState);
|
||||
key := key or (ss shl 16);
|
||||
|
||||
{ Reset Ascii-Char if Alt+Key, fv needs that, may be we
|
||||
need it for other special keys too
|
||||
18 Sept 1999 AD: not for right Alt i.e. for AltGr+ß = \ on german keyboard }
|
||||
if ((ss and kbAlt <> 0) and rightistruealt(t.dwControlKeyState)) or
|
||||
(*
|
||||
{ yes, we need it for cursor keys, 25=left, 26=up, 27=right,28=down}
|
||||
{aggg, this will not work because esc is also virtualKeyCode 27!!}
|
||||
{if (t.wVirtualKeyCode >= 25) and (t.wVirtualKeyCode <= 28) then}
|
||||
no VK_ESCAPE is $1B !!
|
||||
there was a mistake :
|
||||
VK_LEFT is $25 not 25 !! *)
|
||||
{ not $2E VK_DELETE because its only the Keypad point !! PM }
|
||||
(t.wVirtualKeyCode in [$21..$28,$2C,$2D,$2F]) then
|
||||
{ if t.wVirtualScanCode in [$47..$49,$4b,$4d,$4f,$50..$53] then}
|
||||
key := key and $FFFFFF00;
|
||||
|
||||
{and translate to dos-scancodes to make fv happy, we will convert this
|
||||
back in translateKeyEvent}
|
||||
|
||||
if rightistruealt(t.dwControlKeyState) then {not for alt-gr}
|
||||
if (t.wVirtualScanCode >= low (DosTT)) and
|
||||
(t.wVirtualScanCode <= high (dosTT)) then
|
||||
begin
|
||||
b := 0;
|
||||
if (ss and kbAlt) <> 0 then
|
||||
b := DosTT[t.wVirtualScanCode].a
|
||||
else
|
||||
if (ss and kbCtrl) <> 0 then
|
||||
b := DosTT[t.wVirtualScanCode].c
|
||||
else
|
||||
if (ss and kbShift) <> 0 then
|
||||
b := DosTT[t.wVirtualScanCode].s
|
||||
else
|
||||
b := DosTT[t.wVirtualScanCode].n;
|
||||
if b <> 0 then
|
||||
key := (key and $FFFF00FF) or (longint (b) shl 8);
|
||||
end;
|
||||
|
||||
{Alt-0 to Alt-9}
|
||||
if rightistruealt(t.dwControlKeyState) then {not for alt-gr}
|
||||
if (t.wVirtualScanCode >= low (DosTT09)) and
|
||||
(t.wVirtualScanCode <= high (dosTT09)) then
|
||||
begin
|
||||
b := 0;
|
||||
if (ss and kbAlt) <> 0 then
|
||||
b := DosTT09[t.wVirtualScanCode].a
|
||||
else
|
||||
if (ss and kbCtrl) <> 0 then
|
||||
b := DosTT09[t.wVirtualScanCode].c
|
||||
else
|
||||
if (ss and kbShift) <> 0 then
|
||||
b := DosTT09[t.wVirtualScanCode].s
|
||||
else
|
||||
b := DosTT09[t.wVirtualScanCode].n;
|
||||
if b <> 0 then
|
||||
key := (key and $FFFF0000) or (longint (b) shl 8);
|
||||
end;
|
||||
|
||||
TranslateKey := key;
|
||||
end;
|
||||
translateKey := Key;
|
||||
end;
|
||||
*}
|
||||
|
||||
|
||||
//#define IsMsgPortEmpty(x) (((x)->mp_MsgList.lh_TailPred) == (struct Node *)(&(x)->mp_MsgList))
|
||||
|
||||
function IsMsgPortEmpty(port: PMsgPort): boolean;
|
||||
begin
|
||||
IsMsgPortEmpty:=(port^.mp_MsgList.lh_TailPred = @(port^.mp_MsgList));
|
||||
end;
|
||||
|
||||
|
||||
function SysPollKeyEvent: TKeyEvent;
|
||||
//var t : TKeyEventRecord;
|
||||
// k : TKeyEvent;
|
||||
var
|
||||
iMsg : PIntuiMessage;
|
||||
KeyCode: longint;
|
||||
begin
|
||||
KeyCode:=0;
|
||||
SysPollKeyEvent:=0;
|
||||
// writeln('keyboard/SysPollKeyEvent');
|
||||
if videoWindow<>nil then begin
|
||||
if IsMsgPortEmpty(videoWindow^.UserPort) then exit;
|
||||
end;
|
||||
PMessage(iMsg):=GetMsg(videoWindow^.UserPort);
|
||||
if (iMsg<>nil) then begin
|
||||
// writeln('got msg!');
|
||||
case (iMsg^.iClass) of
|
||||
IDCMP_VANILLAKEY: begin
|
||||
writeln('vanilla keycode: ',iMsg^.code);
|
||||
KeyCode:=iMsg^.code;
|
||||
case (iMsg^.code) of
|
||||
09: KeyCode:=$0F09; // Tab
|
||||
13: KeyCode:=$1C0D; // Enter
|
||||
27: KeyCode:=$011B; // ESC
|
||||
|
||||
127: KeyCode:=$5300; // Del
|
||||
|
||||
164: KeyCode:=$1200; // Alt-E
|
||||
215: KeyCode:=$2D00; // Alt-X
|
||||
|
||||
end;
|
||||
end;
|
||||
IDCMP_RAWKEY: begin
|
||||
writeln('raw keycode: ',iMsg^.code);
|
||||
case (iMsg^.code) of
|
||||
35: KeyCode:=$2100; // Alt-F
|
||||
|
||||
71: KeyCode:=$5200; // Ins (Alt/Shift/Ctrl codes needs processing!)
|
||||
|
||||
72: KeyCode:=$4900; // PgUP
|
||||
73: KeyCode:=$5100; // PgDOWN
|
||||
|
||||
76: KeyCode:=$4800; // UP
|
||||
77: KeyCode:=$5000; // DOWN
|
||||
78: KeyCode:=$4D00; // RIGHT
|
||||
79: KeyCode:=$4B00; // LEFT
|
||||
|
||||
80..89: KeyCode:=($3B+(iMsg^.code-80)) shl 8; // F1..F10
|
||||
|
||||
112: KeyCode:=$4700; // HOME
|
||||
113: KeyCode:=$4F00; // END
|
||||
|
||||
else
|
||||
KeyCode:=-1;
|
||||
end;
|
||||
end;
|
||||
else begin
|
||||
KeyCode:=-1;
|
||||
end;
|
||||
end;
|
||||
ReplyMsg(PMessage(iMsg));
|
||||
end;
|
||||
// end;
|
||||
|
||||
// XXX: huh :)
|
||||
if KeyCode>=0 then begin
|
||||
SysPollKeyEvent:=KeyCode or (kbPhys shl 24);
|
||||
end else begin
|
||||
SysPollKeyEvent:=0;
|
||||
end;
|
||||
{*
|
||||
SysPollKeyEvent := 0;
|
||||
if getKeyEventFromQueue (t, true) then
|
||||
begin
|
||||
{ we get an enty for shift, ctrl, alt... }
|
||||
k := translateKey (t);
|
||||
while (k = 0) do
|
||||
begin
|
||||
getKeyEventFromQueue (t, false); {remove it}
|
||||
if not getKeyEventFromQueue (t, true) then exit;
|
||||
k := translateKey (t)
|
||||
end;
|
||||
SysPollKeyEvent := k;
|
||||
end;
|
||||
*}
|
||||
end;
|
||||
|
||||
|
||||
|
||||
function SysGetKeyEvent: TKeyEvent;
|
||||
//var t : TKeyEventRecord;
|
||||
// key : TKeyEvent;
|
||||
var
|
||||
iMsg : PIntuiMessage;
|
||||
res: TKeyEvent;
|
||||
begin
|
||||
{*
|
||||
key := 0;
|
||||
repeat
|
||||
if getKeyEventFromQueueWait (t) then
|
||||
key := translateKey (t);
|
||||
until key <> 0;
|
||||
{$ifdef DEBUG}
|
||||
last_ir.Event.KeyEvent:=t;
|
||||
{$endif DEBUG}
|
||||
SysGetKeyEvent := key;
|
||||
*}
|
||||
|
||||
// writeln('keyboard/SysGetKeyEvent');
|
||||
if videoWindow<>nil then begin
|
||||
repeat
|
||||
WaitPort(videoWindow^.UserPort);
|
||||
res:=SysPollKeyEvent;
|
||||
until res<>0;
|
||||
end;
|
||||
{*
|
||||
if videoWindow<>nil then begin
|
||||
WaitPort(videoWindow^.UserPort);
|
||||
PMessage(iMsg):=GetMsg(videoWindow^.UserPort);
|
||||
if (iMsg<>nil) then begin
|
||||
writeln('got msg!');
|
||||
ReplyMsg(PMessage(iMsg));
|
||||
end;
|
||||
end;
|
||||
*}
|
||||
end;
|
||||
|
||||
|
||||
|
||||
function SysTranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent;
|
||||
begin
|
||||
{*
|
||||
if KeyEvent and $03000000 = $03000000 then
|
||||
begin
|
||||
if KeyEvent and $000000FF <> 0 then
|
||||
begin
|
||||
SysTranslateKeyEvent := KeyEvent and $00FFFFFF;
|
||||
exit;
|
||||
end;
|
||||
{translate function-keys and other specials, ascii-codes are already ok}
|
||||
case (KeyEvent AND $0000FF00) shr 8 of
|
||||
{F1..F10}
|
||||
$3B..$44 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $3B + $02000000;
|
||||
{F11,F12}
|
||||
$85..$86 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $85 + $02000000;
|
||||
{Shift F1..F10}
|
||||
$54..$5D : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $54 + $02000000;
|
||||
{Shift F11,F12}
|
||||
$87..$88 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $87 + $02000000;
|
||||
{Alt F1..F10}
|
||||
$68..$71 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $68 + $02000000;
|
||||
{Alt F11,F12}
|
||||
$8B..$8C : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $8B + $02000000;
|
||||
{Ctrl F1..F10}
|
||||
$5E..$67 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $5E + $02000000;
|
||||
{Ctrl F11,F12}
|
||||
$89..$8A : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $89 + $02000000;
|
||||
|
||||
{normal,ctrl,alt}
|
||||
$47,$77,$97 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdHome + $02000000;
|
||||
$48,$8D,$98 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdUp + $02000000;
|
||||
$49,$84,$99 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdPgUp + $02000000;
|
||||
$4b,$73,$9B : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdLeft + $02000000;
|
||||
$4d,$74,$9D : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdRight + $02000000;
|
||||
$4f,$75,$9F : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdEnd + $02000000;
|
||||
$50,$91,$A0 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdDown + $02000000;
|
||||
$51,$76,$A1 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdPgDn + $02000000;
|
||||
$52,$92,$A2 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdInsert + $02000000;
|
||||
$53,$93,$A3 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdDelete + $02000000;
|
||||
else
|
||||
SysTranslateKeyEvent := KeyEvent;
|
||||
end;
|
||||
end else
|
||||
SysTranslateKeyEvent := KeyEvent;
|
||||
*}
|
||||
end;
|
||||
|
||||
|
||||
function SysGetShiftState: Byte;
|
||||
|
||||
begin
|
||||
{may be better to save the last state and return that if no key is in buffer???}
|
||||
// SysGetShiftState:= lastShiftState;
|
||||
end;
|
||||
|
||||
Const
|
||||
SysKeyboardDriver : TKeyboardDriver = (
|
||||
InitDriver : @SysInitKeyBoard;
|
||||
DoneDriver : @SysDoneKeyBoard;
|
||||
GetKeyevent : @SysGetKeyEvent;
|
||||
PollKeyEvent : @SysPollKeyEvent;
|
||||
GetShiftState : @SysGetShiftState;
|
||||
// TranslateKeyEvent : @SysTranslateKeyEvent;
|
||||
TranslateKeyEvent : Nil;
|
||||
TranslateKeyEventUnicode : Nil;
|
||||
);
|
||||
|
||||
|
||||
begin
|
||||
SetKeyBoardDriver(SysKeyBoardDriver);
|
||||
end.
|
||||
78
rtl/morphos/kvm.pp
Normal file
78
rtl/morphos/kvm.pp
Normal file
@ -0,0 +1,78 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2006 Karoly Balogh
|
||||
member of the Free Pascal Development Team
|
||||
|
||||
Keyboard/Video/Mouse helper unit for Amiga/MorphOS
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
unit kvm;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
exec, intuition, graphics;
|
||||
|
||||
|
||||
function initKVM: boolean;
|
||||
procedure doneKVM;
|
||||
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
var
|
||||
kvmWindow: PWindow;
|
||||
|
||||
const
|
||||
DEFAULT_WINWIDTH = 80;
|
||||
DEFAULT_WINHEIGHT = 25;
|
||||
|
||||
const
|
||||
CHAR_XSIZE = 8;
|
||||
CHAR_YSIZE = 16;
|
||||
|
||||
|
||||
|
||||
|
||||
function initKVM: boolean;
|
||||
begin
|
||||
initKVM:=false;
|
||||
kvmWindow:=OpenWindowTags(nil, [
|
||||
WA_Left,50,
|
||||
WA_Top, 50,
|
||||
WA_InnerWidth, DEFAULT_WINWIDTH *CHAR_XSIZE,
|
||||
WA_InnerHeight,DEFAULT_WINHEIGHT*CHAR_YSIZE,
|
||||
WA_IDCMP, IDCMP_VANILLAKEY or IDCMP_RAWKEY,
|
||||
WA_Title,DWord(PChar('Free Pascal Video Output')),
|
||||
WA_Flags,(WFLG_GIMMEZEROZERO or
|
||||
WFLG_SMART_REFRESH or
|
||||
WFLG_NOCAREREFRESH or
|
||||
WFLG_ACTIVATE or
|
||||
WFLG_DRAGBAR or
|
||||
WFLG_DEPTHGADGET)
|
||||
]);
|
||||
|
||||
if kvmWindow<>nil then initKVM:=true;
|
||||
end;
|
||||
|
||||
|
||||
procedure doneKVM;
|
||||
begin
|
||||
if kvmWindow <> nil then CloseWindow(kvmWindow);
|
||||
end;
|
||||
|
||||
|
||||
begin
|
||||
InitGraphicsLibrary;
|
||||
InitIntuitionLibrary;
|
||||
end.
|
||||
275
rtl/morphos/mouse.pp
Normal file
275
rtl/morphos/mouse.pp
Normal file
@ -0,0 +1,275 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2006 Karoly Balogh
|
||||
member of the Free Pascal development team
|
||||
|
||||
Mouse unit for Amiga/MorphOS
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
unit Mouse;
|
||||
interface
|
||||
|
||||
{$i mouseh.inc}
|
||||
|
||||
implementation
|
||||
|
||||
//uses
|
||||
// windows,dos,Winevent;
|
||||
|
||||
{$i mouse.inc}
|
||||
|
||||
//var
|
||||
// ChangeMouseEvents : TCriticalSection;
|
||||
// LastHandlerMouseEvent : TMouseEvent;
|
||||
|
||||
{
|
||||
procedure MouseEventHandler(var ir:INPUT_RECORD);
|
||||
var
|
||||
e : TMouseEvent;
|
||||
|
||||
begin
|
||||
EnterCriticalSection(ChangeMouseEvents);
|
||||
e.x:=ir.Event.MouseEvent.dwMousePosition.x;
|
||||
e.y:=ir.Event.MouseEvent.dwMousePosition.y;
|
||||
e.buttons:=0;
|
||||
e.action:=0;
|
||||
if (ir.Event.MouseEvent.dwButtonState and FROM_LEFT_1ST_BUTTON_PRESSED<>0) then
|
||||
e.buttons:=e.buttons or MouseLeftButton;
|
||||
if (ir.Event.MouseEvent.dwButtonState and FROM_LEFT_2ND_BUTTON_PRESSED<>0) then
|
||||
e.buttons:=e.buttons or MouseMiddleButton;
|
||||
if (ir.Event.MouseEvent.dwButtonState and RIGHTMOST_BUTTON_PRESSED<>0) then
|
||||
e.buttons:=e.buttons or MouseRightButton;
|
||||
|
||||
if (Lasthandlermouseevent.x<>e.x) or (LasthandlerMouseEvent.y<>e.y) then
|
||||
e.Action:=MouseActionMove;
|
||||
if (LastHandlerMouseEvent.Buttons<>e.Buttons) then
|
||||
begin
|
||||
if (LasthandlerMouseEvent.Buttons and e.buttons<>LasthandlerMouseEvent.Buttons) then
|
||||
e.Action:=MouseActionUp
|
||||
else
|
||||
e.Action:=MouseActionDown;
|
||||
end;
|
||||
|
||||
|
||||
//
|
||||
// The mouse event compression here was flawed and could lead
|
||||
// to "zero" mouse actions if the new (x,y) was the same as the
|
||||
// previous one. (bug 2312)
|
||||
//
|
||||
|
||||
{ can we compress the events? }
|
||||
if (PendingMouseEvents>0) and
|
||||
(e.buttons=PendingMouseTail^.buttons) and
|
||||
(e.action=PendingMouseTail^.action) then
|
||||
begin
|
||||
PendingMouseTail^.x:=e.x;
|
||||
PendingMouseTail^.y:=e.y;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if e.action<>0 then
|
||||
begin
|
||||
LastHandlermouseEvent:=e;
|
||||
|
||||
{ what till there is again space in the mouse event queue }
|
||||
while PendingMouseEvents>=MouseEventBufSize do
|
||||
begin
|
||||
LeaveCriticalSection(ChangeMouseEvents);
|
||||
sleep(0);
|
||||
EnterCriticalSection(ChangeMouseEvents);
|
||||
end;
|
||||
|
||||
PutMouseEvent(e);
|
||||
end;
|
||||
// this should be done in PutMouseEvent, now it is PM
|
||||
// inc(PendingMouseEvents);
|
||||
end;
|
||||
LastMouseEvent:=e;
|
||||
LeaveCriticalSection(ChangeMouseEvents);
|
||||
end;
|
||||
}
|
||||
procedure SysInitMouse;
|
||||
|
||||
var
|
||||
mode : dword;
|
||||
|
||||
begin
|
||||
{
|
||||
// enable mouse events
|
||||
GetConsoleMode(StdInputHandle,@mode);
|
||||
mode:=mode or ENABLE_MOUSE_INPUT;
|
||||
SetConsoleMode(StdInputHandle,mode);
|
||||
|
||||
PendingMouseHead:=@PendingMouseEvent;
|
||||
PendingMouseTail:=@PendingMouseEvent;
|
||||
PendingMouseEvents:=0;
|
||||
FillChar(LastMouseEvent,sizeof(TMouseEvent),0);
|
||||
InitializeCriticalSection(ChangeMouseEvents);
|
||||
SetMouseEventHandler(@MouseEventHandler);
|
||||
ShowMouse;
|
||||
}
|
||||
end;
|
||||
|
||||
|
||||
procedure SysDoneMouse;
|
||||
var
|
||||
mode : dword;
|
||||
begin
|
||||
{
|
||||
HideMouse;
|
||||
// disable mouse events
|
||||
GetConsoleMode(StdInputHandle,@mode);
|
||||
mode:=mode and (not ENABLE_MOUSE_INPUT);
|
||||
SetConsoleMode(StdInputHandle,mode);
|
||||
|
||||
SetMouseEventHandler(nil);
|
||||
DeleteCriticalSection(ChangeMouseEvents);
|
||||
}
|
||||
end;
|
||||
|
||||
|
||||
function SysDetectMouse:byte;
|
||||
var
|
||||
num : dword;
|
||||
begin
|
||||
// Under Amiga/MorphOS, mouse is always there, and it's unable to easily
|
||||
// detect number of buttons. So lets report 3, which is common nowadays. (KB)
|
||||
SysDetectMouse:=3;
|
||||
end;
|
||||
|
||||
|
||||
procedure SysGetMouseEvent(var MouseEvent: TMouseEvent);
|
||||
|
||||
var
|
||||
b : byte;
|
||||
|
||||
begin
|
||||
{
|
||||
repeat
|
||||
EnterCriticalSection(ChangeMouseEvents);
|
||||
b:=PendingMouseEvents;
|
||||
LeaveCriticalSection(ChangeMouseEvents);
|
||||
if b>0 then
|
||||
break
|
||||
else
|
||||
sleep(50);
|
||||
until false;
|
||||
EnterCriticalSection(ChangeMouseEvents);
|
||||
MouseEvent:=PendingMouseHead^;
|
||||
inc(PendingMouseHead);
|
||||
if ptrint(PendingMouseHead)=ptrint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
|
||||
PendingMouseHead:=@PendingMouseEvent;
|
||||
dec(PendingMouseEvents);
|
||||
|
||||
{ LastMouseEvent is already set at the end of the mouse event handler,
|
||||
so this code might compare LastMouseEvent with itself leading to
|
||||
"empty" events (FK)
|
||||
|
||||
if (LastMouseEvent.x<>MouseEvent.x) or (LastMouseEvent.y<>MouseEvent.y) then
|
||||
MouseEvent.Action:=MouseActionMove;
|
||||
if (LastMouseEvent.Buttons<>MouseEvent.Buttons) then
|
||||
begin
|
||||
if (LastMouseEvent.Buttons and MouseEvent.buttons<>LastMouseEvent.Buttons) then
|
||||
MouseEvent.Action:=MouseActionUp
|
||||
else
|
||||
MouseEvent.Action:=MouseActionDown;
|
||||
end;
|
||||
if MouseEvent.action=0 then
|
||||
MousEevent.action:=MouseActionMove; // can sometimes happen due to compression of events.
|
||||
LastMouseEvent:=MouseEvent;
|
||||
}
|
||||
|
||||
LeaveCriticalSection(ChangeMouseEvents);
|
||||
}
|
||||
end;
|
||||
|
||||
|
||||
function SysPollMouseEvent(var MouseEvent: TMouseEvent):boolean;
|
||||
begin
|
||||
{
|
||||
EnterCriticalSection(ChangeMouseEvents);
|
||||
if PendingMouseEvents>0 then
|
||||
begin
|
||||
MouseEvent:=PendingMouseHead^;
|
||||
SysPollMouseEvent:=true;
|
||||
end
|
||||
else
|
||||
SysPollMouseEvent:=false;
|
||||
LeaveCriticalSection(ChangeMouseEvents);
|
||||
}
|
||||
end;
|
||||
|
||||
|
||||
procedure SysPutMouseEvent(const MouseEvent: TMouseEvent);
|
||||
begin
|
||||
{
|
||||
if PendingMouseEvents<MouseEventBufSize then
|
||||
begin
|
||||
PendingMouseTail^:=MouseEvent;
|
||||
inc(PendingMouseTail);
|
||||
if ptrint(PendingMouseTail)=ptrint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
|
||||
PendingMouseTail:=@PendingMouseEvent;
|
||||
{ why isn't this done here ?
|
||||
so the win32 version do this by hand:}
|
||||
inc(PendingMouseEvents);
|
||||
end;
|
||||
}
|
||||
end;
|
||||
|
||||
|
||||
function SysGetMouseX:word;
|
||||
begin
|
||||
{
|
||||
EnterCriticalSection(ChangeMouseEvents);
|
||||
SysGetMouseX:=LastMouseEvent.x;
|
||||
LeaveCriticalSection(ChangeMouseEvents);
|
||||
}
|
||||
end;
|
||||
|
||||
|
||||
function SysGetMouseY:word;
|
||||
begin
|
||||
{
|
||||
EnterCriticalSection(ChangeMouseEvents);
|
||||
SysGetMouseY:=LastMouseEvent.y;
|
||||
LeaveCriticalSection(ChangeMouseEvents);
|
||||
}
|
||||
end;
|
||||
|
||||
|
||||
function SysGetMouseButtons:word;
|
||||
begin
|
||||
{
|
||||
EnterCriticalSection(ChangeMouseEvents);
|
||||
SysGetMouseButtons:=LastMouseEvent.Buttons;
|
||||
LeaveCriticalSection(ChangeMouseEvents);
|
||||
}
|
||||
end;
|
||||
|
||||
const
|
||||
SysMouseDriver : TMouseDriver = (
|
||||
UseDefaultQueue : False;
|
||||
InitDriver : @SysInitMouse;
|
||||
DoneDriver : @SysDoneMouse;
|
||||
DetectMouse : @SysDetectMouse;
|
||||
ShowMouse : Nil;
|
||||
HideMouse : Nil;
|
||||
GetMouseX : @SysGetMouseX;
|
||||
GetMouseY : @SysGetMouseY;
|
||||
GetMouseButtons : @SysGetMouseButtons;
|
||||
SetMouseXY : Nil;
|
||||
GetMouseEvent : @SysGetMouseEvent;
|
||||
PollMouseEvent : @SysPollMouseEvent;
|
||||
PutMouseEvent : @SysPutMouseEvent;
|
||||
);
|
||||
|
||||
begin
|
||||
SetMouseDriver(SysMouseDriver);
|
||||
end.
|
||||
428
rtl/morphos/video.pp
Normal file
428
rtl/morphos/video.pp
Normal file
@ -0,0 +1,428 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2006 by Karoly Balogh
|
||||
member of the Free Pascal development team
|
||||
|
||||
Video unit for Amiga and MorphOS
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
unit Video;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
intuition;
|
||||
|
||||
{$i videoh.inc}
|
||||
|
||||
var
|
||||
videoWindow : pWindow;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
// dos
|
||||
exec,graphics;
|
||||
|
||||
{$i video.inc}
|
||||
|
||||
{$i videodata.inc}
|
||||
|
||||
const
|
||||
LastCursorType: word = crUnderline;
|
||||
OrigScreen: PVideoBuf = nil;
|
||||
OrigScreenSize: cardinal = 0;
|
||||
|
||||
var
|
||||
videoColorMap : pColorMap;
|
||||
videoPens : array[0..15] of longint;
|
||||
|
||||
oldCursorX, oldCursorY: longint;
|
||||
visibleCursor: boolean;
|
||||
oldvisibleCursor: boolean;
|
||||
|
||||
procedure SysInitVideo;
|
||||
var counter: longint;
|
||||
begin
|
||||
writeln('sysinitvideo');
|
||||
InitGraphicsLibrary;
|
||||
InitIntuitionLibrary;
|
||||
{
|
||||
ScreenColor:=true;
|
||||
GetConsoleScreenBufferInfo(TextRec(Output).Handle, OrigConsoleInfo);
|
||||
GetConsoleCursorInfo(TextRec(Output).Handle, OrigConsoleCursorInfo);
|
||||
OrigCP := GetConsoleCP;
|
||||
ConsoleInfo:=OrigConsoleInfo;
|
||||
ConsoleCursorInfo:=OrigConsoleCursorInfo;
|
||||
{
|
||||
About the ConsoleCursorInfo record: There are 3 possible
|
||||
structures in it that can be regarded as the 'screen':
|
||||
- dwsize : contains the cols & row in current screen buffer.
|
||||
- srwindow : Coordinates (relative to buffer) of upper left
|
||||
& lower right corners of visible console.
|
||||
- dmMaximumWindowSize : Maximal size of Screen buffer.
|
||||
The first implementation of video used srWindow. After some
|
||||
bug-reports, this was switched to dwMaximumWindowSize.
|
||||
}
|
||||
with ConsoleInfo.dwMaximumWindowSize do
|
||||
begin
|
||||
ScreenWidth:=X;
|
||||
ScreenHeight:=Y;
|
||||
end;
|
||||
{ TDrawBuffer only has FVMaxWidth elements
|
||||
larger values lead to crashes }
|
||||
if ScreenWidth> FVMaxWidth then
|
||||
ScreenWidth:=FVMaxWidth;
|
||||
CursorX:=ConsoleInfo.dwCursorPosition.x;
|
||||
CursorY:=ConsoleInfo.dwCursorPosition.y;
|
||||
if not ConsoleCursorInfo.bvisible then
|
||||
CursorLines:=0
|
||||
else
|
||||
CursorLines:=ConsoleCursorInfo.dwSize;
|
||||
}
|
||||
videoWindow:=OpenWindowTags(Nil, [
|
||||
WA_Left,50,
|
||||
WA_Top,50,
|
||||
WA_InnerWidth,80*8,
|
||||
WA_InnerHeight,25*16,
|
||||
// WA_IDCMP,IDCMP_MOUSEBUTTONS Or IDCMP_RAWKEYS,
|
||||
WA_IDCMP,IDCMP_VANILLAKEY Or IDCMP_RAWKEY,
|
||||
WA_Title,DWord(PChar('Free Pascal Video Output')),
|
||||
WA_Flags,(WFLG_GIMMEZEROZERO Or WFLG_SMART_REFRESH Or WFLG_NOCAREREFRESH Or WFLG_ACTIVATE Or WFLG_DRAGBAR Or WFLG_DEPTHGADGET)
|
||||
]);
|
||||
|
||||
ScreenWidth := 80;
|
||||
ScreenHeight := 25;
|
||||
|
||||
videoColorMap := pScreen(videoWindow^.WScreen)^.ViewPort.ColorMap;
|
||||
for counter:=0 to 15 do begin
|
||||
videoPens[counter]:=ObtainPen(videoColorMap,-1,
|
||||
vgacolors[counter,0] shl 24,vgacolors[counter,1] shl 24,vgacolors[counter,2] shl 24,
|
||||
PEN_EXCLUSIVE);
|
||||
// writeln(videoPens[counter]);
|
||||
// XXX: do checks for -1 colors (KB)
|
||||
end;
|
||||
|
||||
CursorX:=0;
|
||||
CursorY:=0;
|
||||
oldCursorX:=0;
|
||||
oldCursorY:=0;
|
||||
visibleCursor:=true;
|
||||
oldvisibleCursor:=true;
|
||||
end;
|
||||
|
||||
|
||||
procedure SysDoneVideo;
|
||||
var counter: longint;
|
||||
begin
|
||||
if videoWindow<>nil then CloseWindow(videoWindow);
|
||||
for counter:=0 to 15 do ReleasePen(videoColorMap,videoPens[counter]);
|
||||
|
||||
{
|
||||
SetConsoleScreenBufferSize (TextRec (Output).Handle, OrigConsoleInfo.dwSize);
|
||||
SetConsoleWindowInfo (cardinal (TextRec (Output).Handle), true, OrigConsoleInfo.srWindow);
|
||||
SetConsoleCursorInfo(TextRec(Output).Handle, OrigConsoleCursorInfo);
|
||||
SetConsoleCP(OrigCP);
|
||||
}
|
||||
end;
|
||||
|
||||
|
||||
|
||||
function SysVideoModeSelector (const VideoMode: TVideoMode): boolean;
|
||||
|
||||
{
|
||||
var MI: Console_Screen_Buffer_Info;
|
||||
C: Coord;
|
||||
SR: Small_Rect;
|
||||
}
|
||||
begin
|
||||
{
|
||||
if not (GetConsoleScreenBufferInfo (TextRec (Output).Handle, MI)) then
|
||||
SysVideoModeSelector := false
|
||||
else
|
||||
begin
|
||||
with MI do
|
||||
begin
|
||||
C.X := VideoMode.Col;
|
||||
C.Y := VideoMode.Row;
|
||||
end;
|
||||
with SR do
|
||||
begin
|
||||
Top := 0;
|
||||
Left := 0;
|
||||
{ First, we need to make sure we reach the minimum window size
|
||||
to always fit in the new buffer after changing buffer size. }
|
||||
Right := MI.srWindow.Right - MI.srWindow.Left;
|
||||
if VideoMode.Col <= Right then
|
||||
Right := Pred (VideoMode.Col);
|
||||
Bottom := MI.srWindow.Bottom - MI.srWindow.Top;
|
||||
if VideoMode.Row <= Bottom then
|
||||
Bottom := Pred (VideoMode.Row);
|
||||
end;
|
||||
if SetConsoleWindowInfo (cardinal (TextRec (Output).Handle), true, SR) then
|
||||
if SetConsoleScreenBufferSize (TextRec (Output).Handle, C) then
|
||||
begin
|
||||
with SR do
|
||||
begin
|
||||
{ Now, we can resize the window to the final size. }
|
||||
Right := Pred (VideoMode.Col);
|
||||
Bottom := Pred (VideoMode.Row);
|
||||
end;
|
||||
if SetConsoleWindowInfo (cardinal (TextRec (Output).Handle), true, SR) then
|
||||
begin
|
||||
SysVideoModeSelector := true;
|
||||
SetCursorType (LastCursorType);
|
||||
ClearScreen;
|
||||
end
|
||||
else
|
||||
begin
|
||||
SysVideoModeSelector := false;
|
||||
SetConsoleScreenBufferSize (TextRec (Output).Handle, MI.dwSize);
|
||||
SetConsoleWindowInfo (cardinal (TextRec (Output).Handle), true, MI.srWindow);
|
||||
SetCursorType (LastCursorType);
|
||||
end
|
||||
end
|
||||
else
|
||||
begin
|
||||
SysVideoModeSelector := false;
|
||||
SetConsoleWindowInfo (cardinal (TextRec (Output).Handle), true, MI.srWindow);
|
||||
SetCursorType (LastCursorType);
|
||||
end
|
||||
else
|
||||
SysVideoModeSelector := false;
|
||||
end;
|
||||
}
|
||||
end;
|
||||
|
||||
Const
|
||||
SysVideoModeCount = 6;
|
||||
SysVMD : Array[0..SysVideoModeCount-1] of TVideoMode = (
|
||||
(Col: 40; Row: 25; Color: True),
|
||||
(Col: 80; Row: 25; Color: True),
|
||||
(Col: 80; Row: 30; Color: True),
|
||||
(Col: 80; Row: 43; Color: True),
|
||||
(Col: 80; Row: 50; Color: True),
|
||||
(Col: 80; Row: 25; Color: True) // Reserved for TargetEntry
|
||||
);
|
||||
|
||||
|
||||
Function SysSetVideoMode (Const Mode : TVideoMode) : Boolean;
|
||||
|
||||
Var
|
||||
I : Integer;
|
||||
|
||||
begin
|
||||
{
|
||||
I:=SysVideoModeCount-1;
|
||||
SysSetVideoMode:=False;
|
||||
While (I>=0) and Not SysSetVideoMode do
|
||||
If (Mode.col=SysVMD[i].col) and
|
||||
(Mode.Row=SysVMD[i].Row) and
|
||||
(Mode.Color=SysVMD[i].Color) then
|
||||
SysSetVideoMode:=True
|
||||
else
|
||||
Dec(I);
|
||||
If SysSetVideoMode then
|
||||
begin
|
||||
if SysVideoModeSelector(Mode) then
|
||||
begin
|
||||
ScreenWidth:=SysVMD[I].Col;
|
||||
ScreenHeight:=SysVMD[I].Row;
|
||||
ScreenColor:=SysVMD[I].Color;
|
||||
end else SysSetVideoMode := false;
|
||||
end;
|
||||
}
|
||||
end;
|
||||
|
||||
Function SysGetVideoModeData (Index : Word; Var Data : TVideoMode) : boolean;
|
||||
|
||||
begin
|
||||
SysGetVideoModeData:=(Index<=high(SysVMD));
|
||||
If SysGetVideoModeData then
|
||||
Data:=SysVMD[Index];
|
||||
end;
|
||||
|
||||
Function SysGetVideoModeCount : Word;
|
||||
|
||||
begin
|
||||
SysGetVideoModeCount:=SysVideoModeCount;
|
||||
end;
|
||||
|
||||
procedure SysClearScreen;
|
||||
begin
|
||||
UpdateScreen(true);
|
||||
end;
|
||||
|
||||
|
||||
procedure DrawChar(x,y: longint; bitmap: pBitmap; drawCursor: boolean);
|
||||
var tmpCharData: word;
|
||||
tmpChar : byte;
|
||||
tmpRow : byte;
|
||||
tmpFGColor : byte;
|
||||
tmpBGColor : byte;
|
||||
var
|
||||
counterX, counterY:longint;
|
||||
sX,sY: longint;
|
||||
begin
|
||||
tmpCharData:=VideoBuf^[y*ScreenWidth+x];
|
||||
tmpChar :=tmpCharData and $0ff;
|
||||
tmpFGColor :=(tmpCharData shr 8) and %00001111;
|
||||
tmpBGColor :=(tmpCharData shr 12) and %00000111;
|
||||
|
||||
// write('"',char(tmpChar),'" ',tmpChar);
|
||||
sX:=x*8;
|
||||
sY:=y*16;
|
||||
|
||||
SetAPen(videoWindow^.RPort,videoPens[tmpBGColor]);
|
||||
RectFill(videoWindow^.RPort, sX, sY, sX + 7, sY + 15);
|
||||
|
||||
SetAPen(videoWindow^.Rport,videoPens[tmpFGColor]);
|
||||
for counterY:=0 to 15 do begin
|
||||
tmpRow:=vgafont[tmpChar,counterY];
|
||||
if (tmpRow>0) then begin
|
||||
for counterX:=0 to 7 do begin
|
||||
if ((tmpRow and (1 shl counterX)) > 0) then
|
||||
WritePixel(videoWindow^.RPort,sX+counterX,sY+counterY);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
if drawCursor then begin
|
||||
gfxMove(videoWindow^.RPort,sX,sY+14); Draw(videoWindow^.RPort,sX+7,sY+14);
|
||||
gfxMove(videoWindow^.RPort,sX,sY+15); Draw(videoWindow^.RPort,sX+7,sY+15);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
|
||||
procedure SysUpdateScreen(force: boolean);
|
||||
var
|
||||
BufCounter : Longint;
|
||||
smallforce : boolean;
|
||||
|
||||
counter, counterX, counterY: longint;
|
||||
var
|
||||
tmpBitmap : tBitmap;
|
||||
begin
|
||||
if force then
|
||||
smallforce:=true
|
||||
else begin
|
||||
counter:=0;
|
||||
while not smallforce and (counter<(VideoBufSize div 4)-1) do begin
|
||||
if PDWord(VideoBuf)[counter]<>PDWord(OldVideoBuf)[counter] then smallforce:=true;
|
||||
counter+=1;
|
||||
end;
|
||||
end;
|
||||
|
||||
BufCounter:=0;
|
||||
if smallforce then begin
|
||||
for counterY:=0 to ScreenHeight-1 do begin
|
||||
for counterX:=0 to ScreenWidth-1 do begin
|
||||
if VideoBuf^[BufCounter]<>OldVideoBuf^[BufCounter] then
|
||||
DrawChar(counterX,counterY,@tmpBitmap,false);
|
||||
Inc(BufCounter);
|
||||
end;
|
||||
end;
|
||||
move(VideoBuf^,OldVideoBuf^,VideoBufSize);
|
||||
end;
|
||||
|
||||
if (oldvisibleCursor<>visibleCursor) or (CursorX<>oldCursorX) or (CursorY<>oldCursorY) then begin
|
||||
writeln('kurzor:',cursorx,' ',cursory);
|
||||
DrawChar(oldCursorY,oldCursorX,@tmpBitmap,false);
|
||||
DrawChar(CursorY,CursorX,@tmpBitmap,visibleCursor);
|
||||
oldCursorX:=CursorX;
|
||||
oldCursorY:=CursorY;
|
||||
oldVisibleCursor:=visibleCursor;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure SysSetCursorPos(NewCursorX, NewCursorY: Word);
|
||||
begin
|
||||
CursorX:=NewCursorY;
|
||||
CursorY:=NewCursorX;
|
||||
SysUpdateScreen(false);
|
||||
end;
|
||||
|
||||
function SysGetCapabilities: Word;
|
||||
begin
|
||||
SysGetCapabilities:=cpColor or cpChangeCursor;
|
||||
end;
|
||||
|
||||
function SysGetCursorType: Word;
|
||||
begin
|
||||
if not visibleCursor then SysGetCursorType:=crHidden
|
||||
else SysGetCursorType:=crUnderline;
|
||||
|
||||
{
|
||||
GetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo);
|
||||
if not ConsoleCursorInfo.bvisible then
|
||||
SysGetCursorType:=crHidden
|
||||
else
|
||||
case ConsoleCursorInfo.dwSize of
|
||||
1..30:
|
||||
SysGetCursorType:=crUnderline;
|
||||
31..70:
|
||||
SysGetCursorType:=crHalfBlock;
|
||||
71..100:
|
||||
SysGetCursorType:=crBlock;
|
||||
end;
|
||||
}
|
||||
end;
|
||||
|
||||
|
||||
procedure SysSetCursorType(NewType: Word);
|
||||
begin
|
||||
if newType=crHidden then visibleCursor:=false
|
||||
else visibleCursor:=true;
|
||||
SysUpdateScreen(false);
|
||||
{
|
||||
GetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo);
|
||||
if newType=crHidden then
|
||||
ConsoleCursorInfo.bvisible:=false
|
||||
else
|
||||
begin
|
||||
ConsoleCursorInfo.bvisible:=true;
|
||||
case NewType of
|
||||
crUnderline:
|
||||
ConsoleCursorInfo.dwSize:=10;
|
||||
|
||||
crHalfBlock:
|
||||
ConsoleCursorInfo.dwSize:=50;
|
||||
|
||||
crBlock:
|
||||
ConsoleCursorInfo.dwSize:=99;
|
||||
end
|
||||
end;
|
||||
SetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo);
|
||||
}
|
||||
end;
|
||||
|
||||
|
||||
|
||||
const
|
||||
SysVideoDriver : TVideoDriver = (
|
||||
InitDriver : @SysInitVideo;
|
||||
DoneDriver : @SysDoneVideo;
|
||||
UpdateScreen : @SysUpdateScreen;
|
||||
ClearScreen : @SysClearScreen;
|
||||
SetVideoMode : @SysSetVideoMode;
|
||||
GetVideoModeCount : @SysGetVideoModeCount;
|
||||
GetVideoModeData : @SysGetVideoModeData;
|
||||
SetCursorPos : @SysSetCursorPos;
|
||||
GetCursorType : @SysGetCursorType;
|
||||
SetCursorType : @SysSetCursorType;
|
||||
GetCapabilities : @SysGetCapabilities
|
||||
|
||||
);
|
||||
|
||||
|
||||
initialization
|
||||
SetVideoDriver(SysVideoDriver);
|
||||
end.
|
||||
Loading…
Reference in New Issue
Block a user