Rekurzió
Ezen a lapon néhány példát láthaunk rekurzióra. Van közöttük
matematikai, de főleg geometriaira találunk példákat. (Van egy iteráció is, a
Cos(x)=x egyenlet megoldása.) A rekurzió olyan
eljárás, amely a végrehajtás során újra és újra önmagát hívja, viszont a
leállításról valamely állapot – legtöbb esetben egy változó értékének figyelése
szükséges.
Ime a példák:
Program Binomial;
Uses
Crt, CrtPlus;
Var
i,j: Byte;
Function binom (n,k :integer): integer;
begin
if
(k=0) or (k=n) then binom:=1
else
binom:=binom(n-1,k-1)
+ binom(n-1,k);
end;
Begin
TextMode(CO80);
Szinek(1,15);
ClrScr;
WriteXY(34,1,'A
Pascal háromszög...');
VVonal(34,52,2);
Gotoxy(1,5);
For
i:=0 to 12 do
Begin
gotoxy(40-3*i,WhereY);
For
j:=0 to i do Write(binom(i,j):3,' ');
WriteLn;
End;
WriteXY(20,20,'...
amely a binomi lis együtthatókat tartalmazza.');
Tunj;
Varj;
End.
**************************************************************
Program Burkolo;
Uses
NewDelay,Crt, CrtPlus, Graph;
Const max=25;
Var
Pontok, Mp: Array[1..max+1,
1..3] Of Longint;
ms: Integer;
ss: array[1..max+1] of Real;
Procedure GrInit;
Var
Gd, Gm: Integer;
Begin
DetectGraph(Gd, Gm);
InitGraph(Gd, Gm,
'c:\bp\bgi');
End;
Procedure Feltolt;
Var
i: Byte;
Begin
Randomize;
For
i:=1 to max do
Begin
Pontok[i,1]:=
Random(640); Pontok[i,2]:= Random(480);
Pontok[i,3]:=1;
End;
End;
Function BentVan(x1,y1, x2,y2, x3,y3, x4,y4:
Integer): Boolean;
Function
Ter(x1,y1, x2,y2, x3,y3:Real):Real;
Begin
Ter:=abs((x2*y3+x3*y1+x1*y2-x2*y1-x3*y2-x1*y3)/2);
End;
Begin
BentVan:= Ter(x1,y1,x2,y2,x4,y4)+
Ter(x2,y2,x3,y3,x4,y4)+
Ter(x3,y3,x1,y1,x4,y4)=
Ter(x1,y1,x2,y2,x3,y3);
End;
Procedure Kirak;
Var
i:byte;
Begin
ClearDevice;
For
i:=1 to max do If Pontok[i,3]=1
Then
PutPixel(Pontok[i,1],Pontok[i,2],15)
Else
PutPixel(Pontok[i,1],Pontok[i,2],9);
End;
Procedure Kidob;
Var
i,j,k,l: Byte;
Begin
For
i:=1 to max do for j:=1 to max do For k:=1 to max do For l:=1 to max do
If
(i<>j) And
(i<>k) And (i<>l) And (j<>k) And (j<>l) And
(k<>l) Then
If
Pontok[i,3]+Pontok[j,3]+Pontok[k,3]+Pontok[l,3]=4 Then
Begin
If
BentVan(Pontok[i,1],Pontok[i,2],Pontok[j,1],Pontok[j,2],
Pontok[k,1],Pontok[k,2],Pontok[l,1],Pontok[l,2])
Then
Begin
Pontok[l,3]:=0;
PutPixel(Pontok[l,1],Pontok[l,2],9);
End;
End;
End;
Procedure Rajzol;
Var
i, j, ax, ay, fx, fy, kx, ky: integer;
c: Real;
Begin
Kirak;
j:=0;
For
i:=1 To max do If Pontok[i,3]=1
Then Begin Inc(j); Mp[j]:=Pontok[i] End;
ms:= j;
ax:= GetMaxX; For i:=1 To ms Do If
Mp[i,1]<ax Then
ax:= Mp[i,1];
ay:= GetMaxY; For i:=1 To ms Do If
Mp[i,2]<ay Then
ay:= Mp[i,2];
fx:= 0;
For i:=1 To ms Do If Mp[i,1]>fx
Then fx:= Mp[i,1];
fy:= 0;
For i:=1 To ms Do If Mp[i,2]>fy
Then fy:= Mp[i,2];
kx:= (ax+fx) Div 2; ky:= (ay+fy) Div 2;
For
i:=1 To ms Do
Begin
c:=(ky-Mp[i,2])/Sqrt(Sqr(Mp[i,1]-kx)+Sqr(Mp[i,2]-ky));
If
(Mp[i,1]-kx>=0) And (Mp[i,2]-ky<0) Then
ss[i]:=c Else
If
Mp[i,1]-kx<0 Then
ss[i]:=2-c Else
If
(Mp[i,1]-kx>=0) And (Mp[i,2]-ky>=0) Then
ss[i]:=4+c;
End;
For
i:=1 To ms-1 Do For j:=i To ms do
If
ss[i]>ss[j] Then
Begin
ss[ms+1]:=ss[i];
ss[i]:=ss[j];
ss[j]:=ss[ms+1];
Mp[ms+1]:=Mp[i];
Mp[i]:=Mp[j];
Mp[j]:=Mp[ms+1];
End;
Moveto(Mp[1,1],Mp[1,2]);
For
i:=2 To ms do Lineto(Mp[i,1],Mp[i,2]);
Lineto(Mp[1,1],Mp[1,2]);
End;
Begin
GrInit;
Feltolt;
Kirak;
Kidob;
Rajzol;
Varj;
End.
**************************************************************
Program egyenlet; {az x=cos(x) egyenlet
megoldása iterációval}
Uses
Crt, CrtPlus;
Var
x: real;
Begin
szinek(1,15);ClrScr;
While
x<>Cos(x) do
x:=Cos(x); Writeln(x:12:10);
Tunj; Varj;
End.
**************************************************************
program fa;
uses
NewDelay, graph,crt;
const dfi1=25*pi/180;
dfi2=-25*pi/180;
c1=0.8;
c2=0.8;
minhossz=5;
var gd,gm:integer;
procedure ag(irany,hossz,x0,y0:real);
var x1,y1:real;
begin
x1:=x0+hossz*cos(irany);
y1:=y0+hossz*sin(irany);
line(round(x0),getmaxy-round(y0),round(x1),getmaxy-round(y1));
if
hossz>minhossz then
begin
ag(irany+dfi1,hossz*c1,x1,y1);
ag(irany+dfi2,hossz*c2,x1,y1);
end;
end;
begin
gd:=detect;
initgraph(gd,gm,'c:\bp\bgi');
ag(pi/2,100,getmaxx
div 2,0);
repeat
until keypressed;
closegraph;
end.
**************************************************************
Program Faktor;
Uses
Crt, CrtPlus;
Var
i: Byte;
Function Faktorialis(k: Byte): Longint;
Begin
If
k>0 Then
Faktorialis:=k*Faktorialis(k-1) Else
Faktorialis:=1
End;
Begin
TextMode(CO80);
Szinek(1,15);
ClrScr;
For
i:=0 to 13 do
WriteLn(i:2,'! = ',Faktorialis(i));
Tunj;
Varj;
End.
**************************************************************
Program Fibonacc;
Uses
Crt, CrtPlus;
Var
i: Byte;
Function Fib(n: Byte): Longint;
Begin
If
n<=0 Then
Begin Fib:=0; Exit End;
If
n=1 Then Begin Fib:=1; Exit End;
Fib:= Fib(n-1) +
Fib(n-2);
End;
Begin
Szinek(1,15);
ClrScr;
For
i:=1 To 24 Do WriteLn(i:2,': ',Fib(i));
Tunj;
Varj;
End.
**************************************************************
Program Fillezo;
Uses
Crt, CrtPlus, Graph;
Var
xa, ya, xf, yf: Word;
Procedure GrInit;
Var
Gd, Gm: Integer;
Begin
DetectGraph(Gd, Gm);
InitGraph(Gd, Gm,
'c:\Bp\Bgi');
End;
Procedure Fill1(hc,fc:word);
Var
i, j: Word;
Fest, Elozo: Boolean;
Begin
For
i:= 0 To GetMaxX Do For
j:= 0 To GetMaxY Do If
GetPixel(i,j)=hc Then
Begin
xa:=i; i:= GetMaxX; j:= GetMaxY End;
For
i:= GetMaxX DownTo 0 Do For
j:= GetMaxY DownTo 0 Do If
GetPixel(i,j)=hc Then
Begin
xf:=i; i:= 0; j:= 0 End;
For
j:= 0 To GetMaxY Do For
i:=0 To GetMaxY Do If GetPixel(i,j)=hc
Then
Begin
ya:=j; j:=GetMaxY; i:=GetMaxX End;
For
j:= GetMaxY Downto 0 Do For
i:= GetMaxX Downto 0 Do If
GetPixel(i,j)=hc Then
Begin
yf:= j; j:=0; i:=0 End;
Dec(xa); Dec(ya);
Inc(xf); Inc(yf);
Fest:= False;
For
j:=ya To yf Do
Begin
For
i:=xa To xf Do
Begin
If
Not Elozo And (GetPixel(i,j)=hc)Then Fest:= Not Fest;
Elozo:= GetPixel(i,j)=hc;
If
Fest Then PutPixel(i,j,fc);
End;
Fest:= False;
End;
End;
Procedure Fill(x, y, hc, fc: Word);
Var
i, j, pk, pv: Word;
Begin
j:= y; i:=x;
While
GetPixel(i,j)<>hc do
Begin
i:=x; While
GetPixel(i,j)<>hc do Begin
PutPixel(i,j,fc); Dec(i) End;
pk:= i;
i:=x; While
GetPixel(i,j)<>hc do Begin
PutPixel(i,j,fc); Inc(i) End;
pv:= i;
i:=x; Inc(j);
End;
If
(pk<pv) And
(GetPixel(Round((pk+pv)/2),j)<>hc) Then
Fill(round((pk+pv)/2),j,hc,fc);
j:= y; i:=x;
While
GetPixel(i,j)<>hc do
Begin
i:=x; While
GetPixel(i,j)<>hc do Begin
PutPixel(i,j,fc); Dec(i) End;
pk:=i;
i:=x; While
GetPixel(i,j)<>hc do Begin
PutPixel(i,j,fc); Inc(i) End;
pv:=i;
i:=x; dec(j);
End;
If
(pk<pv) And
(GetPixel(Round((pk+pv)/2),j)<>hc) Then
Fill(round((pk+pv)/2),j,hc,fc);
End;
Begin
GrInit;
SetColor(15);
{ Circle(120,240,60);}
Circle(400,240,30);
Moveto(190,320);
LineTo(450,300);
Lineto(440,90);
Lineto(320,200);
Lineto(200,100);
Lineto(190,320);
Fill(320,250,15,14);
Varj;
End.
**************************************************************
program Frakt;
uses
NewDelay,crt,graph;
const x_el=-300;
y_el=0;
nagyitas=60;
elemek_szama_max=32;
type
matrix=array [0..1,0..1]
of real;
vektor=array [0..1] of real;
ifs_elem=record
szorzo:matrix;
plusz:vektor;
p:real;
end;
ifs_fractal=record
elemek:array [0..elemek_szama_max-1] of
ifs_elem;
elemek_szama:byte;
end;
var x,y:real;
fractal:ifs_fractal;
procedure init;
var gd,gm:integer;
procedure
ifs_feltolt(x1,y1,x2,y2,ax,ay,dp:real);
begin
with
fractal do
begin
with
elemek[elemek_szama] do
begin
szorzo[0,0]:=x1;szorzo[0,1]:=y1;
szorzo[1,0]:=x2;szorzo[1,1]:=y2;
plusz[0]:=ax;
plusz[1]:=ay;
p:=dp;
end;
inc(elemek_szama);
end;
end;
procedure
ifs_init;
var i:byte;
begin
fractal.elemek_szama:=0;
for i:=0 to elemek_szama_max-1 do fractal.elemek[i].p:=1;
end;
begin
randomize;
gd:=vga;gm:=vgahi;
initgraph(gd,gm,'c:\bp\bgi');
ifs_init;
ifs_feltolt( 0.16, 0
, 0 ,
0 , 0 , 0
,0.01);
ifs_feltolt( 0.85,
-0.04, 0.04, 0.85,
1.6 , 0 ,0.85);
ifs_feltolt( 0.22, 0.23, -0.26,
0.2 , 1.6 , 0 ,0.07);
ifs_feltolt( 0.24, 0.26,
0.28, -0.15, 0.44, 0 ,0.07);
x:=0;
y:=0;
end;
procedure kiszamol(akt_elem:byte;var x,y:real);
var uj_x,uj_y:real;
begin
with
fractal do
begin
with
elemek[akt_elem] do
begin
uj_x:=szorzo[0,0]*x+szorzo[0,1]*y+plusz[0];
uj_y:=szorzo[1,0]*x+szorzo[1,1]*y+plusz[1];
end;
end;
x:=uj_x;
y:=uj_y;
end;
procedure uj_pont(var x,y:real;prob:real);
var val:real;
akt_elem:byte;
begin
val:=0;
akt_elem:=0;
with
fractal do
begin
while
val<prob do
begin
val:=val+elemek[akt_elem].p;
inc(akt_elem);
end;
kiszamol(akt_elem-1,x,y);
end;
end;
procedure rajzol(x,y:real);
begin
putpixel(trunc(
x*nagyitas+getmaxx/2+x_el),
trunc(-y*nagyitas+getmaxy/2-y_el),getmaxcolor);
end;
begin
init;
repeat
uj_pont(x,y,random);
rajzol(x,y);
until
keypressed;
end.
**************************************************************
Program FraCsako;
Uses
NewDelay,Crt, CrtPlus, Graph;
Procedure GrInit;
Var
Gd, Gm: Integer;
Begin
DetectGraph(Gd, Gm);
InitGraph(Gd, Gm,
'c:\Bp\Bgi');
End;
Procedure Frakt(x, y, m, al: Integer);
Var
px1, px2, py: Integer;
Begin
px1:=Round(x-m*Cos(al*pi/180));
px2:=Round(x+m*Cos(al*pi/180));
py:=Round(y+m*Sin(al*pi/180));
SetColor(15);MoveTo(x,y);Lineto(px1,py);
SetColor(15);Moveto(x,y);Lineto(px2,py);
If
Round(0.76*m)>3 Then
Begin
Frakt(px1,py,Round(0.76*m),Round(1.12*al));
Frakt(px2,py,Round(0.76*m),Round(1.12*al));
End;
End;
Begin
GrInit;
Frakt(320,0,130,55);
Varj;
End.
**************************************************************
Program GrTolt;
{$M 65521,65000,65000}
Uses
NewDelay,Crt, CrtPlus, Graph;
Var
k: Integer;
Procedure GrInit;
Var
Gd, Gm: Integer;
Begin
DetectGraph(Gd, Gm);
InitGraph(Gd, Gm,
'c:\Bp\Bgi');
End;
Procedure Line(x1,y1,x2,y2:Integer;c:Byte);
Var
i,maxi,dx,dy: Integer;
mx,my: Real;
x,y: Integer;
Begin
If
(x1=x2) And (y1=y2) Then putpixel(x1,y1,c)
Else
Begin
dx:=abs(x2-x1);
dy:=abs(y2-y1);
If
dx>dy Then
maxi:=dx Else maxi:=dy;
mx:=dx/maxi; my:=dy/maxi;
y:=y1; x:=x1;
For
i:=0 To maxi Do
Begin
If
x2>x1 Then
x:=x1+Round(i*mx) Else
x:=x1-Round(i*mx);
If
y2>y1 Then
y:=y1+Round(i*my) Else
y:=y1-Round(i*my);
PutPixel(x,y,c);
End;
End;
End;
Procedure Tolt(x,y,hc,fc: Word);
Begin
If
(x-1>0) And
(GetPixel(x-1,y)<>hc) And
(GetPixel(x-1,y)<>fc) Then
Begin
PutPixel(x-1,y,fc);Tolt(x-1,y,hc,fc) End;
If
(y-1>0) And
(GetPixel(x,y-1)<>hc) And
(GetPixel(x,y-1)<>fc) Then
Begin
PutPixel(x,y-1,fc);Tolt(x,y-1,hc,fc) End;
If
(x+1<=GetMaxX) And
(GetPixel(x+1,y)<>hc) And
(GetPixel(x+1,y)<>fc) Then
Begin
PutPixel(x+1,y,fc);Tolt(x+1,y,hc,fc) End;
If
(y+1<=GetMaxY) And
(GetPixel(x,y+1)<>hc) And
(GetPixel(x,y+1)<>fc) Then
Begin
PutPixel(x,y+1,fc);Tolt(x,y+1,hc,fc) End;
End;
Begin
GrInit;
Line(320,50,350,200,15);
Line(350,200,290,200,15);
Line(290,200,320,50,15);
Tolt(320,55,15,13);
Varj;
End.
**************************************************************
Program HanoiTor;
Uses
NewDelay,Crt, CrtPlus;
Procedure Hanoi(n,a,b,c: Integer);
Begin
If
n>0 Then
Begin
Hanoi(n-1,a,c,b);
WriteLn('Az ',n,'.
korongot: ',a,' --> ',b);
Hanoi(n-1,c,b,a);
End;
End;
Begin
TextMode(CO80);
Szinek(1,15);
ClrScr;
Hanoi(4,1,2,3);
Tunj;
Varj;
End.
**************************************************************
Program Harmad;
Uses
NewDelay,Crt, CrtPlus, Graph;
Procedure GrInit;
Var
gd, gm: Integer;
Begin
DetectGraph(gd, gm);
InitGraph(gd,
gm,'c:\Bp\Bgi');
End;
Procedure Szakaszok(x1,y1, x2,y2: Integer);
Var
hx1,hy1, hx2,hy2, hx3,hy3, x,y: Integer;
Begin
Line(x1,y1,x2,y2);
hx1:=Round((2*x1+x2)/3);
hy1:=Round((2*y1+y2)/3);
hx2:=Round((x1+2*x2)/3);
hy2:=Round((y1+2*y2)/3);
x:=hx2-hx1; y:=hy2-hy1;
hx3:=Round(1/2*x-Sqrt(3)/2*y+hx1);
hy3:=Round(Sqrt(3)/2*x+1/2*y+hy1);
Line(hx1,hy1,hx3,hy3);
Line(hx3,hy3,hx2,hy2);
If
hx2-hx1>3 Then
Begin
Szakaszok(x1, y1,
hx1, hy1);
Szakaszok(hx1,
hy2, hx3, hy3);
Szakaszok(hx3,
hy3, hx2, hy2);
Szakaszok(hx2,
hy2, x2, y2 );
End;
End;
Begin
GrInit;
Szakaszok(43,0,596,0);
Szakaszok(43,240,596,240);
Varj;
End.
**************************************************************
Program Keretek;
Uses
NewDelay,Crt, CrtPlus;
Procedure UKeret(a,b,c,d:Byte);
Var
i:byte;
Begin
For
i:= a+1 To c-1 Do
Begin
Mem[$B800:0+(i-1)*2+(b-1)*80*2]:=196;
Mem[$B800:0+(i-1)*2+(d-1)*80*2]:=196;
End;
For
i:=b+1 To d-1 do
Begin
Mem[$B800:0+(a-1)*2+(i-1)*80*2]:=179;
Mem[$B800:0+(c-1)*2+(i-1)*80*2]:=179;
End;
Mem[$B800:0+(a-1)*2+(b-1)*80*2]:=218;
Mem[$B800:0+(a-1)*2+(d-1)*80*2]:=192;
Mem[$B800:0+(c-1)*2+(b-1)*80*2]:=191;
Mem[$B800:0+(c-1)*2+(d-1)*80*2]:=217;
End;
Procedure Box(a,b,c,d: Byte);
Begin
While
(Port[$3DA] And
8)<>8 do;
UKeret (a,b,c,d);
Tunj; If b<d-1 Then Box(a+3,b+1,c-3,d-1);
End;
Begin
TextMode(CO80);
Szinek(1,15);
ClrScr;
Repeat
Box(1,1,79,24);
Delay(56);
ClrScr;
Until
KeyPressed;
Felre;
Varj;
End.
**************************************************************
Program Kilenced;
Uses
NewDelay, Crt, CrtPlus, Graph;
Procedure GrInit;
Var
gd, gm: Integer;
Begin
DetectGraph(gd, gm);
InitGraph(gd,
gm,'c:\Bp\Bgi');
End;
Procedure Negyzetek(Bfx, Bfy, Jax, Jay:
Integer);
Var
hx, hy: Integer;
Begin
hx:=Round((Jax-Bfx)/3);
hy:=Round((Jay-Bfy)/3);
Rectangle(Bfx, Bfy,
Bfx+hx, Bfy+ hy);
Rectangle(Bfx+ hx,Bfy+
hy,Bfx+2*hx,Bfy+2*hy);
Rectangle(Bfx+2*hx,Bfy+2*hy,Jax, Jay
);
Rectangle(Bfx, Bfy+2*hy,Bfx+hx, Jay
);
Rectangle(Bfx+2*hx,Bfy, Jax,
Bfy+ hy);
If
(Jax-Bfx)>4 Then
Begin
Negyzetek(Bfx, Bfy,
Bfx+hx, Bfy+ hy);
Negyzetek(Bfx+ hx,Bfy+
hy,Bfx+2*hx,Bfy+2*hy);
Negyzetek(Bfx+2*hx,Bfy+2*hy,Jax, Jay
);
Negyzetek(Bfx, Bfy+2*hy,Bfx+hx, Jay
);
Negyzetek(Bfx+2*hx,Bfy, Jax,
Bfy+ hy);
End;
End;
Begin
GrInit;
SetColor(15);
Negyzetek(0,0,639,479);
Varj;
End.
**************************************************************
Program KozOszto;
Uses
NewDelay, Crt, CrtPlus;
Var
x, y: Longint;
Function Lnko(a,b: Longint): Longint;
Begin
If
b>0 Then
Lnko:= Lnko(b, a mod b) Else Lnko:=
a;
End;
Begin
TextMode(CO80);
x:=3300;
y:=555;
Szinek(1,15);
ClrScr;
Write('(',x,',',y,')=',Lnko(x,
y));
Tunj;
Varj;
End.
**************************************************************
Program Labirint;
Uses
NewDelay,Crt, CrtPlus;
Var
k: Byte;
Procedure Lab(Bfx, Bfy, Jax, Jay: Byte);
Var
i, v, w: Byte;
Function
MidRnd1(a, b: Byte): Byte;
Begin
MidRnd1:=a+2*(1+Random(Round((b-a-2)/2))) End;
Function
MidRnd2(a, b: Byte): Byte;
Begin
MidRnd2:=a+2*(Random(Round((b-a-2)/2)))+1 End;
Begin
If
(Abs(Jax-Bfx)>3) Or (Abs(Jay-Bfy)>3) Then
Begin
w:=Random(2);
Case
W Of
0: If
(Abs(Jax-Bfx)>3) Then
Begin
v:=MidRnd1(Bfx,
Jax); For i:=Bfy+1 to Jay-1 do BKep[i,v,1]:=219;
Bkep[MidRnd2(Bfy,
Jay),v,1]:=32;
Lab(Bfx,
Bfy, v, Jay); Lab(v, Bfy, Jax, Jay);
End;
1: If
(Abs(Jay-Bfy)>3) Then
Begin
v:=MidRnd1(Bfy,
Jay); For i:=Bfx+1 to Jax-1 do BKep[v,i,1]:=219;
Bkep[v,MidRnd2(Bfx,
Jax),1]:=32;
Lab(Bfx,
Bfy, Jax, v); Lab(Bfx, v, Jax, Jay);
End;
End;
End;
End;
Begin
TextMode(CO80);
Randomize; Szinek(2,15);
ClrScr;
For
k:=1 to 79 do Begin BKep[1,k,1]:=219; BKep[25,k,1]:=219 End;
For
k:=1 to 25 do Begin BKep[k,1,1]:=219; BKep[k,79,1]:=219 End;
Bkep[2,1,1]:=32;Bkep[24,79,1]:=32;
Lab(1,1,79,25);
Felre; Varj;
End.
**************************************************************
program pafrany;
uses
NewDelay, crt,graph;
const
q=0.7;
c1=0.2;
c2=0.4;
c3=0.1;
dfi1=60*3.1415/180;
dfi2=2*3.1415/180;
dfi3=-75*3.1415/180;
k1=0.35;
k2=0.9;
k3=0.45;
hatar=5;
var gd,gm:integer;
pontok:array[0..4] of pointtype;
procedure
teglalap(px,py,fi,h:real);
var fi1,fi2,fi3,
r1,r2,r3,
h1,h2,h3,
x1,x2,x3,
y1,y2,y3:real;
begin
if
h>hatar then
begin
fi1:=fi+dfi1;fi2:=fi+dfi2;fi3:=fi+dfi3;
r1:=c1*h;r2:=c2*h;r3:=c3*h;
h1:=k1*h;h2:=k2*h;h3:=k3*h;
x1:=px+r1*cos(fi1);y1:=py+r1*sin(fi1);
x2:=px+r2*cos(fi2);y2:=py+r2*sin(fi2);
x3:=px+r3*cos(fi3);y3:=py+r3*sin(fi3);
line(round(px),getmaxy-round(py),round(x1),getmaxy-round(y1));
line(round(px),getmaxy-round(py),round(x2),getmaxy-round(y2));
line(round(px),getmaxy-round(py),round(x3),getmaxy-round(y3));
teglalap(x2,y2,fi2,h2);
teglalap(x1,y1,fi1,h1);
teglalap(x3,y3,fi3,h3);
end
else
begin
pontok[0].x:=round(px+h*cos(fi)-q*h*sin(fi)/2);
pontok[1].x:=round(px+h*cos(fi)+q*h*sin(fi)/2);
pontok[2].x:=round(px+q*h*sin(fi)/2);
pontok[3].x:=round(px-q*h*sin(fi)/2);
pontok[0].y:=getmaxy-round(py+h*sin(fi)+q*h*cos(fi)/2);
pontok[1].y:=getmaxy-round(py+h*sin(fi)-q*h*cos(fi)/2);
pontok[2].y:=getmaxy-round(py-q*h*cos(fi)/2);
pontok[3].y:=getmaxy-round(py+q*h*cos(fi)/2);
pontok[4]:=pontok[0];
drawpoly(5,pontok);
end;
end;
begin
gd:=detect; initgraph(gd,gm,'c:\bp\bgi');
teglalap(getmaxx
div 6,getmaxy/2,-10*pi/180,getmaxx div 5);
repeat
until keypressed;
closegraph;
end.
**************************************************************
Program permut;
Uses
NewDelay,Crt, CrtPlus;
Const n=4;
Type
Tomb= Array[1..n]
Of Byte;
pt= ^tt;
tt=Array[1..5040] Of Tomb;
Var
t:pt;
v: Tomb;
I,J,p, q, m, sz:
Integer;
Function Fakt(k: Byte): Longint;
Begin
If
k>0 Then
Fakt:=k*Fakt(k-1) Else Fakt:=1
End;
Procedure Veletlen(Var v: Tomb);
Var
a: Byte;
i: Byte;
Begin
For i:=1 to n Do V[i]:=0;
For I:=1 To n do
Begin
a:=Random(n)+1; If
V[a]=0 Then V[a]:=i Else Dec(I) End;
End;
Function Berak(v: Tomb): Boolean;
Var
i,j: Integer;
Function
EgyenloE(a,v: tomb):Boolean;
Var
k: Byte;
Begin
EgyenloE:= True;
For
k:=1 to n do If a[k]<>v[k]
Then Egyenloe:= False;
End;
Begin
Berak:= False; i:=1;
While
(t^[i,1]<>0) and Not
EgyenloE(t^[i],v) do inc(i);
If
t^[i,1]=0 Then
Begin
For
j:=1 to n do t^[i,j]:=v[j];
Berak:= True;
End;
End;
Begin
TextMode(CO80);
Szinek(1,15);
ClrScr; Randomize; m:=Fakt(n); sz:=0;
New(t);
For
I:= 1 To 5040 Do For J:= 1 To N Do t^[I,J]:= 0;
While
sz<m Do
Begin
Veletlen(v); If Berak(v) Then
Begin
Inc(sz);
if
(sz mod 100)=0 Then
WriteLn(sz);
End;
End;
For
p:=1 to m do
Begin
Write(p:6,': ');
For
q:=1 to n do Write(t^[p,q]:3);
Writeln;
End;
Tunj;
Varj;
Szinek(0,7);ClrScr;
Dispose(t);
End.
**************************************************************
Program polvagas;
Uses
NewDelay,Crt, CrtPlus, Graph;
Type
PPont= ^TPont;
TPont= Record
x, y: Real;
KP: PPont;
End;
Var
TMax, Tmin: Real;
Var
UjPont, ElsoPont, AktPont: PPont;
A, B: TPont;
k: LongInt;
Procedure GrInit;
Var
Gd, Gm: Integer;
Begin
DetectGraph(Gd, Gm);
InitGraph(Gd, Gm, 'c:\bp\bgi');
End;
Procedure Felfuz(Var UjPont: PPont);
Begin
If
UjPont=Nil Then Exit;
If
ElsoPont= Nil Then
Begin
ElsoPont:= UjPont; AktPont:=ElsoPont; ElsoPont^.KP:=ElsoPont
End
Else
Begin
AktPont^.KP:=
UjPont;
AktPont:= UjPont;
UjPont^.KP:=
ElsoPont;
End;
End;
Procedure Bevitel;
Const p: array[1..8,1..2]
Of LongInt= ((100,120),(180, 70),
(340,100),(600,170),
(500,370),(280,400),
(160,350),(100,260));
Var
i: Byte;
Begin
For
i:=1 To 8 Do
Begin
New(UjPont);
UjPont^.x:=
p[i,1];
UjPont^.y:=
p[i,2];
UjPont^.KP:= Nil;
Felfuz(UjPont);
End;
End;
Procedure PolyRajz;
Begin
AktPont:= ElsoPont;
MoveTo(Round(AktPont^.x),Round(AktPont^.y));
Repeat
LineTo(Round(AktPont^.KP^.x),Round(AktPont^.KP^.y));
AktPont:=AktPont^.KP;
Until
AktPont=ElsoPont;
SetColor(5);
Line(round(A.x),
round(A.y), round(B.x), round(B.y));
End;
Procedure PolyKlipp;
Var
t, p: Real;
ax,ay, fx,fy:
Real;
Begin
TMax:=0; TMin:=1;
AktPont:= ElsoPont;
Repeat
With
AktPont^ do
Begin
p:= (KP^.y-y)*(B.x-A.x)+(x-KP^.x)*(B.y-A.y);
If
p<>0 Then
t:= -((KP^.y-y)*(A.x-x)+(x-KP^.x)*(A.y-y))/p;
If
t=0 Then t:=0.00000001;
If
(Tmax=0) And (p>0)
Then TMax:= t Else
If
(Tmax<>0) And
(p>0) And (TMax>t) Then TMax:= t;
If
(TMin=1) And (p<0) Then TMin:= t Else
If
(TMin<>0) And
(p<0) And (TMin<t) Then TMin:= t;
End;
AktPont:= AktPont^.KP;
Until
AktPont=ElsoPont;
If
TMin<0 Then
TMin:=0; If TMax>1 Then TMax:=1;
If
TMax>=TMin Then
Begin
ax:= Round((1-TMin)*A.x
+ TMin*B.x);
ay:= Round((1-TMin)*A.y
+ TMin*B.y);
fx:= Round((1-TMax)*A.x
+ TMax*B.x);
fy:= Round((1-TMax)*A.y
+ TMax*B.y);
SetColor(15);
Line(Round(ax),Round(ay),
Round(fx),Round(fy));
End;
End;
Begin
Szinek(1,15);
ClrScr;
Bevitel;
GrInit;
Delay(1500);
A.x:=150; A.y:=50;
B.x:=140; B.y:=300;
PolyRajz;
PolyKlipp;
{ For k:=0 to 300 Do
Begin
A.x:=k; A.y:=0;
B.x:=k+200; B.y:=320;
PolyKlipp;
End;
For
k:=0 to 639 do
Begin
A.x:=k; A.y:=0;
B.x:=320; B.y:=240;
PolyKlipp;
End;
For
k:=0 to 479 do
Begin
A.x:=639; A.y:=k;
B.x:=320; B.y:=240;
PolyKlipp;
End;
For
k:=639 downto 0 do
Begin
A.x:=k; A.y:=479;
B.x:=320; B.y:=240;
PolyKlipp;
End;
For
k:=479 downto 0 do
Begin
A.x:=0; A.y:=k;
B.x:=320; B.y:=240;
PolyKlipp;
End;
Varj;
ClearDevice;
PolyRajz;
For
k:=0 to 479 do
Begin
B.x:=0; B.y:=k; A.x:=639;
A.y:=479-k;
PolyKlipp;
End;
For
k:=0 to 639 do
Begin
B.x:=k; B.y:=0; A.x:=639-k;
A.y:=479;
PolyKlipp;
End; }
Varj;
Repeat
ElsoPont^.KP:=
ElsoPont^.KP^.KP;
Dispose(ElsoPont^.KP);
Until
ElsoPont^.KP=ElsoPont;
End.
**************************************************************
Program SikTolt;
Uses
NewDelay,Crt, CrtPlus;
Var
a,b,i: Integer;
Procedure Tolt(x,y:Byte);
Begin
Delay(3);
If
(x-1>0) And
(BKep[y,x-1,1]=32) Then
Begin
BKep[y,x-1,1]:=ord('*'); Tolt(x-1,y) End;
If
(y-1>0) And
(BKep[y-1,x,1]=32) Then
Begin
BKep[y-1,x,1]:=ord('*'); Tolt(x,y-1) End;
If
(x+1<=80) And
(BKep[y,x+1,1]=32) Then
Begin
BKep[y,x+1,1]:=ord('*'); Tolt(x+1,y) End;
If
(y+1<=25) And
(BKep[y+1,x,1]=32) Then
Begin
BKep[y+1,x,1]:=ord('*'); Tolt(x,y+1) End;
End;
Begin
TextMode(CO80);Randomize;
Szinek(1,14); ClrScr;
For
i:= 1 to 900 do
Begin
a:=random(25)+1;
b:=Random(80)+1;
BKep[a,b,1]:=219;
BKep[a,b,2]:=16+5;
End;
Felre;
Tolt(40,12);
Varj; ClrScr;
Ablak(7,0,5,2,50,4,True,'');
Ablak(6,14,2,8,25,16,True,'');
Ablak(5,13,65,11,77,24,True,'');
Tolt(40,12);
Tunj;
Varj;
End.
**************************************************************
Program STMeret;
{$M 65521,65000,650000}
Var
i: Integer;
Procedure Ide;
Begin
Inc(i);
WriteLn(i);
Ide;
End;
Begin
Ide;
End.
**************************************************************
Program Szumm;
{$M 65521,65000,650000}
Uses
NewDelay,Crt, CrtPlus;
Var
i: Word;
Function Szumma(n: Word): Longint;
Begin
If
n>0 Then
Szumma:=n+Szumma(n-1) Else Szumma:=0
End;
Begin
TextMode(CO80);
Szinek(1,15);
ClrScr;
For
i:=0 to 6498 do
WriteLn('Szumma(1-t‹l
',i:2,'-ig)',' = ',Szumma(i));
Tunj;
Varj;
End.
**************************************************************
Program Valami;
Uses
NewDelay,Crt, CrtPlus, Graph;
Procedure GrInit;
Var
Gd, Gm: Integer;
Begin
DetectGraph(Gd, Gm);
InitGraph(Gd, Gm,
'c:\Bp\Bgi');
End;
Procedure Rajzolj(x1, x2, y: Integer);
Var
px, py: Integer;
Begin
delay(100);
px:=Round((x1+x2)/2);
py:=Round((x2-x1)*0.75);
Line(x1,y,x2,y);Line(x2,y,px,py);Line(px,py,x1,y);
if
x2-x1>5 then
Begin
Rajzolj(x1,x1+Round((x2-x1)/3),y);
Rajzolj(x1+Round((x2-x1)/3),x1+2*Round((x2-x1)/3),y);
Rajzolj(x1+2*Round((x2-x1)/3),x2,y);
End;
End;
Begin
GrInit;
Rajzolj(0,639,0);
Varj;
End.