Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FASTSC.ZIP/FASTSCRN.PAS

Pascal/Delphi Source File | 1989-06-30 | 13.5 KB | 520 lines

{$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
{$M 16384,0,655360}
Unit FastScrn;
(***************************************************************************)
(* Program: FastScrn.Pas                                                   *)
(* Last udpate: June 29, 1989                                              *)
(* Author: Mark Addleman                                                   *)
(*                                                                         *)
(* Public domain.  Please distribute freely and in complete form.          *)
(*                                                                         *)
(* Any comments, suggestions, questions, please inform me via CompuServe   *)
(* my ID number is 72777,740                                               *)
(*                                                                         *)
(* Thanks for using FastScrn                                               *)
(***************************************************************************)

Interface
Uses Dos, FastDef;
Type
   ScreenObj                 =   Object
                                    Rows,
                                    Cols         :   Byte;
                                    LastRow      :   Byte;
                                    LastCol      :   Byte;
                                    ScrPtr       :   Pointer;

                                    Constructor Init;
                                    Destructor  Done;

                                    Function  Snow:Boolean; virtual;
                                    Function  ScreenPtr(_Row, _Col:Byte):Pointer; virtual;
                                    Procedure Write(_Row, _Col:Byte; _Color:Integer; _St:String);
                                    Procedure WriteV(_Row, _Col:Byte; _Color:Integer; _St:String);
                                    Procedure WriteA(_Row, _Col:Byte; _Color:Integer; Var _St; _Len:Byte); virtual;
                                    Procedure WriteAv(_Row, _Col:Byte; _Color:Integer; Var _St; _Len:Byte); virtual;
                                    Procedure WriteC(_Row, _Col1, _Col2:Byte; _Color:Integer; _St:String);
                                    Procedure WriteAC(_Row, _Col1, _Col2:Byte; _Color:Integer; Var _St; _Len:Byte);
                                    Procedure WriteCv(_Row1, _Row2, _Col:Byte; _Color:Integer; _St:String);
                                    Procedure WriteACv(_Row1, _Row2, _Col:Byte; _Color:Integer; Var _St; _Len:Byte);
                                    Procedure Fill(_Row, _Col, _Rows, _Cols:Byte; _Color:Integer; _Ch:Char); virtual;
                                    Procedure Color(_Row, _Col, _Rows, _Cols:Byte; _Color:Byte); virtual;
                                    Function  CharAt(_Row, _Col:Byte):Char; virtual;
                                    Function  ColorAt(_Row, _Col:Byte):Byte; virtual;

                                    Procedure Copy(_SourceScreen:ScreenObj; _sRow, _sCol, _Rows, _Cols:Byte;
                                                   _dRow, _dCol:Byte); virtual;

                                    Procedure SetLasts(Rs, Cs:Byte); virtual;
                                 End;

   DisplayObj                =   Object(ScreenObj)
                                    ScreenType   :   Byte;
                                    ScreenSnow   :   Boolean;
                                    Page         :   Byte;

                                    Constructor Init;
                                    Function  Snow:Boolean; virtual;

                                    Function  CurrentRows:Byte; virtual;
                                    Function  CurrentCols:Byte; virtual;
                                    Function  CurrentVideoMode:Byte; virtual;
                                    Procedure SetVideoMode(Mode:Byte); virtual;

                                    Procedure SetCursor(Top, Bottom:Byte); virtual;
                                    Function  GetCursor:Word; virtual;
                                    Procedure CursorOff; virtual;
                                    Procedure CursorOn; virtual;
                                    Procedure CursorFast; virtual;
                                    Procedure CursorSlow; virtual;
                                    Function  WhereR:Byte; virtual;
                                    Function  WhereC:Byte; virtual;
                                    Procedure GotoRC(Row, Col:Byte); virtual;

                                    Procedure UsePage(PageNum:Byte); virtual;
                                    Procedure DisplayPage(PageNum:Byte); virtual;
                                    Function CurrentPage:Byte;
                                 End;

Var
   DisplayScreen             :   DisplayObj;

Implementation
Var
   BaseScreenSeg             :   Word;

Type
   ScreenCharArray           =   Array[1..2] of Byte;

{$L Fast.Obj}
Procedure FcopyAsm(Var Source, Dest; Rows, Cols, SkipSource, SkipDest:Word; Snow:Boolean); external;
Procedure FfillAsm(CharColor:Word; Var Dest; Rows, Cols, SkipDest:Word; Snow:Boolean); external;
Procedure FfillGetColorAsm(Char:Word; Var Dest; Rows, Cols, SkipDest:Word; Snow:Boolean); external;
Procedure FwriteAsm(Var Source, Dest; Len:Word; Color:Word; Snow:Boolean); external;
Procedure FwriteGetColorAsm(Var Source, Dest; Len:Word; Snow:Boolean); external;
Procedure FattrAsm(Char:Word; Var Dest; Rows, Cols, SkipDest:Word; Snow:Boolean); external;
Procedure FwriteVasm(Var Source, Dest; Len:Word; Color:Word; SkipDest:Word; Snow:Boolean); external;
Procedure FwriteVGetColorAsm(Var Source, Dest; Len:Word; SkipDest:Word; Snow:Boolean); external;

Const
   CharacterPos              =   1;
   ColorPos                  =   2;
   SlowCursor                =   3 shl 5;
   HideCursor                =   1 shl 6;

Procedure ScreenObj.SetLasts;
Begin
   If Cs+LastCol > Cols Then Begin
      Inc(LastRow, (Cs+LastCol) div Cols);
      LastCol:=LastCol+Cs-Cols;
   End
   Else Begin
      Inc(LastCol, Cs);
      Inc(LastRow, Rs);
   End;
End;

Function ScreenObj.Snow;
Begin
   Snow:=False;
End;

Function ScreenObj.ScreenPtr;
Begin
   ScreenPtr:=Ptr(Seg(ScrPtr^),
                  Ofs(ScrPtr^)+2*(Pred(_Row)*Cols+Pred(_Col)));
End;

Function ScreenObj.CharAt;
Begin
   CharAt:=Char(ScreenCharArray(ScreenPtr(_Row, _Col)^)[CharacterPos]);
End;

Function ScreenObj.ColorAt;
Begin
   ColorAt:=Byte(ScreenCharArray(ScreenPtr(_Row, _Col)^)[ColorPos]);
End;

Procedure ScreenObj.Write;
Var
   P                         :   Pointer;

Begin
   LastRow:=_Row;
   LastCol:=_Col;

   P:=ScreenPtr(_Row, _Col);

   If _Color=SameAttr Then Begin
      FwriteGetColorAsm(_St[1], P^, Length(_St), Snow);
   End
   Else
      FwriteAsm(_St[1], P^, Length(_St), _Color*$100, Snow);

   SetLasts(0, Length(_St));
End;

Procedure ScreenObj.WriteV;
Var
   P                         :   Pointer;

Begin
   LastRow:=_Row;
   LastCol:=_Col;

   P:=ScreenPtr(_Row, _Col);

   If _Color=SameAttr Then Begin
      FwriteVGetColorAsm(_St[1], P^, Length(_St), Cols*2, Snow);
   End
   Else
      FwriteVasm(_St[1], P^, Length(_St), _Color*$100, Cols*2, Snow);

   SetLasts(Length(_St), 0);
End;

Procedure ScreenObj.WriteCv;
Begin
   WriteV((_Row1+_Row2-Length(_St)) div 2, _Col, _Color, _St);
End;

Procedure ScreenObj.WriteC;
Begin
   Write(_Row, (_Col1+_Col2-Length(_St)) div 2, _Color, _St);
End;

Procedure ScreenObj.WriteA;
Var
   St                        :   String;

Begin
   St:=String(_St)[0]+String(_St);
   St[0]:=Char(_Len);
   Write(_Row, _Col, _Color, St);
End;

Procedure ScreenObj.WriteAC;
Begin
   WriteA(_Row, (_Col1+_Col2-_Len) div 2, _Color, _St, _Len);
End;

Procedure ScreenObj.WriteAv;
Var
   St                        :   String;

Begin
   St:=String(_St)[0]+String(_St);
   St[0]:=Char(_Len);
   WriteV(_Row, _Col, _Color, St);
End;

Procedure ScreenObj.WriteACv;
Begin
   WriteAv((_Row1+_Row2-_Len) div 2, _Col, _Color, _St, _Len);
End;

Procedure ScreenObj.Fill;
Var
   P                         :   Pointer;

Begin
   LastRow:=_Row;
   LastCol:=_Col;

   P:=ScreenPtr(_Row, _Col);

   If _Color=SameAttr Then Begin
      FfillGetColorAsm(Byte(_Ch), P^, _Rows, _Cols, (Cols-_Cols)*2, Snow);
   End
   Else Begin
      FfillAsm((Byte(_Color)*$100+Byte(_Ch)), P^, _Rows, _Cols,
               (Cols-_Cols)*2, Snow);
   End;

   SetLasts(Rows, Cols);
End;

Procedure ScreenObj.Color;
Var
   P                         :   Pointer;

Begin
   LastRow:=_Row;
   LastCol:=_Col;

   P:=ScreenPtr(_Row, _Col);

   FattrAsm(Byte(_Color)*$100, P^, _Rows, _Cols, (Cols-_Cols)*2, Snow);
End;

Procedure ScreenObj.Copy;
Var
   Dest, Source              :   Pointer;

Begin
   Source:=_SourceScreen.ScreenPtr(_sRow, _sCol);
   Dest:=ScreenPtr(_dRow, _dCol);

   FcopyAsm(Source^, Dest^, _Rows, _Cols, (_SourceScreen.Cols-_Cols)*2,
            (Cols-_Cols)*2, Snow);
End;

Constructor ScreenObj.Init;
Begin
   LastRow:=1;
   LastCol:=1;
End;

Destructor ScreenObj.Done;
Begin
End;


Constructor DisplayObj.Init;
   Function EGAinstalled:Boolean;
   Var
      R                      :   Dos.Registers;

   Begin
      R.Ax:=$1200;
      R.Bx:=$0010;
      R.Cx:=$FFFF;
      Intr($10, R);
      EGAinstalled:=Not (R.Cx=$FFFF);
   End;

   Function VGAinstalled:Boolean;
   Var
      R                      :   Dos.Registers;

   Begin
      R.Ax:=$1A00;
      Intr($10, R);
      VGAinstalled:=((R.Al and $FF) = $1a) and
                    ((R.Bl and $FF) in [$7, $8, $B, $C]);
   End;

Label
   CheckVideoMode;

Var
   R                         :   Registers;

Begin
   ScreenObj.Init;

   CheckVideoMode:
   Case CurrentVideoMode of
      7,2,
      0   :   If EGAinstalled Then Begin
                 If VGAinstalled Then
                    ScreenType:=VGAmono
                 Else
                    ScreenType:=EGAmono;
              End
              Else
                 ScreenType:=MDAmono;
      3,1 :   If EGAinstalled Then Begin
                 If VGAinstalled Then
                    ScreenType:=VGAcolor
                 Else
                    ScreenType:=EGAcolor;
              End
              Else
                 ScreenType:=CGAcolor;
      Else Begin
         SetVideoMode(3);
         Goto CheckVideoMode;
      End;
   End;

   Case ScreenType of
      VGAcolor,
      EGAcolor,
      CGAcolor   :   ScrPtr:=Ptr($B800,0);
      VGAmono,
      EGAmono,
      VGAmono    :   ScrPtr:=Ptr($B000,0);
   End;

   If ScreenType=CGAcolor Then
      ScreenSnow:=True
   Else
      ScreenSnow:=False;

   {Simple snow detecting and not very practical.  I lack the ability
    to test on a snow producing card.  I would welcome input!}

   R.Ah:=15;
   Intr($10, R);
   Page:=R.Bh;

   Rows:=CurrentRows;
   Cols:=CurrentCols;
End;

Function DisplayObj.Snow;
Begin
   Snow:=ScreenSnow;
End;

Procedure DisplayObj.SetCursor;
Var
   Registers                 :   Dos.Registers;

Begin
   With Registers Do Begin
      Ah:=1;
      Cl:=Pred(Bottom);
      Ch:=Pred(Top);
   End;
   Intr($10, Registers);
End;

Function DisplayObj.GetCursor;
Var
   R                         :   Registers;

Begin
   R.Ah:=3;
   Intr($10, R);
   GetCursor:=R.Cx;
End;

Procedure DisplayObj.GotoRC;
Var
   Registers                 :   Dos.Registers;

Begin
   With Registers Do Begin
      Ah:=2;
      Bh:=Page;
      Dl:=Pred(Col);
      Dh:=Pred(Row);
   End;
   Intr($10,Registers);
End;

Function DisplayObj.WhereR;
Begin
   WhereR:=Succ(Mem[0:Page+$044F]);
End;

Function DisplayObj.WhereC;
Begin
   WhereC:=Succ(Mem[0:Page+$0450]);
End;

Procedure DisplayObj.CursorOff;
Var
   R                         :   Registers;

Begin
   R.Cx:=GetCursor;
   R.Ch:=R.Ch or HideCursor;

   R.Ah:=1;
   Intr($10, R);
End;

Procedure DisplayObj.CursorOn;
Var
   R                         :   Registers;

Begin
   R.Cx:=GetCursor;
   R.Ch:=R.Ch and not HideCursor;

   R.Ah:=1;
   Intr($10, R);
End;

Procedure DisplayObj.CursorFast;
Var
   R                         :   Registers;

Begin
   R.Cx:=GetCursor;
   R.Ch:=R.Ch and not SlowCursor;

   R.Ah:=1;
   Intr($10, R);
End;

Procedure DisplayObj.CursorSlow;
Var
   R                         :   Registers;

Begin
   R.Cx:=GetCursor;
   R.Ch:=R.Ch or SlowCursor;

   R.Ah:=1;
   Intr($10, R);
End;

Procedure DisplayObj.UsePage;
Begin
   Page:=PageNum;
   ScrPtr:=Ptr(BaseScreenSeg+(Page*MemW[$0000:$044C] div 16), Ofs(ScrPtr^));
End;

Procedure DisplayObj.DisplayPage;
Var
   Registers                 :   Dos.Registers;

Begin
   Page:=PageNum;
   With Registers Do Begin
      Ah:=5;
      Al:=PageNum;
   End;

   Intr($10, Registers);
End;

Function DisplayObj.CurrentPage;
Begin
   CurrentPage:=Page;
End;

Function DisplayObj.CurrentVideoMode;
Var
   R                         :   Dos.Registers;

Begin
   R.Ah:=$0F;
   Intr($10, R);
   CurrentVideoMode:=R.Al;
End;

Procedure DisplayObj.SetVideoMode;
Var
   R                         :   Dos.Registers;

Begin
   R.Ah:=0;
   R.Al:=Mode;

   Intr($10, R);
End;

Function DisplayObj.CurrentRows;
Begin
   If DisplayScreen.ScreenType < EGAColor Then
      CurrentRows:=25
   Else
      CurrentRows:=MemW[$0:$484];
End;

Function DisplayObj.CurrentCols;
Begin
   CurrentCols:=MemW[$0:$44A];
End;

Begin
   DisplayScreen.Init;

   BaseScreenSeg:=Seg(DisplayScreen.ScrPtr^);
End.