home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / VGADOC4B.ZIP / WHATVGA.PAS < prev    next >
Pascal/Delphi Source File  |  1995-09-29  |  79KB  |  2,962 lines
  1.  
  2. uses dos,crt,supervga,idvga;
  3.  
  4. const
  5.   copyright='   29/Sep/95    Copyright 1991-95  Finn Thoegersen';
  6.  
  7.   SWversion = 2000;    {1495 = 1.49e, 1500 = 1.50, 2000 = 2.00}
  8.  
  9.   menuchars:array[1..55] of char=
  10.       'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!@#$%^&()[]{}-_=+/?';
  11.  
  12.   beta_ver=true;
  13.  
  14.  
  15.   max_clk=17;
  16.   clkname:array[0..max_clk] of string[20]=('','Internal','4 Ext Clks'
  17.       ,'8 Ext Clks','16 Ext Clks','32 Ext Clks','64 Ext Clks'
  18.       ,'32 Ext Clks (Sigma)','ICD20c61','ICD20c61A','S3 SDAC','TVP302x'
  19.       ,'ICS2595','SC11412','CH8391/8','STG1703','MUSIC','IBM RGB52x');
  20.  
  21.  
  22.  
  23. var
  24.   af_fil:file;
  25.   af_buf:array[0..2048] of byte;
  26.   af_pos:word;
  27.   af_rec:_AT2;
  28.   af_cmt:string;
  29.   af_tst:_AT3;
  30.   af_fail:boolean;
  31.   af_filename:string[12];
  32.  
  33.   {Displays the copyright & version info}
  34. function wrVersionNbr:string;
  35. var s:string;
  36. begin
  37.   str(SWVersion div 1000,s);
  38.   s:=s+'.'+chr((SWversion div 100) mod 10+48)+chr((SWversion div 10) mod 10+48);
  39.   if (SWversion mod 10)>0 then s:=s+chr(SWversion mod 10+$60);
  40.   if (beta_ver) then s:=s+' (BETA)';
  41.   wrVersionNbr:='WHATVGA v. '+s;
  42. end;
  43.  
  44. function freq(frq:longint):string;
  45. var w:word;
  46.   st:string[5];
  47. begin
  48.   w:=frq mod 1000;
  49.   str(frq div 1000:3,st);
  50.   freq:=st+'.'+chr((w div 100)+48)+chr(((w div 10) mod 10)+48)+chr((w mod 10)+48);
  51. end;
  52.  
  53.   {Appends a datablock to the AF buffer}
  54. procedure AddAFbuf(var b;bytes:word);
  55. begin
  56.   move(b,af_buf[af_pos],bytes);
  57.   inc(af_pos,bytes);
  58. end;
  59.  
  60.   {Writes an AF record to the AF file}
  61. procedure WrAFbuf(typ:byte);
  62. begin
  63.   af_buf[0]:=typ;
  64.   move(af_pos,af_buf[1],2);
  65.   blockwrite(af_fil,af_buf,af_pos);
  66.   close(af_fil);
  67.   reset(af_fil,1);        {Flushes file output}
  68.   seek(af_fil,filesize(af_fil));
  69.   af_pos:=3;
  70. end;
  71.  
  72. function Rtext(str:string;wid:integer):string;
  73. begin
  74.   while str[length(str)]=' ' do dec(str[0]);
  75.   Rtext:=copy('             ',1,wid-length(str))+str;
  76. end;
  77.  
  78. function getComment(tx:string):string;
  79. var s,s1:string;
  80. begin
  81.   writeln('Please enter '+tx+' (max 3 lines):');
  82.   s:='';s1:='';
  83.   readln(s1);
  84.   s1:=strip(s1);
  85.   if s1<>'' then
  86.   begin
  87.     s:=s1;
  88.     readln(s1);s1:=strip(s1);
  89.     if s1<>'' then
  90.     begin
  91.       s:=s+' '+s1;
  92.       readln(s1);s1:=strip(s1);
  93.       if s1<>'' then
  94.       begin
  95.         s:=s+' '+s1;
  96.         writeln;
  97.       end;
  98.     end;
  99.   end;
  100.   getComment:=s;
  101. end;
  102.  
  103. function getYN:boolean;
  104. const YN:array[0..1] of string[3]=('No','Yes');
  105. var ret:integer;
  106. begin
  107.   ret:=-1;
  108.   repeat
  109.     case getkey of
  110.       ord('y'),ord('Y'):ret:=1;
  111.       ord('n'),ord('N'):ret:=0;
  112.                  ch_esc:ret:=0;
  113.     end;
  114.   until ret>-1;
  115.   getYn:=boolean(ret);
  116.   writeln(YN[ret]);
  117.   if ret=0 then af_fail:=true;
  118. end;
  119.  
  120.  
  121. procedure InitAFFile(cursel:word);
  122. var x:word;
  123.   hdr:_AT0;
  124.   mm:byte;
  125. begin
  126.   x:=0;
  127.   repeat
  128.     inc(x);     {Find first free file number}
  129.     af_filename:='WHVGA'+istr(x)+'.TST';
  130.     assign(af_fil,af_filename);
  131.     {$i-}
  132.     reset(af_fil,1);
  133.     {$i+}
  134.     if ioresult=0 then close(af_fil) else x:=0;
  135.   until x=0;
  136.   rewrite(af_fil,1);
  137.   af_pos:=3;
  138.   af_fail:=false;
  139.  
  140.   hdr.SWvers := SWversion;
  141.   hdr.vid_sys:= Vids;
  142.   hdr.cur_vid:= cursel;
  143.   getFtime(af_fil,hdr.curtime);
  144.   AddAFbuf(hdr,sizeof(hdr));
  145.  
  146.   af_cmt:=getComment('your Email address');
  147.   AddAFbuf(af_cmt,length(af_cmt)+1);
  148.  
  149.   af_cmt:=getComment('your name & address');
  150.   AddAFbuf(af_cmt,length(af_cmt)+1);
  151.   af_cmt:=getComment('your video&monitor description');
  152.   AddAFbuf(af_cmt,length(af_cmt)+1);
  153.   af_cmt:=getComment('your system description');
  154.   AddAFbuf(af_cmt,length(af_cmt)+1);
  155.  
  156.   af_cmt:='';
  157.   for mm:=_text to _p32d do   {Build the Mode Name table}
  158.     af_cmt:=af_cmt+copy(mmodenames[mm]+'    ',1,4);
  159.   AddAFbuf(af_cmt,length(af_cmt)+1);
  160.  
  161.   for x:=1 to max_clk do
  162.     AddAFbuf(clkname[x],length(clkname[x])+1);
  163.  
  164.   af_cmt:='';
  165.   AddAFbuf(af_cmt,1);
  166.  
  167.   WrAFbuf(AF_header);
  168. end;
  169.  
  170.  
  171. function getmenkey:integer;
  172. var x,c:word;
  173. begin
  174.   c:=getkey;
  175.   if (c>=ord('a')) and (c<=ord('z')) then c:=c-32;
  176.   getmenkey:=0;
  177.   for x:=1 to 55 do
  178.     if chr(c)=menuchars[x] then getmenkey:=x;
  179.   if c=Ch_Esc then getmenkey:=-1;
  180. end;
  181.  
  182.  
  183. procedure clearmemory;
  184. var x,y,maxbank:word;
  185. begin
  186.   case memmode of
  187.     _text,_txt2,_txt4:
  188.           begin
  189.             {mov es,[vseg]  cld  xor di,di  mov ax,$720  mov cx,$4000  rep stosw}
  190.             inline($8e/6/>vseg/$fc/$31/$ff/$B8/>$720/$B9/>$4000/$f3/$ab);
  191.           end;
  192.      _cga1,_cga2:
  193.           fillchar(mem[SegB800:0],$8000,0);
  194. _pl2,_pl4:begin
  195.             wrinx(GRC,0,0);
  196.             wrinx(GRC,1,15);    (* planar modes *)
  197.             wrinx(GRC,8,255);
  198.             modinx(GRC,5,3,0);
  199.             maxbank:=pred(cv.mm div 256);
  200.           end;
  201.   else maxbank:=pred(cv.mm div 64);
  202.   end;
  203.   if memmode>_cga2 then
  204.     for x:=0 to maxbank do
  205.     begin
  206.       setbank(x);
  207.       {mov es,[vseg]  cld  xor di,di  xor ax,ax  mov cx,$8000  rep stosw}
  208.       inline($8e/6/>vseg/$fc/$31/$ff/$31/$C0/$B9/>$8000/$f3/$ab);
  209.     end;
  210. end;
  211.  
  212.  
  213. procedure setpix(x,y:word;col:longint);
  214. const
  215.   msk:array[0..7] of byte=(128,64,32,16,8,4,2,1);
  216.   plane :array[0..1] of byte=(5,10);
  217.   plane4:array[0..3] of byte=(1,2,4,8);
  218.   mscga4:array[0..3] of byte=($3f,$cf,$f3,$fc);
  219.   shcga4:array[0..3] of byte=(6,4,2,0);
  220. var l:longint;
  221.     m,z:word;
  222. begin
  223.   case memmode of
  224.    _cga1:begin
  225.            z:=(y shr 1)*bytes+(x shr 3);
  226.            if odd(y) then inc(z,8192);
  227.            mem[SegB800:z]:=(mem[SegB800:z] and (255 xor msk[x and 7]))
  228.                          or ((col and 1) shl (7-(x and 7)));
  229.          end;
  230.    _cga2:begin
  231.            z:=(y shr 1)*bytes+(x shr 2);
  232.            if odd(y) then inc(z,8192);
  233.            mem[SegB800:z]:=(mem[SegB800:z] and mscga4[x and 3])
  234.                          or (col and 3) shl shcga4[x and 3];
  235.          end;
  236.     _pl1:begin
  237.            l:=y*bytes+(x shr 3);
  238.            wrinx(GRC,3,0);
  239.            wrinx(GRC,5,2);
  240.            wrinx(SEQ,2,1);
  241.            wrinx(GRC,8,msk[x and 7]);
  242.            setbank(l shr 16);
  243.            z:=mem[vseg:word(l)];
  244.            mem[vseg:word(l)]:=col;
  245.          end;
  246.    _pl1e:begin
  247.            l:=y*bytes+(x shr 3);
  248.            modinx(GRC,5,3,0);
  249.            wrinx(SEQ,2,15);
  250.            wrinx(GRC,0,col*3);
  251.            wrinx(GRC,1,3);
  252.            wrinx(GRC,8,msk[x and 7]);
  253.            z:=mem[vseg:word(l)];
  254.            mem[vseg:word(l)]:=0;
  255.          end;
  256.     _pl2:begin
  257.            l:=y*bytes+(x shr 4);
  258.            wrinx(GRC,3,0);
  259.            wrinx(GRC,5,2);
  260.            wrinx(SEQ,2,plane[(x shr 3) and 1]);
  261.            wrinx(GRC,8,msk[x and 7]);
  262.            setbank(l shr 16);
  263.            z:=mem[vseg:word(l)];
  264.            mem[vseg:word(l)]:=col;
  265.          end;
  266.     _pk2:begin
  267.            l:=y*bytes+(x shr 2);
  268.            setbank(l shr 16);
  269.            z:=mem[vseg:word(l)] and mscga4[x and 3];
  270.            mem[vseg:word(l)]:=z or (col shl shcga4[x and 3]);
  271.          end;
  272.     _pl4:begin
  273.            l:=y*bytes+(x shr 3);
  274.            wrinx(GRC,3,0);
  275.            wrinx(GRC,5,2);
  276.            wrinx(GRC,8,msk[x and 7]);
  277.            setbank(l shr 16);
  278.            z:=mem[vseg:word(l)];
  279.            mem[vseg:word(l)]:=col;
  280.          end;
  281.     _pk4:begin
  282.            l:=y*bytes+(x shr 1);
  283.            setbank(l shr 16);
  284.            z:=mem[vseg:word(l)];
  285.            if odd(x) then z:=z and $f0+col
  286.                      else z:=z and $f+(col shl 4);
  287.            mem[vseg:word(l)]:=z;
  288.          end;
  289.    _pk4a:begin
  290.            l:=y*bytes+(x shr 1);
  291.            setbank(l shr 16);
  292.            z:=mem[vseg:word(l)];
  293.            if odd(x) then z:=z and $f+(col shl 4)
  294.                      else z:=z and $f0+col;
  295.            mem[vseg:word(l)]:=z;
  296.          end;
  297.    _pk4b:begin
  298.            case x and 6 of
  299.             2:inc(x,2);
  300.             4:dec(x,2);
  301.            end;
  302.            l:=y*bytes+(x shr 1);
  303.            setbank(l shr 16);
  304.            z:=mem[vseg:word(l)];
  305.            if odd(x) then z:=z and $f+(col shl 4)
  306.                      else z:=z and $f0+col;
  307.            mem[vseg:word(l)]:=z;
  308.          end;
  309.      _p8:begin
  310.            l:=y*bytes+x;
  311.            setbank(l shr 16);
  312.            mem[vseg:word(l)]:=col;
  313.          end;
  314.    _p15,_p16:
  315.          begin
  316.            l:=y*bytes+(x shl 1);
  317.            setbank(l shr 16);
  318.            memw[vseg:word(l)]:=col;
  319.          end;
  320.    _p24,_p24b:
  321.          begin
  322.            l:=y*bytes+(x*3);
  323.            z:=word(l);
  324.            m:=l shr 16;
  325.            setbank(m);
  326.            if z<$fffe then move(col,mem[vseg:z],3)
  327.            else begin
  328.              mem[vseg:z]:=lo(col);
  329.              if z=$ffff then setbank(m+1);
  330.              mem[vseg:z+1]:=lo(col shr 8);
  331.              if z=$fffe then setbank(m+1);
  332.              mem[vseg:z+2]:=col shr 16;
  333.            end;
  334.          end;
  335.  _p32,_p32b,_p32c,_p32d:
  336.          begin
  337.            l:=y*bytes+(x shl 2);
  338.            setbank(l shr 16);
  339.            meml[vseg:word(l)]:=col;
  340.          end;
  341.     else ;
  342.   end;
  343. end;
  344.  
  345. function whitecol:longint;
  346. var col:longint;
  347. begin
  348.   case memmode of
  349.     _cga1,_pl1e,
  350.        _pl1:col:=1;
  351.    _cga2,_pk2
  352.       ,_pl2:col:=3;
  353.     _pk4,_pl4,_PK4a,_pk4b:
  354.             col:=15;
  355.         _p8:col:=255;
  356.        _p15:col:=$7fff;
  357.        _p16:col:=$ffff;
  358.  _p24,_p24b,_p32,_p32b:
  359.             col:=$ffffff;
  360. _p32c,_p32d:col:=$ffffff00;
  361.   else
  362.   end;
  363.   whitecol:=col;
  364. end;
  365.  
  366.  
  367. procedure wrtext(x,y:word;txt:string);      {write TXT to pos (X,Y)}
  368. type
  369.   pchar=array[char] of array[0..15] of byte;
  370. var
  371.   p:^pchar;
  372.   c:char;
  373.   i,j,z,b,lns:integer;
  374.   ad,bk:word;
  375.   l,v,col:longint;
  376. begin
  377.   lns:=15;       {Assume full height chars}
  378.   ad:=(cv.mm*longint(1024)) div bytes;
  379.   if y+14>ad then lns:=ad-y;    {Check if we're past the bottom}
  380.   rp.bh:=6;
  381.   vio($1130);
  382.   col:=whitecol;
  383.   p:=ptr(rp.es,rp.bp);
  384.   for z:=1 to length(txt) do
  385.   begin
  386.     c:=txt[z];
  387.     for j:=0 to lns do
  388.     begin
  389.       b:=p^[c][j];
  390.       for i:=0 to 7 do
  391.       begin
  392.         if (b and 128)<>0 then v:=col else v:=0;
  393.         setpix(x+i,y+j,v);
  394.         b:=b shl 1;
  395.       end;
  396.     end;
  397.     inc(x,8);
  398.   end;
  399. end;
  400.  
  401.  
  402.  
  403.  
  404. procedure plotchar(x,y,ch:word);
  405. begin
  406.   mem[vseg:(y*pixels+x) shl 1]:=ch;
  407. end;
  408.  
  409. procedure plotchat(x,y,ch,at:word);
  410. begin
  411.   memw[vseg:(y*pixels+x) shl 1]:=at shl 8+ch;
  412. end;
  413.  
  414. procedure plotstr(x,y:word;s:string);
  415. var z:word;
  416. begin
  417.   for z:=1 to length(s) do
  418.     plotchar(x+z-1,y,ord(s[z]));
  419. end;
  420.  
  421.  
  422. procedure drawtestpattern(nam:string);
  423.                        {Draw Test pattern.}
  424. var s:string;
  425.   l:longint;
  426.   x,y,yst:word;
  427.   white:longint;
  428.  
  429.   procedure wline(stx,sty,ex,ey:integer;col:longint);
  430.   var x,y,d,mx,my:longint;
  431.      l:longint;
  432.   begin
  433.     if sty>ey then
  434.     begin
  435.       x:=stx;stx:=ex;ex:=x;
  436.       x:=sty;sty:=ey;ey:=x;
  437.     end;
  438.     y:=0;
  439.     mx:=abs(ex-stx);
  440.     my:=ey-sty;
  441.     d:=0;
  442.     repeat
  443.       if col=0 then l:=rgb(y,y,y) else l:=col;
  444.       y:=(y+1) and 255;
  445.       setpix(stx,sty,l);
  446.       if abs(d+mx)<abs(d-my) then
  447.       begin
  448.         inc(sty);
  449.         d:=d+mx;
  450.       end
  451.       else begin
  452.         d:=d-my;
  453.         if ex>stx then inc(stx)
  454.                   else dec(stx);
  455.       end;
  456.     until (stx=ex) and (sty=ey);
  457.  
  458.   end;
  459.  
  460. begin
  461.   if memmode<=_TXT4 then
  462.   begin
  463.     {Text modes}
  464.  
  465.   {  ClearMemory; }
  466.     for x:=0 to pixels-1 do
  467.     begin
  468.       plotchar(x,0,(x mod 10)+ord('0'));
  469.       if (x mod 10)=0 then
  470.         plotchar(x,1,((x div 10) mod 10)+ord('0'));
  471.       plotchar(x,lins-1,ord('.'));
  472.     end;
  473.     for x:=0 to lins-1 do
  474.     begin
  475.       plotchar(0,x,(x mod 10)+ord('0'));
  476.       if (x mod 10)=0 then
  477.         plotstr(0,x,istr(x));
  478.       plotchar(pixels-1,x,ord('.'));
  479.     end;
  480.     plotstr(5,5,nam);
  481.     for x:=0 to 255 do
  482.       plotchat(x and 15+10,x shr 4+7,65,x);
  483.     plotstr((pixels-30) div 2,lins,'This line shouldn''t be seen!!');
  484.   end
  485.   else begin
  486.  
  487.     white:=whitecol;
  488.  
  489.     wline(50,30,pixels-50,30 ,0);
  490.     wline(50,lins-30,pixels-50,lins-30 ,0);
  491.  
  492.     wline(50,30,50,lins-30 ,0);
  493.     wline(pixels-50,30,pixels-50,lins-30 ,0);
  494.     wline(50,30,pixels-50,lins-30 ,0);
  495.  
  496.     wline(pixels-50,30,50,lins-30 ,0);
  497.  
  498.     if lins>200 then yst:=50 else yst:=18;
  499.     wrtext(10,yst,cv.name+' with '+istr(cv.mm)+' Kb.');
  500.     wrtext(10,yst+25,nam);
  501.  
  502.     for x:=1 to (pixels-10) div 100 do
  503.     begin
  504.       for y:=1 to 10 do
  505.         setpix(x*100,y,white);
  506.       wrtext(x*100+3,1,istr(x));
  507.     end;
  508.  
  509.     for x:=1 to (lins-10) div 100 do
  510.     begin
  511.       for y:=1 to 10 do
  512.         setpix(y,x*100,white);
  513.       wrtext(1,x*100+2,istr(x));
  514.     end;
  515.  
  516.     case colbits[memmode] of
  517.           2:for x:=0 to 63 do
  518.               for y:=0 to 63 do
  519.                 setpix(30+x,yst+y+50,y shr 3);
  520.           4:for x:=0 to 127 do
  521.               if lins<250 then
  522.                 for y:=0 to 63 do
  523.                   setpix(30+x,yst+y+50,y shr 2)
  524.               else
  525.                 for y:=0 to 127 do
  526.                   setpix(30+x,yst+y+50,y shr 3);
  527.           8:for x:=0 to 127 do
  528.               if lins<250 then
  529.                 for y:=0 to 63 do
  530.                   setpix(30+x,yst+50+y,((y shl 2) and 240) +(x shr 3))
  531.               else
  532.                 for y:=0 to 127 do
  533.                   setpix(30+x,yst+50+y,((y shl 1) and 240)+(x shr 3));
  534.  
  535. 15,16,24,32:if pixels<600 then
  536.             begin
  537.               for x:=0 to 63 do
  538.               begin
  539.                 for y:=0 to 63 do
  540.                 begin
  541.                   setpix(30+x,100+y,rgb(x*4,y*4,0));
  542.                   setpix(110+x,100+y,rgb(x*4,0,y*4));
  543.                   setpix(190+x,100+y,rgb(0,x*4,y*4));
  544.                 end;
  545.               end;
  546.               for x:=0 to 255 do
  547.                 for y:=170 to 179 do
  548.                 begin
  549.                   setpix(x,y   ,rgb(x,0,0));
  550.                   setpix(x,y+10,rgb(0,x,0));
  551.                   setpix(x,y+20,rgb(0,0,x));
  552.                 end;
  553.             end
  554.             else begin
  555.               for x:=0 to 127 do
  556.                 for y:=0 to 127 do
  557.                 begin
  558.                   setpix( 30+x,120+y,rgb(x*2,y*2,0));
  559.                   setpix(200+x,120+y,rgb(x*2,0,y*2));
  560.                   setpix(370+x,120+y,rgb(0,x*2,y*2));
  561.                 end;
  562.               for x:=0 to 511 do
  563.                 for y:=260 to 269 do
  564.                 begin
  565.                   setpix(x,y   ,rgb(x shr 1,0,0));
  566.                   setpix(x,y+10,rgb(0,x shr 1,0));
  567.                   setpix(x,y+20,rgb(0,0,x shr 1));
  568.                 end;
  569.             end;
  570.  
  571.     end;
  572.     wline(0,0,10, 0 ,whitecol);
  573.     wline(0,0, 0,10 ,whitecol);
  574.     wline(0,0,10,10 ,whitecol);
  575.  
  576.     wline(pixels-11, 0,pixels-1, 0 ,whitecol);
  577.     wline(pixels-1 , 0,pixels-1,10 ,whitecol);
  578.     wline(pixels-11,10,pixels-1, 0 ,whitecol);
  579.  
  580.     wline(0,lins-11, 0,lins-1  ,whitecol);
  581.     wline(0,lins-1 ,10,lins-1  ,whitecol);
  582.     wline(0,lins-1 ,10,lins-11 ,whitecol);
  583.  
  584.     wline(pixels-11,lins-1 ,pixels-1,lins-1 ,whitecol);
  585.     wline(pixels-1 ,lins-11,pixels-1,lins-1 ,whitecol);
  586.     wline(pixels-11,lins-11,pixels-1,lins-1 ,whitecol);
  587.   end;
  588. end;
  589.  
  590.            (* Writes the string s to 1. line of the mono. screen *)
  591. procedure wrmono(s:string);
  592. var x:word;
  593. begin
  594.   for x:=1 to length(s) do
  595.     mem[SegB000:x+x]:=ord(s[x]);
  596. end;
  597.  
  598.            (* Ensures that xlow<=x<=xhigh *)
  599. procedure chkrange(var x:integer;xlow,xhigh:integer);
  600. begin
  601.   if x<xlow then x:=xlow
  602.   else if x>xhigh then x:=xhigh;
  603. end;
  604.  
  605.  
  606. var
  607.   CurModeIndex:integer;    {Index into the ModeTbl array for the current mode}
  608.  
  609. function testvmode:boolean;
  610. const iltxt:array[boolean] of string[4]=('',' (i)');
  611. var
  612.   s:string;
  613.   r13,sclins,scpixs,scbytes:word;
  614.   x0,y0,x,dlay:integer;
  615.   ch:word;
  616.   stop,scrollable,nxt:boolean;
  617.  
  618. begin
  619.   testvmode:=true;
  620.   s:='Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'+istr(lins)+' '+mmodenames[memmode];
  621.   drawtestpattern(s);
  622.  
  623.   if auto_test then af_rec.flag:=AFF_testok;    {Mode Supported}
  624.  
  625.   scrollable:=false;
  626.   ch:=getkey;
  627.   if (ch<>Ch_Esc) and not (chr(ch) in ['D','F','d','f']) then
  628.   begin
  629.     if memmode>=_pl4 then
  630.     begin
  631.       scrollable:=true;
  632.       { Scroll test  }
  633.       sclins:=lins;
  634.       scpixs:=pixels;
  635.       scbytes:=bytes;
  636.       r13:=rdinx(crtc,$13);
  637.       if ((cv.flags and FLG_StdVGA)>0) and ((bytes*lins*planes*5 div 2)<cv.mm*longint(1024))
  638.         and (r13<128) and (r13>0) and ((bytes div r13) in [1,2,4,8,16])
  639.         and (memmode<>_cga1) and (memmode<>_cga2) then
  640.       begin            {Can we double the screen?}
  641.         wrinx(crtc,$13,r13*2);
  642.         bytes:=bytes*2;
  643.         pixels:=pixels*2;
  644.       end;
  645.       case memmode of
  646.         _text,_txt2,_txt4:
  647.                 lins:=32768 div bytes;
  648.         _cga1,_cga2:
  649.                 lins:=16384 div bytes;
  650.            _pl1:lins:=cv.mm*longint(256) div bytes;
  651.       else lins:=cv.mm*longint(1024) div (bytes*planes);
  652.       end;
  653.       case memmode of
  654.    _cga1,_pl1,
  655.          _pl4:pixels:=bytes*8;
  656.         _cga2:pixels:=bytes*4;
  657.    _pk4,_PK4a,_pk4b:
  658.               pixels:=bytes*2;
  659.           _p8:pixels:=bytes;
  660.     _p15,_p16:pixels:=bytes shr 1;
  661.    _p24,_P24b:pixels:=bytes div 3;
  662.    _p32,_p32b,_p32c,_p32d:
  663.               pixels:=bytes shr 2;
  664.       end;
  665.  
  666.       Clearmemory;
  667.  
  668.       drawtestpattern(s);
  669.       x0:=0;
  670.       y0:=0;
  671.       stop:=false;
  672.  
  673.       dlay:=100;  {100ms}
  674.       if auto_test then pushkey(ord('a'));
  675.       repeat
  676.         setvstart(x0,y0);
  677.         case getkey of
  678.            ord('>'):inc(x0);
  679.            ord('<'):dec(x0);
  680.             Ch_ArUp:y0:=y0-16;
  681.           Ch_ArLeft:x0:=x0-16;
  682.          Ch_ArRight:x0:=x0+16;
  683.           Ch_ArDown:y0:=y0+16;
  684.             Ch_PgUp:dec(y0);
  685.             Ch_PgDn:inc(y0);
  686.           ord('A'),ord('a'):begin
  687.                               x0:=0;y0:=0;x:=0;
  688.                               repeat
  689.                                 delay(dlay);
  690.                                 nxt:=false;
  691.                                 case x of
  692.                                   0:if x0+16<=pixels-scpixs then inc(x0,16)
  693.                                     else begin
  694.                                       nxt:=true;
  695.                                       x0:=pixels-scpixs;
  696.                                     end;
  697.                                   1:if y0+16<=lins-sclins then inc(y0,16)
  698.                                     else begin
  699.                                       nxt:=true;
  700.                                       y0:=lins-sclins;
  701.                                       dlay:=50;  {Speed up for return trip}
  702.                                     end;
  703.                                   2:if x0>=16 then dec(x0,16)
  704.                                     else begin
  705.                                       nxt:=true;
  706.                                       x0:=0;
  707.                                       dlay:=25;  {Speed up for return trip}
  708.                                     end;
  709.                                   3:if y0>=16 then dec(y0,16)
  710.                                     else begin
  711.                                       nxt:=true;
  712.                                       stop:=true;
  713.                                       y0:=0;
  714.                                     end;
  715.                                 end;
  716.                                 setvstart(x0,y0);
  717.                                 if nxt then
  718.                                 begin
  719.                                   inc(x);
  720.                                   delay(500);
  721.                                 end;
  722.                                 if peekkey=Ch_Esc then stop:=true;
  723.                               until stop;
  724.                               delay(500);
  725.                             end;
  726.   ord('D'),ord('d'),ord('F'),ord('f'):begin
  727.                                         stop:=true;
  728.                                         repeatkey;
  729.                                       end;
  730.  
  731.                Ch_Esc,Ch_Cr:stop:=true;
  732.           ord('R'),ord('r'):begin
  733.                               stop:=true;
  734.                               repeatkey;
  735.                             end;
  736.  
  737.         end;
  738.         chkrange(x0,0,pixels-scpixs+10000);
  739.         chkrange(y0,0,lins-sclins);
  740.  
  741.       until stop;
  742.       setvstart(0,0);  {Reset start, some chipsets NEED this}
  743.       pixels:=scpixs;
  744.       lins:=sclins;
  745.       bytes:=scbytes;
  746.     end;
  747.     SetTextMode;
  748.  
  749.     writeln('Values for mode '+hex4(curmode)+':');
  750.     writeln;
  751.     writeln('                       List:  Calc:  BlnkS: RetrS: RetrE: BlnkE: Frame:');
  752.     writeln('Pixels per scan line:',pixels:6,calcpixels:7,calchblks:7,calchrtrs:7
  753.                                    ,calchrtre:7,calchblke:7,calchtot:8);
  754.     writeln('Lines in image:      ',lins:6  ,calclines:7,calcvblks:7,calcvrtrs:7
  755.                                    ,calcvrtre:7,calcvblke:7,calcvtot:8,iltxt[ilace]);
  756.     writeln('Bytes per scanline:  ',bytes:6 ,calcbytes:7);
  757.     writeln('Memory mode:         ',strip(mmodenames[memmode]):6,strip(mmodenames[calcmmode]):7);
  758.     if memmode<_herc then
  759.       writeln('Character cell:      ',charwid,'x',charhigh);
  760.     if vclk>0 then
  761.     begin
  762.       writeln;
  763.       write('Clocks: Pixel: '+freq(vclk)+' MHz, Line: '+freq(hclk)
  764.            ,' KHz, Frame: '+freq(fclk)+' Hz');
  765.       if ilace then write(' (i)');
  766.       writeln;
  767.       writeln('Required bandwidth: '+freq(BWlow)+' -'+freq(BWhigh)+' Mb/s');
  768.     end;
  769.     if auto_test then
  770.     begin
  771.       pushkey(ch);
  772.       writeln;
  773.       write('Did the mode display properly (y/n): ');
  774.       if getYN then inc(af_rec.flag,AFF_dispok);
  775.       if scrollable then
  776.       begin
  777.         writeln;
  778.         write('Did the mode scroll properly (y/n): ');
  779.         if getYN then inc(af_rec.flag,AFF_scrollok)
  780.                  else inc(af_rec.flag,AFF_scroll);
  781.       end;
  782.       if (af_rec.flag and AFF_dispok)=0 then
  783.       begin
  784.         write('Disable the mode (y/n): ');
  785.         if getYN then inc(af_rec.flag,AFF_canceled);
  786.       end;
  787.  
  788.       af_cmt:=GetComment('any comments to the test');
  789.  
  790.       af_rec.vseg    :=vseg;
  791.       af_rec.Cpixels :=calcpixels;
  792.       af_rec.Clins   :=calclines;
  793.       af_rec.Cbytes  :=calcbytes;
  794.       af_rec.CMmode  :=calcmmode;
  795.       af_rec.ChWidth :=charwid;
  796.       af_rec.ChHeight:=charhigh;
  797.       af_rec.Cvseg   :=calcvseg;
  798.       af_rec.ExtPixf :=Extpixfact;
  799.       af_rec.Extlinf :=Extlinfact;
  800.       af_rec.vclk    :=vclk;
  801.       af_rec.hclk    :=hclk;
  802.       af_rec.fclk    :=fclk;
  803.       af_rec.ilace   :=ilace;
  804.  
  805.       pushkey(ch_cr);
  806.     end;
  807.  
  808.     ch:=getkey;
  809.   end;
  810.   if (ch=ord('D')) or (ch=ord('d')) then ch:=dumpVGAregs;
  811.  
  812.   case ch of
  813.      Ch_Esc:testvmode:=false;
  814.     ord('f'),ord('F'):
  815.             dumpVGAregfile;
  816.     ord('r'),ord('R'):
  817.             modetbl[CurModeIndex].flags:=
  818.                      modetbl[CurModeIndex].flags and (not MFL_enabled);
  819.   end;
  820. end;
  821.  
  822.  
  823. function InitMode(md:integer):boolean;
  824. begin
  825.   CurModeIndex:=md;
  826.   memmode:=modetbl[md].memmode;
  827.   pixels :=modetbl[md].xres;
  828.   lins   :=modetbl[md].yres;
  829.   bytes  :=modetbl[md].bytes;
  830.   InitMode:=setmode(modetbl[md].md,true);
  831. end;
  832.  
  833.  
  834.  
  835. procedure testcursor;           {Test HardWare Cursor}
  836. var m,x:word;
  837.   md:integer;
  838.  
  839. procedure setXY(x0,y0:word);
  840. begin
  841.   SetHWcurpos(x0,y0);
  842.   SetHWcurcol(((x0*longint(256) div pixels)*256
  843.           +(y0*longint(256) div lins))*256+$ff,0);
  844. end;
  845.  
  846. procedure tmode(m:word);
  847. const
  848.   CurMap:CursorType=   {Snipers sight}
  849.      ($00f81f00,$00800130,$00800130,$00800100
  850.      ,$00f00f00,$008c3100,$00824100,$00818100
  851.      ,$80800101,$40800102,$20800104,$21800184
  852.      ,$11800188,$11800188,$11800188,$ffffffff
  853.      ,$ffffffff,$11800188,$11800188,$11800188
  854.      ,$21800184,$20800104,$40800102,$80800101
  855.      ,$00818100,$00824100,$008C3100,$00f00f00
  856.      ,$00800100,$00800100,$00800100,$00f81f00);
  857.  
  858. var x,x0,y0:integer;
  859.   fgcol,bkcol:longint;
  860.   stop:boolean;
  861. begin
  862.   if InitMode(m) then
  863.   begin
  864.     drawtestpattern('Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'
  865.         +istr(lins)+' '+istr(modecols[memmode])+' colors');
  866.  
  867.     SetHWcurmap(CurMap);
  868.  
  869.     if auto_test then pushkey(ord('A'));
  870.     stop:=false;
  871.     x0:=100;y0:=150;  {Place it in the palette}
  872.     repeat
  873.       if y0<0 then y0:=0;
  874.       if x0+32>pixels then x0:=pixels-32;
  875.       if y0+32>lins then y0:=lins-32;
  876.  
  877.       SetXY(x0,y0);
  878.       case getkey of
  879.           Ch_ArUp:dec(y0,17);
  880.         Ch_ArLeft:dec(x0,17);
  881.        Ch_ArRight:inc(x0,17);
  882.         Ch_ArDown:inc(y0,17);
  883.         ord('a'),ord('A'):
  884.                   begin
  885.                     x0:=0;
  886.                     repeat
  887.                       SetXY(x0,150);
  888.                       delay(200);
  889.                       inc(x0,17);
  890.                     until x0>pixels-32;
  891.                     x0:=0;
  892.                     repeat
  893.                       SetXY(200,x0);
  894.                       delay(200);
  895.                       inc(x0,17);
  896.                     until x0>lins-32;
  897.                     stop:=true;
  898.                   end;
  899.      Ch_Cr,Ch_Esc:stop:=true;
  900.       end;
  901.     until stop;
  902.     HWcuronoff(false);
  903.     if auto_test then
  904.     begin
  905.       repeat until keypressed;
  906.       SetTextMode;
  907.       write('Did the Hardware Cursor work properly (y/n) ?');
  908.       af_tst.Flag :=ord(getYN)*AFF_testok;
  909.       af_cmt:=getComment('any comments to the test');
  910.  
  911.       af_tst.mode :=modetbl[m].md;
  912.       af_tst.Mmode:=modetbl[m].memmode;
  913.       AddAFbuf(af_tst,sizeof(af_tst));
  914.       AddAFbuf(af_cmt,length(af_cmt)+1);
  915.       WrAFbuf(AF_Tcursor);
  916.     end;
  917.   end;
  918. end;
  919.  
  920. begin
  921.   textmode($103);   {43/50 line text mode}
  922.   writeln('Hardware Cursor test.');
  923.   writeln;
  924.  
  925.   if auto_test then
  926.   begin
  927.     delay(1000);
  928.     pushkey(ord('*'));
  929.   end
  930.   else begin
  931.     writeln('Modes:');
  932.     writeln;
  933.     for m:=1 to nomodes do
  934.       if (modetbl[m].flags AND MFL_enGr)=MFL_enGr then
  935.       writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  936.              +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  937.     writeln;
  938.  
  939.     writeln('  *  All modes');
  940.     writeln;
  941.   end;
  942.  
  943.   x:=getmenkey;
  944.   for m:=1 to nomodes do
  945.     if ((x=0) or (x=m)) and ((modetbl[m].flags AND MFL_enGr)=MFL_enGr) then
  946.       tmode(m);
  947.  
  948. end;
  949.  
  950.  
  951.  
  952. procedure testblit;           {Test BitBLT functions}
  953. var m,x:word;
  954.   md:integer;
  955.  
  956. procedure tmode(m:word);
  957. var x,y,x0,y0,siz:integer;
  958.   stop:boolean;
  959. begin
  960.   if InitMode(m) then
  961.   begin
  962.     drawtestpattern('Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'
  963.         +istr(lins)+' '+istr(modecols[memmode])+' colors');
  964.     if lins>=400 then siz:=8 else siz:=4;
  965.     x0:=pixels div 2-8*siz;
  966.     y0:=lins div 2-8*siz;
  967.  
  968.     case colbits[memmode] of
  969.           4:for x:=0 to 15 do
  970.               fillrect(x0,y0+x*siz,16*siz,siz,x);
  971.           8:for x:=0 to 255 do
  972.               fillrect(x0+(x and 15)*siz,y0+(x div 16)*siz,siz,siz,x);
  973. 15,16,24,32:for x:=0 to 63 do
  974.             begin
  975.               fillrect(x0+(x and 15)*siz,y0+(x div 16)*siz,siz,siz,rgb(x*4,0,0));
  976.               fillrect(x0+(x and 15)*siz,y0+siz*4+(x div 16)*siz,siz,siz,rgb(0,x*4,0));
  977.               fillrect(x0+(x and 15)*siz,y0+siz*8+(x div 16)*siz,siz,siz,rgb(0,0,x*4));
  978.               fillrect(x0+(x and 15)*siz,y0+siz*12+(x div 16)*siz,siz,siz,rgb(x*4,x*4,x*4));
  979.             end;
  980.     end;
  981.     copyrect(x0,y0,x0-siz*15,y0-5  ,siz*16-1,siz*16+1);
  982.     copyrect(x0,y0,x0+5  ,y0-siz*15,siz*16-1,siz*16+1);
  983.     copyrect(x0,y0,x0+siz*15,y0+5  ,siz*16-1,siz*16+1);
  984.     copyrect(x0,y0,x0-5  ,y0+siz*15,siz*16-1,siz*16+1);
  985.  
  986.  
  987.     if memmode<=_pl4 then   {special 16c test pattern}
  988.     begin
  989.       for y:=1 to 8 do
  990.       begin
  991.         y0:=y*10+250;
  992.         fillrect(100,y0,y,8,y);
  993.         x0:=101+y;
  994.         for x:=1 to 15 do
  995.         begin
  996.           fillrect(x0,y0,x,8,y);
  997.           x0:=x0+x+1;
  998.         end;
  999.         fillrect(x0,y0,9-y,8,y);
  1000.         y0:=y0+10;
  1001.       end;
  1002.     {  if readkey='' then;  }
  1003.  
  1004.       for x:=0 to 19 do
  1005.       begin
  1006.         x0:=96+x*8;
  1007.         for y:=0 to 8 do
  1008.           setpix(x0,259+10*y,15);
  1009.       end;
  1010.     end;
  1011.  
  1012.     if auto_test then
  1013.     begin
  1014.       repeat until keypressed;
  1015.       SetTextMode;
  1016.       write('Did the BitBLT test work properly (y/n) ?');
  1017.       af_tst.Flag :=ord(getYN)*AFF_testok;
  1018.       af_cmt:=getComment('any comments to the test');
  1019.  
  1020.       af_tst.mode :=modetbl[m].md;
  1021.       af_tst.Mmode:=modetbl[m].memmode;
  1022.       AddAFbuf(af_tst,sizeof(af_tst));
  1023.       AddAFbuf(af_cmt,length(af_cmt)+1);
  1024.       WrAFbuf(AF_Tbitblt);
  1025.     end
  1026.     else if getkey=0 then;
  1027.   end;
  1028.   settextmode;
  1029. end;
  1030.  
  1031. begin
  1032.   textmode($103);
  1033.   writeln('Hardware BitBLT test.');
  1034.   writeln;
  1035.  
  1036.   if auto_test then
  1037.   begin
  1038.     delay(1000);
  1039.     pushkey(ord('*'));
  1040.   end
  1041.   else begin
  1042.     writeln('Modes:');
  1043.     writeln;
  1044.     for m:=1 to nomodes do
  1045.       if (modetbl[m].flags AND MFL_enGr)=MFL_enGr then
  1046.       writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  1047.              +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  1048.     writeln;
  1049.  
  1050.     writeln('  *  All modes');
  1051.     writeln;
  1052.   end;
  1053.  
  1054.   x:=getmenkey;
  1055.   for m:=1 to nomodes do
  1056.     if ((x=0) or (x=m)) and ((modetbl[m].flags AND MFL_enGr)=MFL_enGr) then
  1057.       tmode(m);
  1058. end;
  1059.  
  1060.  
  1061.  
  1062. procedure testline;           {Test Line Draw functions}
  1063. var x,m:word;
  1064.   md:integer;
  1065.  
  1066. procedure tmode(m:word);
  1067. var x,x0,y0,linl:integer;
  1068.   stop:boolean;
  1069.   col:longint;
  1070.   zz:array[-10..10] of integer;
  1071. begin
  1072.   if InitMode(m) then
  1073.   begin
  1074.     drawtestpattern('Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'
  1075.         +istr(lins)+' '+istr(modecols[memmode])+' colors');
  1076.  
  1077.     x0:=pixels div 2;
  1078.     y0:=lins div 2;
  1079.     linl:=lins div 3;
  1080.     for x:=-10 to 9 do
  1081.     begin
  1082.       case colbits[memmode] of
  1083.            4:col:=(x+11) and 15;
  1084.            8:col:=x*12+128;
  1085.  15,16,24,32:col:=rgb(128-x*10,x+128,128+x*5);
  1086.       end;
  1087.       line(x0,y0,x0+x*(linl div 10),y0-linl,col);
  1088.       line(x0,y0,x0+linl ,y0+x*(linl div 10),col);
  1089.       line(x0,y0,x0-x*(linl div 10),y0+linl,col);
  1090.       line(x0,y0,x0-linl ,y0-x*(linl div 10),col);
  1091.     end;
  1092.     if auto_test then
  1093.     begin
  1094.       repeat until keypressed;
  1095.       SetTextMode;
  1096.       write('Did the Line Draw test work properly (y/n): ?');
  1097.       af_tst.Flag :=ord(getYN)*AFF_testok;
  1098.       af_cmt:=getComment('any comments to the test');
  1099.  
  1100.       af_tst.mode :=modetbl[m].md;
  1101.       af_tst.Mmode:=modetbl[m].memmode;
  1102.       AddAFbuf(af_tst,sizeof(af_tst));
  1103.       AddAFbuf(af_cmt,length(af_cmt)+1);
  1104.       WrAFbuf(AF_Tline);
  1105.     end
  1106.     else if getkey=0 then;
  1107.   end;
  1108.   settextmode;
  1109. end;
  1110.  
  1111. begin
  1112.   textmode($103);
  1113.   writeln('Hardware Line Draw test.');
  1114.   writeln;
  1115.  
  1116.   if auto_test then
  1117.   begin
  1118.     delay(1000);
  1119.     pushkey(ord('*'));
  1120.   end
  1121.   else begin
  1122.     writeln('Modes:');
  1123.     writeln;
  1124.     for m:=1 to nomodes do
  1125.       if (modetbl[m].flags AND MFL_enGr)=MFL_enGr then
  1126.       writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  1127.              +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  1128.     writeln;
  1129.  
  1130.     writeln('  *  All modes');
  1131.     writeln;
  1132.   end;
  1133.  
  1134.   x:=getmenkey;
  1135.   for m:=1 to nomodes do
  1136.     if ((x=0) or (x=m)) and ((modetbl[m].flags AND MFL_enGr)=MFL_enGr) then
  1137.       tmode(m);
  1138. end;
  1139.  
  1140.  
  1141. procedure testRWbank;           {Test R/W bank functions}
  1142. var x,m:word;
  1143.   md:integer;
  1144.  
  1145. procedure CopyLin(x0,y0,x1,y1,pix:word);
  1146. var
  1147.  pxs,px,x,y:word;
  1148.  src,dst:longint;
  1149. begin
  1150.   x:=usebits[memmode] div planes;
  1151.   src:=y0*bytes+(x0*x) div 8;
  1152.   dst:=y1*bytes+(x1*x) div 8;
  1153.   pxs:=(pix*x) div 8;
  1154.   if planes>1 then
  1155.   begin
  1156.     wrinx(GRC,3,0);
  1157.     wrinx(GRC,5,1);
  1158.   end;
  1159.   repeat
  1160.     px:=pxs;
  1161.     x:=$8000-(src and $7FFF);
  1162.     if px>x then px:=x;
  1163.     x:=$8000-(dst and $7FFF);
  1164.     if px>x then px:=x;
  1165.     setbank(dst shr 16);
  1166.     setrbank(src shr 16);
  1167.     move(mem[vseg:src],mem[vseg:dst],px);
  1168.     inc(src,px);
  1169.     inc(dst,px);
  1170.     dec(pxs,px);
  1171.   until pxs=0;
  1172. end;
  1173.  
  1174. procedure tmode(m:word);
  1175. var x,wid:integer;
  1176. begin
  1177.   if InitMode(m) then
  1178.   begin
  1179.     drawtestpattern('Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'
  1180.         +istr(lins)+' '+istr(modecols[memmode])+' colors');
  1181.  
  1182.     wid:=(pixels div 2)-40;
  1183.     for x:=0 to lins-1 do
  1184.       CopyLin(30,x,wid+50,lins-x,wid);
  1185.  
  1186.     if auto_test then
  1187.     begin
  1188.       repeat until keypressed;
  1189.       SetTextMode;
  1190.       write('Did the Read/Write bank test work properly (y/n) ?');
  1191.       af_tst.Flag :=ord(getYN)*AFF_testok;
  1192.       af_cmt:=getComment('any comments to the test');
  1193.  
  1194.       af_tst.mode :=modetbl[m].md;
  1195.       af_tst.Mmode:=modetbl[m].memmode;
  1196.       AddAFbuf(af_tst,sizeof(af_tst));
  1197.       AddAFbuf(af_cmt,length(af_cmt)+1);
  1198.       WrAFbuf(AF_TRWbank);
  1199.     end
  1200.     else if getkey=0 then;
  1201.   end;
  1202.   settextmode;
  1203. end;
  1204.  
  1205. begin
  1206.   textmode($103);
  1207.   writeln('Seperate Read/Write bank test.');
  1208.  
  1209.   if auto_test then
  1210.   begin
  1211.     delay(1000);
  1212.     pushkey(ord('*'));
  1213.   end
  1214.   else begin
  1215.     writeln('Modes:');
  1216.     writeln;
  1217.     for m:=1 to nomodes do
  1218.       if (modetbl[m].flags AND MFL_enGr)=MFL_enGr then
  1219.       writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  1220.              +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  1221.     writeln;
  1222.  
  1223.     writeln('  *  All modes');
  1224.     writeln;
  1225.   end;
  1226.  
  1227.   x:=getmenkey;
  1228.   for m:=1 to nomodes do
  1229.     if ((x=0) or (x=m)) and ((modetbl[m].flags AND MFL_enGr)=MFL_enGr) then
  1230.       tmode(m);
  1231. end;
  1232.  
  1233. procedure testZoom;           {Test Pan & Zoom functions}
  1234. var x,m:word;
  1235.   md:integer;
  1236.  
  1237. procedure tmode(m:word);
  1238. var Xf,Yf,wXs,wXe,wYs,wYe,srcX,srcY:integer;
  1239.     dirty,stop:boolean;
  1240. begin
  1241.   if InitMode(m) then
  1242.   begin
  1243.     drawtestpattern('Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'
  1244.         +istr(lins)+' '+istr(modecols[memmode])+' colors');
  1245.  
  1246.     Xf:=0;Yf:=0;srcX:=0;srcY:=0;
  1247.     wXs:=100;wXe:=150;wYs:=50;wYe:=75;
  1248.  
  1249.     ZoomOnOff(true);
  1250.     stop:=false;dirty:=true;
  1251.  
  1252.     repeat
  1253.       if dirty then
  1254.       begin
  1255.         if Xf<0 then Xf:=0;
  1256.         if Xf>3 then Xf:=3;
  1257.         if Yf<0 then Yf:=0;
  1258.         if Yf>3 then Yf:=3;
  1259.         SetZoomFactor(Xf,Yf);
  1260.  
  1261.         if wXs>wXe then wXe:=wXs;
  1262.         if wYs>wYe then wYe:=wYs;
  1263.         SetZoomWindow(wXs,wYs,wXe,wYe);
  1264.  
  1265.         if srcX<0 then srcX:=0;
  1266.         if srcX>=pixels then srcX:=pixels-1;
  1267.         if srcY<0 then srcY:=0;
  1268.         if srcY>=lins then srcY:=lins-1;
  1269.         setZoomAdr(srcX,srcY);
  1270.       end;
  1271.       dirty:=true;
  1272.       case getkey of
  1273.       ord('-'):dec(Yf);
  1274.       ord('+'):inc(Yf);
  1275.       ord('/'):dec(Xf);
  1276.       ord('*'):inc(Xf);
  1277.        Ch_ArUp:dec(srcY);
  1278.      Ch_ArLeft:dec(srcX);
  1279.     Ch_ArRight:inc(srcX);
  1280.      Ch_ArDown:inc(srcY);
  1281.          Ch_F1:dec(wXs);
  1282.          Ch_F2:inc(wXs);
  1283.          Ch_F3:dec(wXe);
  1284.          Ch_F4:inc(wXe);
  1285.          Ch_F5:dec(wYs);
  1286.          Ch_F6:inc(wYs);
  1287.          Ch_F7:dec(wYe);
  1288.          Ch_F8:inc(wYe);
  1289.   Ch_Esc,Ch_Cr:stop:=true;
  1290.       else dirty:=false;
  1291.       end;
  1292.  
  1293.     until stop;
  1294.     ZoomOnOff(false);
  1295.  
  1296.     if auto_test then
  1297.     begin
  1298.       repeat until keypressed;
  1299.       SetTextMode;
  1300.       write('Did the Pan & Zoom test work properly (y/n) ?');
  1301.       af_tst.Flag :=ord(getYN)*AFF_testok;
  1302.       af_cmt:=getComment('any comments to the test');
  1303.  
  1304.       af_tst.mode :=modetbl[m].md;
  1305.       af_tst.Mmode:=modetbl[m].memmode;
  1306.       AddAFbuf(af_tst,sizeof(af_tst));
  1307.       AddAFbuf(af_cmt,length(af_cmt)+1);
  1308.       WrAFbuf(AF_Tzoom);
  1309.     end
  1310.     else if getkey=0 then;
  1311.   end;
  1312. end;
  1313.  
  1314. begin
  1315.   textmode($103);
  1316.   writeln('Pan & Zoom test.');
  1317.  
  1318.   if auto_test then
  1319.   begin
  1320.     delay(1000);
  1321.     pushkey(ord('*'));
  1322.   end
  1323.   else begin
  1324.     writeln('Modes:');
  1325.     writeln;
  1326.     for m:=1 to nomodes do
  1327.       if (modetbl[m].flags AND MFL_enGr)=MFL_enGr then
  1328.       writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  1329.              +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  1330.     writeln;
  1331.  
  1332.     writeln('  *  All modes');
  1333.     writeln;
  1334.   end;
  1335.  
  1336.   x:=getmenkey;
  1337.   for m:=1 to nomodes do
  1338.     if ((x=0) or (x=m)) and ((modetbl[m].flags AND MFL_enGr)=MFL_enGr) then
  1339.       tmode(m);
  1340. end;
  1341.  
  1342. procedure testbits;           {Test register bits}
  1343. var m,pt,ix,msk:word;
  1344.   md,x:integer;
  1345.   s:string;
  1346.  
  1347. function tmode(m:word):boolean;
  1348. const
  1349.   mask:array[0..7] of byte=(1,2,4,8,16,32,64,128);
  1350. var
  1351.   stop:boolean;
  1352.   x:word;
  1353. begin
  1354.   tmode:=true;
  1355.   if InitMode(m) then
  1356.   begin
  1357.     case memmode of
  1358.       _text,_txt2,_txt4:
  1359.               lins:=32768 div bytes;
  1360.       _cga1,_cga2:
  1361.               lins:=16384 div bytes;
  1362.          _pl1:lins:=cv.mm*longint(256) div bytes;
  1363.     else lins:=cv.mm*longint(1024) div (bytes*planes);
  1364.     end;
  1365.  
  1366.     Clearmemory;
  1367.  
  1368.     clrinx(crtc,$11,$80);
  1369.     drawtestpattern(s);
  1370.     stop:=false;
  1371.     repeat
  1372.       wrtext(10,180,'Reg '+hex4(pt)+'h index '+hex2(ix)+'h bit '+chr(msk+48));
  1373.       x:=rdinx(pt,ix);
  1374.       wrinx(pt,ix,x xor mask[msk]);
  1375.       wrtext(220,180,'= '+chr(48+(rdinx(pt,ix) shr msk) and 1));
  1376.       delay(500);
  1377.       wrinx(pt,ix,x);
  1378.       wrtext(220,180,'= '+chr(48+(rdinx(pt,ix) shr msk) and 1));
  1379.       delay(500);
  1380.  
  1381.       if keypressed then
  1382.         case getkey of
  1383.            ord('-'):if msk>0 then dec(msk)
  1384.                     else begin
  1385.                       msk:=7;
  1386.                       dec(ix);
  1387.                     end;
  1388.            ord('+'):begin
  1389.                       inc(msk);
  1390.                       if msk>7 then
  1391.                       begin
  1392.                         msk:=0;
  1393.                         inc(ix);
  1394.                       end;
  1395.                     end;
  1396.            ord('*'):begin
  1397.                       inc(ix);
  1398.                       msk:=0;
  1399.                     end;
  1400.              Ch_Esc:stop:=true;
  1401.         end;
  1402.     until stop;
  1403.     SetTextmode;
  1404.   end;
  1405. end;
  1406.  
  1407. begin
  1408.   textmode($103);
  1409.   writeln('Test register bits.');
  1410.   writeln;
  1411.   write('Base register (hex): ');
  1412.   readln(s);
  1413.   pt:=dehex(s);
  1414.   write('Start Index (hex 0-FFh): ');
  1415.   readln(s);
  1416.   ix:=dehex(s);
  1417.   write('Start Bit (0-7): ');
  1418.   readln(s);
  1419.   msk:=ord(s[1]) and 7;
  1420.   writeln;
  1421.   writeln('Testing register bits, starting with '+hex4(pt)+'h index '+hex2(ix)+'h bit '+chr(msk+48)+'.');
  1422.   writeln;
  1423.   writeln('  +  Steps up to the next bit (and possibly next index)');
  1424.   writeln('  -  Steps back to the last bit');
  1425.   writeln('  *  Steps to the next index, bit 0');
  1426.   writeln(' Esc Terminates the test');
  1427.   writeln;
  1428.  
  1429.   writeln('Modes:');
  1430.   writeln;
  1431.   for m:=1 to nomodes do
  1432.   begin
  1433.     writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  1434.            +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  1435.   end;
  1436.   writeln;
  1437.   x:=getmenkey;
  1438.   for m:=1 to nomodes do
  1439.     if (x=m) then
  1440.       if not tmode(m) then x:=-1;  {stop}
  1441.  
  1442. end;
  1443.  
  1444.  
  1445. procedure testregs;           {Test register Read/Writable}
  1446. var m,pt,ix,msk:word;
  1447.   md,x:integer;
  1448.   s,IM:string;
  1449.  
  1450. function tmode(md:word):boolean;
  1451. const
  1452.   bit:array[0..7] of byte=(1,2,4,8,16,32,64,128);
  1453. var
  1454.   x,y,z,i:word;
  1455.   msk:array[0..2047] of char;
  1456.   v0:array[0..255] of byte;
  1457.   imsk:array[0..7] of char;
  1458.  
  1459. procedure writelog;
  1460. var x:word;
  1461. begin
  1462.   wrlog('Register test for index '+hex4(pt)+'h  Index mask: '
  1463.        +imsk[0]+imsk[1]+imsk[2]+imsk[3]+imsk[4]+imsk[5]+imsk[6]+imsk[7]);
  1464.   writeln('     01234567 01234567 01234567 01234567 01234567 01234567 01234567 01234567');
  1465.   for x:=0 to 2047 do
  1466.   begin
  1467.     if (x and 63)=0 then s:=' '+hex2(x shr 3)+':';
  1468.     if (x and 7)=0 then s:=s+' ';
  1469.     s:=s+msk[x];
  1470.     if (x and 63)=63 then wrlog(s);
  1471.   end;
  1472.   closelog;
  1473. end;
  1474.  
  1475. begin
  1476.   tmode:=true;
  1477.   if setMode(md,true) then
  1478.   begin
  1479.     clrinx(crtc,$11,$80);
  1480.     drawtestpattern(s);
  1481.     fillchar(imsk,8,'W');
  1482.     y:=inp(pt);z:=0;
  1483.     for x:=0 to 7 do  {Check if each bit of the index register is RW}
  1484.     begin
  1485.       outp(pt,y and not bit[x and 7]);
  1486.       if (inp(pt) and bit[x and 7])>0 then imsk[x]:='1';
  1487.       outp(pt,y or bit[x and 7]);
  1488.       if (inp(pt) and bit[x and 7])=0 then imsk[x]:='0';
  1489.       outp(pt,y);
  1490.       if IM[x+1]=' ' then im[x+1]:=imsk[x];
  1491.     end;
  1492.  
  1493.     z:=0;y:=0;
  1494.     for x:=1 to 8 do
  1495.     begin
  1496.       if (im[x]='0') or (im[x]='1') then z:=z or bit[x-1]*8;
  1497.       if (im[x]='1') then y:=y or bit[x-1]*8;
  1498.     end;
  1499.  
  1500.  
  1501.  
  1502.     fillchar(msk,sizeof(msk),'W');  {Set all bits off}
  1503.     for x:=0 to 2047 do
  1504.       if ((x xor y) and z)>0 then msk[x]:='.';
  1505.  
  1506.     for y:=0 to 255 do v0[y]:=rdinx(pt,y);
  1507.     for x:=1 to 10 do
  1508.       for y:=0 to 255 do   {Find any bits that changes if read again}
  1509.       begin
  1510.         z:=v0[y] xor rdinx(pt,y);
  1511.         for i:=0 to 7 do                   {Check each bit}
  1512.           if (z and bit [i])>0 then msk[y*8+i]:='A';
  1513.       end;
  1514.     openlog(false);
  1515.     wrlog('After re-read test');
  1516.     writelog;
  1517.  
  1518.     for x:=0 to 2047 do  {Check that each bit is R/W}
  1519.       if msk[x]='W' then
  1520.       begin
  1521.         y:=x shr 3;
  1522.         wrinx(pt,y,v0[y] and not bit[x and 7]);
  1523.         if (rdinx(pt,y) and bit[x and 7])>0 then msk[x]:='1';
  1524.         wrinx(pt,y,v0[y] or bit[x and 7]);
  1525.         if (rdinx(pt,y) and bit[x and 7])=0 then msk[x]:='0';
  1526.         wrinx(pt,y,v0[y]);
  1527.       end;
  1528.     openlog(false);
  1529.     wrlog('After R/W test');
  1530.     writelog;
  1531.  
  1532.     for x:=1 to 2047 do   {Try to change one of the other bits}
  1533.       if msk[x]='W' then      {and see if we changes with it}
  1534.       begin
  1535.         y:=x shr 3;
  1536.         wrinx(pt,y,v0[y] xor bit[x and 7]);
  1537.         for z:=0 to x-1 do
  1538.           if (msk[z]='W') and (((v0[z shr 3] xor rdinx(pt,z shr 3))
  1539.              and bit[z and 7])>0) then msk[z]:='C';
  1540.         wrinx(pt,y,v0[y]);
  1541.         for z:=0 to x-1 do
  1542.           if (msk[z]='W') and (((v0[z shr 3] xor rdinx(pt,z shr 3))
  1543.              and bit[z and 7])>0) then msk[z]:='C';
  1544.       end;
  1545.     openlog(true);
  1546.     writelog;
  1547.     if readkey='' then;
  1548.   end;
  1549. end;
  1550.  
  1551. begin
  1552.   SetTextMode;
  1553.   writeln('Test register bits.');
  1554.   writeln;
  1555.   write('Base register (hex): ');
  1556.   readln(s);
  1557.   pt:=dehex(s);
  1558.   writeln;
  1559.   Write('Index mask (low bit first: 0/1/x/ ): ');
  1560.   readln(IM);IM:=copy(IM+'        ',1,8);
  1561.   for m:=1 to 8 do
  1562.     if (IM[m]<>'x') and (IM[m]<>'0') and (IM[m]<>'1') then IM[m]:=' ';
  1563.  
  1564.   writeln('Testing indexed registers for base='+hex4(pt)+'h.');
  1565.   writeln;
  1566.  
  1567.   if (nomodes=0) and tmode($12) then
  1568.   else begin
  1569.     writeln('Modes:');
  1570.     writeln;
  1571.     for m:=1 to nomodes do
  1572.     begin
  1573.       writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  1574.              +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  1575.     end;
  1576.     writeln;
  1577.     x:=getmenkey;
  1578.     if (x>0) and (x<=nomodes) and tmode(modetbl[x].md) then;  {stop}
  1579.   end;
  1580. end;
  1581.  
  1582.  
  1583. procedure testDACgamma;
  1584. var i,j,x,colorsh,
  1585.   redi,redc,grni,grnc,blui,bluc,
  1586.   gamm,oldgam:integer;
  1587.   stop:boolean;
  1588.   red,grn,blu:array[0..255] of byte;
  1589. begin
  1590.   SetTextMode;
  1591.   writeln('Mode for gamma test:');
  1592.   for i:=1 to nomodes do
  1593.     if ((modetbl[i].flags and MFL_enGr)=MFL_enGr)
  1594.       and (modetbl[i].memmode>_P8) then
  1595.     writeln('  '+menuchars[i]+' '+hex4(modetbl[i].md)+'h '
  1596.            +istr(modetbl[i].xres)+'x'+istr(modetbl[i].yres)
  1597.            +' '+mdtxt[modetbl[i].memmode]);
  1598.   write('Select mode: ');
  1599.   i:=getmenkey;
  1600.   if (i<=0) or (i>nomodes) or (modetbl[i].memmode<=_P8) then i:=0;
  1601.   if InitMode(i) then
  1602.   begin
  1603.     drawtestpattern('Test DAC gamma correction');
  1604.     wrtext(30,120,'Press + to toggle the gamma correction off/red/green/blue');
  1605.     wrtext(30,140,'One of the scales will be inverted, the other two unchanged.');
  1606.     stop:=false;
  1607.     gamm:=0;
  1608.     oldgam:=-1;
  1609.     repeat
  1610.       if gamm<>oldgam then
  1611.       begin
  1612.         if gamm=0 then x:=setDACgamma(false)
  1613.         else begin
  1614.           x:=setDACgamma(true);
  1615.           if (x and GAM_8bit)=0 then colorsh:=4 else colorsh:=1;
  1616.           redi:=0;grni:=0;
  1617.           if memmode>=_P24 then
  1618.           begin
  1619.             redc:=1;grnc:=1;
  1620.           end
  1621.           else begin
  1622.             redc:=8;grnc:=8;
  1623.             if (memmode=_P16) then grnc:=4;
  1624.             if (x and GAM_Left8)>0 then redi:=3;
  1625.             if (x and GAM_Left8)>0 then redi:=1;
  1626.             grni:=redi;
  1627.             if (grni>0) and (memmode=_P16) then dec(grni);
  1628.  
  1629.           end;
  1630.  
  1631.           blui:=redi;bluc:=redc;
  1632.           for i:=0 to 255 do
  1633.           begin
  1634.             if gamm=1 then j:=255-i else j:=i;    {Check for inversion}
  1635.             red[i]:=((j shr redi)*redc) div colorsh;
  1636.             if gamm=2 then j:=255-i else j:=i;
  1637.             grn[i]:=((j shr grni)*grnc) div colorsh;
  1638.             if gamm=3 then j:=255-i else j:=i;
  1639.             blu[i]:=((j shr blui)*bluc) div colorsh;
  1640.           end;
  1641.           SetRGBPal(0,0,0,0);  {Keep (0,0,0) as black for background}
  1642.           for i:=1 to 255 do
  1643.             SetRGBPal(i,red[i],grn[i],blu[i]);
  1644.         end;
  1645.         oldgam:=gamm;
  1646.       end;
  1647.       if keypressed then
  1648.         case getkey of
  1649.            ord('+'):gamm:=(gamm+1) and 3;
  1650.        Ch_Esc,Ch_Cr:stop:=true;
  1651.         end;
  1652.     until stop;
  1653.     x:=setDACgamma(false);   {Remove Gamma}
  1654.     setdac8(false);  {Return to 6bit DAC mode}
  1655.  
  1656.     SetTextMode;
  1657.   end;
  1658. end;
  1659.  
  1660.  
  1661. procedure testdac8(m:word);           {Test 8bit DAC mode}
  1662. var
  1663.   stop,dac8,olddac:boolean;
  1664.   x,y,cmd:word;
  1665.   mm:byte;
  1666. begin
  1667.   if InitMode(m) then
  1668.   begin
  1669.     drawtestpattern('Test 6/8 bit DAC');
  1670.     wrtext(30,230,'Press + to toggle the DAC mode');
  1671.     wrtext(30,245,'6bit DAC mode should show the color scales breaking 3 times each');
  1672.     wrtext(30,260,'8bit DAC mode should show unbroken color scales');
  1673.     for y:=0 to 127 do
  1674.       for x:=0 to 255 do
  1675.         setpix(x+30,y+100,(x shr 2)+(y and $60)*2);
  1676.     cmd:=0;
  1677.     stop:=false;
  1678.     dac8:=false;
  1679.     olddac:=not dac8;
  1680.     repeat
  1681.       if dac8<>olddac then
  1682.       begin
  1683.         setdac8(dac8);
  1684.  
  1685.         for x:=0 to 63 do SetRGBPal(x,x*4,0,0);
  1686.         for x:=0 to 63 do SetRGBPal(x+$40,0,x*4,0);
  1687.         for x:=0 to 63 do SetRGBPal(x+$80,0,0,x*4);
  1688.         for x:=0 to 63 do SetRGBPal(x+$C0,x*4,x*4,x*4);
  1689.         olddac:=dac8;
  1690.       end;
  1691.       if keypressed then
  1692.         case getkey of
  1693.            ord('+'):dac8:=not dac8;
  1694.        Ch_Esc,Ch_Cr:stop:=true;
  1695.         end;
  1696.     until stop;
  1697.     setdac8(false);
  1698.  
  1699.     SetTextMode;
  1700.   end;
  1701. end;
  1702.  
  1703.  
  1704. procedure testdac15(m:word);           {Test 8bit DAC mode}
  1705. var
  1706.   stop,dac8,olddac:boolean;
  1707.   x,y,cmd:word;
  1708.   mm:byte;
  1709. begin
  1710.   if InitMode(m) then
  1711.   begin
  1712.     drawtestpattern('Test 15bit (32Kcolor) DAC mode');
  1713.     wrtext(30,230,'Press + to toggle the DAC mode');
  1714.     wrtext(30,248,'The image above is for normal (palette) mode and the one');
  1715.     wrtext(30,266,'below is for 15bit mode. Both should have the Red stripe');
  1716.     wrtext(30,284,'at the top, then green, blue and finally white.');
  1717.     for y:=0 to 127 do
  1718.       for x:=0 to 255 do
  1719.         setpix(x+30,y+100,(x shr 2)+(y and $60)*2);
  1720.     memmode:=_p15;
  1721.     for y:=0 to 15 do
  1722.       for x:=0 to 255 do
  1723.       begin
  1724.         setpix(x+30,y+305,RGB(x,0,0));
  1725.         setpix(x+30,y+321,RGB(0,x,0));
  1726.         setpix(x+30,y+337,RGB(0,0,x));
  1727.         setpix(x+30,y+353,RGB(x,x,x));
  1728.       end;
  1729.  
  1730.     memmode:=_P8;
  1731.     stop:=false;
  1732.     dac8:=false;
  1733.     olddac:=not dac8;
  1734.     repeat
  1735.       if dac8<>olddac then
  1736.       begin
  1737.         if not dac8 then setDACstd
  1738.         else if setdac15 then;
  1739.         olddac:=dac8;
  1740.       end;
  1741.       if keypressed then
  1742.         case getkey of
  1743.            ord('+'):dac8:=not dac8;
  1744.        Ch_Esc,Ch_Cr:stop:=true;
  1745.         end;
  1746.     until stop;
  1747.     setdacstd;
  1748.  
  1749.     SetTextMode;
  1750.   end;
  1751. end;
  1752.  
  1753. procedure testdac16(m:word);           {Test 8bit DAC mode}
  1754. var
  1755.   stop,dac8,olddac:boolean;
  1756.   x,y,cmd:word;
  1757.   mm:byte;
  1758. begin
  1759.   if InitMode(m) then
  1760.   begin
  1761.     drawtestpattern('Test 16bit (64Kcolor) DAC mode');
  1762.     wrtext(30,230,'Press + to toggle the DAC mode');
  1763.     wrtext(30,248,'The image above is for normal (palette) mode and the one');
  1764.     wrtext(30,266,'below is for 16bit mode. Both should have the Red stripe');
  1765.     wrtext(30,284,'at the top, then green, blue and finally white.');
  1766.     for y:=0 to 127 do
  1767.       for x:=0 to 255 do
  1768.         setpix(x+30,y+100,(x shr 2)+(y and $60)*2);
  1769.     memmode:=_p16;
  1770.     for y:=0 to 15 do
  1771.       for x:=0 to 255 do
  1772.       begin
  1773.         setpix(x+30,y+305,RGB(x,0,0));
  1774.         setpix(x+30,y+321,RGB(0,x,0));
  1775.         setpix(x+30,y+337,RGB(0,0,x));
  1776.         setpix(x+30,y+353,RGB(x,x,x));
  1777.       end;
  1778.  
  1779.     memmode:=_P8;
  1780.     stop:=false;
  1781.     dac8:=false;
  1782.     olddac:=not dac8;
  1783.     repeat
  1784.       if dac8<>olddac then
  1785.         if not dac8 then setDACstd
  1786.         else if setdac16 then;
  1787.       olddac:=dac8;
  1788.       case getkey of
  1789.          ord('+'):dac8:=not dac8;
  1790.      Ch_Esc,Ch_Cr:stop:=true;
  1791.       end;
  1792.     until stop;
  1793.     setdacstd;
  1794.     SetTextMode;
  1795.   end;
  1796. end;
  1797.  
  1798. procedure testdac24(m:word);           {Test 8bit DAC mode}
  1799. var
  1800.   stop,dac8,olddac:boolean;
  1801.   x,y,cmd:word;
  1802.   mm:byte;
  1803. begin
  1804.   if InitMode(m) then
  1805.   begin
  1806.     drawtestpattern('Test 24bit (16Mcolor) DAC mode');
  1807.     wrtext(30,230,'Press + to toggle the DAC mode');
  1808.     wrtext(30,248,'The image above is for normal (palette) mode and the one');
  1809.     wrtext(30,266,'below is for 24bit mode. Both should have the Red stripe');
  1810.     wrtext(30,284,'at the top, then green, blue and finally white.');
  1811.     for y:=0 to 127 do
  1812.       for x:=0 to 255 do
  1813.         setpix(x+30,y+100,(x shr 2)+(y and $60)*2);
  1814.     memmode:=_p24;
  1815.     for y:=0 to 15 do
  1816.       for x:=0 to 255 do
  1817.       begin
  1818.         setpix(x+30,y+305,RGB(x,0,0));
  1819.         setpix(x+30,y+321,RGB(0,x,0));
  1820.         setpix(x+30,y+337,RGB(0,0,x));
  1821.         setpix(x+30,y+353,RGB(x,x,x));
  1822.       end;
  1823.  
  1824.     memmode:=_P8;
  1825.     stop:=false;
  1826.     dac8:=false;
  1827.     olddac:=not dac8;
  1828.     repeat
  1829.       if dac8<>olddac then
  1830.       begin
  1831.         if not dac8 then setDACstd
  1832.         else if setdac24 then;
  1833.         olddac:=dac8;
  1834.       end;
  1835.       if keypressed then
  1836.         case getkey of
  1837.            ord('+'):dac8:=not dac8;
  1838.        Ch_Esc,Ch_Cr:stop:=true;
  1839.         end;
  1840.     until stop;
  1841.     setdacstd;
  1842.  
  1843.     SetTextMode;
  1844.   end;
  1845. end;
  1846.  
  1847. procedure testdac32(m:word);           {Test 8bit DAC mode}
  1848. var
  1849.   stop,dac8,olddac:boolean;
  1850.   x,y,cmd:word;
  1851.   mm:byte;
  1852. begin
  1853.   if InitMode(m) then
  1854.   begin
  1855.     drawtestpattern('Test 32bit (16Mcolor - RGBa) DAC mode');
  1856.     wrtext(30,230,'Press + to toggle the DAC mode');
  1857.     wrtext(30,248,'The image above is for normal (palette) mode and the one');
  1858.     wrtext(30,266,'below is for 32bit mode. Both should have the Red stripe');
  1859.     wrtext(30,284,'at the top, then green, blue and finally white.');
  1860.     for y:=0 to 127 do
  1861.       for x:=0 to 255 do
  1862.         setpix(x+30,y+100,(x shr 2)+(y and $60)*2);
  1863.     memmode:=_p32;
  1864.     for y:=0 to 15 do
  1865.       for x:=0 to 255 do
  1866.       begin
  1867.         setpix(x+30,y+305,RGB(x,0,0));
  1868.         setpix(x+30,y+321,RGB(0,x,0));
  1869.         setpix(x+30,y+337,RGB(0,0,x));
  1870.         setpix(x+30,y+353,RGB(x,x,x));
  1871.       end;
  1872.  
  1873.     memmode:=_P8;
  1874.     stop:=false;
  1875.     dac8:=false;
  1876.     olddac:=not dac8;
  1877.     repeat
  1878.       if dac8<>olddac then
  1879.       begin
  1880.         if not dac8 then setDACstd
  1881.         else if setdac32 then;
  1882.         olddac:=dac8;
  1883.       end;
  1884.       if keypressed then
  1885.         case getkey of
  1886.            ord('+'):dac8:=not dac8;
  1887.        Ch_Esc,Ch_Cr:stop:=true;
  1888.         end;
  1889.     until stop;
  1890.     setdacstd;
  1891.  
  1892.     SetTextMode;
  1893.   end;
  1894. end;
  1895.  
  1896.  
  1897.  
  1898.   {Test the DAC Cmd register}
  1899. procedure testdaccmd(m:word);
  1900. var
  1901.   stop:boolean;
  1902.   x,y,cmd,pel:word;
  1903. function bin(w:word):string;
  1904. var s:string[10];
  1905.   i:integer;
  1906. begin
  1907.   s:='';
  1908.   for i:=7 downto 0 do
  1909.     s:=s+chr(((w shr i) and 1) +48);
  1910.   bin:=s;
  1911. end;
  1912.  
  1913. procedure newcmd(cmd:word);
  1914. var x,pel:word;
  1915. begin
  1916.   if cv.chip=__cir54 then
  1917.   begin
  1918.     pel:=inp($3C6);
  1919.     outp($3C6,0);
  1920.   end;
  1921.  
  1922.   outp(setDACpage(dacHIcmd),cmd);
  1923.   clearDACpage;
  1924.   x:=inp(setDACpage(dacHIcmd)) xor cmd;
  1925.   clearDACpage;
  1926.   wrtext(10,10,'DAC Command: '+hex2(cmd)+'h, '+bin(cmd)+'b  XOR: '+hex2(x)+'h, '+bin(x)+'b:');
  1927.   for x:=0 to 63 do
  1928.   begin
  1929.     SetRGBPal(x,x*4,0,0);
  1930.     SetRGBPal(x+$40,0,x*4,0);
  1931.     SetRGBPal(x+$80,0,0,x*4);
  1932.     SetRGBPal(x+$C0,x*4,x*4,x*4);
  1933.   end;
  1934.   if cv.chip=__cir54 then outp($3C6,pel);
  1935. end;
  1936.  
  1937. begin
  1938.   if InitMode(m) then
  1939.   begin
  1940.     drawtestpattern('Test DAC Command register');
  1941.  
  1942.     for y:=100 to 230 do
  1943.       for x:=30 to 170 do
  1944.         setpix(x,y,0);
  1945.  
  1946.     for y:=0 to 63 do
  1947.       for x:=0 to 255 do
  1948.         setpix(x+30,y+100,(x shr 2)+(y and $30)*4);
  1949.  
  1950.     memmode:=_p15;
  1951.     for y:=0 to 15 do
  1952.       for x:=0 to 255 do
  1953.       begin
  1954.         setpix(x+30,y+180,RGB(x,0,0));
  1955.         setpix(x+30,y+196,RGB(0,x,0));
  1956.         setpix(x+30,y+212,RGB(0,0,x));
  1957.         setpix(x+30,y+228,RGB(x,x,x));
  1958.       end;
  1959.  
  1960.     memmode:=_p16;
  1961.     for y:=0 to 15 do
  1962.       for x:=0 to 255 do
  1963.       begin
  1964.         setpix(x+30,y+260,RGB(x,0,0));
  1965.         setpix(x+30,y+276,RGB(0,x,0));
  1966.         setpix(x+30,y+292,RGB(0,0,x));
  1967.         setpix(x+30,y+308,RGB(x,x,x));
  1968.       end;
  1969.  
  1970.     memmode:=_p24;
  1971.     for y:=0 to 15 do
  1972.       for x:=0 to 127 do
  1973.       begin
  1974.         setpix(x+24,y+340,RGB(x*2,0,0));
  1975.         setpix(x+24,y+356,RGB(0,x*2,0));
  1976.         setpix(x+24,y+372,RGB(0,0,x*2));
  1977.         setpix(x+24,y+388,RGB(x*2,x*2,x*2));
  1978.       end;
  1979.  
  1980.     memmode:=_p32;
  1981.     for y:=0 to 15 do
  1982.       for x:=0 to 127 do
  1983.       begin
  1984.         setpix(x+24,y+420,RGB(x*2,0,0));
  1985.         setpix(x+24,y+436,RGB(0,x*2,0));
  1986.         setpix(x+24,y+452,RGB(0,0,x*2));
  1987.         setpix(x+24,y+468,RGB(x*2,x*2,x*2));
  1988.       end;
  1989.  
  1990.     memmode:=_P8;
  1991.     wrtext(5,180,'15');
  1992.     wrtext(5,260,'16');
  1993.     wrtext(5,340,'24');
  1994.     wrtext(5,420,'32');
  1995.     wrtext(50,30,'Press F1..F8 to toggle the DAC mode bits 0..7');
  1996.  
  1997.     stop:=false;
  1998.  
  1999.     if cv.chip=__cir54 then
  2000.     begin
  2001.       pel:=inp($3C6);
  2002.       outp($3C6,0);
  2003.     end;
  2004.     cmd:=inp(SetDACpage(dacHIcmd));
  2005.     clearDACpage;
  2006.     if cv.chip=__cir54 then outp($3C6,pel);
  2007.     repeat
  2008.       newcmd(cmd);
  2009.       case getkey of
  2010.         Ch_F1:cmd:=cmd xor 1;
  2011.         Ch_F2:cmd:=cmd xor 2;
  2012.         Ch_F3:cmd:=cmd xor 4;
  2013.         Ch_F4:cmd:=cmd xor 8;
  2014.         Ch_F5:cmd:=cmd xor 16;
  2015.         Ch_F6:cmd:=cmd xor 32;
  2016.         Ch_F7:cmd:=cmd xor 64;
  2017.         Ch_F8:cmd:=cmd xor 128;
  2018.    ord('A'),ord('a'):for x:=0 to 255 do
  2019.                      begin
  2020.                        newcmd(x);
  2021.                        delay(1000);
  2022.                      end;
  2023.         Ch_Esc,Ch_Cr:stop:=true;
  2024.       end;
  2025.     until stop;
  2026.     clearDACpage;
  2027.     setdacstd;
  2028.  
  2029.     SetTextMode;
  2030.   end;
  2031. end;
  2032.  
  2033.  
  2034.   {Analyse the DAC Cmd register}
  2035. procedure testdaccmdAnal(m:word);
  2036. const
  2037.   msk:array[0..3] of byte=($55,$AA,$5A,$A5);
  2038. var
  2039.   stop:boolean;
  2040.   mask,x,y,z,i,mk,cmd,chg:word;
  2041.   res0:array[0..39] of byte;
  2042.   res:array[byte] of byte;
  2043.   t:text;
  2044.   s:string;
  2045.  
  2046. function DacBit(cmd:integer):integer;
  2047. begin
  2048.   dac2comm;
  2049.   outp($3C6,cmd);
  2050.   dac2pel;
  2051.   dac2comm;
  2052.   DacBit:=inp($3C6);
  2053.   dac2pel;
  2054. end;
  2055.  
  2056. begin
  2057.   if InitMode(m) then
  2058.   begin
  2059.     for x:=0 to 3 do
  2060.     begin
  2061.       dac2pel;
  2062.       outp($3C6,msk[x]);
  2063.       dac2pel;
  2064.       for y:=0 to 9 do res0[x*10+y]:=inp($3C6);
  2065.       dac2pel;
  2066.     end;
  2067.     dac2pel;
  2068.     outp($3C6,$FF);
  2069.     setdacstd;
  2070.     SetTextMode;
  2071.  
  2072.     x:=DacBit(0);
  2073.     mk:=0;
  2074.     for x:=0 to 7 do
  2075.     begin
  2076.       y:=1 shl x;
  2077.       z:=DacBit(y);
  2078.       mk:=mk+(z and y);
  2079.     end;
  2080.     clearDACpage;
  2081.     setdacstd;      {Write the data several times in case we lock up...}
  2082.     SetTextMode;
  2083.  
  2084.     if cv.chip=__cir54 then i:=$FD else i:=$FF;
  2085.     if cv.dactype=_dacTR8001 then i:=$FB;
  2086.     x:=0;y:=255;z:=255;
  2087.     for cmd:=0 to 255 do
  2088.     begin
  2089.       res[cmd]:=DacBit(cmd and i);
  2090.       x:=x or  res[cmd];
  2091.       y:=y and res[cmd];
  2092.       z:=z and (res[cmd] xor not cmd);
  2093.     end;
  2094.     chg:=z and (x and not y);
  2095.     mask:=i;
  2096.   end;
  2097.   clearDACpage;
  2098.   setdacstd;
  2099.   SetTextMode;
  2100.   OpenLog(true);
  2101.   wrlog(  '  DAC Command register read test:');
  2102.   wrlog(  'Read:  $55  $AA  $5A  $A5');
  2103.   for i:=0 to 9 do
  2104.     wrlog('  '+chr(i+48)+'    '+hex2(res0[i])+'   '+hex2(res0[i+10])
  2105.                       +'   '+hex2(res0[i+20])+'   '+hex2(res0[i+30]));
  2106.   wrlog('');
  2107.   wrlog('Dac Single Bit Mask: '+hex2(mk));
  2108.   wrlog('');
  2109.   wrlog('DAC mask: '+hex2(mask)+'h R/W: '+hex2(z)+'h Chg: '+hex2(chg)
  2110.            +' Set: '+hex2(y)+'h Clear: '+hex2(not x)+'h');
  2111.   z:=z or chg;
  2112.   s:='';
  2113.   for i:=0 to 255 do
  2114.     if ((res[i] xor i) and z)<>0 then
  2115.       s:=s+'  '+hex2(i)+' = '+hex2(res[i])+' ';
  2116.   wrlog(s);
  2117.   closelog;
  2118.   if readkey='' then;
  2119. end;
  2120.  
  2121.   {DAC test master menu}
  2122. procedure testdac;
  2123. var i,md:word;
  2124.    stop:boolean;
  2125. begin
  2126.   md:=0;
  2127.   for i:=1 to nomodes do
  2128.     if ((modetbl[i].flags AND MFL_enGr)=MFL_enGr) AND (modetbl[i].memmode=_p8)
  2129.      and (modetbl[i].xres=640) and (modetbl[i].yres=480) then md:=i;
  2130.   stop:=false;
  2131.   repeat
  2132.     SetTextMode;
  2133.     writeln('DAC test options:');
  2134.     writeln('  2 - Test 24bit (16Mcolor) mode');
  2135.     writeln('  3 - Test 32bit (16Mcolor RGBa) mode');
  2136.     writeln('  5 - Test 15bit (32Kcolor) mode');
  2137.     writeln('  6 - Test 16bit (64Kcolor) mode');
  2138.     writeln('  8 - Test 6/8bit mode');
  2139.     writeln('  A - DAC Cmd register Analysis');
  2140.     writeln('  C - Test Command register');
  2141.     writeln('  G - Test Gamma Correction');
  2142.     writeln('  M - Select base mode');
  2143.     writeln('  0 - Return to main menu');
  2144.  
  2145.     case getkey of
  2146.            ord('2'):testdac24(md);
  2147.            ord('3'):testdac32(md);
  2148.            ord('5'):testdac15(md);
  2149.            ord('6'):testdac16(md);
  2150.            ord('8'):testdac8(md);
  2151.   ord('a'),ord('A'):testdaccmdAnal(md);
  2152.   ord('c'),ord('C'):testdaccmd(md);
  2153.   ord('g'),ord('G'):testDACgamma;
  2154.   ord('m'),ord('M'):begin
  2155.                       writeln;
  2156.                       for i:=1 to nomodes do
  2157.                         if ((modetbl[i].flags and MFL_enGr)=MFL_enGr)
  2158.                           and (modetbl[i].memmode=_P8) then
  2159.                         writeln('  '+menuchars[i]+' '+hex4(modetbl[i].md)+'h '
  2160.                                +istr(modetbl[i].xres)+'x'+istr(modetbl[i].yres)
  2161.                                +' '+mdtxt[modetbl[i].memmode]);
  2162.                       write('Select mode: ');
  2163.                       i:=getmenkey;
  2164.                       if (i>0) and (i<=nomodes) and (modetbl[i].memmode=_P8) then md:=i;
  2165.                     end;
  2166.     ord('0'),Ch_Esc:stop:=true;
  2167.     end;
  2168.   until stop;
  2169.  
  2170. end;
  2171.  
  2172.  
  2173. procedure testvgamodes;           {Test extended modes}
  2174. var m:word;
  2175.   md,x:integer;
  2176.  
  2177. function tmode(m:word):boolean;
  2178. begin
  2179.   tmode:=true;
  2180.  
  2181.   if auto_test then
  2182.   begin
  2183.     fillchar(af_rec,sizeof(af_rec),0);
  2184.     af_cmt:='';
  2185.   end;
  2186.  
  2187.   if InitMode(m) then tmode:=testvmode;
  2188.  
  2189.   if auto_test then
  2190.   begin
  2191.     af_rec.mode  :=modetbl[m].md;
  2192.     af_rec.Mmode :=memmode;
  2193.     af_rec.pixels:=pixels;
  2194.     af_rec.lins  :=lins;
  2195.     af_rec.bytes :=bytes;
  2196.     af_rec.crtc  :=crtc;
  2197.     AddAFBuf(af_rec,sizeof(af_rec));
  2198.     AddAFbuf(af_cmt,length(af_cmt)+1);
  2199.     inc(af_pos,FormatRgs(af_buf[af_pos]));
  2200.  
  2201.     WrAFbuf(AF_modeinfo);
  2202.   end;
  2203. end;
  2204.  
  2205. begin
  2206.   textmode($103);
  2207.   writeln('Test extended VGA modes.');
  2208.   writeln('Modes:');
  2209.   writeln;
  2210.   for m:=1 to nomodes do  {Not the Std VGA modes}
  2211.     if ((modetbl[m].flags and MFL_enVGA)=MFL_enabled) then
  2212.       writeln('  '+menuchars[m]+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  2213.              +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  2214.   writeln;
  2215.  
  2216.   writeln('  *  All modes');
  2217.   if auto_test then pushkey(ord('*'));
  2218.   writeln;
  2219.   x:=getmenkey;
  2220.   for m:=1 to nomodes do
  2221.     if ((x=0) or (x=m)) and ((modetbl[m].flags and MFL_enGrVGA)=MFL_enGr) then
  2222.       if not tmode(m) then x:=-1;  {stop}
  2223. end;
  2224.  
  2225. procedure teststdvgamodes;          {Test standard VGA modes}
  2226. var m:word;
  2227.   md,x:integer;
  2228.  
  2229. function tmode(m:word):boolean;
  2230. begin
  2231.  
  2232.   if auto_test then
  2233.   begin
  2234.     fillchar(af_rec,sizeof(af_rec),0);
  2235.     af_cmt:='';
  2236.   end;
  2237.  
  2238.  
  2239.   if InitMode(m) then tmode:=testvmode;
  2240.  
  2241.   if auto_test then
  2242.   begin
  2243.     af_rec.mode  :=stdmodetbl[m].md;
  2244.     af_rec.Mmode :=memmode;
  2245.     af_rec.pixels:=pixels;
  2246.     af_rec.lins  :=lins;
  2247.     af_rec.bytes :=bytes;
  2248.     af_rec.crtc  :=crtc;
  2249.     AddAFBuf(af_rec,sizeof(af_rec));
  2250.     AddAFbuf(af_cmt,length(af_cmt)+1);
  2251.     inc(af_pos,FormatRgs(af_buf[af_pos]));
  2252.     WrAFbuf(AF_modeinfo);
  2253.   end;
  2254. end;
  2255.  
  2256. begin
  2257.   textmode($103);
  2258.   writeln('Standard VGA mode test.');
  2259.   writeln;
  2260.   writeln('Modes:');
  2261.   writeln;
  2262.   for m:=1 to novgamodes do
  2263.   begin
  2264.     writeln('  '+menuchars[m]+' '+hex4(stdmodetbl[m].md)+'h '+istr(stdmodetbl[m].xres)
  2265.            +'x'+istr(stdmodetbl[m].yres)+' '+mdtxt[stdmodetbl[m].memmode]);
  2266.   end;
  2267.   writeln;
  2268.   writeln('  *  All modes');
  2269.  
  2270.   writeln;
  2271.   if auto_test then pushkey(ord('*'));
  2272.   x:=getmenkey;
  2273.   for m:=1 to novgamodes do
  2274.     if (x=0) or (x=m) then
  2275.       if not tmode(m) then x:=-1;
  2276.  
  2277. end;
  2278.  
  2279.  
  2280. procedure searchformodes;      {Run through all possible modes
  2281.                                 and try to id any new ones}
  2282. type
  2283.   regblk=record
  2284.            base:word;
  2285.            nbr:word;
  2286.            x:array[0..255] of byte;
  2287.          end;
  2288. var
  2289.   md,m,hig,wid,x,y,oldbytes,wordadr:word;
  2290.   c:char;
  2291.   ofil:text;
  2292.   attregs:array[0..31] of byte;
  2293.   seqregs,grcregs,crtcregs,xxregs:regblk;
  2294.   stdregs:array[$3C0..$3DF] of byte;
  2295.   l:longint;
  2296.   s:string;
  2297.   stop:boolean;
  2298.  
  2299.  
  2300. procedure dumprg(base:word;var rg:regblk);
  2301. var six,ix:word;
  2302. begin
  2303.   rg.base:=base;
  2304.   six:=inp(base);
  2305.   outp(base,0);
  2306.   ix:=inp(base) xor 255;
  2307.   outp(base,255);
  2308.   ix:=ix and inp(base);
  2309.  
  2310.   if ix>127 then rg.nbr:=255
  2311.   else if ix>63 then rg.nbr:=127
  2312.   else if ix>31 then rg.nbr:=63
  2313.   else if ix>15 then rg.nbr:=31
  2314.   else if ix>7 then rg.nbr:=15
  2315.   else rg.nbr:=7;
  2316.   for ix:=0 to rg.nbr do
  2317.     rg.x[ix]:=rdinx(base,ix);
  2318.   outp(base,six);
  2319. end;
  2320.  
  2321.  
  2322.  
  2323.  
  2324. begin
  2325.   md:=$14;
  2326.   stop:=false;
  2327.   while (md<$80) and not stop do
  2328.   begin
  2329.     textmode(3);
  2330.     gotoxy(10,10);
  2331.     write('Testing mode: '+hex2(md));
  2332.     delay(500);
  2333.     if setmode(md,true) then
  2334.     begin
  2335.       pixels :=calcpixels;
  2336.       lins   :=calclines;
  2337.       bytes  :=calcbytes;
  2338.       vseg   :=calcvseg;
  2339.       memmode:=calcmmode;
  2340.       repeat
  2341.         oldbytes:=bytes;
  2342.  
  2343.         if setmode(md,true) and testvmode then
  2344.         begin
  2345.         {  drawtestpattern('Mode: '+hex2(md)+' ('+istr(pixels)+'x'+istr(lins)+' '
  2346.                    +mmodenames[memmode]+') '+istr(bytes)+' bytes.'); }
  2347.         end;
  2348.  
  2349.       (*  case getkey of
  2350.           Ch_PgUp:bytes:=bytes shl 1;
  2351.           Ch_PgDn:bytes:=bytes shr 1;
  2352.           Ch_ArUp:inc(bytes);
  2353.         Ch_ArDown:dec(bytes);
  2354.            Ch_Esc:stop:=true;
  2355.         end; *)
  2356.       until bytes=oldbytes;
  2357.     end;
  2358.     inc(md);
  2359.   end;
  2360.   textmode(3);
  2361. end;
  2362.  
  2363.  
  2364.  
  2365. var
  2366.   stop:boolean;
  2367.  
  2368. function ljust(s:string;lnn:word):string;
  2369. begin
  2370.   ljust:=copy(s+'          ',1,lnn);
  2371. end;
  2372.  
  2373. function rjust(s:string;lnn:word):string;
  2374. begin
  2375.   if length(s)<lnn then s:=copy('          ',1,lnn-length(s))+s;
  2376.   rjust:=s;
  2377. end;
  2378.  
  2379. function chkptr(w:word):word;
  2380. begin
  2381.   if memw[Seg0000:w+2]=biosseg then chkptr:=memw[Seg0000:w]
  2382.                                else chkptr:=0;
  2383. end;
  2384.  
  2385. function fntadr(BH:word):word;
  2386. begin
  2387.   rp.bh:=BH;
  2388.   vio($1130);
  2389.   if rp.es=biosseg then fntadr:=rp.bp
  2390.   else fntadr:=0;
  2391. end;
  2392.  
  2393. procedure wrAFff;
  2394. var
  2395.   rhdr:_ATff;
  2396.   x,y,z,v:word;
  2397. begin
  2398.   if {af_fail and} (biosseg<>0) then
  2399.   begin
  2400.     fillchar(rhdr,sizeof(rhdr),0);
  2401.     rhdr.base :=biosseg;
  2402.     rhdr.size :=mem[biosseg:2];
  2403.     rhdr.int10:=chkptr($40);
  2404.     rhdr.int6D:=chkptr($1B4);
  2405.     rhdr.m4A8 :=chkptr($4A8);
  2406.     rhdr.fnt14  :=fntadr(2);
  2407.     rhdr.fnt8l  :=fntadr(3);
  2408.     rhdr.fnt8h  :=fntadr(4);
  2409.     rhdr.fnt14x9:=fntadr(5);
  2410.     rhdr.fnt16  :=fntadr(6);
  2411.     rhdr.fnt16x9:=fntadr(7);
  2412.     AddAFbuf(rhdr,sizeof(rhdr));
  2413.     WrAFbuf(AF_BIOSdmp);
  2414.     y:=0;z:=0;
  2415.     for x:=0 to (rhdr.size*512-1) do
  2416.     begin
  2417.       v:=mem[biosseg:x];
  2418.       af_buf[z]:=v-y;
  2419.       y:=v;
  2420.       inc(z);
  2421.       if z>=2000 then
  2422.       begin
  2423.         blockwrite(af_fil,af_buf,z);
  2424.         z:=0;
  2425.       end;
  2426.     end;
  2427.     blockwrite(af_fil,af_buf,z);
  2428.   end;
  2429. end;
  2430.  
  2431.  
  2432. procedure ReCalc(rfil:string);
  2433. var f:file;
  2434.     t:text;
  2435.   at0:_AT0;
  2436.   at2:_AT2;
  2437.   buf:array[0..2000] of byte;
  2438.   hdr:record
  2439.         typ:byte;
  2440.         lnn:word;
  2441.       end;
  2442.  fpos:longint;
  2443.    ix,x,y,z,w:word;
  2444.    s:string[5];
  2445.  
  2446. function popb:word;
  2447. begin
  2448.   popb:=buf[ix];
  2449.   inc(ix);
  2450. end;
  2451.  
  2452. function popw:word;
  2453. var w:word;
  2454. begin
  2455.   move(buf[ix],w,2);
  2456.   inc(ix,2);
  2457.   popw:=w;
  2458. end;
  2459.  
  2460. procedure stinx(base,ix,vl:word);
  2461. begin
  2462.   case base of
  2463.    $3C0:rgs.attregs[ix]:=vl;
  2464.    $3C4:begin
  2465.           rgs.seqregs.x[ix]:=vl;
  2466.           if ix>rgs.seqregs.nbr then rgs.seqregs.nbr:=ix;
  2467.         end;
  2468.    $3CE:begin
  2469.           rgs.grcregs.x[ix]:=vl;
  2470.           if ix>rgs.grcregs.nbr then rgs.grcregs.nbr:=ix;
  2471.         end;
  2472.    $3B4,
  2473.    $3D4:begin
  2474.           rgs.crtcregs.x[ix]:=vl;
  2475.           if ix>rgs.crtcregs.nbr then rgs.crtcregs.nbr:=ix;
  2476.         end;
  2477.   else
  2478.     rgs.xxregs.base:=base;
  2479.     rgs.xxregs.x[ix]:=vl;
  2480.     if ix>rgs.xxregs.nbr then rgs.xxregs.nbr:=ix;
  2481.   end;
  2482. end;
  2483.  
  2484. begin
  2485.   if pos('.',rfil)=0 then rfil:=rfil+'.tst';
  2486.   assign(f,rfil);
  2487.   {$i-}
  2488.   reset(f,1);
  2489.   {$i+}
  2490.   if ioresult=0 then
  2491.   begin
  2492.     rfil[0]:=chr(pred(pos('.',rfil)));
  2493.     assign(t,rfil+'.tt');
  2494.     rewrite(t);
  2495.     fpos:=0;vids:=0;
  2496.     repeat
  2497.       blockread(f,hdr,3);
  2498.       case hdr.typ of
  2499.         0:blockread(f,at0,sizeof(_AT0));
  2500.         1:begin
  2501.             inc(vids);
  2502.             blockread(f,vid[vids],sizeof(vid[1]));
  2503.             if vids=at0.cur_vid then SelectVideo(vids);
  2504.           end;
  2505.         2:begin
  2506.             blockread(f,at2,sizeof(at2));
  2507.             blockread(f,buf,hdr.lnn-sizeof(at2)-3);
  2508.             ix:=buf[0]+1;
  2509.             repeat
  2510.               w:=popw;
  2511.               case w of
  2512.                 1:begin
  2513.                     w:=popw;
  2514.                     x:=popb;y:=popb;
  2515.                     for x:=x to y do stinx(w,x,popb);
  2516.                   end;
  2517.            2..$FE:begin
  2518.                     x:=popw;
  2519.                     for x:=x to x+w-1 do
  2520.                     begin
  2521.                       y:=popb;
  2522.                       if (x>=$3C0) and (x<$3DF) then rgs.stdregs[x]:=y;
  2523.                       if (x>=$3B0) and (x<$3BF) then rgs.stdregs[x+$20]:=y;
  2524.                     end;
  2525.                   end;
  2526.               $ff:begin
  2527.                     w:=popw;
  2528.                     x:=popb;
  2529.                     case w of
  2530.                       0:rgs.tridold0d:=x;
  2531.                       1:rgs.tridold0e:=x;
  2532.                     end;
  2533.                   end;
  2534.               else
  2535.                 x:=popb;
  2536.                 if (w>=$3C0) and (w<$3DF) then rgs.stdregs[w]:=x;
  2537.                 if (w>=$3B0) and (w<$3BF) then rgs.stdregs[w+$20]:=x;
  2538.               end;
  2539.             until w=0;
  2540.             if (at2.flag and 1)>0 then
  2541.             begin
  2542.               CalcRegisters;
  2543.               if (at2.mmode=rgs.mmode) and (at2.pixels=rgs.pixels)
  2544.                and (at2.lins=rgs.lins) and (at2.bytes=rgs.bytes) then s:=' Ok' else s:='';
  2545.               writeln(t,hex4(at2.mode),at2.pixels:5,at2.lins:5,at2.bytes:5
  2546.                        ,' '+mmodenames[at2.mmode]+' vs. '
  2547.                        ,rgs.pixels:5,rgs.lins:5,rgs.bytes:5
  2548.                        ,' '+mmodenames[rgs.mmode]+s);
  2549.             end;
  2550.           end;
  2551.       end;
  2552.       inc(fpos,hdr.lnn);
  2553.       seek(f,fpos);
  2554.     until hdr.typ>2;
  2555.     close(t);
  2556.     close(f);
  2557.   end;
  2558. end;
  2559.  
  2560.  
  2561. procedure testdacbits;
  2562. var
  2563.   dac0,dac1,dac2,dac3:byte;
  2564.   pt,ix,i,old:integer;
  2565.   s:string;
  2566. begin
  2567.   settextmode;
  2568.   write('Base register (hex): ');
  2569.   readln(s);
  2570.   pt:=dehex(s);
  2571.   write('Index (hex 0-FFh): ');
  2572.   readln(s);
  2573.   ix:=dehex(s);
  2574.   dac0:=inp($3C8);
  2575.   dac1:=inp($3C9);
  2576.   dac2:=inp($3C6);
  2577.   dac3:=inp($3C7);
  2578.   old:=rdinx(pt,Ix);
  2579.   writeln('Original: '+hex2(dac0)+' '+hex2(dac1)+' '+hex2(dac2)+' '+hex2(dac3));
  2580.   for i:=0 to 7 do
  2581.   begin
  2582.     wrinx(pt,Ix,old xor (1 shl i));
  2583.     dac0:=inp($3C8);
  2584.     dac1:=inp($3C9);
  2585.     dac2:=inp($3C6);
  2586.     dac3:=inp($3C7);
  2587.     wrinx(pt,Ix,old);
  2588.     writeln('  Bit  ',i,': '+hex2(dac0)+' '+hex2(dac1)+' '+hex2(dac2)+' '+hex2(dac3));
  2589.   end;
  2590.   if readkey='' then;
  2591. end;
  2592.  
  2593.  
  2594.  
  2595.  
  2596.  
  2597. var
  2598.   chp:byte;
  2599.   md,x,y,b:integer;
  2600.   s,fea:string;
  2601.   iteration,err,sel,clks:word;
  2602.   t:text;
  2603.   ok:boolean;
  2604.   devs:array[1..10] of string[80];
  2605.  
  2606.   rcfil:string;
  2607.   ignlist:string;  {Chips we ignore}
  2608.   PCIenable:boolean;
  2609.  
  2610. function mmode(s:string):integer;
  2611. var x:byte;
  2612. begin
  2613.   mmode:=__None;
  2614.   for x:=_text to _p32d do     {Remember to update}
  2615.     if s=strip(mmodenames[x]) then
  2616.       mmode:=x;
  2617. end;
  2618.  
  2619. function FindChp(s:string):integer;
  2620. var chp:integer;
  2621. begin
  2622.   FindChp:=__None;
  2623.   s:=strip(upstr(s));
  2624.   for chp:=__none to max_chip do
  2625.     if upstr(header[chp])=s then
  2626.       FindChp:=chp;
  2627. end;
  2628.  
  2629. procedure initcfg;  {Reset the configuration}
  2630. begin
  2631.   force_mm:=0;
  2632.   force_chip:=__none;
  2633.   force_version:=0;
  2634.   auto_test:=false;
  2635.   clocktest:=true;   {allow clock testing}
  2636.   debug:=false;
  2637.   PCIenable:=true;
  2638.   ignlist:='';
  2639.   fillchar(dotest,sizeof(dotest),ord(true));   {allow test for all chips}
  2640.   noumodes:=0;
  2641. end;
  2642.  
  2643. begin
  2644.   {$ifdef ver70}
  2645.     test8086:=1;    {force 286, 386 mode buggy}
  2646.   {$endif}
  2647.   initcfg;
  2648.  
  2649.   clrscr;
  2650.   assign(t,'whatvga.cfg');
  2651.   {$i-}
  2652.   reset(t);   {Check if the file exists}
  2653.   {$i+}
  2654.   if ioresult=0 then
  2655.   begin
  2656.     cv.chip:=__None;
  2657.     writeln('Configuration file found!');
  2658.     while not eof(t) do
  2659.     begin
  2660.       readln(t,s);
  2661.       if cv.chip=__None then    {Initial section}
  2662.       begin
  2663.         x:=pos('=',s);
  2664.         if x>0 then
  2665.         begin
  2666.           fea:=upstr(strip(copy(s,1,x-1)));  {keyword}
  2667.           s:=strip(copy(s,x+1,255));         {value}
  2668.           if (upstr(s)='YES') or (upstr(s)='ON') or
  2669.              (upstr(s)='Y') or (upstr(s)='1') then ok:=true
  2670.                                               else ok:=false;
  2671.           if fea='AUTOTEST'  then auto_test:=ok;
  2672.           if fea='CLOCKTEST' then clocktest:=ok;
  2673.           if fea='DEBUG'     then debug:=ok;
  2674.           if fea='PCITEST'   then PCIenable:=ok;
  2675.           if fea='MEMORY'    then val(s,force_mm,err);
  2676.           if fea='IGNORE'    then
  2677.           begin
  2678.             chp:=FindChp(upstr(s));
  2679.             if chp<>__None then
  2680.             begin
  2681.               dotest[chp]:=false;
  2682.               ignlist:=ignlist+' '+header[chp];
  2683.             end;
  2684.           end;
  2685.           if fea='CHIPSET'   then
  2686.           begin
  2687.             chp:=FindChp(upstr(s));
  2688.             fillchar(dotest,sizeof(dotest),ord(false));  {Disable all tests}
  2689.             if chp<>__None then
  2690.             begin
  2691.               dotest[chp]:=true;
  2692.               force_chip:=chp;
  2693.             end;
  2694.           end;
  2695.         end;
  2696.       end
  2697.       else
  2698.         if s[1]='-' then
  2699.         begin
  2700.           delete(s,1,1);
  2701.           md:=dehex(clipstr(s));
  2702.           inc(noumodes);
  2703.           usermodes[noumodes].md     :=md;
  2704.           usermodes[noumodes].memmode:=__None;  {Disable}
  2705.           usermodes[noumodes].flags  :=cv.chip;
  2706.         end
  2707.         else if s[1]='+' then
  2708.         begin
  2709.           delete(s,1,1);
  2710.           md:=dehex(clipstr(s));
  2711.           val(clipstr(s),x,err);
  2712.           val(clipstr(s),y,err);
  2713.           chp:=mmode(clipstr(s));
  2714.           val(clipstr(s),b,err);
  2715.           inc(noumodes);
  2716.           usermodes[noumodes].md     :=md;
  2717.           usermodes[noumodes].xres   :=x;
  2718.           usermodes[noumodes].yres   :=y;
  2719.           usermodes[noumodes].bytes  :=b;
  2720.           usermodes[noumodes].memmode:=chp;
  2721.           usermodes[noumodes].flags  :=cv.chip;
  2722.         end;
  2723.  
  2724.       if s[1]='[' then
  2725.         cv.chip:=FindChp(copy(s,2,pos(']',s)-2));
  2726.     end;
  2727.     close(t);
  2728.   end;
  2729.  
  2730.   rcfil:='';
  2731.   for x:=1 to paramcount do
  2732.   begin
  2733.     s:=upstr(paramstr(x))+'  ';
  2734.     case s[1] of
  2735.      '-':begin
  2736.            chp:=FindChp(copy(s,2,255));
  2737.            if chp<>__None then
  2738.            begin
  2739.              dotest[chp]:=false;
  2740.              ignlist:=ignlist+' '+header[chp];
  2741.            end;
  2742.          end;
  2743.      '+':begin
  2744.            chp:=FindChp(copy(s,2,255));
  2745.            fillchar(dotest,sizeof(dotest),ord(false));
  2746.            if chp<>__None then
  2747.            begin
  2748.              dotest[chp]:=true;
  2749.              force_chip:=chp;
  2750.            end;
  2751.          end;
  2752.      '=':val(strip(copy(s,2,255)),force_mm,err);
  2753.      '/':case upcase(s[2]) of
  2754.           'A':auto_test:=true;
  2755.           'C':clocktest:=false;
  2756.           'I':initcfg;
  2757.           'D':debug:=true;
  2758.           'T':rcfil:=strip(copy(s,3,255));
  2759.           'V':begin
  2760.                 val(strip(copy(s,3,255)),y,err);
  2761.                 if err=0 then force_version:=y;
  2762.               end;
  2763.           'P':PCIenable:=false;
  2764.          end;
  2765.     end;
  2766.   end;
  2767.  
  2768.   if rcfil<>'' then
  2769.   begin
  2770.     ReCalc(rcfil);
  2771.     halt(0);
  2772.   end;
  2773.  
  2774.   if (force_mm<>0) or (force_chip<>__none) or (force_version<>0)
  2775.      or (ignlist<>'') then
  2776.   begin
  2777.     if force_mm<>0 then writeln('Memory forced to: '+istr(force_mm)+'K');
  2778.     if force_chip<>__none then writeln('Chip forced to: '+header[force_chip]);
  2779.     if force_version<>0 then writeln('Chips version forced to: ',force_version);
  2780.     if ignlist<>'' then writeln('Chips to ignore:'+ignlist);
  2781.     writeln;
  2782.     writeln('Press a key to continue...');
  2783.     if readkey='' then;
  2784.     clrscr;
  2785.   end;
  2786.  
  2787.  
  2788.  
  2789.   if PCIenable then findPCI;
  2790.   findvideo;
  2791.   settextmode;
  2792.  
  2793.   for x:=1 to vids do
  2794.   begin
  2795.     SelectVideo(x);
  2796.     fea:='';
  2797.     if (cv.features and ft_cursor)>0 then fea:=' C';
  2798.     if (cv.features and ft_blit  )>0 then fea:=fea+' B';
  2799.     if (cv.features and ft_line  )>0 then fea:=fea+' L';
  2800.     if (cv.features and ft_rwbank)>0 then fea:=fea+' R';
  2801.     devs[x]:='  '+istr(x)+'  '+ljust(chipnam[cv.chip],9)
  2802.                +rjust(istr(cv.mm),8)+ljust(fea,8)+'  '+vid[x].name;
  2803.   end;
  2804.  
  2805.  
  2806.   iteration:=0;
  2807.   repeat
  2808.     stop:=false;
  2809.     if vids<>1 then
  2810.     begin
  2811.       SetTextMode;
  2812.       writeln(wrVersionNbr+copyright);
  2813.       writeln;
  2814.       writeln('Multiple Video Interfaces or Adapters found!!');
  2815.       writeln('Please select the one to test:');
  2816.       writeln('       Chip:    Memory:  Feat:  Name:');
  2817.       for x:=1 to vids do writeln(devs[x]);
  2818.       writeln;
  2819.       writeln(' 0  Stop');
  2820.       writeln;
  2821.       sel:=getkey-ord('0');
  2822.       if sel=0 then stop:=true;
  2823.     end
  2824.     else sel:=1;
  2825.     if (sel>0) and (sel<=vids) then SelectVideo(sel);
  2826.  
  2827.     while not stop do
  2828.     begin
  2829.       SetTextMode;
  2830.       writeln(wrVersionNbr+copyright);
  2831.       writeln;
  2832.  
  2833.       write('Video system: ',chipnam[cv.chip],' with '+istr(cv.mm)+' Kbytes');
  2834.       if cv.SubVers<>0 then write(' Version: '+hex4(cv.SubVers));
  2835.       writeln;
  2836.       if cv.name<>'' then writeln('Name: '+cv.name);
  2837.       writeln('Dac: '+cv.dacname);
  2838.       writeln('Clock: '+clkname[cv.clktype]);
  2839.       case cv.clktype of
  2840.         clk_ext2:clks:=4;
  2841.         clk_ext3:clks:=8;
  2842.         clk_ext4:clks:=16;
  2843.         clk_ext5:clks:=32;
  2844.         clk_ext6:clks:=64;
  2845.       else clks:=4;
  2846.       end;
  2847.       if clks>0 then
  2848.       begin
  2849.         for x:=0 to clks-1 do
  2850.         begin
  2851.           if (x and 7)=0 then
  2852.           begin
  2853.             if x>0 then writeln;
  2854.             write('      ');
  2855.           end;
  2856.           write(cv.clks[x]/1000:8:3);
  2857.         end;
  2858.         writeln;
  2859.       end;
  2860.  
  2861.       if cv.features<>0 then
  2862.       begin
  2863.         write('Special features:');
  2864.         if (cv.features and ft_cursor)<>0 then write(' Cursor');
  2865.         if (cv.features and ft_blit)<>0 then write(' BitBlt');
  2866.         if (cv.features and ft_line)<>0 then write(' Line');
  2867.         if (cv.features and ft_rwbank)<>0 then write(' RW-bank');
  2868.         writeln;
  2869.       end;
  2870.  
  2871.       writeln;
  2872.       if (cv.flags and FLG_StdVGA)>0 then
  2873.         writeln('     1  Test Standard VGA modes');
  2874.       writeln('     2  Test Extended modes');
  2875.       if (cv.chip<>__vesa) and (cv.chip<>__XBE) then
  2876.         writeln('     3  Search for video modes');
  2877.       if (cv.features and ft_cursor)<>0 then
  2878.         writeln('     5  HardWare Cursor test');
  2879.       if (cv.features and ft_blit)<>0 then
  2880.         writeln('     6  HardWare BitBLT test');
  2881.       if (cv.features and ft_line)<>0 then
  2882.         writeln('     7  Line Draw test');
  2883.       if (cv.features and ft_rwbank)<>0 then
  2884.         writeln('     8  R/W bank test');
  2885.  
  2886.       writeln;
  2887.       writeln('     B  Individual bit functionality');
  2888.       writeln('     D  DAC test submenu');
  2889.       writeln('     R  Read/Writable registers');
  2890.  
  2891.       writeln;
  2892.       writeln('     0  Stop');
  2893.       writeln;
  2894.  
  2895.       if auto_test then
  2896.       begin
  2897.         inc(iteration);
  2898.         pushkey(Ch_Cr);  {No Operation, just step on}
  2899.         case iteration of
  2900.           1:begin
  2901.               InitAFfile(sel);
  2902.               for x:=1 to vids do
  2903.               begin
  2904.                 AddAFbuf(vid[x],sizeof(vid[1]));
  2905.                 WrAFbuf(AF_videosys);
  2906.               end;
  2907.               if (cv.chip<>__vesa) and (cv.chip<>__XBE) then pushkey(ord('1'));
  2908.             end;
  2909.           2:pushkey(ord('2'));
  2910.           3:if (cv.features and ft_cursor)<>0 then pushkey(ord('5'));
  2911.           4:if (cv.features and ft_blit)<>0 then pushkey(ord('6'));
  2912.           5:if (cv.features and ft_line)<>0 then pushkey(ord('7'));
  2913.           6:if (cv.features and ft_rwbank)<>0 then pushkey(ord('8'));
  2914.           7:pushkey(ch_esc);
  2915.  
  2916.         end;
  2917.       end;
  2918.  
  2919.       case getkey of
  2920.              ord('1'):teststdvgamodes;
  2921.              ord('2'):testvgamodes;
  2922.              ord('3'):searchformodes;
  2923.              ord('5'):testcursor;
  2924.              ord('6'):testblit;
  2925.              ord('7'):testline;
  2926.              ord('8'):testrwbank;
  2927.              ord('9'):testzoom;
  2928.     ord('a'),ord('A'):auto_test:=true;
  2929.     ord('b'),ord('B'):testbits;
  2930.     ord('d'),ord('D'):testdac;
  2931.     ord('r'),ord('R'):testregs;
  2932.     ord('t'),ord('T'):testdacbits;
  2933.  
  2934.  
  2935.               ord('0'):stop:=true;
  2936.       Ch_Esc:begin
  2937.                stop:=true;
  2938.                sel:=0;
  2939.              end;
  2940.       end;
  2941.     end;
  2942.     if vids<=1 then sel:=0;
  2943.   until sel=0;
  2944.  
  2945.   SetTextMode;
  2946.   vio(3);     {Standard mode 3  80x25 text}
  2947.  
  2948.   if auto_test then
  2949.   begin
  2950.     wrAFff;
  2951.     close(af_fil);
  2952.     writeln;
  2953.     writeln('The test results are in the file: ',af_filename);
  2954.     writeln;
  2955.     writeln('For e-mail, modem etc the test file should be compressed');
  2956.     writeln('(ZIP, ARJ...) savings of >40% are not uncommon.');
  2957.     writeln;
  2958.     writeln('For Email transport, remember that the test file is BINARY.');
  2959.  
  2960.   end;
  2961. end.
  2962.