На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Поиск Участники Календарь Избранное RSS
msm.ru
! Друзья, соблюдайте, пожалуйста, правила форума и данного раздела:
• Данный раздел не предназначен для вопросов и обсуждений, он содержит FAQ-заготовки для разных языков программирования. Любой желающий может разместить здесь свою статью. Вопросы же задавайте в тематических разделах!
• Если ваша статья может быть перенесена в FAQ соответствующего раздела, при условии, что она будет оформлена в соответствии с Требованиями к оформлению статей.
• Чтобы остальным было проще понять, указывайте в описании темы (подзаголовке) название языка в [квадратных скобках]!
Модераторы: Модераторы
  
> Замечательные числа , [Pascal] Числа Смита, Армстронга. Совершенные числа.
Guru volvo877
Сообщ. #1 ,

    Guru
    *******
    Профиль · PM
    Поощрения: 7 Dgm
    Рейтинг (т): 878
    Числа и СуперЧисла Смита

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

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

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

    ExpandedWrap disabled
      { Эта функция считает сумму цифр числа 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.
    Почему не надо так делать? Потому, что при вычислении последующих чисел Смита заново вычисляются все предыдущие. Что очень сильно замедляет программу.

    Чтобы ускорить ее, немного изменим структуру программы: при нахождении следующего числа Смита не будем пересчитывать все предыдущие, а воспользуемся сразу числом, уже найденным на предыдущей итерации...
    ExpandedWrap disabled
      {
         Как и прежде, функция, суммирующая все цифры числа,
         переданного ей в качестве параметра
      }
      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-значные числа Армстронга

    ExpandedWrap disabled
      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

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

    Конечно, нахождение совершенных чисел можно реализовать несколькими способами. По традиции: сначала -
    программа, показывающая, как не надо искать Совершенные числа
    ExpandedWrap disabled
      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) нулей. Это позволяет организовать поиск Совершенных чисел вот таким, например, образом:
    ExpandedWrap disabled
      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.
    Сообщение отредактировано: Jin X -
    0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
    0 пользователей:


    Рейтинг@Mail.ru
    [ Script execution time: 0,0288 ]   [ 15 queries used ]   [ Generated: 20.04.24, 06:21 GMT ]  
    Powered by Invision Power Board(U) v1.2 © 2003  IPS, Inc.