Числа и СуперЧисла Смита
{
Функция для подсчета суммы цифр числа 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 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;
Поиск совершенных чисел.
var
I, N, Summa: LongInt;
Delitel: 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'));
{ Распечатываем ... }
writeln(check);
{
... а теперь - проверяем ТОЛЬКО его, пропуская сотни тысяч
чисел, проверка которых заведомо не приведет к успеху.
(здесь еще тоже можно пооптимизировать, но результат и так
выдается практически мгновенно)
}
summa := 1;
for Delitel := 2 to Trunc(Sqrt(check)) do begin
N := (check div Delitel);
if N * Delitel = check then inc(Summa, Delitel + (check div Delitel));
end;
if Int(Sqrt(check)) = Sqrt(check) then dec(Summa, Trunc(Sqrt(check)));
if check = Summa then WriteLn(check, ' - ', Summa);
end;
end.
Реализация вероятностного алгоритма Соловея-Штрассена
Алгоритм Соловея-Штрассена:
function gcd(a, b : integer): integer;
var t: integer;
begin
if a < 0 then a := - a;
if b < 0 then b := - b;
if a < b then begin
t := a; a := b; b := t;
end;
while b<>0 do begin
t := a mod b; a := b; b := t;
end;
gcd := a
end;
function twoFactor(var a: integer): integer;
var i: integer;
begin
i := 0 ;
while ((a mod 2) = 0) do begin
i := i + 1;
a := a div 2;
end;
twoFactor := i;
end;
function jacobi(m, n: integer): integer;
var i, j, d: integer;
begin
i := 1;
while m > 1 do begin
j := twoFactor(m);
if (j mod 2) = 1 then begin
d := n mod 8;
if (d = 3) or (d = 5) then
i := - i;
end ;
if ((m mod 4) = 3) and ((n mod 4 ) = 3) then
i := - i;
d := n mod m;
n := m;
m := d;
end;
jacobi := i;
end;
function jacobiSymbol(a, b: integer): integer;
var i, j: integer;
begin
i := 0 ;
if (a <= 0) or (b <= 1) then i := 2
else begin
if gcd(a, b) = 1 then begin
j := twoFactor( b ) ;
a := a mod b ;
if (a=0) then i := 1
else i := jacobi(a, b);
end
end;
jacobiSymbol := i;
end;
function multiply(a, b, c :integer): integer;
var i: integer;
begin
if a = 0 then i := 0
else begin
if (a mod 2) = 1 then begin
i := multiply((a - 1) div 2, b, c);
if (c - i ) > i then i := i + i
else i := (i - c) + i;
if (c - i ) > b then i := i + b
else i := (i - c) + b ;
end
else begin
i := multiply(a div 2, b, c);
if (c - i ) > i then i := i + i
else i := (i - c) + i;
end
end;
multiply := i;
end;
function fastExp(b, j, n: integer): integer;
var i: longint;
begin
if j = 0 then i := 1
else
if (j mod 2) = 1 then begin
i := fastExp(b, (j-1) div 2, n);
i := multiply(multiply(b, i, n), i, n);
end
else begin
i := fastExp(b, j div 2, n);
i := multiply(i, i, n);
end;
fastExp := i
end;
function legendre(b, n: integer): integer;
var i: integer;
begin
i := 0;
if gcd(b, n) = 1 then begin
if (n mod 2) = 0 then i := 1
else i := fastExp((b mod n), (n-1) div 2, n);
end;
legendre := i;
end;
function primality( p, i : integer ) : integer ;
var
j: integer;
dl, dj: integer;
b: boolean;
begin
if p < 2 then j := 1
else
if p = 2 then j := 0
else
if (p mod 2) = 0 then j := 2
else begin
if (i+1) >= p then i := p - 2;
j := 1;
b := false;
repeat
j := j + 1;
if j > (i+1) then b := true
else begin
if gcd(j,p) > 1 then b := true
else begin
dl := legendre(j, p);
if dl <> 1 then dl := dl - p;
dj := jacobi(j, p);
if dj <> dl then b := true;
end;
end;
until b;
if j > (i+1) then j := 0;
end;
primality := j;
end;
var
i, j, k: integer;
begin
writeln('Тест на простоту числа P, I итераций');
write('P = '); readln(j);
write('I = '); readln(i);
k := primality(j, i);
if k = 0 then writeln(j:0,' возможно является простым.')
else writeln(j:0,' не является простым, не пройден тест ', k:0);
end.
Числа Армстронга
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))
write(res, '':2);
until res = x;
WriteLn;
WriteLn('Const = ', res:(sz+1), ' (', count, ' итераций)');
end.