Power-Programmierung/CD1.mdf/pascal/library/dos/bix/window.sys

Text File | 1986-08-04 | 17KB | 528 lines

(********************************************************************)
(*                                                                  *)
(*           WINDOW.SYS  WINDOW MANIPULATION ROUTINES               *)
(*                                                                  *)
(*      Allows for the manipulation of windows.  A window is        *)
(*      defined as a portion of a display screen.                   *)
(*                                                                  *)
(*                                                                  *)
(*                                                                  *)
(*                                                                  *)
(*                                                                  *)
(*      written by:      John Leonard    1/9/86                     *)
(*                                                                  *)
(*        NOT FOR SALE WITHOUT WRITTEN PERMISSION                   *)
(********************************************************************)


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 VertLine ( x,y,len,left,mid,right : integer);
   const vert:boolean=true;
   begin
      with currentscreendata do
         DisplayLine(page,y-1,x-1,attribute,len,left,mid,right,vert);
   end;


procedure HorLine ( x,y,len,left,mid,right : integer);
   const vert:boolean=false;
   begin
      with currentscreendata do
         DisplayLine(page,y-1,x-1,attribute,len,left,mid,right,vert);
   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 Frame(UpperLeftX, UpperLeftY, LowerRightX, LowerRightY: Integer;
                tl,tr,bl,br : integer;
                ls,ts,rs,bs : integer );
   var  I : Integer;
   begin {Frame}
     GotoXYAbs(UpperLeftX+1, UpperLeftY+1);
     WriteAbs(chr(tl));
     for I := (UpperLeftX + 2) to (LowerRightX ) do
     begin
       WriteAbs(chr(ts));
     end;
     WriteAbs(chr(tr));
     for I := (UpperLeftY + 2) to (LowerRightY ) do
     begin
        GotoXYAbs(UpperLeftX +1, I);  WriteAbs(chr(ls));
        GotoXYAbs(LowerRightX+1, I);  WriteAbs(chr(rs));
     end;
     GotoXYAbs(UpperLeftX+1, LowerRightY+1);
     WriteAbs(chr(bl));
     for I := (UpperLeftX + 2) to (LowerRightX ) do WriteAbs(chr(bs));
     WriteAbs(chr(br));
   end; {Frame}


procedure WindowFrame ( tl,tr,bl,br : integer;
                            ls,ts,rs,bs : integer);
   var i,j:integer;
   begin { MonoFrame }
      with CurrentScreenData do with windowloc[page] do begin
           x1 := x1 - 1;y1 := y1 - 1; x2 := x2 + 1; y2 := y2 + 1;
           framed := true;
           frame( x1,y1,x2,y2,tl,tr,bl,br,ls,ts,rs,bs);
           x1 := x1 + 1;y1 := y1 + 1; x2 := x2 - 1; y2 := y2 - 1;
        end;
   end;


procedure MonoFrame1;
   begin
      WindowFrame(218,191,192,217,179,196,179,196);
   end;


procedure MonoFrame2;
   begin
      WindowFrame(201,187,200,188,186,205,186,205);
   end;


procedure moveleft( FromPage, TuPage, Distance, Fillpage : integer);
   var
      i,width,FillWidth : integer;
      OldOffset,NewOffset,j,
      FromSegment,TuSegment,FillSegment,
      OldFillOffset,NewFillOffset : integer;
      row,column,s1,s2:integer;
   begin
      if (frompage <> tupage) and (fillpage in [0..MaxDisplayStack]) then
            copydisplay(fillpage,tupage);
      with CurrentScreenData do begin
         with windowloc[FromPage] do begin
            if framed then begin
               x1:=x1-1;y1:=y1-1;x2:=x2+1;y2:=y2+1;
            end;
            width := x2 - x1 + 1;
            fromsegment := seg(displaystack[frompage]^);
            tusegment   := seg(displaystack[tupage]^);
            fillsegment := seg(displaystack[fillpage]^);
            for i := y1 to y2 do begin
               OldOffset     := woffset(  i, x1);
               NewOffset     := woffset(  i, x1-distance);
               move( mem[fromsegment:oldoffset],
                     mem[tusegment:newoffset], 2*width);
               if frompage = tupage then begin
                  OldFillOffset := woffset( i, x2-distance+1);
                  NewFillOffset := woffset( i, x2-distance+1);
                  move( mem[fillsegment:OldFillOffset],
                        mem[tusegment:NewfillOffset],
                        2*distance);
               end;
            end;
         end;
         with windowloc[frompage] do
            if framed then begin
            x1:=x1+1;y1:=y1+1;x2:=x2-1;y2:=y2-1;
         end;
         move( windowloc[frompage],
               windowloc[tupage],
               sizeof(windowloc[frompage]) );
         with windowloc[TuPage] do begin
            x1 := x1 - distance; x2 := x2 - distance;
         end;
         readcursorposition(tupage,row,column,s1,s2);
         setcursorposition(tupage,row,column-distance);
      end;
   end;


procedure moveright( FromPage, TuPage, Distance, FillPage : integer );
   var
      i,width,FillWidth : integer;
      OldOffset,NewOffset,j,
      FromSegment,TuSegment,FillSegment,
      OldFillOffset,NewFillOffset : integer;
      row,column,s1,s2:integer;
   begin
      if (frompage <> tupage) and (fillpage in [0..MaxDisplayStack]) then
           copydisplay(fillpage,tupage);
      with CurrentScreenData do begin
         with windowloc[FromPage] do begin
            if framed then begin
               x1:=x1-1;y1:=y1-1;x2:=x2+1;y2:=y2+1;
            end;
            width := x2 - x1 + 1;
            fromsegment := seg(displaystack[frompage]^);
            tusegment   := seg(displaystack[tupage]^);
            fillsegment := seg(displaystack[fillpage]^);
            for i := y1 to y2 do begin
               OldOffset     := woffset(  i, x1);
               NewOffset     := woffset(  i, x1+distance);
               move( mem[fromsegment:oldoffset],
                     mem[tusegment:newoffset], 2*width);
               if frompage = tupage then begin
                  OldFillOffset := woffset( i, x1);
                  NewFillOffset := woffset( i, x1);
                  move( mem[fillsegment:OldFillOffset],
                        mem[tusegment:NewfillOffset],
                        2*distance);
               end;
            end;
         end;
         with windowloc[frompage] do
            if framed then begin
            x1:=x1+1;y1:=y1+1;x2:=x2-1;y2:=y2-1;
         end;
         move( windowloc[frompage],
               windowloc[tupage],
               sizeof(windowloc[frompage]) );
         with windowloc[TuPage] do begin
            x1 := x1 + distance; x2 := x2 + distance;
         end;
         readcursorposition(tupage,row,column,s1,s2);
         setcursorposition(tupage,row,column+distance);
      end;
   end;


procedure moveup( FromPage, TuPage, Distance, FillPage : integer );
   var
      i,width,FillWidth : integer;
      OldOffset,NewOffset,j,
      FromSegment,TuSegment,FillSegment,
      OldFillOffset,NewFillOffset : integer;
      row,column,s1,s2:integer;
   begin
      if (frompage <> tupage) and (fillpage in [0..MaxDisplayStack]) then
           copydisplay(fillpage,tupage);
      with CurrentScreenData do begin
         with windowloc[FromPage] do begin
            if framed then begin
               x1:=x1-1;y1:=y1-1;x2:=x2+1;y2:=y2+1;
            end;
            width := x2 - x1 + 1;
            fromsegment := seg(displaystack[frompage]^);
            tusegment   := seg(displaystack[tupage]^);
            fillsegment := seg(displaystack[fillpage]^);
            for i  := y1 to y2 do begin
               OldOffset     := woffset( i, x1);
               NewOffset     := woffset( i-distance, x1);
               move( mem[fromsegment:oldoffset],
                     mem[tusegment:newoffset], 2*width);
            end;
            if frompage = tupage then begin
               for i := (y2 - distance) to y2 do begin
                  OldFillOffset := woffset(i+1, x1);
                  NewFillOffset := woffset(i+1, x1);
                  move( mem[fillsegment:OldFillOffset],
                        mem[tusegment:NewfillOffset],
                        2*width);
               end;
            end;
         end;
         with windowloc[frompage] do
            if framed then begin
            x1:=x1+1;y1:=y1+1;x2:=x2-1;y2:=y2-1;
         end;
         move( windowloc[frompage],
               windowloc[tupage],
               sizeof(windowloc[frompage]) );
         with windowloc[TuPage] do begin
              y2 := y2 - distance; y1 := y1 - distance;
         end;
         readcursorposition(tupage,row,column,s1,s2);
         setcursorposition(tupage,row-distance,column);
      end;
   end;


procedure movedown( FromPage, TuPage, Distance, FillPage : integer );
   var
      i,width,FillWidth : integer;
      OldOffset,NewOffset,j,
      fromsegment,tusegment,fillsegment,
      OldFillOffset,NewFillOffset : integer;
      row,column,s1,s2:integer;
   begin
      if (frompage <> tupage) and (fillpage in [0..MaxDisplayStack]) then
           copydisplay(fillpage,tupage);
      with CurrentScreenData do begin
         with windowloc[FromPage] do begin
            if framed then begin
               x1:=x1-1;y1:=y1-1;x2:=x2+1;y2:=y2+1;
            end;
            width := x2 - x1 + 1;
            fromsegment := seg(displaystack[frompage]^);
            tusegment   := seg(displaystack[tupage]^);
            fillsegment := seg(displaystack[fillpage]^);
            for i  := y2 downto y1 do begin
               OldOffset     := woffset( i, x1);
               NewOffset     := woffset( i+distance, x1);
               move( mem[fromsegment:oldoffset],
                     mem[tusegment:newoffset], 2*width);
            end;
            if frompage = tupage then begin
               for i := (y1-distance-1) to y1-1 do begin
                  OldFillOffset := woffset( i+1, x1);
                  NewFillOffset := woffset( i+1, x1);
                  move( mem[fillsegment:OldFillOffset],
                        mem[tusegment:NewfillOffset],
                        2*width);
               end;
            end;
         end;
         with windowloc[frompage] do
            if framed then begin
            x1:=x1+1;y1:=y1+1;x2:=x2-1;y2:=y2-1;
         end;
         move( windowloc[frompage],
               windowloc[tupage],
               sizeof(windowloc[frompage]) );
         with windowloc[TuPage] do begin
              y2 := y2 + distance; y1 := y1 + distance;
         end;
         readcursorposition(tupage,row,column,s1,s2);
         setcursorposition(tupage,row+distance,column);
      end;
   end;



function ConstStr(c,n:integer) : Window_Medium_String;
   var s: Window_Medium_String;
   begin
      if n<0 then n := 0;
      s[0] := chr(n);
      fillchar(s[1],n,c);
      conststr := s;
   end;


procedure centertext ( row: integer; text: Window_Big_String );
   var width,i:integer;
   begin
      with CurrentScreenData do with windowloc[page] do begin
         width := x2 - x1;
         i := (width-length(text)) div 2 ;
         gotoxy(i+1,row);write(text);
      end;
   end;


procedure Header ( text : Window_Big_String );
   begin
      with currentscreendata do with windowloc[page] do begin
         hlen:=length(text);
         if not framed then centertext(1,text) else begin
            x1:=x1-1;y1:=y1-1;x2:=x2+1;y2:=y2+1;
            centertext(1,text);
            x1:=x1+1;y1:=y1+1;x2:=x2-1;y2:=y2-1;
         end;
      end;
   end;


procedure Footer ( text : Window_Big_String);
   begin
      with currentscreendata do with windowloc[page] do begin
         flen:=length(text);
         if not framed then centertext (y2+1,text) else begin
            x1:=x1-1;y1:=y1-1;x2:=x2+1;y2:=y2+1;
            centertext(y2+1-y1,text);
            x1:=x1+1;y1:=y1+1;x2:=x2-1;y2:=y2-1;
         end;
      end;
   end;


procedure ClearHeader ( i : integer );
   var text:window_big_string;
   begin
      with currentscreendata do with windowloc[page] do begin
         text := conststr(i,hlen);
         if not framed then centertext(1,text) else begin
            x1:=x1-1;y1:=y1-1;x2:=x2+1;y2:=y2+1;
            centertext(1,text);
            x1:=x1+1;y1:=y1+1;x2:=x2-1;y2:=y2-1;
         end;
      end;
   end;


procedure ClearFooter(i:integer);
   var text:window_big_string;
   begin
      with currentscreendata do with windowloc[page] do begin
         text:=conststr(i,flen);
         if not framed then centertext (y2+1,text) else begin
            x1:=x1-1;y1:=y1-1;x2:=x2+1;y2:=y2+1;
            centertext(y2+1-y1,text);
            x1:=x1+1;y1:=y1+1;x2:=x2-1;y2:=y2-1;
         end;
      end;
   end;


procedure plop ( from,tu : integer );
   begin
      moveright(from,tu,0,-1);
      pagecursorhome(tu);
   end;


procedure noise( freq, time: integer);
   begin
      sound(freq);delay(time);nosound;
   end;


procedure beep;
   begin
      noise( 1000, 200);
   end;


procedure newline;
   begin
      write(#13#10);
   end;


function readkey( var Special : Boolean ) : char;
   var ch : char;
      quit:boolean;
   begin
      Special := false;
      quit := false;
      repeat
         if keypressed then begin
            quit := true;
            read(kbd,ch);
            if ( ch = #27) and keypressed then begin
               read(kbd,ch);
               Special := true;
            end;
         end;
      until quit;
      readkey := ch;
   end;


procedure Strip(var Line : Window_Big_String;
                var Len  : Integer;
                   Break : Window_Char_Set);
   var  Indx: Integer;
   begin
      Len := Length(Line);
      if Len > 0 then begin
        Indx := 0;
        while (Line[Indx+1] in Break) and (Indx < Len) do
          Indx := Indx + 1;
        Delete(Line,1,Indx);
        Len := Len - Indx;
      end
   end;


function parse(var Line: Window_Big_String;
                        Break : Window_Char_Set;
               var nl : boolean  ) : Window_Little_String;
   var
      Len,Indx           : Integer;
   begin
       parse := '';
       Strip(Line,Len,Break);
       if Len = 0
          then Exit;
       Indx := 0;
       while not (Line[Indx+1] in Break) and (Indx < Len) do
          Indx := Indx + 1;
       nl := (Line[Indx+1] = '&');
       parse := Copy(Line,1,Indx);
       Delete(Line,1,Indx);
       Strip(Line,Len,Break)
   end;


procedure PlaceText( text : Window_Big_String );
   var Breakset : Window_Char_Set;
       word     : Window_Little_String;
       leftover,row,column,s1,s2 : integer;
       nl       : boolean;
   begin
      breakset := [' ','&'];
      with currentscreendata do with windowloc[page] do begin
         write(' ');
         repeat
            word := parse(text,breakset,nl);
            readcursorposition(page,row,column,s1,s2);
            leftover := x2 - column;
            if length(word) < leftover then begin
                write(word);
                write(' ');
                end
            else begin
                newline;write(' ');
                write(word);write(' ');
            end;
            if nl then begin
                newline;write(' ');
            end;
         until text = '';

      end;
   end;


function gettext( filename: Window_Little_String;
                      line:integer):Window_Big_String;
    var textfile : text;
        i:integer;
        textstring : Window_Big_String;
    begin
       assign(textfile,filename);
       {$I-} reset(textfile) {$I+};
       if IOResult <> 0 then begin
          windowexit;
          selectpage(0);gotoxy(1,23);
          writeln;
          writeln('Text file ',filename,' not found.  ABORTING.');
          halt;
       end;
       i := 0;
       while i<line do begin
          i := i + 1;
          readln(textfile,textstring);
       end;
       close(textfile);
       gettext := textstring;
    end;