home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / EGATOOLS.ZIP / EGATOOLS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-12-04  |  8.8 KB  |  410 lines
  1. {Enhanced Graphics Adapter toolbox in Turbo pascal:
  2.  
  3.         Authors:   Frank Guenther    (Compuserve 76545,666)
  4.                    Steve Olson
  5.  
  6.         Date   :   Dec 2 1985
  7.  
  8.         Contact at "The Programmers Toolbox"
  9.                     (301) 540-7230  (data)
  10.  
  11.                   ******************************
  12.                   These procedures and functions
  13.                   are in the public domain.
  14.                   ******************************
  15.  
  16.                                                                               }
  17. program ega;
  18.  
  19. type
  20.   regpak=
  21.      record AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS:INTeger END;
  22.   str80=string[80];
  23.   pstr80=^str80;
  24.   coltype=array[0..15] of byte;
  25.  
  26. const defcol:coltype=($0,$1,$2,$3,$4,$5,$14,$7,
  27.                       $38,$39,$3A,$3B,$3C,$3D,$3E,$3F);
  28.  
  29. var stemp:str80;
  30.     x,y,color,bakcolor,ega_mode,ega_mem,ega_feature,ega_switch:integer;
  31.     setcolors:array[0..15] of integer;
  32.  
  33. function get_key:integer;
  34. var r:regpak;
  35. begin
  36.   r.ax:=0;
  37.   intr($16,r);
  38.   if lo(r.ax)=0 then get_key:=hi(r.ax)+256
  39.     else get_key:=lo(r.ax);
  40. end;
  41.  
  42. procedure writestr(wstr:str80;wx,wy:integer;wcolor:byte);
  43. var
  44.   wr:regpak;
  45. begin
  46.   if (wx<0) or (wx>79) or (wy<0) or (wy>24) then exit;
  47.   with wr do begin
  48.   ES:=seg(wstr[1]);
  49.   BP:=ofs(wstr[1]);
  50.   BX:=wcolor;
  51.   CX:=length(wstr);
  52.   DX:=(wy shl 8)+wx;
  53.   AX:=$1301;
  54.   intr(16,wr);
  55.   end;
  56. end;
  57.  
  58. procedure egaset(eset:byte);
  59. var er:regpak;
  60. begin
  61.   er.AX:=eset;
  62.   intr(16,er);
  63. end;
  64.  
  65. procedure setmode(smode:byte);
  66. begin
  67.   port[$3CE]:=5;
  68.   port[$3CF]:=smode;
  69. end;
  70.  
  71. procedure setpalette(spalnum,spalcolor:byte);
  72. var sr:regpak;
  73. begin
  74.   sr.AX:=$1000;
  75.   sr.BX:=(spalcolor shl 8)+spalnum;
  76.   intr(16,sr);
  77. end;
  78.  
  79. procedure egainfo;
  80. var er:regpak;
  81. begin
  82.   er.AX:=$1200;
  83.   er.BX:=$10;
  84.   intr(16,er);
  85.   ega_mode:=hi(er.BX);
  86.   ega_mem:=lo(er.BX);
  87.   ega_feature:=hi(er.CX);
  88.   ega_switch:=lo(er.CX);
  89. end;
  90.  
  91. procedure hrpixel(hx,hy:integer;hcol:byte);
  92. var loc,i:integer;
  93.     bmask:byte;
  94. begin
  95.   if (hx<0) or (hx>639) or (hy<0) or (hy>349) then exit;
  96.   loc:=hy*80+(hx shr 3);
  97.   i:=7-(hx mod 8);
  98.   bmask:=(1 shl i);
  99.   setmode(2);
  100.   port[$3CE]:=8;
  101.   port[$3CF]:=bmask;
  102.   i:=mem[$A000:loc];
  103.   mem[$A000:loc]:=hcol;
  104.   setmode(0);
  105.   port[$3CE]:=8;
  106.   port[$3CF]:=$FF;
  107. end;
  108.  
  109. function getpixval(hx,hy:integer):integer;
  110. var loc,i:integer;
  111.     bmask:byte;
  112. begin
  113.   getpixval:=-1;
  114.   if (hx<0) or (hx>639) or (hy<0) or (hy>349) then exit;
  115.   loc:=hy*80+(hx shr 3);
  116.   i:=7-(hx mod 8);
  117.   bmask:=(1 shl i);
  118.   i:=3;hx:=0;
  119.   repeat
  120.     port[$3CE]:=4;
  121.     port[$3CF]:=i;
  122.     hy:=mem[$A000:loc];
  123.     hx:=hx shl 1;
  124.     if (hy and bmask)>0 then hx:=hx+1;
  125.     i:=i-1;
  126.   until i=-1;
  127.   getpixval:=hx;
  128. end;
  129.  
  130. function readpix(hx,hy:integer;hcol:byte):integer;
  131. var loc,i,j:integer;
  132.     bmask:byte;
  133. begin
  134.   readpix:=0;
  135.   if (hx<0) or (hx>639) or (hy<0) or (hy>349) then exit;
  136.   loc:=hy*80+(hx shr 3);
  137.   i:=7-(hx mod 8);
  138.   bmask:=(1 shl i);
  139.   setmode(8);
  140.   port[$3CE]:=2;
  141.   port[$3CF]:=hcol;
  142.   hy:=mem[$A000:loc];
  143.   readpix:=(bmask shl 8)+(hy and $FF);
  144. end;
  145.  
  146. function testpix(hx,hy:integer;hcol:byte):boolean;
  147. var pixval,bmask:integer;
  148. begin
  149.   testpix:=false;
  150.   pixval:=readpix(hx,hy,hcol);
  151.   bmask:=hi(pixval);
  152.   pixval:=lo(pixval);
  153.   if (bmask and pixval)>0 then testpix:=true;
  154. end;
  155.  
  156. function findpix(hx,hy:integer;hcol:byte):integer;
  157. var pixval,bmask,tmask,result,count:integer;
  158. begin
  159.   findpix:=-99;
  160.   pixval:=readpix(hx,hy,hcol);
  161.   if (lo(pixval)=0) then exit;
  162.   bmask:=hi(pixval);
  163.   pixval:=lo(pixval);
  164.   result:=99;tmask:=bmask;count:=0;
  165.   while (tmask>0) and (result=99) do begin
  166.     if (tmask and pixval)>0 then result:=count;
  167.     count:=count+1;
  168.     tmask:=(bmask shr count);
  169.   end;
  170.   tmask:=(bmask shl 1);count:=1;
  171.   while (tmask<256) and (result>0) do begin
  172.     if (tmask and pixval)>0 then result:=-count;
  173.     count:=count+1;
  174.     tmask:=(bmask shl count);
  175.   end;
  176.   findpix:=result;
  177. end;
  178.  
  179. procedure hrclear(ccolor:byte);
  180. var i:integer;
  181. begin
  182.   for i:=0 to 7 do hrpixel(i,0,ccolor);
  183.   setmode(1);
  184.   i:=mem[$A000:0000];
  185.   i:=0;
  186.   repeat
  187.     memw[$A000:i]:=ccolor;
  188.     i:=i+2;
  189.   until i=28000;
  190.   setmode(0);
  191. end;
  192.  
  193. procedure hrline(xstr,ystr,xend,yend:integer;lcolor:byte);
  194.  
  195. procedure regline(xs,ys,xe,ye:integer);
  196. var ii,jj:integer;
  197. begin
  198.   ii:=((xe-xs) div 2)+xs;
  199.   jj:=((ye-ys) div 2)+ys;
  200.   if ((ii=xs) and (jj=ys)) then exit;
  201.   hrpixel(ii,jj,lcolor);
  202.   regline(xs,ys,ii,jj);
  203.   regline(ii,jj,xe,ye);
  204. end;
  205.  
  206. begin
  207.   regline(xstr,ystr,xend,yend);
  208.   hrpixel(xstr,ystr,lcolor);
  209.   hrpixel(xend,yend,lcolor);
  210. end;
  211.  
  212. procedure drawbox(xstr,ystr,xend,yend,boxcolor:integer);
  213. begin
  214.   hrline(xstr,ystr,xend,ystr,boxcolor);
  215.   hrline(xend,ystr,xend,yend,boxcolor);
  216.   hrline(xend,yend,xstr,yend,boxcolor);
  217.   hrline(xstr,yend,xstr,ystr,boxcolor);
  218. end;
  219.  
  220. procedure fillbox(xstr,ystr,xend,yend,boxcolor:integer);
  221. var i,ii,j,jj,k,l:integer;
  222. begin
  223.   if xend<xstr then begin
  224.     i:=xstr;
  225.     xstr:=xend;
  226.     xend:=i;
  227.   end;
  228.   if yend<ystr then begin
  229.     i:=ystr;
  230.     ystr:=yend;
  231.     yend:=i;
  232.   end;
  233.   k:=xstr div 8;
  234.   l:=xend div 8;
  235.   if (xend mod 8)>0 then l:=l+1;
  236.   for ii:=xstr to xend do hrpixel(ii,ystr,boxcolor);
  237.   setmode(1);
  238.   for i:=ystr+1 to yend do
  239.     for ii:=k to l do begin
  240.       j:=(i-1)*80+ii;
  241.       jj:=mem[$A000:j];
  242.       j:=j+80;
  243.       mem[$A000:j]:=boxcolor;
  244.     end;
  245.   setmode(0);
  246. end;
  247.  
  248. procedure xorbox(xstr,ystr,xend,yend,xorval:integer);
  249. var xs,xe,i,j,k,loc:integer;
  250. begin
  251.   port[$3CE]:=3;
  252.   port[$3CF]:=$18;
  253.   xs:=xstr div 8;
  254.   xe:=xend div 8;
  255.   setmode(2);
  256.   port[$3CE]:=8;
  257.   port[$3CF]:=$FF;
  258.   for j:=ystr to yend do
  259.     for i:=xs to xe do begin
  260.       if i=xs then begin
  261.         for k:=xstr to xstr+7-(xstr mod 8) do hrpixel(k,j,xorval);
  262.         setmode(2);
  263.       end else if i=xe then begin
  264.         for k:=xe*8 to xend do hrpixel(k,j,xorval);
  265.         setmode(2);
  266.       end else begin
  267.         loc:=j*80+i;
  268.         k:=mem[$A000:loc];
  269.         mem[$A000:loc]:=xorval;
  270.       end;
  271.     end;
  272.   setmode(0);
  273.   port[$3CE]:=3;
  274.   port[$3CF]:=0;
  275. end;
  276.  
  277. procedure xorstring(hx,hy,hlength:integer);
  278. var i,j:integer;
  279. begin
  280.   hx:=hx*8;
  281.   i:=hx+(hlength*8)-1;
  282.   hy:=hy*14;
  283.   j:=hy+13;
  284.   xorbox(hx,hy,i,j,$F);
  285. end;
  286.  
  287. procedure drawcircle(xs,ys,rad,dcolor:integer;flg:byte);
  288. var
  289.     i,ma,mb,mc,md,aa,bb,cc,dd,ee,ff,gg,hh,incr2 : integer;
  290.     r1,r2,x,y,temp,incr,fixrad:real;
  291.     flgs:array[1..8] of boolean;
  292.  
  293. begin
  294.   incr:=Pi/(3.1*rad);
  295.   incr2:=round(10000*incr);  {integer incr; speed up loop}
  296.   r1:=sin(incr);
  297.   r2:=cos(incr);             {close to 1; ignore in calculations}
  298.   fixrad:=0.8*rad;
  299.   for i:=0 to 7 do           {Precalculate to speed up loop}
  300.     if (flg and (1 shl i))>0 then flgs[i+1]:=true
  301.       else flgs[i+1]:=false;
  302.   i:=0;x:=1;y:=0;
  303.   while i<=7854 do begin
  304.    ma:=round(rad*x);
  305.    mb:=round(fixrad*y);
  306.    mc:=round(rad*y);
  307.    md:=round(fixrad*x);
  308.    aa:=xs+ma;
  309.    bb:=ys+mb;
  310.    cc:=ys-mb;
  311.    dd:=xs-ma;
  312.    ee:=xs+mc;
  313.    ff:=ys+md;
  314.    gg:=ys-md;
  315.    hh:=xs-mc;
  316.    if flgs[8] then hrpixel(aa,bb,dcolor);
  317.    if flgs[1] then hrpixel(aa,cc,dcolor);
  318.    if flgs[5] then hrpixel(dd,bb,dcolor);
  319.    if flgs[4] then hrpixel(dd,cc,dcolor);
  320.    if flgs[7] then hrpixel(ee,ff,dcolor);
  321.    if flgs[2] then hrpixel(ee,gg,dcolor);
  322.    if flgs[6] then hrpixel(hh,ff,dcolor);
  323.    if flgs[3] then hrpixel(hh,gg,dcolor);
  324.    temp:=y;
  325.    y:=y+x*r1;
  326.    x:=x-temp*r1;
  327.    i:=i+incr2;
  328.   end;
  329. end;
  330.  
  331. procedure palette;
  332. var col,pixcol,row,i,j,k:integer;
  333. begin
  334.   for i:=0 to 15 do begin
  335.     row:=(i div 4);
  336.     col:=(i mod 4);
  337.     row:=row*80+20;
  338.     col:=col*20+5;
  339.     pixcol:=col*8;
  340.     j:=row-1;
  341.     k:=pixcol-1;
  342.     fillbox(pixcol,row,pixcol+79,row+39,i);
  343.     drawbox(k,j,k+81,j+41,0);
  344.   end;
  345. end;
  346.  
  347. procedure interact;
  348. var i,ii,j,jj,k:integer;
  349.  
  350. procedure dbox(dpal,dcol:integer);
  351. var di,dj:integer;
  352. begin
  353.   di:=dpal div 4;
  354.   dj:=dpal mod 4;
  355.   di:=di*80+20-5;
  356.   dj:=(dj*20+5)*8-5;
  357.   drawbox(dj,di,dj+89,di+49,dcol);
  358. end;
  359.  
  360. begin
  361.   writestr('Press ESC to QUIT.',0,23,5);
  362.   xorstring(0,23,18);
  363.   for i:=0 to 15 do setcolors[i]:=defcol[i];
  364.   i:=0;j:=defcol[0];
  365.   ii:=i;
  366.   dbox(i,1);
  367.   repeat
  368.     repeat until keypressed;
  369.     k:=get_key;
  370.     case k of
  371.       27:exit;
  372.      328:j:=j+1;
  373.      336:j:=j-1;
  374.      331:i:=i-1;
  375.      333:i:=i+1;
  376.      else writeln(chr(7));
  377.    end;
  378.    if i>15 then i:=0;
  379.    if i<0 then i:=15;
  380.    if j>63 then j:=0;
  381.    if j<0 then j:=63;
  382.    if i<>ii then begin
  383.      dbox(ii,bakcolor);
  384.      dbox(i,1);
  385.      ii:=i;
  386.      j:=setcolors[i];
  387.      jj:=j;
  388.    end;
  389.    if j<>jj then begin
  390.      setpalette(i,j);
  391.      setcolors[i]:=j;
  392.      jj:=j;
  393.    end;
  394.  until i=16;
  395. end;
  396.  
  397. begin
  398.   clrscr;
  399.   bakcolor:=$3;
  400.   egaset(16);
  401.   setmode(0);
  402.   hrclear(bakcolor);
  403.   egainfo;
  404.   palette;
  405.   interact;
  406.   egaset(3);
  407.   for x:=0 to 15 do writeln('Palette ',x :2,'= ',setcolors[x]);
  408. end.
  409.  
  410.