* OS/2 implementation almost finished, not debugged yet

api/os2/video.inc

@@ -1,340 +1,330 @@
 {
-
-  System independent low-level video interface for os/2
-
-
+  System independent low-level video interface for OS/2
 
   $Id$
-
 }
 
-
-
 uses
 {$IFDEF PPC_FPC}
- VioCalls;
+ DosCalls, VioCalls;
 {$ELSE}
  {$IFDEF PPC_VIRTUAL}
  Os2Base;
  {$ENDIF}
 {$ENDIF}
 
+const
+    InitVideoCalled: boolean = false;
+    OrigEmpty: boolean = false;
+    LastCursorType: word = crUnderline;
+    EmptyCell: cardinal = $0720;
+
+{$IFDEF PPC_VIRTUAL}
+type
+    TVioCursorInfo = VioCursorInfo;
+    TVioModeInfo = VioModeInfo;
+    TVioIntensity = VioIntensity;
+{$ENDIF}
 
-
-var videobuf:Pvideobuf;
-
-    videobufsize:cardinal;
-
-    lastcursortype:word=crunderline;
-
-    cell_width,cell_height:word;
-
+var OrigCurType: TVioCursorInfo;
+    OrigVioMode: TVioModeInfo;
+    OrigHighBit: TVioIntensity;
+    CellHeight: byte;
 
 
 {$ASMMODE ATT}
 
+procedure CheckCellHeight;
 
-
-procedure update_cell_size;
-
-
+var OldCD, CD: TVioCursorInfo;
 
 begin
+    VioGetCurType (OldCD, 0);
+    Move (OldCD, CD, SizeOf (CD));
+    with CD do
+        begin
+            Attr := 0;
+            yStart := word (-90);
+            cEnd := word (-100);
+        end;
+    VioSetCurType (CD, 0);
+    VioGetCurType (CD, 0);
+    CellHeight := CD.cEnd;
+    VioSetCurType (OldCD, 0);
+end;
 
-    {This function cannot fail when the default handle is used.}
 
-    viogetdevicecellsize(cell_height,cell_width,0);
+procedure RegisterVideoModes;
+begin
+{ BW modes are rejected on my (colour) configuration. I can't imagine
+  OS/2 running on MCGA anyway... ;-)
 
+    RegisterVideoMode (40, 25, False, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (80, 25, False, @DefaultVideoModeSelector, 0);
+}
+    RegisterVideoMode (40, 25, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (80, 25, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (80, 30, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (80, 43, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (80, 50, True, @DefaultVideoModeSelector, 0);
+
+{ The following modes wouldn't work on plain VGA; is it useful to check
+  for their availability on the program startup?
+
+    RegisterVideoMode (132, 25, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (132, 30, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (132, 43, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (132, 50, True, @DefaultVideoModeSelector, 0);
+}
 end;
 
 
+procedure SetHighBitBlink (Blink: boolean);
 
-procedure initvideo;
-
-
+var VI: TVioIntensity;
 
 begin
-
-    initvideocalled:=true;
-
-    {Get the address of the videobuffer.}
-
-    if viogetbuf(videobuf,videobufsize,0)=0 then
-
+    with VI do
         begin
+            cb := 6;
+            rType := 2;
+            fs := byte (not (Blink));
+        end;
+    VioSetState (VI, 0);
+end;
 
-            update_cell_size;
 
-            sethighbitblink;
+procedure InitVideo;
 
-            setcursortype(lastcursortype);
+var P: PVideoModeList;
+    MI: TVioModeInfo;
 
+begin
+    InitVideoCalled := true;
+    VideoBufSize := 0;
+    MI.cb := SizeOf (MI);
+    VioGetMode (MI, 0);
+    if OrigEmpty then
+        begin
+{Remember original video mode, cursor type and high bit behaviour setting}
+            Move (MI, OrigVioMode, SizeOf (OrigVioMode));
+            VioGetCurType (OrigCurType, 0);
+            with OrigHighBit do
+                begin
+                    cb := 6;
+                    rType := 2;
+                end;
+            VioGetState (OrigHighBit, 0);
+{Register the curent video mode in Modes if not there yet}
+            with OrigVioMode do
+                begin
+                    P := Modes;
+                    while (P <> nil) and ((P^.Row <> Row) or (P^.Col <> Col)
+                                      or (P^.Color <> (Color >= Colors_16))) do
+                        P := P^.Next;
+                    if P = nil then
+{Assume we have at least 16 colours available in "colour" modes}
+                        RegisterVideoMode (Col, Row, Color >= Colors_16,
+                                                 @DefaultVideoModeSelector, 0);
+                end;
+        end;
+    with MI do
+        begin
+            ScreenWidth := Col;
+            ScreenHeight := Row;
+            ScreenColor := Color >= Colors_16;
+        end;
+    VioGetCurPos (CursorY, CursorX, 0);
+    LowAscii := true;
+    SetCursorType (LastCursorType);
+{Get the address of the videobuffer.}
+    if VioGetBuf (VideoBuf, PWord (VideoBufSize)^, 0) = 0 then
+        begin
+            VideoBuf := SelToFlat (TFarPtr (VideoBuf));
+            SetHighBitBlink (true);
         end
-
     else
-
-        errcode:=errvioinit;
-
+        ErrorHandler (errVioInit, nil);
 end;
 
 
-
-procedure setcursorpos(newcursorx,newcursory:word);
-
-
+procedure SetCursorPos (NewCursorX, NewCursorY: word);
 
 begin
-
-    if viosetcurpos(newcursory,newcursorx,0)<>0 then
-
-        {Do not set an error code; people should fix invalid newcursorx or
-
-         newcursory values when designing, there is no need for detecting
-
+    if VioSetCurPos (NewCursorY, NewCursorX, 0) = 0 then
+        begin
+            CursorX := NewCursorX;
+            CursorY := NewCursorY;
+        end
+    else
+        {Do not set an error code; people should fix invalid NewCursorX
+         or NewCursorY values when designing, there is no need for detecting
          these errors at runtime.}
-
-        runerror(225);
-
+        RunError (225);
 end;
 
 
+function GetCursorType: word;
 
-function getcursortype:word;
-
-
-
-var cd:Tviocursorinfo;
-
-
+var CD: TVioCursorInfo;
 
 begin
-
-    viogetcurtype(cd,0);    {Never fails, because handle is default handle.}
-
-    if cd.attr=-1 then
-
-        getcursortype:=crhidden
-
-    else
-
-        {Because the cursor's start and end lines are returned, we'll have
-
-         to guess heuristically what cursor type we have.}
-
-        case cd.cend-cd.ystart of
-
-            0:
-
-                {Propably this does not occur, but you'll never know.}
-
-                getcursortype:=crhidden;
-
-            1..cell_height div 4:
-
-                getcursortype=crunderline;
-
-            cell_height div 4..cell_height div 2:
-
-                getcursortype:=crhalfblock;
-
+    VioGetCurType (CD, 0);    {Never fails, because handle is default handle.}
+    with CD do
+        begin
+            CursorLines := Succ (cEnd) - yStart;
+            if Attr = word (-1) then
+                GetCursorType := crHidden
             else
-
-                getcursortype:=crblock;
-
+{Because the cursor's start and end lines are returned, we'll have
+ to guess heuristically what cursor type we have.}
+                if CursorLines = 0 then
+{Probably this does not occur, but you'll never know.}
+                    GetCursorType := crHidden
+                else if CursorLines <= Succ (CellHeight div 4) then
+                    GetCursorType := crUnderline
+                else if CursorLines <= Succ (CellHeight div 2) then
+                    GetCursorType := crHalfBlock
+                else
+                    GetCursorType := crBlock;
         end;
-
-end;
-
-
-
-procedure setcursortype;
-
-
-
-begin
-
 end;
 
 
+procedure SetCursorType (NewType: word);
 
-procedure donevideo;
-
-
+var CD: TVioCursorInfo;
 
 begin
-
-    If initvideocalled then
-
+    VioGetCurType (CD, 0);
+    with CD do
         begin
-
-            lastcursortype:=getcursortype;
-
-            clearscreen;
-
-            setcursortype(crunderline);
-
-            setcursorpos(0,0);
-
-            initvideocalled:=false;
-
-            videobufsize:=0;
-
+            case NewType of
+                crHidden: Attr := word (-1);
+                crUnderline:
+                    begin
+                        yStart := word (-90);
+                        cEnd := word (-100);
+                    end;
+                crHalfBlock:
+                    begin
+                        yStart := word (-50);
+                        cEnd := word (-100);
+                    end;
+                crBlock:
+                    begin
+                        yStart := 0;
+                        cEnd := word (-100);
+                    end;
+            end;
+            VioSetCurType (CD, 0);
+            VioGetCurType (CD, 0);
+            CursorLines := Succ (cEnd) - yStart;
         end;
-
-end;
-
-
-
-
-
-function GetCapabilities: Word;
-
-
-
-begin
-
-  GetCapabilities := $3F;
-
-end;
-
-
-
-
-
-procedure SetCursorPos(NewCursorX, NewCursorY: Word);
-
-
-
-begin
-
 end;
 
 
-
-
-
-function GetCursorType: Word;
-
-
+procedure DoneVideo;
 
 begin
-
+    if InitVideoCalled then
+        begin
+            LastCursorType := GetCursorType;
+            ClearScreen;
+{Restore original settings}
+            VioSetMode (OrigVioMode, 0);
+            CheckCellHeight;
+{Set CursorX and CursorY}
+            SetCursorPos (0, 0);
+            VioSetState (OrigHighBit, 0);
+            VioSetCurType (OrigCurType, 0);
+            VideoBufSize := 0;
+            InitVideoCalled := false;
+        end;
 end;
 
 
-
-
-
-procedure SetCursorType(NewType: Word);
-
-
+function GetCapabilities: word;
 
 begin
-
+    GetCapabilities := $3F;
 end;
 
 
+function DefaultVideoModeSelector (const VideoMode: TVideoMode; Params: longint): boolean;
 
-
-
-function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean;
-
-
+var OldMI, MI: TVioModeInfo;
 
 begin
-
+    OldMI.cb := SizeOf (OldMI);
+    if VioGetMode (OldMI, 0) <> 0 then
+        DefaultVideoModeSelector := false
+    else
+        begin
+            with MI do
+                begin
+                    cb := 8;
+                    fbType := 0;
+                    if VideoMode.Color then
+                        Color := Colors_16
+                    else
+                        Color := Colors_2;
+                    Col := VideoMode.Col;
+                    Row := VideoMode.Row;
+                end;
+            if VioSetMode (MI, 0) = 0 then
+                if VioGetBuf (VideoBuf, PWord (VideoBufSize)^, 0) = 0 then
+                    begin
+                        VideoBuf := SelToFlat (TFarPtr (VideoBuf));
+                        DefaultVideoModeSelector := true;
+                        SetHighBitBlink (true);
+                        CheckCellHeight;
+                        SetCursorType (LastCursorType);
+                        ClearScreen;
+                    end
+                else
+                    begin
+                        DefaultVideoModeSelector := false;
+                        VioSetMode (OldMI, 0);
+                        VioGetBuf (VideoBuf, PWord (VideoBufSize)^, 0);
+                        VideoBuf := SelToFlat (TFarPtr (VideoBuf));
+                        SetHighBitBlink (true);
+                        CheckCellHeight;
+                        SetCursorType (LastCursorType);
+                        ClearScreen;
+                    end
+            else
+                begin
+                    DefaultVideoModeSelector := false;
+                    VioGetBuf (VideoBuf, PWord (VideoBufSize)^, 0);
+                    VideoBuf := SelToFlat (TFarPtr (VideoBuf));
+                    SetHighBitBlink (true);
+                    SetCursorType (LastCursorType);
+                end;
+        end;
 end;
 
 
-
-
-
 procedure ClearScreen;
 
-
-
-begin
-
-end;
-
-
-
-
-
-procedure UpdateScreen(Force: Boolean);
-
 begin
-
-  if LockUpdateScreen<>0 then
-
-   exit;
-
-  if not force then
-
-   begin
-
-	 asm
-
-		movl    VideoBuf,%esi
-
-		movl    OldVideoBuf,%edi
-
-		movl    VideoBufSize,%ecx
-
-		shrl    $2,%ecx
-
-		repe
-
-		cmpsl
-
-		orl     %ecx,%ecx
-
-		jz      .Lno_update
-
-		movb    $1,force
-
-.Lno_update:
-
-	 end;
-
-   end;
-
-  if Force then
-
-   begin
-
-	 dosmemput(videoseg,0,videobuf^,VideoBufSize);
-
-	 move(videobuf^,oldvideobuf^,VideoBufSize);
-
-   end;
-
+    VioScrollDown (0, 0, word (-1), word (-1), 0, PWord (@EmptyCell)^, 0);
 end;
 
 
-
-
-
-procedure RegisterVideoModes;
-
+procedure UpdateScreen (Force: boolean);
 begin
-
-  RegisterVideoMode(40, 25, False, DefaultVideoModeSelector, $00000000);
-
-  RegisterVideoMode(40, 25, True, DefaultVideoModeSelector, $00000001);
-
-  RegisterVideoMode(80, 25, False, DefaultVideoModeSelector, $00000002);
-
-  RegisterVideoMode(80, 25, True, DefaultVideoModeSelector, $00000003);
-
+    VioShowBuf (0, VideoBufSize, 0);
 end;
 
 
-
 {
 
   $Log$
-  Revision 1.2  2000-07-13 11:32:26  michael
+  Revision 1.3  2000-09-24 19:53:03  hajny
+    * OS/2 implementation almost finished, not debugged yet
+
+  Revision 1.2  2000/07/13 11:32:26  michael
   + removed logs
  
 }