Ha egy derékszögű háromszög oldalainak mérőszáma egész, akkor ezt a három mérőszámot Pitagoraszi számhármasnak nevezzük. A legkisebb és talán legismertebb ilyen három szám: 3,4 és 5. (3² + 4² = 5²). Valamint a kőművesek által, a házak alapjainak derékszögű kijelölésére régóta használt: 60, 80 és 100 (cm), mely az előző számsor 20-sorosa (azaz mint két háromszög egymáshoz hasonló).

         Az itt látható programmal tetszőleges létező (a számítógép illetve a használt programnyelv lehetőségei szerinti) Pitagoraszi számhármas meghatározható (kihagyás és hasonlóság miatti ismétlés nélkül). A képzési szabály:

         A = M² - N²

         B = 2*M*N

         C = M² + N²

ahol M>N, az M és N közül az egyik páros a másik páratlan, valamint M és N relatív prímek.

         A program az eredményeket egy StringGridben helyezi el, mely sorainak számát dinamikusan növeli. A próbafuttatás M=100-ig történt, és 2040 számhármast állított elő.

         A futtatás eredménye:

         A program listája:

unit UPitagorasz;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, 

  Controls, Forms, Dialogs, Grids, StdCtrls;

type
  TfmPitagorasz = class(TForm)
    lbPitagorasz: TLabel;
    sgTabla: TStringGrid;
    btKilepes: TButton;
    procedure btKilepesClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fmPitagorasz: TfmPitagorasz;

implementation

{$R *.dfm}

procedure TfmPitagorasz.btKilepesClick(Sender: TObject);
begin
  Close;
end;

Function RelPrim(P,Q: LongInt): Boolean;
Var R: LongInt;
Begin
  Repeat
    R:= P Mod Q;
    P:= Q;
    Q:= R;
  Until R=0;
  RelPrim:= P=1;
End;

procedure TfmPitagorasz.FormCreate(Sender: TObject);
Var I, J, S: LongInt;
begin
  With sgTabla Do
  Begin
    Cells[0,0]:= 'Sorsz.';
    Cells[1,0]:= 'M:';
    Cells[2,0]:= 'N:';
    Cells[3,0]:= 'A:';
    Cells[4,0]:= 'B:';
    Cells[5,0]:= 'C:';
    S:= 0;
    For I:= 2 To 100 Do For J:= 1 To I-1 Do
    If RelPrim(I,J) And (Odd(I) XOr Odd(J)) Then
    Begin
      If RowCount<S Then RowCount:= RowCount+1;
      Inc(S); Cells[0,S]:= IntToStr(S);
      Cells[1,S]:= IntToStr(I);
      Cells[2,S]:= IntToStr(J);
      Cells[3,S]:= IntToStr(Sqr(I)-Sqr(J));
      Cells[4,S]:= IntToStr(2*I*J);
      Cells[5,S]:= IntToStr(Sqr(I)+Sqr(J));
    End;
  End;
end;

end.

         Írjunk programot, amely egy táblázatban (minél nagyobb értékig, de a tábla teljes terjedelmében látható legyen a képernyőn) megjeleníti a számokat, majd végignézi, hogy melyek a prímszámok, ezeket feketével írja ki, míg a nem prímeket ettől eléggé eltérő színnel. A táblázat egy StringGrid legyen, melynek a rögzített cellái ne legyenek láthatóak. A program 1540-ig (35*44) keresi meg a prímszámokat. A programon csak a rács oszlopai illetve sorai számának átírásával ettől különböző értékig történik a keresés (akár az értékek növelhetők is, csak akkor nem látszik minden szám egyszerre a képernyőn).

         A program futtatási képe:

A program listája:

unit UPrim;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

  Graphics, Controls, Forms, Dialogs, Grids, StdCtrls;

type
  TfmPrim = class(TForm)
    sgTabla: TStringGrid;
    lbPrim: TLabel;
    btKilepes: TButton;
    procedure FormCreate(Sender: TObject);
    procedure btKilepesClick(Sender: TObject);
    procedure sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
      Rect: TRect; State: TGridDrawState);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fmPrim: TfmPrim;

implementation

{$R *.dfm}

procedure TfmPrim.btKilepesClick(Sender: TObject);
begin
  Close;
end;

Function Prime(S: Word): Boolean;
Var J: Word;
Begin
  Prime:= False; If S In [0,1] Then Exit; Prime:= True;
  For J:= 2 To Trunc(Sqrt(S)) Do If (S Mod J)=0 Then
  Begin Prime:= False; Break End;
End;

procedure TfmPrim.FormCreate(Sender: TObject);
Var I, J: Word;
begin
  With sgTabla Do
  Begin
    ColWidths[0]:= 0;
    RowHeights[0]:= 0;
    For I:= 0 To RowCount-2 Do For J:= 1 To ColCount-1 Do
    Cells[J,I+1]:= IntToStr((ColCount-1)*I+J);
  End;
end;

procedure TfmPrim.sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  With sgTabla.Canvas.Brush Do
  Begin
    {kiválasztott cella}
    If gdSelected In State Then Color:= clYellow;
    {a táblázat belseje}
    If Not((gdSelected In State) Or (gdFixed In State)) Then
    Color:= clWindow;
  End;
  With sgTabla.Canvas.Font Do
  If Prime(StrToInt(sgTabla.Cells[Col,Row])) Then
  Color:= clBlack Else Color:= clFuchsia;
  sgTabla.Canvas.TextRect(Rect,Rect.Left+1,

                          Rect.Top+1,sgTabla.Cells[Col,Row]);
  If gdFocused In State Then sgTabla.Canvas.DrawFocusRect(Rect);
end;

end.

         Néhány évvel ezelőtt láttam egy filmet (sajnos nem emlékszem a pontos dátumra, helyre és címre), amelyben szó volt egy nagy titkot felfedő üzenetről, melyet a következőképpen lehetett megismerni: a természetes számokat spirális alakban kellett felírni, minél nagyobb értékig. A következő lépésben csak a prímszámokat kellett meghagyni a táblázatban a többit törölni. Ez után a számokat pontokra kell cserélni, az ábrát sűríteni és az így kapott ábrából lehetett volna az üzenet tartalmára következtetni. Úgy gondoltam ezt kipróbálom, vajon mekkora benne a csúsztatás. Az, hogy némi szabályosság fellelhető az ábrán, kétségtelen. De, hogy valami nagy titkot rejtene, azt kétlem.

Első lépésként lássuk az első 256 számot a kérdéses elrendezésben:

         Jól látható, hogy néhány prímszám átlós elrendeződésben jelenik meg, de ezek az együttállások nem igazán hosszúak (pl.: 3, 5, 13, 19, 31, 41, 71, 109; vagy: 5, 7, 17, 23, 37, 47, 79, 119, 167, 223). Az is jól látható, hogy bizonyos átlókon egyetlen prímszám sem lesz. (pl.: 0, 4, 8, 16, 24, 36, 48, 64, 80 …) Ugyancsak nem lesz egyetlen prímszám sem, a páros számokat tartalmazó átlókon, ugyanis a táblázat párosság szerint sakktábla-szerű elrendezés (kivéve természetes azt, amelyen az egyetlen páros prímszám, a 2 található). A prímszámoknak ilyentén ábrázolására először Stanislaw Ulam lengyel matematikus 1963-ban gondolt, és ezt az ábrázolást az Ő tiszteletére a matematika Ulam-spirálnak nevezi.

         Programozás-technikailag az jelentett némi fejtörést, vajon hogyan lehetne az előbbi számtáblát minél könnyebben létrehozni. A listából kiderül, hogy aránylag egyszerű (természetesen más eszközökkel is lehet hasonlóan egyszerű) kódot sikerült alkotni. A megjelenítő form grafikus méretéhez igazodva a számolás 501972-ig történt.

         Íme a végeredmény:

         A program listája pedig:

unit UPrimSpiral;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, 

  Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TfmPrimSpiral = class(TForm)
    btKilepes: TButton;
    procedure btKilepesClick(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fmPrimSpiral: TfmPrimSpiral;

implementation

{$R *.dfm}

Function Prime(S: Word): Boolean;
Var J: Word;
Begin
  Prime:= False; If S In [0,1] Then Exit; Prime:= True;
  For J:= 2 To Trunc(Sqrt(S)) Do If (S Mod J)=0 Then
  Begin Prime:= False; Break End;
End;

procedure TfmPrimSpiral.btKilepesClick(Sender: TObject);
begin
  Close;
end;

procedure TfmPrimSpiral.FormPaint(Sender: TObject);
Var I, M, X, Y: Integer;
    N: LongInt;
    S: String;
begin
  N:= 0; M:= 0;
  With Canvas Do
  Begin
    X:= ClientWidth Div 2;
    Y:= ClientHeight Div 2;
    Repeat
      For I:= 0 To M Do
      Begin If Prime(N) Then Pixels[X,Y]:= 0; Inc(N); Inc(X) End;
      For I:= 0 To M Do
      Begin If Prime(N) Then Pixels[X,Y]:= 0; Inc(N); Dec(Y) End;
      Inc(M);
      For I:= 0 To M Do
      Begin If Prime(N) Then Pixels[X,Y]:= 0; Inc(N); Dec(X) End;
      For I:= 0 To M Do
      Begin If Prime(N) Then Pixels[X,Y]:= 0; Inc(N); Inc(Y) End;
      Inc(M);
    Until N>500000;
    Str(N,S); TextOut(10,50,S);
  End;
end;

end.

Két prímszámot ikerprímnek nevezünk, ha különbségük 2. Ilyenek például: 3 és 5, 5 és 7, 11 és 13. A 3, 5 és 7 hármas ikerprímek. Több hármas ikerprím nem létezhet, hiszen három olyan szám, amelyek között 2 a különbség a következőképpen írható: 3k, 3k+2, 3k+4 vagy 3k+1, 3k+3, 3k+5, vagy 3k+2, 3k+4, 3k+6 (ahol k>2). Bármelyik szerinti felírás esetén a három számból az egyik osztható 3-al, azaz nem lehet mindegyike prím.

A program 1.000.000-ig kereste az ikerprímeket, melynek száma: 8240. A futási képek:

         A program listája:

unit UIkerprimek;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics,

  Controls, Forms, Dialogs, Grids, StdCtrls;

type
  TfmIkerprimek = class(TForm)
    lbIkerprimek: TLabel;
    sgTabla: TStringGrid;
    btKilepes: TButton;
    procedure btKilepesClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fmIkerprimek: TfmIkerprimek;

implementation

{$R *.dfm}

procedure TfmIkerprimek.btKilepesClick(Sender: TObject);
begin
  Close;
end;

Function Prime(S: Int64): 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 S-1 Do If (S Mod J)=0 Then
  Begin Prime:= False; Break End;
End;

procedure TfmIkerprimek.FormCreate(Sender: TObject);
Var I, N: LongInt;
begin
  With sgTabla Do
  Begin
    Cells[0,0]:= 'Sorsz.';
    Cells[1,0]:= 'P1';
    Cells[2,0]:= 'P2';
    N:= 0;
    For I:= 1 To 1000000 Do
    If Prime(I) And Prime(I+2) Then
    Begin
      If RowCount<N+2 Then RowCount:= RowCount+1;
      Inc(N);
      Cells[0,N]:= IntToStr(N);
      Cells[1,N]:= IntToStr(I);
      Cells[2,N]:= IntToStr(I+2);
    End;
  End;
end;

end.

         A számítógépes információtovábbítás biztonságossá tétele érdekében az adatok titkosítására van szükség. A legelterjedtebb titkosítási mód az RSA, mely egy nyílt kódú, aszimmetrikus titkosító eljárás. Ehhez az eljáráshoz szükség van két elég nagy prímszámra. Ezek szorzata és egy ehhez a szorzathoz relatív prímszám a nyilvános kulcs, melyet mindenki ismerhet. Az egyik prímszámot az információ-küldő, a másikat a fogadó birtokolja. Hatványozás és maradékképzések segítségével a titkosított üzenetet csak a fogadó képes a saját kulcsa segítségével visszafejteni. Az egész eljárás biztonsága attól függ, hogy nyilvános kulcsban szereplő elég nagy prímszámok valóban elég nagyok-e. A cél minél nagyobb prímszámok előállítása, mert minél nagyobb egy szám, prímszám volta, illetve ha nem prím, akkor a szorzattá alakítása, annál hosszabb ideig lehetséges, és itt a hosszú idő alatt évmilliárdokra kell gondolni, még a mai leggyorsabb számítógépekkel is.

Elég nagy prímszám előállításánál leggyakrabban a Mersenne-féle számok között keresnek. A Mersenne-féle számok a következő alakúak:

         2^p-1,

ahol a p maga is prímszám. A legnagyobb ismert Mersenne-féle prímszám a 47., mely közel 13 millió tízes számrendszerbeli számjegyként írható fel, és egy mai gyors személyi számítógép egy hónapos munkájának az eredménye.

         Az itt található program csak demonstráció, nem képes a fent említett méretű prímszámok közelébe sem érni. Azért az első 10 Mersenne-féle prímet produkálja.

         A futtatási kép:

         A program listája:

unit UMersenne;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics,

  Controls, Forms, Dialogs, StdCtrls, Grids;

type
  TfmMersenne = class(TForm)
    lbMersenne: TLabel;
    sgTabla: TStringGrid;
    btKilepes: TButton;
    procedure btKilepesClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fmMersenne: TfmMersenne;

implementation

{$R *.dfm}

procedure TfmMersenne.btKilepesClick(Sender: TObject);
begin
  Close;
end;

Function Prime(S: Int64): 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 S-1 Do If (S Mod J)=0 Then
  Begin Prime:= False; Break End;
End;

Function Hatvany(P: Word): Int64;
Begin
  If P=0 Then Hatvany:= 1 Else Hatvany:= 2*Hatvany(P-1);
End;

procedure TfmMersenne.FormCreate(Sender: TObject);
Var I, N, M: LongInt;
begin
  With sgTabla Do
  Begin
    ColWidths[2]:= 140;

    Cells[0,0]:= 'Sorsz.';
    Cells[1,0]:= 'P';
    Cells[2,0]:= '2^P-1';
    Cells[3,0]:= 'Prim?';
    Cells[4,0]:= 'Merse.sorsz.';
    I:= 0; M:= 0;
    For N:= 1 To 1000 Do If Prime(N) Then
    Begin
      If RowCount<I+2 Then RowCount:= RowCount+1;
      Inc(I);
      Cells[0,I]:= IntToStr(I);
      Cells[1,I]:= IntToStr(N);
      Cells[2,I]:= IntToStr(Hatvany(N)-1);
      If Prime(Hatvany(N)-1) Then
      Begin
        Cells[3,I]:= 'Igen'; Inc(M); Cells[4,I]:= IntToStr(M);
      End
      Else Cells[3,I]:= 'Nem';
    End;
  End;
end;

end.

Azokat a természetes számokat, amelyek osztóinak összege egyenlő a számmal, tökéletes számoknak nevezzük (az osztók közé bevesszük az 1-et, de magát a számot nem).

Euklidesz felismerte, hogy az első 4 tökéletes szám alakja:

2^(n-1)*(2ⁿ-1),

sőt azt is bebizonyította, ha 2ⁿ-1 prím, akkor a képlet tökéletes számot határoz meg. A 2ⁿ-1 alakú prímszámokat Mersenne prímeknek nevezzük. Eddig még csak páros tökéletes számokat ismerünk. Nem ismert, hogy létezhet-e egyáltalán páratlan tökéletes szám. Az is bizonyításra vár, hogy a tökéletes számok száma véges-e vagy végtelen. Euler bebizonyította, hogy Euklidesz képlete az összes páros tökéletes számot megadja. Viszont a Mersenne prímek számosságát sem ismerjük, így ez sem segít a tökéletes számok számosságának megítélésében.

         Ez a program az első 10 Mersenne prím mellett az első 8 tökéletes számot is szolgáltatja, a 9. és 10.-re már túlcsordul.

         A futási kép:

         A program listája:

unit UTokeletes;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

  Graphics, Controls, Forms, Dialogs, StdCtrls, Grids;

type
  TForm1 = class(TForm)
    lbTokeletes: TLabel;
    sgTabla: TStringGrid;
    btKilepes: TButton;
    procedure btKilepesClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.btKilepesClick(Sender: TObject);
begin
  Close;
end;

Function Prime(S: Int64): 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 S-1 Do If (S Mod J)=0 Then
  Begin Prime:= False; Break End;
End;

Function Hatvany(P: Word): Int64;
Begin
  If P=0 Then Hatvany:= 1 Else Hatvany:= 2*Hatvany(P-1);
End;

procedure TForm1.FormCreate(Sender: TObject);
Var I, N, M: LongInt;
begin
  With sgTabla Do
  Begin
    ColWidths[0]:= 32;
    ColWidths[1]:= 32;
    ColWidths[2]:= 140;
    ColWidths[3]:= 32;
    ColWidths[4]:= 34;
    ColWidths[5]:= 140;

    Cells[0,0]:= 'Sorsz.';
    Cells[1,0]:= 'P';
    Cells[2,0]:= '2^P-1';
    Cells[3,0]:= 'Prim?';
    Cells[4,0]:= 'Merse';
    Cells[5,0]:= 'Tökéletes szám';
    I:= 0; M:= 0;
    For N:= 1 To 70 Do If Prime(N) Then
    Begin
      If RowCount<I+2 Then RowCount:= RowCount+1;
      Inc(I);
      Cells[0,I]:= IntToStr(I);
      Cells[1,I]:= IntToStr(N);
      Cells[2,I]:= IntToStr(Hatvany(N)-1);
      If Prime(Hatvany(N)-1) Then
      Begin
        Cells[3,I]:= 'Igen'; Inc(M); Cells[4,I]:= IntToStr(M);
        If Hatvany(N-1)*(Hatvany(N)-1)>0 Then
        Cells[5,I]:= IntToStr(Hatvany(N-1)*(Hatvany(N)-1)) Else
        Cells[5,I]:= '>MaxInt64';
      End
      Else Cells[3,I]:= 'Nem';
    End;
  End;
end;

end.

Két természetes számot barátságos szám-párnak nevezünk, ha kölcsönösen igaz rájuk, hogy az egyik szám önmagánál kisebb osztóinak összege egyenlő a másik számmal.

Ilyen például a 220 és a 284 szám-pár, mert 220 önmagánál kisebb osztóinak összege: 1 + 2 + 4 + 5 + 10 + 11 + 20 + 22 + 44 + 55 + 110 = 284, míg ugyanez 284 esetén: 1 + 2 + 4 + 71 + 142 = 220, vagyis teljesítik a fenti definíciót. A (220; 248) számpárt, mit a legkisebb barátságos számokat, már az ókori görögök is ismerték.

Barátságos számok keresése nagy érdeklődésre tartott számot a történelem folyamán. Igyekeztek minél nagyobb ilyen számokat találni. Míg a középkorban nagy fegyverténynek számított egy-egy újabb számpár felfedezése, a számítógépek megjelenésével a talált szám-párok száma exponenciálisan nőni kezdett. Ma már több mint négymillió barátságos számpárt ismerünk.

A most bemutatandó program elvileg alkalmas arra, hogy a használt programnyelv kereteit figyelembe véve, a lehető legnagyobb értékig az összes barátságos számpárt megkeresse. Nem alkalmaz különleges algoritmust, csak a szokásos osztókeresést és összegzést. Beállíthatjuk a keresési intervallumot, majd start után egy listadobozban jeleníti meg a talált szám-párokat, miközben folyamatosan minden megtalált barátságos számot szöveges állományba ment. Lehetőség van arra is, hogy egy megadható számnál nem nagyobb, egyébként legnagyobb barátságos számpárt megkeressük. Ekkor az első megtalált szám-párnál a keresés befejeződik. Hasonlóképp lehetőség van arra is, hogy egy adott számnál nagyobb, de legkisebb barátságos számpárt megkeressük. A kereséseknél a határ mindig a kisebbik barátságos számra vonatkozik.

A Delphiben az Int64 típussal tárolhatunk legnagyobb egész számot, melynek értéke: 9.223.372.036.854.775.807. Elvileg ilyen nagyságrendű számok között is kereshetnének személyi számítógépeink barátságos számokat, de sajnos már a 16 jegyű számok környékén egyetlen szám osztóinak összegét is csak másodpercek alatt határozzák meg, így értelmes idő alatt nem tudnak megbirkózni a legnagyobb Int64 körüli intervallumban lévő számok vizsgálatával. A programba egyébként ez a lehetőség is be van építve. Tehát ha akár a gépek, akár az algoritmusok javulnak, értelmes lehet ilyen magasságokban is keresgetni a programmal.

Az algoritmus olyan, hogy az intervallumhatár csak a kisebbik számra érvényes, így ha a teljes keresést több intervallum beírásával hajtjuk végre, akkor se marad ki egyetlen barátságos szám sem. A program futási idejének csökkentése érdekében, a képernyőn csak minden tízezredik lépés sorszámát írjuk ki.

A programot a következő paraméterekkel futtattam: Kezdőérték = 1, Végérték = 100 millió. A gép egy 2GHz-es kétmagos Pentium, a futási idő 600 perc körüli volt, és ebben az intervallumban 236 számpárt talált. Kíváncsi voltam a 100 milliót követő első szám-párra, így a következő screen-shot-on még ezt is láthatjuk:

A program listája:

unit UBaratSzam;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

  Graphics, Controls, Forms, Dialogs, StdCtrls, Grids;

type
  TfmBaratSzam = class(TForm)
    lbBaratSzam: TLabel;
    lbKezdo: TLabel;
    edKezdo: TEdit;
    lbVegertek: TLabel;
    edVegertek: TEdit;
    btKilepes: TButton;
    btStart: TButton;
    ldTalalt: TListBox;
    lbVege: TLabel;
    btTorles: TButton;
    lbSzampSzam: TLabel;
    edSzampSzam: TEdit;
    ldSzamok: TListBox;
    lbStart: TLabel;
    lbStop: TLabel;
    edStart: TEdit;
    edStop: TEdit;
    btMax64: TButton;
    edSzam: TEdit;
    edMax: TEdit;
    btKisebb: TButton;
    btNagyobb: TButton;
    procedure btKilepesClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btStartClick(Sender: TObject);
    procedure edKezdoChange(Sender: TObject);
    procedure edVegertekChange(Sender: TObject);
    procedure btTorlesClick(Sender: TObject);
    procedure btMax64Click(Sender: TObject);
    procedure btKisebbClick(Sender: TObject);
    procedure btNagyobbClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fmBaratSzam: TfmBaratSzam;
  Kezd, Vege, Max64: Int64;
  DNev: String;
  FText: Text;

implementation

{$R *.dfm}

procedure TfmBaratSzam.btKilepesClick(Sender: TObject);
begin
  Close;
end;

Function Hatvany(P: Word): Int64;
Begin
  If P=0 Then Hatvany:= 1 Else Hatvany:= 2*Hatvany(P-1);
End;

procedure TfmBaratSzam.FormCreate(Sender: TObject);
begin
  Kezd:= StrToInt(edKezdo.Text);
  Vege:= StrToInt(edVegertek.Text);
  lbVege.Visible:= False;
  Max64:= Hatvany(63)-1;
  DNev:= 'barat.txt';
end;

procedure TfmBaratSzam.edKezdoChange(Sender: TObject);
Var Kod: Integer;
begin
  With edKezdo Do Val(Text,Kezd,Kod);
end;

procedure TfmBaratSzam.edVegertekChange(Sender: TObject);
Var Kod: Integer;
begin
  With edVegertek Do Val(Text,Vege,Kod);
end;

procedure TfmBaratSzam.btMax64Click(Sender: TObject);
begin
  edVegertek.Text:= IntToStr(Max64);
end;

procedure TfmBaratSzam.btTorlesClick(Sender: TObject);
begin
  ldTalalt.Clear;
  ldSzamok.Clear;
  edSzampSzam.Text:= '';
  edStart.Text:= '';
  edStop.Text:= '';
  Repaint;
end;

procedure TfmBaratSzam.btStartClick(Sender: TObject);
Var I, J, S1, S2: Int64;
    V: Comp;
    Ws: String;
begin
  edStart.Text:= TimeToStr(GetTime);
  edStop.Text:= '';
  lbVege.Visible:= False; Repaint;
  I:= Kezd;
  While I<=Vege Do
  Begin
    If I Mod 10000=0 Then With edSzam Do Begin Text:= IntToStr(I); RePaint End;
    If ldSzamok.Items.IndexOf(IntToStr(I))=-1 Then
    Begin
      S1:= 1; J:= 2; V:= I;
      While J<Sqrt(V) Do
      Begin If I Mod J=0 Then Inc(S1,J+(I Div J)); Inc(J) End;
      If (J=Sqrt(V)) And (I Mod J=0) Then S1:= S1+J;
      If S1>I Then
      Begin
        S2:= 1; J:= 2; V:= S1;
        While J<Sqrt(V) Do
        Begin If S1 Mod J=0 Then Inc(S2,J+(S1 Div J)); Inc(J) End;
        If (J=Sqrt(V)) And (S1 Mod J=0) Then S2:= S2+J;
        If I=S2 Then
        Begin
          With ldSzamok.Items Do Begin Add(IntToStr(I)); Add(IntToStr(S1)) End;
          With ldTalalt Do
          Begin Items.Add(IntToStr(I)+' - '+IntToStr(S1)); RePaint End;
          AssignFile(FText,DNev); Append(FText);
            WriteLn(FText,I,' - ',S1);
          CloseFile(FText);
        End;
      End;
    End;
    Inc(I);
  End;
  lbVege.Visible:= True;
  ldTalalt.Clear;
  AssignFile(FText,DNev); Reset(FText);
    While Not (EOF(FText)) Do
    Begin
      ReadLn(FText,Ws);
      ldTalalt.Items.Add(Ws);
    End;
  CloseFile(FText);

  edSzampSzam.Text:= IntToStr(ldTalalt.Items.Count);
  edStop.Text:= TimeToStr(GetTime);
end;

procedure TfmBaratSzam.btKisebbClick(Sender: TObject);
Var I, J, S1, S2: Int64;
    V: Comp;
    Van: Boolean;
begin
  edStart.Text:= TimeToStr(GetTime);
  edStop.Text:= '';
  lbVege.Visible:= False; Repaint;
  Van:= False;
  I:= StrToInt(edMax.Text);
  While Not Van Do
  Begin
    If I Mod 10000=0 Then With edSzam Do Begin Text:= IntToStr(I); RePaint End;
    If ldSzamok.Items.IndexOf(IntToStr(I))=-1 Then
    Begin
      S1:= 1; J:= 2; V:= I;
      While J<Sqrt(V) Do
      Begin If I Mod J=0 Then Inc(S1,J+(I Div J)); Inc(J) End;
      If (J=Sqrt(V)) And (I Mod J=0) Then S1:= S1+J;
      If S1>I Then
      Begin
        S2:= 1; J:= 2; V:= S1;
        While J<Sqrt(V) Do
        Begin If S1 Mod J=0 Then Inc(S2,J+(S1 Div J)); Inc(J) End;
        If (J=Sqrt(V)) And (S1 Mod J=0) Then S2:= S2+J;
        If I=S2 Then
        Begin
          ldTalalt.Items.Add(IntToStr(I)+' - '+IntToStr(S1));
          Van:= True;
        End;
      End;
    End;
    Dec(I);
  End;
  lbVege.Visible:= True;
  edSzampSzam.Text:= IntToStr(ldTalalt.Items.Count);
  edStop.Text:= TimeToStr(GetTime);
end;

procedure TfmBaratSzam.btNagyobbClick(Sender: TObject);
Var I, J, S1, S2: Int64;
    V: Comp;
    Van: Boolean;
begin
  edStart.Text:= TimeToStr(GetTime);
  edStop.Text:= '';
  lbVege.Visible:= False; Repaint;
  Van:= False;
  I:= StrToInt(edMax.Text);
  While Not Van Do
  Begin
    If I Mod 10000=0 Then With edSzam Do Begin Text:= IntToStr(I); RePaint End;
    If ldSzamok.Items.IndexOf(IntToStr(I))=-1 Then
    Begin
      S1:= 1; J:= 2; V:= I;
      While J<Sqrt(V) Do
      Begin If I Mod J=0 Then Inc(S1,J+(I Div J)); Inc(J) End;
      If (J=Sqrt(V)) And (I Mod J=0) Then S1:= S1+J;
      If S1>I Then
      Begin
        S2:= 1; J:= 2; V:= S1;
        While J<Sqrt(V) Do
        Begin If S1 Mod J=0 Then Inc(S2,J+(S1 Div J)); Inc(J) End;
        If (J=Sqrt(V)) And (S1 Mod J=0) Then S2:= S2+J;
        If I=S2 Then
        Begin
          ldTalalt.Items.Add(IntToStr(I)+' - '+IntToStr(S1));
          AssignFile(FText,DNev); Append(FText);
            WriteLn(FText,I,' - ',S1);
          CloseFile(FText);
          Van:= True;
        End;
      End;
    End;
    Inc(I);
  End;
  lbVege.Visible:= True;
  edSzampSzam.Text:= IntToStr(ldTalalt.Items.Count);
  edStop.Text:= TimeToStr(GetTime);
end;

end.

Egy természetes számot egyensúlyszámnak (Balance number) nevezünk, ha az összes előtte lévő természetes szám összege egyenlő, az őt követő valahány természetes szám összegével.

A 6 például egy egyensúlyszám, hiszen teljesíti a fenti definíciót, ugyanis: 1+2+3+4+5 = 7+8. További néhány egyensúlyszám: 6, 35, 204, 1189, 6930, 40391. Írjunk programot, mely a gép adta lehetőségeket kihasználva a lehető legnagyobb értékig meghatározza az összes egyensúlyszámot.

A többször módosított, egyre magasabb értékekre is elfogadható futási idővel rendelkező programot igazán nagy értékekre elsőként 10.000.000-ig futattam. A gyorsabb futás érdekében csak minden 100000. lépéskor frissül a ciklusváltozó értékét folyamatosan tartalmazó Edit mező. Ebben az intervallumban 9 darab egyensúlyszámot talált a gép. Aztán 100 millió, majd 1 milliárd volt a felső határ. A 11. egyensúlyszám után már majdnem feladtam, nincs tovább, ennyire volt képes a program. Íme az első 11 egyensúlyszám:

Nem nyugodtam, szerettem volna a 12.-et is megkeresni. Néhány milliárd fölötti futtatás közben (hiszen nem egy-két percről van szó), a már megtalált számokat figyelve, arra jöttem rá, hogy az egymást követő számok hányadosa 6 körüli. Elő egy Excel táblát, nézzük mi a hányados:

            Az eredmény elég meggyőző abban a tekintetben, hogy a hányados 14 tizedes jegyre a 10. számtól ugyanaz és előtte sem nagyon különbözik egymástól. Úgy néz ki, mintha a hányadosok egy konvergens sorozatot alkotnának. Csak körülbelüli értékeket számolva a 1,55 milliárd - 1,7 milliárd keresési intervallum következett, és teljes volt a siker, kevesebb mint egy óra alatt meglett a 12. egyensúlyszám:

Természetesen később a köztes értékekre is lefuttattam a programot, nem talált további egyensúlyszámokat, tehát a megtalált valóban a 12. Ha a sejtés igaz a hányadosok sorozatára, akkor a következő egyensúlyszámokat egy Excel tábla segítségével megjósolhatjuk:

A táblában kövérrel írva a felszorzással számított értékek vannak. És valóban, jól látható, hogy a 12. számot pontosan adja. A továbbiak pontosságát már csak más algoritmusokat alkalmazó program segítségével lehet ellenőrizni. Jelen program ugyanis 3 milliárd környékén, a számok összegének kiszámításánál túlcsordul. Mindenesetre nagy valószínűséggel a 13. egyensúlyszám 9.228.778.026, a 14. egyensúlyszám pedig 53.789.260.175. Legalábbis ezektől nem túlságosan sokkal különbözik. (Akinek kedve van, nosza, írjon rá ellenőrző programot. Lehet, hogy rövidesen én is szolgálok egy ilyennel.)

A program listája:

unit UEgyenSzam;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

  Graphics, Controls, Forms, Dialogs, StdCtrls, Grids;

type
  TfmEgyenSzam = class(TForm)
    lbEgyenSzam: TLabel;
    btKilepes: TButton;
    lbKezdo: TLabel;
    edKezdo: TEdit;
    lbVeg: TLabel;
    edVeg: TEdit;
    sgEgyenSzam: TStringGrid;
    btKeres: TButton;
    lbKesz: TLabel;
    edSzamol: TEdit;
    Label1: TLabel;
    edStart: TEdit;
    Label2: TLabel;
    edStop: TEdit;
    Function Osszeg(E, U: Int64): Int64;
    procedure btKilepesClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btKeresClick(Sender: TObject);
    procedure edKezdoChange(Sender: TObject);
    procedure edVegChange(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fmEgyenSzam: TfmEgyenSzam;
  Kezdo, Veg: LongInt;
  DNev: String;
  FText: Text;

implementation

{$R *.dfm}

procedure TfmEgyenSzam.btKilepesClick(Sender: TObject);
begin
  Close;
end;

procedure TfmEgyenSzam.FormCreate(Sender: TObject);
begin
  With sgEgyenSzam Do
  Begin
    Cells[0,0]:= 'Sorsz.:';
    ColWidths[0]:= 40;
    ColWidths[2]:= 280;
    Cells[1,0]:= 'Egyensúlyszám:';
    Cells[2,0]:= 'Az összeg:';
  End;
  Kezdo:= StrToInt(edKezdo.Text);
  Veg:= StrToInt(edVeg.Text);
end;

procedure TfmEgyenSzam.edKezdoChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edKezdo.Text,Kezdo,Kod);
end;

procedure TfmEgyenSzam.edVegChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edVeg.Text,Veg,Kod);
end;

Function TfmEgyenSzam.Osszeg(E, U: Int64): Int64;
Begin
  Osszeg:= Round((E+U)*(U-E+1)/2);
End;

procedure TfmEgyenSzam.btKeresClick(Sender: TObject);
Var N: Word;
    I, J: LongInt;
    S1, S2, E, K, V: Int64;
    Van: Boolean;
begin
  edStart.Text:= TimeToStr(GetTime); edStart.Repaint;
  edStop.Text:= ''; edStop.Repaint;
  lbKesz.Caption:= '               '; lbKesz.RePaint;
  edSzamol.Text:= '1'; edSzamol.Repaint;
  N:= 1;
  With sgEgyenSzam Do
  Begin
    For I:= 0 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
    sgEgyenSzam.RePaint;
    If Kezdo<2 Then Kezdo:= 2;
    For I:= Kezdo To Veg Do
    Begin
      edSzamol.Text:= IntToStr(I);
      If (I<10000) Or (I Mod 100000=0) Then edSzamol.Repaint;
      S1:= Osszeg(1,I-1);
      E:= Round(1.4*I); V:= Round(1.5*I); Van:= False;
      While (E<=V) And Not Van Do
      Begin
        K:= (E+V) Div 2;
        S2:= Osszeg(I+1,K);
        If S1=S2 Then Van:= True Else
        If S1<S2 Then V:= K-1 Else E:= K+1;
      End;
      If Van Then
      Begin
        Cells[0,N]:= IntToStr(N)+'.';
        Cells[1,N]:= IntToStr(I);
        Cells[2,N]:= IntToStr(S1);
        sgEgyenSzam.Repaint; Inc(N);
      End;
    End;
  End;
  lbKesz.Caption:= 'Kész';
  edStop.Text:= TimeToStr(GetTime);
  DNev:= 'EgyenSzam.txt'; N:= 1;
  AssignFile(FTExt,DNev); ReWrite(FText);
    With sgEgyenSzam Do While Cells[0,N]<>'' Do
    Begin
      WriteLn(FText,Cells[0,N],' ',Cells[1,N],'-',Cells[2,N]);
      Inc(N);
    End;
  CloseFile(FText);
end;

end.

Írjunk programot, mely a Delphi Int64 maximális számábrázolását meghaladó módon meg tudja határozni például kettő hatványait. Természetesen az így előállított számok a programnyelv szempontjából nem lesznek számként kezelhetők. Olyan tömbök, illetve stringek lesznek, melyeknek 0-9 karakterek az elemei. Az itt közölt megoldási kód nagyon egyszerű, elemzését bárki elvégezheti.

A futtatás két képernyője, rajta a 2-nek a hatványai a 0.-tól a 199.-ig:

         Ha egy A korlátos, mérhető területű geometriai alakzat P pontját véletlenszerűen választjuk ki, akkor annak a valószínűsége, hogy az A-nak a B mérhető területű részhalmazára esik: (B mértéke) / (A mértéke). Ezt a valószínűséget (mivel a valószínűség meghatározásához geometriai mértéket kell meghatározni), geometriai valószínűségnek nevezzük.

         A geometriai valószínűség fogalma lehetőséget kínál területek mérőszámának közelítésére. Ha egy négyzetbe egy, az oldalait érintő kört rajzolunk, majd az alakzat pontjait véletlenül választjuk ki elég sokszor, akkor a körre eső pontok száma úgy aránylik a négyzetre eső (összes pont) számához, mint a kör területe a négyzet területéhez. Képletben: R²*Pi / 4*R². Ha e törtet egyszerűsítjük, akkor a valószínűségre Pi / 4 adódik.

Nincs más feladatunk, mint folyamatosan véletlenül választani a négyzet területéről egy pontot, ezt számolni (N) és megnézni, hogy a kör területére esett-e, ha igen akkor azt külön számoljuk (K). Mindig kiírathatjuk a programmal a 4*N/K értéket, mely a Pi értékét közelíti. (Hogy a rajz mindig változzon, a kör területére eső pontoknál nem beállítódik a piros szín, hanem újonnan történő kiválasztáskor a háttérszínnel váltakozik. Így soha nem lesz a kör területe homogén piros. Ugyanígy van a körre nem eső pontoknál is, csak kék színnel.)

         Mivel a program leállítási feltételt nem tartalmaz, gondoskodni kell a folyamatos végrehajtás mellett a leállíthatóságról is. Ezt elegánsan egy programozási szál indításával oldhatjuk meg. Az indítást a Start feliratú nyomógomb végzi, melyet megnyomva Enabled tulajdonságát False-ra változtatjuk, mert újabb megnyomása a programot leállíthatatlanná tenné. A képernyőn folyamatosan látjuk a Pi tényleges értékét, a közelítő értéket, valamint a pontválasztások számát.

         A futási kép, miközben a gép átlépte a 20 millió pontválasztást:

         A program listája:

unit UPi;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

  Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TSzamol=Class(TThread)
    Private
      X, Y: Integer;
      Protected
        Procedure Execute; OverRide;
        Procedure Szamol;
  End;

  TfmPi = class(TForm)
    lbPi: TLabel;
    btKilepes: TButton;
    btStart: TButton;
    procedure btKilepesClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure btStartClick(Sender: TObject);
  private
    { Private declarations }
    Sz: TSzamol;
  public
    { Public declarations }
  end;

Const R= 300;

var
  fmPi: TfmPi;
  Xk, Yk: Integer;
  N, K: LongInt;
  Bent: Boolean;

implementation

{$R *.dfm}

procedure TfmPi.btKilepesClick(Sender: TObject);
begin
  Close;
end;

procedure TfmPi.FormCreate(Sender: TObject);
begin
  Randomize;
  Xk:= ClientWidth Div 2;
  Yk:= ClientHeight Div 2;
  N:= 0; K:= 0;
end;

procedure TfmPi.FormPaint(Sender: TObject);
begin
  With Canvas Do
  Begin
    Pen.Color:= clBlue;
    Rectangle(Xk-R,Yk-R,Xk+R,Yk+R);
    Pen.Color:= clRed;
    Arc(Xk-R,Yk-R,Xk+R,Yk+R,Xk+R,Yk+R,Xk+R,Yk+R);
    Font.Size:= 12;
    TextOut(10,100,'Pi: 3,14159265358979');
  End;
end;

Procedure TSzamol.Execute;
Begin
  Repeat
    X:= Random(2*R+1)-R;
    Y:= Random(2*R+1)-R;
    Inc(N); Bent:= False;
    If Sqr(X)+Sqr(Y)<=Sqr(R) Then
    Begin Bent:= True; Inc(K) End;
    Synchronize(Szamol);
  Until Terminated;
End;

Procedure TSzamol.Szamol;
Begin
  With fmPi.Canvas Do
  Begin
    If Bent Then
    If Pixels[Xk+X,Yk+Y]= clRed Then
    Pixels[Xk+X,Yk+Y]:= clBtnFace Else
    Pixels[Xk+X,Yk+Y]:= clRed;
    If Not Bent Then
    If Pixels[Xk+X,Yk+Y]= clBlue Then
    Pixels[Xk+X,Yk+Y]:= clBtnFace Else
    Pixels[Xk+X,Yk+Y]:= clBlue;
    Font.Size:= 12;
    TextOut(10,120,'Pi~ '+FloatToStr(4*K/N));
    TextOut(10,150,'N:  '+IntToStr(N));
  End;
End;

procedure TfmPi.btStartClick(Sender: TObject);
begin
  btStart.Enabled:= False;
  Sz:= TSzamol.Create(False);
end;

end.

         A Galton-deszka egy lejtősen felállított, egyenlőszárúháromszög alakú deszka, melynek a felső csúcsától az alaplapja felé golyókat lehet legurítani, melyek az útjukba eső akadályokon 1/2 – 1/2 valószínűséggel térnek el jobbra illetve balra, míg végül kis dobozokban gyűlnek össze. Ha N darab eltérítési lehetőséggel találkozik, akkor N+1 dobozban gyűlnek össze golyók. Annak valószínűsége, hogy egy golyó a K. csatornába esik: (N alatt a K)/2ⁿ, azaz binomiális eloszlást követ. A nagy számok törvénye szerint, ha N elég nagy, akkor a binomiális eloszlás a normális eloszláshoz közelít.

         Programunk a fent leírt folyamatot szimulálja. A dobozokba esett golyókat egyre magasabb fehér téglalap jelzi. Folyamatosan kiírja a középső öt doboz tartalmát, valamint az összes felhasznált golyó számát. Ha az öt legtöbb golyót tartalmazó doboz valamelyike tele van, leáll a szimuláció. Közben a program nem állítható meg. A futás lassítása érdekében, egy

     For L:= 1 To 100 Do Pixels[200,20]:= clBlue;

sort tartalmaz, melynek paraméterei az aktuális gép sebességéhez illesztendők.

         A program startra kész állapotban:

         A program futási képe, amikor a 11. doboz tartalma 70 fölé nőtt:

         A futási kép az animáció befejeztével:

         A program listája:

unit UGalton;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

  Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;

type
  TfmGalton = class(TForm)
    btStart: TButton;
    btKilepes: TButton;
    Procedure Deszka;
    Procedure Animacio;
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure btStartClick(Sender: TObject);
    procedure btKilepesClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TGolyo= Class
       Fx, Fy, Fr, Fd: Integer;
       Fm: Boolean;
       Procedure Init(Ix, Iy, Ir: Integer);
       Procedure Show;
       Procedure Hide;
       Procedure MoveRel(X, Y: Integer);
       Function Moved: Boolean;
       Procedure SetMove;
       Function GetX: Integer;
       Function GetY: Integer;
       Function GetD: Integer;
       Procedure SetD(D: Integer);
     End;

Const N= 20; M= 32; Dx= 48; Dy= 24; Ex= -400; Ey= 20; R=4;

var
  fmGalton: TfmGalton;
  Xk, Yk: Integer;
  Fg: Array[1..M+1] Of TGolyo;
  D: Array[1..N+1] Of Integer;

implementation

{$R *.dfm}
Procedure TGolyo.Init(Ix, Iy, Ir: Integer);
Begin
  Fx:= Ix; Fy:= Iy; Fr:= Ir; Fd:= 0; Fm:= False;
End;

Procedure TGolyo.Show;
Begin
  With fmGalton.Canvas Do
  Begin
    Pen.Color:= clWhite;
    Brush.Color:= clWhite;
    Ellipse(Fx-Fr, Fy-Fr, Fx+Fr, Fy+Fr);
  End;
End;

Procedure TGolyo.Hide;
Begin
  With fmGalton.Canvas Do
  Begin
    Pen.Color:= clBlue;
    Brush.Color:= clBlue;
    Ellipse(Fx-Fr, Fy-Fr, Fx+Fr, Fy+Fr);
  End;
End;

Procedure TGolyo.MoveRel(X, Y: Integer);
Begin
  Hide; Fx:= Fx + X; Fy:= Fy + Y; Show;
End;

Function TGolyo.Moved: Boolean;
Begin
  Moved:= Fm;
End;

Procedure TGolyo.SetMove;
Begin
  Fm:= True;
End;

Function TGolyo.GetX: Integer;
Begin
  GetX:= Fx;
End;

Function TGolyo.GetY: Integer;
Begin
  GetY:= Fy;
End;

Function TGolyo.GetD: Integer;
Begin
  GetD:= Fd;
End;

Procedure TGolyo.SetD(D: Integer);
Begin
  Fd:= D;
End;

Procedure TfmGalton.Deszka;
Var I, J: Byte;
    Ws: String;
Begin
  With Canvas Do
  Begin
    Pen.Color:= clBlue;
    Brush.Color:= clBlue;
    Rectangle(0,0,2*Xk,2*Yk);
    With Pen Do
    Begin
      Width:= 3;
      Color:= clWhite;
    End;
    MoveTo(Xk-2*R-1,0); LineTo(Xk-2*R-1,6*R); LineTo(6*R,Xk-2*R-1);
    MoveTo(Xk+2*R+1,0); LineTo(Xk+2*R+1,6*R); LineTo(2*Xk-6*R,Xk-2*R-1);
    With Pen Do
    Begin
      Width:= 1;
      Color:= clRed;
    End;
    Brush.Color:= clRed;
    For I:= 1 To N Do For J:= I To N Do
    Begin
      If Odd(J) Then
      Begin
        MoveTo(Dx*(N-I)+Dx*(J Div 2)+Ex,Dy*J+Ey);
        LineTo(Dx*(N-I)+Dx*(J Div 2)+Ex-2*R,Dy*J+Ey+2*R);
        LineTo(Dx*(N-I)+Dx*(J Div 2)+Ex,Dy*J+Ey+4*R);
        LineTo(Dx*(N-I)+Dx*(J Div 2)+Ex+2*R,Dy*J+Ey+2*R);
        LineTo(Dx*(N-I)+Dx*(J Div 2)+Ex,Dy*J+Ey);
        FloodFill(Dx*(N-I)+Dx*(J Div 2)+Ex,Dy*J+Ey+1,clRed,fsBorder);
      End Else
      Begin
        MoveTo(Dx*(N-I)+Dx*(J Div 2)-Dx Div 2+Ex,Dy*J+Ey);
        LineTo(Dx*(N-I)+Dx*(J Div 2)-Dx Div 2+Ex-2*R,Dy*J+Ey+2*R);
        LineTo(Dx*(N-I)+Dx*(J Div 2)-Dx Div 2+Ex,Dy*J+Ey+4*R);
        LineTo(Dx*(N-I)+Dx*(J Div 2)-Dx Div 2+Ex+2*R,Dy*J+Ey+2*R);
        LineTo(Dx*(N-I)+Dx*(J Div 2)-Dx Div 2+Ex,Dy*J+Ey);
        FloodFill(Dx*(N-I)+Dx*(J Div 2)-Dx Div 2+Ex,Dy*J+Ey+1,clRed,fsBorder);
      End;
    End;
    Pen.Color:= clWhite;
    Brush.Color:= clBlue;
    For I:= 1 To N+1 Do
    Begin
      MoveTo(I*Dx-9*R,(N+2)*Dy-R);
      LineTo(I*Dx-9*R,2*Yk-15);
      MoveTo(I*Dx+R,(N+2)*Dy-R);
      LineTo(I*Dx+R,2*Yk-15);
      MoveTo(I*Dx-9*R,2*Yk-15);
      LineTo(I*Dx+R,2*Yk-15);
      Font.Color:= clBtnFace;
      Str(I,Ws); TextOut(I*Dx-5*R, 2*Yk-14, Ws);
    End;
    With Font Do
    Begin
      Name:= 'Times New Roman';
      Color:= clYellow;
      Size:= 30;
      Style:= [fsBold,fsUnderLine];
    End;
    TextOut(100,10,'Galton'); TextOut(2*Xk-200,10,'Deszka');
    With Font Do
    Begin
      Size:= 12;
      Name:= 'courier';
      Style:= [fsBold];
    End;
  End;
  For I:= 1 To M+1 Do
  Begin
    Fg[I]:= TGolyo.Create;
    Fg[I].Init(Xk,R,R); Fg[1].Show;
  End;
  Fg[1].SetMove;
End;

procedure TfmGalton.btKilepesClick(Sender: TObject);
begin
  Close;
end;

procedure TfmGalton.FormCreate(Sender: TObject);
begin
  Xk:= ClientWidth Div 2;
  Yk:= ClientHeight Div 2;
  Randomize;
end;

Procedure TfmGalton.Animacio;
Var I, K: Byte;
    L: LongInt;
    S, SM: Word;
    Ws: String;
Begin
  I:= 1; S:= 0; SM:= 2*Yk-(N+3)*Dy;
  Repeat
    With Fg[I] Do If Moved Then With Canvas Do
    Begin
      MoveRel(GetD,1);
      If GetY Mod Dy=0 Then
      Begin
        SetD(1-2*Random(2));
        Fg[I+1].SetMove;
      End;
      If GetY>(N+1)*Dy Then
      Begin
        K:= ((GetX-5*R) Div Dx)+1; Inc(D[K]);
        Brush.Color:= clWhite;
        Pen.Color:= ClWhite;
        Rectangle((K-1)*Dx+4*R,2*Yk-2-D[K]-12,(K-1)*Dx+Dx,2*Yk-14);
        Hide; Init(Xk,R,R); SetMove; Show; Inc(S);
        Pen.Color:= clBlue;
        Brush.Color:= clBlue;
        Font.Color:= clWhite;
        Rectangle(100,100,200,210);
        Str(S,Ws); TextOut(100,100,'Teljes: '+Ws);
        Str(D[ 9],Ws); TextOut(2*Xk-200,100,'D[ 9]: '+Ws);
        Str(D[10],Ws); TextOut(2*Xk-200,120,'D[10]: '+Ws);
        Str(D[11],Ws); TextOut(2*Xk-200,140,'D[11]: '+Ws);
        Str(D[12],Ws); TextOut(2*Xk-200,160,'D[12]: '+Ws);
        Str(D[13],Ws); TextOut(2*Xk-200,180,'D[13]: '+Ws);
      End;
      For L:= 1 To 100 Do Pixels[200,20]:= clBlue;
    End;
    Inc(I); If I>M Then I:= 1;
  Until (D[9]>SM) Or (D[10]>SM) Or
       (D[11]>SM) Or (D[12]>SM) Or (D[13]>SM);
  For I:= 1 To M+1 Do Fg[I].Hide;
End;

procedure TfmGalton.btStartClick(Sender: TObject);
begin
  Animacio;
end;

procedure TfmGalton.FormPaint(Sender: TObject);
begin
  Deszka;
end;

end.

Ez a program azt próbálja bemutatni, hogy a kétdimenziós vektortérben hogyan hatnak az egyes vektorokra a lineáris transzformációk. Megadhatjuk a transzformáció mátrixát, megadhatjuk a koordinátarendszerben az egységet. A statikus képen az egységkör kerületére mutató vektorok képét fehér színnel rajzolja a program (a vektor végét jelző nyíltól eltekintve), majd sárgával a transzformált vektorokat, melyek mindig egy ellipszis (speciális esetben egy kör) kerületére mutatnak. Animációt is bekapcsolhatunk, ekkor az eredeti vektor piros, a képvektor kék színben jelenik meg, és a változási sebesség menet közben módosítható. Jó szórakozást a program használatához.

A program egy futási képe:

A program listája:

unit ULinalgDemo;

interface

uses
  Windows, Messages, SysUtils, Classes,

  Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Spin;

type
  TfmLinalgDemo = class(TForm)
    btKilepes: TButton;
    btStart: TButton;
    lbA11: TLabel;
    edA11: TEdit;
    lbA12: TLabel;
    edA12: TEdit;
    lbA21: TLabel;
    edA21: TEdit;
    lbA22: TLabel;
    edA22: TEdit;
    btAlap: TButton;
    edMaxKoord: TEdit;
    lbMaxKoord: TLabel;
    lbSajat: TLabel;
    lbSzogValt: TLabel;
    edSzogValt: TEdit;
    btAnimacio: TButton;
    tiIdozito: TTimer;
    seSebes: TSpinEdit;
    lbSebes: TLabel;
    Procedure KepTorles;
    Procedure Alap;
    procedure btAlapClick(Sender: TObject);
    Procedure MatrixOlvas;
    Procedure TranszformKepre;
    Procedure SajatErtek;
    Procedure IrEgyenes(M, B: Real);
    Procedure NormEgyenes(A, B, C: Real);
    procedure btStartClick(Sender: TObject);
    procedure btKilepesClick(Sender: TObject);
    procedure tiIdozitoTimer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btAnimacioClick(Sender: TObject);
    procedure seSebesChange(Sender: TObject);
    procedure edA11Change(Sender: TObject);
    procedure edA12Change(Sender: TObject);
    procedure edA21Change(Sender: TObject);
    procedure edA22Change(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

Const Max=5000;

var
  fmLinalgDemo: TfmLinalgDemo;
  Xm,Ym, Xk,Yk: Integer;            //képenyő és félképernyő méretek
  N: Integer;                       //vektorok száma az egységkörben
  P: Integer;                       //maximális egész koordináta
  D: Integer;                       //egész koordináta-távolsága pixelben
  Ds: Integer;                      //fokonkénti rajzolás
  A: Array[1..2,1..2] Of Real;      //a lineáris transzformáció mátrixa
  K1, K2: Real;                     //a lineáris transzformáció sajátértékei
  Animal: Boolean;                  //az animációt figyelő
  AN: Integer;                      //az animációban aktuális vektor sorszáma

implementation

{$R *.DFM}

Procedure TfmLinalgDemo.KepTorles;  //a képernyő törlése
Var R: TRect;
Begin
  R.Left:= 0; R.Top:= 0; R.Right:= Xm; R.Bottom:= Ym; Canvas.FillRect(R);
  lbMaxKoord.Repaint; lbSzogValt.Repaint;
  lbA11.Repaint; lbA12.Repaint;
  lbA21.Repaint; lbA22.Repaint;
  lbSajat.Repaint;
End;

procedure TfmLinalgDemo.Alap;       //koordinátarendszer és az egységkör
Var I: Integer;
Begin
  Xm:= ClientWidth; Ym:= ClientHeight;
  Xk:= Xm Div 2; Yk:= Ym Div 2; D:= Yk Div P;
  With Canvas Do
  Begin
    Pen.Color:= clBlack;
    MoveTo(Xk,0); LineTo(Xk,Ym);
    MoveTo(Xk-Yk,Yk); LineTo(Xk+Yk,Yk);
    For I:= 1 To P Do
    Begin
      MoveTo(Xk+I*D,Yk-5); LineTo(Xk+I*D,Yk+5);
      TextOut(Xk+I*D,Yk+10,IntToStr(I));
      MoveTo(Xk-I*D,Yk-5); LineTo(Xk-I*D,Yk+5);
      TextOut(Xk-I*D-4,Yk+10,'-'+IntToStr(I));
      MoveTo(Xk-5,Yk+I*D); LineTo(Xk+5,Yk+I*D);
      TextOut(Xk-20,Yk+I*D-6,'-'+IntToStr(I));
      MoveTo(Xk-5,Yk-I*D); LineTo(Xk+5,Yk-I*D);
      TextOut(Xk-20,Yk-I*D-6,IntToStr(I));
    End;
    Pen.Color:= clWhite;
    For I:= 1 To N Do
    Begin
      MoveTo(Xk,Yk);
      LineTo(Xk + Round(D*Cos(I*Ds*Pi/180)), Yk - Round(D*Sin(I*Ds*Pi/180)));
    End;
  End;
End;

procedure TfmLinalgDemo.btAlapClick(Sender: TObject);
Var Kod: Integer;
begin
  Val(edSzogValt.Text,Ds,Kod); N:= Round(360/Ds);
  Val(edMaxKoord.Text,P,Kod);
  KepTorles; Alap;
  Animal:= False; btAnimacio.Enabled:= False;
end;

Procedure TfmLinalgDemo.MatrixOlvas; //a maátrix beolvasása ellenőrzés nélkül
Var Kod: Integer;
Begin
  Val(edA11.Text,A[1,1],Kod); Val(edA12.Text,A[1,2],Kod);
  Val(edA21.Text,A[2,1],Kod); Val(edA22.Text,A[2,2],Kod);
End;

procedure TfmLinalgDemo.edA11Change(Sender: TObject);
begin
  MatrixOlvas; Keptorles;
  btAlapClick(Sender); btStartClick(Sender);
end;

procedure TfmLinalgDemo.edA12Change(Sender: TObject);
begin
  MatrixOlvas; Keptorles;
  btAlapClick(Sender); btStartClick(Sender);
end;

procedure TfmLinalgDemo.edA21Change(Sender: TObject);
begin
  MatrixOlvas; Keptorles;
  btAlapClick(Sender); btStartClick(Sender);
end;

procedure TfmLinalgDemo.edA22Change(Sender: TObject);
begin
  MatrixOlvas; Keptorles;
  btAlapClick(Sender); btStartClick(Sender);
end;

Procedure TfmLinalgDemo.TranszformKepre; //a kör transzformáltjának rajzolása
Var I: Word;
Begin
  With Canvas Do
  Begin
    Pen.Color:= clYellow;
    For I:= 1 To N Do
    Begin
      MoveTo(Xk,Yk);
      LineTo(Xk + Round(A[1,1]*D*Cos(I*Ds*Pi/180)+A[1,2]*D*Sin(I*Ds*Pi/180)),
             Yk - Round(A[2,1]*D*Sin(I*Ds*Pi/180)+A[2,2]*D*Sin(I*Ds*Pi/180)));
    End;
  End;
End;

Procedure TfmLinalgDemo.SajatErtek;      //a sájátértékek meghatározása
Var DetA, SpurA, Di: Real;
    S1, S2, S: String;
    N1, N2, M1, M2: Real;
Begin
  DetA:= A[1,1]*A[2,2]-A[2,1]*A[1,2];    //a mátrix determinánsa
  SpurA:= A[1,1]+A[2,2];                 //a mátrix spurja
  //a karakterisztikus egyenlet: k*k - SpurA*k + DetA = 0
  Di:= SpurA*SpurA-4*DetA;               //a karakterisztikus egyenlet
                                         //diszkriminánsa
  If Di>=0 Then                           //két valós gyök
  Begin
    K1:= (SpurA+Sqrt(Di))/2;              //sajátértékek
    K2:= (SpurA-Sqrt(Di))/2;
    Str(K1:4:2, S1);
    Str(K2:4:2, S2);
    S:= 'Sajátérték: '+S1+' és '+S2;
    N1:= A[2,2]-A[1,2]-K1;
    N2:= A[2,2]-A[1,2]-K2;
    With Canvas Do
    Begin
      If N1<>0 Then M1:= (A[1,1]-A[2,1]-K1)/N1 Else M1:= Max;
      If N2<>0 Then M2:= (A[1,1]-A[2,1]-K2)/N2 Else M2:= Max;
      Pen.Color:= clGreen;
      If M1=0 Then M1:= 1/Max; IrEgyenes(M1,0);
      If M2=0 Then M2:= 1/Max; IrEgyenes(M2,0);
    End;
  End
  Else S:= 'Nincs sajátérték';
  lbSajat.Caption:= S;
End;

Procedure TfmLinalgDemo.IrEgyenes(M, B: Real); //irányvektoros egyenes
Begin
  If M=0 Then Exit;
  NormEgyenes(M,-1,B);
End;

Procedure TfmLinalgDemo.NormEgyenes(A, B, C: Real); //normálvektoros egyenes
Const Dx=50;
      Dy=50;
Var Xh, Yh: Real;
Begin
  If A*B=0 Then Exit;
  Xh:= Xk/Dx; Yh:= Yk/Dy;
  With Canvas Do
  Begin
    MoveTo(0, Yk+Round(Dy*(C-Xh*A)/B));
    LineTo(Xm, Yk+Round(Dy*(C+Xh*A)/B));
    MoveTo(Xk-Round(Dx*(C-Yh*B)/A), Ym);
    LineTo(Xk-Round(Dx*(C+Yh*B)/A), 0);
  End;
End;

procedure TfmLinalgDemo.btStartClick(Sender: TObject);
begin
  KepTorles; btAlapClick(Sender);
  MatrixOlvas; TranszformKepre; SajatErtek;
  btAnimacio.Enabled:= True;
end;

procedure TfmLinalgDemo.tiIdozitoTimer(Sender: TObject);
begin
  If Not Animal Then Exit;
  With Canvas Do
  Begin
    Pen.Color:= clWhite;
    MoveTo(Xk,Yk);
    LineTo(Xk + Round(D*Cos(AN*Ds*Pi/180)), Yk - Round(D*Sin(AN*Ds*Pi/180)));
    Pen.Color:= clYellow;
    MoveTo(Xk,Yk);
    LineTo(Xk + Round(A[1,1]*D*Cos(AN*Ds*Pi/180)+A[1,2]*D*Sin(AN*Ds*Pi/180)),
           Yk - Round(A[2,1]*D*Sin(AN*Ds*Pi/180)+A[2,2]*D*Sin(AN*Ds*Pi/180)));

    Inc(AN);

    Pen.Color:= clRed;
    MoveTo(Xk,Yk);
    LineTo(Xk + Round(D*Cos(AN*Ds*Pi/180)), Yk - Round(D*Sin(AN*Ds*Pi/180)));
    Pen.Color:= clBlue;
    MoveTo(Xk,Yk);
    LineTo(Xk + Round(A[1,1]*D*Cos(AN*Ds*Pi/180)+A[1,2]*D*Sin(AN*Ds*Pi/180)),
           Yk - Round(A[2,1]*D*Sin(AN*Ds*Pi/180)+A[2,2]*D*Sin(AN*Ds*Pi/180)));
  End;
end;

procedure TfmLinalgDemo.seSebesChange(Sender: TObject);
begin
  tiIdozito.Interval:= seSebes.Value;
end;

procedure TfmLinalgDemo.FormCreate(Sender: TObject);
begin
  Animal:= False; AN:= 0;
  tiIdozito.Interval:= seSebes.Value;
end;

procedure TfmLinalgDemo.btAnimacioClick(Sender: TObject);
begin
  Animal:= Not Animal;
  With btAnimacio Do If Animal Then
  Caption:= 'Animáció Ki' Else Caption:= 'Animáció Be';
end;

procedure TfmLinalgDemo.btKilepesClick(Sender: TObject);
begin
  Close;
end;

end.