Karakterkészlet

Ez egy nagyon egyszerű kis program. Gyakorlatilag egy sztringrács tulajdonságainak beállításán és egy kettős For cikluson kívül semmit nem tartalmaz. Talán a megjelenített karakterek hordoznak némi információt. Megfigyelhető a 128-as kódnál nagyobb kódú karaktereknél a nemzetközi karakterkészlet sajátos kiosztása.

A program futási képe:

A program listája:

unit UKarakt;

interface

uses
  Windows, Messages, SysUtils, Classes,

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

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

var
  fmKarakterek: TfmKarakterek;

implementation

{$R *.DFM}

procedure TfmKarakterek.FormCreate(Sender: TObject);
Var I, J: Integer;
begin
With sgKarakterek Do
Begin
    ColWidths[0]:= 24;
For I:= 0 To 15 Do Cells[0,I+1]:= IntToStr(I);
For I:= 0 To 15 Do Cells[I+1,0]:= IntToStr(I);
For I:= 0 To 15 Do For J:= 0 To 15 Do
    Cells[I+1,J+1]:= IntToStr(I*16+J)+': '+Chr(I*16+J);
End;
end;

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

end.

Számológép

Írjunk programot, amely egy egyszerű zsebszámológép működését szimulálja. A program legyen képes a négy alapművelet végrehajtására, lehessen utolsó bevitt adatot és minden adatot törölni. Nyomógomb legyen a kikapcsolására is.

A számjegyeket és műveleti jeleket tartalmazó nyomógombokat futási időben állítsa elő a program.

A program formja szerkesztési időben:

A futtatási kép:

A program listája:

unit USzgep;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, 

Graphics, Controls, Forms, Dialogs, StdCtrls;
type
  TfmSzGep = class(TForm)
    edEred: TEdit;
    btOff: TButton;
    btCE: TButton;
    btCLR: TButton;
Procedure SzGombClick(Sender: TObject);
Procedure MuGombClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btOffClick(Sender: TObject);
procedure btCLRClick(Sender: TObject);
procedure btCEClick(Sender: TObject);
private
public
end;
var
  fmSzGep: TfmSzGep;
  SzBt: Array[1..12] Of TButton;
  MuBt: Array[1..5] Of TButton;
  Muv: String; E, A, B: Real;
  Elso, Uj: Boolean;

implementation
{$R *.dfm}

Procedure TfmSzGep.SzGombClick(Sender: TObject);
Begin
If Uj Then edEred.Text:= '0';
With Sender As TButton Do If Caption<>'+/-' Then
Begin
If edEred.Text='0' Then edEred.Text:= Caption
Else edEred.Text:= edEred.Text+Caption;
End Else
Begin
If edEred.Text[1]='-' Then
    edEred.Text:= Copy(edEred.Text,2,Length(edEred.Text)-1)
Else edEred.Text:= '-'+edEred.Text;
End;
  Uj:= False;
End;

Procedure TfmSzGep.MuGombClick(Sender: TObject);
Var Kod: Integer; Ws: String;
Begin
  Uj:= True;
If Elso Then Val(edEred.Text,A, Kod)

Else Val(edEred.Text,B, Kod);
  Elso:= Not Elso;
With Sender As TButton Do If Caption<>'=' Then Muv:= Caption;
With Sender As TButton Do If Caption='=' Then
Begin
If Muv='+' Then E:= A+B; If Muv='-' Then E:= A-B;
If Muv='*' Then E:= A*B; If Muv='/' Then E:= A/B;
    Str(E:10:4,Ws); If Pos('.',Ws)>0 Then
While Ws[Length(Ws)]='0' Do Ws:= Copy(Ws,1,Length(Ws)-1);
If Ws[Length(Ws)]='.' Then Ws:= Copy(Ws,1,Length(Ws)-1);
    edEred.Text:= Ws; Elso:= True;
End;
End;

procedure TfmSzGep.FormCreate(Sender: TObject);
Var I: Integer;
begin
  B:= 0; E:= 0; Elso:= True; Uj:= False;
For I:= 1 To 12 Do
Begin
    SzBt[I]:= TButton.Create(Self);
With SzBt[I] Do
Begin
      Parent:= fmSzGep;
      Top:= 100+30*((I-1) Div 3);
      Left:= 100+40*((I-1) Mod 3);
      Width:= 30;
      Height:= 20;
With Font Do
Begin
        Style:= [fsBold];
        Size:= 10;
End;
Case I Of
        1..9: Caption:= IntToStr(I);
        10: Caption:= '0';
        11: Caption:= '.';
        12: Caption:= '+/-';
End;
      OnClick:= SzGombClick;
End;
End;
For I:= 1 To 5 Do
Begin
    MuBt[I]:= TButton.Create(Self);
With MuBt[I] Do
Begin
      Parent:= fmSzGep;
      Top:= 70+30*I;
      Left:= 230;
      Width:= 30;
      Height:= 20;
With Font Do
Begin
        Style:= [fsBold];
        Size:= 10;
End;
Case I Of
        1: Caption:= '+';
        2: Caption:= '-';
        3: Caption:= '*';
        4: Caption:= '/';
        5: Begin Height:= 25; Caption:= '=' End;
End;
      OnClick:= MuGombClick;
End;
End;
With btOff Do Begin Top:= 220; Left:= 100 End;
With btCLR Do Begin Top:= 220; Left:= 140 End;
With  btCE Do Begin Top:= 220; Left:= 180 End;
end;

procedure TfmSzGep.btOffClick(Sender: TObject);
begin
  Close;
end;

procedure TfmSzGep.btCLRClick(Sender: TObject);
begin
  edEred.Text:= '0'; A:= 0; B:= 0; E:= 0;
end;

procedure TfmSzGep.btCEClick(Sender: TObject);
begin
  edEred.Text:= '0'; If Elso Then A:= 0 Else B:=0;
end;

end.

Személyi azonosítók ellenőrzése

Gyakran előfordul, hogy személyekkel kapcsolatos adatok között számszerű azonosítókat is rögzíteni kell. A helyes adatrögzítést segítendő, a bevitel után célszerű az azonosító helyességének ellenőrzése. Erre mutat lehetőséget ez a program, hiszen minden azonosító utolsó számjegye egy kontrol számjegy, mely előzőkből egyszerű matematikai műveletekkel származtatható.

A program futási képe:

A program listája:

unit USzemAzon;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TfmSzemAzon = class(TForm)
    lbSzemAzon: TLabel;
    lbKIR: TLabel;
    edKIR: TEdit;
    lbTAJ: TLabel;
    edTAJ: TEdit;
    lbAdo: TLabel;
    edAdo: TEdit;
    lbSzemSzam: TLabel;
    edSzemSzam: TEdit;
    btKIR: TButton;
    btTAJ: TButton;
    btAdo: TButton;
    btSzemSzam: TButton;
    edKIREr: TEdit;
    edTAJEr: TEdit;
    edAdoEr: TEdit;
    edSzemSzamEr: TEdit;
    btKilepes: TButton;
procedure btKilepesClick(Sender: TObject);
procedure btKIRClick(Sender: TObject);
procedure btTAJClick(Sender: TObject);
procedure btAdoClick(Sender: TObject);
procedure btSzemSzamClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

  St11=String[11];
  St10=String[10];
  St9=String[9];

var
  fmSzemAzon: TfmSzemAzon;

implementation

{$R *.dfm}

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

Function JoKIR(S: St11): Boolean;
Var I, N: Word;
Begin
  JoKIR:= False; If Length(S)<>11 Then Exit;
For I:= 1 To 11 Do If Not(S[I] In ['0'..'9']) Then
Begin Break; Exit End;
  N:= 0; For I:= 1 To 10 Do N:= N+I*StrToInt(S[I]);
  JoKIR:= (N Mod 11)=StrToInt(S[11]);
End;

Function JoTAJ(S: St9): Boolean;
Var I, N: Word;
Begin
  JoTAJ:= False; If Length(S)<>9 Then Exit;
For I:= 1 To 9 Do If Not(S[I] In ['0'..'9']) Then
Begin Break; Exit End;
  N:= 3*StrToInt(S[1])+
      7*StrToInt(S[2])+
      3*StrToInt(S[3])+
      7*StrToInt(S[4])+
      3*StrToInt(S[5])+
      7*StrToInt(S[6])+
      3*StrToInt(S[7])+
      7*StrToInt(S[8]);
  JoTAJ:= (N Mod 10)=StrToInt(S[9]);
End;

Function JoAdo(S: St10): Boolean;
Var I, N: Word;
Begin
  JoAdo:= False; If Length(S)<>10 Then Exit;
For I:= 1 To 10 Do If Not(S[I] In ['0'..'9']) Then
Begin Break; Exit End;
  N:= 0; For I:= 1 To 9 Do N:= N+I*StrToInt(S[I]);
  JoAdo:= (N Mod 11)=StrToInt(S[10]);
End;

Function JoSzemSzam(S: St11): Boolean;
Var I, N: Word;
begin
  JoSzemSzam:= False; If Length(S)<>11 Then Exit;
For I:= 1 To 11 Do If Not(S[I] In ['0'..'9']) Then
Begin Break; Exit End;
  N:= 0; For I:= 1 To 10 Do N:= N+I*StrToInt(S[I]);
  JoSzemSzam:= (N Mod 11)=StrToInt(S[11]);
end;

procedure TfmSzemAzon.btKIRClick(Sender: TObject);
begin
If JoKir(edKIR.Text) Then edKIREr.Text:= 'Igen' Else

edKIREr.Text:= 'Nem';
end;

procedure TfmSzemAzon.btTAJClick(Sender: TObject);
begin
If JoTAJ(edTAJ.Text) Then edTAJEr.Text:= 'Igen' Else

edTAJEr.Text:= 'Nem';
end;

procedure TfmSzemAzon.btAdoClick(Sender: TObject);
begin
If JoAdo(edAdo.Text) Then edAdoEr.Text:= 'Igen' Else

edAdoEr.Text:= 'Nem';
end;

procedure TfmSzemAzon.btSzemSzamClick(Sender: TObject);
begin
If JoSzemSzam(edSzemSzam.Text) Then edSzemSzamEr.Text:= 'Igen' 

Else edSzemSzamEr.Text:= 'Nem';
end;

end.

Sejtek

Írjunk programot, mely egy sejtből kiindulva, egyre nagyobb sejttelepet hoz létre. A születendő sejteket véletlen választással hozzuk létre. A születés akkor adjon valóban új sejtet, ha az adott helyen és a 8 szomszédos helyen, összesen csak egyetlen sejt létezik. Megfigyelhetjük a sejttelep fejlődésében a fa struktúrát, azaz nem abszolút véletlenül épül fel a kolónia (felépítése talán korallhoz hasonlít legjobban).

Egy futtatás végeredménye:

A program listája:

unit USejtek;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, 

Graphics, Controls, Forms, Dialogs, StdCtrls;

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

var
  fmSejtek: TfmSejtek;

implementation

{$R *.dfm}

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

procedure TfmSejtek.FormPaint(Sender: TObject);
Var X, Y, Xk, Yk, Xb,Xj, Yf,Yl, Di: Integer;
    J: LongInt;
    A,B,C,D,E,F,G,H,I: Byte;
begin
  btKilepes.Enabled:= False;
  Xk:= ClientWidth Div 2;
  Yk:= ClientHeight Div 2;
  Di:= 10;
  Randomize;
With Canvas Do
Begin
    Pixels[Xk,Yk]:= 0;
    Xb:= Xk-Di; Xj:= Xk+Di;
    Yf:= Yk-Di; Yl:= Yk+Di;
    Sleep(500);
For J:= 1 To 1000000 Do
Begin
      X:= Random(Xj-Xb+1)+Xb;
      Y:= Random(Yl-Yf+1)+Yf;
      A:= 0; B:= 0; C:= 0; D:= 0; E:= 0;
      F:= 0; G:= 0; H:= 0; I:= 0;
If (Pixels[X-1,Y-1]=0) Then A:= 1;
If (Pixels[X  ,Y-1]=0) Then B:= 1;
If (Pixels[X+1,Y-1]=0) Then C:= 1;
If (Pixels[X-1,Y  ]=0) Then D:= 1;
If (Pixels[X  ,Y  ]=0) Then E:= 1;
If (Pixels[X+1,Y  ]=0) Then F:= 1;
If (Pixels[X-1,Y+1]=0) Then G:= 1;
If (Pixels[X,  Y+1]=0) Then H:= 1;
If (Pixels[X+1,Y+1]=0) Then I:= 1;
If A+B+C+D+E+F+G+H+I=1 Then
Begin
        Pixels[X,Y]:= 0;
If X-Di<Xb Then Xb:= X-Di;
If X+Di>Xj Then Xj:= X+Di;
If Y-Di<Yf Then Yf:= Y-Di;
If Y+Di>Yl Then Yl:= Y+Di;
End;
End;
End;
  btKilepes.Enabled:= True;
end;

end.

Fraktál

Hozzunk létre véletlen fraktált a számítógép segítségével, mely pontokból áll össze. A generálás alapja az legyen, hogy a fraktál csak lapszomszéd szerint növekedhet. Ha véletlen választunk egy pontot a síkon, akkor azt addig mozgassuk véletlenül tengelyirányokba, ameddig hozzá nem tapad, a már meglévő pontokhoz. Így a fraktál növekedése egy fához hasonlít, csak a burjánzás mind a négy irányba megtörténik. A fraktál növekedésével a generálás lelassul, mert egyre több új pont nem tud a meglévőkhöz tapadni, hamarabb jut el a véletlen választás határához, amikor megsemmisül. (A program a Sejtek programhoz hasonló, viszont a generálás alapvetően más, mint ott, ezáltal a végeredmény is jelentősen különbözik, az ott látottaktól.)

A program futási képe körülbelül két perc után:

A program listája:

unit UFraktal;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

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

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

var
  fmFraktal: TfmFraktal;
  X, Y, Xk, Yk, Fx, D: Integer;


implementation

{$R *.dfm}

procedure TfmFraktal.tiIdozitoTimer(Sender: TObject);
begin
With Canvas Do
Begin
While (Pixels[X-1,Y]=clBlack) And (Pixels[X+1,Y]=clBlack) And
          (Pixels[X,Y-1]=clBlack) And (Pixels[X,Y+1]=clBlack) And
          (X>Xk-D) And (X<Xk+D) And (Y>Yk-D) And (Y<Yk+D) Do
Begin
      Pixels[X, Y]:= clBlack;
Case Random(4) Of
        0: Dec(X);
        1: Dec(Y);
        2: Inc(X);
        3: Inc(Y);
End;
      Pixels[X, Y]:= clWhite;
If (X=Xk-D) Or (X=Xk+D) Or (Y=Yk-D) Or (Y=Yk+D)
Then Pixels[X, Y]:= clBlack;
End;
If Not((X=Xk-D) Or (X=Xk+D) Or (Y=Yk-D) Or (Y=Yk+D)) Then
If X<Fx Then Fx:= X; D:= 20+2*(Xk-Fx);
    X:= Xk + Random(D) - (D Div 2);
    Y:= Yk + Random(D) - (D Div 2);
End;
end;

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

procedure TfmFraktal.FormPaint(Sender: TObject);
begin
  Xk:= ClientWidth Div 2;
  Yk:= ClientHeight Div 2;
  Fx:= Xk; Randomize; D:= 20;
With Canvas Do
Begin
    Pen.Color:= clBlack;
    Brush.Color:= clBlack;
    Rectangle(0,0,2*Xk,2*Yk);
    Pixels[Xk, Yk]:= clWhite;
End;
  X:= Xk + Random(D) - (D Div 2);
  Y:= Yk + Random(D) - (D Div 2);
end;

end.