Tools

Ezen a lapon egy modulgyűjtemény látható. Olyan eljárások és függvények, melyekre bármikor szükségünk lehet. A legtöbbjükben van valami egyszerű kis trükk, gondolat. Azért, hogy ezeket ne kelljen mindig újra kitalálni és megírni, itt összegyűjtöttem őket. Természetesen tartalma folyamatosan bővülni fog.

(* várakozás *)

Procedure Delay(Sec, MSec: Word);
Var Idopont: TDateTime;
Begin
Idopont:= Now + EncodeTime(0,Sec Div 60, Sec Mod 60, MSec);
While Now<Idopont Do Application.ProcessMessage;
End;

(* prímszám vizsgáló *)

Function Prime(S: LongInt): Boolean;
Var J: Word;
Begin
Prime:= False; If S In [0,1] Then Exit;
Prime:= True; If S In [2,3] Then Exit;
Prime:= False; If (S Mod 6<>1) And (S Mod 6<>5) Then Exit;
Prime:= True;
For J:= 2 To Round(Sqrt(S)) Do If (S Mod J)=0 Then
Begin Prime:= False; Break End;
End;

(* szökőév vizsgáló *)

Function SzokoEv(Ev: Word): Boolean;
Begin
SzokoEv:= (Ev Mod 4 = 0) And (Ev Mod 100 <> 0) Or (Ev Mod 400 = 0);
End;

(* faktoriális rekurzióval *)

Function Fakt(N: Byte): LongInt;
Begin
If N>0 Then Fakt:= N*Fakt(N-1) Else Fakt:= 1;
End;

(* egész-e egy valós szám *)

Function EgeszE(R: Real): Boolean;
Begin
EgeszE:= Frac(R)=0.0;
End;

(* nyomtató állapotának vizsgálata *)

Function PrinterStatus: Boolean;
Begin
PrinterStatus:= False;
With CPU Do
Begin
    AH:= 2; DX:= 0; Intr($17,CPU);
If (AH And $B8)=$90 Then PrinterStatus:= True;
End;
End;

(* véletlen +1, -1 *)

Function RndM1P1: Integer;
Begin
  RndM1P1:= 1-2*Random(2);
End;

(* permutáció *)

//Permutáció deklarációs előzmények:

Type St8=String[8];

Const M=1*2*3*4*5*6*7*8;

Var PT: Array[1..M] Of St8;
    S: St8;

Procedure Permut(I: Word);
Var Ind: Word;
    J: Word;
Ch: Char;
Begin
If I=1 Then Begin Inc(Ind); PT[Ind]:= S End Else
Begin
Permut(I-1);
For J:= 1 To I-1 Do
Begin
Ch:= S[J]; S[J]:= S[I]; S[I]:= Ch; Permut(I-1);
Ch:= S[J]; S[J]:= S[I]; S[I]:= Ch;
End;
End;
End;

//Meghívása:
  Ind:= 0; S:= '12345678'; Permut(8);  //Permutáció vége

(* legnagyobb közös osztó *)

Function LNKO(A,B: Word);
Var M: Word;
Begin
  LNKO:= 0; If A+B=0 Then Exit;
If A=0 Then Begin LNKO:= B; Exit End;
If B=0 Then Begin LNKO:= A; Exit End;
Repeat
    M:= A Mod B; A:= B; B:= M;
Until M=0;
  LNKO:= A;
End;

(* egy dátum a hét melyik napjára esik *)

Function NapNev(E,H,N: Word): Byte;
Var A: Word;
Begin
  A:= E+H+N+((8*H+1) Div 5)+(E Div 4)-(E Div 100)+(E Div 400)+1;
NapNev:= A Mod 7;     //(V-S:0123456)
End;

(* fájl létezésének vizsgálata *)

Function FileExists(FileName: String): Boolean;
Var Fil: File;
Begin
FileExists:= False;
AssignFile(Fil,FileName); {$I-}Reset(Fil);{$I+}
If IOResult= 0 Then
Begin
FileExists:= True;
CloseFile(Fil);
End;
End;

(* előjelfüggvény *)

Function Sign(X: Real): Integer;
Begin
If X<0 Then Sign:= -1 Else If X>0 Then Sign:= 1 Else Sign:= 0;
End;

(* 10-es alapú logaritmus *)

Function Lg(X: Real): Real;
Const Ln10=2.302585092994;
Begin
  Lg:= Ln(X)/Ln10;
End;

(* egy tömb elemei közül a rosszak kiszórása *)

Const M=100;

Var A, B: Array[1..M] Of Byte;
    Ma, Mb: Byte;

Procedure Feltolt;
Var I: Byte;
Begin
For I:= 1 To M Do
Begin A[I]:= Random(256); Write(A[I]:4) End;
  Ma:= M; Mb:= 0;
End;

Function Jo(C: Byte): Boolean;
Begin
Jo:= C>=40;
End;

Procedure Valogat;
Var I, J: Byte;
Begin
  I:= 1;
While I<Ma Do
Begin
While Not Jo(A[I]) Do
Begin
      Inc(Mb); B[Mb]:= A[I];
For J:= I To Ma-1 Do A[J]:= A[J+1]; A[Ma]:= 0; Dec(Ma);
End;
    Inc(I);
End;
End;

Procedure Kepre;
Var I: Byte;
Begin
For I:= 1 To Ma Do Write(A[I]:4); WriteLn;
For I:= 1 To Mb Do Write(B[I]:4);
End;

Begin
Randomize; Feltolt; Valogat; Kepre;
End.

(* rendezések *)

Procedure Kozvetlen;
Var I, J: Word;
    T: Array[0..N] Of Word;

P: Word;
Begin
For I:= 0 To N-1 Do For J:= I+1 To N Do
If T[I]>T[J] Then
Begin
    P:= T[I];
    T[I]:= T[J];
    T[J]:= P;
End;
End;

Procedure Buborek;
Var I, J: Word;
    T: Array[0..N] Of Word;

P: Word;
Begin
For J:= 0 To N-1 Do
For I:= 0 To N-1 Do
If T[I]>T[I+1] Then
Begin
    P:= T[I];
    T[I]:= T[I+1];
    T[I+1]:= P;
End;
End;

Procedure JBuborek; (* javított buborék *)
Var I: Word;

    T: Array[0..N] Of Word;

VoltCsere: Boolean;
    P: Word;
Begin
While VoltCsere Do
Begin
VoltCsere:= False;
For I:= 0 To N-1 Do
If T[I]>T[I+1] Then
Begin
VoltCsere:= True;
      P:= T[I];
      T[I]:= T[I+1];
      T[I+1]:= P;
End;
End;
End;

Procedure Shell;
Var I, G: Word;

    T: Array[0..N] Of Word;

VoltCsere: Boolean;
    P: Word;
Begin
  G:= (N+1) Div 2;
Repeat
Repeat
VoltCsere:= False;
For I:= 0 To N-G Do
If T[I]>T[I+G] Then
Begin
        P:= T[I];
        T[I]:= T[I+G];
        T[I+G]:= P;
VoltCsere:= True;
End;
Until Not VoltCsere;
    G:= G Div 2;
Until G=0;
End;

Procedure Kivalasztas;
Var I, J: Integer;

    T: Array[0..N] Of Word;

    P: Integer;
Lk, Lki: Word;
Begin
  I:= -1;
While I<N-1 Do
Begin
Lk:= T[I+1]; Lki:= I+1;
For J:= I+1 To N Do If T[J]<Lk Then
Begin
Lk:= T[J];
Lki:= J;
End;
If I+1<>Lki Then
Begin
      P:= T[I+1];
      T[I+1]:= T[Lki];
      T[Lki]:= P;
End;
    Inc(I);
End;
End;

Procedure Beszuras;
Var I, J, K: Word;

    T: Array[0..N] Of Word;

    P: Word;
Begin
For I:= 0 to N do
Begin
    J:= I;
While (J>0) And (T[J-1]>T[I]) Do (* lineáris keresés *)
Dec(J);
    P:= T[I];
For K:= I DownTo J Do T[K]:= T[K-1];
    T[J]:= P;
End;
End;

Procedure JBeszuras; (* javított beszúrás *)
Var I, J, K: Word;

    T: Array[0..N] Of Word;

    P: Word;
    Ah, Fh, M: Word;
Begin
For I:= 0 To N Do
Begin
    Ah:= 0; Fh:= I-1; J:= I;
if T[I]<T[Fh] Then
Begin
Repeat (* bináris keresés *)

        M:= (Ah+Fh) Div 2;
If T[M]>=T[I] Then Fh:= M Else Ah:= M+1;
Until Ah=Fh;
While J>Fh do

Dec(J);
End;
    P:= T[I];
For K:= I DownTo J Do T[K]:= T[K-1];
    T[J]:= P;
End;
End;

Procedure QuickSort(Ki, Vi: Integer); (* gyors rendezés *)
Var A, F: Integer;

    T: Array[0..N] Of Word;

    K: Integer;
    P: Word;
Begin
  A:= Ki;
  F:= Vi;
  K:= T[(Ki+Vi) Div 2];
Repeat
While T[A]<K Do Inc(A);
While T[F]>K Do Dec(F);
If A<=F Then
Begin
If A<F Then
Begin
        P:= T[A];
        T[A]:= T[F];
        T[F]:= P;      

End;
      Inc(A);
Dec(F);
End;
Until A>F;
If KI<F Then QuickSort(Ki,F);
If A<Vi Then QuickSort(A,Vi);
End;

(* string validálás *)

Function ValidSt(S: String): String;

Var I, N: Byte;
Ws: String;
    Van: Boolean;
Begin
  N:= Length(S); ValidSt:=''; If N=0 Then Exit; Ws:= S;
While (N>0) And (Ws[N]=' ') Do
Begin Ws:= Copy(Ws,1,N-1); Dec(N) End; If Ws='' Then Exit;
While Ws[1]=' ' Do Begin Ws:= Copy(Ws,2,N-1); Dec(N) End;
  Van:= True;
If N>3 Then While Van Do
Begin
    Van:= False; N:= Length(Ws);
For I:=2 To N-1 Do If (Ws[I]=' ') And (Ws[I+1]=' ') Then
Begin
      Van:= True; Ws:= Copy(Ws,1,I) + Copy(Ws,I+2,N-I-1);
End;
End;
ValidSt:= Ws;
End;