Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/BIX03.ZIP/DISPLAY.SYS

Text File | 1986-08-04 | 19.0 KB | 583 lines

(****************************************************************************)
(*                                                                          *)
(*                         DISPLAY.SYS                                      *)
(*                  NON-GRAPHIC WINDOWING UTILITIES                         *)
(*                                                                          *)
(*        These subroutines use ROM-BIOS calls to perform                   *)
(*        various video display options.  The leftover memory in the        *)
(*        Video Display Area is used to its full advantage.                 *)
(*        A stack of display screens is established and may be accessed     *)
(*        by reference to absolute page number or with Pops and Pushes.     *)
(*        Different Windows may be specified for each screen.               *)
(*        This module includes:                                             *)
(*                                                                          *)
(*  GetMachineType        -F-  Returns String describing Machine Type.      *)
(*  GetDisplayType        -F-  Returns String describing type of Display.   *)
(*  SetCursorPosition     -P-  Display Primitive.                           *)
(*  ReadCursorPostion     -P-  Display Primitive.                           *)
(*  SetActiveDisplayPage  -P-  Display Primitive.                           *)
(*  ScrollWindowUp        -P-  Display Primitive.                           *)
(*  ScrollWindowDown      -P-  Display Primitive.                           *)
(*  WriteCharacterandAttribute -P- Display Primitive.                       *)
(*  WriteCharacter        -P-  Display Primitive.                           *)
(*  CursorUp              -P-  Display Primitive.                           *)
(*  CursorDown            -P-  Display Primitive.                           *)
(*  CursorLeft            -P-  Display Primitive.                           *)
(*  CursorRight           -P-  Display Primitive.                           *)
(*  BackSpace             -P-  Display Primitive.                           *)
(*  WriteChar             -P-  Substituted for Standard ConOut Procedure.   *)
(*  WriteAbs              -P-  Overrides Carriage Return at EOL.            *)
(*  GotoXY                -P-  Sets Cursor Position on Default Page.        *)
(*  GotoXYAbs             -P-  Overrides Current Window Settings.           *)
(*  WhereX                -F-  Returns X cursor position relative to window.*)
(*  WhereY                -F-  Returns Y cursor position relative to window.*)
(*  PageCursorHome        -P-  Homes cursor on selected page.               *)
(*  Window                -P-  Selects window coordinates on default page.  *)
(*  ClrScr                -P-  Clears the default page.                     *)
(*  DisplayLine           -P-  Display Primitive.                           *)
(*  ClrEOL                -P-  Clears to EOL on default page.               *)
(*  SelectPage            -P-  Sets default Screen Page.                    *)
(*  ClearPage             -P-  Resets All Parameters for selected page.     *)
(*  DisplayInit           -P-  ClearPage on all screens in display stack.   *)
(*  DisplayAllocate       -P-  Allocates RAM screen Page.                   *)
(*  DisplayDispose        -P-  DISPOSES RAM already allocated for screen.   *)
(*  StackInit             -P-  Initializes RAM screen stack.                *)
(*  WindowInit            -P-  Initializes Program for All Display Functions*)
(*  WindowExit            -P-  Restores original screen settings.           *)
(*  CopyDisplay           -P-  Copies from one stack position to another.   *)
(*  DisplayHome           -P-  Homes cursor on default page.                *)
(*  DisplayEnd            -P-  Positions cursor at bottom-right of window.  *)
(*  DisplayPush           -P-  Pushes selected screen onto stack.           *)
(*  DisplayPop            -P-  Pops previously PUSHED screen from stack.    *)
(*  SaveScreen            -P-  Saves Screen Contents upon entry to program. *)
(*  RestoreScreen         -P-  Restores data from last SaveScreen.          *)
(*                                                                          *)
(*                                                                          *)
(*    REQUIRES:   DISPDEF.SYS                                               *)
(*                BIOS.SYS                                                  *)
(*                PBIOS.SYS                                                 *)
(*                                                                          *)
(*                                                                          *)
(*          written by:   John Leonard      10/30/1986                      *)
(*                                          12/31/1986                      *)
(*                                           1/02/1986                      *)
(*                                           1/07/1986                      *)
(*                                           4/06/1986                      *)
(*                                           4/17/1986                      *)
(*                                                                          *)
(*     NOT FOR SALE WITHOUT WRITTEN PERMISSION                              *)
(****************************************************************************)


function GetMachineType : window_string;
   begin
     case mem[$f000:$fffe] of
          $ff : getmachinetype := 'IBM-PC';
          $fe : getmachinetype := 'IBM-XT';
          $fd : getmachinetype := 'PC-JR';
          $fc : getmachinetype := 'IBM-AT';
          $2D : getmachinetype := 'Compaq';
          $9a : getmachinetype := 'Compaq+';
     else       getmachinetype := 'Unknown';
     end; { case mem[$f000:$feee] of }
   end;


function GetDisplayType : window_string;
   var regs : Bios_Record;
       machinetype : Window_String;
   begin
    machinetype := getmachinetype;
     if machinetype = 'PC-JR' then
        getdisplaytype := machinetype
     else begin
        regs.ah := $12;regs.bh := 3;regs.bl := $10;intr($10,regs);
        if regs.bh < 2 then getdisplaytype := 'EGA'
        else begin
             regs.ah := $0f;intr($10,regs);
             if regs.al = 7 then getdisplaytype := 'Mono'
             else if regs.al < 7 then getdisplaytype := 'CGA'
             else getdisplaytype := 'Unknown';
        end;
     end;
   end;


procedure SetCursorPosition( page,row,column : integer);
   begin
      if ( page in [0..hardwaretop] ) then begin
         bsetcursorposition( page,row,column);
         wsetcursorposition( page,row,column);
         end
      else
         wsetcursorposition( page,row,column);
   end;


procedure ReadCursorPosition( page:integer;
             var row,column,s1,s2 : integer);
   begin
      if ( page in [0..hardwaretop] ) then begin
            breadcursorposition( page,row,column,s1,s2);
            wsetcursorposition( page,row,column);
         end
      else
         wreadcursorposition( page,row,column,s1,s2);
   end;


procedure SetActiveDisplaypage ( i:integer);
   begin
      if not ( i in [0..maxdisplaystack]) then exit;
      if ( i in [0..hardwaretop] )then begin
         bsetactivedisplaypage(i);
         wsetactivedisplaypage(i);
         end
      else
         wsetactivedisplaypage(i);
   end;


procedure ScrollWindowUp ( lines,xfiller,y1,x1,y2,x2 : integer );
   begin
      with currentscreendata do begin
         if ( page in [0..hardwaretop]) then
            bscrollwindowup( lines,xfiller,y1,x1,y2,x2)
         else
            wscrollwindowup( lines,xfiller,y1,x1,y2,x2);
      end;
   end;


procedure ScrollWindowDown ( lines,xfiller,y1,x1,y2,x2 : integer );
   begin
      with currentscreendata do begin
         if ( page in [0..hardwaretop]) then
            bscrollwindowdown( lines,xfiller,y1,x1,y2,x2)
         else
            wscrollwindowdown( lines,xfiller,y1,x1,y2,x2);
      end;
   end;


procedure WriteCharacterandAttribute ( character,page,attribute,num:integer);
   begin
      if ( page in [0..hardwaretop]) then
         bwritecharacterandattribute( character,page,attribute,num)
      else
         wwritecharacterandattribute( character,page,attribute,num);
   end;


procedure WriteCharacter( character,page,num: integer);
   begin
      if ( page in [0..hardwaretop]) then
         bwritecharacter( character,page,num)
      else
         wwritecharacter( character,page,num);
   end;


procedure CursorUp;
   var row,column,s1,s2:integer;
   begin
      with currentscreendata do with windowloc[page] do begin
         readcursorposition(page,row,column,s1,s2);
         if row > y1 then
            row := row - 1
         else
            scrollwindowdown(1,DefaultFiller,y1,x1,y2,x2);
         setcursorposition(page,row,column);
      end;
   end;


procedure CursorDown;
   var row,column,s1,s2 : integer;
   begin
      with currentscreendata do with windowloc[page] do begin
         readcursorposition(page,row,column,s1,s2);
         if row < y2 then
            row := row + 1
         else
            scrollwindowup(1,defaultFiller,y1,x1,y2,x2);
         setcursorposition(page,row,column);
      end;
   end;


procedure CursorLeft;
   var row,column,s1,s2:integer;
   begin
      with CurrentScreenData do with windowloc[page] do begin
         readcursorposition(page,row,column,s1,s2);
         if column > x1 then
            column := column - 1
         else begin
            column := x2;
            if row > y1 then
               row := row - 1
            else scrollwindowdown(1,DefaultFiller,y1,x1,y2,x2);
         end;
         setcursorposition(page,row,column);
      end;
   end;


procedure CursorRight;
   var row,column,s1,s2:integer;
   begin
      with CurrentScreenData do with windowloc[page] do begin
         readcursorposition(page,row,column,s1,s2);
         if column < x2 then
            column := column + 1
         else begin
            column := x1;
            if row < y2 then
               row := row + 1
            else scrollwindowup(1,defaultfiller,y1,x1,y2,x2);
         end;
         setcursorposition(page,row,column);
      end;
   end;


procedure BackSpace;
   begin
      cursorleft;
      with currentscreendata do with windowloc[page] do
         writecharacterandattribute(defaultfiller,page,defaultattribute,1);
   end;


procedure WriteChar( ch: char);
   var
      row,column,s1,s2 : integer;
   begin
      with CurrentScreenData do begin
         ReadCursorPosition(page,row,column,s1,s2);
         with windowloc[page] do
            case ch of
              #8    : backspace;
              #10   : cursordown;
              #13   : begin
                         column := x1;
                         SetCursorPosition(page,row,column);
                      end;
            else begin
                WriteCharacterAndAttribute(ord(ch),page,attribute,1);
                cursorright;
            end;
         end;
      end;
   end;


procedure WriteAbs( ch: char);
   var
      row,offs,column,s1,s2 : integer;
   begin
      with CurrentScreenData do begin
         ReadCursorPosition(page,row,column,s1,s2);
         case ch of
            #8   : exit;
            #10  : exit;
            #13  : exit;
            ^G   : begin
                     sound(1000);delay(200);nosound;
                   end;
            else begin
               WriteCharacterAndAttribute(ord(ch),page,attribute,1);
               if column< DefaultWidth then column := column + 1;
               setcursorposition(page,row,column);
            end;
         end;
      end;
   end;


procedure GotoXY(x,y:integer);
   begin
      with currentscreendata do with windowloc[page] do
         SetCursorPosition(page,y+y1-1,x+x1-1)
   end;


procedure GotoXYAbs(x,y:integer);
   begin
      with CurrentScreenData do with windowloc[page] do
         SetCursorPosition(page,y-1,x-1);
   end;


function wherex : integer;
   var page,row,column,s1,s2:integer;
   begin
      with currentscreendata do with windowloc[page] do begin
         readcursorposition(page,row,column,s1,s2);
         wherex := column - x1 + 1;
      end;
   end;


function wherey : integer;
   var row,column,s1,s2 : integer;
   begin
      with currentscreendata do with windowloc[page] do begin
         readcursorposition(page,row,column,s1,s2);
         wherey := row - y1 + 1;
      end;
   end;


procedure PageCursorHome(i:integer);
   begin
      with CurrentScreenData do with windowloc[i] do
            SetCursorPosition(page,y1,x1);
   end;


procedure Window( ix1,iy1,ix2,iy2 : integer );
   begin
      with CurrentScreenData do with windowloc[page] do begin
         x1:=ix1-1;y1:=iy1-1;x2:=ix2-1;y2:=iy2-1;
         pagecursorhome(page);
      end;
   end;


procedure ClrScr;
   var i,j:integer;
   begin
      with CurrentScreenData do with windowloc[page] do begin
         scrollwindowup(0,attribute,y1,x1,y2,x2);
         pagecursorhome(page);
      end;
   end;

procedure DisplayLine( page,y,x,attribute,len,begchar,midchar,endchar:Integer;
                vertical : boolean );
   var i,j:integer;
   begin
      setcursorposition(page,y,x);
      writecharacterandattribute(begchar,page,attribute,1);
      if vertical then begin
         for i := y+1 to (y+len-2) do begin
            setcursorposition(page,i,x);
            writecharacterandattribute(midchar,page,attribute,1);
         end;
         setcursorposition(page,y+len-1,x);
         writecharacterandattribute(endchar,page,attribute,1);
         end
      else begin
         setcursorposition(page,y,x+1);
         writecharacterandattribute(midchar,page,attribute,len-2);
         setcursorposition(page,y,x+len-1);
         writecharacterandattribute(endchar,page,attribute,1);
      end;
   end;


procedure clreol;
   const vert:boolean=false;
   var oldx,oldy:integer;
   begin
      oldx := wherex;oldy:=wherey;
      with currentscreendata do with windowloc[page] do
      DisplayLine(page,wherey-1,wherex-1,attribute,x2-wherex-1,
         filler,filler,filler,vert);
      gotoxy(oldx,oldy);
   end;



procedure selectpage(i: integer); forward;


procedure ClearPage( I : integer );
   var oldpage : integer;
   begin
      oldpage := CurrentScreenData.page;
      selectpage( I );
      with currentscreendata do with windowloc[i] do begin
         framed := false;
         hlen := 0;flen:=0;
         xloc := 1;yloc:=1;
      end;
      window(1,1,80,25);clrscr;
      selectpage( oldpage );
   end;


procedure DisplayInit;
   var i:integer;
   begin
      with CurrentScreenData do begin
         attribute := DefaultAttribute;
         filler    := DefaultFiller;
      end;
      if ( hardwaretop >= 1 ) then
         for i := 1 to hardwaretop do clearpage(i);
   end;


procedure DisplayAllocate( var pointer: mono_screen_pointer);
   var test : ^integer;
   begin
      new(pointer);
      while ofs(pointer^) <> 0 do begin
         dispose(pointer);
         new(test);
         new(pointer);
      end;
      fillchar(pointer^,sizeof(pointer^),defaultfiller);
   end;


procedure DisplayDispose( var pointer : mono_screen_pointer);
   begin
      dispose(pointer);
      pointer := nil;
   end;


procedure SelectPage;
   begin
      if ( i in [0..MaxDisplayStack]) then
         if not ( i in [0..hardwaretop]) then
            if displaystack[i] = nil then begin
               displayallocate(displaystack[i]);
               clearpage(i);
            end;
          setactivedisplaypage(i);
   end;


procedure StackInit;
   var i:integer;
      ch: char;
   begin
      with CurrentScreenData do
         for i := 0 to hardwaretop do
            DisplayStack[i] := addr(mem[hardb:(defaultregensize*i)]);
      for i := hardwaretop+1 to MaxDisplayStack do
         DisplayStack[i] := nil;
   end;


procedure WindowInit;
   begin
      with InitialScreenData do begin
         mtype := GetMachineType;
         stype := GetDisplayType;
         regen := memw[$0000:$044C];
         conout:= conoutptr;
         if (stype='Mono') then
         hardb := $B000 else hardb := $B800;
         readcursorposition(0,y,x,s1,s2);
      end;
      memw[$0000:$044C] := DefaultRegenSize;
      conoutptr        := ofs(writechar);
      with CurrentScreenData do begin
         regen  := DefaultRegenSize;
         hardb  := InitialScreenData.hardb;
         filler := DefaultFiller;
         s1     := InitialScreenData.s1;
         s2     := InitialScreenData.s2;
         attribute := DefaultAttribute;
         with windowloc[0] do begin
            xloc:=initialscreendata.x;
            yloc:=initialscreendata.y;
            framed:=false;
            x1:=0;y1:=0;x2:=79;y2:=24;
            hlen:=0;flen:=0;
         end;
      end;
      DisplayInit;
      StackInit;
      Selectpage(0);
      window(1,1,80,25);
   end;



procedure WindowExit;
   var i:integer;
   begin
      setactivedisplaypage(0);
      with InitialScreenData do begin
         memw[$0000:$044C] := regen;
         conoutptr         := conout;
         setcursorposition(0,y,x);
         setcursorsize(s1,s2);
      end;
      for i := hardwaretop+1 to MaxDisplayStack do
         if DisplayStack[i] <> nil then begin
            DisplayDispose(DisplayStack[i]);
         end;
   end;



procedure CopyDisplay( from,tu:integer);
   var row,column,s1,s2:integer;
   begin
     if( not (from in [0..MaxDisplayStack]) and
         not ( tu  in [0..MaxDisplayStack]) ) then exit;
     if(from=tu) then exit;
     if( (from=0) and (tu=0) ) then exit;
     if DisplayStack[from] = nil then DisplayAllocate(DisplayStack[from]);
     if DisplayStack[tu]   = nil then begin
         DisplayAllocate(DisplayStack[tu]);
         clearpage(tu);
     end;
     while  not ((port[$3DA] and 8) = 8 ) do;
     move( DisplayStack[from]^,
           DisplayStack[tu]^,
           sizeof(DisplayStack[from]^) );
     with CurrentScreenData do
        move( windowloc[from],windowloc[tu],sizeof(windowloc[from]) );
     readcursorposition(from,row,column,s1,s2);
     setcursorposition(tu,row,column);
   end;


procedure DisplayHome;
   begin
      gotoxy(1,1);
   end;


procedure DisplayEnd;
   begin
      with currentscreendata do with windowloc[page] do
         gotoxyabs(x2+1,y2+1);
   end;


procedure displaypush(i:integer);
   begin
      displaytop := displaytop - 1;
      copydisplay(i,displaytop);
   end;


procedure displaypop(i:integer);
   begin
      copydisplay(displaytop,i);
      displaytop := displaytop + 1;
      if displaytop > maxdisplayStack then displaytop := maxdisplaystack;
   end;


procedure savescreen;
   begin
      copydisplay(0,maxdisplaystack);
   end;


procedure restorescreen;
   begin
      copydisplay(maxdisplaystack,0);
   end;