Задачи на Pascal/Delphi (РЕШЕНИЕ)

[Digma]

День добрый. Прошу помощи, а точнее решите пожалуйсто 2 задачки.

Составти пожалуйсто программу.

1. Среди элементов квадратной матрицы 3х3 определить количество отрицательных элементов, а положительные увеличить на 2!!!

2. В массиве из 10 вещественных чисел найти наибольший элемент и поменять его местами с первым элементом.

ПОЖАЛЙСТО НАПИШИТЕ СРАЗУ ПРОГРАММУ, БУДУ ОЧЕНЬ БЛАГОДАРЕН! РЕШИВШЕМУ ЗАКИНУ ДЕНЕГ НА МОБИЛУ!!! ПЛИЗ!!!

[martinges]

пока свободное время буду прикалываться

Apocalipsis

раздел переменных

а,b: массив[1..const]действительных чисел;

count,i:целое число;

начало блока кода

цикл с параметром i

занести данные в массив a;

конец цикла с параметром;

цикл с параметром i

занести 0 в массив b;

конец цикла с параметром;

цикл с параметром i до const-1 элемента массива

если (i элемент а)*(i+1 элемент а)<0 тогда

начало

I+1 элемент массива b =1;

увеличиваем count на 1;

конец цикла с параметром;

цикл с параметром i

если I элемент массива b не равен 0 то вывести на экран: ‘мужик на ‘,I,’ месте знак поменялсо караул ’;

конец цикла с параметром;

вывести на экран: ‘капитан, за время вашего отсутствия выявлено ‘,count,’ чередований знаков ’;

конец блока кода.

[Baimer]

Digma

var
a:array [1..3,1..3]of integer;
i,j,n:integer;
begin
for i:=1 to 3 do
for j:=1 to 3 do
begin
readln(a[i,j]);
if a[i,j]<0 then n:=n+1
else a[i,j]:=a[i,j]+2;
end;
for i:=1 to 3 do begin
writeln;
for j:=1 to 3 do write(a[i,j],' ');
end;
writeln('отрицательных элементов ',n);
end.

program zadacha1;

var
a:array[1..10]of real;
i,n:integer;
x:real;
begin
for i:=1 to 10 do readln(a[i]);
x:=a[1];
n:=1;
for i:=2 to 10 do if x x:=a[i];
n:=i;
end;
a[n]:=a[1];
a[1]:=x;
for i:=1 to 10 do writeln(a[i]);
end.

program zadacha2;

[Apocalipsis]

Кто умеет создавать отчеты в делфи отпишите в личку.

[Exclusive]

Уважаемые программисты. Пожалуйсто напишите программу для решения этих двух задачек.

1. Определить, является ли заданное натуральное число N совершенным, т.е. равным сумме всех своих (положительных) делителей, кроме самого себя.

2. Вычислить значение выражения: y=5!/(4в степени5+4!/(4в степени4+3!/(4в степени3+2!/(4в степени2+1/(4+х)))))

Не смог понять как написать число в степени, поэтому написал словами. Пожалуйсто помогите, напишите программу...

[ght]

спасибо за решение задач!!! Решите пожалуйста еще 2 задачи до пятницы срочно надо(скоро сессия )

1. Найти все двухзначные числа , сумма квадратов цифр которых делится на 13

2. Даны действительное a и натуральное n . Вычислить

p=a*(1+2)*(1+2+3)*...*(1+2+...+n)

[SxLvn]

Написал прогу, тока чёт она тупит, помогите исправить, пожалуйста:

Даны сведения о сотрудниках учреждения: фамилия, инициалы, номер телефона.

Упорядочить сведения о сотрудниках, фамилия которых начинается с заданной буквы, в порядке возрастания номеров телефонов.

program zad;
uses crt;
const y=3;
type stud=record
fam,fio:string[30];
nomer:longint;
end;
var st:stud;
a:array[1..y] of stud;
i,j,k,n:integer;
x:longint;
begin
clrscr;
for i:=1 to y do
begin
writeln ('vvedite familiyu'); readln (a[i].fam);
writeln ('vvedite iniczial'); readln (a[i].fio);
writeln ('vvedite nomer'); readln (a[i].nomer);
end;
for i:=1 to y do
if a[i].fam[1]='o' then x:=a[i].nomer;
n:=i;
for j:=1 to y do
if a[j].nomer>x then
begin
x:=a[j].nomer;
n:=j;
end;
for i:=n to y do
a[i]:=a[i+1];
for i:=1 to y do
writeln (a[i].fam, a[i].fio:4, a[i].nomer:12);
readkey
end.

[martinges]

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

[FunlOvEe]

ght

var i:integer;
begin
clrscr;
for i:= 10 to 99 do
if ( ( sqr( i div 10 ) + sqr( i mod 10 ) ) mod 13 = 0 ) then
write( i:3 );
readkey;
end.

uses crt;

var n,i:integer;
a,p:real;
function sum(n:integer):integer;
begin
if n = 0 then sum := 0
else
sum := n+sum(n-1);
end;
begin
clrscr;
write('a = ');
readln(a);
write('n = ');
readln(n);
p := a;
for i:=2 to n do
begin
p := p * sum(i);
end;
write('Ответ: ',p:5:2);
readkey;
end.

uses crt;

[genemy]

SxLvn, у вас в коде полная каша

где сортировка то ?

примерно должно быть так

писал прямо тут, не проверял )

var
tmp_stud : stud;
// ....
for i:=1 to y
do if a[i].fam[1]='o'
then begin
		x := 0;
		for j := i to у
		do if a[j].fam[1]='o' and a[j].nomer > x
		then begin
			x := a[j].nomer;
			k := j;
		end;
	if k <> i
	then begin
		tmp_stud := a[i];
		a[i] := a[k];
		a[k] := tmp_stud;
		end;
end;
// тут вывод

[$h|{et]

Уважаемые программисты. Пожалуйсто напишите программу для решения этих задач.

1.Дана последовательность действительных чисел A1,

2.Даны действительные числа A1,A2,...An. Требуется умножить все члены последовательности A1,A2,...An на квадрат ее наименьшего члена, если Ак>0,и на квадрат ее наибольшего члена, если Ак<0(1

3.Дана последовательность целых чисел.Найти кол-во различных чисел в этой последовательности.

4.Дана последовательность целых чисел A1,A2,...An.Выяснить, какое число встречается раньше-положительное или отрицательное.

[Галсан]

все уже не надо

[Digma]

Уважаемые программисты. Пожалуйсто напишите программу для решения этих двух задачек.

1. Определить, является ли заданное натуральное число N совершенным, т.е. равным сумме всех своих (положительных) делителей, кроме самого себя.

2. Вычислить значение выражения: y=5!/(4в степени5+4!/(4в степени4+3!/(4в степени3+2!/(4в степени2+1/(4+х)))))

Не смог понять как написать число в степени, поэтому написал словами. Пожалуйсто помогите, напишите программу...

[SxLvn]

genemy а можешь всю прогу написать, а то у мну не получается.

У меня так получилось

uses crt;
const y=3;
type stud=record
fam,fio:string[30];
nomer:longint;
end;
var tmp_stud:stud;
a:array[1..y] of stud;
i,j,k,n:integer;
x:longint;
begin
clrscr;
for i:=1 to y do
begin
writeln ('vvedite familiyu'); readln (a[i].fam);
writeln ('vvedite iniczial'); readln (a[i].fio);
writeln ('vvedite nomer'); readln (a[i].nomer);
end;
for i:=1 to y
do if a[i].fam[1]='o'
then begin
x := 0;
for j := i to ó
do if a[j].fam[1]='o' and a[j].nomer > x
then begin
x := a[j].nomer;
k := j;
end;
if k <> i
then begin
tmp_stud := a[i];
a[i] := a[k];
a[k] := tmp_stud;
end;
end;
for i:=n to y do
a[i]:=a[i+1];
for i:=1 to y do
writeln (a[i].fam, a[i].fio:4, a[i].nomer:12);
readkey
end.

program zad;

[genemy]

 for i:=n to y do

     a:=a[i+1];

вот это зачем ?

у меня ни дельфи ни паскаля нету

[ght]

FunlOvEe

спасибо огромное! Завтро покажу задачи и все ок)))

[FunlOvEe]

Digma

var i,n,sum:integer;
begin
clrscr;
write(' N = ' );
readln(n);
for i:=1 to n div 2 do
if n mod i = 0 then
sum:= sum + i;
if ( sum = n) then
writeln(' Число ',n, ' совершенное')
else
writeln(' Число ',n, ' несовершенное');
readkey;
end.

uses crt;

var n,i:integer;
x,y:real;
function f(n:integer):integer;
begin
if n = 0 then f := 1
else
f := n*f(n-1);
end;
function s(x,n:real):real;
var t:real;
begin
t := Abs(x);
if x < 0 then
s:= (-1)*exp(n*Ln(t))
else
s:= exp(n*Ln(t));
end;
begin
clrscr;
x := 0;
y := f(5)/( s(4,5)+f(4) /
( s(4,4)+f(3) /
( s(4,3)+f(2) /
(s(4,2)+1/(4+x))
)
)
);
write(y:1:8);
readkey;
end.

uses crt;

SxLvn

const y = 4;
type stud = record
fam,fio:string[30];
nomer:longint;
end;
var tmp_stud:stud;
a:array[1..y] of stud;
i,j,k,n:integer;
x:longint;

procedure swap(var e1, e2: stud);
var
e: stud;
begin
e := e1; e1 := e2; e2 := e;
end;

procedure qsort(l, r: integer);
var
i, j, x: integer;
begin
i := l;
j := r;
x := a[l+random(r-l+1)].nomer;
repeat
while ( x > a[i].nomer ) do inc(i);
while ( x < a[j].nomer ) do dec(j);
if (i <= j) and ((a[i].fam[1] = 'o') or ( a[j].fam[1] = 'o')) then
begin
swap(a[i], a[j]);
inc(i);
dec(j);
end
else
begin
inc(i);
dec(j);
end;
until i > j;
if l < j then qsort(l, j);
if i < r then qsort(i, r);
end;

begin
clrscr;
for i:=1 to y do
begin
write('vvedite familiyu: ');
readln(a[i].fam);
write('vvedite iniczial: ');
readln(a[i].fio);
write('vvedite nomer: ');
readln(a[i].nomer);
end;
for i:=1 to y do
if ( a[i].fam[1] = 'o' ) then
qsort(1,y);
for i:=1 to y do
writeln (a[i].fam, a[i].fio:4, a[i].nomer:12);
readkey;
end.

uses crt;

[SxLvn]

SxLvn

const y = 4;
type stud = record
fam,fio:string[30];
nomer:longint;
end;
var tmp_stud:stud;
a:array[1..y] of stud;
i,j,k,n:integer;
x:longint;

procedure swap(var e1, e2: stud);
var
e: stud;
begin
e := e1; e1 := e2; e2 := e;
end;

procedure qsort(l, r: integer);
var
i, j, x: integer;
begin
i := l;
j := r;
x := a[l+random(r-l+1)].nomer;
repeat
while ( x > a[i].nomer ) do inc(i);
while ( x < a[j].nomer ) do dec(j);
if (i <= j) and ((a[i].fam[1] = 'o') or ( a[j].fam[1] = 'o')) then
begin
swap(a[i], a[j]);
inc(i);
dec(j);
end
else
begin
inc(i);
dec(j);
end;
until i > j;
if l < j then qsort(l, j);
if i < r then qsort(i, r);
end;

begin
clrscr;
for i:=1 to y do
begin
write('vvedite familiyu: ');
readln(a[i].fam);
write('vvedite iniczial: ');
readln(a[i].fio);
write('vvedite nomer: ');
readln(a[i].nomer);
end;
for i:=1 to y do
if ( a[i].fam[1] = 'o' ) then
qsort(1,y);
for i:=1 to y do
writeln (a[i].fam, a[i].fio:4, a[i].nomer:12);
readkey;
end.

uses crt;

Спс за попытку, но прога не сортирует

[SaS]

Помогите написать.

Среди N четырехугольников с заданными сторонами подсчитать количество параллелограммов, из которых найти один с наибольшим периметром.

[Lakers]

Экспромт.....

max,i,n,k:integer;
function pro(i:integer):boolean;
begin
if ((a[i][1]=a[i][2])and(a[i][3]=a[i][4]))or
((a[i][3]=a[i][2])and(a[i][1]=a[i][4]))then pro:=true
else pro:=false;
end;

begin
clrscr;
write('Введите кол-во четырехугольников');
readln(n);
for i:=1 to n do
begin
write('сторона 1: ');readln(a[i][1]);
write('сторона 2: ');readln(a[i][2]);
write('сторона 3: ');readln(a[i][3]);
write('сторона 4: ');readln(a[i][4]);
end;
max:=-1;
for i:=1 to n do
begin
if pro(i) then
begin
k:=k+1;
if a[i][1]+a[i][2]+a[i][3]+a[i][4]>max then
max:=a[i][1]+a[i][2]+a[i][3]+a[i][4];
end;
end;
writeln('количество прямоугольников: ',k);
writeln('максимальный периметр: ',max);
readkey;
end.

var a[1..100][1..4]of integer;

[Скиф]

Скиф

program D_Andre;

type Pere=array [1..10] of byte;

var N,i,j:byte;

X:Pere;

Yes:boolean;

procedure Next(var X:Pere;var Yes:boolean);

var i:byte;

procedure Swap(var a,b:byte); {обмен переменных}

var c:byte;

begin c:=a;a:=b;b:=c end;

begin

i:=N-1;

while (i>0)and(X>X[i+1]) do dec(i);

if i>0 then

begin

j:=i+1;

while (jX) do inc(j);

Swap(X,X[j]);

for j:=i+1 to (N+i) div 2 do Swap(X[j],X[N-j+i+1]);

Yes:=true

end

else Yes:=false

end;

function pro:boolean;

var i:integer;

f:boolean;

begin

f:=true;

for i:=1 to n-1 do

begin

if i mod 2=1 then

begin

if x>x[i+1] then f:=false;

end

else

begin

if x

end;

end;

pro:=f;

end;

begin

assign(input,'p.txt');

reset(input);

assign(output,'p_OUT.txt');

rewrite(output);

readln(n);

for i:=1 to N do X:=i;

repeat

if pro then begin for i:=1 to N do write(X);writeln;end;

Next(X,Yes)

until not Yes;

close(output);

end.

создаш файл "p.txt" туда запишеш 7.

Спасибо огромное!!!!!!

[SaS]

Lakers спс.

Вот ещо помогите)))

Pascal/Записи.

Даны сведения о сотрудниках учреждения: фамилия, инициалы, номер телефона (если телефона нет, то 0).
а) Выдать на экран сведения о сотрудниках, номер телефона которых заканчивается на  “10”, и подсчитать их количество.
б) Упорядочить все сведения о сотрудниках в алфавитном порядке фамилий.

Помогите)

[martinges]

а в чем именно помочь? с функцией ввода? с процедурой сортировки? если просто тупо написать прогу, то это неинтересно

[SaS]

Lakers спс.

Вот ещо помогите)))

Pascal/Записи.

Даны сведения о сотрудниках учреждения: фамилия, инициалы, номер телефона (если телефона нет, то 0).
а) Выдать на экран сведения о сотрудниках, номер телефона которых заканчивается на  “10”, и подсчитать их количество.
б) Упорядочить все сведения о сотрудниках в алфавитном порядке фамилий.

HeLp)))

[ght]

решите еще эти плз)))

1) Вычислить произведение элементов массива С [7] целых чисел, и если это произведение отрицательное , то вывести его абсолютное значение.

2) Дана последовательность n различных целых чисел. Найти сумму ее членов , расположенных между максимальным и минимальным значениями(в сумму включить и оба этих числа)

меня уже в группе за гения считают =))))