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

[SaS]

var
i, j: integer;
s1: string;
begin
Result := '';
while (s <> '') do
begin
i := Pos(' ', s);
if (i > 0) then
begin
s1 := Copy(s, 1, i - 1);
Delete(s, 1, i);
end
else
begin
s1 := s;
s := '';
end;
j := Length(s1);
if (j > 1) then
Result := Result + Copy(s1, j div 2 + 1, Length(s1)) + Copy(s1, 1, j div 2)
else
Result := s1;
if (i > 0) then
Result := Result + ' ';
end;
end;

function myF(s: string): string;

это для дельфи

Чот пробовал подогнать, под паскль, но что то видимо пропустил, не работает.

Спс bayarookie.

[L0K1]

ЭЭ а я отличиий не нашел.. delphi - pascal. Код один..

SaS

Ты как пробовал запускать? (вызов функции)

[Скиф]

Помогите пожалуйста решить задачу на Pascal'е очень надо!

[SxLvn]

Помогите плиз срочно решить задачку, матрицу вообще забыл(

Дана действительная матрица размера M*N. Определить числа Х1,Х2,...,Хm, равные соответственно суммам наибольших и наименьших значений элементов строк.

[SxLvn]

var
i, j: integer;
s1: string;
begin
Result := '';
while (s <> '') do
begin
i := Pos(' ', s);
if (i > 0) then
begin
s1 := Copy(s, 1, i - 1);
Delete(s, 1, i);
end
else
begin
s1 := s;
s := '';
end;
j := Length(s1);
if (j > 1) then
Result := Result + Copy(s1, j div 2 + 1, Length(s1)) + Copy(s1, 1, j div 2)
else
Result := s1;
if (i > 0) then
Result := Result + ' ';
end;
end;

function myF(s: string): string;

это для дельфи

Чот пробовал подогнать, под паскль, но что то видимо пропустил, не работает.

Спс bayarookie.

Паскаль:

program stroka;
uses crt;
var
  i, j: integer;
  s1,s,result: string;
begin
  clrscr;
  writeln('vvedite stroky');
  readln(s);
  Result := '';
  while (s <> '') do
  begin
    i := Pos(' ', s);
    if (i > 0) then
    begin
      s1 := Copy(s, 1, i - 1);
      Delete(s, 1, i);
    end
    else
    begin
      s1 := s;
      s := '';
    end;
    j := Length(s1);
    if (j > 1) then
      Result := Result + Copy(s1, j div 2 + 1, Length(s1)) + Copy(s1, 1, j div 2)
    else
      Result := s1;
    if (i > 0) then
      Result := Result + ' ';
  end;
  writeln(result);
  readkey;
end.

[Lakers]

SxLvn

uses crt;

var i,j,n,m:integer;

a:array[1..20,1..20]of integer;

function min(i:integer):integer;

var j,w:integer;

begin

w:=a[i,1];

for j:=2 to m do if a[i,j]

min:=w;

end;

function max(i:integer):integer;

var j,w:integer;

begin

w:=a[i,1];

for j:=2 to m do if a[i,j]>w then w:=a[i,j];

max:=w;

end;

begin

clrscr;

write('N= ');readln(n);

write('M= ');readln(m);

randomize;

for i:=1 to n do

for j:=1 to m do

a[i,j]:=random(100);

for i:=1 to n do begin

for j:=1 to m do

write(a[i,j]:4);

writeln;

end;

for i:=1 to n do begin

writeln(min(i)+max(i));

end;

readkey;

end.

Добавлено спустя 16 минут 20 секунд:

Скиф

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.

[PapiruS]

var
x, y, z: real;
i, j: integer;

begin
x := 0;
while x < 0.99998 do
begin
x := x + 0.00001;
y := x;
i := 1;
j := 1;
while true do
begin
i := i + 2;
j := j * -1;
z := Power(x, i) / i;
if z < 0.00001 then Break;
y := y + j * z;
end;
writeln(' x = ', x:1:5, ' y = ', y:6:4, ' = ', ArcTan(x):6:4);
end;
end.

может и нагнал чего-то, перепроверь

спс за решение но мне надо для блок схемы,мб переделаешь?

[bayarookie]

PapiruS

блок-схема? это что?

[PapiruS]

bayarookie

это кароче где в прямоугольничках да в овальчиках пишется алгоритм программы.

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

[Lakers]

PapiruS

вообщето она вот так решается=)

uses crt;

const e=0.00001;

var x,y,m:real;

i,k,l:integer;

begin

clrscr;

write('vvedite x= ');readln(x);

k:=1;

y:=0;

l:=0;

m:=x;

while m>e do begin

inc(l);

m:=x;

for i:=1 to k-1 do m:=m*x;

m:=m/k;

if l mod 2 =0 then y:=y+m else y:=y-m;

k:=k+2;

end;

writeln('Y= ',y:0:5);

writeln('arctan= ',arctan(x):0:6);

readkey;

end.

[PapiruS]

Lakers

cпс за решение но тут надо было найти значение выражение справой части а не арктангенса вот так:

[Lakers]

ну я его и нашел.просто этот ряд и есть арктангенс.а арктангенс я вывожу для проверки...

[Rush-j]

Пожалуйста помогите мне решить задачу на паскале

Задача. День рождения.

заданы день и месяц рождения, а также текущие день, месяц и год. Определите, сколько дней осталось до дня рождения.

Примечание. Високосные годы - это те, которые делятся на 400, а также те, номер которых делится на 4, но не делится на 100.

Ограничения: год от 1920 до 3000, месяц - от 1 до 12, день - от 1 до числа дней в месяце.

[bayarookie]

для дельфи просто:

var
  y, m, d: word;
begin
  DecodeDate(Now, y, m, d);
  writeln('enter day and month');
  readln(d, m);
  writeln(Trunc(EncodeDate(y, m, d)) - Trunc(Now));

или нужно разработать код низкоуровневый?

[Rush-j]

Мне на паскале это нужно...

[bayarookie]

вот фигня же этот паскаль:

uses WinCrt;

var
d1, m1, y1, d2, m2, i, j, d3: word;
m3: array [1..12] of word;

begin
writeln('Enter current day month year');
readln(d1, m1, y1);
writeln('enter day and month of birthday');
readln(d2, m2);
m3[1] := 31;
if (m1 > m2) or ((m1 = m2) and (d1 > d2)) then
y1 := y1 + 1;
if (y1 div 4) = (y1 / 4) then
m3[2] := 29
else
m3[2] := 28;
m3[3] := 31;
m3[4] := 30;
m3[5] := 31;
m3[6] := 30;
m3[7] := 31;
m3[8] := 31;
m3[9] := 30;
m3[10] := 31;
m3[11] := 30;
m3[12] := 31;
if (m1 = m2) and (d1 <= d2) then
d3 := d2 - d1
else
begin
d3 := m3[m1] - d1;
for i := 1 to 12 do
begin
j := m1 + i;
if (j > 12) then
j := j - 12;
if (j = m2) then Break;
d3 := d3 + m3[j];
end;
d3 := d3 + d2;
end;
writeln('remaining days: ', d3);
end.

program den_r;

Добавлено спустя 4 минуты 55 секунд:

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

[Rush-j]

Спасибо

[SaS]

var
i, j: integer;
s1: string;
begin
Result := '';
while (s <> '') do
begin
i := Pos(' ', s);
if (i > 0) then
begin
s1 := Copy(s, 1, i - 1);
Delete(s, 1, i);
end
else
begin
s1 := s;
s := '';
end;
j := Length(s1);
if (j > 1) then
Result := Result + Copy(s1, j div 2 + 1, Length(s1)) + Copy(s1, 1, j div 2)
else
Result := s1;
if (i > 0) then
Result := Result + ' ';
end;
end;

function myF(s: string): string;

это для дельфи

А в паскале тоже можеш, если нетрудно???

[bayarookie]

SaS

uses WinCrt;

var
i, j: integer;
s, s1, Result: string;

begin
writeln('enter string:');
readln(s);
Result := '';
while (s <> '') do
begin
i := Pos(' ', s);
if (i > 0) then
begin
s1 := Copy(s, 1, i - 1);
Delete(s, 1, i);
end
else
begin
s1 := s;
s := '';
end;
for j := 1 to Length(s1) do
begin
i := Pos(s1[j], s1);
i := Pos(s1[j], Copy(s1, i + 1, Length(s1)));
if (i = 0) then
Break;
end;
if (i > 0) then
Result := Result + s1 + ' ';
end;
writeln(Result);
end.

program two_char;

uses WinCrt;
var
A: array [1..2] of word;
X: array [1..2] of word;
am, x1, x2, i, Y: word;
begin
A[1] := 1;
A[2] := 2;
X[1] := 3;
X[2] := 4;
am := 0;
for i := 1 to 2 do
if am < A[i] then
am := A[i];
x1 := 0;
x2 := 0;
for i := 1 to 2 do
if Odd(i) then
begin
if x1 < X[i] then
x1 := X[i];
end
else
if x2 < X[i] then
x2 := X[i];
Y := am + sqr(x1 - x2);
writeln('Y=', Y);
end.

program max_1;

[PapiruS]

помогите решить задачи плз.Надо написать блок-схему или код на паскале чтобы можно было переделать под блок-схему

Дано натуральное число k. Напечатать k-ую цифру последовательности: 12345678910111213..., в которой выписаны подряд все натуральные числа.

Дана последовательность из целых чисел, которые вводятся по одному. За последним числом вводится нуль. Найти два наименьших числа последовательности.

[SxLvn]

Lakers Respect!

А можете такую задачку посмотреть:

Сказали через процедуру сделать, ваще не получатся:

Даны вещественные массивы А(16) В(20) вычислить:

у=((а1+а3+а5+...+а15)^2 - (b2+b4+b6+...+b20)^2)\((a2+a4+a6+...+a16)^2 + (b1+b3+b5+...+b10)^2)

[Lakers]

через функцию наверно а не процедуру.

Добавлено спустя 2 минуты 23 секунды:

ет че такое?

у=((а1+а3+а5+...+а15)^2 - (b2+b4+b6+...+b20)^2)\((a2+a4+a6+...+a20)^2 + (b1+b3+b5+...+b10)^2)

в то время как А(16)

Добавлено спустя 10 минут 23 секунды:

uses crt;

var a,b:array[1..20]of real;

i:integer;

function f:real;

var i:integer;

s1,s2,s3,s4:real;

begin

s1:=0;

for i:=1 to 15 do s1:=s1+a;

s2:=0;

for i:=1 to 20 do s2:=s2+b;

s3:=0;

for i:=2 to 16 do s3:=s3+a;

s4:=0;

for i:=1 to 10 do s4:=s4+b;

f:=(s1*s1-s2*s2)/(s3*s3+s4*s4);

end;

begin

clrscr;

randomize;

for i:=1 to 16 do a:=random(10);

for i:=1 to 20 do b:=random(10);

writeln(f:0:3);

readkey;

end.

Добавлено спустя 21 минуту 33 секунды:

PapiruS

uses crt;

var x,y,p,k:integer;

s:longint;

begin

clrscr;

write('N= ');readln(k);

x:=1;

y:=1;

p:=1;

s:=0;

while x<=k do

begin

s:=s+x;

x:=y+p;

p:=y;

y:=x;

end;

writeln('SUM= ',s);

readkey;

end.

uses crt;

var k,i,j,n,c:integer;

a:array[1..10]of byte;

begin

clrscr;

write('K= ');readln(k);

j:=0;

while k>0 do

begin

j:=j+1;

i:=j;

n:=0;

while i>0 do

begin

n:=n+1;

a[n]:=i mod 10;

i:=i div 10;

end;

if k-n>0 then

begin

k:=k-n

end

else

begin

c:=a[n-k+1];

k:=-1;

end;

end;

writeln©;

readkey;

end.

uses crt;

var x,m1,m2:integer;

begin

clrscr;

read(x);

m1:=x;

m2:=x;

while x<>0 do

begin

if (xm1) then m2:=x;

if (x

begin

m2:=m1;

m1:=x;

end;

read(x);

end;

writeln('MIN1: ',m1);

writeln('MIN2: ',m2);

readkey;

end.

[martinges]

Lakers

помойму в теле функции ошибка...... сумма идёт по четным и ечетным элементам массива, а у тебя суммирует все подряд....

[PapiruS]

Lakers

спс за решение , но 2-ую нужно без масива, для блок-схемы

а в первой почему та там на единицу ошибается

Добавлено спустя 6 минут 28 секунд:

uses crt;

var x,y,p,k:integer;

s:longint;

begin

clrscr;

write('N= ');readln(k);

x:=2;

y:=1;

p:=1;

s:=0;

while x<=k do

begin

s:=s+x;

x:=y+p;

p:=y;

y:=x;

end;

writeln('SUM= ',s);

readkey;

end.

[Lakers]

ага,можно так исправить.

а что трудного при описании массива в блок схеме?