Форум на Исходниках.RU https://forum.sources.ru Форум на Исходниках.RU Форум на Исходниках.RU https://forum.sources.ru/index.php?showtopic=330611&view=findpost&p=2776843 Sun, 12 Dec 2010 20:04:55 +0000 Замечательные числа https://forum.sources.ru/index.php?showtopic=330611&view=findpost&p=2776843 Числа и СуперЧисла Смита

Составное число называется Числом Смита, если сумма его цифр равна сумме цифр всех чисел, образующихся разложением исходного числа на простые множители. Число Смита называется СуперЧислом Смита, если сумма его цифр является Числом Смита.

Приведенные ниже программы ищут СуперЧисло Смита с номером X...

Для начала - программа, показывающая, как делать не надо

    { Эта функция считает сумму цифр числа N }
    function GetOneDigits (n : LongInt) : integer;
    var s : Integer;
    begin
       s := 0;
       while n <> 0 do begin
          Inc(s, n mod 10);
          n := n div 10
       end;
       GetOneDigits := s
    end;
     
    {
       Эта функция считает сумму цифр разложения исходного числа N
       на простые множители и возвращает в Amount число простых множителей
    }
    function GetSimpleDigits (n : LongInt; Var amount : Integer) : Integer;
    var
       s, factor : Integer;
    begin
       s := 0; factor := 2;
       amount := 0;
       repeat
          if n mod factor = 0 then
          begin
             s := s + GetOneDigits (factor); Inc (amount);
             n := n div factor
          end
          else Inc (factor)
       until n = 1;
       GetSimpleDigits := s
    end;
     
    { Функция возвращает N-ное число Смита }
    function GetSmith (n : Integer) : LongInt;
    var
       i, amount : Integer; od, sd : Integer;
       count : LongInt;
       Found : Boolean;
    begin
       i := 0; count := 2;
       while i <> n do
       begin
          repeat
             Inc(count);
             Found :=
                (GetOneDigits (count) = GetSimpleDigits (count, amount)) and
                (amount > 1)
          until Found;
          inc(i)
       end;
       GetSmith := Count
    end;
     
    { Функция проверяет, является ли N числом Смита }
    function IsSmith (n : LongInt) : Boolean;
    var
       i : Integer;
       next : LongInt;
    begin
       i := 0;
       repeat
          Inc(i); next := GetSmith (i)
       until next >= n;
       IsSmith := (next = n)
    end;
     
    { Функция возвращает N-ное суперчисло Смита }
    function Super (n : Integer) : LongInt;
    var
       i, count : Integer;
       smith : LongInt;
       Found : Boolean;
    begin
       i := 0; count := 0;
       while i <> n do
       begin
          Inc(i);
          repeat
             Inc (count);
             smith := GetSmith (count);
             Found := IsSmith (GetOneDigits (smith));
          until Found;
       end;
       Super := smith
    end;
     
    var
       X : Integer;
    begin
      Write ('X = '); ReadLn (X);
      WriteLn ('Smith super number (X) = ', Super (X));
    end.
Почему не надо так делать? Потому, что при вычислении последующих чисел Смита заново вычисляются все предыдущие. Что очень сильно замедляет программу.

Чтобы ускорить ее, немного изменим структуру программы: при нахождении следующего числа Смита не будем пересчитывать все предыдущие, а воспользуемся сразу числом, уже найденным на предыдущей итерации...
    {
       Как и прежде, функция, суммирующая все цифры числа,
       переданного ей в качестве параметра
    }
    function sum_of_digits (n : longint) : integer;
    var s : integer;
    begin
       s := 0;
     
       while n <> 0 do
       begin
          inc(s, n mod 10);
          n := n div 10;
       end;
       sum_of_digits := s
    end;
     
    {
       Функция, раскладывающая переданное ей число на простые множители,
       и находящая сумму цифр всех этих множителей
    }
    function Factorization (X : longint) : longint;
    var i, s : word;
     
       procedure DivX;
       begin
          while (x > 1) and (x mod i = 0) do
          begin
             inc (s, sum_of_digits (i));
             x := x div i;
          end;
       end;
     
    begin
       s := 0;
       i := 2;
       DivX;
       i := 3;
       while (i < x div 2) do begin
          DivX;
          inc(i, 2);
       end;
       if x > 1 then inc(s, sum_of_digits (x));
        
       Factorization := s;
    end;
     
    {
       Функция, проверяющая число на простоту
    }
    function IsPrime (X : word): boolean;
    var i : integer;
    begin
       isPrime := false;
       if not odd(x) and (x <> 2) then exit;
       i := 3;
        
       while i <= sqrt(x) do
       begin
          if x mod i = 0 then exit;
          inc (i, 2);
       end;
       IsPrime := true;
    end;
     
    {
       Функция IsSmith осуществляет проверку, является ли переданное ей
       число "числом Смита"
    }
    function IsSmith(n: longint): boolean;
    begin
       IsSmith :=
          not IsPrime (n) and
          (sum_of_digits (n) = Factorization (n));
    end;
     
    {
       С помощью функции GetNextSmith, можно получить i-ое число Смита,
       зная предыдущее, (i - 1)-ое. Очень сильно ускорит программу, поскольку
       избавляет от необходимости постоянно пересчитывать одни и те же числа ...
    }
    function GetNextSmith (prev : longint) : longint;
    var i : longint;
    begin
       i := prev;
       repeat
          inc (i);
       until IsSmith (i);
       GetNextSmith := i;
    end;
     
    {
       Нахождение Суперчисла Смита под номером N
    }
    function Super(n: integer): longint;
    var
       i, curr : longint;
       smith : longint;
    begin
       curr := 0; i := 0;
       smith := 2;
       repeat
     
          repeat
             inc (i);
             smith := GetNextSmith (smith);
          until IsSmith (sum_of_digits(smith));
     
          inc(curr);
       until curr = n;
       Super := smith;
    end;
     
    var
       X : Integer;
    begin
       write ('X = '); readln  (X);
       writeln('Smith super number (X) = ', Super (X));
    end.


В результате получаем программу, работающую быстрее предыдущей версии во много раз. После замеров времени выполнения получилось следующее:
СуперСмит5. Старая версия: 62 мс., новая: 1 мс.
СуперСмит100. Старая версия: 7653 мс., новая: 63 мс.
СуперСмит200. Старая версия: 43891 мс., новая: 220 мс.



Числа Армстронга

Число Армстронга - такое число из k цифр, для которого сумма k-х степеней его цифр равна самому этому числу, например 153 = 13 + 53 + 33
Ниже приведены две функции для работы с числами Армстронга:
  • Function IsArmstrong(n: LongInt): Boolean;
    Возвращает True, если переданное ей в качестве аргумента число является числом Армстронга.
  • Procedure GetArmstrongs(n: integer);
    Распечатывает все n-значные числа Армстронга

    function Power (n, k : Integer) : LongInt;
    var
       p : LongInt; i : Word;
    begin
       p := 1;
       for i := 1 to k do
          p := p * n;
       Power := p
    end;
     
    function IsArmstrong (n : LongInt) : Boolean;
    var
       Weight : Array [0 .. 9] Of LongInt;
       i, j : Integer; s : LongInt;
    begin
       i := -1; s := n;
       while s > 0 do
       begin
          Inc (i);
          Weight [i] := s mod 10;
          s := s div 10
       end;
     
       for j := 0 to i do
          s := s + Power (Weight [j], Succ (i));
       IsArmstrong := (s = n)
    end;
     
    procedure GetArmstrongs (n : integer);
    var
       Weight : Array [0 .. 9] Of LongInt;
       k, x, min, max, s, p : LongInt;
    begin
       for k := 0 to 9 do
          Weight[k] := Power (k, n);
     
       min := Power (10, Pred(n));
       max := Pred (10 * min);
     
       for x := min to max do
       begin
          p := x; s := 0;
          for k := 1 to n do
          begin
             Inc (s, Weight [p mod 10]);
             p := p div 10
          end;
     
          if s = x then
             WriteLn (x, ' - Armstrong')
       end
    end;
     
    var
       n : 1 .. 9;
     
    begin
       repeat
          Write ('n [1 .. 9] = '); ReadLn (n)
       until n In [1 .. 9];
     
      GetArmstrongs (n);
     
      WriteLn ('1741725: ', isArmstrong (1741725))
    end.



Совершенные числа

Сушествует особый класс чисел, равных сумме всех своих делителей, отличных от самого числа. То есть,

6 = 1 + 2 + 3
28 = 1 + 2 + 4 + 7 + 14

и так далее...

Конечно, нахождение совершенных чисел можно реализовать несколькими способами. По традиции: сначала -
программа, показывающая, как не надо искать Совершенные числа
    const
      final = 500000;
     
    var
       i, s, divider : longint;
    begin
       for i := 2 to final do begin
          s := 1;
          for divider := 2 to trunc (sqrt (i)) do
          begin
     
             if i mod divider = 0 then s := s + divider + (i div divider);
     
          end;
          if i = s then writeln(s);
       end;
    end.
Эта программа выдаст все совершенные числа на промежутке [2 .. final], но она будет довольно долго работать (тем дольше, чем шире просматриваемый интервал).

Между тем, количество кандидатов на роль совершенных чисел можно значительно сократить, пользуясь тем фактом, что во всех Совершенных числах в двоичной записи сначала идут n единиц, а потом (n - 1) нулей. Это позволяет организовать поиск Совершенных чисел вот таким, например, образом:
    var
       i, n, s : longint;
       divider : integer;
        
       bin, bs : integer; { Счетчики для работы со строками }
       bin_s : string;    { Строковое представление Совершенного числа в двоичном виде }
       check : LongInt;   { Число - кандидат на роль Совершенного }
    begin
     
       { Проверим все числа, двоичная запись которых содержит 3 .. 29 символов }
       for bin := 1 to 14 do
       begin
          bin_s := '';
        
          { Создаем бинарное представление числа-кандидата на роль Совершенного }
          for bs := 1 to bin do bin_s := '1' + bin_s + '0';
          bin_s := '1' + bin_s;
            
          { Переводим его из 2 представления в десятичное }
          check := 0;
          for i := 1 to length (bin_s) do check:= check * 2 + (ord (bin_s[i]) - ord ('0'));
            
          {
             ... а теперь - проверяем ТОЛЬКО его, пропуская сотни тысяч чисел, проверка которых
             заведомо не приведет к успеху (здесь еще тоже можно пооптимизировать, но результат
             и так выдается практически мгновенно)
          }
            
          s := 1;
          for divider := 2 to trunc (sqrt (check)) do
          begin
        
             if check mod divider = 0 then s := s + divider + (check div divider);
          
          end;
          if check = s then WriteLn (check);
       end;
    end.
]]> volvo877 Все языки: Статьи, заготовки в FAQ