online kép - Fájl  tube fájl feltöltés file feltöltés - adja hozzá a fájlokat online fedezze fel a legújabb online dokumentumok Kapcsolat
   
 

Letöltheto dokumentumok, programok, törvények, tervezetek, javaslatok, egyéb hasznos információk, receptek - Fájl kiterjesztések - fajltube.com

 

Online dokumentumok - kep
   
kategória
 

Biológia állatok Fizikai Földrajz Kémia Matematika Növénytan Számítógépes
Filozófia
Gazdaság
Gyógyszer
Irodalom
Menedzsment
Receptek
Vegyes

 
 
 
 













































 
 

Rekurzió (particiószam, Hanoi tornyai, postfix konverzió)

számítógépes

Fájl küldése e-mail Esszé Projekt


egyéb tételek

 
A programok felépítése, az utasítasok típusai
Könyvtarak
PLC-S VEZÉRLÉSEK MEGBÍZHATÓSÁGÁNAK NÖVELÉSE
VoIP technológia
Adatbazis létrehozasa - Access
Rekurzió (particiószam, Hanoi tornyai, postfix konverzió)
 
 

Rekurzió (particiószám, Hanoi tornyai, postfix konverzió).

Program Particio;

  Var

    n : Word;

  Function P(n : Word) : Longint;

    Function P2(m,n : Word) : Longint;

      Begin

        If (m = 1) Or (n = 1) Then

          P2 := 1

        Else If m <= n Then

          P2 := 1 + P2(m,m-1)

        Else

          P2 :=P2(m,n-1) + P2(m-n,n)

      End;

  Begin



    P:=P2(n,n);

  End;

Begin

  Writeln(' Kerem az inputot; 0 a vege ! '); Readln(n);

  While n <> 0 Do Begin

      Writeln('F(',n:1,') = ',P(n));

      Readln(n)

    End

End.

Program HanoiTornyai;

  Uses Crt;

  Const

    N = 10;

    N2= 20;

  Var

   Torony : Array[1..3] Of 0..N;

   K : Array[0..N] Of String[N2];

   Tx : Array[1..3] Of Byte;

   Talp : Byte;

   C : Char;

 Procedure Inicializalas;

   Var

    i,j : Integer;

   Begin

     Talp := 20; Tx[1] := 1; Tx[2] := 29; Tx[3] := 57;

     K[0] := '';

     For i := 1 To N2 Do K[0] := Concat(K[0], ' ');

     For i := 1  To N Do

       Begin

         K[i] := K[i-1];

         For j := 1 To i Do

           Begin

             K[i][N-j+1] := #219;

             K[i][N+j] := #219;

           End;

       End;

     Torony[1] := N; Torony[2] := 0; Torony[3] := 0;

     Clrscr;

     GotoXY(1,1);

     WriteLn(' A <z> kivetelevel barmely billentyu leutesere ');

     WriteLn(' egy korongot rak at. A <z> leutese utan nem var!');

     For i := 1 To N Do

       Begin

         GotoXY(TX[1], Talp-i); Write(K[N-i+1]);

       End;

     C := ' ';

   End (* Inicializalas *);

  Procedure Atrak(i, Rol, Ra : Integer);

    Begin

      If C <> 'z' Then

       C := ReadKey;

      GotoXY(Tx[Rol], Talp-Torony[Rol]); Dec(Torony[Rol]);

      Write(K[0]);

      Inc(Torony[Ra]);

      GotoXY(Tx[Ra], Talp-Torony[Ra]);

      Write(K[i]);

    End (* Atrak *);

  Procedure Hanoi(M, Honnan, Hova : Integer);

    Begin

      If M = 1

        Then

          Atrak(1, Honnan, Hova)

        Else Begin

          Hanoi(M-1, Honnan, 6-(Honnan+Hova));

          Atrak(M, Honnan, Hova);

          Hanoi(M-1,6-(Honnan+Hova), Hova);

        End

    End (* Hanoi *);

  Begin

    Inicializalas;

    Hanoi(10,1,2);

  End.

Program Postfix;

Uses Crt;

  Var

    Formula, PostForm : String[255];

    i : Integer; Jel, Van : Char; Jo : Boolean;

  Procedure KovJel;

    Begin

      Repeat

        i := Succ(i);

      Until Formula[i] <> ' ';

      Jel := Formula[i]

    End;

  Procedure Tag; Forward;

  Procedure Tenyezo; Forward;

  Procedure Kifejezes;

    Var

      M : Char;

    Begin

      Tag;

      While Jo And (Jel In ['+','-']) Do Begin

        M := Jel;

        KovJel;

        Tag;

        PostForm := PostForm + M;

      End

    End (* Kifejezes *);

  Procedure Tag;

    Var

      M : Char;

    Begin

      Tenyezo;

      While Jo And (Jel In ['*','/']) Do Begin

        M := Jel;

        KovJel;

        Tenyezo;

        PostForm := PostForm + M;

      End

    End (* Tag *);

  Procedure Tenyezo;

    Begin

      Case Jel Of

        'a'..'z','A'..'Z':

              Begin

                 PostForm := PostForm + Jel; KovJel;

              End;

        '(' : Begin

                KovJel;

                Kifejezes;

                If Jo And (Jel = ')') Then

                  KovJel

                Else

                  Jo := False

              End;

         Else Jo := False

       End (* Case *)

      End (* Tenyezo *);

  Begin

    Repeat

      ClrScr;

      Writeln(' Kerem az input formulat ! ');

      Readln(Formula);

      Formula := Formula + '.' ; Postform := '';

      i := 0; KovJel; Jo := True;

      Kifejezes;

      If Not Jo Or (Jel <> '.') Then

        WriteLn('Hibas a formula: ',Copy(Formula,1,i),'<- itt a hiba!')

      Else

        WriteLn('A postfix alak: ',Postform);

      WriteLn;

      WriteLn('Van meg input? (I/N) ');

      Van := Readkey;

    Until UpCase(Van)='N';

End.

2. A kupacrendezés.

Procedure KupacRend(Var T : Tomb);

  Var

    i : Word; E : Elemtip;

  Procedure Sullyeszt(K,L : Word );

 

    Var

      Apa,Fiu : Word;

    Begin

      E := T[K]; Apa := K; Fiu := 2*Apa;

      While (Fiu <= L) Do Begin

        If (Fiu < L) And (T[Fiu].kulcs < T[Fiu+1].kulcs) Then

          Fiu := Fiu+1;

        If E.kulcs >= T[Fiu].kulcs Then

          Break

        Else Begin

          T[Apa] := T[Fiu];

          Apa := Fiu; Fiu := 2*Apa

        End

      End;

      T[Apa] := E

    End (* Sullyeszt *);

  Begin (* KupacRend *)

    For i := TMeret Div 2 Downto 1 Do

      Sullyeszt(i,TMeret);

    For i := TMeret Downto 2 Do Begin

      E := T[i]; T[i] := T[1]; T[1] := E;

      Sullyeszt(1,i-1)

    End;

  End (* KupacRend *);

3. A gyorsrendezés.

Procedure Gyors(Var T:Tomb; Kisebb:RendRelTip);

  Function Feloszt(Bal,Jobb : Word): Word;

    Var

      Fe,E : Elemtip;

      i,j : Word;

    Begin

      Fe := T[(Bal+Jobb) Div 2];

      i := Bal-1; j := Jobb+1;

      While True Do Begin

        Repeat

          Inc(i)

        Until Not Kisebb(T[i],Fe);

        Repeat

          Dec(j)

        Until Not Kisebb(Fe,T[j]);

        If I < J  Then Begin

          E := T[i]; T[i] := T[j]; T[j] := E;

        End Else Begin

          Feloszt:= j;

          Exit

        End;

      End;

    End (* Feloszt *);

  Procedure Rendez(Bal,Jobb : Integer);

    Var

      f : Word;

    Begin

      f:= Feloszt(Bal, Jobb);

      If Bal<f Then

        Rendez(Bal, f);

      If f<Jobb Then

        Rendez(f+1, Jobb)

    End (* Rendez *);

  Begin

    Rendez(1, N)

  End; (* Gyors *)

4. Lineáris idejü rendezési algoritmusok (számláló, radix, vödrös).

Procedure Szamlalorend(Var T,T1 : Tomb);

  Var

    i,j : Word;

    S: Array[0..M] Of Word;

  Begin

    For i := 0 To M Do S[i]:= 0;

    For i := 1 To N Do Inc(S[T[i].kulcs]);

    For i := 1 To M Do S[i]:= S[i-1]+S[i];

      (* S[i]=|| *)

    For i := N DownTo 1 Do

      Begin

        j := T[i].kulcs;

        T1[ S[j] ]:= T[i];

        Dec(S[j]);

      End

  End (* Szamlalorend *);

------------------------------

Procedure RadixRend(Var L : Lanc);

  Var

    T : Array[Char] Of Record

                         Eleje,Vege:Lanc;

                       End;

    C : Char; E : Lanc;

    i, Maxhossz : Word;

Begin

  Maxhossz := 0; E:=L;(* a maximalis szohossz meghatarozasa *)

  While E <> Nil Do

    Begin

      If Length(E^.Elem.kulcs) > Maxhossz Then

        Maxhossz := Length(E^.Elem.kulcs);

      E:= E^.Csat

    End;

  For C := Chr(0) To Chr(255) Do  (* ures reszlistak letrehozasa *)

    Begin

      New(T[C].Vege); T[C].Eleje:= T[C].Vege;

    End;

  For i := Maxhossz Downto 1 Do

    Begin

      While L <> Nil Do (* szavak szetosztasa a reszlistakra, *)

        Begin     (* az i-edik betu szereint *)

          E:= L; L:= L^.Csat;

          If i <= Length(E^.Elem.kulcs) Then

            C := E^.Elem.kulcs[i]

          Else

            C := ' ';

          T[C].Vege^.Csat:= E;

          T[C].Vege:= E;

        End;

      L:= Nil;

      For C := Chr(255) DownTo Chr(0) Do

        Begin (*a reszlistak osszekapcsolasa*)

          T[C].Vege^.Csat:= L; L:= T[C].Eleje^.Csat;

          T[C].Vege:=T[C].Eleje;

        End

    End

End (* RadixRend *);

------------------------------

Procedure VodrosRend(Var T,T1:Tomb);

  Const

    M=N; (* a vodrok szama *)

  Type

    Lanc=^Cella;

    Cella=Record

            index: Word;

            Csat: Lanc

          End;

  Var

    E: Elemtip;

    V:Array[0..M-1] Of Lanc;

    i,j,k : Word; p,q,Uj: Lanc;

  Begin

    For i := 0 To M-1 Do V[i]:= Nil;

    For i := 1 To N Do

      Begin     (* az elemek szetosztasa *)

        j:= Trunc(T[i].kulcs*M);

        New(Uj); Uj^.index:= i;

        Uj^.csat:= V[j]; V[j]:= Uj;

      End;

    i:= 1;

    For j := 0 To M-1 Do    (* a vodrokben levo elemek osszefuzese es *)

      Begin (*rendezese beszuro rendezessel*)

        p:= V[j];

        While p <> Nil Do

          Begin

            E:= T[p^.index];

            k:= i-1;

            While (k>0) And (T1[k].kulcs > E.kulcs) Do

              Begin

                T1[k+1]:= T1[k]; Dec(k);

              End;

            T1[k+1]:= E; q:= p;

            p:= p^.Csat; Dispose(q);

            Inc(i);

          End;

      End;

  End; (* VodrosRend *)

5. Mediánok és rendezett minták; k-adik legkisebb elemet kiválasztó algoritmusok.

Function Kivalaszt(Var T : Tomb; K : Word) : Word;

  Function Feloszt(Bal,Jobb : Word): Word;

    Var

      E : Elemtip; Fk : Kulcstip;

      i,j : Word;

    Begin

      Fk := T[Bal].kulcs;

      I := Bal-1; J := Jobb+1;

      While True Do

      Begin

        Repeat Inc(i)

        Until Fk <= T[I].kulcs ;

        Repeat Dec(j)

        Until T[j].kulcs <= Fk;

        If I < J  Then

            Begin

              E := T[I]; T[I] := T[J]; T[J] := E;

            End

        Else Begin Feloszt:= j; Exit End;

      End;

    End (* Feloszt *);

 Begin

  Bal:=1; Jobb:=N;

  While Bal < Jobb Do

    Begin

      Kozep:= Feloszt(Bal,Jobb);

      If k<= Kozep-Bal+1 Then

          Jobb:= Kozep

      Else Begin

        K:= K-(Kozep-Bal+1); Bal:= Kozep+1

      End

    End;

  Kivalaszt:= Bal

End (* Kivalaszt *);

6. Külsö rendezési algoritmusok; összefésülö rendezések

Program KM_Rend;

  Const

    MaxMem = 15*1024;

    MaxP   = 32;

  Type

    Elemtip=Single;

    MemTip=Array[1..MaxMem] Of Elemtip;

  Var

    P:Longint;

    F: Array[Boolean] Of File;

    FNev : String;

    Mem: ^MemTip;

    M  : Longint;

    BM : longint;

    Rh : Longint;

    N  : Longint;

    inf,ouf:Boolean;

Function OptP(N,M:Longint):Word;

Const

  a=1.0; b=1000.0;

Var

  r,rm,rmin,rmax:Longint;

  NpM,Km,K:Real;

  Function Log(a,x:Real):Real;

  Begin

    Log:=Ln(x)/Ln(a)

  End;

  Function Gyok(r,x:Real):Real;

  Begin

    Gyok:=Exp(Ln(x)/r);

  End;

Begin

  Km:=1.0E10; NpM:=N/M;

  rmin:=Round(Log(m-1,N/M)+0.5); rmax:=Round(Log(2,N/M)+0.5);

  For r:=rmin To rmax Do Begin

    K:=r*(a*M/b + Gyok(r,NpM)+1);

    If K<Km Then Begin

      rm:=r; Km:=K;

    End;

  End;

  OptP:=Round(Gyok(rm,NpM)+0.5);

End;

Procedure Belsorendez(Tol,Ig: Longint);

   Var E,Fe:Elemtip;

Function BelFeloszt( Bal,Jobb: Longint): Longint ;

  Var E,Fe : Elemtip; Tovabb:Boolean;

  Begin

    Fe := Mem^[(Bal+Jobb) Div 2]; Tovabb:=Bal <= Jobb;

    While Tovabb Do Begin

      While Mem^[Bal] < Fe Do Inc(Bal);

      While Mem^[Jobb] > Fe Do Dec(Jobb);

      If Bal < Jobb  Then  Begin

        E := Mem^[Bal]; Mem^[Bal] := Mem^[Jobb]; Mem^[Jobb] := E;

        Inc(Bal); Dec(Jobb);

      End Else

        Tovabb:=False

    End;

    BelFeloszt:=Jobb;

  End (* BelFeloszt *);

  Procedure Beszurorend(Kezd,Veg: Longint);

  Var mi,i,j,N,d:Longint;

  Begin

    N:=Veg-Kezd+1;

    mi:= Kezd;

    If N<=11 Then d:=N-1 Else d:=10;

    (* Strazsa allitasa az Kezd cimre *)

    For i:=Kezd+1 To Kezd+d Do Begin

      If (Mem^[i]<Mem^[mi]) Then mi:=i;

    End;

    Move(Mem^[Kezd], E, Rh);

    Move(Mem^[mi], Mem^[Kezd], Rh);

    Move(E, Mem^[mi], Rh);

    For i:=Kezd+1 To Veg Do Begin

      j:=i-1;

      Move(Mem^[i], E,Rh);

      While (E< Mem^[j]) Do Begin

        Move(Mem^[j],Mem^[j+1],Rh);

        Dec(j);

      End;

      Move(E,Mem^[j+1], Rh);

    End;

  End (* BeszuroRend *);

  Procedure BRendez(Kezd,Veg : Longint);

    Var

      Kozep : Longint;

    Begin

      While (Veg-Kezd)>10 Do

        Begin

          Move(Mem^[(Kezd+Veg) Div 2], Fe, Rh);

          Kozep:=BelFeloszt(Kezd,Veg);

          If Kozep-Kezd > Veg-Kozep Then Begin

             BRendez(Kezd, Kozep);

             Kezd:=Kozep+1;

          End Else Begin

            BRendez(Kozep+1,Veg);

            Veg:=Kozep;

          End;

        End;

    End (* BRendez *);

  Begin

    If (Ig-Tol)>10 Then BRendez(Tol,Ig);

    Beszurorend(Tol,Ig);

  End; (* BelsoRendez *)

Procedure Nyit;

  Var i:Integer;

    s1,s2:String;

  Begin

    Val(ParamStr(1), M, i);

    Rh:=Sizeof(Elemtip);

    inf:=True; ouf:=False;

    Assign(F[inf],FNev);

   

      Reset(F[inf],1);

   

    If IOResult <> 0 Then Halt;

    N:=FileSize(F[inf]) Div Rh;

    P:=OPtP(N,M);

    BM:=M Div (P+1);



    M:=(P+1)*BM;

    If N<M Then Begin

      M:=N; BM:=M;

    End;

    GetMem(Mem,M*Rh);

    Assign(F[ouf],'tmp.dat');

    Rewrite(F[ouf],1);

  End;

Procedure Zar;

  Var i:Word;

    xF:File;

  Begin

    Close(F[inf]);

    Close(F[ouf]);

    Erase(F[inf]);

    If inf Then Begin

      Assign(xF,'tmp.dat');

      Rename(xF, FNev);

    End;

    FreeMem(Mem,M*Rh);

  End;

  Procedure Menet0;

    Var

      Rr,Reksz:Longint;

  Begin

    Rr:=N;

    While Rr >0 Do Begin

      If Rr<M Then Reksz:=Rr Else Reksz:=M;

      Dec(Rr,Reksz);

      BlockRead(F[inf], Mem^[1], Reksz*Rh);

      BelsoRendez(1, Reksz);

      BlockWrite(F[ouf], Mem^[1], Reksz*Rh);

    End;

  End;

  Procedure MergeRuns(nf,Fpoz,Lr,tLr:Longint);

    Var i:Longint;

      orp,Reksz:Longint;

      S :Array[1..MaxP] Of Word;

      Rr,

      Mp,             

      Fp,EndP: Array[1..MaxP] Of Longint;

      Sm:Longint; 

      Procedure SorEpit(Sm:Longint);

        Var E:Elemtip;

         Apa,fiu,i:Longint; Tovabb:Boolean;

      Begin

        For i:=1 To Sm Do S[i]:=i;

        For i:= Sm Div 2 Downto 1 Do Begin

          E:=Mem^[Mp[S[i]]];

          Apa:=i;fiu:=i Shl 1; Tovabb:=True;

          While Tovabb And (fiu<=Sm) Do Begin

            If (fiu<Sm) And (Mem^[Mp[S[fiu+1]]]<Mem^[Mp[S[fiu]]]) Then

              Inc(fiu);

            If (E<Mem^[Mp[S[fiu]]]) Then

              Tovabb:=False

            Else Begin

              S[Apa]:=S[fiu];

              Apa:=fiu; fiu:=fiu Shl 1;

            End;

          End;

          S[Apa]:=i;

        End (* For *);

      End (*SorEpit *);

      Procedure SorBol(orp:Longint);

        Var

          Apa,fiu,bal,jobb,mf:Longint; Tovabb:Boolean;

          E:Elemtip;

      Begin

        mf:=S[1];

        Mem^[orp]:=Mem^[Mp[mf]];

        Inc(Mp[mf]);

        If Mp[mf]=EndP[mf] Then Begin

          If Rr[mf]>0 Then Begin

            If Rr[mf]>BM Then Reksz:=BM Else Reksz:=Rr[mf];

            Mp[mf]:=(mf-1)*BM+1;

            Seek(F[inf],Fp[mf]);

            BlockRead(F[inf], Mem^[Mp[mf]], Reksz*Rh);

            Dec(Rr[mf],Reksz);

            Inc(Fp[mf],Reksz*Rh);

            EndP[mf]:=Mp[mf]+Reksz;

          End Else Begin

            mf:=S[Sm]; S[1]:=mf;

            Dec(Sm);

          End;

        End;

        If Sm=0 Then Exit;

        E:=Mem^[Mp[mf]]; 

        Apa:=1;fiu:=2; Tovabb:=True;

        While Tovabb And (fiu<=Sm) Do Begin

          If (fiu<Sm) And (Mem^[Mp[S[fiu+1]]]<Mem^[Mp[S[fiu]]]) Then

            Inc(fiu);

          If (E<=Mem^[Mp[S[fiu]]]) Then

            Tovabb:=False

          Else Begin

            S[Apa]:=S[fiu];

            Apa:=fiu; fiu:=fiu Shl 1;

          End;

        End;

        S[Apa]:=mf;

      End (* SorBol *);

  Begin

    For i:=1 To nf-1 Do Begin

      Mp[i]:=1+(i-1)*BM;

      Fp[i]:=(Fpoz+(i-1)*Lr)*Rh;

      Seek(F[inf],Fp[i]);

      BlockRead(F[inf], Mem^[Mp[i]], BM*Rh);

      EndP[i]:=Mp[i]+BM;

      Rr[i]:=Lr-BM;

      Inc(Fp[i],BM*Rh);

    End;

    If tLr>BM Then Reksz:=BM Else Reksz:=tLr;

    Mp[nf]:=1+(nf-1)*BM;

    Fp[nf]:=(Fpoz+(nf-1)*Lr)*Rh;

    Seek(F[inf],Fp[nf]);

    BlockRead(F[inf], Mem^[Mp[nf]], Reksz*Rh);

    EndP[nf]:=Mp[nf]+Reksz;

    Rr[nf]:=tLr-Reksz;

    Inc(Fp[nf],Reksz*Rh);

    Sm:=nf; SorEpit(Sm);

    orp:=M-Bm;

    While Sm<>0 Do Begin

      Inc(orp);

      Sorbol(orp);

      If orp=M Then Begin

        BlockWrite(F[ouf], Mem^[M-BM+1], BM*Rh);

        orp:=M-BM;

      End;

    End;

    BlockWrite(F[ouf], Mem^[M-BM+1], (BM-(M-orp))*Rh);

  End;

  Procedure FesuloMenet;

  Var Lr,Nr,tLr,Fpoz:Longint;

    i,lf:Word;

  Begin

    Lr:=M;        

    Repeat

    inf:=ouf; ouf:=Not ouf;

    Seek(F[inf],0); Seek(F[ouf],0);

      Fpoz:=0;        

      Nr:=(N+P*Lr-1) Div (P*Lr);     

      lf:=(N Mod (P*Lr)+Lr-1) Div Lr;

      If lf=0 Then lf:=P;

      tLr:=N Mod Lr;

      If tLr=0 Then tLr:=Lr;

      For i:=1 To Nr-1 Do  Begin

        MergeRuns(P,Fpoz,Lr,Lr);  

        Inc(Fpoz,P*Lr);

      End;

      MergeRuns(lf,Fpoz,Lr,tLr); 

      Lr:=Lr*P;

    Until Lr>=N;

  End ;

Procedure Rendez; 

Begin (* Rendez *)

  Nyit;

  If N<=M Then Begin

    BlockRead(F[inf], Mem^[1], N*Rh);

    BelsoRendez(1, N);

    Seek(F[inf],0);

    BlockWrite(F[inf], Mem^[1], N*Rh);

    inf:=ouf; ouf:=Not inf;

  End Else Begin

    Menet0;

    FesuloMenet;

  End;

  Zar;

End (* Rendez *);

Begin

  FNev:= 't.dat';

  Rendez;

End.

7. Külsö rendezési algoritmusok; partícionáló rendezések.

Program KP_Rend;

  Const

    maxP= 7;

    MaxMem = 14*1024; 

  Type

    Elemtip=Single;

    MemTip =Array[0..MaxMem] Of Elemtip;

    LinkP  =^Cell;

    Cell   =Record Fn:Word; d,l:Longint; link:LinkP End;

  Var

    F: Array[0..MaxP+1] Of File;

    FNev : String;

    E:Array[1..MaxP*(MaxP+1) div 2] Of Single;

   

    Mem: ^MemTip;

    M  : Longint;

    M2 : Longint;

    Rh : Longint;

    N  : Longint;

    P  : Longint;

    Nr :        

         Array[0..maxP+1] Of Longint;

    Top:LinkP;

    Ip   :Longint;

    Mbent:Longint;

Function Pvalaszt(N:Longint):Word;

  Const

    ab=0.002;

    Inf=10E10;

  Var

    P,PP,Op,Pm,Pn,k:Word;

    L,Lpk:Longint;

    Tp,Tmin,ab2:Single;

    V:Array[1..512] of Longint;

    Vp:Word;

Function Pmax(N:Longint):Word;

(* Pmax(N)=Min *)

  Var bal,jobb,k:Word;

    mn:Single;

  Begin

    mn:=M/N;

    bal:=1; jobb:=MaxP;

    While bal<jobb Do Begin

      k:=(bal+jobb) div 2;

      If E[k*(k-1)Shr 1+1]>mn Then

        bal:=k+1

      Else

        jobb:=k

    End;

    Pmax:=jobb;

  End;

  Begin

    Pn:=Pmax(N);

    If Pn<=3 Then

      Pvalaszt:=Pn

    Else Begin

      Tmin:=Inf;

      ab2:=2.0*ab;

      For P:=2 To Pn Do Begin

        Vp:=1; Tp:=0.0;

        V[1]:=N;

        While Vp>0 DO Begin

          L:=V[Vp]; Dec(Vp);

          If L<=M Then

            Tp:=Tp+ab2*L+2.0

          Else Begin

            Pm:=Pmax(L);

            If (Pm<=3)And(P>Pm) Or (Pm<P) Then

              Tp:=Tp+2*ab2*L+(Pm+1)*Round(L/M+0.5)+2*Pm

            Else Begin

              Tp:=Tp+ab2*L+(P+1)*Round(L/M+0.5);

              PP:=P*(P-1) Shr 1;

              For k:=1 To P Do Begin

                Lpk:=Trunc(L*E[PP+k]);

                Inc(Vp);

                V[Vp]:=Lpk;

              End

            End;

          End

        End;

        If Tp<Tmin Then Begin

          Tmin:=Tp;

          Op:=P;

        End

      End;

      Pvalaszt:=OP;

    End;

  End;

  Procedure Nyit;

    Var i:Integer;  Si:String;

      EF:File of Single;

  Begin

    Assign(EF,'E.dat'); Reset(EF);

    For i:=1 To MaxP*(MaxP+1) div 2 Do Begin

      Read(EF,E[i]);

    End;

    Close(EF);

    Val(ParamStr(1), M, i);

    Rh:=Sizeof(Elemtip);

    Assign(F[0],Fnev); Reset(F[0],1);

    N:=FileSize(F[0]) Div Rh;

    If Odd(M) Then Inc(M);

    M2:=M Div 2;

    GetMem(Mem,(M+1)*Rh);

    For i:=1 To maxP+1 Do Begin

      Str(i,Si);

      Assign(F[i],'tmp.'+Si);

      Rewrite(F[i],1);

      Nr[i]:=0;

    End;

    Nr[0]:=0;

    Top:=Nil;

  End;

  Procedure Zar;

    Var i:Word;

  Begin

    Close(F[0]);

    For i:=1 To maxP+1 Do Begin

      Close(F[i]);

      Erase(F[i]);

    End;

    FreeMem(Mem,M*Rh);

  End;

  Procedure Push(fn:Word; L,d:Longint);

    Var Ucell:LinkP;

  Begin

    Inc(Nr[fn],L);

    New(Ucell);

    Ucell^.d:=d; Ucell^.L:=L; Ucell^.fn:=fn;

    Ucell^.link:=Top;

    Top:=Ucell;

  End;

  Procedure Pop(Var fn:Word; Var L,d:Longint);

    Var dc:LinkP;

  Begin

    fn:=Top^.fn; d:=Top^.d; L:=Top^.L;

    Dec(Nr[fn],L);

    dc:=Top; Top:=dc^.link;

    Dispose(dc);

  End;

  Procedure MBeTolt(From:Word; L:Longint; Var Origo:Longint);

   

    Var bereksz:Longint;

    Begin

      bereksz:=(L-Mbent);

      If bereksz=0 Then Exit;

      If FilePos(F[From])<>Nr[From]*Rh Then

        Seek(F[From], Nr[From]*Rh);

      If bereksz<Ip Then Begin

        Origo:=Ip-bereksz;

        BlockRead(F[From], Mem^[Origo], Bereksz*Rh);

      End Else If M-Ip+1>=L Then Begin

        Origo:=Ip;

        BlockRead(F[From], Mem^[Ip+Mbent], Bereksz*Rh);

      End Else Begin;

        Origo:=1;

        BlockRead(F[From], Mem^[1], (Ip-1)*Rh);

        BlockRead(F[From], Mem^[Ip+Mbent], (L-(Ip+Mbent-1))*Rh);

      End;

    End;

  Procedure KiTolt(Fpos,Mpos,L:Longint);

  Begin

    Seek(F[0], Fpos*Rh);

    BlockWrite(F[0], Mem^[Mpos], L*Rh);

  End;

  Function Feloszt( Bal,Jobb: Longint): Longint ;

    Var Fe,E : Elemtip;

      Bal0,Kozep:Longint;

    Begin

      Bal0:=Bal;

      If Bal<Jobb Then Begin

        kozep:=(Bal+Jobb) Div 2;

        If Mem^[Jobb]<Mem^[Bal] Then Begin

          E := Mem^[Bal]; Mem^[Bal] := Mem^[Jobb]; Mem^[Jobb] := E;

        End;

        If Mem^[kozep]>Mem^[Jobb] Then Begin

          E := Mem^[Jobb]; Mem^[Jobb] := Mem^[kozep]; Mem^[kozep] := E;

        End;

        If Mem^[Bal]<Mem^[Kozep] Then Begin

          E := Mem^[Bal]; Mem^[Bal] := Mem^[kozep]; Mem^[kozep] := E;

        End;

        Fe:=Mem^[Bal];

        While True Do Begin

          Repeat Dec(Jobb) Until Mem^[Jobb] <= Fe;

          Repeat Inc(Bal) Until Mem^[Bal] >= Fe;

          If Bal < Jobb  Then  Begin

            E := Mem^[Bal]; Mem^[Bal] := Mem^[Jobb]; Mem^[Jobb] := E;

          End Else

            Break;

        End;

      End;

      Feloszt:=Jobb;

      E := Mem^[Jobb]; Mem^[Jobb] := Mem^[Bal0]; Mem^[Bal0] := E;

    End(*Feloszt*);

Procedure MFeloszt(Var fn:Word; Var L,d:Longint; P:Word);

Var

  Rem,  

  Reksz:Longint; 

  Fe:Array[1..maxP] Of Elemtip;

  Pr:Array[1..maxP] Of Longint; 

  FF:Array[0..maxP] Of Longint; 

  i,ufn,ud:Longint;

  mki:Longint;

Procedure FeValaszt(M,K,r:Longint);

 

 

  Var FZh,Zh,zfi:Longint;

    i:Word;

  Procedure ZValaszt(Bal,Jobb:Longint);

    Var fi,bzi,jzi:Longint;

    Begin

      bzi:=Bal Div Zh; jzi:=Jobb Div Zh;

      While (bzi+1<jzi) Or

            ((bzi<=jzi) And ((FF[bzi]=0) Or (FF[jzi]=0))) Do Begin

        fi:=Feloszt(Bal,Jobb);

        zfi:=fi Div Zh;

        If (fi Mod Zh >=r) And (FF[zfi]<fi) Then

          FF[zfi]:=fi;

        If Bal<=fi-1 Then ZValaszt(Bal,fi-1);

        Bal:=fi+1;   

        If Bal>Jobb Then exit;

        bzi:=Bal Div Zh;

     End ;

    End;

  Begin

    Zh:=r+(M-r*K) Div (K-1);

    For i:=0 To K-2 Do Begin

      FF[i]:=0;

    End; FF[K-1]:=M-1;

    ZValaszt(0,M-1);

  End;

  Procedure MemFeloszt(Bal,Jobb:Longint;fi,fj:Word);

 

  Var K,fk,B,J:Longint;

    Fel,E:Elemtip;

  Begin

    fk:=(fi+fj) Shr 1;

    B:=Bal; J:=Jobb;

    Fel:=Fe[fk];

    While True Do Begin

      While Mem^[B] < Fel Do Inc(B);

      While Mem^[J] > Fel Do Dec(J);

      If B < J  Then  Begin

        E := Mem^[B]; Mem^[B] := Mem^[J]; Mem^[J] := E;

        Inc(B); Dec(J);

      End Else

        Break;

    End;

    K:=J;

    FF[fk]:=K;

    If (fi<fk) And (Bal<=K) Then

      MemFeloszt(Bal,K, fi,fk-1);

    If (fk<fj) And (K<Jobb) Then

      MemFeloszt(K+1,Jobb, fk+1,fj);

  End;

  Begin

    For i:=1 To P Do Begin

      Pr[i]:=0;

      If FilePos(F[i])<>Nr[i]*Rh Then

        Seek(F[i], Nr[i]*Rh);

    End;

    If FilePos(F[P+1])<>Nr[P+1]*Rh Then

      Seek(F[P+1], Nr[P+1]*Rh);

    MBetolt(fn,M,mki);

    Mem^[0]:=Mem^[M];

    FeValaszt(M,P,Trunc((M/P)*0.3));   

             

    mki:=0;

    For i:=0 To P-1 Do Begin

      Fe[i+1]:=Mem^[FF[i]];

      Reksz:=FF[i]-mki+1;

      Inc(Pr[i+1], Reksz);

      If i+1=fn Then 

        BlockWrite(F[P+1], Mem^[mki], Reksz*Rh)

      Else

        BlockWrite(F[i+1],   Mem^[mki], Reksz*Rh);


      mki:=FF[i]+1;

    End;

    Mem^[0]:=Fe[1]; Mem^[M+1]:=Fe[P-1];

    Rem:=L-M;

    If Rem >M Then Reksz:=M Else Reksz:=Rem;

    BlockRead(F[fn], Mem^[1], Reksz*Rh);

    Dec(Rem,Reksz);

    While True Do Begin

      For i:=0 To P-1 Do FF[i]:=0;

      FF[P]:=Reksz; Mem^[Reksz+1]:=Fe[P-1];

      MemFeloszt(1,Reksz, 1,P-1);

      If Rem=0 Then Break;     

      mki:=1;

      For i:=1 To P Do If FF[i-1]<FF[i] Then Begin

         Reksz:=FF[i]-mki+1;

         Inc(Pr[i], Reksz);

         If i=fn Then

           BlockWrite(F[P+1], Mem^[mki], Reksz*Rh)

         Else

           BlockWrite(F[i],   Mem^[mki], Reksz*Rh);

         mki:=FF[i]+1;

      End;

      If Rem >M Then Reksz:=M Else Reksz:=Rem;

      BlockRead(F[fn], Mem^[1], Reksz*Rh);

      Dec(Rem,Reksz);

    End;

    MBent:=0; mki:=1;

    For i:=1 To P Do

      If (FF[i]>0) And (FF[i-1]<FF[i]) Then Begin

        Reksz:=FF[i]-mki+1;

        If (Reksz>MBent) Then Begin

          MBent:=Reksz; ufn:=i;

        End;

        mki:=FF[i]+1;

      End;

    mki:=1;     

    For i:=1 To P Do Begin

      If FF[i-1]<FF[i] Then

        Reksz:=FF[i]-mki+1

      Else

        Reksz:=0;

      Inc(Pr[i],Reksz);

      If Pr[i]<>0 Then Begin

        If i=ufn Then

          ud:=d

        Else Begin

         If (i=fn) Then Begin

           BlockWrite(F[P+1], Mem^[mki], Reksz*Rh);

           Push(P+1, Pr[i], d);

          End Else Begin

            BlockWrite(F[i], Mem^[mki], Reksz*Rh);

            Push(i, Pr[i], d);

          End;

        End;

        Inc(d,Pr[i]);

        Inc(mki,Reksz);

      End;

    End;

    Ip:=FF[ufn-1]+1;   

    L:=Pr[ufn];

    If ufn=fn Then fn:=P+1 Else fn:=ufn;

    d:=ud;

  End ;

Procedure BFeloszt(Var From:Word; Var L,d:Longint);

 

 

  Var

    Bal,Jobb:Longint;

    To1,To2:Word;

    Rem:Longint;

    Bereksz:Longint;

    K:Longint;      

    Bpr,Jpr:Longint;

    Ki:Longint;

    E,Fe:Elemtip;

Function FeValaszt2(Bal,Jobb,r:Longint):Longint;

 

  Var fi,Zb,Zj:Longint;

    E:Elemtip;

  Begin

    Zb:=Bal+r;

    Zj:=Jobb-r;

    While True Do Begin

      fi:=Feloszt(Bal, Jobb);

      If fi<Zb Then

        Bal:=fi+1

      Else If fi>Zj Then

        Jobb:=fi-1

      Else

        Break;

    End;

    FeValaszt2:=fi;

  End;

  Begin(* BFeloszt *);

    To1:=From+1; If To1>maxP Then To1:=1;

    To2:=To1+1;  If To2>maxP Then To2:=1;

    Bpr:=0; Jpr:=0;

    MBetolt(From,M,K); 

    Seek(F[To1] , Nr[To1]*Rh); 

    Seek(F[To2] , Nr[To2]*Rh);  

    Rem:=L-M;

    K:=FeValaszt2(1,M,Trunc(M*0.3));  

    Fe:=Mem^[K];

    Mem^[0]:=Fe; Mem^[M+1]:=Fe;

    While Rem>0 Do Begin 

      If K<M2 Then Begin

        If M-K>Rem Then Bereksz:=Rem Else Bereksz:=M-K;

        Ip:=K+1; Ki:=To2;

      End Else Begin

        If K>Rem Then Bereksz:=Rem Else Bereksz:=K;

        Ip:=K-Bereksz+1; Ki:=To1;

      End;

      Dec(Rem,Bereksz);

      BlockWrite(F[Ki], Mem^[Ip], Bereksz*Rh); 

      BlockRead(F[From], Mem^[Ip], Bereksz*Rh);

      If Ki=To1 Then Inc(Bpr,Bereksz) Else Inc(Jpr,Bereksz);

      K:=Feloszt(Ip,Ip+Bereksz-1);

      Bal:=Ip; Jobb:=Ip+Bereksz-1;

      While True Do Begin

        While Mem^[Bal] < Fe Do Inc(Bal);

        While Mem^[Jobb] > Fe Do Dec(Jobb);

        If Bal < Jobb  Then  Begin

          E := Mem^[Bal]; Mem^[Bal] := Mem^[Jobb]; Mem^[Jobb] := E;

          Inc(Bal); Dec(Jobb);

        End Else

          Break

      End;

      K:=Jobb;

    End;

    If Bpr=0 Then Begin   

      BelsoRendez(1,K);

      KiTolt(d,1,K);

      From:=To2; L:= L-K; d:=d+K;

      Ip:=K+1; Mbent:=M-K;

    End Else If Jpr=0 Then Begin

      BelsoRendez(K+1,M);

      KiTolt(d+Bpr+K,K+1,M-K);

      From:=To1; L:= Bpr+K; d:=d;

      Ip:=1; Mbent:=K;

    End Else Begin

      Inc(Bpr,K); Inc(Jpr,M-K);

      If K<M2 Then Begin 

        BlockWrite(F[To1], Mem^[1], K*Rh);

        Push(To1,Bpr,d);

        Ip:=K+1; Mbent:=M-K;

        From:=To2; L:=Jpr; d:=d+Bpr;

      End Else Begin

        BlockWrite(F[To2], Mem^[K+1], (M-K)*Rh);

        Push(To2,Jpr,d+Bpr);

        Ip:=1; Mbent:=K;

        From:=To1; L:=Bpr; d:=d;

      End;

    End;

  End;

Procedure Rendez(FNev : String);

  Var

    fn:Word;         

    L, 

    d,  

    Origo:Longint;

Begin (* Rendez *)

  Nyit;

  Ip:=1; Mbent:=0;

  fn:=0; L:=N; d:=0; 

  Repeat

    If L<=M Then Begin  

      MBeTolt(fn,L,Origo);

      BelsoRendez(Origo,Origo+L-1);

      KiTolt(d,Origo,L);

      L:=0; Ip:=1; Mbent:=0;

    End Else Begin

      P:=Pvalaszt(L);

      If P=2 Then Begin

        BFeloszt(fn,L,d)  

      End Else Begin

        MFeloszt(fn,L,d,P);

      End;

    End;

    If (L=0) And (Top<>Nil) Then Begin

      Pop(fn,L,d);

      Ip:=1; MBent:=0;

    End;

  Until L=0;

  Zar;

End (* Rendez *);

Begin

  FNev:= 't.dat';

  Rendez(FNev);

End.

8. Dinamikus programozás (pénzváltás, optimális bináris keresöfa).

Program Valto;

(* A penzvaltas problema

Input: p1,...pn, E pozitiv egeszek

Output: Eloallithato-e a E osszeg a p1,...,pn penzekkkel?

       Azaz van-e olyan S resze 1..n, hogy Sum(pi: i elem S)=E

*)

Const

  MaxN=500;

Var

  N:Word;

  E:Word;

  P:Array[1..MaxN] of Word;

  Van:Boolean;

Procedure Beolv; 

  Var

    Bef:Text;

    i:Word;

  Begin

    Assign(Bef,'VALTO.BE'); Reset(Bef);

    ReadLn(Bef,E);

    ReadLn(Bef,N);

    For i:=1 To N Do Begin

      Read(Bef,P[i]);

    End;

    Close(Bef);

  End;

Procedure KiIr;

  Var

    Kif:Text;

    i,k:Word;

  Begin

    Assign(KiF,'VALTO.KI'); Rewrite(KiF);

    If Van Then WriteLn(Kif,'Van megolds')

           Else WriteLn(Kif,'Nincs megolds');

    Close(KiF);

  End;

Function V(X,i:Word):Boolean;

  Begin

    V:=(X=P[i]) Or

       (i>1) And V(X,i-1) Or

       (i>1) And (X>P[i]) And V(X-P[i],i-1) ;

  End;

Function Vm(E:Word):Boolean;

Const

  MaxE=100;

Var

  VT:Array[0..MaxE,1..MaxN] Of 0..2;

  i,j,x:Word;

Function V(X,i:Word):Boolean;

  Var Jo:Boolean;

  Begin

    If VT[x,i]<2 Then    

      V:=VT[x,i]=1

    Else Begin

      Jo:=(X=P[i]) Or (i>1) And

         ((X>P[i]) And V(X-P[i],i-1) Or V(X,i-1));

      VT[x,i]:=Ord(Jo);  

      V:=Jo;

    End;

  End;

  Begin

    For i:=1 To N Do  

      For x:=1 To E Do VT[x,i]:=2;

    V(E,N);

    Vm:=VT[E,N]=1;

  End;

Function VT(E:Word):Boolean;

Const

  MaxE=100;

Var

  VTm:Array[0..MaxE,1..MaxN] Of Boolean;

  i,x:Word;

  Begin

    For i:=1 To N Do   

      For x:=1 To E Do VTm[x,i]:=False;

    If P[1]<=E Then VTm[P[1],1]:=True;

    For i:=2 To N Do

      For x:=1 To E Do

        VTm[x,i]:=VTm[x,i-1] Or (x>=P[i]) And VTm[x-P[i],i-1];

    Vt:=VTm[E,N];

  End;

Function V1T(E:Word):Boolean;

Const

  MaxE=60000;

Var

  VT:Array[0..MaxE] Of Boolean;

  i,x:Word;

  Begin

    For x:=1 To E Do VT[x]:=False;

    VT[0]:=True;

    If P[1]<=E Then VT[P[1]]:=True;

    For i:=2 To N Do

      For x:=E DownTo 1 Do

        VT[x]:=VT[x] Or (x>=P[i]) And VT[x-P[i]];

    V1T:=VT[E];

  End;

Begin

  Beolv;

  Van:=V(E,N);

  WriteLn(Van);

  KiIr;

End.

Unit BinKerFa ;

Interface

  Type

    Kulcstip = 0..1;(*a redezési mezö tipusa*)

    Adattip  = 0..1; (* az adatmezö típusa *)

    Elemtip = Record

         kulcs: Kulcstip;

         adat : Adattip

       End;

    BinFa = ^BinFaPont;

    BinFaPont = Record

           adat : Elemtip;

           bal, jobb : BinFa

         End;

 

    Function Keres(F : BinFa;

            K : Kulcstip) : BinFa;

    Procedure Bovit0(Var F : BinFa; (* a bövítendö fa *)

            X : Elemtip); (* a bövítendö elem *)

    Procedure Bovit(Var F : BinFa;  (* a bövítendö fa *)

            X : Elemtip;  (* a bövítendö elem *)

            Var Tobb : Boolean ); (* lehet többszörös elem ? *)

    Procedure Torol(Var F : BinFa;

            K : Kulcstip;   (* a törlendö pont kulcsa  *)

            Var Volt : Boolean); (* volt ilyen pont ? *)

Implementation

  Function Keres(F : BinFa; K : Kulcstip) : BinFa;

    Begin

      While (F <> Nil) And (K<>F^.adat.kulcs) Do

        If K < F^.adat.kulcs Then

          F := F^.bal

        Else

          F := F^.jobb;

      Keres:= F;

    End (* Keres *) ;

  Procedure Bovit0(Var F : BinFa;

                       X : Elemtip);

 

    Begin

      If F = Nil Then Begin

        New(F);

        F^.adat:= X;

        F^.bal:= Nil; F^.jobb:= Nil;

      End Else Begin

        If X.kulcs < F^.adat.kulcs Then

          Bovit0(F^.bal, X)

        Else

          Bovit0(F^.jobb, X)

      End;

    End (* Bovit0 *) ;

  Procedure Bovit(Var F : BinFa;

                      X : Elemtip;

                  Var Tobb : Boolean );

    Var

      P, Apa, Ujp : BinFa;

      Nincs : Boolean;

    Begin

      New(Ujp); Nincs := True;

      With Ujp^ Do Begin

        adat := X ;

        bal := Nil; jobb := Nil

      End;

      If F = Nil Then

        F := Ujp

      Else Begin

        P := F;

        While (P <> Nil) Do Begin

          Apa := P;

          If X.kulcs < P^.adat.kulcs Then

            P := P^.bal

          Else

            If X.kulcs > P^.adat.kulcs Then

              P := P^.jobb

          Else Begin

            Nincs:= False;

            If Not Tobb Then Begin

              Tobb:= True; Dispose(Ujp); Exit

            End Else

              p:= p^.jobb

          End

        End;

        If X.kulcs < Apa^.adat.kulcs Then

          Apa^.bal := Ujp

        Else

          Apa^.jobb := Ujp

      End;

      Tobb := Not Nincs

    End (* Bovit *) ;

  Procedure Torol(Var F : BinFa;

                      K : Kulcstip;

                  Var Volt : Boolean);

    Var

      P, Apa, T : BinFa;

      Tovabb : Boolean;

    Begin

      P := F; Apa := P; Tovabb := True;

      (* a K kulcsu pont keresese *)

      While (P <> Nil) And Tovabb Do

        If K < P^.adat.kulcs Then Begin

          Apa := P; P := P^.bal

        End Else If K > P^.adat.kulcs Then Begin

          Apa := P; P := P^.jobb

        End Else

          Tovabb := False;

     

      Volt := Not Tovabb;

      If Volt Then Begin

      (* P^.adat.kulcs=K, Apa a P pont apja, ha P=F akkor P=Apa *)

        T := P; (* a törlendö pont T *)

        If P^.bal = Nil Then 

          If P = Apa^.bal Then

            Apa^.bal := P^.jobb

          Else If P = Apa^.jobb Then

            Apa^.jobb := P^.jobb

          Else F := P^.jobb

        Else If P^.jobb = Nil Then

          If P = Apa^.bal Then

            Apa^.bal := P^.bal

          Else

            If P = Apa^.jobb Then

              Apa^.jobb := P^.bal

          Else

            F := P^.bal

        Else Begin     

           T := P^.jobb; Apa := T;

           While T^.bal <> Nil Do Begin

             Apa := T; T := T^.bal

           End;

           (* P helyebe T kerül *)

           P^.adat := T^.adat;

           If T = Apa Then

             P^.jobb := T^.jobb

           Else

             Apa^.bal := T^.jobb;

         End;

        Dispose(T)

      End

    End (* Torol *) ;

End (* BinKerFa *) .

9. A mohó stratégia (egységnyi végr. munkák ütemezése, Huffman kód).

Procedure EgyUtemez(    K : Haszon;

                        H : Hatarido;

                    Var B : Beosztas;

                    Var P : Real    );

  Var

    i,j : Integer;

  Begin

    P := 0.0;

    For i := 1 To N Do B[i] := 0;

    For i := 1 To N Do Begin

      If H[i] > N Then

        j := N

      Else

        j := H[i];

      While (j > 0) And (B[j] = 0) Do

        Dec(j);

      If j > 0 Then Begin



          B[j] := i; P := P + K[i]

      End

    End;

  End (* EgyUtemez *);

Program Huffman_Kod;

Uses MPsor;

  Const n=???;

  Type

    Gyakori= Array[0..2*n-1] Of Longint;

    Fa= Array[1..2*n-1] Of Integer;

  Function Kis(Var X,Y: Elemtip): Boolean;

 

      Begin

        Kis:= P[X] <= P[Y]

      End;

  Procedure Huffman(Var P: Gyakori; Var T: Fa);

    Var S: MPsor.Tipus; i,pont,x,y: Word;

   

  Begin

    Letesit(S, Kis);

    For i:= 1 To n Do Sorba(S,i);

    T[2*n-1]:=0;

    pont:= n;               

    For i:= 1 To n-1 Do Begin  

      Sorbol(S,x); Sorbol(S,y);

      Inc(pont);   

      T[x]:= -pont; T[y]:= pont;

      P[pont]:= P[x]+ P[y];

      Sorba(S,pont);

    End;

  End;

  Procedure KiIr(Var T:Fa; i:Word);

    Begin

      If T[i]<>0 Then Begin

        KiIr(T,Abs(T[i]));

        If T[i]<0 Then Write(0:1)

                  Else Write(1:1);

      End;

    End;

Var

  T:FA; P:Gyakori; i:Word;

Begin

  For i:= 1 To n Do Read(P[i]);

  Huffman(P,T);

  For i:= 1 To n Do Begin KiIr(T,i); writeln; End

End.

10. Megoldás szisztematikus keresése visszalépéssel.

   

  Procedure UresX(Var X:MTer);Forward;

    

  Function EFiu(Var X: MTer): Boolean; Forward;

    

  Function Testver(Var X: MTer): Boolean; Forward;

   

  Function Apa(Var X: MTer):Boolean;  Forward;

   

  Function Megoldas (Var X: MTer): Boolean; Forward;

  Function LehetMego(Var X: MTer): Boolean; Forward;

   

   

Procedure RKeres(X:MTer);

Begin

  If Megoldas(X) Then Begin

    X0:=X;

    Van:=True; Exit

  End;

  If Not EFiu(X) Then Exit;

  Repeat         

    If Not LehetMego(X) Then

      Continue; 

    RKeres(X);

    If Van Then

  Until Not Testver(X)

End;

Procedure Keres(X:MTer);

  Var Elsore: Boolean;

  Begin (* Keres *)

    If Not LehetMego(X) Then Exit;

    Elsore:=True;

    While True Do

      If Elsore Then Begin

        If Megoldas(X) Then Begin 

          X0:=X;

          Break

        End;

        Elsore:=(EFiu(X) And LehetMego(X));

      End Else If Testver(X)  Then

        Elsore:=LehetMego(X)

      Else If Not Apa(X) Then 

        Break;

  End (* Keres *);

11. Megoldás szisztematikus keresése elágazás-korlátozással.

Program Elagazas_Korlatozas;

  Type

    MTer  = Record End;(* a megoldaster tipusa *)

    PriSor= Record End;(* a maximumos prioritasi sor tipusa *)

  Const

    Inf=1.0E10;

  Procedure Uresit(Var S:PriSor);

    Begin  End;

  Procedure SorBa(Var S:PriSor; X:MTer);

    Begin  End;

  Procedure SorBol(Var S:PriSor; Var X:MTer);

    Begin  End;

  Procedure Megszuntet(Var S:PriSor);

    Begin  End;

  Function Ures(S:PriSor):Boolean;

    Begin  End;

 

  Procedure UresX(Var X:MTer);

   

    Begin End;

  Function EFiu(Var X: MTer): Boolean;

   

    Begin End;

  Function Testver(Var X: MTer): Boolean;

   

    Begin End;

  Function Megoldas(Var X: MTer): Boolean;

   

  Begin End;

  Function LehetMego(Var X: MTer): Boolean;

   

   

   Begin End;

  Function C(Const X: MTer): Real;

   

  Begin End;

  Function AK(Var X: MTer): Real;

   

  Begin End;

  Function FK(Var X: MTer): Real;

   

    Begin End;

Procedure BBKeres1(X:MTer; Var X0:MTer; Var C0:Real);

 

 

 

Var

  S:PriSor; 

  G_F_K:Real; 

Begin (* BBKeres1 *)

  UresX(X0);

  G_F_K:=Inf;

  If Not LehetMego(X) Then Exit;   

  Uresit(S);    

  SorBa(S,X);  

  While Not Ures(S) Do Begin       

    SorBol(S,X);

    If G_F_K<=AK(X) Then Exit;   

    If EFiu(X) Then

    Repeat 

      If Not LehetMego(X) Then 

        Continue;

      If AK(X)>=G_F_K Then Continue;

      If Megoldas(X) And  

         (C(X)<G_F_K) Then  Begin  

        G_F_K:=C(X);

        X0:=X;

      End;

      SorBa(S,X);

    Until Not Testver(X);    

  End;

  C0:=G_F_K;

End (* BBKeres1 *);

Procedure BBKeres2(X:MTer; Var X0:MTer; Var C0:Real);

 

 

 

Var

  S:PriSor; 

  G_F_K:Real; 

Begin (* BBKeres2 *)

  C0:=Inf;

  If Not LehetMego(X) Then Exit;

  G_F_K:=FK(X); 

  Uresit(S);      

  SorBa(S,X); 

  While Not Ures(S) Do Begin

    SorBol(S,X);

    If AK(X)>G_F_K Then Begin

      Megszuntet(S);

      Exit;      

    End;

    If EFiu(X) Then 

    Repeat

      If Not LehetMego(X) Then

        Continue;

      If G_F_K<AK(X) Then Continue;

      If Megoldas(X) And (C(X)<=G_F_K)

      Then Begin 

        X0:=X;    

        G_F_K:=C(X)

      End Else If FK(X)<G_F_K Then

        G_F_K:=FK(X);    

      SorBa(S,X);

    Until Not Testver(X); 

  End;

  C0:=G_F_K;

End (* BBKeres2 *);

Begin End.

12. Absztrakt adattipusok: Verem, Sor, Lista, Prioritási sor, Sorozat, Halmaz, Függvény.

Unit Verem;

  Interface

      Elemtip = ???;(*a generikus parameter*)

      Tipus = Pointer; (*a Veremp adattipus fo tipusa*)

      Verem = Verem0.Tipus;

   

      Procedure Letesit(Var V : Tipus);

      Procedure Megszuntet(Var V : Tipus);

      Procedure Uresit(Var V : Tipus);

      Procedure VeremBe(Var V : Tipus; X : Elemtip);

      Procedure VeremBol(Var V : Tipus; Var X : Elemtip);

      Function  Urese(V : Tipus) : Boolean;

      Procedure Teteje(V : Tipus; Var X : Elemtip);

      Procedure Torol(Var V : Tipus);

  Implementation

End (* Verem0 *).

Unit Sor ;

  Interface

    Type

      Elemtip = ???; (*generikus parameter*)

      Tipus  = Pointer; (* a Sor adattipus tipusa *)

   

    Procedure Letesit(Var S : Tipus);

    Procedure Megszuntet(Var S : Tipus);

    Procedure Uresit(Var S : Tipus);

    Function  Elemszam(S : Tipus) : Word;

    Procedure SorBa(Var S : Tipus; X : Elemtip);

    Procedure SorBol(Var S : Tipus; Var X : Elemtip);

    Procedure Elso(    S : Tipus; Var X : Elemtip);

    Procedure Torol(Var S : Tipus);

Unit Lista;

  Interface

    Type

      Elemtip = ???;  (* a lista elemtipusa *)

      Tipus = Pointer;  (* a lista adattipus tipusa *)

   

      Procedure  Letesit(Var L : Tipus);

      Procedure  Uresit(Var L : Tipus);

      Function   Urese(L : Tipus) : Boolean;

      Function   Elejen(L : Tipus) : Boolean;

      Function   Vegen(L : Tipus) : Boolean;

      Procedure  Elejere(Var L : Tipus);

      Procedure  Vegere(Var L : Tipus);

      Procedure  Tovabb(Var L : Tipus);

      Procedure  Kiolvas(    L : Tipus; Var X : Elemtip);

      Procedure  Modosit(Var L : Tipus; Y : Elemtip);

      Procedure  Bovit(Var L : Tipus; Y : Elemtip);

      Procedure  Torol(Var L : Tipus);

      Procedure  Kapcsol(Var L1,L2 : Tipus);

Unit PriSor ;

 

Interface

  Type

    Elemtip = ???;

    RendRelTip = Function (Var X,Y: Elemtip): Boolean;

    Tipus = Pointer;(*az adattipus fö tipusa*)

 

    Procedure Letesit(Var S : Tipus; M: RendRelTip);

    Procedure Megszuntet(Var S : Tipus);

    Procedure Uresit(Var S : Tipus);

    Function  Elemszam(S : Tipus) : Word;

    Procedure SorBa(Var S : Tipus; Y : Elemtip);

    Procedure SorBol(Var S : Tipus; Var X : Elemtip);

    Procedure Elso(S : Tipus; Var X :Elemtip);

    Procedure Torol(Var S: Tipus);

Unit Sorozat ;

Interface

  Type

    Elemtip = ???;(* a sorozat elemeinek tipusa *)

    Tipus = Pointer;(*az adattipus fö tipusa*)

 

    Procedure Letesit(Var S : Tipus);

    Procedure Megszuntet(Var S : Tipus);

    Procedure Uresit(Var S : Tipus);

    Function  Elemszam(S : Tipus) : Word;

    Procedure Bovit(Var S : Tipus; i : Word; Y : Elemtip);

    Procedure Torol(Var S : Tipus; i : Word);

    Procedure Kiolvas(    S : Tipus; i : Word; Var X : Elemtip);

    Procedure Modosit(Var S : Tipus; i : Word; Y : Elemtip);

Unit Halmaz ;

  Interface

    Type

      Elemtip = ???

      Tipus = Pointer;  (* az adattipus fö tipusa *)

      Iterator = Pointer; (* az itertor tipusa *)

   

      Procedure Letesit(Var H : Tipus);

      Procedure Megszuntet(Var H : Tipus);

      Procedure Uresit(Var H : Tipus);

      Function  Eleme(H : Tipus; E : Elemtip) : Boolean;

      Function  Elemszam(H : Tipus) : Word;

      Procedure Bovit(Var H : Tipus; Y : Elemtip);

      Procedure Torol(Var H : Tipus; E : Elemtip);

      Procedure IterKezd(    H : Tipus; Var I : Iterator);

      Procedure IterAd(Var I : Iterator; Var X : Elemtip);

      Function  IterVege(I : Iterator) : Boolean;

(* Halmaz *)

Unit Fuggveny;

  Interface

    Type

      Kulcstip= ???;       (* a Függvény elemeinek kulcstípusa  *)

      Adattip = ???;        (* a Függvény elemeinek adattípusa   *)

      Elemtip = Record

                  kulcs : Kulcstip;

                  adat  : Adattip

                End;

      Tipus = Pointer;    (* az adattípus reprezentáló típusa *)

      Iterator = Pointer; (* az iterátor típusa *)

    

      Procedure Letesit(Var F : Tipus);

      Procedure Megszuntet(Var F : Tipus);

      Procedure Uresit(Var F : Tipus);

      Function  Eleme(F : Tipus; K : Kulcstip) : Boolean;

      Function  Elemszam(F : Tipus) : Word;

      Procedure Kiolvas(    F : Tipus; K : Kulcstip; Var A : Adattip);

      Procedure Modosit(Var F : Tipus; K : Kulcstip; A : Adattip);

      Procedure Bovit(Var F : Tipus; Y : Elemtip);

      Procedure Torol(Var F : Tipus; K : Kulcstip);

      Procedure IterKezd(    F : Tipus; Var I : Iterator);

      Procedure IterAd(Var I : Iterator; Var K : Kulcstip);

      Function  IterVege(I : Iterator) : Boolean;

(* Fuggveny *)

13. Fák, fák ábrázolása, fabejáró algoritmusok.

Type

  Elemtip=???;

  Fa=^FaPont;

  FaPont=Record

           Adat:Elemtip;

           Efiu,Testver:Fa;

           Apa:FA

         End;

  MuvelTip=Procedure(Var X:Elemtip);

Procedure Bejar(P:Fa; M:MuvelTip);

Begin

  M(P^.Adat);

  P:=P^.Efiu;

  While P<>Nil Do Begin

    Bejar(P,M);

    P:=P^.Testver;

  End;

End;

Procedure Bejar2(P:Fa; M:MuvelTip);

Begin

  M(P^.Adat);

  If P^.Efiu<> Nil Then

    Bejar2(P^.Efiu,M);

  If P^.Testver<> Nil Then

    Bejar2(P^.Testver,M);

End;

Procedure VBejar1(P:Fa; M:MuvelTip);

Var V:Verem; Elsore:Boolean;

Begin

  Letesit(V); Elsore:=True;

  VeremBe(V,Nil);

  While P<>Nil Do Begin

    If Elsore Then Begin

      M(P^.Adat);

      If P^.Efiu<> Nil Then Begin

        VeremBe(V,P);

        P:=P^.Efiu;

      End Else

        Elsore:=False

    End Else Begin

      P:=P^.Testver;

      If P<>Nil Then

        Elsore:=True

      Else

        VeremBol(V,P);

    End;

  End;

End;

Procedure ABejar(P:Fa; M:MuvelTip);

Begin

  While P<>Nil Do Begin

    M(P^.Adat);

    While (P^.Efiu<>Nil) Do Begin

      P:=P^.Efiu;

      M(P^.Adat);

    End;

    While (P<>Nil) And (P^.Testver=Nil) Do

      P:=P^.Apa;

    If P<>Nil Then

      P:=P^.Testver;

  End;

End;

Procedure VBejar(P:Fa; M:MuvelTip);

Var V:Verem;

Begin

  Letesit(V); VeremBe(V,Nil);

  While P<>Nil Do Begin

    M(P^.Adat);

    While (P^.Efiu<>Nil) Do Begin

      If P^.Testver<>Nil Then

        VeremBe(V,P^.Testver);

      P:=P^.Efiu;

      M(P^.Adat);

    End;

    If P^.Testver<>Nil Then

      P:=P^.Testver

    Else

      VeremBol(V,P);

  End;

End;

Procedure SzBejar(P:Fa; M:MuvelTip);

Var S:Sor;

Begin

  Letesit(S);

  SorBa(S,P);

  While Elemsazam(S)>0 Do Begin

    SorBol(S,P);

    M(P^.Adat);

    P:=P^.Efiu;

    While (P<>Nil) Do Begin

      SorBa(S,P);

      P:=P^.Testver;

    End;

  End;

End;

 

Találat: 1378