home *** CD-ROM | disk | FTP | other *** search
/ Best Objectech Shareware Selections / UNTITLED.iso / boss / grap / util / 006 / whatvga.pas < prev    next >
Pascal/Delphi Source File  |  1993-01-23  |  25KB  |  1,007 lines
  1.  
  2. uses dos,crt,supervga;
  3.  
  4.  
  5. procedure setpix(x,y:word;col:longint);
  6. const
  7.   msk:array[0..7] of byte=(128,64,32,16,8,4,2,1);
  8.   plane :array[0..1] of byte=(5,10);
  9.   plane4:array[0..3] of byte=(1,2,4,8);
  10.   mscga4:array[0..3] of byte=($3f,$cf,$f3,$fc);
  11.   shcga4:array[0..3] of byte=(6,4,2,0);
  12. var l:longint;
  13.     m,z:word;
  14. begin
  15.   case memmode of
  16.    _cga2:begin
  17.            z:=(y shr 1)*bytes+(x shr 3);
  18.            if odd(y) then inc(z,8192);
  19.            mem[$b800:z]:=(mem[$b800:z] and (255 xor msk[x and 7]))
  20.                          or ((col and 1) shl (7-(x and 7)));
  21.          end;
  22.    _cga4:begin
  23.            z:=(y shr 1)*bytes+(x shr 2);
  24.            if odd(y) then inc(z,8192);
  25.            mem[$b800:z]:=(mem[$b800:z] and mscga4[x and 3])
  26.                          or (col and 3) shl shcga4[x and 3];
  27.          end;
  28.     _pl2:begin
  29.            l:=y*bytes+(x shr 3);
  30.            wrinx($3ce,3,0);
  31.            wrinx($3ce,5,2);
  32.            wrinx($3c4,2,1);
  33.            wrinx($3ce,8,msk[x and 7]);
  34.            setbank(l shr 16);
  35.            z:=mem[vseg:word(l)];
  36.            mem[vseg:word(l)]:=col;
  37.          end;
  38.    _pl2e:begin
  39.            l:=y*128+(x shr 3);
  40.            modinx($3ce,5,3,0);
  41.            wrinx($3c4,2,15);
  42.            wrinx($3ce,0,col*3);
  43.            wrinx($3ce,1,3);
  44.            wrinx($3ce,8,msk[x and 7]);
  45.            z:=mem[vseg:word(l)];
  46.            mem[vseg:word(l)]:=0;
  47.          end;
  48.     _pl4:begin
  49.            l:=y*bytes+(x shr 4);
  50.            wrinx($3ce,3,0);
  51.            wrinx($3ce,5,2);
  52.            wrinx($3c4,2,plane[(x shr 3) and 1]);
  53.            wrinx($3ce,8,msk[x and 7]);
  54.            setbank(l shr 16);
  55.            z:=mem[vseg:word(l)];
  56.            mem[vseg:word(l)]:=col;
  57.          end;
  58.     _pk4:begin
  59.            l:=y*bytes+(x shr 2);
  60.            setbank(l shr 16);
  61.            z:=mem[vseg:word(l)] and mscga4[x and 3];
  62.            mem[vseg:word(l)]:=z or (col shl shcga4[x and 3]);
  63.          end;
  64.    _pl16:begin
  65.            l:=y*bytes+(x shr 3);
  66.            wrinx($3ce,3,0);
  67.            wrinx($3ce,5,2);
  68.            wrinx($3ce,8,msk[x and 7]);
  69.            setbank(l shr 16);
  70.            z:=mem[vseg:word(l)];
  71.            mem[vseg:word(l)]:=col;
  72.          end;
  73.    _pk16:begin
  74.            l:=y*bytes+(x shr 1);
  75.            setbank(l shr 16);
  76.            z:=mem[vseg:word(l)];
  77.            if odd(x) then z:=z and $f+(col shl 4)
  78.                      else z:=z and $f0+col;
  79.            mem[vseg:word(l)]:=z;
  80.          end;
  81.    _p256:begin
  82.            l:=y*bytes+x;
  83.            setbank(l shr 16);
  84.            mem[vseg:word(l)]:=col;
  85.          end;
  86.    _p32k,_p64k:
  87.          begin
  88.            l:=y*bytes+(x shl 1);
  89.            setbank(l shr 16);
  90.            memw[vseg:word(l)]:=col;
  91.          end;
  92.    _p16m:begin
  93.            l:=y*bytes+(x*3);
  94.            z:=word(l);
  95.            m:=l shr 16;
  96.            setbank(m);
  97.            if z<$fffe then move(col,mem[vseg:z],3)
  98.            else begin
  99.              mem[vseg:z]:=lo(col);
  100.              if z=$ffff then setbank(m+1);
  101.              mem[vseg:z+1]:=lo(col shr 8);
  102.              if z=$fffe then setbank(m+1);
  103.              mem[vseg:z+2]:=col shr 16;
  104.            end;
  105.          end;
  106.     else ;
  107.   end;
  108. end;
  109.  
  110.  
  111. procedure setvstartxy(x,y:word);
  112. var l:longint;
  113. begin
  114.   l:=0;
  115.   case memmode of
  116.           _pl16:l:=(bytes*y+(x div 8))*4;
  117.           _p256:l:=bytes*y+x;
  118.     _p32k,_p64k:l:=bytes*y+x*2;
  119.           _p16m:l:=bytes*y+x*3;
  120.   end;
  121.   setvstart(l);
  122. end;
  123.  
  124.  
  125. function whitecol:longint;
  126. var col:longint;
  127. begin
  128.   case memmode of
  129.     _cga2,_pl2e,
  130.      _pl2:col:=1;
  131.     _cga4,_pk4
  132.     ,_pl4:col:=3;
  133.     _pk16,_pl16,
  134.     _p256:col:=15;
  135.     _p32k:col:=$7fff;
  136.     _p64k:col:=$ffff;
  137.     _p16m:col:=$ffffff;
  138.   else
  139.   end;
  140.   whitecol:=col;
  141. end;
  142.  
  143.  
  144. procedure wrtext(x,y:word;txt:string);      {write TXT to pos (X,Y)}
  145. type
  146.   pchar=array[char] of array[0..15] of byte;
  147. var
  148.   p:^pchar;
  149.   c:char;
  150.   i,j,z,b:integer;
  151.   ad,bk:word;
  152.   l,v,col:longint;
  153. begin
  154.   rp.bh:=6;
  155.   vio($1130);
  156.   case memmode of
  157.     _cga2,_pl2e,
  158.      _pl2:col:=1;
  159.     _cga4,_pk4
  160.     ,_pl4:col:=3;
  161.     _pk16,_pl16,
  162.     _p256:col:=15;
  163.     _p32k:col:=$7fff;
  164.     _p64k:col:=$ffff;
  165.     _p16m:col:=$ffffff;
  166.   else
  167.   end;
  168.   p:=ptr(rp.es,rp.bp);
  169.   for z:=1 to length(txt) do
  170.   begin
  171.     c:=txt[z];
  172.     for j:=0 to 15 do
  173.     begin
  174.       b:=p^[c][j];
  175.       for i:=0 to 7 do
  176.       begin
  177.         if (b and 128)<>0 then v:=col else v:=0;
  178.         setpix(x+i,y+j,v);
  179.         b:=b shl 1;
  180.       end;
  181.     end;
  182.     inc(x,8);
  183.   end;
  184. end;
  185.  
  186.  
  187. procedure drawtestpattern(nam:string);
  188.                        {Draw Test pattern.}
  189. var s:string;
  190.   l:longint;
  191.   x,y,yst:word;
  192.   white:longint;
  193.  
  194.   function rgb(r,g,b:word):longint;
  195.   begin
  196.     r:=lo(r);g:=lo(g);b:=lo(b);
  197.     case colbits[memmode] of
  198.        1:rgb:=r and 1;
  199.        2:rgb:=r and 3;
  200.        4:rgb:=r and 15;
  201.        8:rgb:=r;
  202.       15:rgb:=((r shr 3) shl 5+(g shr 3)) shl 5+(b shr 3);
  203.       16:rgb:=((r shr 3) shl 6+(g shr 2)) shl 5+(b shr 3);
  204.       24:rgb:=(longint(r) shl 8+g) shl 8 +b;
  205.     end;
  206.   end;
  207.  
  208.  
  209.   procedure wline(stx,sty,ex,ey:integer);
  210.   var x,y,d,mx,my:integer;
  211.      l:longint;
  212.   begin
  213.     if sty>ey then
  214.     begin
  215.       x:=stx;stx:=ex;ex:=x;
  216.       x:=sty;sty:=ey;ey:=x;
  217.     end;
  218.     y:=0;
  219.     mx:=abs(ex-stx);
  220.     my:=ey-sty;
  221.     d:=0;
  222.     repeat
  223.       l:=rgb(y,y,y);
  224.       y:=(y+1) and 255;
  225.       setpix(stx,sty,l);
  226.       if abs(d+mx)<abs(d-my) then
  227.       begin
  228.         inc(sty);
  229.         d:=d+mx;
  230.       end
  231.       else begin
  232.         d:=d-my;
  233.         if ex>stx then inc(stx)
  234.                   else dec(stx);
  235.       end;
  236.     until (stx=ex) and (sty=ey);
  237.  
  238.   end;
  239.  
  240. begin
  241.  
  242.   white:=whitecol;
  243.  
  244.   wline(50,30,pixels-50,30);
  245.   wline(50,lins-30,pixels-50,lins-30);
  246.  
  247.   wline(50,30,50,lins-30);
  248.   wline(pixels-50,30,pixels-50,lins-30);
  249.   wline(50,30,pixels-50,lins-30);
  250.  
  251.   wline(pixels-50,30,50,lins-30);
  252.  
  253.   if lins>200 then yst:=50 else yst:=10;
  254.   wrtext(10,yst,name+' with '+istr(mm)+' Kbytes.');
  255.   wrtext(10,yst+25,nam);
  256.  
  257.   for x:=1 to (pixels-10) div 100 do
  258.   begin
  259.     for y:=1 to 10 do
  260.       setpix(x*100,y,white);
  261.     wrtext(x*100+3,1,istr(x));
  262.   end;
  263.  
  264.   for x:=1 to (lins-10) div 100 do
  265.   begin
  266.     for y:=1 to 10 do
  267.       setpix(y,x*100,white);
  268.     wrtext(1,x*100+2,istr(x));
  269.   end;
  270.  
  271.   case memmode of
  272.      _pk4,
  273.      _pl4:for x:=0 to 63 do
  274.             for y:=0 to 63 do
  275.               setpix(30+x,yst+y+50,y shr 3);
  276.     _pk16,
  277.     _pl16:for x:=0 to 127 do
  278.             if lins<250 then
  279.               for y:=0 to 63 do
  280.                 setpix(30+x,yst+y+50,y shr 2)
  281.             else
  282.               for y:=0 to 127 do
  283.                 setpix(30+x,yst+y+50,y shr 3);
  284.     _p256:for x:=0 to 127 do
  285.             if lins<250 then
  286.               for y:=0 to 63 do
  287.                 setpix(30+x,yst+50+y,((y shl 2) and 240) +(x shr 3))
  288.             else
  289.               for y:=0 to 127 do
  290.                 setpix(30+x,yst+50+y,((y shl 1) and 240)+(x shr 3));
  291.  
  292.     _p32k,_p64k,_p16m:
  293.           if pixels<600 then
  294.           begin
  295.             for x:=0 to 63 do
  296.             begin
  297.               for y:=0 to 63 do
  298.               begin
  299.                 setpix(30+x,100+y,rgb(x*4,y*4,0));
  300.                 setpix(110+x,100+y,rgb(x*4,0,y*4));
  301.                 setpix(190+x,100+y,rgb(0,x*4,y*4));
  302.               end;
  303.             end;
  304.             for x:=0 to 255 do
  305.               for y:=170 to 179 do
  306.               begin
  307.                 setpix(x,y,rgb(x,0,0));
  308.                 setpix(x,y+10,rgb(0,x,0));
  309.                 setpix(x,y+20,rgb(0,0,x));
  310.               end;
  311.           end
  312.           else begin
  313.             for x:=0 to 127 do
  314.               for y:=0 to 127 do
  315.               begin
  316.                 setpix(30+x,120+y,rgb(x*2,y*2,0));
  317.                 setpix(200+x,120+y,rgb(x*2,0,y*2));
  318.                 setpix(370+x,120+y,rgb(0,x*2,y*2));
  319.               end;
  320.             for x:=0 to 511 do
  321.               for y:=260 to 269 do
  322.               begin
  323.                 setpix(x,y,rgb(x shr 1,0,0));
  324.                 setpix(x,y+10,rgb(0,x shr 1,0));
  325.                 setpix(x,y+20,rgb(0,0,x shr 1));
  326.               end;
  327.