Amiga-likes: huge keyboard/video unit rework

* 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 -

.gitattributes

@@ -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

packages/rtl-console/src/amicommon/keyboard.pp

@@ -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.

packages/rtl-console/src/amicommon/mouse.pp

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

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

@@ -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('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
-    //writeln('resize');
-    WinW := VideoWindow^.GZZWidth div 8;
-    WinH := VideoWindow^.GZZHeight div 16;
-    LastW := WinW;
-    LastH := WinH;
+    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;

packages/rtl-console/src/aros/video.pp

@@ -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.

packages/rtl-console/src/morphos/video.pp

@@ -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.