home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 276.img / FORUM21S.ZIP / SCRNUNIT.ARC / SCRNUNIT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-12-21  |  9.2 KB  |  385 lines
  1. unit scrnunit;
  2.  
  3. {$R-,S-,I-,D-,V-,B-}
  4.  
  5. interface
  6.  
  7. uses dos,crt;
  8.  
  9. {$L c:\units\scrnunit\scrn.obj}
  10.  
  11. const maxwindows=20;
  12.  
  13. type dataarearec=record
  14.        scrnseg,
  15.        filter,
  16.        wchattr,
  17.        wch,
  18.        wattr,
  19.        rchattr,
  20.        scrnwid,
  21.        dubscrnwid,
  22.        numwindows,
  23.        curwindow,
  24.        beepduration,
  25.        beepfrequency,
  26.        realcursortrack:integer;
  27.        windul,
  28.        windlr,
  29.        windulptr,
  30.        windsize,
  31.        windcursor,
  32.        windcptr,
  33.        windattr:array [1..maxwindows] of integer
  34.      end;
  35.  
  36.      block=record
  37.        x1,y1,x2,y2:byte
  38.      end;
  39.  
  40.      window=record
  41.        handle,index,
  42.        x1,y1,x2,y2,xsize,ysize,
  43.        titlecolor,framecolor,normalcolor,
  44.        boldcolor,datacolor,choicecolor,barcolor,inputcolor,
  45.        imagesize:integer;
  46.        imageptr:pointer;
  47.        title:string[80]
  48.      end;
  49.  
  50.      windowptr=^window;
  51.  
  52.      jointtype=(vertleft,vertright,horizup,horizdown,cross);
  53.  
  54. var scrn:text;           { Accessed by SCRN.ASM }
  55.     darea:dataarearec;   { Accessed by SCRN.ASM }
  56.  
  57.     wholescreen:window;
  58.     curwindowptr:windowptr;
  59.  
  60. procedure initscrnunit;
  61. procedure setblock (var b:block; x1,y1,x2,y2:integer);
  62. procedure pushcurwindow;
  63. procedure popcurwindow;
  64. procedure pushdarea;       { DON'T DO pusdarea; movewindow; popdarea!!!! }
  65. procedure popdarea;
  66. procedure setcurwindow (var w:window);
  67. procedure openwindow (var w:window; x1,y1,x2,y2,framecolor,normalcolor:integer);
  68. procedure windowtitle (title:string);
  69. procedure closewindow;
  70. procedure movewindow (nx,ny:integer);
  71. procedure reshapewindow (x1,y1,x2,y2:integer);
  72. procedure gotoxy (x,y:integer);
  73. procedure drawjoint (x,y:integer; jt:jointtype);
  74. function  wherex:integer;
  75. function  wherey:integer;
  76. function  curcolor:integer;
  77. procedure colorregion (x1,x2,y,attr:integer);
  78. procedure clreol;
  79. procedure clrscr;
  80. procedure setfilter (filtersnow:boolean);
  81. procedure setcursortracking (realtrack:boolean);
  82. procedure fillblock (b:block; ch:char; a:integer);
  83. procedure clearblock (b:block; a:integer);
  84. procedure colorblock (b:block; a:integer);
  85. procedure frameblock (b:block; a:integer);
  86. procedure scrupblock (b:block; a:integer);
  87. procedure scrdnblock (b:block; a:integer);
  88. procedure readblock (b:block; var buffer);
  89. procedure writeblock (b:block; var buffer);
  90. procedure fillwindow (ch:char; a:integer);
  91. procedure clearwindow (a:integer);
  92. procedure colorwindow (a:integer);
  93. procedure framewindow (a:integer);
  94. procedure scrupwindow (a:integer);
  95. procedure scrdnwindow (a:integer);
  96. procedure readwindow (var buffer);
  97. procedure writewindow (var buffer);
  98. procedure setcolor (attr:integer);
  99. procedure movecsr;
  100.  
  101. implementation
  102.  
  103. const windowstacksize=50;
  104.       dareastacksize=50;
  105.       jointchars:array [vertleft..cross] of char=(#180,#195,#193,#194,#197);
  106.  
  107. type dareaptr=^dataarearec;
  108.  
  109. var windowstack:array [0..windowstacksize] of windowptr;
  110.     windowstackptr:integer;
  111.     dareastack:array [1..dareastacksize] of dareaptr;
  112.     dareastackcwp:array [1..dareastacksize] of windowptr;
  113.     dareastackptr:integer;
  114.  
  115. {$F+}
  116.  
  117. procedure setfilter (filtersnow:boolean); external;
  118. procedure setcursortracking (realtrack:boolean); external;
  119. procedure fillblock (b:block; ch:char; a:integer); external;
  120. procedure clearblock (b:block; a:integer); external;
  121. procedure colorblock (b:block; a:integer); external;
  122. procedure frameblock (b:block; a:integer); external;
  123. procedure scrupblock (b:block; a:integer); external;
  124. procedure scrdnblock (b:block; a:integer); external;
  125. procedure readblock (b:block; var buffer); external;
  126. procedure writeblock (b:block; var buffer); external;
  127. procedure fillwindow (ch:char; a:integer); external;
  128. procedure clearwindow (a:integer); external;
  129. procedure colorwindow (a:integer); external;
  130. procedure framewindow (a:integer); external;
  131. procedure scrupwindow (a:integer); external;
  132. procedure scrdnwindow (a:integer); external;
  133. procedure readwindow (var buffer); external;
  134. procedure writewindow (var buffer); external;
  135. procedure setcolor (attr:integer); external;
  136. procedure movecsr; external;
  137.  
  138. procedure initscrn; external;    {These aren't public}
  139. procedure setwindow (x1,y1,x2,y2:integer); external;
  140. procedure movexy (x,y:integer); external;
  141. function  initwindow (x1,y1,x2,y2:integer):integer; external;
  142. procedure killwindow; external;
  143.  
  144. {$F-}
  145.  
  146. procedure setblock (var b:block; x1,y1,x2,y2:integer);
  147. begin
  148.   b.x1:=x1;
  149.   b.y1:=y1;
  150.   b.x2:=x2;
  151.   b.y2:=y2
  152. end;
  153.  
  154. procedure setcurwindow (var w:window);
  155. begin
  156.   darea.curwindow:=w.handle;
  157.   curwindowptr:=@w;
  158.   if darea.realcursortrack<>0 then movecsr
  159. end;
  160.  
  161. procedure pushcurwindow;
  162. begin
  163.   if windowstackptr>=windowstacksize then begin
  164.     writeln ('Too many pushed windows');
  165.     halt (1)
  166.   end;
  167.   inc (windowstackptr);
  168.   windowstack[windowstackptr]:=curwindowptr
  169. end;
  170.  
  171. procedure popcurwindow;
  172. begin
  173.   setcurwindow (windowstack[windowstackptr]^);
  174.   if windowstackptr>0 then dec (windowstackptr)
  175. end;
  176.  
  177. procedure pushdarea;
  178. begin
  179.   if dareastackptr>=dareastacksize then begin
  180.     writeln ('Too many pushed data areas');
  181.     halt (1)
  182.   end;
  183.   inc (dareastackptr);
  184.   new (dareastack[dareastackptr]);
  185.   dareastack[dareastackptr]^:=darea;
  186.   dareastackcwp[dareastackptr]:=curwindowptr
  187. end;
  188.  
  189. procedure popdarea;
  190. begin
  191.   if dareastackptr>0 then begin
  192.     darea:=dareastack[dareastackptr]^;
  193.     curwindowptr:=dareastackcwp[dareastackptr];
  194.     dispose (dareastack[dareastackptr]);
  195.     dec (dareastackptr);
  196.   end
  197. end;
  198.  
  199. procedure setwindowcoors (nx1,ny1,nx2,ny2:integer);
  200. begin
  201.   with curwindowptr^ do begin
  202.     setwindow (nx1,ny1,nx2,ny2);
  203.     x1:=nx1;
  204.     y1:=ny1;
  205.     x2:=nx2;
  206.     y2:=ny2;
  207.     xsize:=nx2-nx1-1;
  208.     ysize:=ny2-ny1-1;
  209.     imagesize:=(xsize+2)*(ysize+2)*2
  210.   end
  211. end;
  212.  
  213. procedure openwindow (var w:window; x1,y1,x2,y2,framecolor,normalcolor:integer);
  214. begin
  215.   pushcurwindow;
  216.   x1:=x1-1;
  217.   y1:=y1-1;
  218.   x2:=x2-1;
  219.   y2:=y2-1;
  220.   w:=wholescreen;
  221.   w.handle:=initwindow (x1,y1,x2,y2);
  222.   setcurwindow (w);
  223.   if w.handle<0 then begin
  224.     writeln ('Too many opened windows');
  225.     halt (1)
  226.   end;
  227.   w.index:=(w.handle div 2)+1;
  228.   setwindowcoors (x1,y1,x2,y2);
  229.   w.framecolor:=framecolor;
  230.   w.normalcolor:=normalcolor;
  231.   getmem (w.imageptr,w.imagesize);
  232.   readwindow (w.imageptr^);
  233.   framewindow (framecolor);
  234.   clearwindow (normalcolor)
  235. end;
  236.  
  237. procedure windowtitle (title:string);
  238. begin
  239.   pushdarea;
  240.   movexy (1,0);
  241.   setcolor (curwindowptr^.titlecolor);
  242.   curwindowptr^.title:=title;
  243.   write (scrn,copy(title,1,curwindowptr^.xsize));
  244.   popdarea
  245. end;
  246.  
  247. procedure closewindow;
  248. var w:windowptr;
  249. begin
  250.   w:=curwindowptr;
  251.   if w^.handle=0 then exit;
  252.   writewindow (w^.imageptr^);
  253.   freemem (w^.imageptr,w^.imagesize);
  254.   killwindow;
  255.   w^.handle:=0;
  256.   popcurwindow
  257. end;
  258.  
  259. {$S+}
  260.  
  261. procedure reshapewindow (x1,y1,x2,y2:integer);
  262. var contblock:block;
  263.     contents:array[1..4096] of byte;
  264.     nxs,nys,cx2,cy2:integer;
  265.     w:windowptr;
  266. begin
  267.   x1:=x1-1;
  268.   y1:=y1-1;
  269.   x2:=x2-1;
  270.   y2:=y2-1;
  271.   w:=curwindowptr;
  272.   nxs:=x2-x1-1;
  273.   nys:=y2-y1-1;
  274.   if nxs<w^.xsize then cx2:=nxs else cx2:=w^.xsize;
  275.   if nys<w^.ysize then cy2:=nys else cy2:=w^.ysize;
  276.   setblock (contblock,0,0,cx2,cy2);
  277.   readblock (contblock,contents);
  278.   writewindow (w^.imageptr^);
  279.   freemem (w^.imageptr,w^.imagesize);      { Old window essentially closed }
  280.   setwindowcoors (x1,y1,x2,y2);
  281.   getmem (w^.imageptr,w^.imagesize);
  282.   readwindow (w^.imageptr^);
  283.   framewindow (contents[2]);    { Use attribute from screen }
  284.   clearwindow (w^.normalcolor);
  285.   writeblock (contblock,contents)
  286. end;
  287.  
  288. {$S-}
  289.  
  290. procedure movewindow (nx,ny:integer);
  291. begin
  292.   with curwindowptr^ do
  293.     reshapewindow (nx,ny,nx+xsize+1,ny+ysize+1)
  294. end;
  295.  
  296. procedure gotoxy (x,y:integer);
  297. begin
  298.   movexy (x,y)
  299. end;
  300.  
  301. procedure drawjoint (x,y:integer; jt:jointtype);
  302. begin
  303.   pushcurwindow;
  304.   x:=x+curwindowptr^.x1;
  305.   y:=y+curwindowptr^.y1;
  306.   setcurwindow (wholescreen);
  307.   gotoxy (x,y);
  308.   write (jointchars[jt]);
  309.   popcurwindow
  310. end;
  311.  
  312. function wherex:integer;
  313. begin
  314.   wherex:=lo(darea.windcursor[curwindowptr^.index])
  315. end;
  316.  
  317. function wherey:integer;
  318. begin
  319.   wherey:=darea.windcursor[curwindowptr^.index] shr 8
  320. end;
  321.  
  322. function curcolor:integer;
  323. begin
  324.   curcolor:=darea.windattr[curwindowptr^.index]
  325. end;
  326.  
  327. procedure colorregion (x1,x2,y,attr:integer);
  328. var b:block;
  329. begin
  330.   setblock (b,x1,y,x2,y);
  331.   colorblock (b,attr)
  332. end;
  333.  
  334. procedure clreol;
  335. var b:block;
  336.     y:integer;
  337. begin
  338.   y:=wherey;
  339.   setblock (b,wherex,y,curwindowptr^.xsize,y);
  340.   clearblock (b,curcolor)
  341. end;
  342.  
  343. procedure clrscr;
  344. begin
  345.   clearwindow (curcolor);
  346.   gotoxy (1,1)
  347. end;
  348.  
  349. procedure initscrnunit;
  350. begin
  351.   initscrn;
  352.   with wholescreen do begin
  353.     handle:=0;
  354.     index:=1;
  355.     x1:=-1;
  356.     y1:=-1;
  357.     x2:=darea.scrnwid;
  358.     y2:=25;
  359.     xsize:=x2;
  360.     ysize:=y2;
  361.     titlecolor:=$70;
  362.     framecolor:=7;
  363.     normalcolor:=7;
  364.     boldcolor:=15;
  365.     choicecolor:=15;
  366.     datacolor:=15;
  367.     barcolor:=$70;
  368.     inputcolor:=15;
  369.     imagesize:=0;
  370.     imageptr:=nil
  371.   end;
  372.   dareastackptr:=0;
  373.   windowstackptr:=0;
  374.   windowstack[0]:=@wholescreen;
  375.   curwindowptr:=@wholescreen;
  376.   with textrec(output) do begin
  377.     inoutfunc:=textrec(scrn).inoutfunc;
  378.     flushfunc:=textrec(scrn).flushfunc
  379.   end
  380. end;
  381.  
  382. begin
  383.   initscrnunit
  384. end.
  385.