paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 04:59:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

Amiga-likes: huge keyboard/video unit rework

Browse Source 
* unified video unit for all three systems
* faster drawing (simple Window instead of GZZ, which introduces an extra layer)
* helper function to wait for a system event with a timeout, to be used by FV
* mouse events now hooked on IntuiTicks instead of MouseMove, this helps to
  avoid flooding the message system with events even on classic Amigas
* better resize event support
* focus/unfocus event support
* fixed to empty the Window's message port properly on close
* cursor blinking support (hooked on IntuiTicks)
* minor bugfixes, code cleanup
* probably more...

git-svn-id: trunk@29335 -
This commit is contained in:
Károly Balogh 2014-12-26 23:25:25 +00:00
parent 136f845576
commit 0f10a71fa0
6 changed files with 337 additions and 1313 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -6597,10 +6597,9 @@ packages/rtl-console/Makefile.fpc.fpcmake svneol=native#text/plain
packages/rtl-console/fpmake.pp svneol=native#text/plain
packages/rtl-console/src/amicommon/keyboard.pp svneol=native#text/plain
packages/rtl-console/src/amicommon/mouse.pp svneol=native#text/plain
packages/rtl-console/src/amicommon/video.pp svneol=native#text/plain
packages/rtl-console/src/amicommon/videodata.inc svneol=native#text/plain
packages/rtl-console/src/amiga/crt.pp svneol=native#text/plain
packages/rtl-console/src/amiga/video.pp svneol=native#text/plain
packages/rtl-console/src/aros/video.pp svneol=native#text/plain
packages/rtl-console/src/emx/crt.pp svneol=native#text/plain
packages/rtl-console/src/go32v2/crt.pp svneol=native#text/plain
packages/rtl-console/src/go32v2/keyboard.pp svneol=native#text/plain
@ -6616,7 +6615,6 @@ packages/rtl-console/src/inc/mouse.inc svneol=native#text/plain
packages/rtl-console/src/inc/mouseh.inc svneol=native#text/plain
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/morphos/video.pp 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/netware/crt.pp svneol=native#text/plain

163
packages/rtl-console/src/amicommon/keyboard.pp
View File

@ -17,10 +17,24 @@ interface
{$i keybrdh.inc}
{
Amiga specific function, waits for a system event to occur on the
message port of the window. This is mainly used in Free Vision to
give up the Task's timeslice instead of dos.library/Delay() which
blocks the event handling and ruins proper window refreshing among
others
input: specify a timeout to wait for an event to arrive. this is the
maximum timeout. the function might return earlier or even
immediately if there's an event. it's specified in milliseconds
result: boolean if there is an incoming system event. false otherwise
}
function WaitForSystemEvent(millisec: Integer): boolean;
implementation
uses
video, exec,intuition, inputevent, mouse, sysutils, keymap;
video, exec, intuition, inputevent, mouse, sysutils, keymap, timer;
{$i keyboard.inc}
{$i keyscan.inc}
@ -212,6 +226,36 @@ begin
SetShiftState(IQual); // set Shift state qualifiers. do this for all messages we get.
// main event case
case (IClass) of
IDCMP_ACTIVEWINDOW: begin
GotActiveWindow;
end;
IDCMP_INACTIVEWINDOW: begin
// force cursor off. we stop getting IntuiTicks when
// the window is inactive, so the blinking stops.
ToggleCursor(true);
GotInactiveWindow;
end;
IDCMP_INTUITICKS: begin
ToggleCursor(false);
MouseX := (MouseX - VideoWindow^.BorderLeft) div 8;
MouseY := (MouseY - VideoWindow^.BorderTop) div 16;
if (MouseX >= 0) and (MouseY >= 0) and
(MouseX < Video.ScreenWidth) and (MouseY < Video.ScreenHeight) and
((MouseX <> OldMouseX) or (MouseY <> OldmouseY))
then begin
// //writeln('mousemove:',Mousex,'/',Mousey,' oldbutt:',OldButtons);
// Drawing is very slow so when moving window it will drag behind
// because the mouse events stack in the messageport
// -> so we override move until messageport is empty or keyevent is fired
SendMouse := True;
MouseEvent := True;
mes.Action := MouseActionMove;
mes.Buttons := OldButtons;
mes.X := MouseX;
mes.Y := MouseY;
//PutMouseEvent(me);
end;
end;
IDCMP_CLOSEWINDOW: begin
//writeln('got close');
GotCloseWindow;
@ -219,6 +263,9 @@ begin
IDCMP_CHANGEWINDOW: begin
GotResizeWindow;
end;
IDCMP_REFRESHWINDOW: begin
GotRefreshWindow;
end;
IDCMP_MOUSEBUTTONS: begin
MouseEvent := True;
me.x := (MouseX - videoWindow^.BorderLeft) div 8; // calculate char position
@ -256,6 +303,9 @@ begin
//writeln('Buttons: ' , me.Buttons);
end;
IDCMP_MOUSEMOVE: begin
{ IDCMP_MOUSEMOVE is disabled now in the video unit,
according to autodocs INTUITICKS should be enough
to handle most moves, esp. in a "textmode" app }
MouseX := (MouseX - VideoWindow^.BorderLeft) div 8;
MouseY := (MouseY - VideoWindow^.BorderTop) div 16;
if (MouseX >= 0) and (MouseY >= 0) and
@ -456,6 +506,111 @@ begin
SysGetShiftState := LastShiftState;
end;
var
waitTPort: PMsgPort;
waitTimer: PTimeRequest;
waitTimerFired: boolean;
function WaitForSystemEvent(millisec: Integer): boolean;
var
windowbit: PtrUInt;
timerbit: PtrUInt;
recvbits: PtrUInt;
begin
WaitForSystemEvent:=false;
if waitTPort = nil then
begin
{ this really shouldn't happen, but it's enough to avoid a
crash if the timer init failed during startup }
if VideoWindow <> nil then
WaitPort(VideoWindow^.UserPort);
exit;
end;
windowbit:=0;
if VideoWindow <> nil then
begin
if not IsMsgPortEmpty(VideoWindow^.UserPort) then
begin
WaitForSystemEvent:=true;
exit;
end;
windowbit:=1 shl (VideoWindow^.UserPort^.mp_SigBit);
end;
timerbit:=0;
if waitTPort <> nil then
timerbit:=1 shl (waitTPort^.mp_SigBit);
if (windowbit or timerbit) = 0 then exit;
if not waitTimerFired then
begin
waitTimer^.tr_node.io_Command:=TR_ADDREQUEST;
waitTimer^.tr_time.tv_secs:=millisec div 1000;
waitTimer^.tr_time.tv_micro:=(millisec mod 1000) * 1000;
SendIO(PIORequest(waitTimer));
waitTimerFired:=true;
end;
recvbits:=Wait(windowbit or timerbit);
if (recvbits and windowbit) > 0 then
WaitForSystemEvent:=true;
if waitTimerFired then
begin
AbortIO(PIORequest(waitTimer));
WaitIO(PIORequest(waitTimer));
SetSignal(0,timerbit);
waitTimerFired:=false;
end;
end;
procedure DoneSystemEventWait;
begin
if assigned(waitTimer) then
begin
if waitTimerFired then
begin
AbortIO(PIORequest(waitTimer));
WaitIO(PIORequest(waitTimer));
waitTimerFired:=false;
end;
CloseDevice(PIORequest(waitTimer));
DeleteIORequest(PIORequest(waitTimer));
waitTimer:=nil;
end;
if assigned(waitTPort) then
begin
DeleteMsgPort(waitTPort);
waitTPort:=nil;
end;
end;
procedure InitSystemEventWait;
var
initOK: boolean;
begin
waitTimerFired:=false;
waitTPort:=CreateMsgPort();
if assigned(waitTPort) then
begin
waitTimer:=PTimeRequest(CreateIORequest(waitTPort,sizeof(TTimeRequest)));
if assigned(waitTimer) then
begin
if OpenDevice(TIMERNAME,UNIT_VBLANK,PIORequest(waitTimer),0) = 0 then
begin
initOK:=true;
waitTimerFired:=false;
end;
end;
end;
if not initOK then begin
{* this really shouldn't happen if everything is OK with the system *}
SysDebugLn('FPC RTL-Console: SystemEventWait Initialization failed!');
DoneSystemEventWait;
end;
end;
const
SysKeyboardDriver : TKeyboardDriver = (
InitDriver : @SysInitKeyBoard;
@ -468,6 +623,10 @@ const
TranslateKeyEventUnicode : Nil;
);
begin
initialization
SetKeyBoardDriver(SysKeyBoardDriver);
InitSystemEventWait;
finalization
DoneSystemEventWait;
end.

8
packages/rtl-console/src/amicommon/mouse.pp
View File

@ -31,14 +31,6 @@ begin
SysDetectMouse:=3;
end;
const
SysMouseDriver : TMouseDriver = (
UseDefaultQueue : True;

219
packages/rtl-console/src/amiga/video.pp → packages/rtl-console/src/amicommon/video.pp
View File

@ -1,9 +1,9 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2006 by Karoly Balogh
Copyright (c) 2006-2014 by Karoly Balogh
member of the Free Pascal development team
Video unit for Amiga and MorphOS
Video unit for Amiga, MorphOS and AROS
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -45,6 +45,13 @@ procedure GotCloseWindow;
function HasCloseWindow: boolean;
procedure GotResizeWindow;
function HasResizeWindow(var winw:longint; var winh: longint): boolean;
procedure GotRefreshWindow;
procedure ToggleCursor(forceOff: boolean);
procedure GotActiveWindow;
function HasActiveWindow: boolean;
procedure GotInactiveWindow;
function HasInactiveWindow: boolean;
procedure SetWindowTitle(const winTitle: AnsiString; const screenTitle: AnsiString);
var
VideoWindow: PWindow;
@ -69,10 +76,16 @@ var
VideoColorMap : PColorMap;
VideoPens : array[0..15] of LongInt;
OldSH, OldSW : longint;
OldCursorX,
OldCursorY : LongInt;
CursorType : Word;
OldCursorType : Word;
CursorUpdateCnt : Word;
CursorUpdateSpeed : Word;
CursorState : boolean;
ForceCursorUpdate : boolean;
{$ifdef WITHBUFFERING}
BitmapWidth, BitmapHeight: Integer;
@ -81,6 +94,8 @@ var
GotCloseWindowMsg : Boolean;
GotResizeWindowMsg : Boolean;
GotActiveWindowMsg : Boolean;
GotInactiveWindowMsg : Boolean;
LastL, LastT: Integer;
LastW, LastH: Integer;
WindowForReqSave: PWindow;
@ -134,6 +149,18 @@ begin
_OpenWindowTags:=OpenWindowTagList(a, @tags);
end;
const
VIDEO_IDCMP_DEFAULTS = IDCMP_RAWKEY or
IDCMP_MOUSEBUTTONS or
IDCMP_CHANGEWINDOW or IDCMP_CLOSEWINDOW or
IDCMP_ACTIVEWINDOW or IDCMP_INACTIVEWINDOW or
IDCMP_REFRESHWINDOW or
IDCMP_INTUITICKS;
{ simple refresh would be nicer here, but smart refresh gives better
results when moving around the window with the input blocked.
(eg. compiling in the IDE) }
VIDEO_WFLG_DEFAULTS = WFLG_RMBTRAP or WFLG_SMART_REFRESH;
Function GetWindow: PWindow;
begin
if FPC_VIDEO_FULLSCREEN then
@ -155,11 +182,8 @@ begin
WA_Activate , 1,
WA_Borderless , 1,
WA_BackDrop , 1,
WA_FLAGS , (WFLG_GIMMEZEROZERO or WFLG_REPORTMOUSE or WFLG_RMBTRAP or
WFLG_SMART_REFRESH or WFLG_NOCAREREFRESH),
WA_IDCMP , (IDCMP_RAWKEY or
IDCMP_MOUSEMOVE or IDCMP_MOUSEBUTTONS or
IDCMP_CHANGEWINDOW or IDCMP_CLOSEWINDOW)
WA_FLAGS , VIDEO_WFLG_DEFAULTS,
WA_IDCMP , VIDEO_IDCMP_DEFAULTS
]);
end else
begin // Windowed Mode
@ -172,14 +196,11 @@ begin
WA_MaxHeight , 32768,
WA_Title , PtrUInt(PChar('FPC Video Window Output')),
WA_Activate , 1,
WA_FLAGS , (WFLG_GIMMEZEROZERO or WFLG_REPORTMOUSE or
WFLG_SMART_REFRESH or WFLG_NOCAREREFRESH or
WA_FLAGS , (VIDEO_WFLG_DEFAULTS or
WFLG_DRAGBAR or WFLG_DEPTHGADGET or WFLG_SIZEGADGET or
WFLG_SIZEBBOTTOM or WFLG_RMBTRAP or WFLG_CLOSEGADGET),
WA_IDCMP , (IDCMP_RAWKEY or
IDCMP_MOUSEMOVE or IDCMP_MOUSEBUTTONS or
IDCMP_CHANGEWINDOW or IDCMP_CLOSEWINDOW)//,
]);
WFLG_SIZEBBOTTOM or WFLG_CLOSEGADGET),
WA_IDCMP , VIDEO_IDCMP_DEFAULTS
]);
end;
Process := PProcess(FindTask(nil));
@ -207,7 +228,7 @@ var
Counter: LongInt;
begin
{$ifdef VIDEODEBUG}
WriteLn('FULLSCREEN VIDEO UNIT MODIFICATION v2');
WriteLn('FULLSCREEN VIDEO UNIT MODIFICATION v2');
if FPC_VIDEO_FULLSCREEN then
WriteLn('DEBUG: Recognized fullscreen mode')
else
@ -247,9 +268,9 @@ begin
ScreenColor := True;
end;
{$ifdef WITHBUFFERING}
BufRp^.Bitmap := AllocBitmap(VideoWindow^.GZZWidth, VideoWindow^.GZZHeight, VideoWindow^.RPort^.Bitmap^.Depth, BMF_CLEAR, VideoWindow^.RPort^.Bitmap);
BitmapWidth := VideoWindow^.GZZWidth;
BitmapHeight := VideoWindow^.GZZHeight;
BufRp^.Bitmap := AllocBitmap(VideoWindow^.InnerWidth, VideoWindow^.InnerHeight, VideoWindow^.RPort^.Bitmap^.Depth, BMF_CLEAR, VideoWindow^.RPort^.Bitmap);
BitmapWidth := VideoWindow^.InnerWidth;
BitmapHeight := VideoWindow^.InnerHeight;
{$endif}
{ viewpostcolormap info }
videoColorMap := pScreen(videoWindow^.WScreen)^.ViewPort.ColorMap;
@ -272,14 +293,21 @@ begin
OldCursorY := 0;
CursorType := crHidden;
OldCursorType := crHidden;
CursorState := true;
ForceCursorUpdate:=false;
CursorUpdateSpeed:=2; // this could come from an env-var or something
CursorUpdateCnt:=0;
GotCloseWindowMsg := false;
GotResizeWindowMsg := false;
GotActiveWindowMsg := false;
GotInactiveWindowMsg := false;
end;
procedure SysDoneVideo;
var
Counter: LongInt;
msg: PMessage;
begin
if VideoWindow <> nil then
begin
@ -289,13 +317,21 @@ begin
LastL := VideoWindow^.LeftEdge;
LastT := VideoWindow^.TopEdge;
end;
// clean up the messages from our window before closing
Forbid();
repeat
msg:=GetMsg(videoWindow^.UserPort);
if (msg <> nil) then ReplyMsg(msg);
until msg = nil;
ModifyIDCMP(videoWindow,0);
Permit();
CloseWindow(videoWindow);
VideoWindow := nil;
end;
{$ifdef WITHBUFFERING}
FreeBitmap(BufRp^.Bitmap);
BufRp^.Bitmap := nil;
{$endif}
VideoWindow := nil;
for Counter := 0 to 15 do
ReleasePen(VideoColorMap, VideoPens[Counter]);
if ((FPC_VIDEO_FULLSCREEN) and (OS_Screen <> nil)) then
@ -317,6 +353,7 @@ begin
begin
LastT := 50;
LastL := 50;
LastW := 80;
LastH := 25;
end;
@ -336,8 +373,6 @@ begin
SysSetVideoMode := True;
end;
var
OldSH, OldSW : longint;
procedure SysClearScreen;
begin
@ -355,12 +390,12 @@ var
sX, sY: LongInt;
begin
TmpCharData := VideoBuf^[y * ScreenWidth + x];
TmpChar := TmpCharData and $0ff;
TmpChar := byte(TmpCharData);
TmpFGColor := (TmpCharData shr 8) and %00001111;
TmpBGColor := (TmpCharData shr 12) and %00000111;
sX := x * 8;
sY := y * 16;
sX := x * 8 + videoWindow^.borderLeft;
sY := y * 16 + videoWindow^.borderTop;
if crType <> crBlock then
begin
@ -397,7 +432,7 @@ begin
if Force then
begin
if (OldSH = ScreenHeight) and (OldSW = ScreenWidth) then
Force:=false
Force := false
else
begin
OldSH := ScreenHeight;
@ -411,20 +446,21 @@ begin
end else
begin
Counter:=0;
while not smallforce and (Counter < (VideoBufSize div 4) - 1) do
begin
SmallForce := (PDWord(VideoBuf)[Counter] <> PDWord(OldVideoBuf)[Counter]);
inc(Counter);
end;
if not ForceCursorUpdate then
while not smallforce and (Counter < (VideoBufSize div 4) - 1) do
begin
SmallForce := (PDWord(VideoBuf)[Counter] <> PDWord(OldVideoBuf)[Counter]);
inc(Counter);
end;
end;
{$ifdef WITHBUFFERING}
if (VideoWindow^.GZZWidth > BitmapWidth) or (VideoWindow^.GZZHeight > BitmapHeight) then
if (VideoWindow^.InnerWidth > BitmapWidth) or (VideoWindow^.InnerHeight > BitmapHeight) then
begin
FreeBitmap(BufRp^.Bitmap);
BufRp^.Bitmap := AllocBitmap(VideoWindow^.GZZWidth, VideoWindow^.GZZHeight, VideoWindow^.RPort^.Bitmap^.Depth, BMF_CLEAR, VideoWindow^.RPort^.Bitmap);
BitmapWidth := VideoWindow^.GZZWidth;
BitmapHeight := VideoWindow^.GZZHeight;
BufRp^.Bitmap := AllocBitmap(VideoWindow^.InnerWidth, VideoWindow^.InnerHeight, VideoWindow^.RPort^.Bitmap^.Depth, BMF_CLEAR, VideoWindow^.RPort^.Bitmap);
BitmapWidth := VideoWindow^.InnerWidth;
BitmapHeight := VideoWindow^.InnerHeight;
Force := True;
Smallforce := True;
end;
@ -458,14 +494,14 @@ begin
if (CursorType <> OldCursorType) or
(CursorX <> OldCursorX) or (CursorY <> OldCursorY) or
SmallForce then
SmallForce or ForceCursorUpdate then
begin
{$ifdef WITHBUFFERING}
DrawChar(BufRp, OldCursorY, OldCursorX, crHidden);
DrawChar(BufRp, CursorY, CursorX, CursorType);
if CursorState then DrawChar(BufRp, CursorY, CursorX, CursorType);
{$else}
DrawChar(VideoWindow^.RPort, OldCursorY, OldCursorX, crHidden);
DrawChar(VideoWindow^.RPort, CursorY, CursorX, CursorType);
if CursorState then DrawChar(VideoWindow^.RPort, CursorY, CursorX, CursorType);
{$endif}
OldCursorX := CursorX;
OldCursorY := CursorY;
@ -526,21 +562,116 @@ end;
function HasResizeWindow(var WinW: LongInt; var WinH: LongInt): Boolean;
begin
//writeln('Has resize ', GotResizeWindowMsg);
WinW := 0;
WinH := 0;
HasResizeWindow := GotResizeWindowMsg;
if Assigned(VideoWindow) then
if GotResizeWindowMsg then
begin
//writeln('resize');
WinW := VideoWindow^.GZZWidth div 8;
WinH := VideoWindow^.GZZHeight div 16;
LastW := WinW;
LastH := WinH;
//writeln('Has resize ', GotResizeWindowMsg);
if Assigned(VideoWindow) then
begin
WinW := VideoWindow^.GZZWidth div 8;
WinH := VideoWindow^.GZZHeight div 16;
// writeln('resize', winw, ' ',winh);
LastW := WinW;
LastH := WinH;
end
end
else
begin
WinW := LastW;
WinH := LastH;
end;
GotResizeWindowMsg := False;
end;
procedure GotRefreshWindow;
begin
if assigned(VideoWindow) then
begin
oldSH := -1;
oldSW := -1;
BeginRefresh(VideoWindow);
SysUpdateScreen(true);
EndRefresh(VideoWindow, true);
end;
end;
procedure ToggleCursor(forceOff: boolean);
begin
if CursorType = crHidden then exit;
if forceOff then
begin
CursorState:=false;
// to immediately turn on cursor on the next toggle
CursorUpdateCnt:=CursorUpdateSpeed;
end
else
begin
Inc(CursorUpdateCnt);
if CursorUpdateCnt >= CursorUpdateSpeed then
begin
CursorState:=not CursorState;
CursorUpdateCnt:=0;
end
else
exit;
end;
ForceCursorUpdate:=true;
SysUpdateScreen(False);
ForceCursorUpdate:=false;
end;
procedure GotActiveWindow;
begin
GotActiveWindowMsg:=true;
end;
function HasActiveWindow: boolean;
begin
HasActiveWindow:=GotActiveWindowMsg;
GotActiveWindowMsg:=false;
end;
procedure GotInactiveWindow;
begin
GotInactiveWindowMsg:=true;
end;
function HasInactiveWindow: boolean;
begin
HasInactiveWindow:=GotInactiveWindowMsg;
GotInactiveWindowMsg:=false;
end;
{ SetWindowTitles seems not to copy the buffer, at least on AROS.
So we better keep a reference of the strings to ourselves... }
var
globWinT: AnsiString;
globScreenT: AnsiString;
procedure SetWindowTitle(const winTitle: AnsiString; const screenTitle: AnsiString);
var
winT: PChar;
screenT: PChar;
begin
globWinT:=winTitle;
globScreenT:=screenTitle;
if VideoWindow <> nil then
begin
if globWinT = '' then
winT:=PChar(PtrInt(-1))
else
winT:=PChar(globWinT);
if globScreenT = '' then
screenT:=PChar(PtrInt(-1))
else
screenT:=PChar(globScreenT);
SetWindowTitles(VideoWindow, winT, screenT);
end;
end;
function SysGetVideoModeCount: Word;
begin
SysGetVideoModeCount := 2;

606
packages/rtl-console/src/aros/video.pp
View File

@ -1,606 +0,0 @@
{
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;
{.$define VIDEODEBUG}
{.$define WITHBUFFERING}
{
Date: 2013-01-09
What: Adjusted FPC video unit for AROS (/AmigaOS?)
goal:
---------------------------------------------------------------------------
Attempt to add user-on-demand support for AROS Fullscreen to the FPC video
unit.
}
interface
uses
amigados, intuition, tagsarray, utility, sysutils;
{$i videoh.inc}
{ Amiga specific calls, to help interaction between Keyboard, Mouse and
Video units, and Free Vision }
procedure GotCloseWindow;
function HasCloseWindow: boolean;
procedure GotResizeWindow;
function HasResizeWindow(var winw:longint; var winh: longint): boolean;
var
VideoWindow: PWindow;
implementation
uses
exec, agraphics;
{$i video.inc}
{$i videodata.inc}
const
VIDEOSCREENNAME = 'FPC Video Screen Output';
var
OS_Screen : PScreen = nil; // To hold our screen, when necessary
FPC_VIDEO_FULLSCREEN : Boolean = False; // Global that defines when we need to attempt opening on own scren
var
VideoColorMap : PColorMap;
VideoPens : array[0..15] of LongInt;
OldCursorX,
OldCursorY : LongInt;
CursorType : Word;
OldCursorType : Word;
{$ifdef WITHBUFFERING}
BitmapWidth, BitmapHeight: Integer;
BufRp: PRastPort;
{$endif}
GotCloseWindowMsg : Boolean;
GotResizeWindowMsg : Boolean;
LastL, LastT: Integer;
LastW, LastH: Integer;
WindowForReqSave: PWindow;
Process: PProcess;
(*
GetScreen: pScreen;
Tries to open a custom screen, which attempt to clone the workbench,
and returns the pointer to the screen. Result can be nil when failed
otherwise the screen got opened correctly.
*)
Function GetScreen: pScreen;
var
ScreenTags: TTagsList;
Tags: PTagItem;
begin
AddTags(ScreenTags,[
SA_Title , VIDEOSCREENNAME,
SA_Left , 0,
SA_Top , 0,
SA_ShowTitle , 0, // Do not show the screen's TitleBar
SA_Type , 1 shl 1, // pubscreen
SA_PubName , VIDEOSCREENNAME,
SA_Quiet , True,
SA_LikeWorkbench , 1 // Let OS
]);
Tags := GetTagPtr(ScreenTags);
GetScreen := OpenScreenTagList(nil, Tags);
{$ifdef VIDEODEBUG}
if (GetScreen <> nil) then
Writeln('DEBUG: Opened a new screen')
else
Writeln('ERROR: Failed to open new screen');
{$endif}
end;
(*
GetWindow: pWindow;
Tries to create and open a window. Returns the pointer to
the window or nil in case of failure.
The routine keeps the global FPC_FULL_SCREEM option into
account and act accordingly.
In windowed mode it returns a window with another kind of
settings then when it has to reside on it's own customscreen.
*)
Function GetWindow: PWindow;
Var
WindowTags: TTagsList;
Tags: PTagItem;
begin
if FPC_VIDEO_FULLSCREEN then
begin
OS_Screen := GetScreen;
If OS_Screen = nil then
Exit;
{$ifdef VIDEODEBUG}
WriteLn('DEBUG: Opened customscreen succesfully');
{$endif}
Addtags(WindowTags, [
WA_CustomScreen, OS_Screen,
WA_Left , 0,
WA_Top , 0,
WA_InnerWidth , (OS_Screen^.Width div 8) * 8,
WA_InnerHeight, (OS_Screen^.Height div 16) * 16,
WA_AutoAdjust , 1,
WA_Activate , 1,
WA_Borderless , 1,
WA_BackDrop , 1,
WA_FLAGS , (WFLG_GIMMEZEROZERO or WFLG_REPORTMOUSE or WFLG_RMBTRAP or
WFLG_SMART_REFRESH or WFLG_NOCAREREFRESH),
WA_IDCMP , (IDCMP_RAWKEY or
IDCMP_MOUSEMOVE or IDCMP_MOUSEBUTTONS or
IDCMP_CHANGEWINDOW or IDCMP_CLOSEWINDOW)
]);
end else
begin // Windowed Mode
AddTags(WindowTags, [
WA_Left , LastL,
WA_Top , LastT,
WA_InnerWidth , LastW*8,
WA_InnerHeight, LastH*16,
WA_MaxWidth , 32768,
WA_MaxHeight , 32768,
WA_Title , PChar('FPC Video Window Output'),
WA_Activate , 1,
WA_FLAGS , (WFLG_GIMMEZEROZERO or WFLG_REPORTMOUSE or
WFLG_SMART_REFRESH or WFLG_NOCAREREFRESH or
WFLG_DRAGBAR or WFLG_DEPTHGADGET or WFLG_SIZEGADGET or
WFLG_SIZEBBOTTOM or WFLG_RMBTRAP or WFLG_CLOSEGADGET),
WA_IDCMP , (IDCMP_RAWKEY or
IDCMP_MOUSEMOVE or IDCMP_MOUSEBUTTONS or
IDCMP_CHANGEWINDOW or IDCMP_CLOSEWINDOW)//,
]);
end;
Tags := GetTagPtr(WindowTags);
GetWindow := OpenWindowTagList(nil, Tags);
Process := PProcess(FindTask(nil));
WindowForReqSave := Process^.pr_WindowPtr;
Process^.pr_WindowPtr := GetWindow;
{$ifdef VIDEODEBUG}
If GetWindow <> nil then
WriteLn('DEBUG: Sucessfully opened videounit Window')
else
WriteLn('ERROR: Failed to open videounit Window');
{$endif}
end;
// ==========================================================================
// ==
// == Original source code continues, with minor adjustments
// ==
// ==========================================================================
procedure SysInitVideo;
var
Counter: LongInt;
begin
{$ifdef VIDEODEBUG}
WriteLn('FULLSCREEN VIDEO UNIT MODIFICATION v2');
if FPC_VIDEO_FULLSCREEN then
WriteLn('DEBUG: Recognized fullscreen mode')
else
WriteLn('DEBUG: Recognized windowed mode');
{$endif}
// fill videobuf and oldvideobuf with different bytes, to allow proper first draw
FillDword(VideoBuf^, VideoBufSize div 4, $1234D3AD);
FillDword(OldVideoBuf^, VideoBufSize div 4, $4321BEEF);
VideoWindow := GetWindow;
// nice hardcode values are probably going to screw up things
// so wee neeed a way to detrmined how many chars could be on
// the screen in both directions. And a bit accurate.
if FPC_VIDEO_FULLSCREEN then
begin
// just to make sure that we are going to use the window width
// and height instead of the one from the screen.
// This is to circumvent that the window (or virtual window from
// vision based on characters pixels * characters in both
// dimensions) is actually smaller then the window it resides on.
//
// Can happen for instance when the window does not hide it's
// borders or title as intended.
ScreenWidth := VideoWindow^.GZZWidth div 8;
ScreenHeight := VideoWindow^.GZZHeight div 16;
ScreenColor := False;
{$ifdef VIDEODEBUG}
Writeln('DEBUG: Fullscreen - windowed - Width * Heigth = ',ScreenWidth,' * ',ScreenHeight);
{$endif}
end else
begin
ScreenWidth := LastW;
ScreenHeight := LastH;
ScreenColor := True;
end;
{$ifdef WITHBUFFERING}
BufRp^.Bitmap := AllocBitmap(VideoWindow^.GZZWidth, VideoWindow^.GZZHeight, VideoWindow^.RPort^.Bitmap^.Depth, BMF_CLEAR, VideoWindow^.RPort^.Bitmap);
BitmapWidth := VideoWindow^.GZZWidth;
BitmapHeight := VideoWindow^.GZZHeight;
{$endif}
{ viewpostcolormap info }
videoColorMap := pScreen(videoWindow^.WScreen)^.ViewPort.ColorMap;
for Counter := 0 to 15 do
begin
VideoPens[Counter] := ObtainPen(VideoColorMap, LongWord(-1),
vgacolors[counter, 0] shl 24, vgacolors[counter, 1] shl 24, vgacolors[counter, 2] shl 24,
PEN_EXCLUSIVE);
{$ifdef VIDEODEBUG}
If VideoPens[Counter] = -1 then
WriteLn('errr color[',Counter,'] = ', VideoPens[Counter])
else
WriteLn('good color[',Counter,'] = ', VideoPens[Counter]);
{$endif}
end;
CursorX := 0;
CursorY := 0;
OldCursorX := 0;
OldCursorY := 0;
CursorType := crHidden;
OldCursorType := crHidden;
GotCloseWindowMsg := false;
GotResizeWindowMsg := false;
end;
procedure SysDoneVideo;
var
Counter: LongInt;
begin
if VideoWindow <> nil then
begin
Process^.pr_WindowPtr := WindowForReqSave;
if not FPC_VIDEO_FULLSCREEN then
begin
LastL := VideoWindow^.LeftEdge;
LastT := VideoWindow^.TopEdge;
end;
CloseWindow(videoWindow);
end;
{$ifdef WITHBUFFERING}
FreeBitmap(BufRp^.Bitmap);
BufRp^.Bitmap := nil;
{$endif}
VideoWindow := nil;
for Counter := 0 to 15 do
ReleasePen(VideoColorMap, VideoPens[Counter]);
if ((FPC_VIDEO_FULLSCREEN) and (OS_Screen <> nil)) then
begin
CloseScreen(OS_Screen);
end;
end;
function SysSetVideoMode(const Mode: TVideoMode): Boolean;
var
dx: integer;
dy: integer;
begin
if ScreenColor <> Mode.Color then
begin
SysDoneVideo;
FPC_VIDEO_FULLSCREEN := not Mode.color;
if not FPC_VIDEO_FULLSCREEN then
begin
LastT := 50;
LastL := 50;
LastW := 80;
LastH := 25;
end;
SysInitVideo;
end else
if not FPC_VIDEO_FULLSCREEN then
begin
dx := (Mode.col * 8) - VideoWindow^.GZZWidth;
dy := (Mode.row * 16) - VideoWindow^.GZZHeight;
SizeWindow(videoWindow, dx, dy);
end;
ScreenWidth := Mode.col;
ScreenHeight := Mode.row;
LastW := Mode.Col;
LastH := Mode.Row;
ScreenColor := Mode.color;
SysSetVideoMode := True;
end;
var
OldSH, OldSW : longint;
procedure SysClearScreen;
begin
oldSH := -1;
oldSW := -1;
UpdateScreen(True);
end;
procedure DrawChar(rp: PRastPort; x, y: LongInt; crType: Word);
var
TmpCharData: Word;
TmpChar: Byte;
TmpFGColor: Byte;
TmpBGColor: Byte;
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;
sX := x * 8;
sY := y * 16;
if crType <> crBlock then
begin
SetABPenDrMd(rp, VideoPens[TmpFGColor], VideoPens[tmpBGColor], JAM2);
end else
begin
{ in case of block cursor, swap fg/bg colors
and BltTemplate() below will take care of everything }
SetABPenDrMd(rp, VideoPens[tmpBGColor], VideoPens[tmpFGColor], JAM2);
end;
BltTemplate(@Vgafont[tmpChar, 0], 0, 1, rp, sX, sY, 8, 16);
if crType = crUnderLine then
begin
{ draw two lines at the bottom of the char, in case of underline cursor }
GfxMove(rp, sX, sY + 14); Draw(rp, sX + 7, sY + 14);
GfxMove(rp, sX, sY + 15); Draw(rp, sX + 7, sY + 15);
end;
end;
procedure SysUpdateScreen(Force: Boolean);
var
BufCounter: Longint;
SmallForce: Boolean;
Counter, CounterX, CounterY: LongInt;
//BufRp: PRastPort;
t: Double;
NumChanged: Integer;
begin
SmallForce := False;
// override forced update when screen dimensions haven't changed
if Force then
begin
if (OldSH = ScreenHeight) and (OldSW = ScreenWidth) then
Force:=false
else
begin
OldSH := ScreenHeight;
OldSW := ScreenWidth;
end;
end;
if Force then
begin
SmallForce:=true;
end else
begin
Counter:=0;
while not smallforce and (Counter < (VideoBufSize div 4) - 1) do
begin
SmallForce := (PDWord(VideoBuf)[Counter] <> PDWord(OldVideoBuf)[Counter]);
inc(Counter);
end;
end;
{$ifdef WITHBUFFERING}
if (VideoWindow^.GZZWidth > BitmapWidth) or (VideoWindow^.GZZHeight > BitmapHeight) then
begin
FreeBitmap(BufRp^.Bitmap);
BufRp^.Bitmap := AllocBitmap(VideoWindow^.GZZWidth, VideoWindow^.GZZHeight, VideoWindow^.RPort^.Bitmap^.Depth, BMF_CLEAR, VideoWindow^.RPort^.Bitmap);
BitmapWidth := VideoWindow^.GZZWidth;
BitmapHeight := VideoWindow^.GZZHeight;
Force := True;
Smallforce := True;
end;
{$endif}
BufCounter:=0;
NumChanged:=0;
if Smallforce then
begin
//t := now();
for CounterY := 0 to ScreenHeight - 1 do
begin
for CounterX := 0 to ScreenWidth - 1 do
begin
if (VideoBuf^[BufCounter] <> OldVideoBuf^[BufCounter]) or Force then
begin
{$ifdef WITHBUFFERING}
DrawChar(BufRp, CounterX, CounterY, crHidden);
{$else}
DrawChar(VideoWindow^.RPort, CounterX, CounterY, crHidden);
{$endif}
OldVideoBuf^[BufCounter] := VideoBuf^[BufCounter];
Inc(NumChanged);
end;
Inc(BufCounter);
end;
end;
//if NumChanged > 100 then
// writeln('redraw time: ', floattoStrF((Now-t)* 24 * 60 * 60 * 1000000 / NumChanged, fffixed, 8,3), ' us/char' ); // ms
end;
if (CursorType <> OldCursorType) or
(CursorX <> OldCursorX) or (CursorY <> OldCursorY) or
SmallForce then
begin
{$ifdef WITHBUFFERING}
DrawChar(BufRp, OldCursorY, OldCursorX, crHidden);
DrawChar(BufRp, CursorY, CursorX, CursorType);
{$else}
DrawChar(VideoWindow^.RPort, OldCursorY, OldCursorX, crHidden);
DrawChar(VideoWindow^.RPort, CursorY, CursorX, CursorType);
{$endif}
OldCursorX := CursorX;
OldCursorY := CursorY;
OldcursorType := CursorType;
end;
{$ifdef WITHBUFFERING}
BltBitMapRastPort(BufRp^.Bitmap, 0, 0, VideoWindow^.RPort, 0, 0, ScreenWidth * 8, ScreenHeight * 16, $00C0);
{$endif}
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
SysGetCursorType := cursorType;
end;
procedure SysSetCursorType(NewType: Word);
begin
cursorType := newType;
{ FIXME: halfBlock cursors are not supported for now
by the rendering code }
if CursorType = crHalfBlock then
cursorType := crBlock;
SysUpdateScreen(False);
end;
// Amiga specific calls
procedure GotCloseWindow;
begin
GotCloseWindowMsg := True;
end;
function HasCloseWindow: Boolean;
begin
HasCloseWindow := GotCloseWindowMsg;
GotCloseWindowMsg := False;
end;
procedure GotResizeWindow;
begin
GotResizeWindowMsg := True;
end;
function HasResizeWindow(var WinW: LongInt; var WinH: LongInt): Boolean;
begin
//writeln('Has resize ', GotResizeWindowMsg);
WinW := 0;
WinH := 0;
HasResizeWindow := GotResizeWindowMsg;
if Assigned(VideoWindow) then
begin
//writeln('resize');
WinW := VideoWindow^.GZZWidth div 8;
WinH := VideoWindow^.GZZHeight div 16;
LastW := WinW;
LastH := WinH;
end;
GotResizeWindowMsg := False;
end;
function SysGetVideoModeCount: Word;
begin
SysGetVideoModeCount := 2;
end;
function SysGetVideoModeData(Index: Word; var Mode: TVideoMode): Boolean;
var
Screen: PScreen;
begin
case Index of
0: begin
Mode.Col := 80;
Mode.Row := 25;
Mode.Color := True;
end;
1: begin
Screen := LockPubScreen('Workbench');
Mode.Col := Screen^.Width div 8;
Mode.Row := Screen^.Height div 16;
UnlockPubScreen('Workbench', Screen);
Mode.Color := False;
end;
end;
SysGetVideoModeData := True;
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);
LastT := 50;
LastL := 50;
LastW := 80;
LastH := 25;
{$ifdef WITHBUFFERING}
BufRp := CreateRastPort;
BufRp^.Layer := nil;
BufRp^.Bitmap := nil;
{$endif}
finalization
{$ifdef WITHBUFFERING}
if Assigned(BufRp^.Bitmap) then
FreeBitmap(BufRp^.Bitmap);
FreeRastPort(BufRp);
{$endif}
end.

650
packages/rtl-console/src/morphos/video.pp
View File

@ -1,650 +0,0 @@
{
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;
{.$define VIDEODEBUG}
{.$define WITHBUFFERING}
{
Date: 2013-01-09
What: Adjusted FPC video unit for AROS (/AmigaOS?)
goal:
---------------------------------------------------------------------------
Attempt to add user-on-demand support for AROS Fullscreen to the FPC video
unit.
DISCLAIMER:
Experimental code only meant as PoC.
DON'T USE FOR PUBLICATION UNLESS ALL PERSONAL COMMENTS AND REFERENCES ARE
REMOVED AND THE ACTUAL CODE IS APPROVED BY SOMEONE THAT KNOWS WHAT HE/SHE
IS DOING.
THIS CODE IS PROOF OF CONCEPT ONLY AND AS SUCH DOES NOT PROVIDE 100%
RELIABLE CODE AND/OR APPROVED PROGRAMMING TECHNIQUES.
Idea:
The idea of running a video-unit screen on its own graphical screen
emerged from ALB42's port of the dos-based fp-editor that is distributed
with freepascal. In it's original form the editor would be run from dos
and would present itself in a full-screen modus fashion.
This behaviour changed slightly with the ending of the dos era, and
instead a commando window started to appear in regular OS'.
But even when this changed, Windows users were still able to view this
command window in full-screen by means of pressing ctrl-enter.
Since this behaviour is not present on current next gen amigaOS systems,
we have to live without that.
And so begun the idea of letting the video-unit somehow be influenced
in such a way that an Freevision application that uses the videounit
could be shown in fullscreen.
In order to accomplish this task we missuse the color tag of TVideomode.
When the color is set to monochrome it will show the
dos-screen on a full graphics screen and the dos-output will be shown
in a borderless backdrop window. That way it appears that the vision
application is running full-screen.
The current implementation has a limitation that cannot be solved.
Namely, the vision screens are based on a ascii character screen, so
the final measurements of the full-screen-window will depend
on the amount of pixels that maximally can be displayed by means of
those same character-sizes.
Since the used font is currently 8 pixels width and 16 pixels high,
it becomes clear that not every screen-resolution is suitable to
exactly fit both dimensions pixelwise. As a result a small
stripe (of default backgroundcolor) on the bottom or right may appear.
HAVE FUN !
MaGoRiuM
}
interface
uses
amigados, intuition, {tagsarray,} utility, sysutils;
{$i videoh.inc}
{ Amiga specific calls, to help interaction between Keyboard, Mouse and
Video units, and Free Vision }
procedure GotCloseWindow;
function HasCloseWindow: boolean;
procedure GotResizeWindow;
function HasResizeWindow(var winw:longint; var winh: longint): boolean;
var
VideoWindow: PWindow;
implementation
uses
exec, agraphics;
{$i video.inc}
{$i videodata.inc}
const
VIDEOSCREENNAME = 'FPC Video Screen Output';
var
OS_Screen : PScreen = nil; // To hold our screen, when necessary
FPC_VIDEO_FULLSCREEN : Boolean = False; // Global that defines when we need to attempt opening on own scren
var
VideoColorMap : PColorMap;
VideoPens : array[0..15] of LongInt;
OldCursorX,
OldCursorY : LongInt;
CursorType : Word;
OldCursorType : Word;
{$ifdef WITHBUFFERING}
BitmapWidth, BitmapHeight: Integer;
BufRp: PRastPort;
{$endif}
GotCloseWindowMsg : Boolean;
GotResizeWindowMsg : Boolean;
LastL, LastT: Integer;
LastW, LastH: Integer;
WindowForReqSave: PWindow;
Process: PProcess;
(*
GetScreen: pScreen;
Tries to open a custom screen, which attempt to clone the workbench,
and returns the pointer to the screen. Result can be nil when failed
otherwise the screen got opened correctly.
*)
Function GetScreen: pScreen;
begin
GetScreen:=OpenScreenTags(nil,[
SA_Title , DWord(PChar(VIDEOSCREENNAME)),
SA_Left , 0,
SA_Top , 0,
SA_ShowTitle , 0, // Do not show the screen's TitleBar
SA_Type , PUBLICSCREEN_F,
SA_PubName , DWord(PChar(VIDEOSCREENNAME)),
SA_Quiet , 1,
SA_LikeWorkbench , 1 // Let OS
]);
{$ifdef VIDEODEBUG}
if (GetScreen <> nil) then
Writeln('DEBUG: Opened a new screen')
else
Writeln('ERROR: Failed to open new screen');
{$endif}
end;
(*
GetWindow: pWindow;
Tries to create and open a window. Returns the pointer to
the window or nil in case of failure.
The routine keeps the global FPC_FULL_SCREEM option into
account and act accordingly.
In windowed mode it returns a window with another kind of
settings then when it has to reside on it's own customscreen.
*)
Function GetWindow: PWindow;
begin
GetWindow:=nil;
if FPC_VIDEO_FULLSCREEN then
begin
OS_Screen := GetScreen;
If OS_Screen = nil then
Exit;
{$ifdef VIDEODEBUG}
WriteLn('DEBUG: Opened customscreen succesfully');
{$endif}
GetWindow:=OpenWindowTags(nil, [
WA_CustomScreen, PtrUInt(OS_Screen),
WA_Left , 0,
WA_Top , 0,
WA_InnerWidth , (OS_Screen^.Width div 8) * 8,
WA_InnerHeight, (OS_Screen^.Height div 16) * 16,
WA_AutoAdjust , 1,
WA_Activate , 1,
WA_Borderless , 1,
WA_BackDrop , 1,
WA_FLAGS , (WFLG_GIMMEZEROZERO or WFLG_REPORTMOUSE or WFLG_RMBTRAP or
WFLG_SMART_REFRESH or WFLG_NOCAREREFRESH),
WA_IDCMP , (IDCMP_RAWKEY or
IDCMP_MOUSEMOVE or IDCMP_MOUSEBUTTONS or
IDCMP_CHANGEWINDOW or IDCMP_CLOSEWINDOW)
]);
end else
begin // Windowed Mode
GetWindow:=OpenWindowTags(nil,[
WA_Left , LastL,
WA_Top , LastT,
WA_InnerWidth , LastW*8,
WA_InnerHeight, LastH*16,
WA_MaxWidth , 32768,
WA_MaxHeight , 32768,
WA_Title , PtrUInt(PChar('FPC Video Window Output')),
WA_Activate , 1,
WA_FLAGS , (WFLG_GIMMEZEROZERO or WFLG_REPORTMOUSE or
WFLG_SMART_REFRESH or WFLG_NOCAREREFRESH or
WFLG_DRAGBAR or WFLG_DEPTHGADGET or WFLG_SIZEGADGET or
WFLG_SIZEBBOTTOM or WFLG_RMBTRAP or WFLG_CLOSEGADGET),
WA_IDCMP , (IDCMP_RAWKEY or
IDCMP_MOUSEMOVE or IDCMP_MOUSEBUTTONS or
IDCMP_CHANGEWINDOW or IDCMP_CLOSEWINDOW)//,
]);
end;
Process := PProcess(FindTask(nil));
WindowForReqSave := Process^.pr_WindowPtr;
Process^.pr_WindowPtr := GetWindow;
{$ifdef VIDEODEBUG}
If GetWindow <> nil then
WriteLn('DEBUG: Sucessfully opened videounit Window')
else
WriteLn('ERROR: Failed to open videounit Window');
{$endif}
end;
// ==========================================================================
// ==
// == Original source code continues, with minor adjustments
// ==
// ==========================================================================
procedure SysInitVideo;
var
Counter: LongInt;
begin
InitGraphicsLibrary;
InitIntuitionLibrary;
{$ifdef VIDEODEBUG}
WriteLn('FULLSCREEN VIDEO UNIT MODIFICATION v2');
if FPC_VIDEO_FULLSCREEN then
WriteLn('DEBUG: Recognized fullscreen mode')
else
WriteLn('DEBUG: Recognized windowed mode');
{$endif}
// fill videobuf and oldvideobuf with different bytes, to allow proper first draw
FillDword(VideoBuf^, VideoBufSize div 4, $1234D3AD);
FillDword(OldVideoBuf^, VideoBufSize div 4, $4321BEEF);
VideoWindow := GetWindow;
// nice hardcode values are probably going to screw up things
// so wee neeed a way to detrmined how many chars could be on
// the screen in both directions. And a bit accurate.
if FPC_VIDEO_FULLSCREEN then
begin
// just to make sure that we are going to use the window width
// and height instead of the one from the screen.
// This is to circumvent that the window (or virtual window from
// vision based on characters pixels * characters in both
// dimensions) is actually smaller then the window it resides on.
//
// Can happen for instance when the window does not hide it's
// borders or title as intended.
ScreenWidth := VideoWindow^.GZZWidth div 8;
ScreenHeight := VideoWindow^.GZZHeight div 16;
ScreenColor := False;
{$ifdef VIDEODEBUG}
Writeln('DEBUG: Fullscreen - windowed - Width * Heigth = ',ScreenWidth,' * ',ScreenHeight);
{$endif}
end else
begin
ScreenWidth := LastW;
ScreenHeight := LastH;
ScreenColor := True;
end;
{$ifdef WITHBUFFERING}
BufRp^.Bitmap := AllocBitmap(VideoWindow^.GZZWidth, VideoWindow^.GZZHeight, VideoWindow^.RPort^.Bitmap^.Depth, BMF_CLEAR, VideoWindow^.RPort^.Bitmap);
BitmapWidth := VideoWindow^.GZZWidth;
BitmapHeight := VideoWindow^.GZZHeight;
{$endif}
{ viewpostcolormap info }
videoColorMap := pScreen(videoWindow^.WScreen)^.ViewPort.ColorMap;
for Counter := 0 to 15 do
begin
VideoPens[Counter] := ObtainPen(VideoColorMap, LongWord(-1),
vgacolors[counter, 0] shl 24, vgacolors[counter, 1] shl 24, vgacolors[counter, 2] shl 24,
PEN_EXCLUSIVE);
{$ifdef VIDEODEBUG}
If VideoPens[Counter] = -1 then
WriteLn('errr color[',Counter,'] = ', VideoPens[Counter])
else
WriteLn('good color[',Counter,'] = ', VideoPens[Counter]);
{$endif}
end;
CursorX := 0;
CursorY := 0;
OldCursorX := 0;
OldCursorY := 0;
CursorType := crHidden;
OldCursorType := crHidden;
GotCloseWindowMsg := false;
GotResizeWindowMsg := false;
end;
procedure SysDoneVideo;
var
Counter: LongInt;
begin
if VideoWindow <> nil then
begin
Process^.pr_WindowPtr := WindowForReqSave;
if not FPC_VIDEO_FULLSCREEN then
begin
LastL := VideoWindow^.LeftEdge;
LastT := VideoWindow^.TopEdge;
end;
CloseWindow(videoWindow);
end;
{$ifdef WITHBUFFERING}
FreeBitmap(BufRp^.Bitmap);
BufRp^.Bitmap := nil;
{$endif}
VideoWindow := nil;
for Counter := 0 to 15 do
ReleasePen(VideoColorMap, VideoPens[Counter]);
if ((FPC_VIDEO_FULLSCREEN) and (OS_Screen <> nil)) then
begin
CloseScreen(OS_Screen);
end;
end;
function SysSetVideoMode(const Mode: TVideoMode): Boolean;
var
dx: integer;
dy: integer;
begin
if ScreenColor <> Mode.Color then
begin
SysDoneVideo;
FPC_VIDEO_FULLSCREEN := not Mode.color;
if not FPC_VIDEO_FULLSCREEN then
begin
LastT := 50;
LastL := 50;
LastW := 80;
LastH := 25;
end;
SysInitVideo;
end else
if not FPC_VIDEO_FULLSCREEN then
begin
dx := (Mode.col * 8) - VideoWindow^.GZZWidth;
dy := (Mode.row * 16) - VideoWindow^.GZZHeight;
SizeWindow(videoWindow, dx, dy);
end;
ScreenWidth := Mode.col;
ScreenHeight := Mode.row;
LastW := Mode.Col;
LastH := Mode.Row;
ScreenColor := Mode.color;
SysSetVideoMode := True;
end;
var
OldSH, OldSW : longint;
procedure SysClearScreen;
begin
oldSH := -1;
oldSW := -1;
UpdateScreen(True);
end;
procedure DrawChar(rp: PRastPort; x, y: LongInt; crType: Word);
var
TmpCharData: Word;
TmpChar: Byte;
TmpFGColor: Byte;
TmpBGColor: Byte;
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;
sX := x * 8;
sY := y * 16;
if crType <> crBlock then
begin
SetABPenDrMd(rp, VideoPens[TmpFGColor], VideoPens[tmpBGColor], JAM2);
end else
begin
{ in case of block cursor, swap fg/bg colors
and BltTemplate() below will take care of everything }
SetABPenDrMd(rp, VideoPens[tmpBGColor], VideoPens[tmpFGColor], JAM2);
end;
BltTemplate(@Vgafont[tmpChar, 0], 0, 1, rp, sX, sY, 8, 16);
if crType = crUnderLine then
begin
{ draw two lines at the bottom of the char, in case of underline cursor }
agraphics.gfxMove(rp, sX, sY + 14); Draw(rp, sX + 7, sY + 14);
agraphics.gfxMove(rp, sX, sY + 15); Draw(rp, sX + 7, sY + 15);
end;
end;
procedure SysUpdateScreen(Force: Boolean);
var
BufCounter: Longint;
SmallForce: Boolean;
Counter, CounterX, CounterY: LongInt;
//BufRp: PRastPort;
t: Double;
NumChanged: Integer;
begin
SmallForce := False;
// override forced update when screen dimensions haven't changed
if Force then
begin
if (OldSH = ScreenHeight) and (OldSW = ScreenWidth) then
Force:=false
else
begin
OldSH := ScreenHeight;
OldSW := ScreenWidth;
end;
end;
if Force then
begin
SmallForce:=true;
end else
begin
Counter:=0;
while not smallforce and (Counter < (VideoBufSize div 4) - 1) do
begin
SmallForce := (PDWord(VideoBuf)[Counter] <> PDWord(OldVideoBuf)[Counter]);
inc(Counter);
end;
end;
{$ifdef WITHBUFFERING}
if (VideoWindow^.GZZWidth > BitmapWidth) or (VideoWindow^.GZZHeight > BitmapHeight) then
begin
FreeBitmap(BufRp^.Bitmap);
BufRp^.Bitmap := AllocBitmap(VideoWindow^.GZZWidth, VideoWindow^.GZZHeight, VideoWindow^.RPort^.Bitmap^.Depth, BMF_CLEAR, VideoWindow^.RPort^.Bitmap);
BitmapWidth := VideoWindow^.GZZWidth;
BitmapHeight := VideoWindow^.GZZHeight;
Force := True;
Smallforce := True;
end;
{$endif}
BufCounter:=0;
NumChanged:=0;
if Smallforce then
begin
//t := now();
for CounterY := 0 to ScreenHeight - 1 do
begin
for CounterX := 0 to ScreenWidth - 1 do
begin
if (VideoBuf^[BufCounter] <> OldVideoBuf^[BufCounter]) or Force then
begin
{$ifdef WITHBUFFERING}
DrawChar(BufRp, CounterX, CounterY, crHidden);
{$else}
DrawChar(VideoWindow^.RPort, CounterX, CounterY, crHidden);
{$endif}
OldVideoBuf^[BufCounter] := VideoBuf^[BufCounter];
Inc(NumChanged);
end;
Inc(BufCounter);
end;
end;
//if NumChanged > 100 then
// writeln('redraw time: ', floattoStrF((Now-t)* 24 * 60 * 60 * 1000000 / NumChanged, fffixed, 8,3), ' us/char' ); // ms
end;
if (CursorType <> OldCursorType) or
(CursorX <> OldCursorX) or (CursorY <> OldCursorY) or
SmallForce then
begin
{$ifdef WITHBUFFERING}
DrawChar(BufRp, OldCursorY, OldCursorX, crHidden);
DrawChar(BufRp, CursorY, CursorX, CursorType);
{$else}
DrawChar(VideoWindow^.RPort, OldCursorY, OldCursorX, crHidden);
DrawChar(VideoWindow^.RPort, CursorY, CursorX, CursorType);
{$endif}
OldCursorX := CursorX;
OldCursorY := CursorY;
OldcursorType := CursorType;
end;
{$ifdef WITHBUFFERING}
BltBitMapRastPort(BufRp^.Bitmap, 0, 0, VideoWindow^.RPort, 0, 0, ScreenWidth * 8, ScreenHeight * 16, $00C0);
{$endif}
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
SysGetCursorType := cursorType;
end;
procedure SysSetCursorType(NewType: Word);
begin
cursorType := newType;
{ FIXME: halfBlock cursors are not supported for now
by the rendering code }
if CursorType = crHalfBlock then
cursorType := crBlock;
SysUpdateScreen(False);
end;
// Amiga specific calls
procedure GotCloseWindow;
begin
GotCloseWindowMsg := True;
end;
function HasCloseWindow: Boolean;
begin
HasCloseWindow := GotCloseWindowMsg;
GotCloseWindowMsg := False;
end;
procedure GotResizeWindow;
begin
GotResizeWindowMsg := True;
end;
function HasResizeWindow(var WinW: LongInt; var WinH: LongInt): Boolean;
begin
WinW := 0;
WinH := 0;
HasResizeWindow := GotResizeWindowMsg;
if Assigned(VideoWindow) then
begin
//writeln('resize');
WinW := VideoWindow^.GZZWidth div 8;
WinH := VideoWindow^.GZZHeight div 16;
LastW := WinW;
LastH := WinH;
end;
GotResizeWindowMsg := False;
end;
function SysGetVideoModeCount: Word;
begin
SysGetVideoModeCount := 2;
end;
function SysGetVideoModeData(Index: Word; var Mode: TVideoMode): Boolean;
var
Screen: PScreen;
begin
case Index of
0: begin
Mode.Col := 80;
Mode.Row := 25;
Mode.Color := True;
end;
1: begin
Screen := LockPubScreen('Workbench');
Mode.Col := Screen^.Width div 8;
Mode.Row := Screen^.Height div 16;
UnlockPubScreen('Workbench', Screen);
Mode.Color := False;
end;
end;
SysGetVideoModeData := True;
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);
LastT := 50;
LastL := 50;
LastW := 80;
LastH := 25;
{$ifdef WITHBUFFERING}
BufRp := CreateRastPort;
BufRp^.Layer := nil;
BufRp^.Bitmap := nil;
{$endif}
finalization
{$ifdef WITHBUFFERING}
if Assigned(BufRp^.Bitmap) then
FreeBitmap(BufRp^.Bitmap);
FreeRastPort(BufRp);
{$endif}
end.