Автор работы: Пользователь скрыл имя, 16 Сентября 2009 в 13:41, Не определен
Учебник по программированию
p:boolean;
function sravnenie(x,y:chislo):integer;
var i,r:integer;
begin r:=0;i:=1;
repeat if (x[i])>(y[i]) then r:=1;
if x[i]<y[i] then r:=-1;
i:=i+1;
until (r<>0)or(i>kol);
sravnenie:=r;
end;
procedure add(x,y:chislo;var z:chislo);
var p,a,b,c:integer;
begin p:=0;
for i:=kol downto 1 do
begin a:=x[i];
b:=y[i];
c:=a+b+p;
z[i]:=c mod 10;
p:=c div 10;
end;
if p>0 then begin write('переполнение');
readln
end
end;
procedure sub (x,y:chislo;var z:chislo);
var i,j,p,l,a,b,r,c:integer;
begin p:=0;
for i:=kol downto 1 do
begin a:=(x[i]);
b:=(y[i]);
c:=a-b+p;
if c<0 then begin c:=c+10;
end
else p:=0;
z[i]:=(c);
end;
if p<0 then begin write('отриц.число');
readln
end;
end;
procedure Division(x,y:chislo;var z,O:chislo);
var a,b,r,c,i,j,xt,yt,yt1,s:
y1:chislo;
begin z:=C0; o:=x;
if sravnenie(x,y)=-1 then exit;
y1:=y;
yt:=1;while y[yt]=0 do inc(yt);
xt:=1;while x[xt]=0 do inc(xt);
s:=yt-xt;yt1:=xt;
for i:=1 to kol do if i+s<=kol then y1[i]:=y1[i+s]
while yt1<=yt do
begin r:=0;
while not(sravnenie(x,y1)=-1) do
begin Sub(x,y1,x);
r:=r+1
end;
for i:=1 to kol-1 do z[i]:=z[i+1];
z[kol]:=r;r:=0;
for i:=kol downto 2 do y1[i]:=y1[i-1];
y1[1]:=0;yt1:=yt1+1;
end;
o:=x
end;
procedure print(x:chislo);
var i:integer;
p:boolean;
begin p:=false;
for i:=1 to kol do
begin if x[i]<>0 then p:=true;
if p then write(x[i])
end;
if not(p) then write(0)
end;
procedure input(var x:chislo);
var i,j:integer; s:string;
begin readln(s);
x:=c0;j:=kol;
for i:=length(s) downto 1 do
begin val(s[i],x[j],code);
j:=j-1;
end;
end;
begin for i:=1 to kol do c0[i]:=0;
c1:=c0;c1[kol]:=1;
write('Введите n=');input(n);x:=n;
j:=c1;add(j,c1,j);k:=0;
writeln('Делители:');
writeln(1);p:=true;lastd:=c1;
while not(sravnenie(x,j)=-1) do
begin division(x,j,z,o);
if sravnenie(o,c0)=0
then begin x:=z;
end
else add(j,c1,j);
end;
writeln('Всего ',k+1,' делителей');
readln
end.
15. Переставить цифры числа так, чтобы образовалось максимальное
число, записанное теми же цифрами
program borlpasc;
var n:string; c:char;i,j:integer;
begin write('введите n'); readln(n);
for j:=1 to length(n) do
for i:=1 to length(n)-1 do
if n[i]<n[i+1] then begin c:=n[i]; n[i]:=n[i+1]; n[i+1]:=c;
end;
writeln('n=',n);
end.
16. Переставить цифры числа так, чтобы образовалось наименьшее число, записанное теми же цифрами.
program borlpasc;
var n:string; c:char;i,j:integer;
begin write('введите n='); readln(n);
for j:=1 to length(n) do
for i:=1 to length(n)-1 do
if n[i]>n[i+1] then begin c:=n[i]; n[i]:=n[i+1]; n[i+1]:=c;
end;
writeln('n=',n);
end.
17. составить программу перевода римских чисел в арабски
program borlpasc;{сост вить прогр мму перевод римских чисел в р бские}
var s:string; {ВЕРНА!!!!}
n,c,c1,i,a:integer;
begin writeln('введите число:');
readln(s);
c:=0;n:=0;
for i:=1 to length(s) do
begin
c1:=c;
if s[i]='I' then c:=1;
if s[i]='V' then c:=5;
if s[i]='X' then c:=10;
if s[i]='L' then c:=50;
if s[i]='C' then c:=100;
if s[i]='D' then c:=500;
if s[i]='M' then c:=1000;
if c>c1 then a:=-2*c1
else a:=0;
n:=n+a+c
end;
writeln('в ше число=',n)
end.
18. Дано натур. число N. Если это не палиндром, реверсируйте его цифры
и сложите исходное число с числом, полученным в результате
реверсирования. Если сумма не палиндром, то повторите те же действия
и выполняйте их до тех пор, пока не получится палиндром
{ Пример:
{ 78+87=165
{ 165+561=726
{ 726+627=1353 }
{ 1353+3531=4884
uses CRT;
var N, N2, nn:Longint;
BEGIN
ClrScr;
Write('N:= '); ReadLn(N);
nn:= 0;
repeat
N:= N+ nn;
nn:= 0;
N2:= N;
while N>0 do begin
nn:= nn*10+(N mod 10);
N:= N div 10;
end;
N:= N2;
Write(#13#10,N,'+ ', nn, '=');
until N=nn;
WriteLn(' Ответ');
Write('< Ok >'); ReadKey;
END.
19. Дано натур. число N. Поменять порядок следования цифр в этом числе на обратный
uses CRT;
var N, nn:Longint;
BEGIN
ClrScr;
Write('N:= '); ReadLn(N);
nn:= 0;
while N>0 do begin
nn:= nn*10+(N mod 10);
N:= N div 10;
end;
WriteLn('N''= ',nn);
Write(#10#13'< Ok >'); ReadKey;
END.
20. Дано натур. число N. Найти и вывести все числа в интервале от 1
до N-1, у которых произведение всех цифр совпадает с суммой цифр
данного
uses CRT;
var N, nn, i, A, B:integer;
BEGIN
ClrScr;
Write('N:= '); ReadLn(N);
A:= 1;
nn:= N;
Write('Произведение ');
while nn>0 do begin
A:= (nn mod 10)* A;
if (nn mod 10)>1 then
Write(nn mod 10,'x');
nn:= nn div 10;
end;
WriteLn(#8'=',A);
WriteLn('Числ :');
for i:=1 to N-1 do begin
nn:= i;
B:=1;
while nn>0 do begin
B:= (nn mod 10)* B;
nn:= nn div 10;
end;
if A=B then Write(i:8);
end;
Write(#10#13'< Ok >'); ReadKey;
END.
20. Найти произведение цифр заданного целого четырехзначного
числа.
+-----------------------------
¦ Номер ¦ Проверяемый ¦ Число ¦ Результ ты ¦
¦ тест ¦ случ й ¦ ¦ ¦
¦-------+---------------------
¦ 1 ¦ Число положительное ¦ Number = 2314 ¦ P = 24 ¦
¦-------+---------------------
¦ 2 ¦ Число отриц тельное ¦ Number =-1245 ¦ P = 40 ¦
+-----------------------------
Program DigitsProduct;
Uses Crt;
Var Number, {з д нное число}
i, j, k, l, {цифры числ }
P : Integer; {произведение цифр}