home *** CD-ROM | disk | FTP | other *** search
/ The Unsorted BBS Collection / thegreatunsorted.tar / thegreatunsorted / hacking / phreak_utils_pc / grwins.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-04-01  |  3.3 KB  |  121 lines
  1. unit grwins;
  2.  
  3. interface
  4.  
  5. uses crt, types, video, bbp_vars, ferror, vgagraph;
  6.  
  7. var old :array [1..100] of pointer;
  8.     x   :byte;
  9.     cnt :byte;
  10.  
  11. procedure OpenBox(num,ux,uy,lx,ly:byte;shadow,fill,zoom:boolean);
  12. procedure CloseBox(num:byte);
  13. procedure IgnBox(num:byte);
  14.  
  15. implementation
  16.  
  17. function Stg(w:word):String;
  18. var s:string;
  19. begin
  20.   str(w,s);
  21.   stg:=s;
  22. end;
  23.  
  24. procedure put(x,y,col:byte;c:char);
  25. begin
  26.   mem[vadr:2*((y-1)*80+x)-2]:=ord(c);
  27.   mem[vadr:2*((y-1)*80+x)-1]:=col;
  28. end;
  29.  
  30. procedure vshadow(x,y:byte);
  31. begin
  32.   mem[vadr:2*((y-1)*80+x)-1]:=colors.shadow;
  33. end;
  34.  
  35. procedure drawbox(ux,uy,lx,ly:byte;fill:boolean);
  36. var x:byte;
  37. begin
  38.   put(ux,uy,colors.win_border_1,'┌');
  39.   put(lx,uy,colors.win_border_1,'┐');
  40.   put(ux,ly,colors.win_border_1,'└');
  41.   put(lx,ly,colors.win_border_1,'┘');
  42.   put(ux+1,uy,colors.win_border_1,'─');
  43.   put(lx-1,uy,colors.win_border_1,'─');
  44.   put(ux+1,ly,colors.win_border_1,'─');
  45.   put(lx-1,ly,colors.win_border_1,'─');
  46.   put(ux+2,uy,colors.win_border_2,'─');
  47.   put(lx-2,uy,colors.win_border_2,'─');
  48.   put(ux+2,ly,colors.win_border_2,'─');
  49.   put(lx-2,ly,colors.win_border_2,'─');
  50.   put(ux+3,uy,colors.win_border_2,'─');
  51.   put(lx-3,uy,colors.win_border_2,'─');
  52.   put(ux+3,ly,colors.win_border_2,'─');
  53.   put(lx-3,ly,colors.win_border_2,'─');
  54.   put(ux,uy+1,colors.win_border_2,'│');
  55.   put(ux,ly-1,colors.win_border_2,'│');
  56.   put(lx,uy+1,colors.win_border_2,'│');
  57.   put(lx,ly-1,colors.win_border_2,'│');
  58.   for x:=ux+4 to lx-4 do put(x,uy,colors.win_border_3,'─');
  59.   for x:=ux+4 to lx-4 do put(x,ly,colors.win_border_3,'─');
  60.   for x:=uy+2 to ly-2 do put(ux,x,colors.win_border_3,'│');
  61.   for x:=uy+2 to ly-2 do put(lx,x,colors.win_border_3,'│');
  62.   if fill then for x:=ux+1 to lx-1 do for y:=uy+1 to ly-1 do put(x,y,colors.win_fill,' ');
  63. end;
  64.  
  65. procedure zoombox(eulx,euly,elrx,elry:byte);
  66. var ulx, uly, lrx, lry :word;
  67. begin
  68.   ulx:=eulx+((elrx-eulx) div 2)-1;
  69.   uly:=euly+((elry-euly) div 2)-1;
  70.   lrx:=eulx+((elrx-eulx) div 2)+1;
  71.   lry:=euly+((elry-euly) div 2)+1;
  72.   while not((ulx=eulx) and (uly=euly) and (lrx=elrx) and (lry=elry)) do begin
  73.     if cnt=0 then begin cnt:=1; vsync; end else dec(cnt);
  74.     drawbox(ulx,uly,lrx,lry,true);
  75.     if ulx>eulx then dec(ulx);
  76.     if uly>euly then dec(uly);
  77.     if lrx<elrx then inc(lrx);
  78.     if lry<elry then inc(lry);
  79.   end;
  80. end;
  81.  
  82. procedure openbox(num,ux,uy,lx,ly:byte;shadow,fill,zoom:boolean);
  83. var x,y :byte;
  84. begin
  85.   cnt:=0;
  86.   if old[num]<>nil then fatalerror('Window save pointer #'+stg(num)+' is already busy. Report to author.');
  87.   if num<>0 then begin
  88.     getmem(old[num],4000);
  89.     move(mem[vadr:0],old[num]^,4000);
  90.   end;
  91.   if zoom then zoombox(ux,uy,lx,ly);
  92.   drawbox(ux,uy,lx,ly,fill);
  93.   if shadow then begin
  94.     for x:=ux+2 to lx+2 do vshadow(x,ly+1);
  95.     for x:=uy+1 to ly do for y:=1 to 2 do vshadow(lx+y,x);
  96.   end;
  97. end;
  98.  
  99. procedure CloseBox(num:byte);
  100. begin
  101.   move(old[num]^,mem[vadr:0],4000);
  102.   freemem(old[num],4000);
  103.   old[num]:=nil;
  104. end;
  105.  
  106. procedure IgnBox(num:byte);
  107. begin
  108.   freemem(old[num],4000);
  109.   old[num]:=nil;
  110. end;
  111.  
  112. begin
  113.   if paramstr(1)='/(C)' then begin
  114.     writeln('GRWINS.PAS       Window & Zoomwindow routines in Txt mode');
  115.     writeln('                 (C) 1991-1994 by Onkel Dittmeyer');
  116.     writeln;
  117.     readln;
  118.   end;
  119.   for x:=1 to 100 do old[x]:=nil;
  120. end.
  121.