IPB
ЛогинПароль:

> Внимание! Действует предмодерация

Подраздел FAQ (ЧАВО, ЧАстые ВОпросы) предназначен для размещения готовых рабочих программ, реализаций алгоритмов. Это нечто вроде справочника, он наполнялся в течение 2000х годов. Ваши вопросы, особенно просьбы решить задачу, не пройдут предмодерацию. Те, кто наполнял раздел, уже не заходят на форум, а с теми, кто на форуме сейчас, лучше начинать общение в других разделах. В частности, решение задач — здесь.

 
 Ответить  Открыть новую тему 
> Замечательные числа
сообщение
Сообщение #1


Гость






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


Приведенная ниже программа ищет СуперЧисло Смита с номером 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.


**********

Update: поскольку вышеприведенная функция поиска Суперчисел Смита работает очень медленно - выкладываю обновленную версию:

Спойлер (Показать/Скрыть)

Немного информации о скорости работы:
СуперСмит5. Старая версия: 62 мс., новая: 1 мс.
СуперСмит100. Старая версия: 7653 мс., новая: 63 мс.
СуперСмит200. Старая версия: 43891 мс., новая: 220 мс.

Сообщение отредактировано: volvo -
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


Гость






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

Собираем из заданного числа "обратное" ему (с цифрами, записанными в обратном порядке), и проверяем заданное и "обратное" на равенство друг другу...
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;
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


Ищущий истину
******

Группа: Пользователи
Сообщений: 4 825
Пол: Мужской
Реальное имя: Олег

Репутация: -  45  +


Поиск совершенных чисел.
Цитата
Определенный интерес для любителей представляет программа поиска совершенных чисел. Ее схема проста: в цикле для каждого числа проверять сумму его делителей и сравнивать ее с самим числом, - если они равны, то это число совершенное.


Код
Var
  I,N,Summa: LongInt;
  Delitel: Integer;
Begin
  For I := 3 To 34000000 Do Begin
    Summa := 1;
    For Delitel := 2 To Trunc(Sqrt(I)) Do Begin
      N := (I Div Delitel);
      If N * Delitel = I Then Summa := Summa + Delitel + (I Div Delitel);
    End;

    If Int(Sqrt(I)) = Sqrt(I) Then Summa := Summa - Trunc(Sqrt(I));

    If I = Summa Then WriteLn(I, ' - ', Summa);
  End;
End.


Добавлено (volvo):
  • Количество кандидатов на роль совершенных чисел можно значительно сократить, пользуясь тем фактом, что во всех Совершенных числах в двоичной записи сначала идут n единиц, а потом (n - 1) нулей. Это позволяет организовать поиск подобных чисел вот таким, например, образом:
    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 isPrime(X: word): boolean;
var
i: integer;
Begin
isPrime:=false;
for i:=2 to trunc(sqrt(x)) do
if x mod i = 0 then Exit;
isPrime:=true
End;


Реализация вероятностного алгоритма Миллера-Рабина с 20 раундами.

Для примера выдает простые на отрезке [1000000000,1000100000]

Код

function mulmod(x,y,m:longint):longint; assembler;
asm
mov eax,x
mul y
div m
mov eax,edx
end;

function powmod(x,a,m:longint):longint;
var
r:longint;
begin
r:=1;
while a>0 do
begin
if odd(a) then r:=mulmod(r,x,m);
a:=a shr 1;
x:=mulmod(x,x,m);
end;
powmod:=r;
end;

function isprime(p:longint):boolean;
var q,i,a:longint;
const rounds=20;
begin
if odd(p) then
begin
isprime:=true;
q:=p-1;
while not odd(q) do q:=q shr 1;
for i:=1 to rounds do
begin
a:=Random(p-2)+2;
if powmod(a,p-1,p)<>1 then
begin
isprime:=false;
break;
end;
a:=powmod(a,q,p);
if a<>1 then
begin
while (a<>1) and (a<>p-1) do a:=mulmod(a,a,p);
if a=1 then
begin
isprime:=false;
break;
end;
end;
end;
end else isprime:=(p=2);
end;

var t:longint;
begin
Randomize;
for t:=1000000000 to 1000100000 do if isprime(t) then writeln(t);
end.


--------------------
Помогая друг другу, мы справимся с любыми трудностями!
"Не опускать крылья!" (С)
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


Гость






Реализация вероятностного алгоритма Соловея-Штрассена

Алгоритм Соловея-Штрассена:
  1. Выбирается случайное a из {1, ..., n - 1}. Проверяем условие НОД(a,n)=1
  2. Если (1) не выполнено, то n – составное
  3. Проверяем сравнение a^((n-1)/2) = a/n (mod n)
  4. Если (3) не выполнено, то n – составное
  5. В противном случае результат не известен.

Программная реализация:
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.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #5


Гость






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


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


Гость






Постоянная Капрекара
Цитата
Выберите любое четырехзначное число, в котором не все цифры одинаковые. Расположите цифры сначала в порядке убывания, затем, переставив их в обратном порядке, образуйте новое число. Вычтите новое число из старого. Повторяя этот процесс с получающимися разностями (не более чем за семь шагов) получим число 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))
write(res, '':2);
until res = x;

WriteLn;
WriteLn('Const = ', res:(sz+1), ' (', count, ' итераций)');
end.
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 




- Текстовая версия 28.07.2017 1:41
Хостинг предоставлен компанией "Веб Сервис Центр" при поддержке компании "ДокЛаб"