Программирование на 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 _Next(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
    _Next(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;