Power-Programmierung/CD1.mdf/pascal/library/dos/shazam/gvideo.imp

Text File | 1992-09-01 | 7.9 KB | 257 lines

   {*******************************************************************

   GVIDEO.IMP

   *******************************************************************}
   {===================================================================

   BORDER.  Color Range is 0..15 (same as CRT unit constants)

   0-Black   4-Red         8-DarkGray     12-LightRed
   1-Blue    5-Magenta     9-LightBlue    13-LightMagenta
   2-Green   6-Brown      10-LightGreen   14-Yellow
   3-Cyan    7-LightGray  11-LightCyan    15-White

   Certain EGA/VGA systems have modified BIOS' which messes up the
   palette.  Noted on an external color monitor for a "lunchbox"
   portable with built-in plasma display; apparently, manufacturer
   attempts to simulate color with shading.

   ===================================================================}
procedure SetBorder ( Color : byte ) ;
var
   R                         : Registers ;
begin
   if not AllowBorderColors then EXIT ;               { global option }
   if Application <> NIL then
      if AppPalette <> apColor then
         Color               := 0 ;                           { BLACK }
   with R do
   begin
      AH                     := $0B ;
      BH                     := $00 ;
      BL                     := Color ;
      Intr ( $10 , R ) ;
   end ;
end ;
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

   VIDEO

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   MONITOR TYPE

   ===================================================================}
function IsMono : boolean ;
var
   CrtMode                   : byte ABSOLUTE $0040:$0049 ;
begin
   IsMono                    := CrtMode = 7 ;
end ;
   {===================================================================

   VIDEO MEMORY

   ===================================================================}
function HardwareScreenBuffer : pointer ;
begin
   if IsMono then
      HardwareScreenBuffer   := PTR ( $B000 , 0 )
   else
      HardwareScreenBuffer   := PTR ( $B800 , 0 ) ;
end ;
   {===================================================================

   VIDEO MEMORY - automatic DesqView support (see APP.PAT for APP.PAS)

   ===================================================================}
function MyScreenBuffer : pointer ;
var
   DesqViewScreen            : word ;
begin
{$IFDEF desqview }
   DesqViewScreen            := DV_Get_Video_Buffer ;
   if DesqViewScreen > 0 then
      MyScreenBuffer         := PTR ( DESQviewScreen , 0 )
   else
{$ENDIF}
      MyScreenBuffer         := HardwareScreenBuffer ;
end ;
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

   SCREEN PUSH/POP

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   VIDEO
   Note:  Non-standard super-VGA may not update correctly.
          Became valid starting with EGA cards.

   ===================================================================}
function BiosHeight : byte ;
var
   BiosScreenRows            : byte ABSOLUTE $0040 : $0084 ;
begin
   if BiosScreenRows = 0 then
      BiosHeight             := 25
   else
      BiosHeight             := BiosScreenRows + 1 ;
end ;

function BiosWidth : byte ;
var
   CrtMode                   : byte ABSOLUTE $0040:$0049 ;
begin
   case CrtMode of
   0 ,
   1 : BiosWidth             := 40 ;
   2 ,
   3 ,
   7 : BiosWidth             := 80 ;
   else
      BiosWidth              := 80 ;
   end ;
end ;
   {===================================================================

   BUFFER - calculate based on BIOS height

   ===================================================================}
function VideoBufSize : word ;
begin
   VideoBufSize              := BiosWidth * BiosHeight * 2 ;
end ;
   {===================================================================

   SAVE

   ===================================================================}
procedure PushScreen ;
var
   Buf                       : pointer ;
begin
   if SaveScreen <> NIL then EXIT ;
   if VideoBufSize > MaxAvail then EXIT ;
   OldX                      := WhereX ;
   OldY                      := WhereY ;
   OldBufSize                := VideoBufSize ;
   GetMem ( SaveScreen , OldBufSize ) ;
   Buf                       := MyScreenBuffer ;
   Move ( Mem [ Seg ( Buf^ ) : 0 ] , SaveScreen^ , OldBufSize ) ;
end ;
   {===================================================================

   SHOW

   ===================================================================}
procedure PullScreen ;
var
   Buf                       : pointer ;
begin
   if SaveScreen = NIL then EXIT ;
   Buf                       := MyScreenBuffer ;
   Move ( SaveScreen^, Mem [ Seg ( Buf^ ) : 0 ] , OldBufSize ) ;
   GotoXY ( OldX , OldY ) ;
end ;
   {===================================================================

   FREE - Release memory without re-display

   ===================================================================}
procedure FreeScreen ;
begin
   if SaveScreen = NIL then EXIT ;
   FreeMem ( SaveScreen , OldBufSize ) ;
   SaveScreen                := NIL ;
end ;
   {===================================================================

   RESTORE

   ===================================================================}
procedure PopScreen ;
begin
   PullScreen ;
   FreeScreen ;
end ;
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   OFFSET

   ===================================================================}
function CharOffset ( x , y : byte ) : word ;
begin
   if x < 1 then x           := 1 ;
   if y < 1 then y           := 1 ;
   if x > BiosWidth then x   := BiosWidth ;
   if y > BiosHeight then y  := BiosHeight ;
   CharOffset                := ( ( Y - 1 ) * BiosWidth + x - 1 ) * 2 ;
end ;
   {===================================================================

   CHAR

   ===================================================================}
function GetChar ( x , y : byte ; Vid : pointer ) : char ;
begin
   if Vid <> NIL then
      GetChar                := chr ( Mem [ Seg ( Vid^ ) :
                                            CharOffset ( x , y ) ] )
   else
      GetChar                := #0 ;
end ;
   {===================================================================

   LINE

   ===================================================================}
function GetLine ( y : byte ; Vid : pointer ) : string ;
var
   x                         : byte ;
   S                         : string ;
begin
   S                         := '' ;
   if Vid <> NIL then
      for x := 1 to BiosWidth do
         S                   := S + chr ( Mem [ Seg ( Vid^ ) :
                                          CharOffset ( x , y ) ] ) ;
   GetLine                   := S ;
end ;
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

   INTERFACE

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   OFF

   ===================================================================}
procedure VisionOFF ;
begin
   DoneSysError ;
   DoneEvents ;
   SaveSnow                  := DRIVERS.CheckSnow ; { InitVideo resets }
   DoneVideo ;
   DoneMemory ;
end ;
   {===================================================================

   ON

   ===================================================================}
procedure VisionON ;
begin
   InitMemory ;
   InitVideo ;
   DRIVERS.CheckSnow         := SaveSnow ;         { InitVideo resets }
   InitEvents ;
   InitSysError ;
   hdRefreshDisplay ;
end ;