» Задачи на Turbo Pascal 7.0

Товарищи! Огромноя просьба: ПОМОГИТЕ! Ведь сесия на носу! Вот пару задач, кто что может!

№1.
Дан целый массив из 4 строк и 5 столбцов. Упорядочить массив по возростанию элементов первой строки.

№2.
В массиве из 10 целых чисел найти наименьшие элементы и поменять местами с последним элементом.

№3.
Ввести строку из символов 2-х типов: А и В. Подсчитать колличество символов А и символов В в строке. Если число символов А больше числа символов В, то удалить в строке все символы В, иначе удалить в строке все символы А. Вывести полученую строку.

Зарание, всем попытавшимся решить эти задачки, вырожаю большую благодарность!
P.S. Ведь сесия на носу!

Цитата:

№1.
Дан целый массив из 4 строк и 5 столбцов. Упорядочить массив по возрастанию элементов первой строки.

Program Primer1;
Uses crt;
Type TMass=Array [1..4,1..5] of Integer;
var mass:TMass;
Procedure Vvod(var a:TMass);
var i,j:Integer;
begin
For i:=1 to 4 do
For j:=1 to 5 do
begin
Write('a[',i,',',j,']=');
Readln(a[i,j]);
end;
end;
Procedure ObmenStolbcov(k,l:Integer);
var b:Array [1..4] of Integer;
i:Integer;
begin
For i:=1 to 4 do
begin
b[i]:=mass[i,k];
mass[i,k]:=mass[i,l];
mass[i,l]:=b[i];
end;
end;
Procedure Vozrastanie(var a:TMass);
var i,j,min,N:Integer;
begin
For i:=1 to 5 do
begin
min:=a[1,i];
N:=i;
For j:=i+1 to 5 do
if a[1,j]<min then
begin
min:=a[1,j];
N:=j;
end;
If i<>N then ObmenStolbcov(i,N);
end;
end;
Procedure Vivod(a:TMass);
var i,j:Integer;
begin
For i:=1 to 4 do
For j:=1 to 5 do
Writeln('a[',i,',',j,']=',a[i,j]);
end;
begin
ClrScr;
Vvod(mass);
Vozrastanie(mass);
Vivod(mass);
Readkey;
end.


Добавлено:

Цитата:

№3.
Ввести строку из символов 2-х типов: А и В. Подсчитать колличество символов А и символов В в строке. Если число символов А больше числа символов В, то удалить в строке все символы В, иначе удалить в строке все символы А. Вывести полученую строку.

Program Primer3;
Uses Crt;
var s:String;
Function KolSimv(ch:Char;Str:String):Integer;
var i,k:Integer;
begin
k:=0;
For i:=1 to Length(Str) do
if Str[i]=ch then inc(k);
KolSimv:=k;
end;
Function StrokaUdal(ch:Char;Str:String):String;
var i:Integer;
begin
While pos(ch,Str)<>0 do
Delete(Str,pos(ch,Str),1);
StrokaUdal:=Str;
end;
begin
ClrScr;
Write('Введите строку:');
Readln(s);
If KolSimv('A',s)>KolSimv('B',s) then Writeln(StrokaUdal('B',s)) else
Writeln(StrokaUdal('A',s));
Readkey;
end.

Добавлено:

Цитата:

№2.
В массиве из 10 целых чисел найти наименьшие элементы и поменять местами с последним элементом.

Program Primer2;
Uses Crt;
Const k=10;
Type TMass=Array[1..k] of Integer;
var m:TMass;
Procedure Vvod;
var i:Integer;
begin
For i:=1 to k do
begin
Write('m[',i,']=');
Readln(m[i]);
end;
end;
Function min:Integer;
var d,i:Integer;
begin
d:=m[1];
For i:=2 to k do
if m[i]<d then d:=m[i];
min:=d;
end;
Procedure Zamena;
var t,i:Integer;
begin
t:=min;
If t<>m[10] then
begin
For i:=1 to k do
if t=m[i] then m[i]:=m[10];
m[10]:=t;
end;
end;
Procedure Vivod;
var i:Integer;
begin
For i:=1 to k do Write('m[',i,']=',m[i]);
end;
begin
ClrScr;
Vvod;
Zamena;
Vivod;
Readkey;
end.

Люди, помогите разобрать программу:

uses crt,graph;
var A,B:array[0..51,0..31] of boolean;
i,j,VP,step,live,dead,born:integer;
s,stri:string;
label 1;
{****************************************}
Procedure FlipVP(var P:integer);
Begin
SetVisualPage(P);
P:=1-P;
SetActivePage(p);
ClearDevice;
End;
{****************************************}
Function Nears(x,y:integer):integer;
var i,j,s:integer;
Begin
s:=0;
for i:=x-1 to x+1 do
for j:=y-1 to y+1 do
if a[i,j] then s:=s+1;
if a[x,y] then s:=s-1;
Nears:=s;
End;
{****************************************}
Function Change:boolean;
Begin
born:=0;
dead:=0;
Change:=False;
for i:=1 to 50 do
for j:=1 to 30 do
begin
if A[i,j] then
begin
if ((Nears(i,j)<2) or (Nears(i,j)>3)) then
begin
B[i,j]:=false;
dead:=dead+1;
Change:=true;
end;
end
else
begin
if Nears(i,j)=3 then
begin
B[i,j]:=true;
born:=born+1;
Change:=true;
end;
end;
end;
End;
{****************************************}
Procedure Setup;
var i,j:integer;
Begin
Randomize;
for i:=1 to 50 do
for j:=1 to 30 do
if Random(2)=0 then A[i,j]:=true;
End;
{****************************************}
Procedure Draw;
var i,j:integer;
Begin
Rectangle(0,0,639,349);
for i:=0 to 51 do
for j:=0 to 31 do
begin
if A[i,j] then SetFillStyle(1,10)
else SetFillStyle(9,1);
Bar(55+10*i,10+8*j,65+10*i,18+8*j);
Rectangle(55+10*i,10+8*j,65+10*i,18+8*j);
end;
End;
{****************************************}
Procedure Copy;
var i,j:integer;
Begin
for i:=1 to 50 do
for j:=1 to 30 do
A[i,j]:=B[i,j];
End;
{****************************************}
Procedure Print;
Begin
Str(step:3,s);
stri:='Step#'+s;
Str(live:3,s);
stri:=stri+' Cells '+s;
outtextxy(55,300,stri);
Str(born:3,s);
stri:='Born'+s;
Str(dead:3,s);
stri:=stri+' Died'+s;
outtextxy(55,315,stri);
End;
{****************************************}
Procedure Count;
var i,j:integer;
Begin
live:=0;
for i:=1 to 50 do
for j:=1 to 30 do
if A[i,j] then live:=live+1;
End;
{****************************************}
BEGIN
Setup;
i:=9;
j:=1;
InitGraph(i,j,'c:\bp\bin');
SetColor(9);
While Change do
begin
step:=step+1;
FlipVP(VP);
Draw;
Count;
Print;
Copy;
Delay(22);
if KeyPressed then
if ReadKey<>'' then
goto 1;
end;
1:
ReadKey;
CloseGraph;
ClrScr;
END.

Там понятно почти все, только я не поняла, как процедуры Setup и Count работают. Заранее благодарю.
Кстати, программа игры "Жизнь" Конвея

minos14 Большое спасибо!!!

Товарищи ру.нета, огромная просьба - решите кто что сможет, тем самым вы поможете бедному студенту. Сесия через неделю, а я в душе не е.. как решать эти задачки! И в армию я тоже не хочу! Заранне всем попытавшимся решить эти задачи, выражаю благодарность! В долгу не останусь, помогу чем смогу. А вот и они:











P.S: Ну не силен я в Pascal'e что ж поделаешь!

Народ помогите:
Напишите программу, которая бы читала число, и находила бы все простые числа - полиндромы(с начала и с конца читаются одиннаково) до него.

rumigor
Что именно ты не можешь сделать? так как в программе надо реализовать всего две два действия, это проверка на простоту (делается в лоб, просто проверяю алгоритм простоты) и второе это проверка на перевертыш (есть 2 способа это сделать ИМХО), уточни что конкретно не понятно, и дай код, который не работает, так как целиком вряд ли кто будет писать, обычно ищут ошибки.

Помогите с этим заданием
При некоторых заданных x,N и Е, определяемых вводом, вычислите сумму N слагаемых заданного вида, а также сумму тех слогаемых, которые по абсолютной велечине больше Е. Для второго случая выполните суммирование двух значений Е, отличающихся на порядок, и при этом определите количество слагаемых, включенных в сумму. Сравните результаты с точным значением функции, для которой данная сумма определяет приближенное значение при х, лежащем в интервале (-R,R)
картинку к заданию можно посмотреть здесь http://leahov.narod.ru/zadanie.html

Народ, подскажите как реализовать вывод графиков двух функций в текстовый файл (*.txt), при помощи псевдографики??? (предположим y=x^2 и y=e^x)

Пацаны помогите плиз!!! Задачка не сложная, но у меня блин не получается!
Вообщем задача с циклом:
дана функция F=tg^4 (x^5+c-19^0) при этом 1<=x<=5; шаг =0.2; c=-14,2.
Блин уже все перепробовал - постоянно выдает сабж типо     "invalid floating point operation", либо все значения f - одинаковые, а я так думаю что такого быть не должно!

Добавлено:
uses crt;
var a,c,x,f:real;
begin
clrscr;
c:=(-14,2);
x:=1;
a:=((exp(5*(ln(x))))+c-1);
while (x<=5) do
begin
f:=exp(4*(ln(sin(a)/cos(a))));
write(x:6:3,' =x ');
writeln(f:6:3, ' =f');
x:=x+0.2;
end;
readln;
end.

Енто код. Иль хотяб ошибки помогите найти. plz

Цитата:

uses crt;
var a,c,x,f:real;
begin
clrscr;
c:=-14.2; //здесь точка нужна как разделитель целой и дробной
x:=1;
while (x<=5) do
begin
a:=exp(5*ln(x))+c-1;
f:=exp(4*ln(tan(a)));
write(x:6:3,' =x ');
writeln(f:6:3, ' =f');
x:=x+0.2;
end;
readln;
end.

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

пожалуйста помогите решить вот эти задачки, а если можете то объсните.Я сам не успеваю экзамены зачёты...прошу !!!!!!!
№2
1. Треугольник задан величинами его углов и радиусом описанной окружности. Найти стороны треугольника.
2. Треугольник задан длинами сторон. Найти длины медиан.
 
№3
1. Даны действительные положительные числа a,b. Выяснить, можно ли прямоугольник со сторонами a,b уместить внутри прямоугольника со сторонами c,d так, чтобы каждая из сторон одного прямоугольника была параллельна или перпендикулярна каждой стороне второго прямоугольника.
2. Даны действительные числа a,b,c,d. Если a<=b<=c<=d, то числа оставить без изменения; в противном случае все числа заменяются их квадратами.
 
№4
1. Дано действительное число a. Найти среди чисел 1, 1+1/2, 1+1/2+1/3,… первое, большее a.
2.  Дано натуральное число n. Получить наименьшее число в виде 2 в степени n, превосходящее n.

to ShIvADeSt: Спасибочки!
Если честно то я сам немного недогнал зачем мне дают 19 в степени 0! А выражение под тангенсом (x в степени 5 + с - 19 в степени 0), тангенс в 4 ой степени.
Исправил ошибку, но теперь пишет "invalid floating operation". Блин не пойму чего ему не нравится, а если без использования exp то считает. Может еще чего подскажешь? А то я на паскале всего 2 недели и многого не знаю.

grek99
попробуй взять abs(), т.к. числа некоторые отрицательные. На отладке видно, когда возникает ошибка.

f:=exp(4*ln(abs(tan(a))));

to DisAsm:
Спасибо за помощь! Вроде работает.

Добавлено:
Есчо вопросик!

Цитата:

program comp;
type TComp=Record
Re,Im:real;
Algebr:boolean;
end;
var Comp1,Comp2,Comp3:TComp;

procedure InComp(Var Comp:TComp);
Const Str1='vvedite deistvetelnyu chast';
Str2='vvedite mnimyu chast';
begin write(Str1);
readln(Comp.Re);
write(Str2);
readln(Comp.Im);
end;

procedure OutComp(Str:string;Comp:TComp);
begin
with Comp do
if (Im>=0) then
writeln(Str,Re:5:2,'+j',Im:5:2)
else writeln(Str,Re:5:2,'-j',-Im:5:2);
end;


begin
InComp(Comp1);
InComp(Comp2);
InComp(Comp3);
OutComp (???);
end.

Вот в этом всем я вообще разобраться не могу!!! Здесь процедуры ввода и вывода комплексных чисел. Вводиться они вводятся а что мне надо написать где OutComp не знаю! Поможите plz!

2 grek99

Цитата:

что мне надо написать где OutComp не знаю!

Нужно написать:

Цитата:

OutComp (_Str, _Comp);

, где _Str - любая строка (которая будет выводится процедурой OutComp перед комплексным числом _Comp), _Comp - комплексное число (запись типа TComp)

например, если

Цитата:

Comp1.Re:= 1;
Comp1.Im:= 2;
OutComp('Comp1 is ', Comp1);

, то будет выведено:

Цитата:

Comp1 is 1.00+j 2.00

To Dikun:
Спасибочки большое!!! А не знаешь как мне здесь же написать процедуры для действий над комплексными числами т.е. -,+,*,/ ???

2 grek99

Цитата:

А не знаешь как мне здесь же написать процедуры для действий над комплексными числами т.е. -,+,*,/ ???

Цитата:

procedure SumComp(comp1, comp2: TComp; var Result: TComp);
{сумма}
begin
Result.Re:= comp1.Re + comp2.Re;
Result.Im:= comp1.Im + comp2.Im;
end;

procedure DifferenceComp
(
comp1 {уменьшаемое},
comp2 {вычитаемое}: TComp;
var Result: TComp
);
{разность}
begin
Result.Re:= comp1.Re - comp2.Re;
Result.Im:= comp1.Im - comp2.Im;
end;

procedure ProductComp(comp1, comp2: TComp; var Result: TComp);
{произведение}
begin
Result.Re:= comp1.Re * comp2.Re - comp1.Im * comp2.Im;
Result.Im:= comp1.Im * comp2.Re + comp1.Re * comp2.Im;
end;

procedure QuotientComp
(
comp1 {делимое},
comp2 {делитель}: TComp;
var Result: TComp
);
{частное}
var
a: Real;
begin
a:= Sqr(comp2.Re) + Sqr(comp2.Im);
Result.Re:= (comp1.Re * comp2.Re + comp1.Im * comp2.Im) / a;
Result.Im:= (comp1.Im * comp2.Re - comp1.Re * comp2.Im) / a;
end;

Использование: например,

Цитата:

Comp1.Re:= 1;
Comp1.Im:= 2;

Comp2.Re:= 3;
Comp2.Im:= 4;

QuotientComp(Comp1, Comp2, Comp3);
OutComp('The Result is ', Comp3);

!Хотя бы половину решите плиззз......очень прошу вас

to dikun: Спасибо ужо разобрался!

1. Треугольник задан величинами его углов и радиусом описанной окружности. Найти стороны треугольника.
2. Треугольник задан длинами сторон. Найти длины медиан.

Напишите пожалуйста какие здесь формулы надо ставить...а то я не силён в математике
------------------------------------------------------------------------------------------------------------
2. Даны действительные числа a,b,c,d. Если a<=b<=c<=d, то числа оставить без изменения; в противном случае все числа заменяются их квадратами.

И как здесь условие написать....вот мой вариант

If a<=b then
begin
If b<=c then
begin
If c<=d then
Хотя здесь что-то не так..
а еще как можно записать??

Цитата:

2. Даны действительные числа a,b,c,d. Если a<=b<=c<=d, то числа оставить без изменения; в противном случае все числа заменяются их квадратами.

И как здесь условие написать....вот мой вариант

If a<=b then
begin
If b<=c then
begin
If c<=d then
Хотя здесь что-то не так..
а еще как можно записать??

Я думаю что прога выглядит примерно так:

var a,b,c,d,z,x,y,v:integer;
begin
writeln('введите числа');
readln(a,b,c,d);
if (a<=b) and (b<=c) and (c<=d) then writeln(a,b,c,d)
else begin
z:=a*a;
x:=b*b;
y:=c*c;
v:=d*d;
writeln('квадраты чисел',z,x,y,v);
end
end.

спасибо большое grek99!!!

ну а я сам сделал вот так
uses crt;
var a,b,c,d:integer;
begin
clrscr;
writeln('ведите числа a,b,c,d');
readln(a,b,c,d);
if (a<=b) and (b<=c) and (c<=d) then writeln <-- я не знал как это написать
else begin
a:=sqr(a); b:=sqr(b); c:=sqr(c); d:=sqr(d);
end;
writeln('a=',a,' b=',b,' c=',c,' d=',d);
readln
end.


Добавлено:
а не мог бы ты на счет этой задачки подкинуть формулы

1. Треугольник задан величинами его углов и радиусом описанной окружности. Найти стороны треугольника.

вторую то я сам кое как доделал почти

Цитата:

а не мог бы ты на счет этой задачки подкинуть формулы

1. Треугольник задан величинами его углов и радиусом описанной окружности. Найти стороны треугольника.

Я бы с радостью но вот уже геометрию забыл, ни одной формулы не помню а в учебнике копаться времени нету -> зачеты поздавать не могу, так что делов хватает.

понимаю....но всё равно спасибо!!!

grek99
Transeau
еще такие бессмысленные посты и в рид онли, подобные вещи по ПМ.

Цитата:

1. Треугольник задан величинами его углов и радиусом описанной окружности. Найти стороны треугольника.

Код:
Условные обозначения:
X[Y] - X с индексом Y.

Как задать режим окна, в котором выполняется программа, размером 80 на 40 ? С каким аргументом вызывать процедуру textmode(?) ?

Добавлено:
СРОЧНО!!

Номера некоторых видеорежимов (на других видеокартах видеорежимы могут отличаться, почему - см. ниже):
0 - 40x25
2 - 80x25
7 - 80x25 black-white
256 - 40x50
258 - 80x50
263 - 80x50 black-white



Выдержка из help'а TP7 на русском (есть на http://slonpts.narod.ru/rus_help.zip 362 Kb
скопировать в папку с turbo.exe с заменой файлов):

TextMode (процедура) (Модуль Crt)
-------------------------------------
Устанавливает определенный текстовый режим.

Объявление:
Procedure TextMode(Mode : Integer);

Режим:
Real, Protected

Замечания:
При вызове процедуры TextMode:

¦ Размеры текущего окна приравниваются к размерам всего экрана

¦ DirectVideo устанавливается равным True

¦ Если был выбран цветной режим, то CheckSnow устанавливается равным True

¦ Текущий текстовый атрибут сбрасывается к нормальному, что соответствует вызову NormVideo

¦ Прежний видеорежим сохраняется в переменной LastMode

Кроме того, при запуске программы, значение переменной LastMode
устанавливается равным последнему активному видеорежиму.

Вызов TextMode(LastMode) устанавливает последний активный текстовый режим.
Это может быть полезно, если вы хотите возвратиться к текстовому режиму
после работы в графическом режиме.

Следующее обращение к TextMode

TextMode(C80 + Font8x8)

установит цветной текстовый режим 80x43 для EGA или 80x50 для VGA.
TextMode(Lo(LastMode)) всегда выключает режим 80x(43/50) и сбрасывает режим
дисплея (хотя и оставляет видеорежим неизменным); в то время как

TextMode(Lo(LastMode) + Font8x8)

оставит прежний видеорежим, но переключит дисплей в режим 80x(43/50).

Если ваша система находится в режиме с 43-мя или с 50-ю строками при запуске
программы, то текущий видеорежим будет сохранен инициализационной частью
модуля Crt, и в переменной WindMax будет сохранено максимальное число строк
на экране.

Вот, как корректно написать программу, которая при завершении работы
восстановит видеорежим к его первоначальному состоянию:

Program MyVideo;

Uses Crt;

Var OrigMode : Integer;

Begin
OrigMode:=LastMode; { Запоминаем начальный видеорежим }
. . .
TextMode(OrigMode); { Восстанавливаем его при выходе }
End.

slonpts, выручил, спасибо !


Цитата:

TextMode(С80+Font8x8)

Вот то что мне было нужно!