home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PAS_0493.ZIP / X320X240.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-04-15  |  14.2 KB  |  432 lines
  1. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 120 of 150
  3. From : Sean Palmer                         1:104/123.0          08 Apr 93  15:37
  4. To   : All
  5. Subj : G:[1 of 2] X320x240 unit
  6. ────────────────────────────────────────────────────────────────────────────────}
  7. {by Sean Palmer, 1993}
  8. {released to the Public Domain}
  9. {$A-,B-,D+,E-,F-,G+,I-,L+,N-,O-,R-,S-,V-,X+} {TP 6.0 & 286 required!}
  10. unit x320x240;
  11.  
  12. {in tweaked modes, each latch/bit plane contains the entire 8-bit pixel.
  13.  the sequencer map mask determines which plane (pixel) to update, and, when
  14.  reading, the read map select reg determines which plane (pixel) to read.}
  15. {almost exactly opposite from regular vga 16-color modes which is why I never
  16.  could get my routines to work for BOTH modes. 8) }
  17.  
  18. { #=source screen pixel
  19.   Normal 16-color         Tweaked 256-color
  20.  
  21.       Bit Mask                Bit Mask
  22.       76543210                33333333
  23.  Map  76543210           Map  22222222
  24.  Mask 76543210           Mask 11111111
  25.       76543210                00000000
  26.  
  27.   Functional equivalents
  28.       Bit Mask        =       Seq Map Mask
  29.       Seq Map Mask    =       Bit Mask
  30. }
  31.  
  32.  
  33. interface
  34.  
  35. var
  36.  color:byte;
  37.  
  38. const
  39.  xRes=320; yRes=240;   {displayed screen size}
  40.  xMax=xRes-1; yMax=yRes-1;
  41.  xMid=xMax div 2; yMid=yMax div 2;
  42.  vxRes=512; vyRes=$40000 div vxRes; {virtual screen size}
  43.  nColors=256;
  44.  tsx:byte=8; tsy:byte=8;  {tile size}
  45.  
  46. procedure plot(x,y:integer);
  47. function  scrn(x,y:integer):byte;
  48.  
  49. procedure hLin(x,x2,y:integer);
  50. procedure vLin(x,y,y2:integer);
  51. procedure rect(x,y,x2,y2:integer);
  52. procedure pane(x,y,x2,y2:integer);
  53.  
  54. procedure line(x,y,x2,y2:integer);
  55. procedure oval(xc,yc,a,b:integer);
  56. procedure disk(xc,yc,a,b:integer);
  57. procedure fill(x,y:integer);
  58.  
  59. procedure putTile(x,y:integer;p:pointer);
  60. procedure overTile(x,y:integer;p:pointer);
  61. procedure putChar(x,y:integer;p:word);
  62.  
  63. procedure setColor(color,r,g,b:byte); {rgb vals are from 0-63}
  64. function  getColor(color:byte):longint; {returns $00rrggbb format}
  65. procedure setPalette(color:byte;num:word;var rgb); {rgb is list of 3-byte rgb
  66. vals}
  67. procedure getPalette(color:byte;num:word;var rgb);
  68.  
  69. procedure clearGraph;
  70. procedure setWriteMode(f:byte);
  71. procedure waitRetrace;
  72. procedure setWindow(x,y:integer);
  73.  
  74. {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
  75.  
  76. implementation
  77.  
  78. const
  79.  vSeg=$A000;           {video segment}
  80.  vxBytes=vxRes div 4;  {bytes per virtual scan line}
  81.  
  82. var
  83.  crtcPort:word;  {crt controller}
  84. const
  85.  seqPort=$3C4;   {Sequencer}
  86.  gcPort=$3CE;    {Graphics Controller}
  87. type
  88.  tRGB=record r,g,b:byte;end;
  89.  
  90. var
  91.  oldMode:byte;
  92.  exitSave:pointer;
  93.  
  94. {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
  95.  
  96. procedure clearGraph;assembler;asm
  97.  mov ax,vSeg; mov es,ax; mov dx,seqPort;
  98.  mov ax,$0F02; out dx,ax; {enable whole map mask}
  99.  xor di,di; mov cx,$8000; {screen size in words}
  100.  cld; mov al,color; mov ah,al; repz stosw; {clear screen}
  101.  end;
  102.  
  103. procedure setWriteMode(f:byte);assembler;asm {copy/and/or/xor modes}
  104.  mov ah,f; shl ah,3; mov al,3; mov dx,gcPort; out dx,ax; {function select reg}
  105.  end;
  106.  
  107. procedure waitRetrace;assembler;asm
  108.  mov dx,crtcPort; add dx,6; {find crt status reg (input port #1)}
  109. @L1: in al,dx; test al,8; jnz @L1;  {wait for no v retrace}
  110. @L2: in al,dx; test al,8; jz @L2; {wait for v retrace}
  111.  end;
  112.  
  113. const
  114.  attrPort=$3C0;   {attribute Controller}
  115. var
  116.  input1Port:word;  {crtc Input Status Reg #1=crtcPort+6}
  117.  
  118. {Since a virtual screen can be larger than the actual screen, scrolling is
  119.  possible.  This routine sets the upper left corner of the screen to the
  120.  specified pixel.}
  121. {make sure 0<=x<=vxRes-xRes, 0<=y<=vyRes-yRes}
  122. procedure setWindow(x,y:integer);assembler;asm
  123.  mov ax,vxBytes; mul y; mov bx,x; mov cl,bl;
  124.  shr bx,2; add bx,ax;     {bx=Ofs of upper left corner}
  125.  mov dx,input1Port; @L: in al,dx; test al,8; jnz @L;  {wait for no v retrace}
  126.  sub dx,6;  {CRTC port}
  127.  mov al,$D; mov ah,bl; cli; {these values are sampled at start of retrace}
  128.  out dx,ax;  {lo byte of display start addr}
  129.  dec al; mov ah,bh; out dx,ax;    {hi byte}
  130.  sti;
  131.  add dx,6; @L2: in al,dx; test al,8; jz @L2;  {wait for v retrace}
  132.   {this also resets Attrib flip/flop}
  133.  mov dx,attrPort; mov al,$33; out dx,al;   {Select Pixel Pan Register}
  134.  and cl,3; mov al,cl; shl al,1; out dx,al;   {Shift is for 256 Color Mode}
  135.  end;
  136.  
  137. {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
  138.  
  139. procedure plot(x,y:integer);assembler;asm
  140.  mov ax,vSeg; mov es,ax;
  141.  mov di,x; mov cx,di; shr di,2;
  142.  mov ax,vxBytes; mul y; add di,ax;
  143.  mov ax,$0102; and cl,3; shl ah,cl;
  144.  mov dx,seqPort; out dx,ax; {set bit mask}
  145.  mov al,color; stosb;
  146.  end;
  147.  
  148. function scrn(x,y:integer):byte;assembler;asm
  149.  mov ax,vSeg; mov es,ax;
  150.  mov di,x; mov cx,di; shr di,2;
  151.  mov ax,vxBytes; mul y; add di,ax;
  152.  and cl,3; mov ah,cl; mov al,4;
  153.  mov dx,gcPort; out dx,ax;      {Read Map Select register}
  154.  mov al,es:[di];  {get the whole plane}
  155.  end;
  156.  
  157. procedure hLin(x,x2,y:integer);assembler;asm
  158.  mov ax,vSeg; mov es,ax; cld;
  159.  mov ax,vxBytes; mul y; mov di,ax; {base of scan line}
  160.  mov bx,x;  mov cl,bl; shr bx,2;
  161.  mov dx,x2; mov ch,dl; shr dx,2;
  162.  and cx,$0303;
  163.  sub dx,bx;     {width in bytes}
  164.  add di,bx;     {offset into video buffer}
  165.  mov ax,$FF02; shl ah,cl; and ah,$0F; {left edge mask}
  166.  mov cl,ch;
  167.  mov bh,$F1; rol bh,cl; and bh,$0F; {right edge mask}
  168.  mov cx,dx; or cx,cx; jnz @LEFT;
  169.  and ah,bh;                  {combine left & right bitmasks}
  170. @LEFT:
  171.  mov dx,seqPort; out dx,ax; inc dx;
  172.  mov al,color; stosb;
  173.  jcxz @EXIT; dec cx; jcxz @RIGHT;
  174.  mov al,$0F; out dx,al;     {skipped if cx=0,1}
  175.  mov al,color; repz stosb;   {fill middle bytes}
  176. @RIGHT:
  177.  mov al,bh; out dx,al;       {skipped if cx=0}
  178.  mov al,color; stosb;
  179. @EXIT:
  180.  end;
  181.  
  182. procedure vLin(x,y,y2:integer);assembler;asm
  183.  mov ax,vSeg; mov es,ax; cld;
  184.  mov di,x; mov cx,di; shr di,2;
  185.  mov ax,vxBytes; mul y; add di,ax;
  186.  mov ax,$102; and cl,3; shl ah,cl; mov dx,seqPort;out dx,ax;
  187.  mov cx,y2; sub cx,y; inc cx; mov al,color;
  188. @DOLINE: mov bl,es:[di]; stosb; add di,vxBytes-1; loop @DOLINE;
  189.  end;
  190.  
  191. procedure rect(x,y,x2,y2:integer);var i:word;begin
  192.  hlin(x,pred(x2),y);hlin(succ(x),x2,y2);vlin(x,succ(y),y2);vlin(x2,y,pred(y2));
  193.  end;
  194.  
  195. procedure pane(x,y,x2,y2:integer);var i:word;begin
  196.  for i:=y2 downto y do hlin(x,x2,i);
  197.  end;
  198.  
  199. procedure line(x,y,x2,y2:integer);var d,dx,dy,ai,bi,xi,yi:integer;begin
  200.  if(x<x2)then begin xi:=1;dx:=x2-x;end else begin xi:=-1;dx:=x-x2;end;
  201.  if(y<y2)then begin yi:=1;dy:=y2-y;end else begin yi:=-1;dy:=y-y2;end;
  202.  plot(x,y);
  203.  if dx>dy then begin ai:=(dy-dx)*2;bi:=dy*2; d:=bi-dx;
  204.   repeat
  205.    if(d>=0)then begin inc(y,yi);inc(d,ai);end else inc(d,bi);
  206.    inc(x,xi);plot(x,y);
  207.    until(x=x2);
  208.   end
  209.  else begin ai:=(dx-dy)*2;bi:=dx*2; d:=bi-dy;
  210.   repeat
  211.    if(d>=0)then begin inc(x,xi);inc(d,ai);end else inc(d,bi);
  212.    inc(y,yi);plot(x,y);
  213.    until(y=y2);
  214.   end;
  215.  end;
  216.  
  217. procedure oval(xc,yc,a,b:integer);var
  218. x,y:integer;aa,aa2,bb,bb2,d,dx,dy:longint;begin
  219.  x:=0;y:=b; aa:=longint(a)*a;aa2:=2*aa; bb:=longint(b)*b;bb2:=2*bb;
  220.  d:=bb-aa*b+aa div 4; dx:=0;dy:=aa2*b;
  221.  plot(xc,yc-y);plot(xc,yc+y);plot(xc-a,yc);plot(xc+a,yc);
  222.  while(dx<dy)do begin
  223.   if(d>0)then begin dec(y); dec(dy,aa2); dec(d,dy); end;
  224.   inc(x); inc(dx,bb2); inc(d,bb+dx);
  225.   plot(xc+x,yc+y); plot(xc-x,yc+y); plot(xc+x,yc-y); plot(xc-x,yc-y);
  226.   end;
  227.  inc(d,(3*(aa-bb)div 2-(dx+dy))div 2);
  228.  while(y>0)do begin
  229.   if(d<0)then begin inc(x); inc(dx,bb2); inc(d,bb+dx); end;
  230.   dec(y); dec(dy,aa2); inc(d,aa-dy);
  231.   plot(xc+x,yc+y); plot(xc-x,yc+y); plot(xc+x,yc-y); plot(xc-x,yc-y);
  232.   end;
  233.  end;
  234.  
  235. procedure disk(xc,yc,a,b:integer);var
  236. x,y:integer;aa,aa2,bb,bb2,d,dx,dy:longint;begin
  237.  x:=0;y:=b; aa:=longint(a)*a;aa2:=2*aa; bb:=longint(b)*b;bb2:=2*bb;
  238.  d:=bb-aa*b+aa div 4; dx:=0;dy:=aa2*b;
  239.  vLin(xc,yc-y,yc+y);
  240.  while(dx<dy)do begin
  241.   if(d>0)then begin dec(y); dec(dy,aa2); dec(d,dy); end;
  242.   inc(x); inc(dx,bb2); inc(d,bb+dx);
  243.   vLin(xc-x,yc-y,yc+y);vLin(xc+x,yc-y,yc+y);
  244.   end;
  245.  inc(d,(3*(aa-bb)div 2-(dx+dy))div 2);
  246.  while(y>=0)do begin
  247.   if(d<0)then begin
  248.    inc(x); inc(dx,bb2); inc(d,bb+dx);
  249.    vLin(xc-x,yc-y,yc+y);vLin(xc+x,yc-y,yc+y);
  250.    end;
  251.   dec(y); dec(dy,aa2); inc(d,aa-dy);
  252.   end;
  253.  end;
  254.  
  255. var fillVal:byte;
  256. {This routine only called by fill}
  257. function lineFill(x,y,d,prevXL,prevXR:integer):integer;var
  258. xl,xr,i:integer;label _1,_2,_3;begin
  259.  xl:=x;xr:=x;
  260.  repeat dec(xl); until(scrn(xl,y)<>fillVal)or(xl<0); inc(xl);
  261.  repeat inc(xr); until(scrn(xr,y)<>fillVal)or(xr>xMax); dec(xr);
  262.  hLin(xl,xr,y);
  263.  inc(y,d);
  264.  if word(y)<=yMax then
  265.   for x:=xl to xr do
  266.    if(scrn(x,y)=fillVal)then begin
  267.     x:=lineFill(x,y,d,xl,xr);
  268.     if word(x)>xr then goto _1;
  269.     end;
  270. _1:dec(y,d+d); asm neg d;end;
  271.  if word(y)<=yMax then begin
  272.   for x:=xl to prevXL do
  273.    if(scrn(x,y)=fillVal)then begin
  274.     i:=lineFill(x,y,d,xl,xr);
  275.     if word(x)>prevXL then goto _2;
  276.     end;
  277. _2:for x:=prevXR to xr do
  278.    if(scrn(x,y)=fillVal)then begin
  279.     i:=lineFill(x,y,d,xl,xr);
  280.     if word(x)>xr then goto _3;
  281.     end;
  282. _3:end;
  283.  lineFill:=xr;
  284.  end;
  285.  
  286. procedure fill(x,y:integer);begin
  287.  fillVal:=scrn(x,y);if fillVal<>color then lineFill(x,y,1,x,x);
  288.  end;
  289.  
  290.  
  291. {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
  292.  
  293. procedure putTile(x,y:integer;p:pointer);assembler;asm
  294.  push ds; lds si,p;
  295.  mov ax,vSeg; mov es,ax;
  296.  mov di,x; mov cx,di; shr di,2;
  297.  mov ax,vxBytes; mul y; add di,ax;
  298.  mov ax,$102; and cl,3; shl ah,cl;      {make bit mask}
  299.  mov dx,seqPort; mov bh,tsy;
  300. @DOLINE: mov cl,tsx; xor ch,ch; push ax; push di;    {save starting bit mask}
  301. @LOOP: {mov al,2;} out dx,ax;
  302.  shl ah,1;       {give it some time to respond}
  303.  mov bl,es:[di]; movsb; dec di;
  304.  test ah,$10; jz @SAMEBYTE; mov ah,1; inc di; @SAMEBYTE:
  305.  loop @LOOP;
  306.  pop di; add di,vxBytes; pop ax; {start of next line}
  307.  dec bh; jnz @DOLINE;
  308.  pop ds;
  309.  end;
  310.  
  311. procedure overTile(x,y:integer;p:pointer);assembler;asm
  312.  push ds; lds si,p;
  313.  mov ax,vSeg; mov es,ax;
  314.  mov di,x; mov cx,di; shr di,2;
  315.  mov ax,vxBytes; mul y; add di,ax;
  316.  mov ax,$102; and cl,3; shl ah,cl;      {make bit mask}
  317.  mov bh,tsy; mov dx,seqPort;
  318. @DOLINE: mov ch,tsx; push ax; push di;    {save starting bit mask}
  319. @LOOP: mov al,2; mov dx,seqPort; out dx,ax; shl ah,1;
  320.  xchg ah,cl; mov al,4; mov dl,gcPort and $FF; out dx,ax; xchg ah,cl; inc cl;
  321. and cl,3;
  322.  lodsb; or al,al; jz @SKIP;
  323.  mov bl,es:[di]; cmp bl,$C0; jae @SKIP; stosb; dec di; @SKIP:
  324.  test ah,$10; jz @SAMEBYTE; mov ah,1; inc di; @SAMEBYTE:
  325.  dec ch; jnz @LOOP;
  326.  pop di; add di,vxBytes; pop ax; {start of next line}
  327.  dec bh; jnz @DOLINE;
  328.  pop ds;
  329.  end;
  330.  
  331. {won't handle chars wider than 1 byte}
  332. procedure putChar(x,y:integer;p:word);assembler;asm
  333.  mov si,p;  {offset of char in DS}
  334.  mov ax,vSeg; mov es,ax;
  335.  mov di,x; mov cx,di; shr di,2;
  336.  mov ax,vxBytes; mul y; add di,ax;
  337.  mov ax,$0102; and cl,3; shl ah,cl;      {make bit mask}
  338.  mov dx,seqPort; mov cl,tsy; xor ch,ch;
  339. @DOLINE: mov bl,[si]; inc si; push ax; push di;    {save starting bit mask}
  340. @LOOP: mov al,2; out dx,ax; shl ah,1;
  341.  shl bl,1; jnc @SKIP; mov al,color; mov es:[di],al; @SKIP:
  342.  test ah,$10; jz @SAMEBYTE; mov ah,1; inc di; @SAMEBYTE:
  343.  or bl,bl; jnz @LOOP;
  344.  pop di; add di,vxBytes; pop ax; {start of next line}
  345.  loop @DOLINE;
  346.  end;
  347.  
  348. {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
  349.  
  350. const
  351.  tableReadIndex=$3C7;
  352.  tableWriteIndex=$3C8;
  353.  tableDataRegister=$3C9;
  354.  
  355. procedure setColor(color,r,g,b:byte);assembler;asm {set DAC color}
  356.  mov dx,tableWriteIndex; mov al,color; out dx,al; inc dx;
  357.  mov al,r; out dx,al; mov al,g; out dx,al; mov al,b;out dx,al;
  358.  end; {write index now points to next color}
  359.  
  360. function getColor(color:byte):longint;assembler;asm {get DAC color}
  361.  mov dx,tableReadIndex; mov al,color; out dx,al; add dx,2; cld;
  362.  xor bh,bh; in al,dx; mov bl,al; in al,dx; mov ah,al; in al,dx; mov dx,bx;
  363.  end; {read index now points to next color}
  364.  
  365. procedure setPalette(color:byte;num:word;var rgb);assembler;asm
  366.  mov cx,num; jcxz @X; mov ax,cx; shl cx,1; add cx,ax; {mul by 3}
  367.  push ds; lds si,rgb; cld;
  368.  mov dx,tableWriteIndex; mov al,color; out dx,al; inc dx;
  369. @L: lodsb; out dx,al; loop @L; pop ds; @X:
  370.  end;
  371.  
  372. procedure getPalette(color:byte;num:word;var rgb);assembler;asm
  373.  mov cx,num; jcxz @X; mov ax,cx; shl cx,1; add cx,ax; {mul by 3}
  374.  les di,rgb; cld;
  375.  mov dx,tableReadIndex; mov al,color; out dx,al; add dx,2;
  376. @L: in al,dx; stosb; loop @L; @X:
  377.  end;
  378.  
  379. {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
  380.  
  381. function vgaPresent:boolean;assembler;asm
  382.  mov ah,$F; int $10; mov oldMode,al;  {save old Gr mode}
  383.  mov ax,$1A00; int $10;    {check for VGA}
  384.  cmp al,$1A; jne @ERR;     {no VGA Bios}
  385.  cmp bl,7; jb @ERR;        {is VGA or better?}
  386.  cmp bl,$FF; jnz @OK;
  387. @ERR: xor al,al; jmp @EXIT;
  388. @OK: mov al,1;
  389. @EXIT:
  390.  end;
  391.  
  392. const
  393.  crtcRegLen=10;
  394.  crtcRegTable:array[1..crtcRegLen]of word=
  395.   ($0D06,$3E07,$4109,$EA10,$AC11,$DF12,$0014,$E715,$0616,$E317);
  396.  
  397. procedure graphBegin;var p:array[0..255]of tRGB; i,j,k,l:byte;begin
  398.  asm mov ax,$0013; int $10;end;   {set BIOS mode}
  399.  l:=0;
  400.  for i:=0 to 5 do for j:=0 to 5 do for k:=0 to 5 do
  401.   with p[l] do begin r:=(i*63)div 5;g:=(j*63)div 5;b:=(k*63)div 5;inc(l);end;
  402.  for i:=216 to 255 do with p[i] do begin l:=((i-216)*63)div
  403. 39;r:=l;g:=l;b:=l;end;
  404.  setpalette(0,256,p); color:=0;
  405.  asm
  406.   mov dx,seqPort; mov ax,$0604; out dx,ax; {disable chain 4}
  407.   mov ax,$0100; out dx,ax; {synchronous reset asserted}
  408.   dec dx; dec dx; mov al,$E3; out dx,al;   {misc output port at $3C2}
  409.  {use 25mHz dot clock, 480 lines}
  410.   inc dx; inc dx; mov ax,$0300; out dx,ax; {restart sequencer}
  411.   mov dx,crtcPort; mov al,$11; out dx,al;    {select cr11}
  412.   inc dx; in al,dx; and al,$7F; out dx,al; dec dx; {remove write protect from
  413. cr0-cr7}
  414.   mov si,offset crtcRegTable; mov cx,crtcRegLen;
  415.   repz outsw;      {set crtc data}
  416.   mov ax,vxBytes; shr ax,1;  {words per scan line}
  417.   mov ah,al; mov al,$13; out dx,ax; {set CRTC offset reg}
  418.   end;
  419.  clearGraph;
  420.  end;
  421.  
  422. procedure graphEnd;far;begin
  423.  exitProc:=exitSave;
  424.  asm mov al,oldMode; mov ah,0; int $10; end;
  425.  end;
  426.  
  427. begin
  428.  crtcPort:=memw[$40:$63]; input1Port:=crtcPort+6;
  429.  if vgaPresent then begin exitSave:=exitProc; exitProc:=@graphEnd; graphBegin; 
  430. end
  431.  else begin writeln(^G+'VGA required.');halt(1); end;
  432.  end.