home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / idfi / idfi.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1990-03-21  |  1.9 KB  |  106 lines
  1. program idfi;
  2. uses opcrt,dos;
  3. const
  4.  hcrt=$3b4;
  5. type
  6.   vsystem=(MONO,HERC,CGA,EGA,VGA,MCGA,OTHER);
  7. const
  8.   sys_names : array[vsystem] of string[26]=
  9.    ('Mono Text','Hercules','Color Graphics','Extended Graphics',
  10.     'Video Graphics Array','Multi-Color Graphics','Don''t know');
  11. var
  12.   rr:registers;
  13.  
  14.  
  15. function find6845(addr:word):boolean; (* TRUE IF 6845 *)
  16. var
  17.  tmp:byte;
  18. begin
  19.   port[addr]:=$F;
  20.   tmp:=port[addr+1];
  21.   port[addr+1]:=$66;
  22.   delay(100);
  23.   find6845:=port[addr+1]=$66;
  24.   port[addr+1]:=tmp;
  25. end;
  26.  
  27. function findmono:vsystem;
  28. var
  29.  cnt:word;
  30.  tmp1,tmp2:byte;
  31. begin
  32.  if find6845(hcrt) then
  33.  begin
  34.    tmp1:=port[hcrt+6] and $80;
  35.    repeat
  36.      tmp2:=port[hcrt+6] and $80;
  37.    until tmp1<>tmp2;
  38.    if tmp1<>tmp2 then findmono:=HERC
  39.                  else findmono:=MONO;
  40.  end
  41.  else (*Not Mono *)
  42.    findmono:=OTHER;
  43. end;
  44.  
  45. function findCGA:vsystem;
  46. begin
  47.  if find6845($3D4) then findCGA:=CGA
  48.                    else findCGA:=OTHER;
  49. end;
  50.  
  51. function findEGA:vsystem;
  52. begin
  53.  rr.bx:=$0010;
  54.  rr.ax:=$1200;
  55.  intr($10,rr);
  56.  if lo(rr.bx)<>$10 then
  57.  begin
  58.   case lo(rr.cl) div 2 of
  59.     0,3:findEGA:=CGA;
  60.     1,4:findEGA:=EGA;
  61.     2,5:findEGA:=Herc;
  62.   end
  63.  end
  64.  else (*No ega *)
  65.    findEGA:=OTHER;
  66. end;
  67.  
  68. function findPS2:vsystem;
  69. begin
  70.  rr.ax:=$1A00;
  71.  intr($10,rr);
  72.  if lo(rr.ax)=$1A then
  73.  begin
  74.    case lo(rr.bx) of
  75.    0,3,6,9:findPS2:=other;
  76.          1:findPS2:=MONO;
  77.          2:findPS2:=CGA;
  78.       4,10:findPS2:=EGA;
  79.          5:findPS2:=HERC;
  80.        7,8:findPS2:=VGA;
  81.      11,12:findPS2:=MCGA;
  82.    end
  83.  end
  84.  else
  85.    findPS2:=OTHER;
  86. end;
  87.  
  88. function whatvsystem:vsystem;
  89. var
  90.  ts:vsystem;
  91. begin
  92.  ts:=findPS2;
  93.  if ts=other then
  94.     ts:=findEGA;
  95.  if ts=other then
  96.     ts:=findmono;
  97.  if ts=other then
  98.     ts:=findCGA;
  99.  whatvsystem:=ts;
  100. end;
  101.  
  102. begin
  103.  writeln('Video system is ',sys_names[whatvsystem]);
  104.  halt(ord(whatvsystem)+100);
  105. end.
  106.