freepascal.compiler/rtl/os2/video.pp

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by Florian Klaempfl
    member of the Free Pascal development team

    Video unit for OS/2

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
unit Video;

interface

{$i videoh.inc}

implementation

uses
  DosCalls, VioCalls;

{$i video.inc}


const
    LastCursorType: word = crUnderline;
    EmptyCell: cardinal = $0720;
    OrigScreen: PVideoBuf = nil;
    OrigScreenSize: cardinal = 0;

var OrigCurType: TVioCursorInfo;
    OrigVioMode: TVioModeInfo;
    OrigHighBit: TVioIntensity;
    OrigCurRow: word;
    OrigCurCol: word;
    CellHeight: byte;

procedure CheckCellHeight;

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;




procedure SetHighBitBlink (Blink: boolean);

var VI: TVioIntensity;

begin
    with VI do
        begin
            cb := 6;
            rType := 2;
            fs := byte (not (Blink));
        end;
    VioSetState (VI, 0);
end;


Var 
  SysVideoBuf : PVideoBuf;

procedure SysInitVideo;

var MI: TVioModeInfo;

begin
  MI.cb := SizeOf (MI);
  VioGetMode (MI, 0);
  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 (SysVideoBuf, PWord (@VideoBufSize)^, 0) = 0 then
    begin
    SysVideoBuf := SelToFlat (TFarPtr (SysVideoBuf));
    SetHighBitBlink (true);
    end
  else
    ErrorHandler (errVioInit, nil);
end;


procedure SysSetCursorPos (NewCursorX, NewCursorY: word);

begin
  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);
end;


function SysGetCursorType: word;

var CD: TVioCursorInfo;

begin
    VioGetCurType (CD, 0);    {Never fails, because handle is default handle.}
    with CD do
      begin
      CursorLines := Succ (cEnd) - yStart;
      if Attr = word (-1) then
         SysGetCursorType := crHidden
      else
       {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.}
           SysGetCursorType := crHidden
         else if CursorLines <= Succ (CellHeight div 4) then
           SysGetCursorType := crUnderline
         else if CursorLines <= Succ (CellHeight div 2) then
           SysGetCursorType := crHalfBlock
         else
           SysGetCursorType := crBlock;
   end;
end;


procedure SysSetCursorType (NewType: word);

var CD: TVioCursorInfo;

begin
  VioGetCurType (CD, 0);
  with CD do
    begin
    case NewType of
      crHidden: Attr := word (-1);
      crUnderline:
        begin
        Attr := 0;
        yStart := word (-90);
        cEnd := word (-100);
        end;
      crHalfBlock:
        begin
        Attr := 0;
        yStart := word (-50);
        cEnd := word (-100);
        end;
      crBlock:
        begin
        Attr := 0;
        yStart := 0;
        cEnd := word (-100);
        end;
    end;
    VioSetCurType (CD, 0);
    VioGetCurType (CD, 0);
    CursorLines := Succ (cEnd) - yStart;
    end;
end;


procedure SysDoneVideo;

var PScr: pointer;
    ScrSize: cardinal;

begin
  LastCursorType := GetCursorType;
  ClearScreen;
  {Restore original settings}
  VioSetMode (OrigVioMode, 0);
  CheckCellHeight;
{Set CursorX and CursorY}
  SetCursorPos (0, 0);
  VioSetState (OrigHighBit, 0);
  VioSetCurType (OrigCurType, 0);
  VioSetCurPos (OrigCurRow, OrigCurCol, 0);
  if (OrigScreenSize <> 0) and (OrigScreen <> nil) then
    begin
    ScrSize := 0;
    if (VioGetBuf (PScr, PWord (@ScrSize)^, 0) = 0) and 
       (ScrSize = OrigScreenSize) then
      begin
      PScr := SelToFlat (TFarPtr (PScr));
      Move (OrigScreen^, PScr^, OrigScreenSize);
      VioShowBuf (0, ScrSize, 0);
      end;
    end;
end;


function SysGetCapabilities: word;

begin
  SysGetCapabilities := $3F;
end;


function SysVideoModeSelector (const VideoMode: TVideoMode): boolean;

var OldMI, MI: TVioModeInfo;

begin
  OldMI.cb := SizeOf (OldMI);
  if VioGetMode (OldMI, 0) <> 0 then
    SysVideoModeSelector := false
  else
    begin
    with MI do
      begin
      cb := 8;
      fbType := 1;
      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 (SysVideoBuf, PWord (@VideoBufSize)^, 0) = 0 then
        begin
        SysVideoBuf := SelToFlat (TFarPtr (SysVideoBuf));
        SysVideoModeSelector := true;
        SetHighBitBlink (true);
        CheckCellHeight;
        SetCursorType (LastCursorType);
        ClearScreen;
        end
      else
        begin
        SysVideoModeSelector := false;
        VioSetMode (OldMI, 0);
        VioGetBuf (SysVideoBuf, PWord (@VideoBufSize)^, 0);
        SysVideoBuf := SelToFlat (TFarPtr (SysVideoBuf));
        SetHighBitBlink (true);
        CheckCellHeight;
        SetCursorType (LastCursorType);
        ClearScreen;
        end
    else
      begin
      SysVideoModeSelector := false;
      VioGetBuf (SysVideoBuf, PWord (@VideoBufSize)^, 0);
      SysVideoBuf := SelToFlat (TFarPtr (SysVideoBuf));
      SetHighBitBlink (true);
      SetCursorType (LastCursorType);
      end;
    end;
end;

Const 
  SysVideoModeCount = 6;
  SysVMD : Array[0..SysVideoModeCount-1] of TVideoMode = (
   (Col: 40; Row: 25; Color: True),
   (Col: 80; Row: 25; Color: True),
   (Col: 80; Row: 30; Color: True),
   (Col: 80; Row: 43; Color: True),
   (Col: 80; Row: 50; Color: True),
   (Col: 80; Row: 25; Color: True) // Reserved for TargetEntry
  );

{ .MVC. were commented:
   BW modes are rejected on my (colour) configuration. I can't imagine
   OS/2 running on MCGA anyway... ;-)
   (Col: 40; Row: 25;Color: False),
   (Col: 80; Row: 25;Color: False),
   The following modes wouldn't work on plain VGA; is it useful to check
   for their availability on the program startup?
   (Col: 132;Row: 25;Color: True),
   (Col: 132;Row: 30;Color: True),
   (Col: 132;Row: 43;Color: True),
   (Col: 132;Row: 50;Color: True),
}

Function SysSetVideoMode (Const Mode : TVideoMode) : Boolean;

Var
  I : Integer;

begin
  I:=SysVideoModeCount-1;
  SysSetVideoMode:=False;
  While (I>=0) and Not SysSetVideoMode do
    If (Mode.col=SysVMD[i].col) and
       (Mode.Row=SysVMD[i].Row) and
       (Mode.Color=SysVMD[i].Color) then
      SysSetVideoMode:=True
    else
      Dec(I);  
  If SysSetVideoMode then
    begin
    SysVideoModeSelector(Mode);
    ScreenWidth:=SysVMD[I].Col;
    ScreenHeight:=SysVMD[I].Row;
    ScreenColor:=SysVMD[I].Color;
    end;
end;
  
Function SysGetVideoModeData (Index : Word; Var Data : TVideoMode) : boolean;

begin
  SysGetVideoModeData:=(Index<=SysVideoModeCount);
  If SysGetVideoModeData then
    Data:=SysVMD[Index];
end;

Function SysGetVideoModeCount : Word;

begin
  SysGetVideoModeCount:=SysVideoModeCount;
end;

procedure SysClearScreen;

begin
  VioScrollDn (0, 0, word (-1), word (-1), word (-1), PWord (@EmptyCell)^, 0);
  Move (VideoBuf^, OldVideoBuf^, VideoBufSize);
end;


{$ASMMODE INTEL}

procedure SysUpdateScreen (Force: boolean);

var SOfs, CLen: cardinal;

begin
  if not (Force) then
    asm
    cld
    mov esi, VideoBuf
    mov edi, OldVideoBuf
    mov eax, VideoBufSize
    mov ecx, eax
    shr ecx, 1
    shr ecx, 1
    repe
    cmpsd
    je @no_update
    inc ecx
    mov edx, eax
    mov ebx, ecx
    shl ebx, 1
    shl ebx, 1
    sub edx, ebx
    mov SOfs, edx
    mov Force, 1
    std
    mov edi, eax
    mov esi, VideoBuf
    add eax, esi
    sub eax, 4
    mov esi, eax
    mov eax, OldVideoBuf
    add eax, edi
    sub eax, 4
    mov edi, eax
    repe
    cmpsd
    inc ecx
    shl ecx, 1
    shl ecx, 1
    mov CLen, ecx
@no_update:
    end
  else
    begin
    SOfs := 0;
    CLen := VideoBufSize;
    end;
  // .MVC. Move video buffer to system video buffer.
  Move(VideoBuf^,SysVideoBuf^,VideoBufSize);
  if Force then
    begin
    VioShowBuf (SOfs, CLen, 0);
    Move (VideoBuf^ [SOfs div SizeOf (TVideoCell)],
          OldVideoBuf^ [SOfs div SizeOf (TVideoCell)], CLen);
    end;
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
  );

procedure TargetEntry;

var
  PScr: pointer;

begin
{Remember original video mode, cursor type and high bit behaviour setting}
  OrigVioMode.cb := SizeOf (OrigVioMode);
  VioGetMode (OrigVioMode, 0);
  VioGetCurType (OrigCurType, 0);
  VioGetCurPos (OrigCurRow, OrigCurCol, 0);
  with OrigHighBit do
    begin
    cb := 6;
    rType := 2;
    end;
  VioGetState (OrigHighBit, 0);
  { Register the curent video mode in reserved slot in System Modes}
  with OrigVioMode do
    begin
    {Assume we have at least 16 colours available in "colour" modes}
    SysVMD[SysVideoModeCount-1].Col:=Col;
    SysVMD[SysVideoModeCount-1].Row:=Row;
    SysVMD[SysVideoModeCount-1].Color:=(Color >= Colors_16);
    end;
  {Get the address of the original videobuffer and size.}
  if VioGetBuf (PScr, PWord (@OrigScreenSize)^, 0) = 0 then
    begin
    PScr := SelToFlat (TFarPtr (PScr));
    GetMem (OrigScreen, OrigScreenSize);
    Move (PScr^, OrigScreen^, OrigScreenSize);
    end;
end;


initialization
  SetVideoDriver(SysVideoDriver);
  TargetEntry;
end.

{
  $Log$
  Revision 1.6  2001-10-06 22:28:24  michael
  + Merged video mode selection/setting system

  Revision 1.5  2001/09/21 19:50:19  michael
  + Merged driver support from fixbranch

  Revision 1.4  2001/02/04 01:55:05  hajny
    * one more correction (not crucial)

  Revision 1.2.2.4  2001/10/06 22:23:40  michael
  + Better video mode selection/setting system

  Revision 1.2.2.3  2001/09/21 18:42:08  michael
  + Implemented support for custom video drivers.

  Revision 1.2.2.2  2001/02/04 02:02:28  hajny
    * corrections from the main branch merged

  Revision 1.3  2001/02/01 21:35:36  hajny
    * correction of a previously introduced bug

  Revision 1.2  2001/01/23 20:23:56  hajny
    * another little optimization of UpdateScreen

  Revision 1.1  2001/01/13 11:03:58  peter
    * API 2 RTL commit

}