Замечательные числа
   
Числа и СуперЧисла Смита (ускоренная версия) Постоянная Капрекара
Определить, является ли число палиндромом (без преобразования в строку) Совершенные числа (+ алгоритм ускоренного поиска)
Числа Армстронга  
   


Числа и СуперЧисла Смита

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

Приведенная ниже программа ищет СуперЧисло Смита с номером 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.
В результате получаем программу, работающую быстрее предыдущей в десятки раз.


Определить, является ли число палиндромом (без его преобразования в строку)

Собираем из заданного числа "обратное" ему (с цифрами, записанными в обратном порядке), и проверяем заданное и "обратное" на равенство друг другу...
function is_palindrom(x: longint): boolean;
var prev, T: longint;
begin
  prev := x;

  T := 0;
  while x <> 0 do begin
    T := T * 10 + (x mod 10);
    x := x div 10;
  end;

  is_palindrom := (prev = T)
end;


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

Число Армстронга - такое число из k цифр, для которого сумма k-х степеней его цифр равна самому этому числу, например 153 = 13 + 53 + 33

Ниже приведены две функции для работы с числами Армстронга:
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.


Постоянная Капрекара

Выберите любое четырехзначное число, в котором не все цифры одинаковые. Расположите цифры сначала в порядке убывания, затем, переставив их в обратном порядке, образуйте новое число. Вычтите новое число из старого. Повторяя этот процесс с получающимися разностями (не более чем за семь шагов) получим число 6174, которое будет затем воспроизводить самого себя.

Примечание: производя вычитания нули следует сохранять.

Примеры:

4321 - 1234 = 3087 -> 8730 - 0378 = 8352 -> 8532 - 2358 = 6174.
1100 - 11 = 1089 -> 9810 - 189 = 9621 -> 9621 - 1269 = 8352 -> 8532 - 2358 = 6174.

Ниже представлена программа для нахождения числа итераций, необходимых для достижения постоянной Капрекара для любого 4-х значного числа.
function Justify(s: String;
         Const n: Byte): String;
begin
  while Length(s) < n do
    s := '0' + s;
  Justify := s
end;

function Trim(s: String): String;
begin
  while s[1] = '0' do
    Delete(s, 1, 1);
  Trim := s
end;

function sort_digits(n: Integer;
         size: Byte): Integer;
var
  s: String;

  procedure SwapIndex(i, j: Byte);
  var Ch: Char;
  begin
    Ch := s[i]; s[i] := s[j]; s[j] := Ch
  end;

var
  i, j: Byte; Err: Word;
begin
  Str(n, s);
  s := Justify(s, size);

  for i := 1 to size do
    for j := size downto i+1 do
      if s[Pred(j)] < s[j] then
        SwapIndex(Pred(j), j);

  s := Trim(s);

  Val(s, n, Err);
  sort_digits := n
end;

function revert(n: Integer;
         size: Byte): Integer;
var
  s, inv: String;
  i, Err: Word;
begin
  s := Justify(s, size);

  inv := '';
  for i := Length(s) downto 1 do
    inv := inv + s[i];

  s := Trim(s);

  Val(inv, n, Err);
  revert := n
end;

const
  sz = 4;
var
  res, sort, x: Integer;
  count: Word;
begin
  Write('Введите 4-х значное число: '); ReadLn(res);
  count := 0;
  repeat
    Inc(count); x := res;
    sort := sort_digits(x, sz);
    res := Abs(sort - revert(sort, sz))
  until res = x;
  WriteLn('Const = ', res:(sz+1), ' (', count, ' итераций)')
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.