Amiga: rtl-console and fv now builds for classic Amiga. It probably still nukes badly though, due to problems in the age-old AmUnits interface units. To be fixed soon.

git-svn-id: trunk@28567 -

.gitattributes

@@ -6589,6 +6589,7 @@ 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/videodata.inc 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/Makefile.fpc.fpcmake

@@ -62,7 +62,7 @@ dirs_netware=rtl-console fv zlib unzip
 dirs_netwlibc=rtl-console fv zlib unzip
 dirs_palmos=palmunits
 dirs_go32v2=rtl-console fv graph unzip gdbint
-dirs_amiga=amunits
+dirs_amiga=amunits rtl-console fv
 dirs_morphos=morphunits rtl-console fv opengl sdl
 dirs_aros=arosunits rtl-console fv
 dirs_wii=libogcfpc

packages/fv/fpmake.pp

@@ -20,7 +20,7 @@ begin
     P.Author := 'Leon De Boer and Pierre Mueller';
     P.License := 'LGPL with modification, ';
     P.HomepageURL := 'www.freepascal.org';
-    P.OSes := [beos,haiku,freebsd,darwin,iphonesim,solaris,netbsd,openbsd,linux,win32,win64,os2,emx,netware,netwlibc,go32v2,morphos,aros,aix];
+    P.OSes := [beos,haiku,freebsd,darwin,iphonesim,solaris,netbsd,openbsd,linux,win32,win64,os2,emx,netware,netwlibc,go32v2,aix]+AllAmigaLikeOSes;
     P.Email := '';
     P.Description := 'Free Vision, a portable Turbo Vision clone.';
     P.NeedLibC:= false;
@@ -31,6 +31,7 @@ begin
     P.Dependencies.add('rtl-extra');
     P.Dependencies.add('morphunits',[morphos]);
     P.Dependencies.add('arosunits',[aros]);
+    P.Dependencies.add('amunits',[amiga]);
 
     T:=P.Targets.AddUnit('app.pas');
       with T.Dependencies do

packages/rtl-console/fpmake.pp

@@ -13,10 +13,10 @@ Const
   UnixLikes = AllUnixOSes -[QNX];
  
   WinEventOSes = [win32,win64];
-  KVMAll       = [emx,go32v2,MorphOS,aros,netware,netwlibc,os2,win32,win64]+UnixLikes;
+  KVMAll       = [emx,go32v2,netware,netwlibc,os2,win32,win64]+UnixLikes+AllAmigaLikeOSes;
   
-  // all full KVMers have crt too, except MorphOS and AROS
-  CrtOSes      = KVMALL+[msdos,WatCom]-[MorphOS,aros];
+  // all full KVMers have crt too, except Amigalikes
+  CrtOSes      = KVMALL+[msdos,WatCom]-AllAmigaLikeOSes;
   KbdOSes      = KVMALL+[msdos];
   VideoOSes    = KVMALL;
   MouseOSes    = KVMALL;
@@ -46,18 +46,19 @@ begin
     P.Dependencies.Add('rtl-extra'); // linux,android gpm.
     P.Dependencies.Add('morphunits',[morphos]);
     P.Dependencies.Add('arosunits',[aros]);
+    P.Dependencies.Add('amunits',[amiga]);
 
     P.SourcePath.Add('src/inc');
     P.SourcePath.Add('src/$(OS)');
     P.SourcePath.Add('src/darwin',[iphonesim]);
     P.SourcePath.Add('src/unix',AllUnixOSes);
     P.SourcePath.Add('src/os2commn',[os2,emx]);
-    P.SourcePath.Add('src/amicommon',[aros,morphos]);
+    P.SourcePath.Add('src/amicommon',AllAmigaLikeOSes);
     P.SourcePath.Add('src/win',WinEventOSes);
 
     P.IncludePath.Add('src/inc');
     P.IncludePath.Add('src/unix',AllUnixOSes);
-    P.IncludePath.add('src/amicommon',[aros,morphos]);
+    P.IncludePath.add('src/amicommon',AllAmigaLikeOSes);
     P.IncludePath.Add('src/$(OS)');
     P.IncludePath.Add('src/darwin',[iphonesim]);
 
@@ -86,7 +87,7 @@ begin
      begin
        AddInclude('videoh.inc');
        AddInclude('video.inc');
-       AddInclude('videodata.inc',[MorphOS]);
+       AddInclude('videodata.inc',AllAmigaLikeOSes);
        AddInclude('convert.inc',AllUnixOSes);
        AddInclude('nwsys.inc',[netware]);
      end;

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

@@ -0,0 +1,606 @@
+{
+    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.