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.