home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD2.mdf / doc / graphdoc / whatvga.pas < prev    next >
Pascal/Delphi Source File  |  1994-01-18  |  46KB  |  1,811 lines
  1.  
  2. uses dos,crt,supervga;
  3.  
  4. const
  5.   copyright='WHATVGA v. 1.50   18/jan/94    Copyright 1991-94  Finn Thoegersen';
  6.  
  7.   SWversion = 1500;    {1495 = 1.49e, 1500 = 1.50}
  8.  
  9.   menuchars:array[1..55] of char=
  10.       'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!@#$%^&()[]{}-_=+/?';
  11.  
  12. var
  13.   af_fil:file;
  14.   af_buf:array[0..2048] of byte;
  15.   af_pos:word;
  16.   af_rec:_AT2;
  17.   af_cmt:string;
  18.   af_tst:_AT3;
  19.   af_fail:boolean;
  20.   af_filename:string[12];
  21.  
  22. procedure AddAFbuf(var b;bytes:word);
  23. begin
  24.   move(b,af_buf[af_pos],bytes);
  25.   inc(af_pos,bytes);
  26. end;
  27.  
  28. procedure WrAFbuf(typ:byte);
  29. begin
  30.   af_buf[0]:=typ;
  31.   move(af_pos,af_buf[1],2);
  32.   blockwrite(af_fil,af_buf,af_pos);
  33.   close(af_fil);
  34.   reset(af_fil,1);        {Flushes file output}
  35.   seek(af_fil,filesize(af_fil));
  36.   af_pos:=3;
  37. end;
  38.  
  39. function getComment(tx:string):string;
  40. var s,s1:string;
  41. begin
  42.   writeln('Please enter '+tx+' (max 3 lines):');
  43.   s:='';s1:='';
  44.   readln(s1);
  45.   s1:=strip(s1);
  46.   if s1<>'' then
  47.   begin
  48.     s:=s1;
  49.     readln(s1);s1:=strip(s1);
  50.     if s1<>'' then
  51.     begin
  52.       s:=s+' '+s1;
  53.       readln(s1);s1:=strip(s1);
  54.       if s1<>'' then
  55.       begin
  56.         s:=s+' '+s1;
  57.         writeln;
  58.       end;
  59.     end;
  60.   end;
  61.   getComment:=s;
  62. end;
  63.  
  64. function getYN:boolean;
  65. const YN:array[0..1] of string[3]=('No','Yes');
  66. var ret:integer;
  67. begin
  68.   ret:=-1;
  69.   repeat
  70.     case getkey of
  71.       ord('y'),ord('Y'):ret:=1;
  72.       ord('n'),ord('N'):ret:=0;
  73.                  ch_esc:ret:=0;
  74.     end;
  75.   until ret>-1;
  76.   getYn:=boolean(ret);
  77.   writeln(YN[ret]);
  78.   if ret=0 then af_fail:=true;
  79. end;
  80.  
  81.  
  82. procedure InitAFFile(cursel:word);
  83. var x:word;
  84.   hdr:_AT0;
  85.   mm:mmods;
  86. begin
  87.   x:=0;
  88.   repeat
  89.     inc(x);     {Find first free file number}
  90.     af_filename:='WHVGA'+istr(x)+'.TST';
  91.     assign(af_fil,af_filename);
  92.     {$i-}
  93.     reset(af_fil,1);
  94.     {$i+}
  95.     if ioresult=0 then close(af_fil) else x:=0;
  96.   until x=0;
  97.   rewrite(af_fil,1);
  98.   af_pos:=3;
  99.   af_fail:=false;
  100.  
  101.   hdr.SWvers := SWversion;
  102.   hdr.vid_sys:= Vids;
  103.   hdr.cur_vid:= cursel;
  104.   getFtime(af_fil,hdr.curtime);
  105.   AddAFbuf(hdr,sizeof(hdr));
  106.  
  107.   af_cmt:=getComment('your Email address');
  108.   AddAFbuf(af_cmt,length(af_cmt)+1);
  109.  
  110.   af_cmt:=getComment('your name & address');
  111.   AddAFbuf(af_cmt,length(af_cmt)+1);
  112.   af_cmt:=getComment('your video&monitor description');
  113.   AddAFbuf(af_cmt,length(af_cmt)+1);
  114.   af_cmt:=getComment('your system description');
  115.   AddAFbuf(af_cmt,length(af_cmt)+1);
  116.  
  117.   af_cmt:='';
  118.   for mm:=_text to _p32 do   {Build the Mode Name table}
  119.     af_cmt:=af_cmt+copy(mmodenames[mm]+'    ',1,4);
  120.   AddAFbuf(af_cmt,length(af_cmt)+1);
  121.  
  122.   WrAFbuf(0);
  123. end;
  124.  
  125.  
  126. function getmenkey:integer;
  127. var x,c:word;
  128. begin
  129.   c:=getkey;
  130.   if (c>=ord('a')) and (c<=ord('z')) then c:=c-32;
  131.   getmenkey:=0;
  132.   for x:=1 to 55 do
  133.     if chr(c)=menuchars[x] then getmenkey:=x;
  134.   if c=Ch_Esc then getmenkey:=-1;
  135. end;
  136.  
  137.  
  138. procedure clearmemory;
  139. var x,y,maxbank:word;
  140. begin
  141.   case memmode of
  142.     _text,_text2,_text4:
  143.           begin
  144.             {mov es,[vseg]  cld  xor di,di  mov ax,$720  mov cx,$4000  rep stosw}
  145.             inline($8e/6/>vseg/$fc/$31/$ff/$B8/>$720/$B9/>$4000/$f3/$ab);
  146.           end;
  147.      _cga1,_cga2:
  148.           fillchar(mem[$B800:0],$8000,0);
  149. _pl2,_pl4:begin
  150.             wrinx(GRC,0,0);
  151.             wrinx(GRC,1,15);    (* planar modes *)
  152.             wrinx(GRC,8,255);
  153.             modinx(GRC,5,3,0);
  154.             maxbank:=pred(mm div 256);
  155.           end;
  156.   else maxbank:=pred(mm div 64);
  157.   end;
  158.   if memmode>_cga2 then
  159.     for x:=0 to maxbank do
  160.     begin
  161.       setbank(x);
  162.       {mov es,[vseg]  cld  xor di,di  xor ax,ax  mov cx,$8000  rep stosw}
  163.       inline($8e/6/>vseg/$fc/$31/$ff/$31/$C0/$B9/>$8000/$f3/$ab);
  164.     end;
  165. end;
  166.  
  167.  
  168. procedure setpix(x,y:word;col:longint);
  169. const
  170.   msk:array[0..7] of byte=(128,64,32,16,8,4,2,1);
  171.   plane :array[0..1] of byte=(5,10);
  172.   plane4:array[0..3] of byte=(1,2,4,8);
  173.   mscga4:array[0..3] of byte=($3f,$cf,$f3,$fc);
  174.   shcga4:array[0..3] of byte=(6,4,2,0);
  175. var l:longint;
  176.     m,z:word;
  177. begin
  178.   case memmode of
  179.    _cga1:begin
  180.            z:=(y shr 1)*bytes+(x shr 3);
  181.            if odd(y) then inc(z,8192);
  182.            mem[$b800:z]:=(mem[$b800:z] and (255 xor msk[x and 7]))
  183.                          or ((col and 1) shl (7-(x and 7)));
  184.          end;
  185.    _cga2:begin
  186.            z:=(y shr 1)*bytes+(x shr 2);
  187.            if odd(y) then inc(z,8192);
  188.            mem[$b800:z]:=(mem[$b800:z] and mscga4[x and 3])
  189.                          or (col and 3) shl shcga4[x and 3];
  190.          end;
  191.     _pl1:begin
  192.            l:=y*bytes+(x shr 3);
  193.            wrinx(GRC,3,0);
  194.            wrinx(GRC,5,2);
  195.            wrinx(SEQ,2,1);
  196.            wrinx(GRC,8,msk[x and 7]);
  197.            setbank(l shr 16);
  198.            z:=mem[vseg:word(l)];
  199.            mem[vseg:word(l)]:=col;
  200.          end;
  201.    _pl1e:begin
  202.            l:=y*bytes+(x shr 3);
  203.            modinx(GRC,5,3,0);
  204.            wrinx(SEQ,2,15);
  205.            wrinx(GRC,0,col*3);
  206.            wrinx(GRC,1,3);
  207.            wrinx(GRC,8,msk[x and 7]);
  208.            z:=mem[vseg:word(l)];
  209.            mem[vseg:word(l)]:=0;
  210.          end;
  211.     _pl2:begin
  212.            l:=y*bytes+(x shr 4);
  213.            wrinx(GRC,3,0);
  214.            wrinx(GRC,5,2);
  215.            wrinx(SEQ,2,plane[(x shr 3) and 1]);
  216.            wrinx(GRC,8,msk[x and 7]);
  217.            setbank(l shr 16);
  218.            z:=mem[vseg:word(l)];
  219.            mem[vseg:word(l)]:=col;
  220.          end;
  221.     _pk2:begin
  222.            l:=y*bytes+(x shr 2);
  223.            setbank(l shr 16);
  224.            z:=mem[vseg:word(l)] and mscga4[x and 3];
  225.            mem[vseg:word(l)]:=z or (col shl shcga4[x and 3]);
  226.          end;
  227.     _pl4:begin
  228.            l:=y*bytes+(x shr 3);
  229.            wrinx(GRC,3,0);
  230.            wrinx(GRC,5,2);
  231.            wrinx(GRC,8,msk[x and 7]);
  232.            setbank(l shr 16);
  233.            z:=mem[vseg:word(l)];
  234.            mem[vseg:word(l)]:=col;
  235.          end;
  236.     _pk4:begin
  237.            l:=y*bytes+(x shr 1);
  238.            setbank(l shr 16);
  239.            z:=mem[vseg:word(l)];
  240.            if odd(x) then z:=z and $f+(col shl 4)
  241.                      else z:=z and $f0+col;
  242.            mem[vseg:word(l)]:=z;
  243.          end;
  244.      _p8:begin
  245.            l:=y*bytes+x;
  246.            setbank(l shr 16);
  247.            mem[vseg:word(l)]:=col;
  248.          end;
  249.    _p15,_p16:
  250.          begin
  251.            l:=y*bytes+(x shl 1);
  252.            setbank(l shr 16);
  253.            memw[vseg:word(l)]:=col;
  254.          end;
  255.     _p24:begin
  256.            l:=y*bytes+(x*3);
  257.            z:=word(l);
  258.            m:=l shr 16;
  259.            setbank(m);
  260.            if z<$fffe then move(col,mem[vseg:z],3)
  261.            else begin
  262.              mem[vseg:z]:=lo(col);
  263.              if z=$ffff then setbank(m+1);
  264.              mem[vseg:z+1]:=lo(col shr 8);
  265.              if z=$fffe then setbank(m+1);
  266.              mem[vseg:z+2]:=col shr 16;
  267.            end;
  268.          end;
  269.     _p32:begin
  270.            l:=y*bytes+(x shl 2);
  271.            setbank(l shr 16);
  272.            meml[vseg:word(l)]:=col;
  273.          end;
  274.     else ;
  275.   end;
  276. end;
  277.  
  278. function whitecol:longint;
  279. var col:longint;
  280. begin
  281.   case memmode of
  282.     _cga1,_pl1e,
  283.      _pl1:col:=1;
  284.     _cga2,_pk2
  285.     ,_pl2:col:=3;
  286.     _pk4,_pl4,
  287.       _p8:col:=15;
  288.      _p15:col:=$7fff;
  289.      _p16:col:=$ffff;
  290. _p24,_p32:col:=$ffffff;
  291.   else
  292.   end;
  293.   whitecol:=col;
  294. end;
  295.  
  296.  
  297. procedure wrtext(x,y:word;txt:string);      {write TXT to pos (X,Y)}
  298. type
  299.   pchar=array[char] of array[0..15] of byte;
  300. var
  301.   p:^pchar;
  302.   c:char;
  303.   i,j,z,b:integer;
  304.   ad,bk:word;
  305.   l,v,col:longint;
  306. begin
  307.   rp.bh:=6;
  308.   vio($1130);
  309.   case memmode of
  310.     _cga1,_pl1e,
  311.      _pl1:col:=1;
  312.     _cga2,_pk2
  313.     ,_pl2:col:=3;
  314.     _pk4,_pl4,
  315.       _p8:col:=15;
  316.      _p15:col:=$7fff;
  317.      _p16:col:=$ffff;
  318. _p24,_p32:col:=$ffffff;
  319.   else
  320.   end;
  321.   p:=ptr(rp.es,rp.bp);
  322.   for z:=1 to length(txt) do
  323.   begin
  324.     c:=txt[z];
  325.     for j:=0 to 15 do
  326.     begin
  327.       b:=p^[c][j];
  328.       for i:=0 to 7 do
  329.       begin
  330.         if (b and 128)<>0 then v:=col else v:=0;
  331.         setpix(x+i,y+j,v);
  332.         b:=b shl 1;
  333.       end;
  334.     end;
  335.     inc(x,8);
  336.   end;
  337. end;
  338.  
  339.  
  340.   function rgb(r,g,b:word):longint;
  341.   begin
  342.     r:=lo(r);g:=lo(g);b:=lo(b);
  343.     case colbits[memmode] of
  344.        1:rgb:=r and 1;
  345.        2:rgb:=r and 3;
  346.        4:rgb:=r and 15;
  347.        8:rgb:=r;
  348.       15:rgb:=((r shr 3) shl 5+(g shr 3)) shl 5+(b shr 3);
  349.       16:rgb:=((r shr 3) shl 6+(g shr 2)) shl 5+(b shr 3);
  350.       24:rgb:=(longint(r) shl 8+g) shl 8 +b;
  351.     end;
  352.   end;
  353.  
  354.  
  355.  
  356. procedure plotchar(x,y,ch:word);
  357. begin
  358.   mem[vseg:(y*pixels+x) shl 1]:=ch;
  359. end;
  360.  
  361. procedure plotchat(x,y,ch,at:word);
  362. begin
  363.   memw[vseg:(y*pixels+x) shl 1]:=at shl 8+ch;
  364. end;
  365.  
  366. procedure plotstr(x,y:word;s:string);
  367. var z:word;
  368. begin
  369.   for z:=1 to length(s) do
  370.     plotchar(x+z-1,y,ord(s[z]));
  371. end;
  372.  
  373.  
  374. procedure drawtestpattern(nam:string);
  375.                        {Draw Test pattern.}
  376. var s:string;
  377.   l:longint;
  378.   x,y,yst:word;
  379.   white:longint;
  380.  
  381.   procedure wline(stx,sty,ex,ey:integer;col:longint);
  382.   var x,y,d,mx,my:integer;
  383.      l:longint;
  384.   begin
  385.     if sty>ey then
  386.     begin
  387.       x:=stx;stx:=ex;ex:=x;
  388.       x:=sty;sty:=ey;ey:=x;
  389.     end;
  390.     y:=0;
  391.     mx:=abs(ex-stx);
  392.     my:=ey-sty;
  393.     d:=0;
  394.     repeat
  395.       if col=0 then l:=rgb(y,y,y) else l:=col;
  396.       y:=(y+1) and 255;
  397.       setpix(stx,sty,l);
  398.       if abs(d+mx)<abs(d-my) then
  399.       begin
  400.         inc(sty);
  401.         d:=d+mx;
  402.       end
  403.       else begin
  404.         d:=d-my;
  405.         if ex>stx then inc(stx)
  406.                   else dec(stx);
  407.       end;
  408.     until (stx=ex) and (sty=ey);
  409.  
  410.   end;
  411.  
  412. begin
  413.   if memmode<=_TEXT4 then
  414.   begin
  415.     {Text modes}
  416.  
  417.   {  ClearMemory; }
  418.     for x:=0 to pixels-1 do
  419.     begin
  420.       plotchar(x,0,(x mod 10)+ord('0'));
  421.       if (x mod 10)=0 then
  422.         plotchar(x,1,((x div 10) mod 10)+ord('0'));
  423.       plotchar(x,lins-1,ord('.'));
  424.     end;
  425.     for x:=0 to lins-1 do
  426.     begin
  427.       plotchar(0,x,(x mod 10)+ord('0'));
  428.       if (x mod 10)=0 then
  429.         plotstr(0,x,istr(x));
  430.       plotchar(pixels-1,x,ord('.'));
  431.     end;
  432.     plotstr(5,5,nam);
  433.     for x:=0 to 255 do
  434.       plotchat(x and 15+10,x shr 4+7,65,x);
  435.     plotstr((pixels-30) div 2,lins,'This line shouldn''t be seen!!');
  436.   end
  437.   else begin
  438.  
  439.     white:=whitecol;
  440.  
  441.     wline(50,30,pixels-50,30 ,0);
  442.     wline(50,lins-30,pixels-50,lins-30 ,0);
  443.  
  444.     wline(50,30,50,lins-30 ,0);
  445.     wline(pixels-50,30,pixels-50,lins-30 ,0);
  446.     wline(50,30,pixels-50,lins-30 ,0);
  447.  
  448.     wline(pixels-50,30,50,lins-30 ,0);
  449.  
  450.     if lins>200 then yst:=50 else yst:=18;
  451.     wrtext(10,yst,name+' with '+istr(mm)+' Kb.');
  452.     wrtext(10,yst+25,nam);
  453.  
  454.     for x:=1 to (pixels-10) div 100 do
  455.     begin
  456.       for y:=1 to 10 do
  457.         setpix(x*100,y,white);
  458.       wrtext(x*100+3,1,istr(x));
  459.     end;
  460.  
  461.     for x:=1 to (lins-10) div 100 do
  462.     begin
  463.       for y:=1 to 10 do
  464.         setpix(y,x*100,white);
  465.       wrtext(1,x*100+2,istr(x));
  466.     end;
  467.  
  468.     case memmode of
  469.        _pk2,
  470.        _pl2:for x:=0 to 63 do
  471.               for y:=0 to 63 do
  472.                 setpix(30+x,yst+y+50,y shr 3);
  473.       _pk4,
  474.        _pl4:for x:=0 to 127 do
  475.               if lins<250 then
  476.                 for y:=0 to 63 do
  477.                   setpix(30+x,yst+y+50,y shr 2)
  478.               else
  479.                 for y:=0 to 127 do
  480.                   setpix(30+x,yst+y+50,y shr 3);
  481.         _p8:for x:=0 to 127 do
  482.               if lins<250 then
  483.                 for y:=0 to 63 do
  484.                   setpix(30+x,yst+50+y,((y shl 2) and 240) +(x shr 3))
  485.               else
  486.                 for y:=0 to 127 do
  487.                   setpix(30+x,yst+50+y,((y shl 1) and 240)+(x shr 3));
  488.  
  489.       _p15,_p16,_p24,_p32:
  490.             if pixels<600 then
  491.             begin
  492.               for x:=0 to 63 do
  493.               begin
  494.                 for y:=0 to 63 do
  495.                 begin
  496.                   setpix(30+x,100+y,rgb(x*4,y*4,0));
  497.                   setpix(110+x,100+y,rgb(x*4,0,y*4));
  498.                   setpix(190+x,100+y,rgb(0,x*4,y*4));
  499.                 end;
  500.               end;
  501.               for x:=0 to 255 do
  502.                 for y:=170 to 179 do
  503.                 begin
  504.                   setpix(x,y   ,rgb(x,0,0));
  505.                   setpix(x,y+10,rgb(0,x,0));
  506.                   setpix(x,y+20,rgb(0,0,x));
  507.                 end;
  508.             end
  509.             else begin
  510.               for x:=0 to 127 do
  511.                 for y:=0 to 127 do
  512.                 begin
  513.                   setpix( 30+x,120+y,rgb(x*2,y*2,0));
  514.                   setpix(200+x,120+y,rgb(x*2,0,y*2));
  515.                   setpix(370+x,120+y,rgb(0,x*2,y*2));
  516.                 end;
  517.               for x:=0 to 511 do
  518.                 for y:=260 to 269 do
  519.                 begin
  520.                   setpix(x,y   ,rgb(x shr 1,0,0));
  521.                   setpix(x,y+10,rgb(0,x shr 1,0));
  522.                   setpix(x,y+20,rgb(0,0,x shr 1));
  523.                 end;
  524.             end;
  525.  
  526.     end;
  527.     wline(0,0,10, 0 ,whitecol);
  528.     wline(0,0, 0,10 ,whitecol);
  529.     wline(0,0,10,10 ,whitecol);
  530.  
  531.     wline(pixels-11, 0,pixels-1, 0 ,whitecol);
  532.     wline(pixels-1 , 0,pixels-1,10 ,whitecol);
  533.     wline(pixels-11,10,pixels-1, 0 ,whitecol);
  534.  
  535.     wline(0,lins-11, 0,lins-1  ,whitecol);
  536.     wline(0,lins-1 ,10,lins-1  ,whitecol);
  537.     wline(0,lins-1 ,10,lins-11 ,whitecol);
  538.  
  539.     wline(pixels-11,lins-1 ,pixels-1,lins-1 ,whitecol);
  540.     wline(pixels-1 ,lins-11,pixels-1,lins-1 ,whitecol);
  541.     wline(pixels-11,lins-11,pixels-1,lins-1 ,whitecol);
  542.   end;
  543. end;
  544.  
  545.            (* Writes the string s to 1. line of the mono. screen *)
  546. procedure wrmono(s:string);
  547. var x:word;
  548. begin
  549.   for x:=1 to length(s) do
  550.     mem[$b000:x+x]:=ord(s[x]);
  551. end;
  552.  
  553.            (* Ensures that xlow<=x<=xhigh *)
  554. procedure chkrange(var x:integer;xlow,xhigh:integer);
  555. begin
  556.   if x<xlow then x:=xlow
  557.   else if x>xhigh then x:=xhigh;
  558. end;
  559.  
  560. function testvmode:boolean;
  561. var
  562.   s:string;
  563.   r13,sclins,scpixs,scbytes:word;
  564.   x0,y0,x:integer;
  565.   ch:word;
  566.   stop,scrollable,nxt:boolean;
  567.  
  568. begin
  569.   testvmode:=true;
  570.   s:='Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'+istr(lins)+' '+mmodenames[memmode];
  571.   drawtestpattern(s);
  572.  
  573.   if auto_test then af_rec.flag:=1;    {Mode Supported}
  574.  
  575.   scrollable:=false;
  576.   ch:=getkey;
  577.   if (ch<>Ch_Esc) and not (chr(ch) in ['D','F','d','f']) then
  578.   begin
  579.     if memmode>=_pl4 then
  580.     begin
  581.       scrollable:=true;
  582.       { Scroll test  }
  583.       sclins:=lins;
  584.       scpixs:=pixels;
  585.       scbytes:=bytes;
  586.       r13:=rdinx(crtc,$13);
  587.       if (r13<128) and ((bytes*lins*planes*5 div 2)<mm*longint(1024))
  588.         and (r13>0) and ((bytes div r13) in [1,2,4,8,16])
  589.         and (memmode<>_cga1) and (memmode<>_cga2) then
  590.       begin            {Can we double the screen?}
  591.         wrinx(crtc,$13,r13*2);
  592.         bytes:=bytes*2;
  593.         pixels:=pixels*2;
  594.       end;
  595.       case memmode of
  596.         _text,_text2,_text4:
  597.                 lins:=32768 div bytes;
  598.         _cga1,_cga2:
  599.                 lins:=16384 div bytes;
  600.            _pl1:lins:=mm*longint(256) div bytes;
  601.       else lins:=mm*longint(1024) div (bytes*planes);
  602.       end;
  603.       case memmode of
  604.    _cga1,_pl1,
  605.          _pl4:pixels:=bytes*8;
  606.         _cga2:pixels:=bytes*4;
  607.          _pk4:pixels:=bytes*2;
  608.           _p8:pixels:=bytes;
  609.     _p15,_p16:pixels:=bytes shr 1;
  610.          _p24:pixels:=bytes div 3;
  611.          _p32:pixels:=bytes shr 2;
  612.       end;
  613.  
  614.       Clearmemory;
  615.  
  616.       drawtestpattern(s);
  617.       x0:=0;
  618.       y0:=0;
  619.       stop:=false;
  620.  
  621.       if auto_test then pushkey(ord('a'));
  622.       repeat
  623.         setvstart(x0,y0);
  624.         case getkey of
  625.             Ch_ArUp:y0:=y0-16;
  626.           Ch_ArLeft:x0:=x0-16;
  627.          Ch_ArRight:x0:=x0+16;
  628.           Ch_ArDown:y0:=y0+16;
  629.             Ch_PgUp:dec(y0);
  630.             Ch_PgDn:inc(y0);
  631.           ord('A'),ord('a'):begin
  632.                               x0:=0;y0:=0;x:=0;
  633.                               repeat
  634.                                 setvstart(x0,y0);
  635.                                 delay(100);
  636.                                 nxt:=false;
  637.                                 case x of
  638.                                   0:if x0+16<=pixels-scpixs then inc(x0,16)
  639.                                                            else nxt:=true;
  640.                                   1:if y0+16<=lins-sclins then inc(y0,16)
  641.                                                          else nxt:=true;
  642.                                   2:if x0>=16 then dec(x0,16) else nxt:=true;
  643.                                   3:if y0>=16 then dec(y0,16) else pushkey(ch_esc);
  644.                                 end;
  645.                                 if nxt then
  646.                                 begin
  647.                                   inc(x);
  648.                                   delay(500);
  649.                                 end;
  650.                                 if peekkey=Ch_Esc then stop:=true;
  651.                               until stop;
  652.                               delay(500);
  653.                             end;
  654.           ord('D'),ord('d'),ord('F'),ord('f'),Ch_Esc,Ch_Cr:stop:=true;
  655.         end;
  656.         chkrange(x0,0,pixels-scpixs);
  657.         chkrange(y0,0,lins-sclins);
  658.  
  659.       until stop;
  660.       setvstart(0,0);  {Reset start, some chipsets NEED this}
  661.       pixels:=scpixs;
  662.       lins:=sclins;
  663.       bytes:=scbytes;
  664.     end;
  665.     dac2comm;     {Reset DAC}
  666.     outp($3c6,0);
  667.     dac2pel;
  668.     textmode(3);
  669.  
  670.     writeln('Values for mode '+hex4(curmode)+':');
  671.     writeln;
  672.     write('Pixels per scan line:',pixels:5);
  673.     if pixels<>calcpixels then write(' Calculated:',calcpixels:5);
  674.     writeln;
  675.     write('Lines in image:      ',lins:5);
  676.     if lins<>calclines then write(' Calculated:',calclines:5);
  677.     writeln;
  678.     write('Bytes per scanline:  ',bytes:5);
  679.     if bytes<>calcbytes then write(' Calculated:',calcbytes:5);
  680.     writeln;
  681.     write('Memory mode:         ',mmodenames[memmode]:5);
  682.     if memmode<>calcmmode then write(' Calculated:',mmodenames[calcmmode]:5);
  683.     writeln;
  684.     if memmode<_herc then writeln('Character cell:      ',charwid,'x',charhigh);
  685.     if vclk>0 then
  686.     begin
  687.       writeln;
  688.       write('Clocks: Pixel: ',vclk:7:3,' MHz, Line: ',hclk:7:3
  689.            ,' KHz, Frame: ',fclk:7:3,' Hz');
  690.       if ilace then write(' (i)');
  691.       writeln;
  692.     end;
  693.     if auto_test then
  694.     begin
  695.       pushkey(ch);
  696.       writeln;
  697.       write('Did the mode display properly (y/n): ');
  698.       if getYN then inc(af_rec.flag,2);
  699.       if scrollable then
  700.       begin
  701.         writeln;
  702.         write('Did the mode scroll properly (y/n): ');
  703.         if getYN then inc(af_rec.flag,8)
  704.                  else inc(af_rec.flag,4);
  705.       end;
  706.       af_cmt:=GetComment('any comments to the test');
  707.  
  708.       af_rec.vseg    :=vseg;
  709.       af_rec.Cpixels :=calcpixels;
  710.       af_rec.Clins   :=calclines;
  711.       af_rec.Cbytes  :=calcbytes;
  712.       af_rec.CMmode  :=calcmmode;
  713.       af_rec.ChWidth :=charwid;
  714.       af_rec.ChHeight:=charhigh;
  715.       af_rec.Cvseg   :=calcvseg;
  716.       af_rec.ExtPixf :=Extpixfact;
  717.       af_rec.Extlinf :=Extlinfact;
  718.       af_rec.vclk    :=vclk;
  719.       af_rec.hclk    :=hclk;
  720.       af_rec.fclk    :=fclk;
  721.       af_rec.ilace   :=ilace;
  722.  
  723.  
  724.  
  725.  
  726.       pushkey(ch_cr);
  727.     end;
  728.  
  729.  
  730.  
  731.     ch:=getkey;
  732.   end;
  733.   if (ch=ord('D')) or (ch=ord('d')) then ch:=dumpVGAregs;
  734.  
  735.   case ch of
  736.      Ch_Esc:testvmode:=false;
  737.     ord('f'),ord('F'):
  738.             dumpVGAregfile;
  739.   end;
  740. end;
  741.  
  742.  
  743.  
  744.  
  745.  
  746. procedure testcursor;           {Test HardWare Cursor}
  747. var m,x:word;
  748.   md:integer;
  749.  
  750. procedure setXY(x0,y0:word);
  751. begin
  752.   SetHWcurpos(x0,y0);
  753.   SetHWcurcol(((x0*longint(256) div pixels)*256
  754.           +(y0*longint(256) div lins))*256+$ff,0);
  755. end;
  756.  
  757. procedure tmode(m:word);
  758. const
  759.   CurMap:CursorType=
  760.      ($00f81f00,$00800130,$00800130,$00800100
  761.      ,$00f00f00,$008c3100,$00824100,$00818100
  762.      ,$80800101,$40800102,$20800104,$21800184
  763.      ,$11800188,$11800188,$11800188,$ffffffff
  764.      ,$ffffffff,$11800188,$11800188,$11800188
  765.      ,$21800184,$20800104,$40800102,$80800101
  766.      ,$00818100,$00824100,$008C3100,$00f00f00
  767.      ,$00800100,$00800100,$00800100,$00f81f00);
  768.  
  769. var x,x0,y0:integer;
  770.   fgcol,bkcol:longint;
  771.   stop:boolean;
  772. begin
  773.   memmode:=modetbl[m].memmode;
  774.   pixels :=modetbl[m].xres;
  775.   lins   :=modetbl[m].yres;
  776.   bytes  :=modetbl[m].bytes;
  777.   if setmode(modetbl[m].md) then
  778.   begin
  779.     drawtestpattern('Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'
  780.         +istr(lins)+' '+istr(modecols[memmode])+' colors');
  781.  
  782.     SetHWcurmap(CurMap);
  783.  
  784.     if auto_test then pushkey(ord('A'));
  785.     stop:=false;
  786.     x0:=100;y0:=150;  {Place it in the palette}
  787.     repeat
  788.       if x0<0 then x0:=0;
  789.       if y0<0 then y0:=0;
  790.       if x0+32>pixels then x0:=pixels-32;
  791.       if y0+32>lins then y0:=lins-32;
  792.  
  793.       SetXY(x0,y0);
  794.       case getkey of
  795.           Ch_ArUp:dec(y0,17);
  796.         Ch_ArLeft:dec(x0,17);
  797.        Ch_ArRight:inc(x0,17);
  798.         Ch_ArDown:inc(y0,17);
  799.         ord('a'),ord('A'):
  800.                   begin
  801.                     x0:=0;
  802.                     repeat
  803.                       SetXY(x0,150);
  804.                       delay(200);
  805.                       inc(x0,17);
  806.                     until x0>pixels-32;
  807.                     x0:=0;
  808.                     repeat
  809.                       SetXY(200,x0);
  810.                       delay(200);
  811.                       inc(x0,17);
  812.                     until x0>lins-32;
  813.                     stop:=true;
  814.                   end;
  815.      Ch_Cr,Ch_Esc:stop:=true;
  816.       end;
  817.     until stop;
  818.     HWcuronoff(false);
  819.     if auto_test then
  820.     begin
  821.       repeat until keypressed;
  822.       dac2comm;     {Reset DAC}
  823.       outp($3c6,0);
  824.       dac2pel;
  825.       textmode(3);
  826.       write('Did the Hardware Cursor work properly (y/n) ?');
  827.       af_tst.Flag :=ord(getYN);
  828.       af_cmt:=getComment('any comments to the test');
  829.  
  830.       af_tst.mode :=modetbl[m].md;
  831.       af_tst.Mmode:=modetbl[m].memmode;
  832.       AddAFbuf(af_tst,sizeof(af_tst));
  833.       AddAFbuf(af_cmt,length(af_cmt)+1);
  834.       WrAFbuf(3);
  835.     end;
  836.   end;
  837. end;
  838.  
  839. begin
  840.   textmode($103);   {43/50 line text mode}
  841.   writeln('Hardware Cursor test.');
  842.   writeln;
  843.  
  844.   if auto_test then
  845.   begin
  846.     delay(1000);
  847.     pushkey(ord('*'));
  848.   end
  849.   else begin
  850.     writeln('Modes:');
  851.     writeln;
  852.     for m:=1 to nomodes do
  853.       if modetbl[m].memmode>=_pl4 then
  854.       begin
  855.         writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  856.              +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  857.       end;
  858.     writeln;
  859.  
  860.     writeln('  *  All modes');
  861.     writeln;
  862.   end;
  863.  
  864.   x:=getmenkey;
  865.   for m:=1 to nomodes do
  866.     if ((x=0) or (x=m)) and (modetbl[m].memmode>=_pl4) then tmode(m);
  867.  
  868. end;
  869.  
  870.  
  871.  
  872. procedure testblit;           {Test BitBLT functions}
  873. var m,x:word;
  874.   md:integer;
  875.  
  876. procedure tmode(m:word);
  877. var x,y,x0,y0:integer;
  878.   stop:boolean;
  879. begin
  880.   memmode:=modetbl[m].memmode;
  881.   pixels :=modetbl[m].xres;
  882.   lins   :=modetbl[m].yres;
  883.   bytes  :=modetbl[m].bytes;
  884.   if setmode(modetbl[m].md) then
  885.   begin
  886.     drawtestpattern('Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'
  887.         +istr(lins)+' '+istr(modecols[memmode])+' colors');
  888.  
  889.  
  890.     case memmode of
  891.  _pl4,_pk4:for x:=0 to 15 do
  892.              fillrect(200,100+x*8,128,8,x);
  893.        _p8:for x:=0 to 255 do
  894.              fillrect(200+(x and 15)*8,100+(x div 16)*8,8,8,x);
  895.    _p15,_p16,_p24:
  896.            for x:=0 to 63 do
  897.            begin
  898.              fillrect(200+(x and 15)*8,100+(x div 16)*8,8,8,rgb(x*4,0,0));
  899.              fillrect(200+(x and 15)*8,132+(x div 16)*8,8,8,rgb(0,x*4,0));
  900.              fillrect(200+(x and 15)*8,164+(x div 16)*8,8,8,rgb(0,0,x*4));
  901.              fillrect(200+(x and 15)*8,196+(x div 16)*8,8,8,rgb(x*4,x*4,x*4));
  902.            end;
  903.     end;
  904.  
  905.     copyrect(30,50,500,45,128,200);
  906.     copyrect(200,100,332,105,128,128);
  907.  
  908.     for y:=1 to 8 do
  909.     begin
  910.       y0:=y*10+250;
  911.       fillrect(100,y0,y,8,y);
  912.       x0:=101+y;
  913.       for x:=1 to 15 do
  914.       begin
  915.         fillrect(x0,y0,x,8,y);
  916.         x0:=x0+x+1;
  917.       end;
  918.       fillrect(x0,y0,9-y,8,y);
  919.       y0:=y0+10;
  920.     end;
  921.  
  922.     if memmode<=_pl4 then   {specaal 16c test pattern}
  923.       for x:=0 to 19 do
  924.       begin
  925.         x0:=96+x*8;
  926.         for y:=0 to 8 do
  927.           setpix(x0,259+10*y,15);
  928.       end;
  929.  
  930.     if auto_test then
  931.     begin
  932.       repeat until keypressed;
  933.       dac2comm;     {Reset DAC}
  934.       outp($3c6,0);
  935.       dac2pel;
  936.       textmode(3);
  937.       write('Did the BitBLT test work properly (y/n) ?');
  938.       af_tst.Flag :=ord(getYN);
  939.       af_cmt:=getComment('any comments to the test');
  940.  
  941.       af_tst.mode :=modetbl[m].md;
  942.       af_tst.Mmode:=modetbl[m].memmode;
  943.       AddAFbuf(af_tst,sizeof(af_tst));
  944.       AddAFbuf(af_cmt,length(af_cmt)+1);
  945.       WrAFbuf(4);
  946.     end
  947.     else if getkey=0 then;
  948.   end;
  949. end;
  950.  
  951. begin
  952.   textmode($103);
  953.   writeln('Hardware BitBLT test.');
  954.   writeln;
  955.  
  956.   if auto_test then
  957.   begin
  958.     delay(1000);
  959.     pushkey(ord('*'));
  960.   end
  961.   else begin
  962.     writeln('Modes:');
  963.     writeln;
  964.     for m:=1 to nomodes do
  965.       if modetbl[m].memmode>=_pl4 then
  966.       begin
  967.         writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  968.                +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  969.       end;
  970.     writeln;
  971.  
  972.     writeln('  *  All modes');
  973.     writeln;
  974.   end;
  975.   x:=getmenkey;
  976.   for m:=1 to nomodes do
  977.     if ((x=0) or (x=m)) and (modetbl[m].memmode>=_pl4) then tmode(m);
  978. end;
  979.  
  980.  
  981. procedure testline;           {Test Line Draw functions}
  982. var x,m:word;
  983.   md:integer;
  984.  
  985. procedure tmode(m:word);
  986. var x,x0,y0,w:integer;
  987.   stop:boolean;
  988. begin
  989.   memmode:=modetbl[m].memmode;
  990.   pixels :=modetbl[m].xres;
  991.   lins   :=modetbl[m].yres;
  992.   bytes  :=modetbl[m].bytes;
  993.   if setmode(modetbl[m].md) then
  994.   begin
  995.     drawtestpattern('Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'
  996.         +istr(lins)+' '+istr(modecols[memmode])+' colors');
  997.  
  998.     x0:=pixels div 2;
  999.     y0:=lins div 2;
  1000.     for x:=-10 to 9 do
  1001.     begin
  1002.       case memmode of
  1003.    _pl4,_pk4:w:=(x+11) and 15;
  1004.          _p8:w:=x+11;
  1005.         _p15:w:=$4210+x*$3FF;
  1006.         _p16:w:=$8410+x*$7FF;
  1007.       end;
  1008.       line(x0,y0,x0+x*15,y0-150 ,w);
  1009.       line(x0,y0,x0+150 ,y0+x*15,w);
  1010.       line(x0,y0,x0-x*15,y0+150 ,w);
  1011.       line(x0,y0,x0-150 ,y0-x*15,w);
  1012.     end;
  1013.     if auto_test then
  1014.     begin
  1015.       repeat until keypressed;
  1016.       dac2comm;     {Reset DAC}
  1017.       outp($3c6,0);
  1018.       dac2pel;
  1019.       textmode(3);
  1020.       write('Did the Line Draw test work properly (y/n): ?');
  1021.       af_tst.Flag :=ord(getYN);
  1022.       af_cmt:=getComment('any comments to the test');
  1023.  
  1024.       af_tst.mode :=modetbl[m].md;
  1025.       af_tst.Mmode:=modetbl[m].memmode;
  1026.       AddAFbuf(af_tst,sizeof(af_tst));
  1027.       AddAFbuf(af_cmt,length(af_cmt)+1);
  1028.       WrAFbuf(5);
  1029.     end
  1030.     else if getkey=0 then;
  1031.   end;
  1032. end;
  1033.  
  1034. begin
  1035.   textmode($103);
  1036.   writeln('Hardware Line Draw test.');
  1037.   writeln;
  1038.  
  1039.   if auto_test then
  1040.   begin
  1041.     delay(1000);
  1042.     pushkey(ord('*'));
  1043.   end
  1044.   else begin
  1045.     writeln('Modes:');
  1046.     writeln;
  1047.     for m:=1 to nomodes do
  1048.       if modetbl[m].memmode>=_pl4 then
  1049.       begin
  1050.         writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  1051.                +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  1052.       end;
  1053.     writeln;
  1054.  
  1055.     writeln('  *  All modes');
  1056.     writeln;
  1057.   end;
  1058.  
  1059.   x:=getmenkey;
  1060.   for m:=1 to nomodes do
  1061.     if ((x=0) or (x=m)) and (modetbl[m].memmode>=_pl4) then tmode(m);
  1062. end;
  1063.  
  1064.  
  1065. procedure testRWbank;           {Test R/W bank functions}
  1066. var x,m:word;
  1067.   md:integer;
  1068.  
  1069. procedure tmode(m:word);
  1070. var x,wid:integer;
  1071.   src,dst:longint;
  1072. begin
  1073.   memmode:=modetbl[m].memmode;
  1074.   pixels :=modetbl[m].xres;
  1075.   lins   :=modetbl[m].yres;
  1076.   bytes  :=modetbl[m].bytes;
  1077.   if setmode(modetbl[m].md) then
  1078.   begin
  1079.     drawtestpattern('Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'
  1080.         +istr(lins)+' '+istr(modecols[memmode])+' colors');
  1081.  
  1082.     src:=50*bytes+10;
  1083.     dst:=300*bytes+10;
  1084.     if memmode=_pl4 then
  1085.     begin
  1086.       wid:=50;
  1087.       modinx(GRC,5,3,1);   {Use mode Write mode 1}
  1088.     end else wid:=300;
  1089.     for x:=1 to 200 do
  1090.     begin
  1091.       setbank(dst shr 16);
  1092.       setrbank(src shr 16);
  1093.       move(mem[$a000:src and $ffff],mem[$a000:dst and $ffff],wid);
  1094.       inc(src,bytes);
  1095.       inc(dst,bytes);
  1096.     end;
  1097.     if auto_test then
  1098.     begin
  1099.       repeat until keypressed;
  1100.       dac2comm;     {Reset DAC}
  1101.       outp($3c6,0);
  1102.       dac2pel;
  1103.       textmode(3);
  1104.       write('Did the Read/Write bank test work properly (y/n) ?');
  1105.       af_tst.Flag :=ord(getYN);
  1106.       af_cmt:=getComment('any comments to the test');
  1107.  
  1108.       af_tst.mode :=modetbl[m].md;
  1109.       af_tst.Mmode:=modetbl[m].memmode;
  1110.       AddAFbuf(af_tst,sizeof(af_tst));
  1111.       AddAFbuf(af_cmt,length(af_cmt)+1);
  1112.       WrAFbuf(6);
  1113.     end
  1114.     else if getkey=0 then;
  1115.   end;
  1116. end;
  1117.  
  1118. begin
  1119.   textmode($103);
  1120.   writeln('Seperate Read/Write bank test.');
  1121.  
  1122.   if auto_test then
  1123.   begin
  1124.     delay(1000);
  1125.     pushkey(ord('*'));
  1126.   end
  1127.   else begin
  1128.     writeln('Modes:');
  1129.     writeln;
  1130.     for m:=1 to nomodes do
  1131.       if modetbl[m].memmode>=_pl4 then
  1132.       begin
  1133.         writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  1134.                +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  1135.       end;
  1136.     writeln;
  1137.  
  1138.     writeln('  *  All modes');
  1139.     writeln;
  1140.   end;
  1141.   x:=getmenkey;
  1142.   for m:=1 to nomodes do
  1143.     if ((x=0) or (x=m)) and (modetbl[m].memmode>=_pl4) then tmode(m);
  1144. end;
  1145.  
  1146. procedure testbits;           {Test register bits}
  1147. var m,pt,ix,msk:word;
  1148.   md,x:integer;
  1149.   s:string;
  1150.  
  1151. function tmode(m:word):boolean;
  1152. const
  1153.   mask:array[0..7] of byte=(1,2,4,8,16,32,64,128);
  1154. var
  1155.   stop:boolean;
  1156.   x:word;
  1157. begin
  1158.   tmode:=true;
  1159.   memmode:=modetbl[m].memmode;
  1160.   pixels :=modetbl[m].xres;
  1161.   lins   :=modetbl[m].yres;
  1162.   bytes  :=modetbl[m].bytes;
  1163.   if setmode(modetbl[m].md) then
  1164.   begin
  1165.     case memmode of
  1166.       _text,_text2,_text4:
  1167.               lins:=32768 div bytes;
  1168.       _cga1,_cga2:
  1169.               lins:=16384 div bytes;
  1170.          _pl1:lins:=mm*longint(256) div bytes;
  1171.     else lins:=mm*longint(1024) div (bytes*planes);
  1172.     end;
  1173.  
  1174.     Clearmemory;
  1175.  
  1176.     drawtestpattern(s);
  1177.     stop:=false;
  1178.     repeat
  1179.       wrtext(10,180,'Reg '+hex4(pt)+'h index '+hex2(ix)+'h bit '+chr(msk+48));
  1180.       x:=rdinx(pt,ix);
  1181.       wrinx(pt,ix,x xor mask[msk]);
  1182.       delay(500);
  1183.       wrinx(pt,ix,x);
  1184.       delay(500);
  1185.  
  1186.       if keypressed then
  1187.         case getkey of
  1188.            ord('-'):if msk>0 then dec(msk)
  1189.                     else begin
  1190.                       msk:=7;
  1191.                       dec(ix);
  1192.                     end;
  1193.            ord('+'):begin
  1194.                       inc(msk);
  1195.                       if msk>7 then
  1196.                       begin
  1197.                         msk:=0;
  1198.                         inc(ix);
  1199.                       end;
  1200.                     end;
  1201.            ord('*'):begin
  1202.                       inc(ix);
  1203.                       msk:=0;
  1204.                     end;
  1205.              Ch_Esc:stop:=true;
  1206.         end;
  1207.     until stop;
  1208.     dac2comm;     {Reset DAC}
  1209.     outp($3c6,0);
  1210.     dac2pel;
  1211.     textmode(3);
  1212.   end;
  1213. end;
  1214.  
  1215. begin
  1216.   textmode($103);
  1217.   writeln('Test register bits.');
  1218.   writeln;
  1219.   write('Base register (hex): ');
  1220.   readln(s);
  1221.   pt:=dehex(s);
  1222.   write('Start Index (hex 0-FFh): ');
  1223.   readln(s);
  1224.   ix:=dehex(s);
  1225.   write('Start Bit (0-7): ');
  1226.   readln(s);
  1227.   msk:=ord(s[1]) and 7;
  1228.   writeln;
  1229.   writeln('Testing register bits, starting with '+hex4(pt)+'h index '+hex2(ix)+'h bit '+chr(msk+48)+'.');
  1230.   writeln;
  1231.   writeln('  +  Steps up to the next bit (and possibly next index)');
  1232.   writeln('  -  Steps back to the last bit');
  1233.   writeln('  *  Steps to the next index, bit 0');
  1234.   writeln(' Esc Terminates the test');
  1235.   writeln;
  1236.  
  1237.   writeln('Modes:');
  1238.   writeln;
  1239.   for m:=1 to nomodes do
  1240.   begin
  1241.     writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  1242.            +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  1243.   end;
  1244.   writeln;
  1245.  
  1246.   writeln('  *  All modes');
  1247.  
  1248.   writeln;
  1249.   x:=getmenkey;
  1250.   for m:=1 to nomodes do
  1251.     if (x=0) or (x=m) then
  1252.       if not tmode(m) then x:=-1;  {stop}
  1253.  
  1254. end;
  1255.  
  1256.  
  1257. procedure testdac8;           {Test 8bit DAC mode}
  1258. var m,pt,ix,msk:word;
  1259.   md,x:integer;
  1260.   s:string;
  1261.  
  1262. procedure setpal(inx,red,grn,blu:word);
  1263. begin
  1264.   outp($3C8,inx);
  1265.   outp($3C9,red);
  1266.   outp($3C9,grn);
  1267.   outp($3C9,blu);
  1268. end;
  1269.  
  1270. function tmode(m:word):boolean;
  1271. var
  1272.   stop,dac8,olddac:boolean;
  1273.   x,y:word;
  1274. begin
  1275.   tmode:=true;
  1276.   memmode:=modetbl[m].memmode;
  1277.   pixels :=modetbl[m].xres;
  1278.   lins   :=modetbl[m].yres;
  1279.   bytes  :=modetbl[m].bytes;
  1280.   if setmode(modetbl[m].md) then
  1281.   begin
  1282.     drawtestpattern('Test 6/8 bit DAC');
  1283.     for y:=0 to 127 do
  1284.       for x:=0 to 255 do
  1285.         setpix(x+30,y+100,(x shr 2)+(y and $60)*2);
  1286.  
  1287.     stop:=false;
  1288.     dac8:=false;
  1289.     olddac:=not dac8;
  1290.     repeat
  1291.       if dac8<>olddac then
  1292.       begin
  1293.         if dac8 then setdac8 else setdac6;
  1294.  
  1295.         for x:=0 to 63 do setpal(x,x*4,0,0);
  1296.         for x:=0 to 63 do setpal(x+$40,0,x*4,0);
  1297.         for x:=0 to 63 do setpal(x+$80,0,0,x*4);
  1298.         for x:=0 to 63 do setpal(x+$C0,x*4,x*4,x*4);
  1299.         olddac:=dac8;
  1300.       end;
  1301.       if keypressed then
  1302.         case getkey of
  1303.            ord('6'):dac8:=false;
  1304.            ord('8'):dac8:=true;
  1305.        Ch_Esc,Ch_Cr:stop:=true;
  1306.         end;
  1307.     until stop;
  1308.     setdac6;
  1309.     dac2comm;     {Reset DAC}
  1310.     outp($3c6,0);
  1311.     dac2pel;
  1312.     textmode(3);
  1313.   end;
  1314. end;
  1315.  
  1316. begin
  1317.   textmode($103);
  1318.   writeln('Test 8bit DAC mode (256 of 16m colors).');
  1319.   writeln;
  1320.   writeln('Press 8 to switch to 8bit DAC, 6 to switch to 6bit DAC');
  1321.   writeln;
  1322.  
  1323.   writeln('Modes:');
  1324.   writeln;
  1325.   for m:=1 to nomodes do
  1326.     if modetbl[m].memmode=_p8 then
  1327.       writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  1328.            +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  1329.   writeln;
  1330.  
  1331.   writeln('  *  All modes');
  1332.  
  1333.   writeln;
  1334.   x:=getmenkey;
  1335.   for m:=1 to nomodes do
  1336.     if (x=0) or (x=m) then
  1337.       if not tmode(m) then x:=-1;  {stop}
  1338.  
  1339. end;
  1340.  
  1341.  
  1342. procedure testvgamodes;           {Test extended modes}
  1343. var m:word;
  1344.   md,x:integer;
  1345.  
  1346. function tmode(m:word):boolean;
  1347. begin
  1348.   tmode:=true;
  1349.   memmode:=modetbl[m].memmode;
  1350.   pixels :=modetbl[m].xres;
  1351.   lins   :=modetbl[m].yres;
  1352.   bytes  :=modetbl[m].bytes;
  1353.  
  1354.   if auto_test then
  1355.   begin
  1356.     fillchar(af_rec,sizeof(af_rec),0);
  1357.     af_rec.mode  :=modetbl[m].md;
  1358.     af_rec.Mmode :=memmode;
  1359.     af_rec.pixels:=pixels;
  1360.     af_rec.lins  :=lins;
  1361.     af_rec.bytes :=bytes;
  1362.   end;
  1363.  
  1364.  
  1365.   if setmode(modetbl[m].md) then tmode:=testvmode;
  1366.  
  1367.   if auto_test then
  1368.   begin
  1369.     af_rec.crtc  :=crtc;
  1370.     AddAFBuf(af_rec,sizeof(af_rec));
  1371.     AddAFbuf(af_cmt,length(af_cmt)+1);
  1372.     inc(af_pos,FormatRgs(af_buf[af_pos]));
  1373.  
  1374.     WrAFbuf(2);
  1375.   end;
  1376. end;
  1377.  
  1378. begin
  1379.   textmode($103);
  1380.   writeln('Test extended VGA modes.');
  1381.   writeln('Modes:');
  1382.   writeln;
  1383.   for m:=1 to nomodes do
  1384.   begin
  1385.     writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  1386.            +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  1387.   end;
  1388.   writeln;
  1389.  
  1390.   writeln('  *  All modes');
  1391.   if auto_test then pushkey(ord('*'));
  1392.   writeln;
  1393.   x:=getmenkey;
  1394.   for m:=1 to nomodes do
  1395.     if (x=0) or (x=m) then
  1396.       if not tmode(m) then x:=-1;  {stop}
  1397.  
  1398. end;
  1399.  
  1400. procedure teststdvgamodes;          {Test standard VGA modes}
  1401. var m:word;
  1402.   md,x:integer;
  1403.  
  1404. function tmode(m:word):boolean;
  1405. begin
  1406.   memmode:=stdmodetbl[m].memmode;
  1407.   pixels :=stdmodetbl[m].xres;
  1408.   lins   :=stdmodetbl[m].yres;
  1409.   bytes  :=stdmodetbl[m].bytes;
  1410.  
  1411.   if auto_test then
  1412.   begin
  1413.     fillchar(af_rec,sizeof(af_rec),0);
  1414.     af_rec.mode  :=stdmodetbl[m].md;
  1415.     af_rec.Mmode :=memmode;
  1416.     af_rec.pixels:=pixels;
  1417.     af_rec.lins  :=lins;
  1418.     af_rec.bytes :=bytes;
  1419.   end;
  1420.  
  1421.  
  1422.   if setmode(stdmodetbl[m].md) then tmode:=testvmode;
  1423.  
  1424.   if auto_test then
  1425.   begin
  1426.     af_rec.crtc  :=crtc;
  1427.     AddAFBuf(af_rec,sizeof(af_rec));
  1428.     AddAFbuf(af_cmt,length(af_cmt)+1);
  1429.     inc(af_pos,FormatRgs(af_buf[af_pos]));
  1430.     WrAFbuf(2);
  1431.   end;
  1432. end;
  1433.  
  1434. begin
  1435.   textmode($103);
  1436.   writeln('Standard VGA mode test.');
  1437.   writeln;
  1438.   writeln('Modes:');
  1439.   writeln;
  1440.   for m:=1 to novgamodes do
  1441.   begin
  1442.     writeln('  '+menuchars[m]+' '+hex4(stdmodetbl[m].md)+'h '+istr(stdmodetbl[m].xres)
  1443.            +'x'+istr(stdmodetbl[m].yres)+' '+mdtxt[stdmodetbl[m].memmode]);
  1444.   end;
  1445.   writeln;
  1446.   writeln('  *  All modes');
  1447.  
  1448.   writeln;
  1449.   if auto_test then pushkey(ord('*'));
  1450.   x:=getmenkey;
  1451.   for m:=1 to novgamodes do
  1452.     if (x=0) or (x=m) then
  1453.       if not tmode(m) then x:=-1;
  1454.  
  1455. end;
  1456.  
  1457.  
  1458. procedure searchformodes;      {Run through all possible modes
  1459.                                 and try to id any new ones}
  1460. type
  1461.   regblk=record
  1462.            base:word;
  1463.            nbr:word;
  1464.            x:array[0..255] of byte;
  1465.          end;
  1466. var
  1467.   md,m,hig,wid,x,y,oldbytes,wordadr:word;
  1468.   c:char;
  1469.   ofil:text;
  1470.   attregs:array[0..31] of byte;
  1471.   seqregs,grcregs,crtcregs,xxregs:regblk;
  1472.   stdregs:array[$3c0..$3df] of byte;
  1473.   l:longint;
  1474.   s:string;
  1475.   stop:boolean;
  1476.  
  1477.  
  1478. procedure dumprg(base:word;var rg:regblk);
  1479. var six,ix:word;
  1480. begin
  1481.   rg.base:=base;
  1482.   six:=inp(base);
  1483.   outp(base,0);
  1484.   ix:=inp(base) xor 255;
  1485.   outp(base,255);
  1486.   ix:=ix and inp(base);
  1487.  
  1488.   if ix>127 then rg.nbr:=255
  1489.   else if ix>63 then rg.nbr:=127
  1490.   else if ix>31 then rg.nbr:=63
  1491.   else if ix>15 then rg.nbr:=31
  1492.   else if ix>7 then rg.nbr:=15
  1493.   else rg.nbr:=7;
  1494.   for ix:=0 to rg.nbr do
  1495.     rg.x[ix]:=rdinx(base,ix);
  1496.   outp(base,six);
  1497. end;
  1498.  
  1499.  
  1500.  
  1501.  
  1502. begin
  1503.   md:=$14;
  1504.   stop:=false;
  1505.   while (md<$80) and not stop do
  1506.   begin
  1507.     textmode(3);
  1508.     gotoxy(10,10);
  1509.     write('Testing mode: '+hex2(md));
  1510.     delay(500);
  1511.     if setmode(md) then
  1512.     begin
  1513.       pixels :=calcpixels;
  1514.       lins   :=calclines;
  1515.       bytes  :=calcbytes;
  1516.       vseg   :=calcvseg;
  1517.       memmode:=calcmmode;
  1518.       repeat
  1519.         oldbytes:=bytes;
  1520.  
  1521.         if setmode(md) then
  1522.         begin
  1523.           drawtestpattern('Mode: '+hex2(md)+' ('+istr(pixels)+'x'+istr(lins)+' '
  1524.                    +mmodenames[memmode]+') '+istr(bytes)+' bytes.');
  1525.         end;
  1526.  
  1527.         case getkey of
  1528.           Ch_PgUp:bytes:=bytes shl 1;
  1529.           Ch_PgDn:bytes:=bytes shr 1;
  1530.           Ch_ArUp:inc(bytes);
  1531.         Ch_ArDown:dec(bytes);
  1532.       ord('d'),ord('D'):
  1533.                   begin
  1534.                     bytes:=oldbytes;
  1535.                     x:=dumpVGAregs;
  1536.                   end;
  1537.       ord('f'),ord('F'):
  1538.                   begin
  1539.                     bytes:=oldbytes;
  1540.                     dumpVGAregfile;
  1541.                   end;
  1542.            Ch_Esc:stop:=true;
  1543.         end;
  1544.       until bytes=oldbytes;
  1545.     end;
  1546.     inc(md);
  1547.   end;
  1548.   textmode(3);
  1549. end;
  1550.  
  1551.  
  1552.  
  1553. var
  1554.   stop:boolean;
  1555.  
  1556. function ljust(s:string;lnn:word):string;
  1557. begin
  1558.   ljust:=copy(s+'          ',1,lnn);
  1559. end;
  1560.  
  1561. function rjust(s:string;lnn:word):string;
  1562. begin
  1563.   if length(s)<lnn then s:=copy('          ',1,lnn-length(s))+s;
  1564.   rjust:=s;
  1565. end;
  1566.  
  1567. function chkptr(w:word):word;
  1568. begin
  1569.   if memw[0:w+2]=biosseg then chkptr:=memw[0:w]
  1570.                          else chkptr:=0;
  1571. end;
  1572.  
  1573. function fntadr(BH:word):word;
  1574. begin
  1575.   rp.bh:=BH;
  1576.   vio($1130);
  1577.   if rp.es=biosseg then fntadr:=rp.bp
  1578.   else fntadr:=0;
  1579. end;
  1580.  
  1581. procedure wrAFff;
  1582. var
  1583.   rhdr:_ATff;
  1584.   x,y,z,v:word;
  1585. begin
  1586.   if af_fail and (biosseg<>0) then
  1587.   begin
  1588.     fillchar(rhdr,sizeof(rhdr),0);
  1589.     rhdr.base :=biosseg;
  1590.     rhdr.size :=mem[biosseg:2];
  1591.     rhdr.int10:=chkptr($40);
  1592.     rhdr.int6D:=chkptr($1B4);
  1593.     rhdr.m4A8 :=chkptr($4A8);
  1594.     rhdr.fnt14  :=fntadr(2);
  1595.     rhdr.fnt8l  :=fntadr(3);
  1596.     rhdr.fnt8h  :=fntadr(4);
  1597.     rhdr.fnt14x9:=fntadr(5);
  1598.     rhdr.fnt16  :=fntadr(6);
  1599.     rhdr.fnt16x9:=fntadr(7);
  1600.     AddAFbuf(rhdr,sizeof(rhdr));
  1601.     WrAFbuf(255);
  1602.     y:=0;z:=0;
  1603.     for x:=0 to (rhdr.size*512-1) do
  1604.     begin
  1605.       v:=mem[biosseg:x];
  1606.       af_buf[z]:=v-y;
  1607.       y:=v;
  1608.       inc(z);
  1609.       if z>=2000 then
  1610.       begin
  1611.         blockwrite(af_fil,af_buf,z);
  1612.         z:=0;
  1613.       end;
  1614.     end;
  1615.     blockwrite(af_fil,af_buf,z);
  1616.   end;
  1617. end;
  1618.  
  1619.  
  1620.  
  1621. var
  1622.   chp,force_chip:chips;
  1623.   s,fea:string;
  1624.   iteration,err,x,sel:word;
  1625.  
  1626.   devs:array[1..10] of string[80];
  1627.  
  1628. begin
  1629.   {$ifdef ver70}
  1630.     test8086:=1;    {force 286}
  1631.   {$endif}
  1632.   fillchar(dotest,sizeof(dotest),ord(true));   {allow test for all chips}
  1633.   force_mm:=0;
  1634.   force_chip:=__none;
  1635.   for x:=1 to paramcount do
  1636.   begin
  1637.     s:=upstr(paramstr(x));
  1638.     case s[1] of
  1639.      '-':begin
  1640.            s:=upstr(strip(copy(s,2,255)));
  1641.            for chp:=chips(1) to __none do
  1642.              if upstr(header[chp])=s then
  1643.                dotest[chp]:=false;
  1644.          end;
  1645.      '+':begin
  1646.            s:=upstr(strip(copy(s,2,255)));
  1647.            fillchar(dotest,sizeof(dotest),ord(false));
  1648.            for chp:=chips(1) to __none do
  1649.              if upstr(header[chp])=s then
  1650.              begin
  1651.                dotest[chp]:=true;
  1652.                force_chip:=chp;
  1653.              end;
  1654.          end;
  1655.      '=':val(copy(s,2,255),force_mm,err);
  1656.      '/':if (s='/DEBUG') or (s='/D') then debug:=true
  1657.          else if (s='/A') or (s='/AUTO') then auto_test:=true;
  1658.     end;
  1659.   end;
  1660.  
  1661.   findvideo;
  1662.  
  1663.   if force_chip<>__none then chip:=force_chip;
  1664.   if force_mm<>0 then mm:=force_mm;
  1665.  
  1666.  
  1667.   for x:=1 to vids do
  1668.   begin
  1669.     SelectVideo(x);
  1670.     fea:='';
  1671.     if (features and ft_cursor)>0 then fea:=' C';
  1672.     if (features and ft_blit  )>0 then fea:=fea+' B';
  1673.     if (features and ft_line  )>0 then fea:=fea+' L';
  1674.     if (features and ft_rwbank)>0 then fea:=fea+' R';
  1675.     devs[x]:='  '+istr(x)+'  '+ljust(chipnam[chip],9)
  1676.                +rjust(istr(mm),8)+ljust(fea,8)+'  '+vid[x].name;
  1677.   end;
  1678.  
  1679.  
  1680.   iteration:=0;
  1681.   repeat
  1682.     stop:=false;
  1683.     if vids<>1 then
  1684.     begin
  1685.       textmode(3);
  1686.       writeln(copyright);
  1687.       writeln;
  1688.       writeln('Multiple Video Interfaces or Adapters found!!');
  1689.       writeln('Please select the one to test:');
  1690.       writeln('       Chip:    Memory:  Feat:  Name:');
  1691.       for x:=1 to vids do writeln(devs[x]);
  1692.       writeln;
  1693.       writeln(' 0  Stop');
  1694.       writeln;
  1695.       sel:=getkey-ord('0');
  1696.       if sel=0 then stop:=true;
  1697.     end
  1698.     else sel:=1;
  1699.     if (sel>0) and (sel<=vids) then SelectVideo(sel);
  1700.  
  1701.     while not stop do
  1702.     begin
  1703.       dac2comm;     {Reset DAC}
  1704.       outp($3c6,0);
  1705.       dac2pel;
  1706.       textmode(3);
  1707.       writeln(copyright);
  1708.       writeln;
  1709.  
  1710.       write('Video system: ',chipnam[chip],' with '+istr(mm)+' Kbytes');
  1711.       if SubVers<>0 then write(' Version: '+hex4(SubVers));
  1712.       writeln;
  1713.       if name<>'' then writeln('Name: '+name);
  1714.       writeln('Dac: '+dacname);
  1715.  
  1716.       if features<>0 then
  1717.       begin
  1718.         write('Special features:');
  1719.         if (features and ft_cursor)<>0 then write(' Cursor');
  1720.         if (features and ft_blit)<>0 then write(' BitBlt');
  1721.         if (features and ft_line)<>0 then write(' Line');
  1722.         if (features and ft_rwbank)<>0 then write(' RW-bank');
  1723.         writeln;
  1724.       end;
  1725.  
  1726.       writeln;
  1727.       if (chip<>__vesa) and (chip<>__XBE) then
  1728.         writeln('     1  Test Standard VGA modes');
  1729.       writeln('     2  Test Extended modes');
  1730.       if (chip<>__vesa) and (chip<>__XBE) then
  1731.         writeln('     3  Search for video modes');
  1732.       if (features and ft_cursor)<>0 then
  1733.         writeln('     5  HardWare Cursor test');
  1734.       if (features and ft_blit)<>0 then
  1735.         writeln('     6  HardWare BitBLT test');
  1736.       if (features and ft_line)<>0 then
  1737.         writeln('     7  Line Draw test');
  1738.       if (features and ft_rwbank)<>0 then
  1739.         writeln('     8  R/W bank test');
  1740.       writeln;
  1741.       writeln('     0  Stop');
  1742.       writeln;
  1743.  
  1744.       if auto_test then
  1745.       begin
  1746.         inc(iteration);
  1747.         pushkey(Ch_Cr);  {No Operation, just step on}
  1748.         case iteration of
  1749.           1:begin
  1750.               InitAFfile(sel);
  1751.               for x:=1 to vids do
  1752.               begin
  1753.                 AddAFbuf(vid[x],sizeof(vid[1]));
  1754.                 WrAFbuf(1);
  1755.               end;
  1756.               if (chip<>__vesa) and (chip<>__XBE) then pushkey(ord('1'));
  1757.             end;
  1758.           2:pushkey(ord('2'));
  1759.           3:if (features and ft_cursor)<>0 then pushkey(ord('5'));
  1760.           4:if (features and ft_blit)<>0 then pushkey(ord('6'));
  1761.           5:if (features and ft_line)<>0 then pushkey(ord('7'));
  1762.           6:if (features and ft_rwbank)<>0 then pushkey(ord('8'));
  1763.           7:pushkey(ch_esc);
  1764.  
  1765.         end;
  1766.       end;
  1767.  
  1768.  
  1769.  
  1770.  
  1771.       case getkey of
  1772.              ord('1'):teststdvgamodes;
  1773.              ord('2'):testvgamodes;
  1774.              ord('3'):searchformodes;
  1775.              ord('5'):testcursor;
  1776.              ord('6'):testblit;
  1777.              ord('7'):testline;
  1778.              ord('8'):testrwbank;
  1779.     ord('a'),ord('A'):auto_test:=true;
  1780.     ord('b'),ord('B'):testbits;
  1781.     ord('d'),ord('D'):testdac8;
  1782.              ord('0'):stop:=true;
  1783.       Ch_Esc:begin
  1784.                stop:=true;
  1785.                sel:=0;
  1786.              end;
  1787.       end;
  1788.     end;
  1789.     if vids<=1 then sel:=0;
  1790.   until sel=0;
  1791.  
  1792.   dac2comm;     {Reset DAC}
  1793.   outp($3c6,0);
  1794.   dac2pel;
  1795.   vio(3);
  1796.  
  1797.   if auto_test then
  1798.   begin
  1799.     wrAFff;
  1800.     close(af_fil);
  1801.     writeln;
  1802.     writeln('The test results are in the file: ',af_filename);
  1803.     writeln;
  1804.     writeln('For e-mail, modem etc the test file should be compressed');
  1805.     writeln('(ZIP, ARJ...) savings of >40% are not uncommon.');
  1806.     writeln;
  1807.     writeln('For Email transport, remember that the test file is BINARY.');
  1808.  
  1809.   end;
  1810. end.
  1811.