Category : Pascal Source Code
Archive   : PAS_0693.ZIP
Filename : GRAPHPRC.PAS

{Ä Fido Pascal Conference ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ PASCAL Ä
Msg : 603 of 643
From : Sean Palmer 1:104/123.0 07 Jun 93 13:58
To : John Linden
Subj : Graphics
ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
JL>I use a plot command I wrote..

JL>1. How can I create an all-around procedure to draw lines . Horizontal and
JL>vertical are simple but what are diagonals?? Some code please...and
circles?

JL>2. How do you create a good fill procedure to fill a polygon with a color
JL>etc... ??? More code please..

There, that's the last time I post any of that stuff.

All this is tested.}

procedure rect(x,y,x2,y2:integer);var i:word;begin
hlin(x,pred(x2),y);hlin(succ(x),x2,y2);
vlin(x,succ(y),y2);vlin(x2,y,pred(y2));
end;

procedure pane(x,y,x2,y2:integer);var i:word;begin
for i:=y2 downto y do hlin(x,x2,i);
end;

procedure line(x,y,x2,y2:integer);var d,dx,dy,ai,bi,xi,yi:integer;begin
if(x if(y plot(x,y);
if dx>dy then begin ai:=(dy-dx)*2;bi:=dy*2; d:=bi-dx;
repeat
if(d>=0)then begin inc(y,yi);inc(d,ai);end else inc(d,bi);
inc(x,xi);plot(x,y);
until(x=x2);
end
else begin ai:=(dx-dy)*2;bi:=dx*2; d:=bi-dy;
repeat
if(d>=0)then begin inc(x,xi);inc(d,ai);end else inc(d,bi);
inc(y,yi);plot(x,y);
until(y=y2);
end;
end;

procedure oval(xc,yc,a,b:integer);var
x,y:integer;aa,aa2,bb,bb2,d,dx,dy:longint;begin x:=0;y:=b;
aa:=longint(a)*a;aa2:=2*aa; bb:=longint(b)*b;bb2:=2*bb; d:=bb-aa*b+aa div 4;
dx:=0;dy:=aa2*b; plot(xc,yc-y);plot(xc,yc+y);plot(xc-a,yc);plot(xc+a,yc);
while(dx if(d>0)then begin dec(y); dec(dy,aa2); dec(d,dy); end;
inc(x); inc(dx,bb2); inc(d,bb+dx);
plot(xc+x,yc+y); plot(xc-x,yc+y); plot(xc+x,yc-y); plot(xc-x,yc-y);
end;
inc(d,(3*(aa-bb)div 2-(dx+dy))div 2);
while(y>0)do begin
if(d<0)then begin inc(x); inc(dx,bb2); inc(d,bb+dx); end;
dec(y); dec(dy,aa2); inc(d,aa-dy);
plot(xc+x,yc+y); plot(xc-x,yc+y); plot(xc+x,yc-y); plot(xc-x,yc-y);
end;
end;

procedure disk(xc,yc,a,b:integer);var
x,y:integer;aa,aa2,bb,bb2,d,dx,dy:longint;begin x:=0;y:=b;
aa:=longint(a)*a;aa2:=2*aa; bb:=longint(b)*b;bb2:=2*bb; d:=bb-aa*b+aa div 4;
dx:=0;dy:=aa2*b; vLin(xc,yc-y,yc+y);
while(dx if(d>0)then begin dec(y); dec(dy,aa2); dec(d,dy); end;
inc(x); inc(dx,bb2); inc(d,bb+dx);
vLin(xc-x,yc-y,yc+y);vLin(xc+x,yc-y,yc+y);
end;
inc(d,(3*(aa-bb)div 2-(dx+dy))div 2);
while(y>=0)do begin
if(d<0)then begin
inc(x); inc(dx,bb2); inc(d,bb+dx);
vLin(xc-x,yc-y,yc+y);vLin(xc+x,yc-y,yc+y);
end;
dec(y); dec(dy,aa2); inc(d,aa-dy);
end;
end;

var fillVal:byte;
{This routine only called by fill}
function lineFill(x,y,d,prevXL,prevXR:integer):integer;var
xl,xr,i:integer;label _1,_2,_3;begin xl:=x;xr:=x;
repeat dec(xl); until(scrn(xl,y)<>fillVal)or(xl<0); inc(xl);
repeat inc(xr); until(scrn(xr,y)<>fillVal)or(xr>xMax); dec(xr);
hLin(xl,xr,y);
inc(y,d);
if word(y)<=yMax then
for x:=xl to xr do
if(scrn(x,y)=fillVal)then begin
x:=lineFill(x,y,d,xl,xr);
if word(x)>xr then goto _1;
end;
_1:dec(y,d+d); asm neg d;end;
if word(y)<=yMax then begin
for x:=xl to prevXL do
if(scrn(x,y)=fillVal)then begin
i:=lineFill(x,y,d,xl,xr);
if word(x)>prevXL then goto _2;
end;
_2:for x:=prevXR to xr do
if(scrn(x,y)=fillVal)then begin
i:=lineFill(x,y,d,xl,xr);
if word(x)>xr then goto _3;
end;
_3:end;
lineFill:=xr;
end;

procedure fill(x,y:integer);begin
fillVal:=scrn(x,y);if fillVal<>color then lineFill(x,y,1,x,x);
end;


const
tableReadIndex=$3C7;
tableWriteIndex=$3C8;
tableDataRegister=$3C9;

procedure setColor(color,r,g,b:byte);assembler;asm {set DAC color}
mov dx,tableWriteIndex; mov al,color; out dx,al; inc dx;
mov al,r; out dx,al; mov al,g; out dx,al; mov al,b;out dx,al;
end; {write index now points to next color}

function getColor(color:byte):longint;assembler;asm {get DAC color}
mov dx,tableReadIndex; mov al,color; out dx,al; add dx,2; cld;
xor bh,bh; in al,dx; mov bl,al; in al,dx; mov ah,al; in al,dx; mov dx,bx;
end; {read index now points to next color}

procedure setPalette(color:byte;num:word;var rgb);assembler;asm
mov cx,num; jcxz @X; mov ax,cx; shl cx,1; add cx,ax; {mul by 3}
push ds; lds si,rgb; cld;
mov dx,tableWriteIndex; mov al,color; out dx,al; inc dx;
@L: lodsb; out dx,al; loop @L; pop ds; @X:
end;

procedure getPalette(color:byte;num:word;var rgb);assembler;asm
mov cx,num; jcxz @X; mov ax,cx; shl cx,1; add cx,ax; {mul by 3}
les di,rgb; cld;
mov dx,tableReadIndex; mov al,color; out dx,al; add dx,2;
@L: in al,dx; stosb; loop @L; @X:
end;