/ КОМПЬЮТЕРЫ И ПО / Языки программирования / Pascal

Выпуск № 640
от 24.04.2008, 02:35

Вопрос № 132.402

Помогите пожалуйста с решением: Массивы. 1.Определить список участников гонки на собачьих упряжках, при- шедших к финишу последними. Тип данных-запись. 2. Информация о товаре магазина представлена в следующем порядке: наименование товара, количество, цена поступления, цена продажи. Вывести на экран те товары, которые имеют добавочную стоимость больше 5%. Файлы. 3.Файл прямого доступа. Напишите программу, обрабатывающую дан- ные по заказам со склада: магазин-заказчик, номер заказа, элемент за- каза, объем заказа. Данные хранятся в типизированном файле. Преду- смотреть поиск номеров заказов по названию магазина, поиск заказов по элементам. Отсортировать в файле заказы по магазинам, по номерам заказов. Пожалуйста помогите!Заранее спасибо!

Отправлен: 16.04.2008, 13:36 Вопрос задала: Тимощенко Елизавета Владимировна (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Тимощенко Елизавета Владимировна! Первый вопрос Вы уже публиковали и опять не даете достаточно информации. 1.Что из себя представляет список и какие показатели в него входят. Фамилии, имена, номера или названия команд, время и т.д. Я принял в задаче, что в списке указывается фамилия участника и его время. Устанавливается норматив времени и те, кто не уложился в норматив, выводятся на экран. По готовому алгоритму можете добавить еще что-нибудь. Для простоты время принимаем в целых минутах. Ни разу не видел эти гонки, но думаю что норматив надо брать ~30 минут , вряд ли заезды длятся дольше, если много участников. Если Вы уточните условие, переделаем. 2. Сколько последних участников, что их аж целый список? Обычно бывает только один последний, ну в крайнем случае два. По второй задаче информация тоже довольно скудная. Что за товар, продукты, вещи, автомобили или еще что. Принимаю, что это вещи, количество которых измеряется в штуках, цена поступления и продажи в целых рублях. Поэтому для этих данных применяю тип integer. Если все не так, по готовому алгоритму сами подредактируете. Поскольку информация о товаре, который есть в магазине, значит количество наименований известно, можно использовать массив записей с заданным N. Судя по рассылкам, третью задачу вряд ли кто-то будет делать, шибко длинная. Решение первых двух задач в приложении. Приложение: Задача 1. uses crt; type uchastnik=record fam:string[20]; vr:integer; end; var sp:array[1..50]of uchastnik; nr,n,i:integer; begin clrscr; write('Normativ:');readln(nr); write('Kolichestvo uchastnikov='); readln(n); for i:=1 to n do begin writeln('Uchastnik # ',i); write('Familia: ');readln(sp[i].fam); write('Vremia: ');readln(sp[i].vr); end; writeln; writeln('Ne ulogilis v normativ:'); writeln; for i:=1 to n do if sp[i].vr>nr then begin write(sp[i].fam,' ',sp[i].vr); writeln; end; readln end. Задача 2. uses crt; type tovar=record nam:string[20]; kol:integer; cnps:integer; cnpr:integer; end; var sp:array[1..50]of tovar; n,i:integer; begin clrscr; write('Kolichestvo vidov tovara='); readln(n); for i:=1 to n do begin writeln('Tovar # ',i); write('Naimenovanie: ');readln(sp[i].nam); write('Kolichestvo: ');readln(sp[i].kol); write('Cena postuplenia: ');readln(sp[i].cnps); write('Cena prodagi: ');readln(sp[i].cnpr); end; writeln; writeln('Tovary s dobavochnoj stoimostju > 5%:'); writeln; for i:=1 to n do if (sp[i].cnpr-sp[i].cnps)/sp[i].cnpr*100 > 5 then begin write(sp[i].nam,' ',sp[i].kol,' ',sp[i].cnps,' ',sp[i].cnpr); writeln; end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Студент) Ответ отправлен: 16.04.2008, 16:08 Оценка за ответ: 5

Вопрос № 132.413

Здравствуйте уважаемые эксперты!!!Помогите пожалуйста с Турбо Паскалем: тема - определение корня нелинейного уравнения. Мне надо составить программу для нахождения корня уравнения (e^-2x)-2x +1 =0 методом Ньютона : Xn+1 = Xn - F(Xn)/F'(Xn) n - целое число. Провести вычислительный эксперимент. Определить , сколько итераций потребуется для достижения заданной точности E=10^-12. Пожалуйста подскажите как Постоить график зависимости числа итераций N от заданной точности E. По оси абцисс надо принять обратный логарифмический масштаб (-LgE) Спасибо!!!

Отправлен: 16.04.2008, 15:12 Вопрос задал: Хмелев Андрей Борисович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Boriss Здравствуйте, Хмелев Андрей Борисович! Во-первых, решение самой задачи - определение корня уравнения приведено в приложении. Здесь закомментированы 2 строчки, которые нужны при отладке подобных программ В программе рассчитываются все необходимые данные для графика. Только учтите, что в таких расчетах СЛЕДУЕТ использовать переменные с максимально возможным точным представлением в памяти компьютера. В Pascal это Exdended. А построение: очень простой алгоритм Положение точки (абсциссы) на экране = начальное смещение + (размер области отведенной под график)/(размах графика = максимальное + минимальное значения)*(x - x_мимнимальное_значение) При определении ординаты нужно учесть, что нумерация сверху вниз У меня сложилось впечатление, что Вы (и это похвально) сами хотите построить график. Попробуйте. Если не получится - напишите Могу посоветовать построить несколько графиков в зависимости от положения начальной точки x0 - в моих обозначениях Приложение: uses CRT; function func(xx: Extended): Extended; begin func:=exp(-2*xx) - 2*xx + 1 end; function dfunc(xx: Extended): Extended; begin dfunc := -2*exp(-2*xx) - 2 end; CONST eps0 : Real = 0.1; deps = 10; eps_count = 12; x0 :Extended = 3; VAR r, r1: Extended; count: array [1..eps_count] of Integer; i, c: Integer; ln10: Extended; BEGIN ClrScr; ln10 := ln(10); for i:=1 to eps_count do begin r1 := x0; r := r1 - func(r1)/dfunc(r1); c:=1; while abs(r - r1) > eps0 do begin r1 := r; r := r1 - func(r1)/dfunc(r1); { writeLn(c,' ',r,' ',r1);} inc(c); { if KeyPressed then Halt(0);} end; count[i]:=c; WriteLn(r,' ',eps0:8,' ', count[i],' ',-ln(eps0)/ln10:8:0); eps0 := eps0 / deps; end; END. --------- Вывод - то место в тексте, где вы устали думать

Ответ отправил: Boriss (статус: Профессор) Россия, Саранск Организация: Мордовский госуниверситет, Саранск, Факультет Электронной Техники WWW: Программирование на Паскале ---- Ответ отправлен: 16.04.2008, 15:59 Оценка за ответ: 5 Комментарий оценки: Очень признателен. Пока работаю над графиком.

Вопрос № 132.418

здаравчтвуйте! помогите пожалуйстя решить задачу! задача звучит так: определить количество шипящих букв в каждом слове предложения и определить слово в котором шипящих букв больше!

Отправлен: 16.04.2008, 15:34 Вопрос задал: коваль максим владимирович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Boriss Здравствуйте, коваль максим владимирович! Ну вот, решение Вашей задачи (исходный код) можно взять здесь http://rusfaq.ru/upload/504 Я поместил немного описания, если что не понятно будет - пишите Все, что не русские буквы - считается признаком окончания слова и игнорируется --------- Вывод - то место в тексте, где вы устали думать

Ответ отправил: Boriss (статус: Профессор) Россия, Саранск Организация: Мордовский госуниверситет, Саранск, Факультет Электронной Техники WWW: Программирование на Паскале ---- Ответ отправлен: 18.04.2008, 15:21

Вопрос № 132.432

Немогли бы вы мне помочь в составлении задачи? Мне нужно чтобы фигура двигалась...что-то типа птицы или вертолета это уже не так важно. С использованием графического модуля естественно. =)

Отправлен: 16.04.2008, 16:52 Вопрос задала: диана. (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Verena Здравствуйте, диана.! Анимация изображения программируется элементарно. Суть в том, чтобы нарисовать некое изображение какого-нибудь цвета сначала в одном месте (запоминаем все координаты), а потом, через некоторую задержку, на это же место (по сохранённым коорлинатам) рисуем то же самое изображение цвета фона (т.е. стираем предыдущее), и изображение исходного цвета рисуем по некоторому сдвигу координат. Таким образом, оно как бы передвигается по экрану. Нарисовать картинку практически любой сложности можно при помощи графических примитивов (точка, линия, прямоугольник, круг, овал и т.п.), отрисовку которых обеспечивают соответствующие функции Pascal. Вот здесь приведено довольно-таки полное описание процедур графического режима. При использовании этих функции в программе надо не забывать о грамотной инициализации графического режима, выглядеть это должно так: {Инициализируем графический режим} grDriver:= VGA; {Режим} grMode:= VGAHi; {Разрешение 640х480} grPath:= 'c: p7'; {Каталог с файлом драйвера egavga.bgi} InitGraph (grDriver, grMode, grPath); ErrCode:= GraphResult; {Проверяем, успешна ли инициализация} if ErrCode<>grOk then {Если нет - выходим из программы} Begin Writeln ('Ошибка инициализации графического режима'); Halt (1); End; Вот два примера из книжки Культина: двигающийся по экрану кружок (простое изображение) и двигающийся по экрану кораблик (сложное изображение). Ну, ещё для примера приведу программку из одного из моих прошлых ответов: здесь квадратик перемещается по экрану по нажатию стрелок на клавиатуре. Любую из этих программ легко изменить так, чтобы картинка была другой. Удачи! --------- Эта история - не для истории, понимаешь?

Ответ отправила: Verena (статус: Практикант) Ответ отправлен: 17.04.2008, 22:23 Оценка за ответ: 5

Вопрос № 132.435

помогите пожалуйста из данной записи вивести имена и фамилии студентов что достигли на сегоднашний день возраста 18 лет и имеют за результатами сессии не более 2р троек. Зарание спасибо.Запись: program pb71_07_13; uses crt; type student=record N1, N2, N3, City, Ber, Region, Street:string; ddOB, mmOB, yyOB, ind, Block, Room: word; exam: array [1..5] of byte;v:real; show: boolean; end; var stud: array [1..20] of student; i, j, n, perfect: byte;v:real;code:integer; s:array [1..100] of integer; begin clrscr; writeln('LABORATORNA ROBOTA 13'); writeln('ZAPYSY'); writeln('VARIANT 7'); writeln('Petrenko Maxim'); writeln; write('vvedite koli4estvo studentov: '); readln(n); writeln; writeln('Zapus:'); for i:=1 to n do begin writeln('Stydent:'); write (' familiya: '); readln(stud[i].N1); write(' Imya: '); readln(stud[i].N2); write(' ot4estvo: '); readln(stud[i].N3); writeln('Data rojdeniya:'); write(' Den": '); readln(stud[i].ddOB); write(' Mesyac": '); readln(stud[i].mmOB); write(' god: '); readln(stud[i].yyOB); writeln('Adress:'); write(' Index: '); readln(stud[i].ind); write(' oblast": '); readln(stud[i].Region); write(' gorod: '); readln(stud[i].City); write(' Bereg Dnepra: '); readln(stud[i].Ber); write(' ylucya: '); readln(stud[i].Street); write(' dom: '); readln(stud[i].Block); write(' Kvartura: '); readln(stud[i].Room); writeln(' Sessiya:'); for j:=1 to 5 do begin case j of 1: write(' "Informatuka"'); 2: write(' "Mathematuka"'); 3: write(' "fizuka"'); 4: write(' "Materialoznavstvo"'); 5: write(' "Ingenerna grafika"'); end; write(' ocinka: '); readln(stud[i].exam[j]); end; end;

Отправлен: 16.04.2008, 16:53 Вопрос задал: Петренко Максим Васильевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Петренко Максим Васильевич! Доделал Вашу программу. В Вашем тексте почти ничего не менял, только убрал лишние переменные, которые не используются и, главное, для года, месяца и дня сменил тип Word на Integer. Я полдня как дурак тестировал программу, пока дошло, что у Вас тип Word, а я ввел операции вычитания, которые с этим типом не проходят, т.к. в нем нет чисел<0. Сейчас работает нормально. В приложении код полностью. Приложение: program pb71_07_13; uses crt; type student=record N1, N2, N3, City, Ber, Region, Street:string; ddOB, mmOB, yyOB:integer; ind, Block, Room: word; exam: array [1..5] of byte; end; var stud: array [1..20] of student; i, j, n, k: byte; g,m,d:integer; s:array [1..100] of integer; begin clrscr; writeln('LABORATORNA ROBOTA 13'); writeln('ZAPYSY'); writeln('VARIANT 7'); writeln('Petrenko Maxim'); writeln; write('vvedite koli4estvo studentov: '); readln(n); writeln; writeln('Zapus:'); for i:=1 to n do begin writeln('Stydent:'); write (' familiya: '); readln(stud[i].N1); write(' Imya: '); readln(stud[i].N2); write(' ot4estvo: '); readln(stud[i].N3); writeln('Data rojdeniya:'); write(' Den": '); readln(stud[i].ddOB); write(' Mesyac": '); readln(stud[i].mmOB); write(' god: '); readln(stud[i].yyOB); writeln('Adress:'); write(' Index: '); readln(stud[i].ind); write(' oblast": '); readln(stud[i].Region); write(' gorod: '); readln(stud[i].City); write(' Bereg Dnepra: '); readln(stud[i].Ber); write(' ylucya: '); readln(stud[i].Street); write(' dom: '); readln(stud[i].Block); write(' Kvartura: '); readln(stud[i].Room); writeln(' Sessiya:'); for j:=1 to 5 do begin case j of 1: write(' "Informatuka"'); 2: write(' "Mathematuka"'); 3: write(' "fizuka"'); 4: write(' "Materialoznavstvo"'); 5: write(' "Ingenerna grafika"'); end; write(' ocinka: '); readln(stud[i].exam[j]); end; end; {dobavleno} writeln('Tekuschaia data'); write('god=');readln(g); write('mesiac=');readln(m); write('den=');readln(d); for i:=1 to n do begin k:=0; for j:=1 to 5 do if stud[i].exam[j]=3 then begin k:=k+1; end; if (k<=2)and(g-stud[i].yyOB>18) then else if (k<=2)and (g-stud[i].yyOB=18)and(m-stud[i].mmOB>0)then else if(k<=2)and (g-stud[i].yyOB=18)and(m-stud[i].mmOB=0)and (d-stud[i].ddOB>=0) then begin writeln(stud[i].N1,' ',stud[i].N2); end; end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Студент) Ответ отправлен: 17.04.2008, 13:24 Оценка за ответ: 5 Комментарий оценки: ОГРОМНОЕ СПАСИБО!!! Работает отлично=).

Вопрос № 132.440

Здравствуйте! СРОЧНО! помогите решить задачу: надо посчитать кол-во слов, где есть буква а. Заранее спасибо.

Отправлен: 16.04.2008, 17:11 Вопрос задал: SancheZ549 (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Костя Симанович Здравствуйте, SancheZ549! В приложении вариант решения. Проверил как с английской раскладкой так и с русской. Удачи. Приложение: const Alpha : set of char=['A'..'Z','А'..'П','Р'..'Я','a'..'z','а'..'п','р'..'я']; beta : set of char=['A', 'a', 'А','а']; var s,t :string; i, i1 :integer; a, a1 :integer; {кол-во слов} begin writeln('Введите текст'); readln(s); write('Кол-во слов с буквой "а" = '); i:=1; a := 0; Repeat while NOT(s[i] in Alpha) and (i<=length(s)) do inc(i); t:=''; while (s[i] in Alpha) and (i<=length(s)) do begin t:=t+s[i]; inc(i); end; if length(t)<>0 then begin for i1 := 1 to length(t) do begin if (t[i1] in beta) then a1 := 1; end; a := a + a1; a1 := 0; end; Until (i>length(s)); writeln(a); readln; end.

Ответ отправил: Костя Симанович (статус: 3-ий класс) Ответ отправлен: 17.04.2008, 14:02 Оценка за ответ: 5 Комментарий оценки: Спасибо!

Отвечает: Пупорев Юрий Борисович Здравствуйте, SancheZ549! Какое короткое условие, такое короткое решение. Считаем, что есть несколько слов, разделенных пробелами. Выделяем их из строки в массив, где перебираем посимвольно каждое слово, ищем букву 'а'. Как только находим первую а в слове, заканчиваем цикл и переходим к следующему слову. Так перебрав все слова, находим количество слов с буквой а. Код в приложении. Приложение: program q132440; uses crt; var s:string; s1:array[1..50]of string; i,j,k,g:integer; begin clrscr; write('s: ');readln(s); j:=1; for i:=length(s) downto 1 do {по пробелам отделяем слова, копируем их в массив и удаляем из строки} if s[i]=' 'then begin s1[j]:=copy(s,1,(pos(' ',s)-1)); delete(s,1,pos(' ',s)); j:=j+1; end; s1[j]:=s;{последнее слово строки(пробелов больше нет)} g:=0; for i:=1 to j do for k:=1 to length(s1[i]) do if s1[i][k] ='a' then begin g:=g+1;{если в слове есть буква а, прибавляем 1} break; {прерываем цикл} end; writeln('Kolichestvo takih slov=',g); readln; end.

Ответ отправил: Пупорев Юрий Борисович (статус: Студент) Ответ отправлен: 17.04.2008, 14:03 Оценка за ответ: 5 Комментарий оценки: Благодарю!!

Вопрос № 132.462

Уважаемые эксперты, помогите ответить на вопросы: 1.Проверить существование близнецов среди целых чисел от n до 2n, включив spr(k), значение которого является первое простое число, больше данного неотрицательного числа k? 2. Проверить, является ли последовательность полиндромом?

Отправлен: 16.04.2008, 18:21 Вопрос задал: Papan (статус: 1-ый класс) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Костя Симанович Здравствуйте, Papan! По второй задаче для ввода последовательности предлагаю использовать тип string, тогда последовательность может быть не только числовая, но и буквенная. решение в приложении. Удачи. Приложение: program perewertish; var s1, s2 : string; i : integer; begin writeln('введите последовательность.'); readln(s1); s2:= ''; for i:= length(s1) downto 1 do begin s2 := s2 + s1[i]; end; if s1 = s2 then writeln('- перевёртышь.') else writeln('- не перевёртышь.'); readln; end.

Ответ отправил: Костя Симанович (статус: 3-ий класс) Ответ отправлен: 17.04.2008, 13:16

Вопрос № 132.512

Здравствуйте! Такой вопрос: а как в Паскале копировать содержимое одного файла в другой ? Напишите мне пример в виде кода, пожалуйста. И еще один вопрос: дело в том, что у меня по какой-то причине в конце моей программы компьютер требует end;, сколько я этих end; не вписывал, он все равно их требует. В чем причина ? Программа в приложении. ОГРОМНОЕ СПАСИБО ЗА ПОМОЩЬ! Приложение: Program Menu; uses crt; const n=1; i=1; j=1; var f:text; y:integer; type mass= array [1..n] of integer; type mas= array [1..i, 1..j] of integer; procedure vvodfile; var inf:string; begin clrscr; rewrite (f); writeln ('Vvedite informaciyu, kotoruyu neobhodimo vvesti v fail.'); readln (inf); writeln ('Informaciya zapisana v fail.'); writeln (f,inf); close (f); end; procedure dob; var inf1:string; begin clrscr; reset (f); writeln ('Vvedite informaciyu, kotoruyu neobhodimp dobavit v fail.'); readln (inf1); writeln ('Infomaciya dobavlena.'); writeln (f,inf1); close(f); end; procedure massiv (a:mass); var n,sum,i:integer; begin clrscr; reset (f); write ('Vvedite kol-vo el massiva: '); readln (n); sum:=0; for i:=1 to n do begin write ('Vvedite el massiva: '); readln (a[n]); if a[n]<0 then sum:=sum+a[n]; end; writeln ('Summa otrichatelnih el: ',sum); writeln (f,'Summa otrichatelnih el: ',sum); close (f); end; procedure duo (b:mas); var sum1,k,l,i,j:integer; begin clrscr; reset (f); write ('Vvedite kol-vo strok v massive: '); readln (i); write ('Vvedite kol-vo stolbcov v massive: '); readln (j); sum1:=0; for k:=1 to i do begin for l:=1 to j do begin sum1:=sum1+b[i,j]; end; write ('Obchaya summa el massiva: ',sum1); writeln (f,'Obchaya summa el massiva: ',sum1); close (f); end; begin clrscr; assign (f,'1.txt'); writeln ('1 - Dobavit inform v file'); writeln ('2 - '); writeln ('3 - Dobavlenie v file informacii'); writeln ('4 - Rabota s el odnom massiva'); writeln ('5 - Nayti summu el dvum massiva'); writeln ('6 - Perescitat kol-vo simvolov v stroke'); readln (y); case y of 1:begin vvodfile; end; 3:begin dob; end; end.

Отправлен: 16.04.2008, 21:09 Вопрос задал: BOOM (статус: 10-ый класс) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 10)

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, BOOM! В приложении код программы копирующей один файл в другой. 1)Сначачала получаем имена файлов. 2)Открываем копируемый файл для чтения, а тот в который надо копировать создаем или перезаписываем. 3)Проходим весь первый файл с помощью while not eof(f1), при каждом проходе этого цикла сохраняется тек. строка из первого файла в буфер, а потом содержимое буфера записывается в другой файл. 4)Очищаем буфер второго файла(Flush(f2)), чтобы сохранились все изменения 5)Закрываем все файлы. Приложение: {копирование текстовых файлов} uses CRT; var f1Name, f2Name : string; {Имена файлов} f1, f2 : text; {Файловые переменные} tempstr : string; {Временная строка, нужна для коп. файлов} begin clrscr; Write('Имя копируемого файла: '); {Получаем имя копируемого файла} ReadLn(f1Name); Write('В какой файл копировать ', f1Name, '? '); {Файл в который надо копировать первый файл} ReadLn(f2Name); assign(f1, f1Name); {связываем ф.п. с файлом} reset(f1); {Открываем коп. файл для чтения} assign(f2, f2Name); rewrite(f2); {создаем/перезаписываем файл, в который надо копировать первый файл} while not EOF(f1) do {пока не конец файла, повторяем: } begin readln(f1, tempstr); {читаем тек. строку во временную строку} Writeln(f2, tempstr); {записываем строку во второй файл} end; flush(f2); {очищаем буфер второго файла, чтобы быть уверенным, что он сохранится} close(f1); {закрываем файлы} close(f2); writeln('Файл скопирован'); readln; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 8-ой класс) Ответ отправлен: 16.04.2008, 22:40 Оценка за ответ: 5 Комментарий оценки: Огромное спасибо!

Вопрос № 132.513

уважаемые эксперты! Помогите решить задачу. Программа запрашивает имя первого файла(в формате txt), проверяет существует ли он: если существует, то просит ввести имя второго файла(в формате txt) и копирует первый файл во второй.

Отправлен: 16.04.2008, 21:13 Вопрос задала: Missm (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Missm! Код с коментариями в приложении Удачи!!! Приложение: Uses CRT; {Подключаем модуль CRT для того чтобы использовать функцию очистки экрана} var sFirstFileName, sSecondFileName : string; {Строки для хранения имен файлов} TempStr : string; {Временная строка, нужна для копирования файлов} fFileVar, sFileVar : text; {Файловые переменные} begin clrscr; {очищаем экран} Write('Введите имя первого файла: '); ReadLn(sFirstFileName); {Получаем имя первого файла} assign(fFileVar, sFirstFileName); {Связываем ф.п. с файлом} {$I-} {Отключаем контроль ошибок ввода и вывода, если этого не сделать, то отсутствие файла приведет к аварийному завершению программы} reset(fFileVar); {пытаемся открыть первый файл для чтения} {$I+} {Включаем контроль ошибок} if IOResult <> 0 then {IOResult не равен 0, если последняя операция не удачна} writeln('Первого файла нет!!!') {Если файла нет, то выводим сообщение} else begin write('Введите имя второго файла: '); {Иначе запрашиваем имя второго файла} readln(sSecondFileName); assign(sFileVar, sSecondFileName); rewrite(sFileVar); {Открываем второй файл для перезаписи} while not EOF(fFileVar) do {Повторяем пока не конец файла} begin readLn(fFileVar, TempStr); {сохраняем тек. строку в TEMPSTR} WriteLn(sFileVar, TempStr); {записываем TEMPSTR во второй файл} end; flush(sFileVar); {очищаем буфер, чтобы файл точно сохранился} Close(fFileVar); {закрываем файлы} Close(sFileVar); writeln('Первый файл скопирован в ', sSecondFileName); end; readln; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 8-ой класс) Ответ отправлен: 16.04.2008, 22:07 Оценка за ответ: 5 Комментарий оценки: Большое Вам спасибо!

Вопрос № 132.518

Уважаемые експерты помогите написать програму: Дано свободную последовательность слов. Выписать все гласные буквы с непарных слов, и расположыть их в алфавитном порядке

Отправлен: 16.04.2008, 21:36 Вопрос задал: Solovey (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Solovey! В приложении решение Вашей задачи так, как Вы ее объяснили, т.е. выводим гласные буквы из нечетных по порядку слов, сортируем их по алфавиту и выводим на экран. При решении использовал два массива, т.к. решение без массивов получилось длинным и мало понятным. Здесь же четко видна последовательность действий. Приложение: uses crt; const gl=['а','е','ё','и','о','у','ы','э','ю','я']; var s:string; {строка} s1:array[1..50]of string;{массив слов} s2:array[1..100]of char; {массив гласных букв из нечетных слов} ch:char; {буфер при сортировке} i,j,k,n:integer; {различные счетчики} begin clrscr; write('s:');readln(s); {формируем массив слов, используя функцию pos(' ',s)- первое вхождение пробела в строке, последовательно копируя слова в массив и удаляя из строки} j:=1; for i:=length(s)downto 1 do if s[i]=' ' then begin s1[j]:=copy(s,1,pos(' ',s)-1); delete(s,1,pos(' ',s)); j:=j+1; end; s1[j]:=s; {последнее слово, пробелов больше нет} {формируем массив гласных букв из нечетных слов} k:=0; for i:=1 to j do if i mod 2<>0 then begin for n:=1 to length(s1[i]) do if s1[i][n] in gl then begin k:=k+1; s2[k]:=s1[i][n]; end; end; {сортируем его по возрастанию, т.е по алфавиту} for i:=1 to k-1 do for j:=1 to k-1 do if s2[i]>s2[i+1] then begin ch:=s2[j]; s2[j]:=s2[j+1]; s2[j+1]:=ch; end; {выводим на экран} for i:=1 to k do write(s2[i],' '); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Студент) Ответ отправлен: 17.04.2008, 20:13

Вопрос № 132.580

Здравствуйте, уважаемые эксперты! Пожалуйста, подскажите как решить (или в каком направлении двигаться) 2 задачки: 1) Дана последовательность литер, имеющая следующий вид: d1±d2±d3±…±dn (di- цифры) за которой следует точка. Вычислить данное значение. Сложность возникла с +/-. (Нужно использовать условный оператор?) 2) Даны натуральное число n и целые числа а1, а2,..., an. Выяснить, верно ли, что сумма тех ai , которые меньше 20,5, не превышает 50. Непонятно, зачем дано натуральное число. Где в программе оно будет использоваться? Буду очень благодарна за любую помощь.

Отправлен: 17.04.2008, 10:18 Вопрос задала: BlackFlame (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Delph Здравствуйте, BlackFlame! В приложении решение второй из Ваших задач. Число N определяет количество чисел, которые программа запрашивает и обрабатывает. Приложение: Program Pr132580_2; Uses Crt; Var N, a, i, Sum: Integer; Begin ClrScr; Sum := 0; Repeat Write('N = '); ReadLn(N); Until N > 0; WriteLn('Введите ', N, ' целых чисел:'); for i := 1 to N do begin Write('a[', i, '] = '); ReadLn(a); if a <= 20 then Sum := Sum + a; end; WriteLn('Сумма чисел, меньших чем 20.5, равна ', Sum); if Sum < 50 then WriteLn('Это меньше 50') else if Sum = 50 then WriteLn('Это равно 50') else WriteLn('Это больше 50'); ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Студент) Ответ отправлен: 17.04.2008, 11:24 Оценка за ответ: 5 Комментарий оценки: Огромное спасибо!

Отвечает: Пупорев Юрий Борисович Здравствуйте, BlackFlame! Прилагаю решение первой задачи. При тестировании не забавайте, что вводить надо цифры, а не числа вообще, и не забывайте в конце ставить точку. Приложение: uses crt; const cf=['0'..'9']; var s:string; i,sum,t,c:integer; begin clrscr; writeln('Vvedite posledov.cifr razdelennyh znakami + i -,v konce tochka:'); {в одну строку} readln(s); val(s[1],t,c);sum:=t;{первую цифру превращаем в число, это первая сумма} {то же самое делаем с остальными цифрами} for i:=2 to length(s)-1 do begin if (s[i] in cf)and(s[i-1]='+')then begin val(s[i],t,c); sum:=sum+t; {если плюс, прибавляем} end else if (s[i] in cf)and(s[i-1]='-')then begin val(s[i],t,c); sum:=sum-t; {если минус, вычитаем} end; end; writeln('sum=',sum); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Студент) Ответ отправлен: 17.04.2008, 15:02 Оценка за ответ: 5 Комментарий оценки: Благодарю! Красивое решение.

Вопрос № 132.673

Ну, вы уж меня простите, но надо крайняк решить задачу на pascal. При нажатии клавиши F6 блокируется латинский "y". При повторном нажатии блокировка снимается. Выручите, пожалуйста. Заранее спасибо огромное.

Отправлен: 17.04.2008, 17:34 Вопрос задал: Igoreky (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 5)

Отвечает: Зенченко Константин Николаевич Здравствуйте, Igoreky! Код в приложении. Вопросы задавайте в мини-форум. Удачи! Приложение: uses crt; var a,c:char; b:boolean; begin write('Enter:'); b:=true; a:=' '; repeat c:=a; a:=ReadKey; if ord(a)=0 then begin c:=a; a:=ReadKey; if ord(a)=64 then b:=not b end; if(b or(a<>'y'))and(ord(a)>0)and(ord(c)>0)then write(a); until a=chr(13); end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 18.04.2008, 19:11

Вопрос № 132.706

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

Отправлен: 17.04.2008, 19:31 Вопрос задал: Петренко Дмитро (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Denisss Здравствуйте, Петренко Дмитро! В приложении приведен пример (в DOS кодировке, чтобы можно было сохранить через Блокнот). Для того, чтобы программа не выдавала одинаковые буквы, но написанные в разном регистре (строчные/прописные) за разные, каждое слово приводится к нижнему регистру. Конец очередного слова в предложении определяется наличием букв - если букв нет, значит слово закончилось. Это позволяет писать предложение в любой удобной форме: с использованием знаков препинания, чисел, без пробелов перед и/или после знаков препинания и т.д. Удачи! Приложение: program Q132706; uses Crt; function lowerCase(const aChar: Char): Char; {”г­ЄжЁп ЇҐаҐў®¤  бЁ¬ў®«  ў ­Ё¦­Ё© ॣЁбва} const {‹ вЁ­бЄЁҐ бЁ¬ў®«л} EN_UP_CH: set of Char = ['A'..'Z']; {ЏҐаў п Ї®«®ўЁ­  бЁ¬ў®«®ў ЄЁаЁ««Ёжл} RUS_UP_CH_1: set of Char = ['Ђ'..'Џ']; {‚в®а п Ї®«®ўЁ­  бЁ¬ў®«®ў ЄЁаЁ««Ёжл} RUS_UP_CH_2: set of Char = ['ђ'..'џ']; begin if (aChar in EN_UP_CH) then lowerCase:= Char(Ord('a') + Ord(aChar) - Ord('A')) else if (aChar in RUS_UP_CH_1) then lowerCase:= Char(Ord(' ') + Ord(aChar) - Ord('Ђ')) else if (aChar in RUS_UP_CH_2) then lowerCase:= Char(Ord('а') + Ord(aChar) - Ord('ђ')) else if (aChar = 'р') then lowerCase:= 'с' else lowerCase:= aChar; end; procedure showSingleLetters(aWord: String); {Џа®жҐ¤га  ўлў®¤  ®¤Ё­®з­ле бЁ¬ў®«®ў} var t: Char; i, n, c: Byte; seenCh: set of Char; sinCh: array [1..50] of Char; begin {…б«Ё ¤«Ё­  б«®ў  ­г«Ґў п, в® § ўҐаи Ґ¬ Їа®жҐ¤гаг} if (Length(aWord) < 1) then Exit; {€­ЁжЁ «Ё§ жЁп} seenCh:= []; c:= 0; {‚лў®¤Ё¬ б«®ў®} writeln; writeln(aWord, ':'); {ЏҐаҐў®¤Ё¬ б«®ў® ў ­Ё¦­Ё© ॣЁбва} for i:= 1 to Length(aWord) do aWord[i]:= lowerCase(aWord[i]); {€йҐ¬ ®¤Ё­®з­лҐ бЁ¬ў®«л} for i:= Length(aWord) downto 1 do begin {…б«Ё бЁ¬ў®« ­Ґ ®¤Ё­} if (Pos(aWord[i], aWord) <> i) then seenCh:= seenCh + [aWord[i]] else if not (aWord[i] in seenCh) then begin {“ўҐ«ЁзЁў Ґ¬ бзҐвзЁЄ Ё § Ї®¬Ё­ Ґ¬ ®¤Ё­®з­л© бЁ¬ў®«} Inc(c); sinCh[c]:= aWord[i]; end; end; {…б«Ё ®Ў­ а㦥­ е®вм ®¤Ё­ ®¤Ё­®з­л© бЁ¬ў®«} if (c > 0) then begin {‚лў®¤Ё¬ ¬ ббЁў ®¤Ё­®з­ле бЁ¬ў®«®ў} for i:= c downto 2 do write(sinCh[i], ', '); writeln(sinCh[1], ';'); end; end; const {Ќ Ў®а ЎгЄў « вЁ­бЄ®Ј®  «д ўЁв  Ё ЄЁаЁ««Ёжл} LETTERS: set of Char = ['A'..'Z', 'a'..'z', 'Ђ'..'џ', ' '..'Ї', 'а'..'п', 'р', 'с']; var aStr: String; wStart: Byte; i: Byte; begin {ЋзЁбвЄ  нЄа ­ } ClrScr; {‚ў®¤ бва®ЄЁ} writeln('‚ўҐ¤ЁвҐ ЇаҐ¤«®¦Ґ­ЁҐ:'); ReadLn(aStr); {€­ЁжЁ «Ё§ жЁп} wStart:= 1; {ЏҐаҐЎ®а бва®ЄЁ Ї® бЁ¬ў®« ¬} for i:= 1 to Length(aStr) do begin {Џа®ўҐа塞, пў«пҐвбп «Ё ⥪гйЁ© бЁ¬ў®« ЎгЄў®© ЄЁаЁ««Ёжл} if not (aStr[i] in LETTERS) then begin {‚лў®¤Ё¬ ®¤Ё­®з­лҐ ЎгЄўл} showSingleLetters(Copy(aStr, wStart, i - wStart)); {‡ Ї®¬Ё­ Ґ¬ бв ав®ўго Ї®§ЁжЁо ­®ў®Ј® б«®ў } wStart:= Succ(i); end; end; {Ќ  ўбпЄЁ© б«гз © Їа®ўҐа塞 Ї®б«Ґ¤­Ё© бЁ¬ў®« ў ЇаҐ¤«®¦Ґ­ЁЁ} if (aStr[Length(aStr)] in LETTERS) then {‚лў®¤Ё¬ ®¤Ё­®з­лҐ ЎгЄўл ў Ї®б«Ґ¤­Ґ¬ б«®ўҐ} showSingleLetters(Copy(aStr, wStart, Length(aStr))); {Ћ¦Ё¤ ­ЁҐ ­ ¦ вЁп Ї®«м§®ў вҐ«Ґ¬ «оЎ®© Є­®ЇЄЁ} WriteLn; WriteLn('Press any key...'); ReadLn; end. --------- Будь осторожен, когда молишься ради чего-то, потому что можешь это получить...

Ответ отправил: Denisss (статус: Профессионал) Россия, Москва ICQ: 281599577 ---- Ответ отправлен: 21.04.2008, 19:46

Вопрос № 132.728

Здравствуйте Уважаемые! нужно решить две задачи, пожалуйста. 1Составить программу, позволяющую вводить строку символов (не более 80) и подсчитать в ней количество символов заданного вида. Обеспечить возмож-ность неоднократного решения задачи для разных заданных символов без по-вторной загрузки программы. 2Составить программу, которая определяет максимальный элемент двумерного массива и его порядковый номер.

Отправлен: 17.04.2008, 21:19 Вопрос задала: Малинина Алиса (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Малинина Алиса! Обе задачи с комментариями в приложении Удачи!!! Приложение: {№1} var sText : string[80]; {Строка, её максимальный размер - 80} NeedChar, d : Char; {NeedChar - символ, кол-во которого надо подсчитать} i, Count: integer; {i-счетчик для цикла for, count - кол-во символа} begin Write('Введите строку: '); ReadLn(sText); {Получаем строку} Write('Введите символ: '); ReadLn(NeedChar); {Получаем символ} Count:=0; {Обнуляем счетчик} while true do {бесконечный цикл} begin for i:=1 to Length(sText) do {Перебираем строку} if sText[i]=NeedChar then {Если тек. символ равен заданному, то увеличиваем счетчик на 1} inc(Count); WriteLn(Count); {Выводим кол-во символов} Write('Продолжить?(Y/N) '); ReadLn(d); {Узнаем - повторить или нет} if (d='y') or (d='Y') then {если да, то ещё раз запрашивем символ} begin Write('Введите символ: '); ReadLn(NeedChar); Count:=0; end else break; {иначе выходим из цикла} end; readln; end. {№2} const N=5; //Кол-во строк в массиве M=10; //Кол-во столбцов в массиве var a : array [1..N, 1..M] of Integer; //Сам массив i, j, x, y, max:integer; //i, j-счетчики для циклов for, x-номер столбца, y-номер строки, max-максимальный элемент begin randomize; //Заполняем массив случайными числами for i:=1 to N do begin for j:=1 to M do begin a[i, j]:=random(100)-50; write(a[i, j], ' '); //Выписываем через пробнл end; writeln; end; max:=a[1,1]; //Начальные значения max, x , y x:=1; y:=1; for i:=1 to N do //Перебираем массив for j:=1 to m Do if a[i, j]>max then //если тек. эл болше max , то сохраняем его значение и координаты begin x:=j; y:=i; max:=a[i, j]; end; Write('Максимальный элемент: ', max, ' номер: '); {Вывод} if y=1 then write(x) else write(x+m*(y-1)); ReadLn; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 8-ой класс) Ответ отправлен: 17.04.2008, 22:07 Оценка за ответ: 5

Вопрос № 132.777

Доброе время суток...помогите пожалуйста решить задачки по одномерным массивам: 1) Задайте одномерный массив из 10 элементов с помощью датчика случайных чисел. Все положительные элементы замените максимальными. Выведите на печать исходный и полученный массивы. 2) Задайте одномерный массив из 10 элементов с помощью датчика случайных чисел. Поменяйте знаки всем чётным элементам этого массива, а нечётные увеличьте в 10 раз.Распечатайте исходный и полученный массивы. 3) Сформируйте массив, содержащий 20 элементов, с помощью датчика случайных чисел. Получите новый массив, каждый чётный элемент которого равен произведению соответствующего элемента исходного массива и его индекса. 4)Дан одномерный массив из 10 лементов. Найдите разность наибольшего элемента и среднего арифметического этого массива.

Отправлен: 18.04.2008, 06:18 Вопрос задал: Danilka (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: SHERRY Здравствуйте, Danilka! Коды задач в приложении. Разбирайтесь! Приложение: Задача #1 Const N=10; Var ms: array [1..n] of integer; i,max: integer; begin max := -999; randomize; for i:=1 to n do begin ms[i]:=random(20)-10; if ms[i]>max then max := ms[i]; write(ms[i]:5); end; writeln; writeln; for i:=1 to n do begin if ms[i]>0 then ms[i]:=max; write(ms[i]:6); end; end. #2 Const N=10; Var ms: array [1..n] of integer; i: integer; begin randomize; for i:=1 to n do begin ms[i]:=random(20)-10; write(ms[i]:5); if Odd(ms[i]) then ms[i]:= ms[i]*10 else ms[i] := -ms[i]; end; writeln; writeln; for i:=1 to n do write(ms[i]:6); end. #3 Const N=20; Var ms, ms2: array [1..n] of integer; i: integer; begin randomize; for i:=1 to n do begin ms[i]:=random(20)-10; write(ms[i]:5); if not Odd(ms[i]) then ms2[i]:= ms[i]*i else ms2[i] := ms[i]; end; writeln; writeln; for i:=1 to n do write(ms2[i]:6); readln; end. #4 Const N=10; Var ms, ms2: array [1..n] of integer; i,max,sum: integer; begin max:=-999; sum:=0; randomize; for i:=1 to n do begin ms[i] := random(20); write(ms[i]:5); if ms[i] > max then max := ms[i]; sum := sum + ms[i]; end; writeln; writeln; writeln(max - (sum div n)); readln; end. --------- Самурай без меча подобен самураю с мечём, только без меча..

Ответ отправил: SHERRY (статус: Студент) Ответ отправлен: 18.04.2008, 11:46 Оценка за ответ: 5

Вопрос № 132.808

Доброго времени суток, уважаемые эксперты. Являясь экспертом данной рассылки, я вынужден сам просить помощи. Окажите помощь в написании такой функции: функция вернёт палиндром, получающийся из заданной строки наименьшим количеством удалений символов. Буду благодарен любым пояснениям. Приложение: Палиндромом называется строка символов, которая читается слева направо и спаво налево одинаково. Например 'казак'.

Отправлен: 18.04.2008, 11:54 Вопрос задал: SHERRY (статус: Студент) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 4)

Отвечает: Евчик Сергей Александрович Здравствуйте, SHERRY! Могу предложить такой способ решения. Надеюсь я Вам помог. Приложение: Program z1; uses crt; const a=[' ',',','!','?','.']; var s,s1,polin:string; i,j:integer; k:byte; q:boolean; procedure reWriteString (s1:string; var polin:string); var l:integer; begin polin:=''; for l:=ord(s1[0]) downto 1 do polin:=polin+s1[l]; end; function poisk (s:string):byte; begin k:=0; i:=0; j:=1; q:=false; repeat inc(i); if (s[i] in a) then j:=i+1 else begin repeat inc(i); if s[i] in a then q:=false else q:=true; until (q=false) or (i=ord(s[0])+1); s1:=copy(s,j,i-j); dec(i); reWriteString(s1,polin); Writeln(polin); if s1 = polin then inc(k); end; until i=ord(s[0]); poisk:=k; end; begin Write('Введите строку: '); Readln(s); Writeln('Число полиндромов= ',poisk(s)); readln end.

Ответ отправил: Евчик Сергей Александрович (статус: 4-ый класс) Ответ отправлен: 18.04.2008, 13:15

Отвечает: Зенченко Константин Николаевич Здравствуйте, SHERRY! Смотрите приложение. Проверяются все варианты методом перебора. Вопрос можно сформулировать следующим образом: Дана последовательность символов, найти последовательность-полиндром максимальной длины, соблюдая очередность символов в последовательности. Думаю переделать программу в функцию, для Вас не проблема. Удачи! Приложение: var a:string; b,c:array[0..255]of integer; d,e,f:integer; z:boolean; begin write('Enter:'); readln(a); {сбрасываем массивы и максимум} for d:=0 to 255 do b[d]:=0; c:=b; f:=0; repeat {настраиваемся на начало и конец строки} d:=1; e:=length(a); z:=true; {проверяем полиндром} while z and (d<e)do begin {прорускаем икслючаемые символы} while(b[d]>0)and(d<e)do inc(d); while(b[e]>0)and(d<e)do dec(e); z:=z and(a[d]=a[e]); dec(e); inc(d); end; {если полиндром} if z then begin e:=0; {считаем количество символов} for d:=1 to length(a) do e:=e+1-b[d]; {и проверяем максимум} if e>f then begin f:=e; c:=b; end; end; {двоичный счетчик} d:=0; repeat b[d]:=b[d] mod 2; inc(d); inc(b[d]); until (b[d]<2)or(d>length(a)); until d>length(a); {вывод результата} writeln('длина:',f:4); for d:=1 to length(a) do if c[d]=0 then write(a[d]); writeln; end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 18.04.2008, 17:18 Оценка за ответ: 5 Комментарий оценки: Алгоритм переделал в функцию - всё работает. Большое спасибо!

Вопрос № 132.810

Здравствуйте дорогие эксперты, нужна ваша помощь.Нужно составить программу из трех задачь.У самого не получается соеденить задачи в одну программу.Есть одно условие, пользователь сам выберает что он хочет решать.Зарание большое спасибо.Ниже коды задачь. Приложение: 1.Задача. uses crt; var n : longint; function arif(nn : longint) : longint; begin if (nn=0) or (nn=1) then arif :=1 else arif :=arif(nn-1)+2; end; begin clrscr; writeln('vedite n->'); readln(n); writeln('A(',n,')=',arif(n)); readln; end. 2.Задача. uses crt; var n : longint; k : integer; function koren(i : longint) : integer; var s : integer; begin s :=0; repeat s :=s+ n mod 10; n :=n div 10 until n=0; koren :=s end; begin clrscr; writeln('vedite cheloe chislo->'); readln(n); while n>9 do n :=koren(n); writeln('chyfrovoj korenj vvedennovo chisla =', n); readln; end. 3.Задача. uses crt; var a1,a2,a3,a4,x,y : integer; function maximum(a,b : integer) : integer; begin if a>b then maximum :=a else maximum :=b end; begin clrscr; writeln('vedite chetyre chelyx chisla'); readln(a1,a2,a3,a4); writeln('maksimalnoe iz nih',maximum(maximum(a1,a2),maximum(a3,a4)) ); readln; end.

Отправлен: 18.04.2008, 12:17 Вопрос задал: Westside (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Westside! Код с комментариями в приложении. Главное в этой задаче - это оператор Case, с его помощью мы делаем то что захотел пользователь. Использовать этот оператор очень просто: Case ключ_выбора of список_выбора [else операторы] end Этот оператор работает таки образом: 1) Вычисляется значение ключа выбора 2) В списке выбора отыскивется такой оператор, которому предшевствует константа, равная ключу выбора. 3) Найденый оператор выпольнается. 4) Если в списке выбора нет такой константы, то выполняются оператор стоящий за Else. Часть "Else операторы" можно опускать, тогда если в списке выбора нет такой константы, то ничего не произойдет и оператор Case завершит свою работу. Например var ToDo:integer; begin ReadLn(ToDo); Case ToDo of 1 : FirstFunc; 2 : SecondFunc; else : writeLn('Такой команды нет'); end; end. Если пользователь введет 1, то выволнится функция FirsFunc, если 2 - SecondFunc, если ни то и не другое то выведет сообщение. Удачи!!! Приложение: uses CRT; function maximum(a,b : integer) : integer; {Функции из исходных задач} begin if a>b then maximum:=a else maximum:=b; end; function koren(i : longint) : integer; var s : integer; begin s :=0; repeat s :=s+ i mod 10; i :=i div 10 until i=0; koren :=s; end; function arif(nn : longint) : longint; begin if (nn=0) or (nn=1) then arif :=1 else arif:=arif(nn-1)+2; end; var ToDo : byte; {Переменная с помощью которой определяется что хочет пользователь} n : longint; k : integer; a1,a2,a3,a4,x,y : integer; begin ClrScr; WriteLn('Что вы хотите сделать?'); {Спрашиваем-что надо делать} WriteLn('1-Найти числовой корень из числа', #13, #10, {Выводим что можно сделать, #13,#10-переход на новую строку} '2-Найти максимальное число из двух', #13, #10, '3-A(n)'); ReadLn(ToDo); case ToDo of {С помощью оператора Case делаем нужные действия} 1 : begin {Надо найти числовой корень} clrscr; writeln('Введите целое число: '); readln(n); while n>9 do n:=koren(n); writeln('числовой корень введеного числа = ', n); readln; end; 2 : begin {Максимальное из 4 чисел} clrscr; writeln('Введите четыре целых числа: '); readln(a1,a2,a3,a4); writeln('Максимальное из них: ', maximum(maximum(a1,a2),maximum(a3,a4))); readln; end; 3 : begin {Находим A(n), похоже это арифметическая прогрессия где a1=1, d=2} clrscr; writeln('Введите n: '); readln(n); writeln('A(',n,') = ',arif(n)); readln; end; end; {Конец оператора Case} end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 8-ой класс) Ответ отправлен: 18.04.2008, 13:42 Оценка за ответ: 5 Комментарий оценки: Большое спасибо.Вы мне очень помогли.

Вопрос № 132.826

Задание такое: В двумерном массиве определить столбец(столбцы), содержащие наибольшее значение. Программа готова, вот только одна проблема: КАК ИЗМЕНИТЬ ПОСЛЕДНЮЮ ЧАСТЬ ПРОГРАММЫ (ГДЕ ОНА ДОЛЖНА ВЫВЕСТИ НОМЕРА СТОЛБЦОВ), ВСТАВИВ ТУДА ПЕРЕМЕННУЮ "К", А ТАКЖЕ СКОБКИ "bEGIN" И "END", ТАК ЧТОБЫ ПРОГРАММА ВЫВОДИЛА ВСЕ СТОЛБЦЫ, ГДЕ ЕСТЬ НАИБОЛЬШЕЕ ЗНАЧЕНИЕ И НЕ ВЫВОДИЛА ДВАЖДЫ СТОЛБЕЦ, ГДЕ НАИБОЛЬШЕЕ ЗНАЧЕНИЕ ПОВТОРЯЕТСЯ НЕСКОЛЬКО РАЗ????????????????????????????????????????? Еще желательно, чтобы вначале ввод матрицы был с использованием подпрограмм. Приложение: Program t; Uses crt; Var a:array[1..100, 1..100]of integer; m,n,i,j,max,k:integer; Begin Clrscr; Writeln('Vvedite n'); Readln(n); Writeln('Vvedite m'); Readln(m); max:=a[1,1]; Writeln('Vvedite massiv'); For i:=1 to n do For j:=1 to m do Readln(a[i,j]); Writeln('Vvedennii massiv'); For i:=1 to n do begin for j:=1 to m do Write(a[i,j]:4); Writeln; end; For j:=1 to m do for i:=1 to n do if a[i,j]>max then max:=a[i,j]; Writeln('max=',max); Writeln('Stolbtsi sodershachie max:'); For j:=1 to m do for i:=1 to n do if a[i,j]=max then Writeln(j); Readln; End.

Отправлен: 18.04.2008, 14:11 Вопрос задала: Водянникова Екатерина Валерьевна (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Зенченко Константин Николаевич Здравствуйте, Водянникова Екатерина Валерьевна! Смотрите приложение. Ввод и вывод с помощью процедур. Удачи! Приложение: Program t; Uses crt; Type Ta= array[1..100, 1..100]of integer; Var a:Ta; m,n,i,j,max,k:integer; procedure InMass(var b:Ta); begin Writeln('Vvedite massiv'); For i:=1 to n do For j:=1 to m do Readln(b[i,j]); end; procedure OutMass(var b:Ta); begin Writeln('Vvedennii massiv'); For i:=1 to n do begin for j:=1 to m do Write(b[i,j]:4); Writeln; end; end; Begin Clrscr; Writeln('Vvedite n'); Readln(n); Writeln('Vvedite m'); Readln(m); InMass(a); readln; OutMass(a); max:=a[1,1]; For j:=1 to m do for i:=1 to n do if a[i,j]>max then max:=a[i,j]; Writeln('max=',max); Writeln('Stolbtsi sodershachie max:'); For j:=1 to m do begin k:=0; for i:=1 to n do if a[i,j]=max then inc(k); if k>0 then Writeln(j); end; Readln; End. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 18.04.2008, 14:40 Оценка за ответ: 5 Комментарий оценки: Большое Вам спасибо!!!

Вопрос № 132.853

Уважаемые эксперты!помогите пожалуйста решить задачу! Выполнить обработку элементов прямоугольной матрицы А, имеющей N строк и M столбцов.Просуммировать элементы каждой строки с элементами L-той строки. Очень надо...заранее спасибо...

Отправлен: 18.04.2008, 17:22 Вопрос задал: Igor lukashov (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Igor lukashov! Решение вашей задачи в приложении. Решение очень простое, даже нечего комментировать. Создаете матрицу, а затем ко всем элtментам каждой строки прибавляете соответствующие элементы заданной строки. На всякий случай сделал вариант, если элементы заданной строки не надо прибавлять к самой строке. Этот код закомментирован(заключен в фигурные скобки). Если не нужен, удалите, если нужен, закомментируйте второй цикл, а эти два цикла откройте. Удачи! Приложение: uses crt; var a:array[1..20,1..20]of integer; L,n,m,i,j:integer; begin clrscr; randomize; write('n=');readln(n); write('m=');readln(m); write('1<=L<=n =');readln(L); writeln('Ishodnaia matrica:'); for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(10); write(a[i,j]:3); end; writeln; end; Writeln('Rezultat:'); {stroku L pribavit ko vsem} for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=a[i,j]+a[L,j]; write(a[i,j]:4); end; writeln; end; {stroku L pribavit ko vsem, krome sebia} {for i:=1 to n do if i<>L then begin for j:=1 to m do begin a[i,j]:=a[i,j]+a[L,j]; end; end; for i:=1 to n do begin for j:=1 to m do write(a[i,j]:4); writeln; end;} readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Студент) Ответ отправлен: 19.04.2008, 07:21 Оценка за ответ: 5 Комментарий оценки: Спасибо огромное!Все замечательно работает!Очень вам благодарен!

Вопрос № 132.874

Здравствуйте мне нужно нарисовать произвольный рисунок в Турбо Паскале...мне нужно очень срочно...желательно сегодня...Пожалуста выполните мою прозьбу!!! Очень надо!!!!Заранее большое спасибо!!!

Отправлен: 18.04.2008, 20:22 Вопрос задала: Garagulya Evgeniya (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Verena Здравствуйте, Garagulya Evgeniya! Нарисовать изображение любой сложности можно с помощью графических примитивов (точка, линия, кружок и т.п.). Графический модуль Паскаля предоставляет функционал для их отрисовки - довольно большой набор процедур, отрисовывающих графические примитивы по координатам (описание этих функций есть здесь). Координаты экрана в графическом режиме варьируются от точки (0, 0) до точки (639, 479). Для использования графического режима необходимо произвести его инициализацию функцией InitGraph (режим, разрешение, путь_к_драйверу). Чтобы нарисовать сложное изображение, можно для упрощения нарисовать его на листке бумаги и рассчитать все координаты, прикинуть, какие примитивы можно использовать. В приложении - пример, который выводит на экран кораблик. Удачи! Приложение: program titanik; uses Graph, Crt; var grDriver:integer; { драйвер} grMode:integer; { графический режим } grPath:string; { место расположения драйвера } ErrCode:integer; { результат инициализации графического режима } x,y:integer; { координаты кораблика} color:word; { цвет кораблика} bkcolor:word; { цвет фона } { процедура вывода картинки } Procedure Titan(x,y:integer; { координаты базовой точки} color:word); { цвет корабля (линий)} const dx=5; dy=5; var OldColor:word; begin OldColor:=GetColor; { сохранить текущий цвет } SetColor(color); { установить заданный цвет} { корпус } MoveTo(x,y); LineTo(x,y-2*dy); LineTo(x+10*dx,y-2*dy); LineTo(x+11*dx,y-3*dy); LineTo(x+17*dx,y-3*dy); LineTo(x+14*dx,y); LineTo(x,y); { надстройка  } MoveTo(x+3*dx,y-2*dy); LineTo(x+4*dx,y-3*dy); LineTo(x+4*dx,y-4*dy); LineTo(x+13*dx,y-4*dy); LineTo(x+13*dx,y-3*dy); Line(x+5*dx,y-3*dy,x+9*dx,y-3*dy); { капитанский мостик } Rectangle(x+8*dx,y-4*dy,x+11*dx,y-5*dy); { труба } Rectangle(x+7*dx,y-4*dy,x+8*dx,y-7*dy); { иллюминаторы } Circle(x+12*dx,y-2*dy,Trunc(dx/2)); Circle(x+14*dx,y-2*dy,Trunc(dx/2)); { мачта} Line(x+10*dx,y-5*dy,x+10*dx,y-10*dy); { оснастка  } MoveTo(x+17*dx,y-3*dy); LineTo(x+10*dx,y-10*dy); LineTo(x,y-2*dy); SetColor(OldColor); { восстановить начальный текущий цвет } end; begin grDriver := VGA; { режим VGA} grMode:=VGAHi; { разрешение 640е480} grPath:='c: p7'; { путь к файлу драйвера на Вашем компьютере (egavga.bgi)} InitGraph(grDriver, grMode,grPath); {Инициализация графического режима} ErrCode := GraphResult; {Проверяем, удачна ли инициализация} if ErrCode <> grOk then Halt(1); x:=10; y:=200; color:=LightGray; SetBkColor(Blue); Titan(x,y,color); { вывод кораблика на экран} readln; CloseGraph; end. --------- Эта история - не для истории, понимаешь?

Ответ отправила: Verena (статус: Практикант) Ответ отправлен: 18.04.2008, 21:42 Оценка за ответ: 4

Вопрос № 132.893

Здравствуйте, дорогие эсперты! Помогите,пожайлуста, решить две задачи по теме "Двумерные массивы": 1. Составьте программу нахождения номера строки матрицы А(N,M), для которой среднее арифметическое значение её элементов максимально. 2. Составьте программу вычисления суммы тех отрицательных элементов массива А(n), что стоят в строках, не содержащих нулевых элементов. Зарание, спасибо!

Отправлен: 18.04.2008, 22:14 Вопрос задал: Марков Василий Геннадьевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Марков Василий Геннадьевич! Решение первой и второй задач с пояснениями в приложении. В первой задаче по уму и не надо считать среднее арифметическое, достаточно суммы в строке, а чем больше сумма, тем больше среднее арифметическое. Но…раз надо, значит надо. Приложение: Задача 1. program Sr_ar_str; uses crt; const n=5; m=7; var a:array[1..n,1..m] of integer; sar,max:real; i,j,k,imax:integer; begin clrscr; randomize; writeln('Matrica:'); {присваиваем max наименьшее значение, № строки=1.} max:=0;imax:=1; for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(10);{присваиваем значения элементам матрицы} sar:=sar+a[i,j];{считаем сумму элементов по строкам} write(a[i,j]:3);{выводим на экран} end; sar:=sar/m;{вычисляем среднее арифметическое} if sar> max then begin max:=sar; imax:=i; {определяем № строки} end; writeln; end; writeln('Nomer stroki s max sr_ar=',imax); readln end. Задача 2. program Sum_otr; uses crt; const n=4; m=5; var a:array[1..n,1..m] of integer; i,j,k,sum1,sum,p:integer; begin clrscr; randomize; writeln('Matrica:'); for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(10)-4; write(a[i,j]:4); end; writeln; end; sum:=0; for i:=1 to n do begin k:=0;sum1:=0; for j:=1 to m do if a[i,j]=0 then begin k:=k+1; {считаем количество нолей в строке} end; writeln('k',i,'=',k); if k=0 then {если нолей нет} begin for p:=1 to m do if a[i,p]<0 then {считаем сумму отрицательных в строке} begin sum1:=sum1+a[i,p]; end; end; sum:=sum+sum1; {считаем сумму по всем таким строкам} end; writeln('Summa=',sum); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Студент) Ответ отправлен: 19.04.2008, 12:00 Оценка за ответ: 5 Комментарий оценки: Спасибо,Юрий Борисович,огромное!!! Еще не проверил,но надеюсь, что правильно.

© 2001-2008, Портал RusFAQ.ru, Россия, Москва. Авторское право: ООО "Мастер-Эксперт Про" Техподдержка портала, тел.: +7 (926) 535-23-31 Хостинг: "Московский хостер" Поддержка: "Московский дизайнер" Авторские права | Реклама на портале ∙ Версия системы: 4.91 pre 5.0 RC1 от 13.04.2008
RusFAQ.ru | MosHoster.ru | MosDesigner.ru | RusIRC.ru Kalashnikoff.ru | RadioLeader.ru | RusFUCK.ru