mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 15:49:27 +02:00
+ implemented the video and mouse units for i8086-msdos
git-svn-id: trunk@37743 -
This commit is contained in:
nickysn
parent
81b56c9d4b
commit
a82740d7a7
2
.gitattributes
vendored
2
.gitattributes
vendored
@ -7247,6 +7247,8 @@ packages/rtl-console/src/inc/video.inc svneol=native#text/plain
|
||||
packages/rtl-console/src/inc/videoh.inc svneol=native#text/plain
|
||||
packages/rtl-console/src/msdos/crt.pp svneol=native#text/plain
|
||||
packages/rtl-console/src/msdos/keyboard.pp svneol=native#text/plain
|
||||
packages/rtl-console/src/msdos/mouse.pp svneol=native#text/plain
|
||||
packages/rtl-console/src/msdos/video.pp svneol=native#text/plain
|
||||
packages/rtl-console/src/netware/crt.pp svneol=native#text/plain
|
||||
packages/rtl-console/src/netware/keyboard.pp svneol=native#text/plain
|
||||
packages/rtl-console/src/netware/mouse.pp svneol=native#text/plain
|
||||
|
||||
@ -13,11 +13,11 @@ Const
|
||||
UnixLikes = AllUnixOSes -[QNX];
|
||||
|
||||
WinEventOSes = [win32,win64];
|
||||
KVMAll = [emx,go32v2,netware,netwlibc,os2,win32,win64,win16]+UnixLikes+AllAmigaLikeOSes;
|
||||
KVMAll = [emx,go32v2,msdos,netware,netwlibc,os2,win32,win64,win16]+UnixLikes+AllAmigaLikeOSes;
|
||||
|
||||
// all full KVMers have crt too, except Amigalikes
|
||||
CrtOSes = KVMALL+[msdos,WatCom]-[aros,morphos,amiga];
|
||||
KbdOSes = KVMALL+[msdos];
|
||||
CrtOSes = KVMALL+[WatCom]-[aros,morphos,amiga];
|
||||
KbdOSes = KVMALL;
|
||||
VideoOSes = KVMALL;
|
||||
MouseOSes = KVMALL;
|
||||
TerminfoOSes = UnixLikes-[beos,haiku];
|
||||
@ -84,6 +84,7 @@ begin
|
||||
AddInclude('mouseh.inc');
|
||||
AddInclude('mouse.inc');
|
||||
AddUnit ('winevent',[win32,win64]);
|
||||
AddUnit ('video',[go32v2,msdos]);
|
||||
end;
|
||||
|
||||
T:=P.Targets.AddUnit('video.pp',VideoOSes);
|
||||
@ -94,6 +95,7 @@ begin
|
||||
AddInclude('videodata.inc',AllAmigaLikeOSes);
|
||||
AddInclude('convert.inc',AllUnixOSes);
|
||||
AddInclude('nwsys.inc',[netware]);
|
||||
AddUnit ('mouse',[go32v2,msdos]);
|
||||
end;
|
||||
|
||||
T:=P.Targets.AddUnit('crt.pp',CrtOSes);
|
||||
|
||||
561
packages/rtl-console/src/msdos/mouse.pp
Normal file
561
packages/rtl-console/src/msdos/mouse.pp
Normal file
@ -0,0 +1,561 @@
|
||||
{
|
||||
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
|
||||
|
||||
Mouse unit for MS-DOS
|
||||
|
||||
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}
|
||||
|
||||
{ tells the mouse unit to draw the mouse cursor itself }
|
||||
procedure DoCustomMouse(b : boolean);
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
video,dos;
|
||||
|
||||
{$i mouse.inc}
|
||||
|
||||
|
||||
var
|
||||
CurrentMask : word;
|
||||
MouseCallback : CodePointer; { Mouse call back ptr }
|
||||
const
|
||||
{ indicates whether the mouse cursor is visible when the mouse cursor is
|
||||
drawn by this unit (i.e. drawmousecursor=true) }
|
||||
CustomMouse_MouseIsVisible: boolean = false;
|
||||
MousePresent : boolean = false;
|
||||
First_try : boolean = true;
|
||||
drawmousecursor : boolean = false;
|
||||
|
||||
{ CustomMouse_HideCount holds the hide count for the custom drawn mouse
|
||||
cursor. Normally, when the mouse cursor is drawn by the int 33h mouse
|
||||
driver (and not by this unit), the driver internally maintains a 'hide
|
||||
counter', so that if you call HideMouse multiple times, you need to call
|
||||
ShowMouse the same number of times. When the mouse cursor is customly
|
||||
drawn by this unit, we use this variable in order to maintain the same
|
||||
behaviour. }
|
||||
CustomMouse_HideCount: smallint = 1;
|
||||
|
||||
{ position where the mouse was drawn the last time }
|
||||
oldmousex : smallint = -1;
|
||||
oldmousey : smallint = -1;
|
||||
mouselock : boolean = false;
|
||||
|
||||
{ if the cursor is drawn by this the unit, we must be careful }
|
||||
{ when drawing while the interrupt handler is called }
|
||||
procedure lockmouse;assembler;
|
||||
|
||||
asm
|
||||
@@trylockagain:
|
||||
mov al,1
|
||||
xchg al,mouselock
|
||||
or al,al
|
||||
jne @@trylockagain
|
||||
end;
|
||||
|
||||
procedure unlockmouse;
|
||||
|
||||
begin
|
||||
mouselock:=false;
|
||||
end;
|
||||
|
||||
|
||||
procedure MouseInt;assembler;
|
||||
asm
|
||||
push ds
|
||||
push es
|
||||
push di
|
||||
push cx
|
||||
push dx
|
||||
{$ifdef FPC_MM_TINY}
|
||||
push cs
|
||||
pop ds
|
||||
{$else}
|
||||
mov di, SEG @DATA
|
||||
mov ds, di
|
||||
{$endif}
|
||||
mov mousebuttons,bl
|
||||
mov mousewherex,cx
|
||||
mov mousewherey,dx
|
||||
shr cx,1
|
||||
shr cx,1
|
||||
shr cx,1
|
||||
shr dx,1
|
||||
shr dx,1
|
||||
shr dx,1
|
||||
{$ifdef FPC_MM_HUGE}
|
||||
mov di, SEG ScreenWidth
|
||||
mov es, di
|
||||
cmp es:[ScreenWidth], 40
|
||||
{$else}
|
||||
cmp ScreenWidth, 40
|
||||
{$endif}
|
||||
jne @@morethan40cols
|
||||
shr cx,1
|
||||
@@morethan40cols:
|
||||
{ should we draw the mouse cursor? }
|
||||
cmp drawmousecursor, 0
|
||||
je @@mouse_nocursor
|
||||
cmp CustomMouse_MouseIsVisible, 0
|
||||
je @@mouse_nocursor
|
||||
push ax
|
||||
push bx
|
||||
{$ifdef FPC_MM_HUGE}
|
||||
push si
|
||||
{$endif}
|
||||
{ check lock }
|
||||
mov al, 1
|
||||
xchg al, mouselock
|
||||
or al, al
|
||||
{ don't update the cursor yet, because hide/showcursor is called }
|
||||
jne @@dont_draw
|
||||
|
||||
{ calculate address of old mouse cursor }
|
||||
mov ax, oldmousey
|
||||
{$ifdef FPC_MM_HUGE}
|
||||
{ ES still points to the data segment of unit 'video' }
|
||||
mov si, es:[screenwidth]
|
||||
imul si
|
||||
{$else}
|
||||
imul screenwidth
|
||||
{$endif}
|
||||
add ax, oldmousex
|
||||
shl ax, 1
|
||||
xchg ax, bx
|
||||
{ load start of video buffer }
|
||||
{$ifdef FPC_MM_HUGE}
|
||||
{ ES still points to the data segment of unit 'video' }
|
||||
mov di, es:[videoseg]
|
||||
{$else}
|
||||
mov di, videoseg
|
||||
{$endif}
|
||||
mov es, di
|
||||
{ remove old cursor }
|
||||
xor byte ptr es:[bx], 7fh
|
||||
|
||||
{ store position of old cursor }
|
||||
mov oldmousex, cx
|
||||
mov oldmousey, dx
|
||||
|
||||
{ calculate address of new cursor }
|
||||
mov ax, dx
|
||||
{$ifdef FPC_MM_HUGE}
|
||||
imul si
|
||||
{$else}
|
||||
imul screenwidth
|
||||
{$endif}
|
||||
add ax, cx
|
||||
shl ax, 1
|
||||
xchg ax, bx
|
||||
{ draw new cursor }
|
||||
xor byte ptr es:[bx], 7fh
|
||||
|
||||
{ unlock mouse }
|
||||
mov mouselock, 0
|
||||
|
||||
@@dont_draw:
|
||||
{$ifdef FPC_MM_HUGE}
|
||||
pop si
|
||||
{$endif}
|
||||
pop bx
|
||||
pop ax
|
||||
@@mouse_nocursor:
|
||||
cmp PendingMouseEvents, MouseEventBufSize
|
||||
je @@mouse_exit
|
||||
{$if defined(FPC_MM_COMPACT) or defined(FPC_MM_LARGE) or defined(FPC_MM_HUGE)}
|
||||
les di, [PendingMouseTail]
|
||||
mov word ptr es:[di], bx
|
||||
mov word ptr es:[di+2], cx
|
||||
mov word ptr es:[di+4], dx
|
||||
mov word ptr es:[di+6], 0
|
||||
{$else}
|
||||
mov di, PendingMouseTail
|
||||
mov word ptr [di], bx
|
||||
mov word ptr [di+2], cx
|
||||
mov word ptr [di+4], dx
|
||||
mov word ptr [di+6], 0
|
||||
{$endif}
|
||||
add di, 8
|
||||
lea ax, PendingMouseEvent
|
||||
add ax, MouseEventBufSize*8
|
||||
cmp di, ax
|
||||
jne @@mouse_nowrap
|
||||
lea di, PendingMouseEvent
|
||||
@@mouse_nowrap:
|
||||
mov word ptr PendingMouseTail, di
|
||||
inc PendingMouseEvents
|
||||
@@mouse_exit:
|
||||
pop dx
|
||||
pop cx
|
||||
pop di
|
||||
pop es
|
||||
pop ds
|
||||
retf
|
||||
end;
|
||||
|
||||
PROCEDURE Mouse_Action (Mask : Word; P : CodePointer);
|
||||
VAR
|
||||
Rg : Registers;
|
||||
BEGIN
|
||||
if (P <> MouseCallBack) or (Mask<>CurrentMask) then { Check func different }
|
||||
begin
|
||||
{ Remove old calback }
|
||||
if (CurrentMask <> 0) then
|
||||
begin
|
||||
Rg.AX := 12; { Function id }
|
||||
Rg.CX := 0; { Zero mask register }
|
||||
Rg.ES := 0; { Zero proc seg }
|
||||
Rg.DX := 0; { Zero proc ofs }
|
||||
Intr($33, Rg); { Stop INT 33 callback }
|
||||
end;
|
||||
if P = nil then
|
||||
Mask := 0; { Zero mask register }
|
||||
MouseCallback := P; { Set call back addr }
|
||||
if Mask<>0 then
|
||||
begin
|
||||
Rg.AX := 12; { Set function id }
|
||||
Rg.CX := Mask; { Set mask register }
|
||||
If Mask<>0 then
|
||||
begin
|
||||
Rg.ES := Seg(P^);
|
||||
Rg.DX := Ofs(P^);
|
||||
end
|
||||
else
|
||||
begin
|
||||
Rg.ES:=0;
|
||||
Rg.DX:=0;
|
||||
end;
|
||||
Intr($33, Rg); { Set interrupt 33 }
|
||||
end;
|
||||
CurrentMask:=Mask;
|
||||
end;
|
||||
END;
|
||||
|
||||
|
||||
{ We need to remove the mouse callback before exiting !! PM }
|
||||
|
||||
const StoredExit : CodePointer = Nil;
|
||||
FirstMouseInitDone : boolean = false;
|
||||
|
||||
procedure MouseSafeExit;
|
||||
begin
|
||||
ExitProc:=StoredExit;
|
||||
if MouseCallBack<>Nil then
|
||||
Mouse_Action(0, Nil);
|
||||
if not FirstMouseInitDone then
|
||||
exit;
|
||||
FirstMouseInitDone:=false;
|
||||
end;
|
||||
|
||||
procedure SysInitMouse;
|
||||
begin
|
||||
if not MousePresent then
|
||||
begin
|
||||
if DetectMouse=0 then
|
||||
begin
|
||||
if First_try then
|
||||
begin
|
||||
Writeln('No mouse driver found ');
|
||||
First_try:=false;
|
||||
end;
|
||||
exit;
|
||||
end
|
||||
else
|
||||
MousePresent:=true;
|
||||
end;
|
||||
{ don't do this twice !! PM }
|
||||
|
||||
If not FirstMouseInitDone then
|
||||
begin
|
||||
StoredExit:=ExitProc;
|
||||
ExitProc:=@MouseSafeExit;
|
||||
FirstMouseInitDone:=true;
|
||||
end;
|
||||
If MouseCallBack=Nil then
|
||||
Mouse_Action($ffff, @MouseInt); { Set masks/interrupt }
|
||||
drawmousecursor:=false;
|
||||
CustomMouse_MouseIsVisible:=false;
|
||||
if (screenwidth>80) or (screenheight>50) then
|
||||
DoCustomMouse(true);
|
||||
ShowMouse;
|
||||
end;
|
||||
|
||||
|
||||
procedure SysDoneMouse;
|
||||
begin
|
||||
HideMouse;
|
||||
If (MouseCallBack <> Nil) Then
|
||||
Mouse_Action(0, Nil); { Clear mask/interrupt }
|
||||
end;
|
||||
|
||||
|
||||
function SysDetectMouse:byte;assembler;
|
||||
asm
|
||||
xor ax, ax
|
||||
mov es, ax
|
||||
mov di, es:[4*33h]
|
||||
or di, es:[4*33h+2]
|
||||
jz @@no_mouse
|
||||
|
||||
push bp
|
||||
int 33h
|
||||
pop bp
|
||||
or ax, ax
|
||||
jz @@no_mouse
|
||||
mov ax, bx
|
||||
@@no_mouse:
|
||||
end;
|
||||
|
||||
|
||||
procedure SysShowMouse;
|
||||
|
||||
begin
|
||||
if drawmousecursor then
|
||||
begin
|
||||
lockmouse;
|
||||
if CustomMouse_HideCount>0 then
|
||||
Dec(CustomMouse_HideCount);
|
||||
if (CustomMouse_HideCount=0) and not(CustomMouse_MouseIsVisible) then
|
||||
begin
|
||||
oldmousex:=getmousex-1;
|
||||
oldmousey:=getmousey-1;
|
||||
mem[videoseg:(((screenwidth*oldmousey)+oldmousex)*2)+1]:=
|
||||
mem[videoseg:(((screenwidth*oldmousey)+oldmousex)*2)+1] xor $7f;
|
||||
CustomMouse_MouseIsVisible:=true;
|
||||
end;
|
||||
unlockmouse;
|
||||
end
|
||||
else
|
||||
asm
|
||||
cmp MousePresent, 1
|
||||
jne @@ShowMouseExit
|
||||
mov ax, 1
|
||||
push bp
|
||||
int 33h
|
||||
pop bp
|
||||
@@ShowMouseExit:
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure SysHideMouse;
|
||||
|
||||
begin
|
||||
if drawmousecursor then
|
||||
begin
|
||||
lockmouse;
|
||||
Inc(CustomMouse_HideCount);
|
||||
if CustomMouse_MouseIsVisible then
|
||||
begin
|
||||
CustomMouse_MouseIsVisible:=false;
|
||||
mem[videoseg:(((screenwidth*oldmousey)+oldmousex)*2)+1]:=
|
||||
mem[videoseg:(((screenwidth*oldmousey)+oldmousex)*2)+1] xor $7f;
|
||||
oldmousex:=-1;
|
||||
oldmousey:=-1;
|
||||
end;
|
||||
unlockmouse;
|
||||
end
|
||||
else
|
||||
asm
|
||||
cmp MousePresent, 1
|
||||
jne @@HideMouseExit
|
||||
mov ax, 2
|
||||
push bp
|
||||
int 33h
|
||||
pop bp
|
||||
@@HideMouseExit:
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function SysGetMouseX:word;assembler;
|
||||
asm
|
||||
cmp MousePresent, 1
|
||||
jne @@GetMouseXError
|
||||
mov ax, 3
|
||||
push bp
|
||||
int 33h
|
||||
pop bp
|
||||
xchg ax, cx
|
||||
shr ax, 1
|
||||
shr ax, 1
|
||||
shr ax, 1
|
||||
{$ifdef FPC_MM_HUGE}
|
||||
mov bx, SEG ScreenWidth
|
||||
mov es, bx
|
||||
cmp es:[ScreenWidth], 40
|
||||
{$else}
|
||||
cmp ScreenWidth, 40
|
||||
{$endif}
|
||||
jne @@morethan40cols
|
||||
shr ax, 1
|
||||
@@morethan40cols:
|
||||
inc ax
|
||||
jmp @@exit
|
||||
@@GetMouseXError:
|
||||
xor ax, ax
|
||||
@@exit:
|
||||
end;
|
||||
|
||||
|
||||
function SysGetMouseY:word;assembler;
|
||||
asm
|
||||
cmp MousePresent, 1
|
||||
jne @@GetMouseYError
|
||||
mov ax, 3
|
||||
push bp
|
||||
int 33h
|
||||
pop bp
|
||||
xchg ax, dx
|
||||
shr ax, 1
|
||||
shr ax, 1
|
||||
shr ax, 1
|
||||
inc ax
|
||||
jmp @@exit
|
||||
@@GetMouseYError:
|
||||
xor ax, ax
|
||||
@@exit:
|
||||
end;
|
||||
|
||||
|
||||
function SysGetMouseButtons:word;assembler;
|
||||
asm
|
||||
cmp MousePresent, 1
|
||||
jne @@GetMouseButtonsError
|
||||
mov ax, 3
|
||||
push bp
|
||||
int 33h
|
||||
pop bp
|
||||
xchg ax, bx
|
||||
jmp @@exit
|
||||
@@GetMouseButtonsError:
|
||||
xor ax, ax
|
||||
@@exit:
|
||||
end;
|
||||
|
||||
|
||||
procedure SysSetMouseXY(x,y:word);assembler;
|
||||
asm
|
||||
cmp MousePresent, 1
|
||||
jne @@SetMouseXYExit
|
||||
mov cx, x
|
||||
mov dx, y
|
||||
mov ax, 4
|
||||
push bp
|
||||
int 33h
|
||||
pop bp
|
||||
@@SetMouseXYExit:
|
||||
end;
|
||||
|
||||
Procedure SetMouseXRange (Min,Max:Longint);
|
||||
begin
|
||||
If Not(MousePresent) Then Exit;
|
||||
asm
|
||||
mov ax, 7
|
||||
mov cx, min
|
||||
mov dx, max
|
||||
push bp
|
||||
int 33h
|
||||
pop bp
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure SetMouseYRange (min,max:Longint);
|
||||
begin
|
||||
If Not(MousePresent) Then Exit;
|
||||
asm
|
||||
mov ax, 8
|
||||
mov cx, min
|
||||
mov dx, max
|
||||
push bp
|
||||
int 33h
|
||||
pop bp
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure DoCustomMouse(b : boolean);
|
||||
|
||||
begin
|
||||
lockmouse;
|
||||
CustomMouse_HideCount:=1;
|
||||
oldmousex:=-1;
|
||||
oldmousey:=-1;
|
||||
if ScreenWidth=40 then
|
||||
SetMouseXRange(0,(screenwidth-1)*16)
|
||||
else
|
||||
SetMouseXRange(0,(screenwidth-1)*8);
|
||||
SetMouseYRange(0,(screenheight-1)*8);
|
||||
if b then
|
||||
begin
|
||||
CustomMouse_MouseIsVisible:=false;
|
||||
drawmousecursor:=true;
|
||||
end
|
||||
else
|
||||
drawmousecursor:=false;
|
||||
unlockmouse;
|
||||
end;
|
||||
|
||||
procedure SysGetMouseEvent(var MouseEvent: TMouseEvent);
|
||||
var
|
||||
RR: Registers;
|
||||
begin
|
||||
if not MousePresent then
|
||||
begin
|
||||
Fillchar(MouseEvent,SizeOf(TMouseEvent),#0);
|
||||
end;
|
||||
while PendingMouseEvents = 0 do
|
||||
begin
|
||||
(* Give up time slices while waiting for mouse events. *)
|
||||
Intr ($28, RR);
|
||||
end;
|
||||
MouseEvent:=PendingMouseHead^;
|
||||
inc(PendingMouseHead);
|
||||
if PendingMouseHead=@PendingMouseEvent[0]+MouseEventBufsize then
|
||||
PendingMouseHead:=@PendingMouseEvent[0];
|
||||
dec(PendingMouseEvents);
|
||||
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;
|
||||
LastMouseEvent:=MouseEvent;
|
||||
end;
|
||||
|
||||
|
||||
Const
|
||||
SysMouseDriver : TMouseDriver = (
|
||||
useDefaultQueue : true;
|
||||
InitDriver : @SysInitMouse;
|
||||
DoneDriver : @SysDoneMouse;
|
||||
DetectMouse : @SysDetectMouse;
|
||||
ShowMouse : @SysShowMouse;
|
||||
HideMouse : @SysHideMouse;
|
||||
GetMouseX : @SysGetMouseX;
|
||||
GetMouseY : @SysGetMouseY;
|
||||
GetMouseButtons : @SysGetMouseButtons;
|
||||
SetMouseXY : @SysSetMouseXY;
|
||||
GetMouseEvent : @SysGetMouseEvent;
|
||||
PollMouseEvent : Nil;
|
||||
PutMouseEvent : Nil;
|
||||
);
|
||||
|
||||
Begin
|
||||
SetMouseDriver(SysMouseDriver);
|
||||
end.
|
||||
296
packages/rtl-console/src/msdos/video.pp
Normal file
296
packages/rtl-console/src/msdos/video.pp
Normal file
@ -0,0 +1,296 @@
|
||||
{
|
||||
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
|
||||
|
||||
Video unit for MS-DOS
|
||||
|
||||
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
|
||||
|
||||
{$i videoh.inc}
|
||||
|
||||
var
|
||||
VideoSeg : word;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
mouse,
|
||||
dos;
|
||||
|
||||
{$i video.inc}
|
||||
|
||||
{ used to know if LastCursorType is valid }
|
||||
const
|
||||
LastCursorType : word = crUnderline;
|
||||
|
||||
{ allways set blink state again }
|
||||
|
||||
procedure SetHighBitBlink;
|
||||
var
|
||||
regs : registers;
|
||||
begin
|
||||
regs.ax:=$1003;
|
||||
regs.bx:=$0001;
|
||||
intr($10,regs);
|
||||
end;
|
||||
|
||||
function BIOSGetScreenMode(var Cols,Rows: word; var Color: boolean): boolean;
|
||||
var
|
||||
r: registers;
|
||||
B: array[0..63] of byte;
|
||||
OK: boolean;
|
||||
begin
|
||||
r.ah:=$1b; r.bx:=0;
|
||||
r.es:=Seg(B); r.di:=Ofs(B);
|
||||
intr($10,r);
|
||||
OK:=(r.al=$1b);
|
||||
if OK then
|
||||
begin
|
||||
Cols:=PWord(@B[5])^; Rows:=B[$22];
|
||||
Color:=PWord(@B[$27])^<>0;
|
||||
end;
|
||||
BIOSGetScreenMode:=OK;
|
||||
end;
|
||||
|
||||
procedure SysInitVideo;
|
||||
var
|
||||
regs : registers;
|
||||
begin
|
||||
VideoSeg:=SegB800;
|
||||
if (ScreenWidth=$ffff) or (ScreenHeight=$ffff) or
|
||||
(ScreenWidth=0) or (ScreenHeight=0) then
|
||||
begin
|
||||
ScreenColor:=true;
|
||||
regs.ah:=$0f;
|
||||
intr($10,regs);
|
||||
if (regs.al and 1)=0 then
|
||||
ScreenColor:=false;
|
||||
if regs.al=7 then
|
||||
begin
|
||||
ScreenColor:=false;
|
||||
VideoSeg:=SegB000;
|
||||
end
|
||||
else
|
||||
VideoSeg:=SegB800;
|
||||
ScreenWidth:=regs.ah;
|
||||
regs.ax:=$1130;
|
||||
regs.bx:=0;
|
||||
intr($10,regs);
|
||||
ScreenHeight:=regs.dl+1;
|
||||
BIOSGetScreenMode(ScreenWidth,ScreenHeight,ScreenColor);
|
||||
end;
|
||||
regs.ah:=$03;
|
||||
regs.bh:=0;
|
||||
intr($10,regs);
|
||||
CursorLines:=regs.cl;
|
||||
CursorX:=regs.dl;
|
||||
CursorY:=regs.dh;
|
||||
SetHighBitBlink;
|
||||
SetCursorType(LastCursorType);
|
||||
end;
|
||||
|
||||
|
||||
procedure SysDoneVideo;
|
||||
begin
|
||||
LastCursorType:=GetCursorType;
|
||||
ClearScreen;
|
||||
SetCursorType(crUnderLine);
|
||||
SetCursorPos(0,0);
|
||||
end;
|
||||
|
||||
|
||||
function SysGetCapabilities: Word;
|
||||
begin
|
||||
SysGetCapabilities := $3F;
|
||||
end;
|
||||
|
||||
|
||||
procedure SysSetCursorPos(NewCursorX, NewCursorY: Word);
|
||||
var
|
||||
regs : registers;
|
||||
begin
|
||||
regs.ah:=$02;
|
||||
regs.bh:=0;
|
||||
regs.dh:=NewCursorY;
|
||||
regs.dl:=NewCursorX;
|
||||
intr($10,regs);
|
||||
CursorY:=regs.dh;
|
||||
CursorX:=regs.dl;
|
||||
end;
|
||||
|
||||
{ I don't know the maximum value for the scan line
|
||||
probably 7 or 15 depending on resolution !!
|
||||
}
|
||||
function SysGetCursorType: Word;
|
||||
var
|
||||
regs : registers;
|
||||
begin
|
||||
regs.ah:=$03;
|
||||
regs.bh:=0;
|
||||
intr($10,regs);
|
||||
SysGetCursorType:=crHidden;
|
||||
if (regs.ch and $60)=0 then
|
||||
begin
|
||||
SysGetCursorType:=crBlock;
|
||||
if (regs.ch and $1f)<>0 then
|
||||
begin
|
||||
SysGetCursorType:=crHalfBlock;
|
||||
if regs.cl-1=(regs.ch and $1F) then
|
||||
SysGetCursorType:=crUnderline;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure SysSetCursorType(NewType: Word);
|
||||
var
|
||||
regs : registers;
|
||||
const
|
||||
MaxCursorLines = 7;
|
||||
begin
|
||||
regs.ah:=$01;
|
||||
regs.bx:=NewType;
|
||||
case NewType of
|
||||
crHidden : regs.cx:=$2000;
|
||||
crHalfBlock : begin
|
||||
regs.ch:=MaxCursorLines shr 1;
|
||||
regs.cl:=MaxCursorLines;
|
||||
end;
|
||||
crBlock : begin
|
||||
regs.ch:=0;
|
||||
regs.cl:=MaxCursorLines;
|
||||
end;
|
||||
else begin
|
||||
regs.ch:=MaxCursorLines-1;
|
||||
regs.cl:=MaxCursorLines;
|
||||
end;
|
||||
end;
|
||||
intr($10,regs);
|
||||
end;
|
||||
|
||||
procedure SysUpdateScreen(Force: Boolean);
|
||||
begin
|
||||
HideMouse;
|
||||
if not force then
|
||||
force:=CompareByte(VideoBuf^,OldVideoBuf^,VideoBufSize)<>0;
|
||||
if Force then
|
||||
begin
|
||||
movedata(Seg(videobuf^),Ofs(videobuf^),videoseg,0,VideoBufSize);
|
||||
move(videobuf^,oldvideobuf^,VideoBufSize);
|
||||
end;
|
||||
ShowMouse;
|
||||
end;
|
||||
|
||||
Procedure DoSetVideoMode(Params: Longint);
|
||||
|
||||
type
|
||||
wordrec=packed record
|
||||
lo,hi : word;
|
||||
end;
|
||||
var
|
||||
regs : registers;
|
||||
begin
|
||||
regs.ax:=wordrec(Params).lo;
|
||||
regs.bx:=wordrec(Params).hi;
|
||||
intr($10,regs);
|
||||
end;
|
||||
|
||||
Procedure SetVideo8x8;
|
||||
|
||||
type
|
||||
wordrec=packed record
|
||||
lo,hi : word;
|
||||
end;
|
||||
var
|
||||
regs : registers;
|
||||
begin
|
||||
regs.ax:=3;
|
||||
regs.bx:=0;
|
||||
intr($10,regs);
|
||||
regs.ax:=$1112;
|
||||
regs.bx:=$0;
|
||||
intr($10,regs);
|
||||
end;
|
||||
|
||||
Const
|
||||
SysVideoModeCount = 5;
|
||||
SysVMD : Array[0..SysVideoModeCount-1] of TVideoMode = (
|
||||
(Col: 40; Row : 25; Color : False),
|
||||
(Col: 40; Row : 25; Color : True),
|
||||
(Col: 80; Row : 25; Color : False),
|
||||
(Col: 80; Row : 25; Color : True),
|
||||
(Col: 80; Row : 50; Color : True)
|
||||
);
|
||||
|
||||
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 (I<SysVideoModeCount-1) then
|
||||
DoSetVideoMode(I)
|
||||
else
|
||||
SetVideo8x8;
|
||||
ScreenWidth:=SysVMD[I].Col;
|
||||
ScreenHeight:=SysVMD[I].Row;
|
||||
ScreenColor:=SysVMD[I].Color;
|
||||
DoCustomMouse(false);
|
||||
end;
|
||||
end;
|
||||
|
||||
Function SysGetVideoModeData (Index : Word; Var Data : TVideoMode) : boolean;
|
||||
|
||||
begin
|
||||
SysGetVideoModeData:=(Index<=SysVideoModeCount);
|
||||
If SysGetVideoModeData then
|
||||
Data:=SysVMD[Index];
|
||||
end;
|
||||
|
||||
Function SysGetVideoModeCount : Word;
|
||||
|
||||
begin
|
||||
SysGetVideoModeCount:=SysVideoModeCount;
|
||||
end;
|
||||
|
||||
Const
|
||||
SysVideoDriver : TVideoDriver = (
|
||||
InitDriver : @SysInitVideo;
|
||||
DoneDriver : @SysDoneVideo;
|
||||
UpdateScreen : @SysUpdateScreen;
|
||||
ClearScreen : Nil;
|
||||
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