Лабы_по_проге_Берлин / Лабораторная работа 10 / длинная_арифметика_на_базе_массива

program Lab1;

{$APPTYPE CONSOLE}

uses
SysUtils, Math;

{Максимальное количество цифр в длиннои числе}
Const NMax = 2000;

{Типы для цифры и длиного числа}
Type Digit = 0..9;
DlChislo = Array[1..Nmax] Of Digit;

{Глобальные переменные:

Trans - True, если преобразование строки в длинное число прошло удачно, False в противном случае.

ValueN - число, вплоть до которого слеуде искать палиндромы
ValueI - счётчик, который изменяет свои значения начиная с первого указанного значения вплоть до ValueN
PowValueI - текущее значение ValueI, возведённое в нужную степень.
}
var Trans:Boolean;
ValueN,ValueI,PowValueI : DlChislo;

{Процедура обнуления длинного числа}
Procedure Zero(Var A : DlChislo);
Var I : Integer;
Begin
For I := 1 To NMax Do
A[I] := 0;
End;
{Процедура преобразования длинного числа, записанного
в виде строки, в массив цифр; переменная OK принимает значение True,
если в записи числа нет посторонних символов, отличных от десятичных
цифр, иначе — false}
Procedure Translate(S : String; Var A : DlChislo; Var OK : Boolean);
Var I,SLen : Word;
Begin
Zero(A);
I := Length(S);
SLen := I;
OK := True;
While (I >= 1) And OK Do
Begin
If S[I] In ['0'..'9']
Then
A[SLen - I + 1]:= Ord(S[I]) - 48
Else
OK := False;
Dec(I);
End
End;

{Функция определения количества цифр в записи длинного числа}
Function Dlina(C : DlChislo) : Integer;
Var I : Integer;
Begin
I := NMax;
While (I > 1) And (C[I] = 0) Do
Dec(I);
Dlina := I;
End;

{Процедура умножения длинных чисел.
A, B — множители, C — произведение}
Procedure Multiplication(A, B : DlChislo; Var C : DlChislo);
Var I, J, ALen, BLen : Integer; P : Digit; VspRez : 0..99;
Begin
Zero(C); {Обнуление результата}
ALen:=Dlina(A);
BLen:=Dlina(B);
For I := 1 To ALen Do {Цикл по количеству цифр в первом числе}
Begin
P := 0; {Первоначально перенос равен нулю}
For J := 1 To BLen Do {Цикл по количеству цифр во втором числе}
Begin
VspRez := A[I] * B[J] + P + C[I + J - 1];
C[I + J - 1] := VspRez Mod 10; {Очередное значение цифры в разряде I + J - 1}
P := VspRez Div 10 {Перенос в следующий разряд}
End;
C[I + BLen - 1] := C[I + BLen - 1] + P {последний перенос может быть отличен от нуля,
запишем его в пока ещё свободный разряд}
End
End;
{Процедура сложения длинных чисел.
A, B — множители, C — произведение}
Procedure Sum(A, B : DlChislo; Var C : DlChislo);
Var I, MaxDlin : Integer; P : Digit; VspRez : 0..99;
Begin
Zero(C);
P := 0;
MaxDlin:=Max(Dlina(A),Dlina(B));
For I := 1 To MaxDlin Do {Цикл по количеству цифр
в первом числе}
Begin
{Первоначально перенос равен нулю}
VspRez := A[I] + B[I] + P + C[I];
C[I] := VspRez Mod 10; {Очередное значение цифры в
разряде I + J - 1}
P := VspRez Div 10 {Перенос в следующий разряд}
End;
C[MaxDlin+1] := P {последний перенос может быть отличен от нуля,
его записываем на одну позицию выше}
End;

{Процедура инкремента длинного числа A (A:=A+1)}
procedure Inc(var A : DlChislo);
Var I,Dlin,VspRez : Integer; P : Digit;
Begin
P := 0;
Dlin:= dlina(A);
For I := 1 To Dlin Do {Цикл по количеству цифр в числе}
Begin
{Первоначально перенос равен нулю}
if I = 1 then
VspRez := A[I] + 1
else
VspRez := A[I] + P;
A[I] := VspRez Mod 10; {Очередное значение цифры}
P := VspRez Div 10; {Перенос в следующий разряд}
End;
A[Dlin+1] := A[Dlin+1]+P {последний перенос может быть отличен от нуля,
запишем его в пока ещё свободный разряд}
End;
{Процедура перевода длинного числа A в текстовою строку}
function ToString(A : DlChislo):string;
Var I : Integer;
Res:string;
Begin
Res:='';
For I := dlina(A) DownTo 1 Do {Цикл по количеству цифр в числе}
Res:=Res+IntToStr(A[I]);
Result:=Res;
End;

{Процедура сравнения длинных чисел.
A, B — числа, возвращает: -1, если A<B
0, если A=B
1, если A>B}
function Compare(var A, B : DlChislo):Integer;
Var I,Res,DlinaA,DlinaB : Integer;
Begin
DlinaA:=Dlina(A);
DlinaB:=Dlina(B);
if DlinaA < DlinaB then
begin
Res:=-1
end
else if DlinaA > DlinaB then
begin
Res:=1
end
else
begin
{По умолчанию признаём числа равными}
Res := 0;
For I := 1 To DlinaA Do
begin
if A[I]<B[I] then
Res:=-1
else if ((A[I]=B[I]) and (Res=0)) then
Res:=0
else
Res:=1;
End;
end;
Result:=Res;
End;

{Возводит X в степень a}
function pow(x:DlChislo; a:Integer):DlChislo;
var I:Integer;
pow:DlChislo;
begin
if a=0 then
begin
Translate('1',result,Trans);
end
else
begin
{a=1 }
pow:=x;
{to save the time we're improving a-1 times}
for I:=1 to a-1 do
Multiplication(pow,x,pow);
{return result}
Result:=pow;
end;
end;

{Число ValueI является полиндромом, если оно равно числу, которое получается из его цифр, прочитанных справа налево.
Функция возвращает True - если ValueI является полиндромом.
False - в противном случае.}

function IsPolyndrom(ValueI:DlChislo):Boolean;
var Level,LevelHalf,J:Longint;
IsPolyndrom:Boolean;
begin
Level:=Dlina(ValueI)+1;
LevelHalf:=(Level-1)div 2;
IsPolyndrom:=True;
For J:=LevelHalf DownTo 1 Do
begin
if not(ValueI[J]=ValueI[Level-J]) then
begin
IsPolyndrom:=False;
break;
end;
end;
Result:=IsPolyndrom;
end;

Begin
{Поиск полиндрома начиная с Value1 до Value 2}
Translate('1',ValueI,Trans);
Translate('1200000',ValueN,Trans);
{Начинаем рассчёт}
repeat
{Проверка, является ли текущее значение палиндромов}
if IsPolyndrom(ValueI) then
begin
{Если является - оно возводится в степень}
PowValueI:=pow(ValueI,2);
{Если результат возведения в степень - палиндром, он тоже возводится в степень}
if IsPolyndrom(PowValueI) then
writeln('x=',ToString(ValueI),'; x^2=',ToString(PowValueI));
end;
{Увеличиваем ValueI}
Inc(ValueI);
{Сравнение ValueI и ValueN}
until Compare(ValueI,ValueN) > 0;
{Выход из программы}
writeln;
writeln('The count is finished. Press any key to exit.');
readln;
End.