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

{Эта функция считает сумму цифр числа 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;

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

• 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.

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

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.

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.