Программирование на Delphi

FAQ VCL
Математика

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Как вычислить строку с математической формулой?


// Способ первый
function RecFunc( st: string; x: Double ): Double;
var
  sf: string;
  ls: LongInt;
  r: Double;
  i, j, k, b: LongInt;
begin
   if st = '' then
   begin
      Result := 0;
      Exit;
   end;
   if ( Pos( '-', st ) <= 0 ) and ( Pos( '+', st ) <= 0 ) and
      ( Pos( '/', st ) <= 0 ) and ( Pos( '*', st ) <= 0 ) and ( Pos( '(', st ) <= 0 ) then
   begin
      sf := LowerCase( st );
      if sf = 'x' then
         Result := x
      else
         if sf = 'pi' then
            Result := pi
         else
            if sf = 'e' then
               Result := Exp( 1 )
            else
               Result := StrToFloat( st );
      Exit;
   end;
   if st[Length( st )] = ')' then
   begin
      k := Pos( '(', st );
      j := 1;
      b := 1;
      ls := 1;
      for i := 1 to k-1 do
         if ( st[i] = '-' ) or ( st[i] = '+' ) or ( st[i] = '/' ) or ( st[i] = '*' ) then
            ls := 0;
      if ls = 1 then
         for i := k+1 to Length( st ) do
         begin
            if st[i] = '(' then
               Inc( j )
            else
               if st[i]= ')' then
                  Dec( j );
            if j = 0 then
            begin
               if i = Length( st ) then
                  b := 0;
               Break;
            end;
         end;
      if ( ls = 1 ) and ( k > 0 ) and ( b = 0 ) then // simple func
      begin
         sf := LowerCase( Copy( st, 1, k-1 ) );
         if sf = 'sin' then Result := Sin ( RecFunc( Copy( st, k+1, Length( st )-k-1 ), x ) ) else
         if sf = 'cos' then Result := Cos( RecFunc( Copy( st, k+1, Length( st )-k-1), x ) ) else
         if sf = 'abs' then Result := Abs( RecFunc( Copy( st, k+1, Length( st )-k-1 ), x ) ) else
         if sf = 'ln' then Result := Ln( RecFunc( Copy( st, k+1, Length( st )-k-1 ),x ) ) else
         if sf = 'exp' then Result :=Exp( RecFunc( Copy( st, k+1, Length( st )-k-1 ),x ) ) else
         if sf = 'sqr' then Result :=Sqr( RecFunc( Copy( st, k+1, Length( st )-k-1 ),x ) ) else
         if sf = 'sqrt' then Result :=Sqrt( RecFunc( Copy( st, k+1, Length( st )-k-1 ),x ) ) else
         if sf = 'arctan' then Result :=ArcTan( RecFunc( Copy( st, k+1, Length( st )-k-1 ),x ) ) else
         Result := RecFunc( Copy( st, k+1, Length( st )-k-1 ), x );
         Exit;
      end;
   end;
   k := 0; // num of "("
   b := 1; // begin of st
   ls := 1;
   r := 0;
   for i := 1 to Length( st ) do
   begin
      if st[i] = '(' then
         Inc( k )
      else
         if st[i] = ')' then
            Dec( k );
      if ( k = 0 ) and ( ( st[i] = '+' ) or ( st[i] = '-' ) ) then
      begin
         r := r + ls * RecFunc( Copy( st, b, i-b ), x );
         if st[i] = '+' then
            ls := 1
         else
            ls := -1;
         b := i+1;
      end;
   end;
   if b > 1 then
      r := r + ls * RecFunc( Copy( st, b, Length( st )-b+1 ), x );
   if b = 1 then
   begin
      r := 1;
      ls := 0;
      for i := 1 to Length( st ) do
      begin
         if st[i] = '(' then
            Inc( k )
         else
            if st[i] = ')' then
               Dec( k );
         if ( k = 0 ) and ( ( st[i] = '/' ) or ( st[i] = '*' ) ) then
         begin
            if ls = 0 then
               r := r * RecFunc( Copy( st, b, i-b ), x )
            else
               r := r / RecFunc( Copy( st, b, i-b ), x );
            if st[i] = '/' then
               ls := 1
            else
               ls:=0;
            b := i+1;
         end;
      end;
      if ls = 0 then
         r := r * RecFunc( Copy( st, b, Length( st )-b+1 ), x )
      else
         r := r / RecFunc( Copy( st, b, Length( st )-b+1 ), x );
      Result := r;
   end
   else
      Result := r;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage( FloatToStr( RecFunc( '5*3+sqrt(10)', 0 ) ) );
   ShowMessage( FloatToStr( RecFunc( 'exp(x)', 1 ) ) );
end;

// Способ второй
uses
  {...,} ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  sc: Variant;
begin
   sc := CreateOLEObject( 'ScriptControl' );
   try
      sc.Language := 'VBScript';
      sc.Timeout := -1;
      sc.AllowUI := True;
      Caption := sc.Eval( '2+2*2' );
   finally
      sc := Unassigned;
   end;
end;

// Способ третий
uses
  {...,} JclExprEval; // JEDI

function MySqrt( X: Extended ): Extended;
begin
   Result := Sqrt( X );
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Evaluator: TEvaluator;
  Value: TFloat;
  x: Extended;
begin
   Evaluator := TEvaluator.Create;
   try
      Evaluator.AddFunc( 'sqrt', MySqrt );
      Evaluator.AddVar( 'x', x );
      x := 4;
      Value := Evaluator.Evaluate( '(2+2*sqrt(x))' );
      ShowMessage( FloatToStr( Value ) );
   finally
      Evaluator.Free;
   end;
end;

Как вычислить логарифм?


function Log( x, b: Real ): Real;
begin
   Result := ln( x ) / ln( b );
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage( Format( '%f', [Log( 8, 2 {основание} )] ) );
end;

Как определить в какой координатной четверти лежит точка?


// Способ первый
type
  TQuarter = ( qZero, qAxisX, qAxisY, qQuarter1, qQuarter2, qQuarter3, qQuarter4 );

function GetQuarter( p: TPoint ): TQuarter;
begin
   if ( p.X = 0 ) and ( p.Y = 0 ) then
      Exit( qZero );
   if p.X = 0 then
      Exit( qAxisX );
   if p.Y = 0 then
      Exit( qAxisY );

   if ( p.X > 0 ) and ( p.Y > 0 ) then
      Result := qQuarter1
   else
      if ( p.X < 0 ) and ( p.Y > 0 ) then
         Result := qQuarter2
      else
         if ( p.X < 0 ) and ( p.Y < 0 ) then
            Result := qQuarter3
         else
            if ( p.X > 0 ) and ( p.Y < 0 ) then
               Result := qQuarter4;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  p: TPoint = ( X: 10; Y: 10 );
begin
   case GetQuarter( p ) of
      qZero: ShowMessage( 'Точка лежит в начале координат' );
      qAxisX: ShowMessage( 'Точка лежит на оси X' );
      qAxisY: ShowMessage( 'Точка лежит на оси Y' );
      qQuarter1: ShowMessage( 'Точка лежит в I четверти' );
      qQuarter2: ShowMessage( 'Точка лежит во II четверти' );
      qQuarter3: ShowMessage( 'Точка лежит в III четверти' );
      qQuarter4: ShowMessage( 'Точка лежит в IV четверти' );
   end;
end;

// Способ второй
// Работает с относительно небольшими числами
// (если раскомментировать '{9}', ответ будет не верным
procedure TForm1.Button1Click(Sender: TObject);
var
  p: TPoint;
  Quarter: Byte;
begin
   p.X := 999999999{9};
   p.Y := 999999999{9};
   Quarter := ( p.Y shr 30 ) xor ( p.X shr 31 ) + 1;
   ShowMessage( IntToStr( Quarter ) );
end;

// Способ третий
procedure TForm1.Button1Click(Sender: TObject);
var
  p: TPoint;
  Quarter: Byte;
begin
   p.X := 99999999999999;
   p.Y := 99999999999999;
   Quarter := ( ( ( ( P.Y shr 30 ) and 2 ) or ( p.Y shr 31 ) ) xor ( p.X shr 31 ) ) + 1;
   ShowMessage( IntToStr( Quarter ) );
end;

Как определить угол между точкой и центром координат?


// Способ первый
function GetAngle(p: TPoint): Extended;
var
  Angle: Extended;
begin
  if (p.X = 0) and (p.Y = 0) then
    Exit(0);
  if p.X = 0 then
    if p.Y > 0 then
      Exit(90)
    else
      Exit(270);
  if p.Y = 0 then
    if p.X > 0 then
      Exit(0)
    else
      Exit(180);

  Angle := ArcTan(Abs(p.Y) / Abs(p.X)) * 180 / pi;
  if (p.X > 0) and (p.Y > 0) then
    Result := Angle
  else
    if (p.X < 0) and (p.Y > 0) then
      Result := 180 - Angle
    else
      if (p.X < 0) and (p.Y < 0) then
        Result := 180 + Angle
      else
        if (p.X > 0) and (p.Y < 0) then
          Result := 360 - Angle;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  p: TPoint;
begin
  p.X := 0;
  p.Y := 1;
  ShowMessage(FloatToStr(GetAngle(p)));
end;

// Способ второй
uses
  Math;

procedure TForm1.Button1Click(Sender: TObject);
var
  p: TPoint;
  Degrees: Word;
begin
  p.X := 0;
  p.Y := 1;
  Degrees := Trunc(RadToDeg(ArcTan2(p.Y, p.X)) + 360) mod 360;
  ShowMessage(FloatToStr(Degrees));
end;

Как сгенерировать случайное число в заданном диапазоне?


// Способ первый
uses
  {...,} Math;

procedure TForm1.Button1Click(Sender: TObject);
var
  k: Integer;
begin
   if TryStrToInt( Edit1.Text, k ) then
   begin
      Randomize;
      ShowMessage( 'Сгенерированное число [ ' + IntToStr( RandomRange( -k, k+1 ) ) + ' ]' );
   end
   else
       ShowMessage( 'Введено не целое число! Повторите ввод' );
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
var
  k: Integer;
begin
   if TryStrToInt( Edit1.Text, k ) then
   begin
      Randomize;
      ShowMessage( 'Сгенерированное число [ ' + IntToStr( -k + Random( 2*k+1 ) ) + ' ]' );
   end
   else
       ShowMessage( 'Введено не целое число! Повторите ввод' );
end;

// Способ третий
// Для вещественных чисел
procedure TForm1.Button1Click(Sender: TObject);
var
  Min, Max: Double;
begin
   Min := -10;
   Max := 20;
   Randomize;
   ShowMessage( 'Сгенерированное число [ ' + FloatToStr( Min + Random * ( Max - Min ) ) + ' ]' );
end;

Как перечислить все разбиения N на целые положительные (натуральные) слагаемые?


// Пример: N=4, разбиения: 1+1+1+1, 2+1+1, 2+2, 3+1, 4.
// Чтобы разбиения не повторялись, слагаемые перечисляются в невозрастающем порядке.

type
  Razb = array[Word] of Byte;

procedure Next1( var X: Razb; var L: Byte );
var
  i, j: Byte;
  s: Word;
begin
   i := L - 1;
   s := X[L];
   {поиск i}
   while ( i > 1 ) and ( X[i-1] <= X[i] ) do
   begin
      s := s + X[i];
      Dec( i );
   end;
   Inc( X[i] );
   L := i + s - 1;
   for j := i+1 to L do
      X[j] := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i, L: Byte;
  X: Razb;
  s: string;
begin
   L := StrToInt( Edit1.Text ); // Стичываем число
   for i := 1 to L do
       X[i] := 1;
   for i := 1 to L do
   begin
      s := s + IntToStr( X[i] );
      if i < L then
         s := s + ' + '
      else
         s := s + #13;
   end;
   repeat
      Next1( X, L );
      for i := 1 to L do
      begin
         s := s + IntToStr( X[i] );
         if i < L then
            s := s + ' + '
         else
            if L <> 1 then
               s := s + #13;
      end;
   until L = 1;
   ShowMessage( s );
end;

Как проверить является ли число степенью 2?


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
const
  N = 4;
begin
   if (N > 0) and (N and (N-1) = 0) then
      ShowMessage('Число является степенью 2');
end;

// Способ второй
const
  BitCountTable: array[0..255] of Byte =
    (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4,
     1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
     1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
     2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
     1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
     2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
     2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
     3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
     1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
     2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
     2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
     3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
     2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
     3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
     3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
     4, 5, 5, 6, 5, 6, 6, 7, 5, 6, 6, 7, 6, 7, 7, 8);

function BitCount(const Value: LongWord): LongWord;
var
  v: array[0..3] of Byte absolute Value;
begin
   Result := BitCountTable[v[0]] + BitCountTable[v[1]] +
             BitCountTable[v[2]] + BitCountTable[v[3]];
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  Number = 8;
begin
   if BitCount(Number) = 1 then
      ShowMessage('Число является степенью 2');
end;

Как вычислить ряд Фибоначчи?


// Способ первый
procedure FibonacciSeries( out Series: TStrings; Count: Word );
var
  Fib1, Fib2, FibSum: Int64;
  i: Integer;
begin
   Fib1 := 0;
   Fib2 := 1;
   Series.Add( IntToStr( Fib1 ) );
   Series.Add( IntToStr( Fib2 ) );

   i := 0;
   while i < Count-2 do
   begin
      FibSum := Fib1 + Fib2;
      Series.Add( IntToStr( FibSum ) );
      Fib1 := Fib2;
      Fib2 := FibSum;
      Inc( i );
   end;
end;

procedure TForm2.Button1Click(Sender: TObject);
var
  Series: TStrings;
begin
   Series := TStringList.Create;
   FibonacciSeries( Series, 20 );
   ShowMessage( Series.CommaText );
   Series.Free;
end;

// Способ второй
function Fibo(n: Integer): Integer;
var
  x, y: Integer;
  i: Integer;
begin
   x := 1;
   y := 1;

   for i := 2 to n-1 do
   begin
      y := x + y;
      x := y - x;
   end;

   Result := y;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   // Вычисляем 6-ой элемент ряда 
   ShowMessage(IntToStr(Fibo(6)));
end;

// Способ третий
uses
  Math;

const
  SQRT5: Double = 2.23606797749979; // Sqrt(5)
  PHI: Double  = 1.61803398874989;  // (SQRT5 + 1) / 2

function Fibo(n: Integer): Integer;
begin
   Result := Trunc(Power(PHI, n) / SQRT5 + 0.5);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   // Вычисляем 4-ый элемент ряда 
   ShowMessage(IntToStr(Fibo(4)));
end;

Как найти наибольший общий делитель (НОД)?


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);

  function NOD( a, b: Integer ): Integer;
  begin
     if a <> 0 then
        NOD := NOD( b mod a, a )
     else
        NOD := b;
  end;

var
  a, b: Integer;
begin
   a := 30;
   b := 48;
   ShowMessage( IntToStr( NOD( a, b ) ) );
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);

  function NOD( a, b: Integer ): Integer;
  begin
     while a <> b do
        if a > b then
           a := a - b
        else
           b := b - a;
     Result := a;
  end;

var
  a, b: Integer;
begin
   a := 30;
   b := 48;
   ShowMessage( IntToStr( NOD( a, b ) ) );
end;

// Способ третий
uses
  {...,} Math;

procedure TForm1.Button1Click(Sender: TObject);

  function NOD( a, b: Integer ): Integer;
  var
    Lfactor: Integer;
  begin
     // Return -1 if either value is zero or negative
     if ( a < 1 ) or ( b < 1 ) then
     begin
        Result := -1;
        Exit;
     end;
     // if a = b then this is the GCF
     if a = b then
     begin
        Result := a;
        Exit;
     end;
     Result := 1;
     for Lfactor := Trunc( Max( a, b ) / 2 ) downto 2 do
     begin
        if ( Frac( a / Lfactor ) = 0 ) and ( Frac( b / Lfactor ) = 0 ) then
        begin
           Result := Lfactor;
           Exit; // GCF has been found. No need to continue
        end;
     end;
  end;

var
  a, b: Integer;
begin
   a := 30;
   b := 48;
   ShowMessage( IntToStr( NOD( a, b ) ) );
end;

// Способ четвертый
procedure TForm1.Button1Click(Sender: TObject);

  function NOD( n1, n2: Integer ): Integer;
  var
    temp: Integer;
  begin
     if n1 < n2 then
     begin
        temp := n1;
        n1 := n2;
        n2 := temp;
     end;

     if n2 = 0 then
        Result := n1
     else
     begin
        while n2 > 0 do
        begin
           temp := n1 mod n2;
           n1 := n2;
           n2 := temp;
        end;

        Result := n1;
     end;
  end;

var
  a, b: Integer;
begin
   a := 30;
   b := 48;
   ShowMessage( IntToStr( NOD( a, b ) ) );
end;

Как найти наименьшее общее кратное (НОК)?


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);

  // Наибольший общий делитель
  function NOD( x, y: Integer): Integer;
  begin
     if x <> 0 then
        NOD := NOD( y mod x, x )
     else
        NOD := y;
  end;

  function NOK( x, y: Integer ): Integer;
  begin
     NOK := ( x div NOD( x, y ) ) * y;
  end;

var
  a, b: Integer;
begin
   a := 30;
   b := 48;
   ShowMessage( IntToStr( NOK( a, b ) ) );
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);

  // Наибольший общий делитель
  function NOD( x, y: Integer): Integer;
  begin
     if x <> 0 then
        NOD := NOD( y mod x, x )
     else
        NOD := y;
  end;

  function NOK( n1, n2: Integer): Integer;
  var
    Tmp: Integer;
  begin
     Tmp:= n1 * n2;
     if Tmp = 0 then
        Result := 0
     else
        Result := Tmp div NOD( n1, n2 );
  end;

var
  a, b: Integer;
begin
   a := 30;
   b := 48;
   ShowMessage( IntToStr( NOK( a, b ) ) );
end;