Rekurzió

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.

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;

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;

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;

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;

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;

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;

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;

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;

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;

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;

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;

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;

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;

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;

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;

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;

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;

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;

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;

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;

Begin

GrInit;

Rajzolj(0,639,0);

Varj;

End.