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

Выпуск № 647
от 20.05.2008, 05:05

Вопрос № 135.248

Здравствуйте! Нужна помощь в решении задачи: Дан массив целых чисел, содержащий 15 элементов. Записать в этом же массиве сначала все кратные трем числа, а затем все остальные, сохраняя порядок их следования. Решить задачу нужно самым простым способом, используя 2-3 подпрограммы. Заранее спасибо.

Отправлен: 04.05.2008, 07:18 Вопрос задала: Десятова Ксения Сергеевна (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Delph Здравствуйте, Десятова Ксения Сергеевна! Проще всего (с точки зрения логики алгоритма) было бы воспользоваться двумя вспомогательными массивами, но красивее обойтись только основным. Программа в приложении. Первая процедура заполняет массив случайными числами; вторая проводит указанную Вами сортировку. На основную программу остаются лишь очистка экрана, вызов подпрограмм и ожидание, когда пользователь посмотрит результаты и нажмёт клавишу Enter. Приложение: Program Pr135248; Uses CRT; Const N = 15; Var Arr: Array[1..N] of Integer; procedure ArrInput; var i: Integer; begin Randomize; WriteLn('Исходный случайно заполненный массив:'); for i := 1 to N do begin Arr[i] := Random(100); { случайные числа от 0 до 99 } Write(Arr[i]:4); end; WriteLn; WriteLn; end; procedure ArrSorted; var Last, tmp, i, j: Integer; begin Last := 0; for i := 1 to N do if Arr[i] mod 3 = 0 then begin inc(Last); tmp := Arr[i]; for j := i downto Last + 1 do Arr[j] := Arr[j - 1]; Arr[Last] := tmp; end; WriteLn('Массив после обработки:'); for i := 1 to N do Write(Arr[i]:4); WriteLn; end; Var i: Integer; Begin ClrScr; ArrInput; ArrSorted; ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 04.05.2008, 08:15 Оценка за ответ: 5

Отвечает: Попов Владимир Иванович Здравствуйте, Десятова Ксения Сергеевна! Программка в приложении. Работает. Желаю успеха. Приложение: program massiv; uses crt; const N=15; type Tmassiv=array[1..N] of integer; procedure rand(var px:Tmassiv); var i:byte; begin randomize; for i:=1 to N do px[i]:=random(100); end; procedure output(mes:string;var px:Tmassiv); var i:byte; begin writeln; writeln(mes); writeln; write(' { '); for i:=1 to N do write(px[i],' '); writeln('}'); writeln; end; procedure sort(var px:Tmassiv; var py:Tmassiv); var i,j:byte; begin j:=1; for i:=1 to N do if (px[i] mod 3)=0 then begin py[j]:=px[i]; j:=j+1; end; for i:=1 to N do if (px[i] mod 3)<>0 then begin py[j]:=px[i]; j:=j+1; end; end; function quit:boolean; var ans:char; begin writeln; writeln; write(' Again ? (y/n) ---> '); readln(ans); if ans='n' then quit:=true else quit:=false; end; var x,y:Tmassiv; begin repeat clrscr; rand(x); output(' The initial array is :',x); sort(x,y); output(' The resorted array is :',y); writeln; writeln(' The program is completed !'); until quit; end. --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 6-ой класс) Ответ отправлен: 09.05.2008, 01:29

Вопрос № 135.274

1. С помощью операторов цикла напишите программу фильтр, которая выводит любые символы, но комментирует только буквы русского алфавита. завершение программы по нажатию буквы "я". 2.Найти максимум из 5 чисел. в подпрограмме реализовать выбор max из двух чисел.

Отправлен: 04.05.2008, 11:46 Вопрос задала: lyalya (статус: 5-ый класс) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, lyalya! Поскольку в первой задаче непонятно, что такое "комментирует", в программе два варианта, один закомментирован. Выберите который лучше или сделайте свой. Вторая задача настолько простая, что не требует пояснений. Решение в приложении. Приложение: Задача 1. uses crt; const mn=['А'..'п','р'..'ё']; var c:char; begin clrscr; repeat c:=readkey; if c in mn then {write(' bykva ',c) можно так} write('{',c,'}') {можно как комментарий в Паскале} else write(c); readln; until c='п'; end. Задача 2. uses crt; var a,b,c,d,e:real; function Max(f,g:real):real; begin if f>g then Max:=f else Max:=g; end; begin clrscr; Write('a=');readln(a); Write('b=');readln(b); Write('c=');readln(c); Write('d=');readln(d); Write('e=');readln(e); write('Maximalnoe iz 5 chisel=',Max(Max(Max(a,b),Max(c,d)),e):6:2); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 05.05.2008, 19:00

Вопрос № 135.284

Здравствуйте, уважаемые эксперты помогите, пожалуйста: 1) В одномерном массиве все отрицательные элементы переместить в начало массива, а остальные - в конец с сохранением порядка следования. Дополнительный массив заводить не разрешается. 2)В одномерном массиве с четным количеством элементов (2N) находятся координаты N точек плоскости. она располагаются в следующем порядке : х1,у1,х2,у2,х3,у3..,хn.yn. Опредилить минимальный радиус круга с центром в начале координат, который содержит все точки.

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

Отвечает: Delph Здравствуйте, Иванова Екатерина Сергеевна! В приложении решение первой из Ваших задач. Надеюсь, использовать подпрограммы Вам не запрещали. Приложение: Program Pr135284; Uses CRT; Const N = 15; Var Arr: Array[1..N] of Integer; procedure ArrInput; var i: Integer; begin Randomize; WriteLn('Исходный случайно заполненный массив:'); for i := 1 to N do begin Arr[i] := Random(101) - 50; { случайные числа от -50 до +50 } Write(Arr[i]:4); end; WriteLn; WriteLn; end; procedure ArrMoved; var Last, tmp, i, j: Integer; begin Last := 0; for i := 1 to N do if Arr[i] < 0 then begin inc(Last); tmp := Arr[i]; for j := i downto Last + 1 do Arr[j] := Arr[j - 1]; Arr[Last] := tmp; end; WriteLn('Массив после обработки:'); for i := 1 to N do Write(Arr[i]:4); WriteLn; end; Var i: Integer; Begin ClrScr; ArrInput; ArrMoved; ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 04.05.2008, 14:56 Оценка за ответ: 5

Отвечает: Пупорев Юрий Борисович Здравствуйте, Иванова Екатерина Сергеевна! Радиус окружности, на которой находится точка относительно начала координат, определяется по формуле Rad:=sqrt(sqr(x)+sqr(y)); Наименьшим радиусом будет радиус самой удаленной точки, т.е. max. Берем за максимум радиус первой окружности, затем в цикле увеличивая счетчик i на 2, находим самый максимум. Код в приложении. Приложение: Задача 2. uses crt; const n=10; var a:array[1..n]of real; i:integer; max:real; function Rad(f,g:real):real; begin Rad:=sqrt(sqr(f)+sqr(g)); end; begin clrscr; writeln('Ishodny massiv:'); for i:=1 to n do begin a[i]:=random(21)+random-10; write(a[i]:6:2); end; writeln; readln; max:=Rad(a[1],a[2]);i:=3; while i<=n do begin if Rad(a[i],a[i+1])>max then max:=Rad(a[i],a[i+1]); i:=i+2; end; writeln('Minimalny radius=',max:6:2); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 05.05.2008, 20:40

Отвечает: Попов Владимир Иванович Здравствуйте, Иванова Екатерина Сергеевна! Ваша программа - в приложении. Протестирована. Успешно работает. Удачи. Приложение: program massiv; uses crt; const N=15; type Tmassiv=array[1..N] of integer; procedure rand(var px:Tmassiv); var i:byte; begin randomize; for i:=1 to N do px[i]:=random(100); end; procedure output(mes:string;var px:Tmassiv); var i:byte; begin writeln; writeln(mes); writeln; write(' { '); for i:=1 to N do write(px[i],' '); writeln('}'); writeln; end; procedure sort(var px:Tmassiv; var py:Tmassiv); var i,j:byte; begin j:=1; for i:=1 to N do if (px[i] mod 3)=0 then begin py[j]:=px[i]; j:=j+1; end; for i:=1 to N do if (px[i] mod 3)<>0 then begin py[j]:=px[i]; j:=j+1; end; end; function quit:boolean; var ans:char; begin writeln; writeln; write(' Again ? (y/n) ---> '); readln(ans); if ans='n' then quit:=true else quit:=false; end; var x,y:Tmassiv; begin repeat clrscr; rand(x); output(' The initial array is :',x); sort(x,y); output(' The resorted array is :',y); writeln; writeln(' The program is completed !'); until quit; end. --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 6-ой класс) Ответ отправлен: 09.05.2008, 12:56

Вопрос № 135.301

Уважаемы эксперты, у меня во не получается решить эту задачку. Помогите пожалуйста. Переписать элементы матрицы А в матрицу В, исключая из нее все повторяющиеся элементы, заменяя их 0. Заранее спасибо

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

Отвечает: SHERRY Здравствуйте, Кочкарев Владислав Геннадьевич! Вот код Вашей задачки. const n = 5; {указываем, что в массиве будет 5 элементов} a: array [1..n] of byte = (1, 3, 4, 1, 3); {прописываем элементы массива. Элемент массива не превышает число 255} var mn: set of byte; {множество используем, чтобы контролировать повторяющиеся элементы} i: integer; {переменная-счётчик} b: array [1..n] of byte; {результирующий массив} begin mn := []; {инициализируем множество} for i:=1 to n do {задаём цикл} if not (a[i] in mn) then {если элемент исходного массива не в множестве} begin mn := mn + [a[i]]; {тогда помещаем его в множество} b[i]:=a[i]; {и записываем в результирующий массив} end else b[i]:=0; {если же элемент уже есть в множестве (повторился), то записываем нуль} end. Разбирайтесь! --------- Самурай без меча подобен самураю с мечём, только без меча..

Ответ отправил: SHERRY (статус: 9-ый класс) Ответ отправлен: 04.05.2008, 17:35 Оценка за ответ: 4 Комментарий оценки: Спасибо, особенно за пояснения. Ваш ответ существенно обоготил мои знания.

Вопрос № 135.307

здраствуйте уважаемые эксперты!!! чочу попросить вас об одолжении: помогите пожалуйста мне со следующими задачами. !)Описать процедуру, которая вставляет в список L новый элемент E1 перед первым вхождением элемента E, если E входит в L, иначе удаляет элементы, большие Е. "!)Организовать текстовый файл состоящий из N строк. Заменить в нем одну из строк новой строкой. Номер заменяемой строки и содержимое новой строки запрашивается и вводится с клавиатуры. ПОЖАЛУЙСТА!!!не оставляйте мою просьбу без внимания!!! я вас ОЧЕНЬ прошу:))))))))))))))))

Отправлен: 04.05.2008, 16:57 Вопрос задала: Mor Dina Sergeevna (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Mor Dina Sergeevna! Решение второй задачи в приложении. Следует сначала в блокноте создать файл из нескольких строк, дать ему имя и сохранить, лучше в одной папке с программой. Приложение: uses crt; var f:text; {текстовый файл} n,k,i:integer; s:array[1..100]of string; {массив строк} s1:string; {вводимая строка} begin clrscr; Write ('Vvedite # stroki: ');readln(k); write('Vvedite stroku: ');readln(s1); assign(f,'text_1.txt'); {связываем наш файл с переменной f} reset(f); {открываем файл для чтения} n:=1; while not eof(f)do begin readln(f,s[n]); {считываем строки из файла в массив} n:=n+1; {считаеи строки} end; close(f); {закрываем файл} s[k]:=s1; {переименовываем строку} rewrite(f); {открываем файл для записи} for i:=1 to n do writeln(f,s[i]); {записываем в файл измененный текст} writeln('Fail perezapisan!'); readln; close(f); {закрываем файл} end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 06.05.2008, 07:42

Вопрос № 135.317

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

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

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Chistiak81! Задачи 1, 2, 3, 5 в приложении. Удачи!!! Приложение: {№1} const {Длина массива} n=10; var {массив A} a: array [1..N] of integer; {i-счетчик для цикла For, sum-сумма элементов больших или равных 10} i, sum: integer; begin {Обнуляем сумму, если этого не сделать, переменная будет содержать мусор и программа выдаст неверный резльтат} Sum:=0; {Инициализируем генератор случайных чисел} randomize; WriteLn('Исходный массив: '); {Перебираем весь массив} for i:=1 to N do begin {тек. элю приравнивается к случайному числу из диапозона [-20; 29]} a[i]:=random(50)-20; {Если эл. >= 10, то прибавляем его к сумме} if a[i] >= 10 then inc(sum, a[i]); Write(a[i], ' '); end; {Вывод рез-тов, #13, #10 - переход на новую строку} WriteLn(#13, #10, 'Сумма = ', sum); {ждем нажатия клавиши} readln; end. {№2} const {Кол-во строк в массиве} N=5; {Кол-во столбцов} M=10; var {Двумерный массив} a: Array [1..N, 1..M] of integer; {i, j-для цикла for, sum-сумма строки} i, j, sum: integer; begin {Заполняем массив случайными числами} randomize; for i:=1 to N do begin {Перед начало заполнения очередной строки обнуляем сумму} sum:=0; for j:=1 to M do begin a[i, j]:=random(50)-25; Write(a[i, j]:4); {В цикле заполнения строки, прибавляем к сумме только что созданный элемент} inc(sum, a[i, j]); end; {После вывода каждой строки, выводим её сумму} WriteLn('. Сумма элементов строки = ', sum); end; readln; end. {№3} var Str: string; i: integer; begin Write('Введите строку: '); ReadLn(Str); For i:=1 to Length(str) do if str[i] = 'а' then str[i]:=' '; Write('Рез-тат: ', str); Readln; end. {№5} Uses {Чтобы пожно было рисовать, подключаем модуль Graph} Graph; var {Driver-имя драивера, Mode-режим гр. адаптера} Driver, Mode: integer; {Здесь сохраняем код ошибки} ErrorCode: Integer; begin {Драйвер-vga} Driver:=VGA; {Самый лучший режим, поддерживаемый VGA} Mode:=VGAHi; {Инициируем графический режим, в третьем парамтре вместо c:BP - путь к папке где у Вас установлен TP7, BGI-папка с драйверами} InitGraph(Driver, Mode, 'c:BPBGI'); {Получаем результат последнего действия} ErrorCode:=GraphResult; {Если он <> 0, значит случиласи ошибка, и выводим сообщение об ошибке} If ErrorCode <> 0 Then WriteLn(GraphErrorMsg(ErrorCode)) else begin {Иначе-устанавливаем цвет на красный} SetColor(yellow); {Рисуем многоугольник с координатами 0,0,ширина экрана / 2, высота / 2} Rectangle(0,0, GetMaxX div 2, GetMaxY div 2); {ждем нажатия на любую клавишу} readln; {Выходим из графического режима} CloseGraph; end; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: Студент) Ответ отправлен: 04.05.2008, 18:53 Оценка за ответ: 5

Вопрос № 135.323

Здравствуйте эксперты!Помогите пожалуйста решить задачи по паскалю!Заранее спасибо! Задача 1. Одномерные массивы Дан массив размера N. Утроить в нем вхождения всех элементов с нечетными номерами (1,3,...). Условный оператор не использовать. Задача 2. Строковый тип данных Дана строка, изображающая арифметическое выражение вида «<цифра>±<цифра>±...±<цифра>», где на месте знака операции «±» находится символ «+» или «-»(например,«4+7_2_8»). Вывести значение данного выражения (целое число). Задача 3. Двоичные файлы Дан файл вещественных чисел, содержащий ненулевую часть верхнетреугольной матрицы (по строкам). Создать новый файл, содержащий все элементы данной матрицы (по строкам).Запрещается использовать вспомогательные массивы. Задача 4. Текстовые файлы Дан текстовый файл, содержащий текст, выровненный по левому краю. Абзацы текста разделяются одной пустой строкой. Выровнять текст по ширине (то есть и по левому, и по правому краю), увеличив в каждой непустой строке (кроме последних строк абзацев) количество пробелов между словами, начиная с последнего пробела в строке(ширину текста считать равной 50). Задача 5. Описать процедуру SortDec3(A,B,C), меняющую содержимое переменных А,В,С таким образом, чтобы их значения оказались упорядоченными по убыванию (А,В,С-вещественные параметры, являющиеся одновременно входными и выходными). С помощью этой процедуры упорядочить по убыванию два данных набора из трех чисел:(А1,В1,С1) и (А2,В2,С2). Задача 6. Описать функцию CircleS(R) вещественного типа, находящую площадь круга радиуса R (R-вещественное). С помощью этой функции найти площади трех кругов с данными радиусами. Площадь круга радиуса R вычмсляется по формуле S=П*R². В качестве значения П использовать 3.14.

Отправлен: 04.05.2008, 18:52 Вопрос задал: Сухарев Дмитрий Владимирович (статус: Посетитель) Всего ответов: 3 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Сухарев Дмитрий Владимирович! Задача 6 в приложении Удачи!!! Приложение: var {радиус} r: real; {счетчик для For} i: integer; {Функция для вычисления площади круга} function CircleS(r: real): real; begin {результат функции:=3,14*r*r} CircleS:=3.14*r*r; end; begin {Получан 3 радиуса и вычисляем площадь} for i:=0 to 2 do begin {получаем радиус} Write('Введите радиус: '); ReadLn(r); {Выводим рез-тат} WriteLn('Площадь круга с радиусом ', r:0:4, ' = ', CircleS(r):0:4); end; ReadLn; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: Студент) Ответ отправлен: 04.05.2008, 19:09 Оценка за ответ: 5 Комментарий оценки: спасибо!

Отвечает: Delph Здравствуйте, Сухарев Дмитрий Владимирович! Задача 5 в приложении. Приложение: Program Pr135323_5; Uses CRT; Const N = 2; procedure SortDec3(var a, b, c: Real); var x: Real; begin if b > a then begin x := b; b := a; a := x; end; if c > a then begin x := c; c := a; a := x; end; if c > b then begin x := c; c := b; b := x; end; end; Var a, b, c: Real; i: integer; Begin ClrScr; WriteLn('Сортировка по убыванию ', N, ' троек чисел.'); WriteLn; for i := 1 to N do begin WriteLn('Тройка чисел #', i); Write('a = '); ReadLn(a); Write('b = '); ReadLn(b); Write('c = '); ReadLn(c); SortDec3(a, b, c); WriteLn('Результат сортировки:'); WriteLn(a, '; ', b, '; ', c); WriteLn; end; ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 05.05.2008, 07:57 Оценка за ответ: 5 Комментарий оценки: спасибо!

Отвечает: Пупорев Юрий Борисович Здравствуйте, Сухарев Дмитрий Владимирович! Задачи 1 и 2 в приложении. Задачи легкие поэтому без пояснений. О функциях и процедерах, которые используются, прочитаете в справке или в учебнике. Приложение: Задача 1. uses crt; var a:array[1..20] of integer; n,i:integer; begin clrscr; write('n=');readln(n); for i:=1 to n do begin a[i]:=random(10)+1; write(a[i],' '); end; i:=1; while i<=n do begin a[i]:=3*a[i]; i:=i+2; end; writeln; for i:=1 to n do write(a[i],' '); readln end. Задача 2. uses crt; var s,s1:string; i,t,c,sum:integer; begin clrscr; write('Vvedite arifmeticheskoe vyrazenie: ');readln(s); val(s[1],t,c);sum:=t; for i:=2 to length(s) do begin val(s[i+1],t,c); if s[i]='+'then sum:=sum+t else if s[i]='-'then sum:=sum-t; end; Writeln('sum=',sum); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 06.05.2008, 13:03 Оценка за ответ: 5

Вопрос № 135.337

Здравствуйте, нужна помощь по программированию на зяыке Pascal Одномерные массивы: 1. Дан массив размера N. Продублировать в нем элементы с четными номерами (2, 4, 6, ...). Условный оператор не использовать. Двумерные массивы: 2. Заполнить матрицу ЛП, от левого нижнего угла по диагонали: влево-вверх. Строковый тип данных: 3. Дана строка, состоящая из русских слов, набранных заглавными буквами и разделенных пробелами (одним или несколькими). Найти количество слов, которые начинаются и заканчиваются одной и той же буквой. Двоичные файлы: 4. Даны два целых числа I,J и файл вещественных чисел, содержащий ненулевую часть трехдиагональной матрицы(По строкам). Вывести порядок матрицы и её элемент расположенный в I-й строке и J-м столбце (строки и столбцы нумеруются от 1). Если Требуемый элемент находится в нулевой части матрицы то вывести 0; если элемент отсутствует, то вывести -1. Запрещается использовать вспомогательные массивы. Текстовые файлы: 5. Дано целое число K (>25) и текстовый файл, содержащий текст, выровненный по левому краю. Абзацы текста отделяются друг от друга одной пустой строкой. Отформатировать текст так, чтобы его ширина не превосходила K позиций, и выровнять текст по левому краю, сохранив деление на абзацы. Пробелы в конце строк удалить. Сохранить отформатированный текст в новом текстовом файле.

Отправлен: 04.05.2008, 20:31 Вопрос задал: Ильнур (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 5)

Отвечает: Delph Здравствуйте, Ильнур! Постарался решить первую из Ваших задач. Лучшее, до чего додумался - обрабатывать вывод данных из массива, а не сам массив. По условию задачи запрещено использовать условный оператор, поэтому он подменён другой конструкцией, тоже реагирующей на чётность числа: for j := 0 to (i + 1) mod 2 do... Надеюсь, Вам это подойдёт. Приложение: Program Pr135337_1; Uses CRT; Const N = 10; Var i, j: Integer; Arr : Array[1 .. N] of integer; Begin ClrScr; Randomize; WriteLn('Исходный случайно сформированный массив:'); for i := 1 to N do begin Arr[i] := Random(100); Write(Arr[i]:4); end; WriteLn; WriteLn; WriteLn('Обработанный массив:'); for i := 1 to N do for j := 0 to (i + 1) mod 2 do Write(Arr[i]:4); ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 06.05.2008, 08:28 Оценка за ответ: 5 Комментарий оценки: Спасбо большое!

Отвечает: Пупорев Юрий Борисович Здравствуйте, Ильнур! Первая задача решается так. Смотрите приложение. Приложение: uses crt; var a:array[1..50] of integer; n,i,j:integer; begin clrscr; Write('n=');readln(n); for i:=1 to n do begin a[i]:=i; write(a[i],' '); end; i:=2; {начинаем со второго элемента} while i<=n do begin n:=n+1; {увеличиваем n} for j:=n+1 downto i+1 do {сдвигаем все элементы, начиная с третьего на один вправо} begin a[j]:=a[j-1]; end; a[i+1]:=a[i]; {третьему элементу присваиваем значение второго} i:=i+3; {перешагиваем через два элемента} end; writeln; for i:=1 to n do write(a[i],' '); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 06.05.2008, 13:29 Оценка за ответ: 5 Комментарий оценки: И вам большое спасибо!

Вопрос № 135.347

Доброго времени суток. У меня к вам три вопроса: 1) Как выяснить является ли данное число степенью числа 3. 2) Если не трудно объясните как задавать интервал в random. Например заполнить массив случайным образом из отрезка [22,33] или [-50,50]. 3) Посоветуйте электронный учебник чтоб там было задачи с разобранными примерами и практической частью. Заранее спасибо

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

Отвечает: Gh0stik Здравствуйте, DaImeR! 1. var n:longint; begin   readln(n); {вводим число}   while n mod 3=0 do n:=n div 3; {пока число делится на 3, делим его на 3}   writeln(n=1); {выводим TRUE, если число является степенью тройки и FALSE в противном случае} end. 2. Все достаточно просто, потому рассмотрим задачу в общем виде. Для начала нужно узнать количество чисел которые входят в данный отрезок [a, b]. Количество различных целых чисел можно вычислить так: b-a+1. Поскольку нам необходимо генерировать именно числа из данного отрезка, а функция random(n) генерирует произвольное число из интервала [0,n-1), следовательно чтобы получить произвольное число из отрезка [a, b] достаточно воспользоваться такой конструкцией: random(b-a+1)+a. Соответственно для заполнения массива числами из отрезка [22,33] нужно просто использовать такой блок: ... randomize; for i:=1 to n do m[i]:=random(33-22+1)+22; ... либо если упростить: ... randomize; for i:=1 to n do m[i]:=random(12)+22; ... 3. А учебники можете выбрать по такой ссылке. Good Luck! --------- Непечатный жаргон - это тот язык, которым решительно все программисты владеют в совершенстве.

Ответ отправил: Gh0stik (статус: Академик) Украина, Славянск Организация: Славянский государственный педагогический университет (Кафедра алгебры) WWW: http://gh0stik.rusfaq.ru/ ICQ: 289363162 ---- Ответ отправлен: 04.05.2008, 23:01 Оценка за ответ: 5

Вопрос № 135.358

Здравстсуйте! Нужно решить 5 задач. 1. Дан массив целых чисел. Найти сумму и количество всех элементов, кратных 3 и 5. 2. Определить есть ли в двумерном массиве число 5. Если таких чисел несколько найти их количество. 3. Дана строка. Подсчитать количество симмволов в данной строке. 4. Дан текстовый файл, содержащий целые числа. Найти количество отрицательных чисел. 5. Нарисовать на экране прямоугольник красного цвета.

Отправлен: 04.05.2008, 23:31 Вопрос задал: Аксютчев Иван Владимирович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Шемет Станислав Васильевич Здравствуйте, Аксютчев Иван Владимирович! Программы в приложении... Все они разделены строкой со знаками "*". Приложение: ******************************************************************* const n=100; Var M:array[1..n] of integer; Sum,Col,i:integer; Begin Randomize; sum:=0; col:=0; For i:=1 to n do m[i]:=random(100); For i:=1 to n do if (m[i] mod 3=0) or (m[i] mod 5 =0 ) then Begin inc(col); sum:=sum+m[i]; end; Writeln('Сумма: ',sum); Writeln('Количество: ',col); Readln end. ***************************************************************** Const Nx,Ny=10; Var i,j,col:integer; M:array[1..Nx,1..Ny] of integer; Begin Randomize; col:=0; For i:=1 to Nx do For J:=1 to Ny do If m[i,j]=5 then Inc(col); if col=0 then Writeln('Нет числа "5" в массиве') else If col=1 then Writeln('Есть в массиве число "5"') else Writeln('Количество чисел "5" в массиве ',col); readln; end. ***************************************************************** Var F:text; Col:word; Buf:integer; Begin Assign(f,'d:Input.txt'); Reset(f); col:=0; Repeat Readln(buf); if buf<0 then Inc(col); until eof(f); Close(f); Writeln('Количество отрицательных чисел в файле :',col); Readln; end. **************************************************************** uses Graph; Var X,y:integer; Begin Initgraph(x,y,''); Setcolor(4); Line(100,100,200,100); Line(200,100,200,150); Line(200,150,100,150); Line(100,150,100,100); Readln; Closegraph; end. --------- Любовь это прекрасно!!!

Ответ отправил: Шемет Станислав Васильевич (статус: 7-ой класс) Ответ отправлен: 05.05.2008, 00:49

Вопрос № 135.362

Доброго времени суток. Один вопрос: 1) Дана целочисленная квадратная матрица. Найти в каждой строке наибольший элемент и поменять его местами с элементом главной диагонали. Проблема: не пойму как поменять мах элемент с элементом главной диагонали. Если не трудно проверьте то что я сделал. Спасибо Приложение: uses crt; const n=4; var a:array[1..n,1..n] of integer; max:array[1..n] of integer; i,j:integer; begin clrscr; randomize; {формирование матрицы} for i:=1 to n do for j:=1 to n do a[i,j]:=random(100); { поиск максимального в каждой строке} max[1]:=a[1,1]; for i:=1 to n do begin for j:=2 to n do if a[i,j]> max[i] then max[i]:=a[i,j];end; for i:=1 to n do writeln(max[i]); {вывод матрицы} for i:=1 to n do begin for j:=1 to n do write(a[i,j]:4); writeln; end; readln; end.

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

Отвечает: SHERRY Здравствуйте, DaImeR! Поправил немного Ваш код. При поиске максимального элемента просматривать нужно всю матрицу, поэтому цикл переменной j начинайте с 1. Добавил переменные t (временнная переменная, для обмена местами максимального элемента и элемента главной диагонали), index и index1 хранят координаты максимально элемента. Есть ещё одно замечание: при поиске максимального элемента достаточно было использовать одну челочисленную переменную max, а не массив. Но может Вы после их используете, поэтому трогать не стал. В общем - смотрите, код в приложении. Удачи! Приложение: const n=4; var a:array[1..n,1..n] of integer; max:array[1..n] of integer; i,j,t, index,index1:integer; begin randomize; for i:=1 to n do for j:=1 to n do a[i,j]:=random(100); max[1]:=a[1,1]; for i:=1 to n do begin for j:=1 to n do if a[i,j]> max[i] then begin max[i]:=a[i,j]; index:=i; index1:=j; end; t:=a[i,i]; a[i,i]:=max[i]; a[index,index1]:=t; end; for i:=1 to n do writeln(max[i]); for i:=1 to n do begin for j:=1 to n do write(a[i,j]:4); writeln; end; readln; end. --------- Самурай без меча подобен самураю с мечём, только без меча..

Ответ отправил: SHERRY (статус: 9-ый класс) Ответ отправлен: 05.05.2008, 08:12 Оценка за ответ: 5

Вопрос № 135.380

Здравствуйте! Помогите пожалуйста решить задачку на Pascal. Во введенной строке каждую цифру заменить на следующую по порядку цифру. Цифру 9 заменить на цифру 0.

Отправлен: 05.05.2008, 05:56 Вопрос задала: Булова Варвара Анатольевна (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Delph Здравствуйте, Булова Варвара Анатольевна! Решение в приложении. Приложение: Program Pr135380; Uses CRT; Var Str: String; i: Integer; ch: Byte; Begin ClrScr; Write('Введите исходную строку: '); ReadLn(Str); for i := 1 to Length(Str) do if Str[i] in ['0'..'9'] { Проверяем каждый символ: это цифра? } then begin { Из кода символа вычитаем код '0', прибавляем единицу и вычисляем остаток от деления на 10 } ch := (Ord(Str[i]) - Ord('0') + 1) mod 10; { Возвращаем результат в символьный тип. Для этого прибавляем код нуля, чтобы цифры отображались корректно. } Str[i] := Chr(ch + Ord('0')); end; WriteLn('Обработанная строка: ', Str); ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 05.05.2008, 07:29

Отвечает: Попов Владимир Иванович Здравствуйте, Булова Варвара Анатольевна! Исходный код вашей программы в приложении. Протестирован. Работает. Берёт с клавиатуры любую строку : как из одних цифр, так и без них или буквенно-цифровую. Обрабатывает только цифры - согласно заданию. Использованы функции ord и chr - соответственно, взятия ASCII-кода символа и возврата символа по его ASCII-коду. Удачи. Приложение: program figersup; uses crt; procedure input(var ps:string;var pn:byte); begin writeln; write(' Input your string : '); readln(ps); pn:=length(ps); end; procedure analysis(var ps:string;pn:byte); var i,k:byte; begin for i:=1 to pn do begin k:=ord(ps[i]); case k of 48..56 : ps[i]:=chr(k+1); 57 : ps[i]:='0'; end; end; end; procedure output(mes:string;ps:string); begin writeln; write(mes); writeln('< ',ps,' >'); end; function quit:boolean; var ans:char; begin writeln; writeln; write(' Again ? (y/n) ---> '); readln(ans); if ans='n' then quit:=true else quit:=false; end; var s,mes:string; n:byte; begin repeat clrscr; input(s,n); output(' The initial string is : ',s); analysis(s,n); output(' The figersup string is : ',s); writeln; writeln(' The program is completed !'); until quit; end. --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 6-ой класс) Ответ отправлен: 09.05.2008, 23:33

Вопрос № 135.431

Уважаемые эксперты! Помогите, пожалуйста, решить 2 задачи: 1. Дана строка. Вывести строчные буквы этой строки. А) в порядке их первого вхождения в строку. Б) в алфавитном порядке. 2. Вывести все простые числа из промежутка от 0 до 250 (не используя операцию mod). Заранее огромное спасибо! Swallow.

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Ласточка! Обе задачи выполняются последовательно. Рекурсивный вызов функции Check позволяет организовать цикл проверки чисел. Использована функция Frac()-дробная часть аргумента. Удачи! Приложение: var a:string; b:set of char; c:integer; function check(x:integer):boolean; begin if x<1 then check:=false else if x=1 then check:=true else if x>1 then check:=check(x-1) and (Frac(c/x)>0); end; begin write(' I:Enter string:'); readln(a); b:=[]; {если буквы нет во множестве В, то она встретилась первый раз} write('A:'); for c:=1 to length(a) do if not(a[c]in b)then begin write(a[c]); b:=b+[a[c]]; end; writeln; {перебираем все коды символов и выводим их} write('B:'); for c:=1 to 255 do if chr(c)in b then write(chr(c)); writeln; {выводим простые числа} write(' II:'); for c:=0 to 250 do if check(c-1)then write(c:4); end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Отвечает: Delph Здравствуйте, Ласточка! Вторая задача: Есть любопытный метод, известный под названием "Решето Эратосфена". Его суть заключается в следующем: 1) Выписываем ряд натуральных чисел, начиная с двойки и до некоторой величины, которая нас устраивает. 2) Обводим кружочком самое малое число, которое ещё не обведено и не вычеркнуто. 3) Вычёркиваем все числа, кратные только что обведённому. 4) Пока есть хоть одно число, которое ещё не вычеркнули и не обвели кружком, возвращаемся к шагу 2. В конечном счёте все числа будут либо вычеркнуты, либо обведены кружками. Те, что в кружках, простые. Программа в приложении. Исправлено по просьбе автора ответа. ----- ∙ Отредактировал: Зенченко Констант ин Николаевич (Профессионал) ∙ Дата редактирования: 05.05.2008, 16:41 Приложение: Program Eratosphen; Uses CRT; Const N = 250; Var { минимальное простое число - 2 } Arr: Array[2..N] of Integer; i, j, k: Integer; Begin ClrScr; for i := 2 to N do Arr[i] := i; WriteLn('Поиск простых чисел методом Решета Эратосфена.'); WriteLn; WriteLn('Список простых чисел, не превосходящих ', N); WriteLn; i := 2; k := 0; While i <= N do begin if Arr[i] > 0 then begin Write(Arr[i]:6); j := 2 * i; inc(k); if k = 12 then begin { Переходим на новую строку после каждых 12 чисел } WriteLn; k := 0; end; While j <= N do begin Arr[j] := 0; j := j + i; end; end; inc(i); end; ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 05.05.2008, 16:20 Оценка за ответ: 5 Комментарий оценки: Огромное спасибо за решение, Delph!! Вы мне очень помогли!!

Вопрос № 135.452

уважаемые эксперты. не могу решить задачи. помогите. вот тексты: 1)организовать файл целых чисел из N компонент. удалить из файла отрицательные числа. 2) организоватть текстовый файл f состоящий из N строк, после этого создать текстовый файл g, содержащий строки текстового файла f в обратном порядке. Заранее большое спасибо

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Залилова Регина Рафиковна! Решение задач в приложении. Пояснения минимальные, т.к. программы сплошное повторение 5-6 процедур, смысл которых посмотрите в справке или в учебнике. Приложение: Задача 1. uses crt; var f:text; i,n,a:integer; b:array[1..50]of integer; begin clrscr; write('n=');readln(n); assign(f,'file_1.txt');{создаем файл} rewrite(f); {открываем его для записи} for i:=1 to n do begin readln(a); {вводим числа по условию} write(f,' ',a); {записываем их в файл} end; writeln('Fail zapisan!'); readln; close(f); {закрываем файл} reset(f) ; {открываем для чтения} i:=0; while not eof(f) do begin i:=i+1; read(f,b[i]); {считываем данные из файла в мвссив} write(b[i],' ');{выводим для контроля на экран} end; readln; writeln; close(f); rewrite(f); for i:=1 to n do if b[i]>=0 then begin write(f,b[i],' ');{положительные записываем в файл} write(b[i],' '); {выводим на экран} end; writeln; writeln('Fail perezapisan!'); readln; close(f); end. Задача 2. uses crt; var f,g:text; s:array[1..50]of string; n,i:integer; begin; clrscr; write('n=');readln(n); assign(f,'text1.txt'); {создаем первый файл для записи} rewrite(f); writeln('Vvedite ',n,' strok texta:'); for i:=1 to n do begin readln(s[i]); writeln(f,s[i]); end; close(f); reset(f); {открываем его для чтения} assign(g,'text2.txt');{создаем второй файл для записи} rewrite(g); n:=0; while not eof(f) do begin n:=n+1; readln(f,s[n]) end; close(f); for i:=n downto 1 do begin writeln(g,s[i]); end; writeln('Fail G zapisan!'); readln; close(g); end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 06.05.2008, 21:47 Оценка за ответ: 5 Комментарий оценки: Польшое спасибо Юрий Борисович за столь скорую помощь. Действительно коментарии здесь излишни.Еще раз спасибо, вы мне очень помогли.

Вопрос № 135.461

Здравствуйте, немогу справится с написанием программ, потратил много времени но сам не разобрался 1. Дана матрица целых чисел размером 3x4. Отсортировать каждый столбец матрицы по убыванию. Вывести содержимое матрицы до обработки и после обработки. 2. Организуйте массив содержащий 20 целых чисел. Отсортируйте отдельно элементы с чѐтными индексами по возрастанию, и элементы с нечѐтными индексами по убыванию. 3. Дана действительная матрица размера nxm. Найти сумму наибольших значений элементов ее строк. 4. Натуральное число из n цифр является числом Армстронга, если сумма его цифр, возведѐнных в n-ю степень, равна самому числу. Получить все числа Армстронга, состоящие из трѐх и четырѐх цифр. 5. Найти сумму целых положительных чисел, больших 20, меньших 100, кратных 3 и заканчивающихся на 2, 4 или 8.

Отправлен: 05.05.2008, 16:48 Вопрос задал: WiniHakStyle (статус: 3-ий класс) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Пупорев Юрий Борисович Здравствуйте, WiniHakStyle! Решение ваших задач с небольшими комментариями в приложении. Впредь не советую в один вопрос впихивать более одной задачи, ибо один вопрос-один ответ и никому не нужны все ваши остальные задачи. Кроме того видно, что вы и не пытались ничего решать, а сидите и ждете халявы, да еще и подстегиваете экспертов. Если бы к этому моменту я не решил ваши задачи, я бы и не стал их решать, а так жалко, что добро пропадает. Учитесь себя вести в обществе, хотя бы и виртуальном. Приложение: Задача 1. uses crt; const n=3; m=4; var a:array[1..n,1..m]of integer; i,j,k,x:integer; begin clrscr; randomize; Writeln('Matrica:'); {заполнение матрицы} for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(21)-10;{interv [-10,10]} write(a[i,j]:4); end; writeln; end; readln; for j:=1 to m do {сортрировка каждого столбца матрицы обменом} for i:=1 to n-1 do for k:=1 to n-1 do if a[k,j]<a[k+1,j] then begin x:=a[k,j]; a[k,j]:=a[k+1,j]; a[k+1,j]:=x; end; {вывод результата на экран} writeln('Sortirovka:'); for i:=1 to n do begin for j:=1 to m do write(a[i,j]:4); writeln; end; readln end. Задача 2. uses crt; const n=20; var a:array[1..n]of integer; i,j,x:integer; begin clrscr; randomize; writeln('Massiv:'); for i:=1 to n do begin a[i]:=random(20); write(a[i],' '); end; writeln; {сортируем нечетные номера методом обмена} for i:=1 to n-2 do for j:=1 to n-2 do if (j mod 2=1) and(a[j]<a[j+2]) then begin x:=a[j]; a[j]:=a[j+2]; a[j+2]:=x end {сортируем четные номера} else if (j mod 2=0) and(a[j]>a[j+2]) then begin x:=a[j]; a[j]:=a[j+2]; a[j+2]:=x end; writeln('Sortirovka:'); for i:=1 to n do write(a[i],' '); readln end. Задача 3. uses crt; var a:array[1..20,1..20]of integer; n,m,i,j,sum,max:integer; begin clrscr; write('Kolichestvo strok= ');readln(n); write('Kolichestvo stolbcov= ');readln(m); {Rabota so strokami matricej} randomize; Writeln('Matrica:'); for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(21)-10; write(a[i,j]:4); end; writeln; end; readln; sum:=0; for i:=1 to n do begin max:=a[i,1]; {находим максимальный в каждой строке} for j:=1 to m do if a[i,j]>max then begin max:=a[i,j]; end; sum:=sum+max; {суммируем их} end; writeln('Summa max el-tov v strokah=',sum); readln end. Задача 4. uses crt; var k,i,sum,a,n:integer; p:longint; begin clrscr; for k:=100 to 9999 do begin sum:=0;n:=0;a:=k; while a>0 do begin {отделяем последнюю цифру и прбавляем к сумме} sum:=sum+a mod 10;{} n:=n+1; a:=a div 10; end; {возводим сумму в степень} p:=1; for i:=1 to n do p:=p*sum; if p=k then {если степень суммы=числу, выводим} writeln(k); end; readln end. Задача 5. uses crt; var sum,i:word; begin clrscr; sum:=0; for i:=21 to 99 do if (i mod 3=0)and((i mod 10=2)or(i mod 10=4)or(i mod 10=8)) then begin writeln(i); {выводим для интереса} sum:=sum+i; {считаем сумму} end; writeln('sum=',sum); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 07.05.2008, 10:44 Оценка за ответ: 5 Комментарий оценки: Спосибо за грамотный ответ, три последних задачи я уже сам сделал. И мне не хватило последней.

Вопрос № 135.463

Уважаемые Эксперты. помогите решить задачи: определить и вывести на экран множество символов от "0" до "9" и не входящих в диапазон , составляющих дату рождения введенных с клавиатуры. и вот еще одна.: отсортировать массив из 10 целых чисел, отсортировать его по закону: первый меняется с последним, второй с предпоследним. Заранее спасибо...

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Залилова Регина Рафиковна! Решение Ваших задач в приложении. Приложение: Задача 1. uses crt; const m1=['0'..'9']; {множество всех цифр} var s:string; m2,m:set of '0'..'9'; { Множества, в которых только цифры} i,j:integer; begin clrscr; write('Vvedite datu rozdenia: '); readln(s); writeln; for i:=48 to 57 do {48-57 коды цифр} for j:=1 to length(s) do if chr(i) = s[j] then include(m2,s[j]); {множество цифр даты рождения} m:=m1-m2; {цифры, которых нет в дате рождения} writeln('V date rozdenia net cifr:'); for i:=48 to 57 do if chr(i) in m then write(chr(i),' '); {выводим их на экран} readln end. Задача 2. uses crt; const n=10; var a:array[1..n]of integer; i,t:integer; begin clrscr; randomize; writeln('Ishodny massiv:'); for i:=1 to n do begin a[i]:=random(20); write(a[i],' '); end; writeln; {запоминаем первое число в переменной t, ему прсваиваеи значение последного числа, а последнему числу значение переменной t. Повторяеми это со всеми числами до середины массиваю Если массив нечетный, то среднее число остается без изменений} for i:=1 to n div 2 do begin t:=a[i]; a[i]:=a[n-i+1]; a[n-i+1]:=t; end; writeln('Sortirovka:'); for i:=1 to n do write(a[i],' '); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 07.05.2008, 12:12 Оценка за ответ: 5 Комментарий оценки: Благодарю Вас за оказанную помощь и за трату вашего времени на пояснительные комментарии. Они мне пригодились

Вопрос № 135.475

имется текстовый файл Т. Написать программу, которая выводит на экран первую из самых коротких строк.

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

Отвечает: Шемет Станислав Васильевич Здравствуйте, Shamil boroda! Программа в приложении... Удачи! Приложение: Var F:text; S,buf:string; Begin Assign(f,'D:InPut.txt'); Reset(f); Readln(f,s); While Not (eof(f)) do Begin Readln(f,buf); if Length(buf)<Length(s) then s:=buf; end; Writeln(s); close(f); Readln; end. --------- Любовь это прекрасно!!!

Ответ отправил: Шемет Станислав Васильевич (статус: 7-ой класс) Ответ отправлен: 05.05.2008, 19:38 Оценка за ответ: 5

Вопрос № 135.498

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

Отправлен: 05.05.2008, 19:46 Вопрос задал: парам пам пам Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Шемет Станислав Васильевич Здравствуйте, парам пам пам! Программа в приложении... Удачи...! Приложение: Var F:text; Buf,Max,Min:Integer; Begin Assign(f,'d:input.txt'); Reset(f); max:=0; Min:=0; Repeat Readln(f,buf); If max<buf then max:=buf; If Min>Buf then Min:=buf; until eof(f); Close(f); Writeln(Max-Min); REadln; end. --------- Любовь это прекрасно!!!

Ответ отправил: Шемет Станислав Васильевич (статус: 7-ой класс) Ответ отправлен: 05.05.2008, 19:52

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, парам пам пам! Ответ с комментариями в приложении. Удачи!!! Приложение: program q135498; var {текстовой файл} Txt: text; {min-минимальное число, max-максимальное число, buf-временная переменная} max, min, buf: integer; BEGIN {связываем файловую переменную с файлом data.txt} assign(txt, 'data.txt'); {открываем файл для чтения} reset(txt); {получаем начальные значения минимального и максимального числа} read(txt, max); min:=max; {пока указатель не в конце файла} while not EOF(txt) do begin {читаем очередное слово в буфер} read(txt, buf); {если оно больше максимального, то max:=это число} if buf > max then max:=buf else {иначе если число меньше минимального} if buf < min then min:=buf; end; {закрываем файл} Close(txt); {Выводим разность} WriteLn(max, ' + ', min, ' = ', max-min); readln; END.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: Студент) Ответ отправлен: 05.05.2008, 20:16

Вопрос № 135.548

Здравствуйте!помогите пожалуйста с решением данных заданий: Задача 1. Одномерный массив действительных чисел отсортировать по возрастанию. Задача 2. Найти в двумерном сумму модулей всех отрицательных чисел. Задача 3. Двумерный массив вещественных чисел хранит как положительные, так и отрицательные элементы. Найти количество отрицательных элементов во всем массиве, сумму положительных элементов в 1 строке. Задача 4. Результаты соревнований спортсменов хранятся в массивах. Необходимо написать программу, выводящую на экран призеров (1-3 места) соревнований. Задача 5. В Банк 5 клиентов положили под разные проценты n% начальный капитал S. Требуется вывести фамилии тех клиентов, вклады которых через 3 месяца превысят некоторую сумму R. Задача 6. В текстовом файле ветеринарной клиники хранится информация о животных. Вывести на экран список хозяев и животных в алфавитном порядке. Задача 7. Написать программу, использующую подпрограммы на выбор для сортировки одномерного массива тремя базовыми способами. Задача 8. Разработать модуль и программу, использующую этот модуль, для решения следующей задачи: в текстовом файле хранятся данные студентов и результаты сессии, необходимо вывести студентов-отличников. Заранее спасибо!

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

Отвечает: Delph Здравствуйте, Тимощенко Елизавета Владимировна! В приложении решение первой из Ваших задач. Приложение: Program Pr135548_1; Uses CRT; Const N = 24; Min = -10.0; Max = 10.0; Var i, j: Integer; Arr : Array[1..N] of Real; tmp : Real; Begin ClrScr; Randomize; WriteLn('Исходный случайно сформированный массив:'); for i := 1 to N do begin Arr[i] := Random * (Max - Min) + Min; Write(Arr[i]:9:4); if i mod 8 = 0 then WriteLn; end; for i := 1 to N - 1 do for j := i + 1 to N do if Arr[j] < Arr[i] then begin tmp := Arr[i]; Arr[i] := Arr[j]; Arr[j] := tmp; end; WriteLn; WriteLn; WriteLn('Отсортированный массив:'); for i := 1 to N do begin Write(Arr[i]:9:4); if i mod 8 = 0 then WriteLn; end; ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 06.05.2008, 07:41 Оценка за ответ: 4

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Тимощенко Елизавета Владимировна! Третья с комментариями в приложении. Удачи!!! Приложение: const {кол-во строк} N=5; {кол-во столбцов} M=10; var {вещественный массив} a: array [1..N, 1..M] of real; {сумма} sum: real; {count-кол-во, i и j- для For} count, i, j: integer; begin {Инициализируем сумму, кол-во и генератор сл. чисел} sum:=0; count:=0; randomize; WriteLn('Исходный массив: '); {перебираем весь массив} for i:=1 to N do begin for j:=1 to M do begin {присваиваем тек. эл. сл. вещественное число} a[i, j]:=random(100)-50+random; {выводим} write(a[i, j]:8:3); {если оно отрицательное, то увеличиваем счеичик} if a[i, j] < 0 then inc(count); end; writeln; end; {перебираем первую строку} for i:=1 to M do {если эл. больше нуля, то прибавляем его к сумме} if a[1, i] > 0 then sum:=sum + a[1, i]; {Вывод} WriteLn('Сумма пол. эл. первой строки: ', sum:0:3, #10, #13, 'Кол-во отр. эл.: ', count); readln; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: Студент) Ответ отправлен: 06.05.2008, 20:17 Оценка за ответ: 5 Комментарий оценки: спаисбо))

Отвечает: Пупорев Юрий Борисович Здравствуйте, Тимощенко Елизавета Владимировна! Решение 2 и 4 задач в приложении. Больно уж много Вы их сразу выложили. Здесь один вопрос - один ответ. Приложение: Задача 2. Найти в двумерном сумму модулей всех отрицательных чисел. uses crt; var a:array[1..20,1..20]of real; n,m,i,j:integer; sum:real; begin clrscr; write('Kolichestvo strok= ');readln(n); write('Kolichestvo stolbcov= ');readln(m); randomize; Writeln('Matrica:'); for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(10)+random-4;{interv (-4,6)} write(a[i,j]:5:1); end; writeln; end; readln; sum:=0; for i:=1 to n do for j:=1 to m do if a[i,j]<0 then {если a[i,j]<0, то прибавляем к сумме} begin sum:=sum+abs(a[i,j]); end; writeln('summa modulej otricatelnyh elem matricy=',sum); readln end. Задача 4. Результаты соревнований спортсменов хранятся в массивах. Необходимо написать программу, выводящую на экран призеров (1-3 места) соревнований. Хранить такие данные разных типов удобно в массивах записей. uses crt; type Tsport=record {запись} fam:string[20];{поле фамилия} rez:real; {поле результат} end; var a:array[1..50]of Tsport;{массив записей} n,i,j:integer; x:Tsport; {буфер типа запись при сортировке} begin clrscr; write('Vvedite kolichestvo sportsmenov:'); readln(n); for i:=1 to n do begin writeln('Sportsmen ',i); write('Familia: ');readln(a[i].fam); write('Rezultat: ');readln(a[i].rez); end; for i:=1 to n-1 do for j:=1 to n-1 do {сортируем массив по возрастанию результатов, если лучшие, которые меньше, например бег, или по убыванию, если лучшие, которые больше, например метания, штанга и т.д.} if a[j].rez>a[j+1].rez then begin x:=a[j]; a[j]:=a[j+1]; a[j+1]:=x; end; for i :=1 to 3 do {выводим первые три} begin writeln(i,' mesto - ',a[i].fam:15,' rezultat ',a[i].rez:6:2); {это нужно в одну строку} end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 08.05.2008, 11:18 Оценка за ответ: 4 Комментарий оценки: спасибо

Вопрос № 135.563

Уважаемые эксперты!помогите решить задачу: Найти периметр треугольника,если известны длины трех сторон.При этом наложить ограничения,что стороны могут быть только положительными,а сумма длин 2 сторон всегда больше длины 3 стороны.Стороны a,b,c при запуске программы вводить с клавиатуры самому. Заранее спасибо!)

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

Отвечает: Шемет Станислав Васильевич Здравствуйте, Igor lukashov! Программа в приложении... Удачи !!! Приложение: Var A,b,c:real; Begin Writeln('Введите стороны'); REadln(a,b,c); If ((a>0) and(b>0) and(c>0))and(a+b>c)and(b+c>a) and(a+c>b)then Writeln('Периметр: ',a+b+c) else Writeln('Стороны не совместимы))'); Readln; end. --------- Любовь это прекрасно!!!

Ответ отправил: Шемет Станислав Васильевич (статус: 7-ой класс) Ответ отправлен: 06.05.2008, 09:21

Отвечает: Попов Владимир Иванович Здравствуйте, Igor lukashov! Исходник в приложении. Работает в соответствии с заданием. Успехов. Приложение: program triangle; uses crt; const err=' Input data error :'; procedure input(var pa:integer;var pb:integer;var pc:integer); label L; begin L:writeln; write(' Input the length of 3 triangle bodies {a b c} : '); readln(pa,pb,pc); if (pa<=0) or (pb<=0) or (pc<=0) then begin writeln(err,' a, b, c must be > 0 !'); goto L; end else if (pa+pb<=pc) or (pa+pc<=pb) or (pb+pc<=pa) then begin writeln(err,' the sum of 2 bodies must be > than third !'); goto L; end else end; procedure calc(pa,pb,pc:integer;var px:integer); begin px:=pa+pb+pc; end; procedure output(px:integer); begin writeln; writeln(' The bodylength of your triangle is : P = ',px); end; function quit:boolean; var ans:char; begin writeln; writeln(' The program was successfully completed !'); writeln; writeln; write(' Again ? (y/n) ---> '); readln(ans); if ans='n' then quit:=true else quit:=false; writeln; end; var a,b,c,x:integer; begin repeat clrscr; input(a,b,c); calc(a,b,c,x); output(x); until quit; end. --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 6-ой класс) Ответ отправлен: 10.05.2008, 14:58

Вопрос № 135.597

Помогите решить. Дана квадратная матрица порядка n. Найти наибольшее из значений элементов, расположенных в заштрихованной части матрицы: x o o o x x x o x x x x x x x x x o x x x o o o x (в области, где Х) заранее спасибо

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Кочкарев Владислав Геннадьевич! Программа в приложении. Проверяемая область подсвечивается. Удачи! Приложение: uses crt; const n=10; var a:array[1..n,1..n]of integer; i,j,x,y:integer; begin {пока максимальный элемент a[1,1]} x:=1; y:=1; randomize; {создаем спомощью генератора случайных чисел} for i:=1 to n do begin for j:=1 to n do begin {создаем элемент массива} a[i,j]:=random(99); {проверяем заштрихованную область} if (i>=j)and(i<=(n-j+1))or (i<=j)and(i>=(n-j+1))then begin {меняем яркость} textColor(15); {проверяем максимальных элемент} if a[x,y]<a[i,j]then begin x:=i; y:=j; end; end; {выводим созданный элемент массива} write(a[i,j]:3); {востанавливаем якость} textcolor(7); end; writeln; end; {выводим результат} write('Maximum a[',x,',',y,']:=',a[x,y]:3); readln; end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 06.05.2008, 16:36 Оценка за ответ: 5 Комментарий оценки: Огромное спасибо

Вопрос № 135.614

Просьба помочь в решении задачи на Работу с множествами Дана не пустая последовательность символов. Требуется построить и напечатать множество, элементами которого являются встречающиеся в последовательности цифры от ‘0’ до ‘9’.

Отправлен: 06.05.2008, 14:27 Вопрос задал: Lubimov Alexandr (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Lubimov Alexandr! Решение задачи с пояснениями в приложениию Приложение: uses crt; var s:string; i:integer; mn:set of '0'..'9'; {объявляем тип множества} begin clrscr; mn:=[]; write('s= ');readln(s); writeln; writeln('Mnozestvo:'); for i:=1 to length(s) do if s[i] in ['0'..'9'] then {если цифры} begin include(mn,s[i]); {включаем их во множество, поскольку множество не упрядоченный тип, вывести его на экран нельзя, поэтому выводим символы строки, которые мы включили во множество, тем не менее множество создано и с ним можно работать(складывать его с другим множеством, вычитать, умножать, удалять и прибавлять элементы и т.д.)} write(s[i],' '); end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 07.05.2008, 13:42 Оценка за ответ: 5 Комментарий оценки: БОЛЬШУЩЕЕ СПАСИБО!!! РЕСПЕКТ ВАМ!!!

Вопрос № 135.615

Задача на тему "Файлы. Файловые переменные" Дан файл, содержащий различные даты. Каждая дата-это число, месяц и год. Найти самую позднюю дату. Очень прошу помочь. Заранее спасибо

Отправлен: 06.05.2008, 14:29 Вопрос задал: Lubimov Alexandr (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Lubimov Alexandr! Код с комментариями в приложении. PS. Даты хранятся в текстовом файле в формате ДДММГГГГ. В одной строке только одна дата. Удачи!!!

Ответ отправил: Абельхарисов Руслан / Marked One (статус: Студент) Ответ отправлен: 06.05.2008, 19:54 Оценка за ответ: 5 Комментарий оценки: БОЛЬШОЕ СПАСИБО!!!

Вопрос № 135.631

Уважаемые эксперты!помогите пожалуйста решить следующую задачу: Дан одномерный массив числовых значений,насчитывающий N элементов.Поменять местами М первых элементов с группой элементов,начинающихся с номера К. При этом и элементы массива,и размер, и М, и К вводить самому при запуске программы. Спасибо!)

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Igor lukashov! Решение задачи с пояснениями в приложении. Приложение: uses crt; var a:array[1..50]of real; n,m,k,i:integer; t:real; {буфер при обмене} label 1,2; {метки при неправильном вводе} begin clrscr; write('Vvedite razmernost massiva: '); readln(n); 1: write('Vvedite m <=n mod 2: ');{m должна быть <n/2} readln(m); if m>(n div 2) then begin writeln('Povtorite vvod!'); goto 1; end; 2: write('Vvedite m<k<=n-m: '); {k должно быть >m и <=n-m } readln(k); if (k>(n-m))or(k<=m) then begin writeln('Povtorite vvod!'); goto 2; end; for i:=1 to n do begin write('a[',i,']=');{вводим вручную столбиком значения} readln(a[i]); end; clrscr; {очищаем экран и оставляем нужную информрцию} writeln('n=',n,' m=',m,' k=',k); writeln('Ishodny massiv:'); for i:=1 to n do write(a[i]:5:1); writeln; for i:=1 to m do begin {меняем числа, в буфер запоминаем a[1], a[1]:=a[k]; a[k]:=буфер и так повторяем m раз} t:=a[i]; a[i]:=a[k]; a[k]:=t; k:=k+1; {увеличиваем k} end; writeln('Rezultat:'); for i:=1 to n do write(a[i]:5:1); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 07.05.2008, 17:07 Оценка за ответ: 4

Вопрос № 135.680

Прошу , помогите написать программу в паскале для решения ВОТ УСЛОВИЕ : 1.Разработать систему упражнений для формирования понятия о типах величин 2.Даны координаты вершин треугольника. Найти его площадь. Для нахождения площади использовать формулу Герона. Для нахождения длин сторон использовать формулу расстояния между двумя точками на плоскости. 3.Написать программу, которая запрашиваетномер дня недели и выводит одно из сообщений: рабочий день, суббота или воскресенье. 4.Составить программу, которая выводит на экран квадрат Пифагора - таблицу умножения. Приложение: Если что пишите в асю 351610260

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

Отвечает: Delph Здравствуйте, Максым! Решение второй задачи в приложении. В программе есть комментарии, надеюсь, их будет достаточно для понимания. Приложение: { Нахождение площади треугольника по известным координатам его вершин } Program Pr135680_2; Uses CRT; { Формула Герона } function Gerone(a, b, c: Real): Real; var p: Real; begin p := (a + b + c) / 2; { полупериметр } Gerone := Sqrt(p * (p - a) * (p - b) * (p - c)); end; { новый тип - для вершин треугольника } type TPixel = record x, y: Real; end; { Процедура ввода вершины треугольника (как обычной точки), выводящая подсказки для пользователя } Procedure PixelInput(PixelName: String; var Pixel: TPixel); begin if PixelName <> '' then WriteLn('Введите точку ', PixelName, ':'); Write(' x = '); ReadLn(Pixel.x); Write(' y = '); ReadLn(Pixel.y); end; { Расчёт длины отрезка (стороны треугольника) по известным вершинам концов } function SideLen(p1, p2: TPixel): Real; begin SideLen := Sqrt(SQR(p2.x - p1.x) + SQR(p2.y - p1.y)); end; var Pa, Pb, Pc: TPixel; a, b, c, S: Real; Begin ClrScr; PixelInput('A', Pa); PixelInput('B', Pb); PixelInput('C', Pc); WriteLn; a := SideLen(Pb, Pc); b := SideLen(Pa, Pc); c := SideLen(Pa, Pb); S := Gerone(a, b, c); Write('Площадь треугольника равна '); { Если площадь невелика, выводим её в привычном виде } if S < 10000 then WriteLn(S:10:5) else WriteLn(S); ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 07.05.2008, 09:28

Отвечает: Пупорев Юрий Борисович Здравствуйте, Максым! Решение задач 3 и 4 в приложении. Задачи очень легкие и такие нужно решать самостоятельно. Задача 3 на использование оператора case … of. В задаче 4 в двойном цикле перемножитть номера строк и столбцов. Сделал два варианта. 1 – просто решение, 2 – немного похож на таблицу, если разберетесь, освоите форматированный вывод данных. Приложение: Задача 3. uses crt; var a:byte; begin clrscr; write('a=');readln(a); case a of 1,2,3,4,5:writeln('Rabochij den.'); 6:writeln('Subbota.'); 7:writeln('Voskresenie.'); end; readln end. Задача 4. 1-й вариант. uses crt; var i,j:byte; a:array[1..10,1..10] of byte; begin clrscr; writeln('Tablica Pifagora:'); for i:=1 to 10 do begin for j:=1 to 10 do begin a[i,j]:=i*j; write(a[i,j]:4); end; writeln; end; readln end. 2-й вариант. uses crt; var i,j:byte; a:array[1..10,1..10] of byte; begin clrscr; for i:=1 to 10 do for j:=1 to 10 do a[i,j]:=i*j; writeln('Tablica Pifagora':30); writeln; write(' ':3); for i:=1 to 10 do write(i:4); writeln; for i:=1 to 47 do write('_'); writeln; {write(' ':4);} for i:=1 to 10 do begin write(i:2,'|'); for j:=1 to 10 do write(a[i,j]:4); writeln; end; readln end.

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

Вопрос № 135.686

Помогите пожалуйста написать программу: (условие в приложении) Приложение: Составить программу для расположения чисел в убывающем порядке в заданном одновременном массиве х, состоящим из 25 элементов. Вывод массива оформить процедурой.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, DancaN! Решение в приложении, все оформлено процедурами. Решение настолько простое, что все ясно из текста программы. Приложение: uses crt; const n=25; type Tmass=array[1..n]of integer; var a:Tmass; i,j:integer; Procedure Vyvod; begin for i:=1 to n do write(a[i],' '); end; Procedure Sort; {Сортировка обменом, методом "пузырька"} var x:integer; begin for i:=1 to n-1 do for j:=1 to n-1 do if a[j]<a[j+1] then begin x:=a[j]; a[j]:=a[j+1]; a[j+1]:=x; end; end; begin clrscr; randomize; for i:=1 to n do a[i]:=random(20); writeln('Ishodny massiv:'); Vyvod; writeln; writeln; writeln('Sortirovka:'); Sort; Vyvod; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 08.05.2008, 15:34 Оценка за ответ: 5 Комментарий оценки: ОГРОМНОЕ СПАСИБО!!

Вопрос № 135.703

Мне надо написать функцию которая выдает как результат нажатую клавишу в даный момент "Readkey" не годиться так как она останавливает работу программы. очень надеюсь на помощь.

Отправлен: 06.05.2008, 23:07 Вопрос задал: Делий Роман (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Зенченко Константин Николаевич Здравствуйте, Делий Роман ! Вам поможет вторая функция из этого модуля KeyPressed:boolean; Если клавиша не нажата(False), то выполняете свою программу, если нажата(True), то обрабатываете её(клавишу). Удачи! --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 06.05.2008, 23:28 Оценка за ответ: 5 Комментарий оценки: Спасибо большое я знаю эту функцию, но как то не додумался ее так использовать.

Вопрос № 135.842

Здраствуйте, помогите пожалуйста написать условие, чтобы поместить в другой фаил только те числа, корень их которых натурально целое число Приложение: program lab_3; uses crt; var D,R:text; a:integer; begin clrscr; assign(D,'C:chisla.txt'); reset(D); assign(R,'C:chisla1.txt'); rewrite(R); while not eof(D)do begin read(D,a); a:=sqr(a); if ...... write(R,a,' ') end; close(D); close(R); writeln('Фаил создан!'); end.

Отправлен: 07.05.2008, 19:49 Вопрос задал: Китаев Кирилл Артурович (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 4)

Отвечает: LEXASOFT !!! Здравствуйте, Китаев Кирилл Артурович! Попробуйте так: if trunc(sqrt(a))=0 then write(R,a,' '); Trunc (функция) Усекает значение вещественного типа к значению целочисленного типа. В файл будут записаны только одни нули ----- ∙ Отредактировал: Зенченко Константин Николаевич (Профессионал) ∙ Дата редактирования: 07.05.2008, 20:28 Приложение: program lab_3; uses crt; var D,R:text; a:integer; begin clrscr; assign(D,'C:chisla.txt'); reset(D); assign(R,'C:chisla1.txt'); rewrite(R); while not eof(D)do begin read(D,a); if trunc(sqrt(a))=0 then write(R,a,' '); end; close(D); close(R); writeln('Фаил создан!'); end. ---------

Ответ отправил: LEXASOFT (статус: 8-ой класс) Ответ отправлен: 07.05.2008, 20:03

Отвечает: Зенченко Константин Николаевич Здравствуйте, Китаев Кирилл Артурович! Условие такое: read(D,a); if frac(sqrt(a))=0 then write(R,a,' '); т.е. проверяем если дробная часть квадратного корня равна 0, то записываем в файл. Удачи! --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 135.854

эксперты подскажите пожалуйста как рещить такую задачу : Задана квадратная матрица A размером N x N (N<=10), состоящая из действительных элементов: Найти среднее арифметическое элементов каждого из четных столбцов этой матрицы. Исходные данные задать самостоятельно генератором случайных чисел random.

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Otherside! Программа в приложении. Удачи! Приложение: const n=6; var i, j,k,n1:integer; ar: real; a:array[1..n, 1..n] of real; begin {создаем матрицу} randomize; for i:=1 to n do begin for j:=1 to n do Begin a[i,j]:=20*random-10; write(a[i,j]:10:5); End; writeln; end; writeln; {выводим результат} for i:=1 to n do Begin ar:=0; if (i mod 2)=0 then Begin for j:=1 to n do ar:=ar+a[j,i]; write(ar/n:10:5); end else write(' ':10); end; end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 135.964

1)Дан массив ненулевых целых чисел.Определить,сколько раз меняется знак элементов массива при его просмотре.Например,в массиве 12,-4,13,77,-5,-99 2)дан двумерный массив.Найти сумму элементов главной диагонали массива. 3)дана сторока.вывести данную строку на экран задом наперед.

Отправлен: 08.05.2008, 16:13 Вопрос задал: Черняев Артем Юрьевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: -=Dr. Штопор=- Здравствуйте, Черняев Артем Юрьевич! Код всех трёх задач в приложении, в первых двух при желании можете менять константу N. Если будут вопросы, обращайтесь. P.S. Пожалуйста, не жалейте денег, пишите по задаче на вопрос Приложение: program p135964_1; const N=10; var a:array [1..N] of integer; i,count:integer; BEGIN for i:=1 to N do begin write('Введите ',i,' элемент массива: '); readln(a[i]); end; for i:=2 to N do if a[i]*a[i-1]<0 then inc(count); writeln('Обнаружено ',count,' смен знака'); end. program p135964_2; const N=10; var a:array [1..N, 1..N] of integer; i,j,S:integer; BEGIN randomize; for i:=1 to N do begin for j:=1 to N do begin a[i,j]:=random(21); write(a[i,j]:4); end; writeln; end; for i:=1 to N do S:=S+a[i,i]; writeln('Сумма элементов главной диагонали равна ',S); end. program p135964_3; var s,s1:string; i:byte; BEGIN writeln('Введите строку'); readln(s); for i:=length(s) downto 1 do s1:=s1+s[i]; writeln(s1); end. --------- Tantum possumus, quantum scimus

Ответ отправил: -=Dr. Штопор=- (статус: 9-ый класс) Ответ отправлен: 08.05.2008, 16:49

Вопрос № 136.106

1)дан текстовый файл.переписать всю информацию данного во 2ойфайл,удвоив все буквы В 2)нарисовать на экране круг красного цвета.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Черняев Артем Юрьевич! Решение задач в приложении. По задаче 1 отмечу, что кодировка символов русских букв в Блокноте и Паскале не совпадают, поэтому в программе пишем не символ'в' или 'B', вкоторые при переносе из блокнота в Паскаль превращается в симолы с порядковым номером кода на 64 больше, т.е chr(226) и chr(194) соответственно. Поскольку в условии не указан язык, то это может быть и английская прописная буква В, поэтому я ее тоже добавил. Если что-то лишнее, уберите. Если не знаете как, напишите. Приложение: Задача 1. uses crt; const bk=[chr(66),chr(194),chr(226)]; var f,g:text; s:string; i:integer; begin clrscr; assign(f,'BukvaB.txt'); reset(f); assign(g,'BukvaBB.txt'); rewrite(g); while not eof(f) do begin readln(f,s); for i:=length(s)downto 1 do begin if s[i] in bk then begin insert(s[i],s,i+1); end; end; writeln(g,s); writeln(s); end; writeln('FAIL BUKVA BB ZAPISAN!!!'); readln; close(f); close(g); end. Задача 2. uses crt,graph; var R,x,y,gd,gm:integer; {переменные радиус, координаты центра, константы графического режима} begin clrscr; Write('R=');readln(R); InitGraph(gd,gm,''); {если папка BGI в другой директории, указать к ней путь в ''} x:=getmaxX div 2;y:=getmaxY div 2; {центр экрана} SetColor(4); {красный цвет контура(окружности)} SetFillStyle(1,4); {стиль заполнения 1-сплошное заполнение цветом, 4 – красный цвет} FillEllipse(x,y,R,R); {круг} readln; CloseGraph; {выход} end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 10.05.2008, 09:28

Вопрос № 136.155

Добрый день эксперты. Во время решения задач возникли проблемы. Помогите найти исправить ошибку. 1) Пусть дана последовательность из Н элементов. Элементы массива сдвиньте циклически на две позиции влево. Проблема: После сдвига, первые два элемента b[1] и b[2] принимают "левые" числа, как это исправить. 2) Заполнить массив из десяти элементов (случайным образом) вещественными числами в диапозоне от [0,10]. Найти сумму нечетных элементов. Проблема: Не могу додуматься как сделать чтоб работал с вещественными числами. С целыми все нормально. 3) Подсчитайте сколько раз в заданном тексте встречается наибольшее количество подряд идущих элементов. Проблема: подчитал количество пробелов, а серию не знаю как. спачибо заранее Приложение: uses crt; const n=5; var a,b:array[1..n] of integer; i:byte; begin clrscr; randomize; for i:=1 to n do begin a[i]:=random(21); write(' a[',i,']= ',a[i]); b[i]:=a[i-2]; end; for i:=1 to n do write(' b[',i,']=',b[i]); readln; end. 2) uses crt; const n=10; var a:array[1..n] of integer; i:byte; sum:integer; begin clrscr; randomize; for i:=1 to n do begin {формирование матрицы} a[i]:=random(11);write(a[i],' '); if a[i] mod 2 = 1 then {считаем сумму} sum:=sum+a[i];end; writeln('summa nechetnych= ',sum); readln; end. 3) uses crt; var t:string; k,i:integer; begin clrscr;writeln('Введите строку'); read(t); for i:=1 to length(t) do if t[i]=' ' then inc(k); writeln('Количество= ',k); repeat until keypressed; end.

Отправлен: 10.05.2008, 08:22 Вопрос задал: DaImeR (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 4)

Отвечает: Пупорев Юрий Борисович Здравствуйте, DaImeR! Решение задач 1,2,4 с небольшими пояснениями в приложении. Приложение: Задача 1. uses crt; const n=5; var a:array[1..n]of integer; i,j,r:integer; begin clrscr; randomize; writeln('Ischodny massiv:'); for i:=1 to n do begin a[i]:=i; write(a[i],' '); end; {В цикле два раза запоминаем первый элемент, сдвигаем элементы на один влево, последнму элементу прсваиваем значение первого} for j:=1 to 2 do begin r:=a[1]; for i:=1 to n-1 do begin a[i]:=a[i+1]; end; a[n]:=r; end; writeln; writeln('Sdvinutyj massiv:'); for i:=1 to n do write(a[i],' '); readln; end. Задача 2. {Под нечетными понимается номер элемента в массиве, т.к. вещественные числа в нормальной матеметике не бывают четными и нечетными} uses crt; const n=10; var a:array[1..n]of real; i:integer; sum:real; begin clrscr; randomize; writeln('Ischodny massiv:'); sum:=0; for i:=1 to n do begin a[i]:=random(10)+random; write(a[i]:5:2); if i mod 2<>0 then sum:=sum+a[i]; end; writeln; writeln('summa=',sum:5:2); readln end. Задача 4. В одном двойном цикле сортируем элементы, стоящие на четных местах и на нечетных местах. uses crt; const n=15; var a:array[1..n]of integer; i,j,x:integer; begin clrscr; randomize; writeln('Ischodny massiv:'); for i:=1 to n do begin a[i]:=random(20); write(a[i],' '); end; writeln; for i:=1 to n-2 do for j:=1 to n-2 do if (j mod 2<>0)and(a[j]>a[j+2]) then begin x:=a[j]; a[j]:=a[j+2]; a[j+2]:=x; end else if (j mod 2=0)and(a[j]<a[j+2]) then begin x:=a[j]; a[j]:=a[j+2]; a[j+2]:=x; end; Writeln('Rezultat:'); For i:=1 to n do write(a[i],' '); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 10.05.2008, 18:46 Оценка за ответ: 5

Отвечает: Попов Владимир Иванович Здравствуйте, DaImeR! Исходники ваших программ - в приложении. Изучайте. Обращайтесь с вопросами, если что. Удачи. Приложение: program sdvig; uses crt; const Nmax=15; type Tmassiv=array[1..Nmax] of integer; procedure input_array(var pN:integer;var pX:Tmassiv); label L; var i:byte; begin L:writeln; write(' Input the dimention og your array : N = '); readln(pN); if (pN<1) or (pN>Nmax) then begin writeln(' Error : N must be >= 1 and <= ',Nmax); goto L; end else begin writeln; writeln(' Input the list of your array"s elements :'); writeln(' -------------------------------------------'); for i:=1 to pN do begin write(' x[',i,'] = '); readln(pX[i]); end; end; end; procedure replace_elements(pN:integer;var pX:Tmassiv;var pY:Tmassiv); var i:byte; begin for i:=3 to pN do pY[i-2]:=pX[i]; pY[pN-1]:=pX[1]; pY[pN]:=pX[2]; end; procedure output_results(pN:integer;var pX:Tmassiv;var pY:Tmassiv); var i:byte; begin writeln; write(' The initial array is : '); for i:=1 to pN do write(pX[i],' '); writeln; write(' The replaced elements array is : '); for i:=1 to pN do write(pY[i],' '); writeln; writeln; writeln(' The program is comleted !'); write(' Press <Enter> for quit : '); readln; end; var N:integer; X,Y:Tmassiv; begin clrscr; input_array(N,X); replace_elements(N,X,Y); output_results(N,X,Y); end. program suma; uses crt; type Tmassiv=array[1..10] of real; procedure create_array(var pX:Tmassiv); var i:byte; begin writeln; writeln(' The initial random array of real numbers is :'); writeln(' -----------------------------------------------'); for i:=1 to 10 do begin pX[i]:=10*random; write(' ',pX[i]:4:2); end; writeln; end; procedure sumator(var pX:Tmassiv;var pS:real); var i:byte; begin pS:=0; for i:=1 to 10 do if odd(trunc(pX[i])) then pS:=pS+pX[i]; end; procedure output_result(pS:real); begin writeln; writeln(' The sum of uncouple array"s elements is : S = ',pS:4:2); writeln; writeln(' The program is comleted !'); end; function quit:boolean; var ans:char; begin writeln; writeln; write(' Again ? (y/n) ---> '); readln(ans); if ans='n' then quit:=true else quit:=false; end; var X:Tmassiv; S:real; begin clrscr; repeat create_array(X); sumator(X,S); output_result(S); until quit; end. program txt; uses crt; var s:string; ans:char; i,k,n:byte; begin clrscr; repeat writeln; write(' Input your string => '); readln(s); n:=length(s); k:=0; for i:=1 to n-1 do if s[i]=s[i+1] then inc(k); writeln; writeln(' In your string : '); writeln(' < ',s,' > '); writeln(' there are < ',k,' > cases of repeating the symbols.'); writeln; write(' Again ? (y/n) ---> '); readln(ans); until ans='n'; end. --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 6-ой класс) Ответ отправлен: 13.05.2008, 21:29 Оценка за ответ: 5 Комментарий оценки: Спасибо большое

Вопрос № 136.174

Уважаемые эксперты,прошу вас помочь мне в создании программы: Дан массив целых чисел.Определить есть ли две пары соседних элементов с одними знаками..

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Ведонин Никита Евгеньевич! Решение задачи с пояснениями в приложении. Приложение: uses crt; const n=10; var a:array[1..n]of integer; i,k:integer; begin clrscr; randomize; for i:=1 to n do begin a[i]:=random(10)-4; write(a[i],' '); end; writeln; k:=0;i:=2; while i<=n do begin {если произведение соседних элементов больше 0, то знаки одинаковые} if a[i]*a[i-1]>0 then begin k:=k+1; i:=i+2; {переходим к следующей паре} end else i:=i+1;{иначе переходим к следующему числу} end; writeln('k=',k); if k>=2 then writeln('Dve takih pary est!') else writeln('Dvuh par net.'); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 10.05.2008, 20:01

Вопрос № 136.175

Уважаемые эксперты,прошу вас помочь в создании программы: Дан двумерный массив.Выполнить следующее преобразование:отрицательный последний элемент каждой строки заменить на ноль.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Ведонин Никита Евгеньевич! Решение задачи с небольшими пояснениями в приложении. Приложение: uses crt; var a:array[1..20,1..20]of integer; n,m,i,j:integer; begin clrscr; write('Kolichestvo strok= ');readln(n); write('Kolichestvo stolbcov= ');readln(m); randomize; Writeln('Matrica:'); for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(21)-10; write(a[i,j]:4); end; writeln; end; for i:=1 to n do {Просматриваем каждую строку с конца. Если находим отрицательный элемент, заменяем его на ноль и прерываем цикл.} for j:=m downto 1 do if a[i,j]<0 then begin a[i,j]:=0; break; end; writeln('Rezultat:'); for i:=1 to n do begin for j:=1 to m do write(a[i,j]:4); writeln; end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 10.05.2008, 20:18

Вопрос № 136.176

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

Отправлен: 10.05.2008, 10:59 Вопрос задал: Ведонин Никита Евгеньевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Костя Симанович Здравствуйте, Ведонин Никита Евгеньевич! Один из вариантов в приложении. Только проверте все ли гласные перечислил с константе. Удачи. Приложение: program g; const glas = 'ajoiueAJOIUE'; var s : string; i, gl : integer; begin Write('Введите строку: '); ReadLn(s); gl := 0; for i := 1 to length(glas) do while pos(copy(glas,i,1),s)>0 do begin delete(s, pos(copy(glas,i,1),s), 1); gl := gl + 1; end; WriteLn('Кол-во гласных букв = ', gl); ReadLn; end.

Ответ отправил: Костя Симанович (статус: 4-ый класс) Ответ отправлен: 10.05.2008, 15:03

Вопрос № 136.201

Здравствуйте! Помогите мне, пожалуйста, сделать программу, которая возводит число в степень. Моё решение в приложении, но оно работает немного неправильно. Язык программирования: Pascal. Еще меланький вопросик: а есть ли функция для возведения в степень ? Большое спасибо! Приложение: procedure stepen (var n,a,p:integer; o:byte); begin write ('Vvedite chislo: '); readln (a); write ('Vvedite stepen: '); readln (n); if n mod 2 = 0 then begin for o:=1 to n do begin p:=0; p:=a*a; write ('Rezultat: ',p); readln; end; end; if n mod 2 <> 0 then begin for o:=1 to n do begin p:=0; p:=a*a*a; write ('Rezultat: ',p); readln; end; end; end;

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

Отвечает: Костя Симанович Здравствуйте, BOOM! Как таковой функции возведения числа в любую степень нет (насколько я знаю, могу и ошибаться), чтобы возвести число Х в степень У можно воспользоватся следующим вариантом Х в степени У = EXP(LN(x)*y) где EXP(X) экспоненциальная функция Х LN(x) натуральный логарифм Х Надеюсь помог. Удачи.

Ответ отправил: Костя Симанович (статус: 4-ый класс) Ответ отправлен: 10.05.2008, 14:32 Оценка за ответ: 5 Комментарий оценки: Спасибо.

Вопрос № 136.206

Дан текстовой файл. Переписать во второй файл только цифры.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Пухов Никита Евгеньевич! Создаем текстовый файл любого содержания, но с цифрами. Лучше в той же директории, что и программа, тогда не нужно указывать путь к файлу. После запуска программы ничего кроме сообщения о записи нового файла не ждите. Выходите из программы, ищите новый файл, открывайте его и любуйтесь на результаты своего труда. Код в приложении. Приложение: uses crt; var f,g:text; s:string; i:integer; begin clrscr; {связываем файл с переменной f и открываем его для чтения} Assign(f,'Text1.txt'); reset(f); {создаем файл g и открываум его для записи} assign(g,'Text2.txt'); rewrite(g); while not eof(f) do begin readln(f,s); {считываем строки файла f} for i:=1 to length(s) do if s[i] in ['0'..'9'] then {если цифры} begin write(g,s[i]); {записываем в файл g} end; end; close(f); {закрываем файлы} close(g); writeln('Fail Text2 zapisan!'); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 10.05.2008, 22:13 Оценка за ответ: 5

Вопрос № 136.207

Составить программу вывода последовательности символов А BB CCC .... WWW...WWW (23 раза) на экран.

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

Отвечает: Костя Симанович Здравствуйте, Пухов Никита Евгеньевич! Если правильно понял задание то решение в приложении. 65 это заглавная буква А и далее просто увеличиваем переменную на 1 и выводим символ соответствующий этому числу с помощью функции CHR. Удачи. Приложение: program w; var a, i, i1 : integer; begin a := 65; for i := 1 to 23 do begin for i1 := 1 to i do write(chr(a)); a := a + 1; writeln; end; readln; end.

Ответ отправил: Костя Симанович (статус: 4-ый класс) Ответ отправлен: 10.05.2008, 14:17 Оценка за ответ: 5

Вопрос № 136.211

помогите пожалуйста решить задание в pascal: дано любой текст что заканчиваетса символом &.виписать из етого текста все гласние букви и росположить ихпо алфавиту. Зарание спасибо

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Петренко Максим Васильевич! В приложении программа, которая выполняет Вашу задание двумя способами:с рекурсией и с помощью циклов. Удачи! Приложение: var a:set of char; b:array [0..255]of byte; c:string; d:integer;{} {рекурсивная функция контроля символов} procedure Check(d:string); begin if (length(d)>0)and(d[1]<>'&')then begin Inc(b[ord(d[1])]); Delete(d,1,1); Check(d); end; end; {рекурсивная функция вывода результатов} procedure OutRes(x:integer); begin if(x<256)then if (b[x]>0)and(chr(x)in a)then begin Write(chr(x)); OutRes(x+1); end else OutRes(x+1); end; begin {устанавливаем множество букв} a:=['a'..'z','а', 'е', 'и', 'о', 'у', 'ы', 'э', 'ю', 'я']; {вводим строку и принудительно ставим признак окончания строки} Write('String:');Readln(c);c:=c+'&'; {вариант с рекурсией: сбрасываем массив контроля} FillChar(b,256,chr(0)); {запускаем вариант с рекурсией} Check(c); Write('Result A:'); OutRes(0); {вариант с циклом: сбрасываем массив контроля} FillChar(b,256,chr(0)); Writeln; Write('Result B:'); d:=1; {запускаем цикл контроля символов в строке} repeat Inc(b[ord(c[d])]); Inc(d); until (d>length(c))or(c[d]='&'); {выводим результат} for d:=0 to 255 do if (b[d]>0)and(chr(d)in a)then Write(chr(d)); end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 136.229

доска 8*8, конь, который ходит во все стороны. надо ввести начальные координаты коня, координату пешки и координату, на которую коню надо попасть, но не заходя на поле пешки. нужно посчитать количество ходов от начальной координаты до конечной. В приложении пример задачи,где рисуются ходы коня Нужно сделать что-то наподобие,только с подсчетом и вставить кусок,где выкидывается варианты когда конь попадает на поле с пешкой Зараннее огромное спасибо...вы последняя надежда!! Приложение: program Chess; type ChessBoard = array [1..8,1..8] of integer; {заполнение доски 0 и 1, где 0 - белое поле, 1 - черное поле} procedure fillBoard (var board:ChessBoard); var i, j: integer; begin for i:=1 to 8 do begin for j:=1 to 8 do begin board[i,j] := (i+j+1) mod 2; end; end; end; {вывод доски на экран} procedure paintBoard (var board:ChessBoard); var i, j: integer; begin for i:=8 downto 1 do begin for j:=1 to 8 do begin if (board[i,j]=0) then begin write ('*'); end else if (board[i,j]=1) then begin write (' '); end else if (board[i,j]=4) then begin write ('X'); end else if (board[i,j]=3) then begin write ('K'); end; end; writeln; end; end; {проверка: не выходит ли фигура за границу доски} procedure Select (var board:ChessBoard; v, h: integer); begin if ((v<9) and (v>0) and (h<9) and (h>0)) then board[v,h]:=4; end; {определение положения коня на доске и его возможных ходов} procedure setKnight (var board:ChessBoard; v, h: integer); begin board[v,h]:=3; Select (board, v+2, h+1); Select (board, v+2, h-1); Select (board, v+1, h+2); Select (board, v+1, h-2); Select (board, v-2, h+1); Select (board, v-2, h-1); Select (board, v-1, h+2); Select (board, v-1, h-2); end; {ввод координат коня и определение возможных ходов} procedure askAndSetKnight (var board:ChessBoard); var h, v: integer; begin write ('Где находится конь? (вертикальная, горизонтальная координаты) '); readln (v,h); setKnight (board, v, h); end; var board:ChessBoard; begin fillBoard(board); askAndSetKnight(board); paintBoard(board); writeln ('Нажмите Enter'); readln; end.

Отправлен: 10.05.2008, 15:50 Вопрос задал: Andrew Shtamburg (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Зенченко Константин Николаевич Здравствуйте, Andrew Shtamburg! Программа перебираем все возможные варианты ходов коня по шахматной доске. Обратите внимание на процедуру outLocation она выводит на экран шахматную доску с положением фигур. Если перед командой until a=nil; поставить вывод доски то можно проследить за работой программы в пошаговом режиме. Обработку момента когда конь попадает на пешку можете посмотреть тут. Удачи! Приложение: uses Crt; const n=8;{размер доски} type{запись} TList=^TBase; TBase=record x,y,z:integer;{координаты и количество вариантов ходов} w:Tlist;{указатель на следующий элемент} end; var a,b:TList; Board:packed array[0..n+2,0..n+2]of boolean; Fx,Fy,Px,Py:integer; k:longint; procedure inpLocation(var x,y:integer); var z:char; zA,zB:set of Char; begin {возможные вводимые значения} zA:=['a'..'h']; zB:=['1'..'8']; x:=0; y:=0; repeat repeat z:=ReadKey; until(z in zA)or(z in zB);{проверяем нажатую клавишу} if(z in zA)or(z in zB)then write(z);{} if z in zA then x:=ord(z)-96;{записываем координаты} if z in zB then y:=ord(z)-48; until (x>0)and(y>0);{выходим когда введены горизонтальная и вертикальная координата} end; procedure outLocation; var i,j:integer; c:Tlist; begin for i:=n downto 1 do begin for j:=1 to n do begin {меняем атрибуты цвета и фона взависимости от поля} TextColor(ord(Board[i,j])*15); TextBackGround(ord(not Board[i,j])*15); c:=a; repeat c:=c^.w;{} until (c=nil)or((c^.x=j)and(c^.y=i)); {выводим: К - конь, п - пешка, точка в центре поля - пройденый путь, пробел - ещё не использованая клетка} if (c^.x=j)and(c^.y=i)then Write(chr($fa)) else if (a^.x=j)and(a^.y=i)then Write('K') else if (Px=j)and(Py=i) then Write(chr($af)) else Write(' '); end; TextColor(7);{востанавливаем значения по умолчанию} TextBackGround(0); Writeln; end; readKey;{эта команда только для контроля вывода одного пути или хода} Writeln; end; begin {формируем шахматную доску} for Fx:=1 to n do begin Board[Fx,1]:=odd(Fx); for Fy:=2 to n do Board[Fx,Fy]:=not Board[Fx,Fy-1]; end; {вводим положения фигур} Write('Конь [a1,f5]:'); inpLocation(Fx,Fy);Writeln; {начальная точка} new(a); a^.x:=Fx;{координата по горозонтали} a^.y:=Fy;{координата по вертикали} a^.z:=8;{число ходов для данной точки} a^.w:=nil;{метка конца списка путей} Write('Куда [a1,f5]:'); inpLocation(Fx,Fy);Writeln; Write('Пешка[a1,f5]:'); inpLocation(Px,Py);Writeln; {количество путей} k:=0; repeat {проверяем по ходам для текущего положения} case a^.z of 8:begin new(b); b^.w:=a; b^.x:=a^.x-1; b^.y:=a^.y-2; end; 7:begin new(b); b^.w:=a; b^.x:=a^.x-2; b^.y:=a^.y+1; end; 6:begin new(b); b^.w:=a; b^.x:=a^.x-1; b^.y:=a^.y+2; end; 5:begin new(b); b^.w:=a; b^.x:=a^.x+1; b^.y:=a^.y+2; end; 4:begin new(b); b^.w:=a; b^.x:=a^.x+2; b^.y:=a^.y+1; end; 3:begin new(b); b^.w:=a; b^.x:=a^.x-1; b^.y:=a^.y+2; end; 2:begin new(b); b^.w:=a; b^.x:=a^.x+1; b^.y:=a^.y-2; end; 1:begin new(b); b^.w:=a; b^.x:=a^.x-1; b^.y:=a^.y-2; end; {хода нет, возращаемся назад} 0:begin b:=a; a:=a^.w; dispose(b);{освобождаем память от текущего положения} b:=a; end; end; {если указатели не равны, это значит есть новый ход} if a<>b then begin dec(a^.z);{уменьшаем количество ходов текущего положения} b^.z:=8;{для нового полжения ставим количество ходов} a:=b;{следующее положение} end; {проверяем достигли ли конечной точки} if (a^.x=Fx)and(a^.y=Fy)then begin outLocation;{выводим путь} inc(k);{увеличиваем счетчик путей} b:=a; a^.z:=0;{заканчиваем ход} end; b:=a; {проверяем есть ли повторное попадание на одну клетку} repeat b:=b^.w; until (b=nil)or((b^.x=a^.x)and(b^.y=a^.y)); {если два раза на одной клетке заканчиваем ход} if b<>nil then a^.z:=0; {если вышли за пределы доски заканчиваем ход} if (a^.x<1)or(a^.y<1)or (a^.x>n)or(a^.y>n)or ((a^.x=Px)and(a^.y=Py))then a^.z:=0; {если тут вызывать процедуру outLocation то можно проследить как работает программа в пошаговом режиме} until a=nil;{повторяем в цикле пока не обойдем все возможные комбинации} writeln('Path:',k);{выводим результат} end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 136.233

подскажите пожалуйста как написать прогу : указатель мыши стоит в самом центре экрана, туда пользователь вводит слово,состоящее из восьми символов, затем слово должно появится в самом верхнем левом и правом углах и в самом низу в левом и правом углу... программу надо написать через READKEY.

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

Отвечает: Boriss Здравствуйте, Otherside! Это почти несложно - пример в приложении. Проблема только в одном: при попытке записать что-то в самый правый нижний угол вызывает прокрутку экрана. По этой причине не в самый правый записано. Проблему легко преодолеть записью в видеобуфер. Нужно показать как? Приложение: uses CRT; VAR S: String; ch: Char; BEGIN ClrSCR; GotoXY(40, 12); S:=''; repeat ch:=ReadKey; if (ch >= ' ') then begin S:=S+ch; write(ch) end; until ch = #13; {Код ENTER} GotoXY(1,1); Write(S); GotoXY(81 - length(S), 1); Write(S); GotoXY(1,25); Write(S); GotoXY(80 - length(S), 25); Write(S); END. --------- Вывод - то место в тексте, где вы устали думать

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

Вопрос № 136.250

Уважаемые Эксперты, помогите написать программу. Сведения о подписчиках хранятся в файле, имеющем следующую структуру: индекс издания, наименование издания, период подписки (на ск. месяцев), фамилия подписчика, его адрес, стоимость подписки в месяц, номер почтового отделения связи. Написать программу, формирующую списки подписчиков одного отделения связи.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Кочкарев Владислав Геннадьевич! Решение задачи с пояснениями в приложении. Приложение: uses crt; type Tpodp=record {тип запись с полями по условию} ind:word; izd:string[20]; per:byte; fam:string[20]; adr:string[20]; stm:real; nom:word; end; var sp:array[1..100]of Tpodp;{массив записей, или список} f:file of Tpodp; {типизированный файл} n,i,nos:integer; begin clrscr; assign(f,'podpiska.dat');{создаем файл, даем имя и связываем с переменной} rewrite(f); {открываем для записи} write('Kolichestvo podpischikov='); readln(n); for i:=1 to n do {вводим данные } begin writeln('Podpisctik ',i); write('Index: ');readln(sp[i].ind); write('Izdanie: ');readln(sp[i].izd); write('Period: ');readln(sp[i].per); write('Familia: ');readln(sp[i].fam); write('Adres: ');readln(sp[i].adr); write('Stoimost: ');readln(sp[i].stm); write('Otdelenie: ');readln(sp[i].nom); write(f,sp[i]); {записываем их в файл} end; close(f); {закрываем файл} reset(f); {открываем для чтения} n:=0; while not eof(f) do begin n:=n+1; read(f,sp[n]); {считываем данные в список} end; write('# Otdelenia sviazi:'); readln(nos); writeln; for i:=1 to n do if sp[i].nom=nos then {если № отделения совпадает, выводим данные} begin writeln('Index: ',sp[i].ind,' Izdanie: ',sp[i].izd,' Period: ',sp[i].per,' mes'); {писать в одну строку} writeln('Familia: ',sp[i].fam,' Adres: ',sp[i].adr,' Stoimost: ',sp[i].stm:6:2,' rub'); {писать в одну строку} writeln; end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 11.05.2008, 21:02 Оценка за ответ: 5

Вопрос № 136.291

Уважаемые эксперты! SOS, помогите пожалуйста решить задачи! Нужно сформировать одномерный массив случайных чисел, вывести из него те элементы, которые стоят на позиции представленной собой числам Фибаначи (1, 1, 2, 3, 5, 8, 13, 21, и т. д. ).

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

Отвечает: SHERRY Здравствуйте, Marina korolyova! Решил. Проверял на небольших значениях n - работает. См.приложение. Приложение: const n = 15; {количество элементов массива} var ms: array [1..n] of integer; {собственно - массив} i, sum, a: integer; {вспомогательные переменные} begin randomize; {включаем генератор случайных чисел} for i:=1 to n do {задаём цикл} begin ms[i]:=random(100); {каждому элементу массива присваиваем значения из диапазона 0..99} write(ms[i]:5); {выводим на экран для ясности} end; writeln; sum:=1; i:=1; a:=0; {инициализируем вспомогательные переменные} Repeat {до тех пор, пока число фибоначчи не превысит размер массива - мы выводим на экран элемент массива с номером числа полседовательности Фибоначчи} write(ms[i]:5); i := sum + a; {формируем число из последовательности- каждый последующий элемент = сумма 2-х предыдущих} a:=sum; sum := i; Until i>=n; readln; end. --------- Самурай без меча подобен самураю с мечём, только без меча..

Ответ отправил: SHERRY (статус: 9-ый класс) Ответ отправлен: 11.05.2008, 00:49

Вопрос № 136.305

эксперты, подскажите пожалуйста, как написать это? Программирование с использованием подпрограмм Считать случайную матрицу A=[5X5] из файла, созданную с помощью процедуры random, передать в процедуру, в ней с помощью этой матрицы создать 2 новых матрицы Symm= A+At и AntiSymm= A-At. Эти 2 новые матрицы вернуть в главную программу и распечатать по строкам.

Отправлен: 11.05.2008, 08:55 Вопрос задала: Otherside (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 5)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Otherside! Будем считать, что то условие, которое я предположил, верное. В пользу транспонированной матрицы и то, что легко проверить правильность сложения и вычитания ее с исходной матрицей, прослеживая результаты по всем диагоналям. Тогда код программы с пояснениями в приложении. Если я неправ, то легко поправить программу, заменив транспонированную матрицу на другую. Приложение: uses crt; const n=5; {размерность матриц} type Tmatr=array[1..n,1..n] of integer; var A,At,B,C:Tmatr; {матрицы} f:text; {текстовый файл} i,j:integer; Procedure NewMatr(p:Tmatr;var v,t:tmatr); {Параметры процедуры: входной-исходная матрица из файла; выходные-две матрицы по условию. Транспонированная матрица-локальная переменная, т.к. в программе не используется} var pt:Tmatr; begin {создаем транспонированную матрицу} for i:=1 to n do for j:=1 to n do pt[i,j]:=p[j,i]; {создаем матрицу-сумму} for i:=1 to n do for j:=1 to n do v[i,j]:=p[i,j]+pt[i,j]; {создаем матрицу-разность} for i:=1 to n do for j:=1 to n do t[i,j]:=p[i,j]-pt[i,j]; end; {Начало программы} begin clrscr; randomize; assign(f,'matr_A.txt'); {создаем файл, даем ему имя, если нужно, путь} rewrite(f); {открываем для записи} for i:=1 to n do {создаем матрицу и записываем в файл} begin writeln(f,''); {новая строка} for j:=1 to n do begin a[i,j]:=random(10);{случайное число} write(f,a[i,j]:3); {строка матрицы} end; end; close(f); {закрываем файл} reset(f); {открываем для чтения} while not eof(f) do begin read(f,a[i,j]); {считываем матрицу из файла} end; close(f); {закрываем файл} NewMatr(a,b,c); {вызываем нашу процедуру} writeln('Matrica Summ:'); {выводим на экран матрицу суммы} for i:=1 to n do begin for j:=1 to n do write(b[i,j]:4); writeln; end; writeln('Matrica AntiSumm:'); {выводим на экран матрицу разности} for i:=1 to n do begin for j:=1 to n do write(c[i,j]:4); writeln; end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 11.05.2008, 12:32 Оценка за ответ: 4

Отвечает: Попов Владимир Иванович Здравствуйте, Otherside! Исходный код программы решения вашей задачи - в приложении. Протестирован. Работает. Желаю успехов. Приложение: program matrix5; uses crt; type Tmatrix=array[1..5,1..5] of integer; procedure create_matrix(var xA:Tmatrix); var i,j:byte; begin for i:=1 to 5 do for j:=1 to 5 do xA[i,j]:=random(20)-10; end; procedure transp_matrix(var xA:Tmatrix;var xAt:Tmatrix); var i,j:byte; begin for i:=1 to 5 do for j:=1 to 5 do xAt[i,j]:=xA[j,i]; end; procedure generate_matrix(var xA:Tmatrix;var xAt:Tmatrix;var xS:Tmatrix; var xaS:Tmatrix); var i,j:byte; begin for i:=1 to 5 do for j:=1 to 5 do begin xS[i,j]:=xA[i,j]+xAt[i,j]; xaS[i,j]:=xA[i,j]-xAt[i,j]; end; end; procedure output_matrix(mes:string;var X:Tmatrix); var i,j:byte; begin writeln; writeln(mes); for i:=1 to 5 do begin for j:=1 to 5 do write(' ',X[i,j]:3); writeln; end; end; procedure finish; begin writeln; writeln(' The program was successfully completed !'); writeln; writeln; end; function quit:boolean; var ans:char; begin write(' Again ? (y/n) ---> '); readln(ans); if ans='n' then quit:=true else quit:=false; end; var A,At,Symm,AntiSymm:Tmatrix; begin clrscr; repeat create_matrix(A); transp_matrix(A,At); generate_matrix(A,At,Symm,AntiSymm); output_matrix(' The initial random matrix A is :',A); output_matrix(' The Symm matrix is :',Symm); output_matrix(' The AntiSymm matrix is :',AntiSymm); finish; until quit; end. --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 6-ой класс) Ответ отправлен: 15.05.2008, 19:06

Вопрос № 136.309

Здравствуйте. Подскажите пожалуйста, каким образом можно реализовать программу, которая удваивала бы каждый элемент созданного стека. Спасибо.

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

Отвечает: Попов Владимир Иванович Здравствуйте, GenD0S! Ваша задачка требует такого тактического манёвра : при чтении данных из стека сам стек автоматически уничтожается, поэтому для выполнения операций над элементами стека необходимо промежуточное сохранение значений этих элементов в памяти или на диске. Как раз второй вариант реализован в предложенном решении : созданный стек записывается на диск в типизированный файл f.dat, затем все данные при считывании из этого файла удваиваются и формируют новый стек, который и выводится на экран в качестве ответа. Исходник - в приложении. Протестирован. Работает. Желаю успеха. Приложение: program stack; uses crt; const max=20; type Tptr=^Tstack; Tstack=record data:integer; next:Tptr; end; Tfd=file of integer; procedure create_stack(var xtop:Tptr;var px:integer); begin new(xtop); xtop^.next:=NIL; xtop^.data:=px; end; procedure add_to_stack(var xtop:Tptr;var px:integer); var curr:Tptr; begin new(curr); curr^.next:=xtop; xtop:=curr; xtop^.data:=px; end; procedure take_from_stack(var xtop:Tptr;var px:integer); begin px:=xtop^.data; xtop:=xtop^.next; end; procedure input_data(var xtop:Tptr); label L; var n,x,i:integer; begin L:writeln; write(' How many numbers do you want to input into the stack : n = '); readln(n); if (n<1) or (n>max) then begin writeln(' Error : n must be >=1 and <= ',max); end else begin writeln(' Input your numbers one by one :'); write(' x[1] = '); readln(x); create_stack(xtop,x); for i:=2 to n do begin write(' x[',i,'] = '); readln(x); add_to_stack(xtop,x); end; end; end; procedure save_data(var xtop:Tptr;var pf:Tfd); var x:integer; begin assign(pf,'f.dat'); rewrite(pf); repeat take_from_stack(xtop,x); write(pf,x); until xtop=NIL; close(pf); end; procedure read_and_change_data(var pf:Tfd;var ytop:Tptr); var x,y:integer; begin assign(pf,'f.dat'); reset(pf); read(pf,x); y:=2*x; create_stack(ytop,y); while not(eof(pf)) do begin read(pf,x); y:=2*x; add_to_stack(ytop,y); end; close(pf); erase(pf); end; procedure output_result(var ytop:Tptr); var y,i:integer; begin writeln; writeln(' The changed stack is :'); i:=1; repeat take_from_stack(ytop,y); writeln(' y[',i,'] = ',y); inc(i); until ytop=NIL; end; procedure finish; begin writeln; writeln(' The program was successfully completed !'); write(' Press <Enter> for quit ---> '); readln; end; var f:Tfd; top1,top2:Tptr; begin clrscr; input_data(top1); save_data(top1,f); read_and_change_data(f,top2); output_result(top2); finish; end. --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 6-ой класс) Ответ отправлен: 15.05.2008, 22:03 Оценка за ответ: 5

Вопрос № 136.335

Здравствуйте! У меня осталась последняя задача на Pascal, с которой я не справился, помогите мне, пожалуйста, ее решить. Задача: Дан массив "а" размерностью "М" целых чисел. Получить матрицу в [n,m], каждая строка которой получается возведением в степень, равную номеру этой строки данного массива "а". n - ввести с клавиатуры. Заранее большое спасибо!

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, BOOM! Код программы в приложении. Следует отметить, что при больших n и целых a[i] будут получаться очень большие числа, превышающие размеры Longint. Нужно выбирать либо небольшие целые числа и небольшое n, либо небольшие вещественные числа типа Extented и практически любые n. Соответственно следует следить за форматированием вывода данных, чтобы соблюсти вид нормальной матрицы. В моем примере a[i] от 1 до 5 n я принимал 5. Приложение: uses crt; const m=6; var a:array[1..m]of integer; {массив} b:array[1..10,1..m]of longint; {матрица} i,j,t:integer; p:longint; {произведение} begin clrscr; write('n=');readln(n); writeln('Massiv:'); for i:=1 to m do begin a[i]:=i; write(a[i],' '); end; writeln; for j:=1 to m do for i:=1 to n do begin {Элементам первой строки, т.е. первому элементу каждого столбца, присваиваем значения массива. Затем каждый следующий элемент в столбце получается умножением первого элемента на себя столько раз, каков номер строки.} b[1,j]:=a[j]; p:=1; for t:=1 to i do begin p:=p*b[1,j]; b[i,j]:=p; end; end; writeln('Matrica:'); for i:=1 to n do begin for j:=1 to m do write(b[i,j]:6); writeln; end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 11.05.2008, 16:00

Вопрос № 136.353

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

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Otherside! Смотрите приложение. Программа выводит три окружности и вращает их относительно самой большой из них. Удачи! Приложение: uses Graph,Crt; const Constant=2*pi/360; R0=100; R1=30; var x0,x1,x2,y0,y1,y2,x,y:integer; begin {запускаем графический режим} x0:=detect; InitGraph(x0,y0,''); if GraphResult<>grOk then halt(1); {центр экрана} x0:=GetMaxX div 2; y0:=GetMaxY div 2; Randomize; x:=Random(360);{случайные начальные положения} y:=Random(360); repeat ClearViewPort;{чистим экран} x1:=round(R0 * cos(Constant*x));{считаем координаты} y1:=round(R0 * sin(Constant*x)); x2:=round(R1 * cos(Constant*y)); y2:=round(R1 * sin(Constant*y)); Circle(x0+x1+x2,y0+y1+y2,2);{рисуем круги} Circle(x0+x1,y0+y1,5); Circle(x0,y0,10); x:=(x+1)mod 360;{следующее значения} y:=(y+20)mod 360; until KeyPressed; end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 136.359

Здраствуйте !...Помогите пожалуста построить графически график ф-ии, y=arctg 4x, с диапазонам 0...3 и шагом 0,15.

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Китаев Кирилл Артурович! Программа в приложении. Удачи! Приложение: uses Crt,Graph; const n=3; var i,j:integer; x,yMax,yMin:real; function Fn(x:real):real; begin Fn:=ArcTan(4*x); end; begin {запускаем графический режим} i:=detect; InitGraph(i,j,''); if GraphResult<>grOk then Halt(1); {начальное значение Х, ищем минимальное и максимальное значения} x:=0; yMin:=Fn(x); yMax:=Fn(x); While x<=n do begin if yMin>Fn(x)then yMin:=Fn(x); if yMax<Fn(x)then yMax:=Fn(x); x:=x+0.01; end; {выводим ось У} Line(10,1,10,GetMaxY); {получаем коэфициэнты для графиков} yMax:=abs(yMax-yMin)/(GetMaxY-20); yMin:=n/(GetMaxX-20); {выводим} for i:=0 to GetMaxX-20 do begin {песчитываем в координаты на экране} j:=round(Fn(i*yMin)/yMax); {подсвечиваем каждое 0.15 значение Х} if(round(int(i*yMin*100))mod 15)=0 then Circle(i+10,GetMaxY-j-10,1); {выводим сам график} PutPixel(i+10,GetMaxY-j-10,14); {ось Х} if Fn(i*yMin)=0 then begin {выводим ось Х} Line(1,GetMaxY-round(Fn(i*yMax)/yMax)-10,GetMaxX,GetMaxY-round(Fn(i*yMin)/yMax)-10); SetLineStyle(4,1,1); {выводим точки равные целым значениям} for j:=1 to n do begin Circle((j*(GetMaxX-20) div n)+10,GetMaxY-round(Fn(i*yMax)/yMax)-10,2); Line((j*(GetMaxX-20) div n)+10,1,(j*(GetMaxX-20) div n)+10,GetMaxY); end; end; end; ReadKey; end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 136.373

Здравствуйте. Мне надо, чтобы программа считывала информацию из файла на русском языке. Когда использую стандартные функции read(readln), то считывается какая-то ерунда (то греческие символы, то русские, но не те). Видимо он считывает в другой кодировке. Как мне это исправить? Спасибо.

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

Отвечает: Fenixk19 Здравствуйте, Asteriks! Все правильно сказал товарищ Boriss в коментах. Хочу дополнить, что можно пойти другим путем, и перевести текстовый файл в кодировку dos(ibm866), воспользовавшись текстовым редактором с возможностью перекодировки(кажется, так умеет Notepad++).

Ответ отправил: Fenixk19 (статус: 3-ий класс) Ответ отправлен: 12.05.2008, 01:44 Оценка за ответ: 5

Вопрос № 136.412

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

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Трошин Евгений Александрович! Создайте текстовый файл и заполните его целыми числами в строчку через пробелы. Присвойте ему имя и сохраните, лучше в той же директории, что и программа, тогда не надо будет указывать путь к файлу. Код программы в приложении. Приложение: uses crt; var f:text; a,b,max,min,rez:integer; begin clrscr; assign(f,'chisla.txt'); {связываем файл с переменной} reset(f); {открываем для чтения} min:=maxint;max:=-maxint; {самое маленькое и самое большое число} while not eof(f) do begin read(f,a); {считываем число, если больше максимального, то макс присваиваем это число, если меньше мин, то мин присваиваем это число} if a<min then begin min:=a; end else if a>max then begin max:=a; end; write(a,' '); {выводим на экран, не обязательно} end; close(f); writeln; writeln('max=',max,' min=',min); {не обязательно} writeln('Raznost max-min=',max-min); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 12.05.2008, 20:21

Вопрос № 136.425

Помогите пожалуйста с программой. Условие: Задаем размеры массива , например n=6 m=8 Строим начальную матрицу (заполняем подряд числами по строкам) {используя только цикл for и условие If} | 1 2 3 4 5 6 7 8| | 9 10 11 12 13 14 15 16| A=|17 18 19 20 21 22 23 24| |25 26 27 28 29 30 31 32| |33 34 35 36 37 38 39 40| |41 42 43 44 45 46 47 48| 1) Используя оператор цикла for и условия If получить из данной матрицы А следующую матрицу (заполнение улиткой) | 1 2 3 4 5 6 7 8| |24 25 26 27 28 29 30 9| A=|23 40 41 42 43 44 31 10| |22 39 48 47 46 45 32 11| |21 38 37 36 35 34 33 12| |20 19 18 17 16 15 14 13| 2) Аналогично, только заполняем зигзагом | 1 2 6 7 15 16 27 28| | 3 5 8 14 17 26 29 38| A=| 4 9 13 18 25 30 37 39| |10 12 19 24 31 36 40 45| |11 20 23 32 35 41 44 46| |21 22 33 34 42 43 47 48|

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Константин Шипилов! Все три задачи выполняются последовательно. Вопросы по программе задавайте в мини-форум. Удачи! Приложение: const n=6;m=8; var a:array[1..n,1..m]of integer; k,x,y,z:integer; {проверка диапазона } procedure check(var i,j:integer;s:integer); begin if i=0 then inc(i) else if i>s then begin i:=s; j:=j+2; end; end; {} procedure outMassiv; begin for x:=1 to n do begin for y:=1 to m do write(a[x,y]:3); writeln; end; writeln; end; begin {задача 1 формируем массив} for x:=1 to n do for y:=1 to m do a[x,y]:=(x-1)*m +y; outMassiv; {задача 2 начальные значения координат} x:=1; y:=1; k:=0;{начальное значение конечного автомата} for z:=1 to n*m do begin a[x,y]:=z;{присваеиваем значение} {конечный автомат} case k mod 4 of 0:begin{увеличиваем У и проверяем условие переключения автомата} inc(y); if y=(m-x+1)then inc(k); end; 1:begin{увеличиваем Х и упроверяем условие переключения автомата} inc(x); if(n-x)=(m-y)then inc(k); end; 2:begin{уменьшаем У и проверяем условие переключения автомата} dec(y); if(n-x+1)=y then inc(k); end; 3:begin{уменьшаем Х и проверяем условие переключения автомата} dec(x); if(x-1)=y then inc(k); end; end; end; outMassiv; {задача 3} {начальные значиения} x:=1; y:=1; k:=1;{коэфициент перрключения} {перебираем все номера} for z:=1 to n*m do begin a[x,y]:=z; {следующие координаты} x:=x-k; y:=y+k; {сдедующая строка эквивалентна if (x=0)or(y=0)or(x>n)or(y>n) then k:=-k;} k:=k*(1-2*ord((x=0)or(y=0)or(x>n)or(y>m))); {корректируем координаты} if odd(z)then begin check(x,y,n); check(y,x,m); end else begin check(y,x,m); check(x,y,n); end; end;{выводим результат} outMassiv; end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 136.457

Составить программу создающую файл из 10 значений типа integer. Прочитать файл и вычислить сумму его элементов.

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

Отвечает: Попов Владимир Иванович Здравствуйте, Cobain! Ваша задача требует организации трёх процедур : создания типизированного файла и записи в него чисел, введённых с клавиатуры; считывания данных из файла с их сохранением в некотором числовом массиве; подсчёта суммы элементов сформированного массива и вывода её значения на экран. Исходный код программы - в приложении. Протестирован. Работает. Желаю успеха. Приложение: program wfile; uses crt; type Tdf=file of integer; Tmassiv=array[1..10] of integer; procedure create_file(var xf:Tdf); var i:byte; px:Tmassiv; begin assign(xf,'my_file.dat'); rewrite(xf); writeln; writeln(' Input 10 integer numbers :'); for i:=1 to 10 do begin write(' x[',i,'] = '); readln(px[i]); write(xf,px[i]); end; close(xf); writeln(' Your numbers were written to the file <my_file.dat>'); end; procedure read_file(var xf:Tdf;var xm:Tmassiv); var i:byte; begin writeln; writeln(' The reading list of file datas is :'); assign(xf,'my_file.dat'); reset(xf); for i:=1 to 10 do begin read(xf,xm[i]); write(' ',xm[i]); end; close(xf); writeln; end; procedure summ(var xm:Tmassiv;var xs:integer); var i:byte; begin xs:=0; for i:=1 to 10 do xs:=xs+xm[i]; writeln; writeln(' The summ of your numbers is S = ',xs); end; procedure finish; begin writeln; writeln(' The program was successfully completed !'); write(' Press <Enter> for quit ---> '); readln; end; var f:Tdf; m:Tmassiv; s:integer; begin clrscr; create_file(f); read_file(f,m); summ(m,s); finish; end. --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 6-ой класс) Ответ отправлен: 16.05.2008, 19:45

Вопрос № 136.458

Вычислить гипотенузу и площадь прямоугольного треугольника по значению катаетов

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

Отвечает: Попов Владимир Иванович Здравствуйте, Cobain! Исходный код вашей программки - в приложении. Проверен. Желаю удачи. Приложение: program triangle; uses crt; var a,b,c,p,S:real; begin clrscr; writeln; write(' Input the values of <a> & <b> : '); readln(a,b); c:=sqrt(a*a+b*b); writeln(' c = ',c:7:2); p:=(a+b+c)/2; s:=sqrt(p*(p-a)*(p-b)*(p-c)); writeln(' S = ',S:7:2); writeln; write(' That is all. Press <Enter> for quit - '); readln; end. --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 6-ой класс) Ответ отправлен: 16.05.2008, 20:08

Вопрос № 136.459

Вывести массив(не более 20 элементов) и определить есть ли в нем элементы с одинаковыми значениями

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Cobain! Смотрите приложение. Изменяя константу К Вы можете получать различные результаты. Удачи! Приложение: const n=20; k=40; var a:array[1..n]of integer; b,c:integer; d:boolean; begin randomize; d:=false; for b:=1 to n do begin a[b]:=random(k); write(a[b]:4); c:=1; while c<b do begin if a[c]=a[b] then d:=true; inc(c); end; end; writeln; writeln(d); end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 136.460

Вывести 2 числа. Преобразовать числа в строки, объединить их и вывести на экран

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Cobain! Программа в приложении. Преобразование числа в строку выполняет рекурсивная функция NumberToString. Если нужно без рекурсии обращайтесь в мини-форум вопроса. Удачи! Приложение: var a:string; b:integer; {рекурсивная функция вызывает сама себя с новыми значениями} function NumberToString(n:integer):string; begin if n>0 {вызываем саму себя и добавляем в конец программы младшую цифру} then NumberToString:=NumberToString(n div 10)+chr((n mod 10)+48) {число равно 0 возвращаем пустую строку} else NumberToString:=''; end; begin a:=''; {вводим первое число} write('enter num A:'); readln(b); a:=a+NumberToString(b); {вводим второе число} write('enter num B:'); readln(b); a:=a+' '+NumberToString(b); {выводим результат} writeln(a); end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 136.462

создать 2-х мерный массив, имеющий 4 строки и 3 столбца. Найти в нем максимальный элемент и вывести его местоположение в массиве

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

Отвечает: Delph Здравствуйте, Cobain! Программа в приложении. Переменные Min и Max задают минимальное и максимальное значения для элементов массива. Приложение: Program Pr136462; Uses CRT; Const M = 4; N = 3; Var Min, Max, i, j, Mi, Mj: Integer; Arr: Array[1..M, 1..N] of Integer; Begin ClrScr; Randomize; Min := -10; Max := 10; Mi := 1; Mj := 1; WriteLn('Исходный случайно сформированный массив:'); for i := 1 to M do begin for j := 1 to N do begin Arr[i, j] := Random(Max - Min + 1) + Min; Write(Arr[i, j]: 5); if Arr[i, j] > Arr[Mi, Mj] then begin Mi := i; Mj := j; end; end; WriteLn; end; WriteLn; WriteLn('Максимальный элемент: строка #', Mi, ', столбец #', Mj); ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 12.05.2008, 14:51

Вопрос № 136.463

Найти наибольшее из 6 чисел, введеных с клавиатуры

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

Отвечает: Coupler Здравствуйте, Cobain! Решение задачи в приложении. Только я советую решать подобное самому - на таких задачах учатся. Приложение: program Project2; var i, n, max:integer; begin for i:=1 to 6 do begin writeln ('Введите число'); readln (n); if (n>max) or (i=1) then max:=n; end; writeln (max); readln; end.

Ответ отправил: Coupler (статус: Специалист) Ответ отправлен: 12.05.2008, 14:06

Вопрос № 136.464

Создать программу создающую файл из 25 случайных значений типа integer в диапазоне 0 ... 300. Вывести файл на экран

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Cobain! Программа в приложении. Код простой, поэтому в комментариях нет необходимости. Удачи! Приложение: var a,b:integer; c:file of integer; begin assign(c,'q136464.dat'); rewrite(c); for a:=1 to 25 do begin b:=random(300); write(c,b); end; reset(c); while not(eof(c)) do begin read(c,a); write(a:16); end; close(c); end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 136.465

ввести с клавиатуры элементы матрицы 3х3. Вывести на экран исходную матрицу, каждый элемент которой умножен на 3

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

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Cobain! Задача с комментариями в приложении. Удачи!!! Приложение: Const {Размер матрицы} n=3; m=3; var {Сама матрица} Matrix: array [1..N, 1..M] of integer; {Счетчики для For} i, j: integer; begin {Получаем матрицу} WriteLn('Введите матрицу: '); for i:=1 to N do for J:=1 to M do begin Write('Элемент № [', i, ',', j,']: '); ReadLn(Matrix[i, j]); end; WriteLn('Рез-тат: '); {В цикле перебираем всю матрицу} for i:=1 to N do begin for j:=1 to M do {Выводим тек. эл. умноженыый на 3} Write(Matrix[i, j]*3:3); {Начинаем новую строку} WriteLn; end; readln; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: Студент) Ответ отправлен: 12.05.2008, 22:02

Вопрос № 136.467

Составить программу, которая создает пустой файл, переименовывает его, а потом уничтожает

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

Отвечает: Coupler Здравствуйте, Cobain! Решение задачи в приложении. Приложение: program Project1; var f:file; begin assign (f, '123.txt'); rewrite (f);{если файла не существует, rewrite создаст его} closefile (f); rename (f, '321.txt'); erase (f); end.

Ответ отправил: Coupler (статус: Специалист) Ответ отправлен: 12.05.2008, 14:22

Вопрос № 136.469

Вычислить длину окружности и площадь круга, если известен диаметр

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

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Cobain! Задача с пояснениями в приложении. Площадь вычисляется так: s=П*r*r(П-число Пи). П можно получит с помощью функции Pi. Окружность: l=2*П*r. Радиус равен половине диаметра. Удачи!!! Приложение: var {d-диаметр, s-площадь, l-длина,r-радиус} D, S, l, r: real; begin {Получаем диаметр} Write('Введите диаметр: '); ReadLn(D); {Вычисляем радиус, площадь и длину} r:=d/2; s:=Pi*r*r; l:=Pi*2*r; {Вывод} WriteLn('Длина окружности: ', l:3:3); WriteLn('Площадь круга: ', S:3:3); ReadLn; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: Студент) Ответ отправлен: 12.05.2008, 21:51

Вопрос № 136.470

Вычислить площадь треугольника по координатам его вершин

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

Отвечает: Delph Здравствуйте, Cobain! Программа в приложении. Комментарии по ходу программы подскажут, что к чему. Приложение: { Нахождение площади треугольника по известным координатам его вершин } Program Pr135680_2; Uses CRT; { Формула Герона } function Gerone(a, b, c: Real): Real; var p: Real; begin p := (a + b + c) / 2; { полупериметр } Gerone := Sqrt(p * (p - a) * (p - b) * (p - c)); end; { новый тип - для вершин треугольника } type TPixel = record x, y: Real; end; { Процедура ввода вершины треугольника (как обычной точки), выводящая подсказки для пользователя } Procedure PixelInput(PixelName: String; var Pixel: TPixel); begin if PixelName <> '' then WriteLn('Введите точку ', PixelName, ':'); Write(' x = '); ReadLn(Pixel.x); Write(' y = '); ReadLn(Pixel.y); end; { Расчёт длины отрезка (стороны треугольника) по известным вершинам концов } function SideLen(p1, p2: TPixel): Real; begin SideLen := Sqrt(SQR(p2.x - p1.x) + SQR(p2.y - p1.y)); end; var Pa, Pb, Pc: TPixel; a, b, c, S: Real; Begin ClrScr; PixelInput('A', Pa); PixelInput('B', Pb); PixelInput('C', Pc); WriteLn; a := SideLen(Pb, Pc); b := SideLen(Pa, Pc); c := SideLen(Pa, Pb); S := Gerone(a, b, c); Write('Площадь треугольника равна '); { Если площадь невелика, выводим её в привычном виде } if S < 10000 then WriteLn(S:10:5) else WriteLn(S); ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 12.05.2008, 14:13

Вопрос № 136.471

Найти в одномерном массиве 2 элеметна, сумма которых максимальна

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Cobain! В приложении программа. Удачи! Приложение: const n=15; var a:array[1..n]of integer; b,c,d,e:integer; begin {создаем и выводим массив} randomize; for b:=1 to n do begin a[b]:=random(98)+1; write(a[b]:4); end; writeln; {пока считаем максимальная сумма a[1] и a[2]} d:=1; e:=2; {ищем максимальную пару} for b:=1 to n-1 do for c:=b+1 to n do if(a[b]+a[c])>(a[d]+a[e])then begin d:=b; e:=c; end; {выводим результат} writeln((a[d]+a[e]):5,'=':2,a[d]:3,'+':2,a[e]:3); end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 136.472

Составить программу, которая создает файл следуещей структуры: № по порядку ФИО № телефона Ввести 5 записей и вывести файл на экран

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

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Cobain! Задачи с пояснениями в приложении. Удачи!!! Приложение: type {Тип для создания типизированого файла} OurFile = record {Номер записи} num: integer; {ФИО} FIO: string; {Номер телефона} Phone: string; end; const {кол-во записей в файле} N=5; var {Объявляем типизированный файл} DataFile: file of OurFile; {Счетчик для For} i: integer; {Переменная тип OurFile} Rec: OurFile; begin {Связываем переменную с файлом} assign(DataFile,'data.txt'); {Открываем для перезаписи} ReWrite(datafile); {Цикл заполнения файла} for i:=1 to N do begin {Выводим номер записи} WriteLn('Запись №', i); {Сохраняем в переменную Rec} Rec.num:=i; {Получаем ФИО и сохраняем его в пременную того же типа какой у файла} Write('ФИО: '); ReadLn(Rec.FIO); {Получаем телефон} Write('Номер телефона: '); ReadLn(Rec.Phone); {Записываем заполненную переменную в файл} Write(DataFile, Rec); end; {для чтения} reset(DataFile); WriteLn('Содержимое файла: '); {Цикл чтения файла} for i:=1 to N do begin {Получаем очередную запись} read(DataFile, Rec); {Выводим содержимое на экран} WriteLn('Ноиер записи: ', Rec.num); WriteLn('ФИО: ', Rec.FIO); WriteLn('Номер телефона: ', Rec.Phone); end; {Закрываем файл} close(dataFile); ReadLn; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: Студент) Ответ отправлен: 12.05.2008, 21:32

Вопрос № 136.473

Составить программу вычисления кол-ва слов в строке. Слова разделены 1 пробелом

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

Отвечает: Disasm Здравствуйте, Cobain! Если без дополнительных проверок, т.е. условие строго выполняется: 1. Слова разделены только 1 пробелом. 2. В конце строки нет пробела. То программа будет такая. Приложение: Program Poisk_slov; USES CRT; Var S : String; { Исходная строка } i : Byte; { Переменная цикла } k : Byte; { Переменная количества слов в строке } begin ClrScr; WriteLn('Vvedite slova cherez probel:'); Read(S); { Вводим исходную строку } For i:= 1 to Length(S) do { В цикле перебираем по одному символу всю строку } if S[i]=' ' then k:=k+1 { Если очередной символ пробел, то увеличиваем счетчик k на 1 } k :=k+1; { Увеличиваем счетчик k на 1 для правильного счета } WriteLn('Всего в строке ',k,' слов'); end.

Ответ отправил: Disasm (статус: 1-ый класс) Ответ отправлен: 12.05.2008, 15:54

Вопрос № 136.490

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

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Ласточка! Решение задачи с пояснениями в приложении. Приложение: uses crt; var s,s1,s2:string; {строки} i,t,c:integer; mn:set of '0'..'9'; {множество} begin clrscr; write('s: ');readln(s); s1:='';mn:=[]; {пустая строка и пустое множество} for i:=1 to length(s) do {если цифра и еще такой небыло} if (s[i] in['0'..'9'])and not(s[i] in mn) then begin s1:=s1+s[i]; {добавляем цифру в новую строку} include(mn,s[i]); {добавляем ее во множество} end; s2:=s1[1];i:=2; {присваиваем новой строке первую цифру} while i<=length(s1) do begin if s1[i]>s1[i-1] then {начиная со второй проверяем пока цифры возрастают} begin s2:=s2+s1[i]; {если да, вставляем в строку S2.} i:=i+1; {переходим к следующей} end else i:=i+1; end; val(s2,t,c); {превращаем строку в число} writeln('Rezultat=',t*5); {выводим результат, умноженный на 5} readln

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 12.05.2008, 18:26 Оценка за ответ: 5 Комментарий оценки: Огромное спасибо за ответ! Вы мне очень помогли!!!

Вопрос № 136.510

Здравствуйте! У меня программа, которая считает сумму всех элементов массива, перемножает все элементы, находит среднее арифметическое. Сумму и произведение всех элементов массива она считает правильно, а среднее арифметическое неправильно, правда, среднее арифметическое у меня в модуле. Вместо среднего арифметического она выдает какую-то чушь. Язык программирования: Pascal. Скажите, пожалуйста, почему среднее арифметическое неправильно считается ? Модуль и прога в приложении. Большое спасибо! Приложение: Программа: uses crt, universal; var a:mas; av:real; const n=10; procedure massiv; var i,n:integer; av,sum,um:real; begin write ('Vvedite razmernost massiva: '); readln (n); for i:=1 to n do begin write ('Vvedite el massiva: '); readln (a[i]); end; sum:=0; um:=1; for i:=1 to n do begin sum:=sum+a[i]; um:=um*a[i]; end; average (av,i,a); writeln ('Summa el massiva: ',sum:0:1); writeln ('Proizvedenie el massiva: ',um:0:1); write ('Srednee arifmet: ',av:0:1); readln; end; begin clrscr; massiv; end. Модуль: unit universal; interface const n=10; type mas= array [1..n] of real; var a:mas; procedure slogenie (var a,b,c:real); procedure vich (var a,b,c:real); procedure umnog (var a,b,c:real); procedure delenie (var a,b,c:real); procedure average (var av:real; i:integer; a:mas); procedure stepen (var y,x:real); implementation procedure slogenie (var a,b,c:real); begin write ('Vvedite 1 4islo: '); readln(a); write ('Vvedite 2 4islo: '); readln (b); c:=a+b; writeln; write ('Summa 4isel: ',c); end; procedure vich (var a,b,c:real); begin write ('Vvedite 1 4islo: '); readln (a); write ('Vvedite 2 4islo: '); readln (b); c:=a-b; write ('Raznost: ',c); end; procedure umnog (var a,b,c:real); begin write ('Vvedite 1 4islo: '); readln (a); write ('Vvedite 2 4islo: '); readln (b); c:=a*b; write ('Proizvedenie: ',c); end; procedure delenie (var a,b,c:real); begin write ('Vvedite 1 4islo: '); readln (a); write ('Vvedite 2 4islo: '); readln (b); c:=a/b; write ('Chastnoe: ',c); end; procedure average (var av:real; i:integer; a:mas); begin av:=0; for i:=1 to n do av:=av+a[i]; av:=av/n; end; procedure stepen (var y,x:real); begin write ('Vvedite 4islo: '); readln (x); write ('Vvedite stepen: '); readln (y); y:=EXP(LN(x)*y); writeln; write ('Rezultat: ',y:2:2); readln; end; end.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, BOOM! procedure average (var av:real; i:integer; a:mas); begin av:=0; for i:=1 to n do av:=av+a[i]; av:=av/n; В параметры процедуры нужно не i а n, т.е. procedure average (var av:real; n:integer; a:mas); var i:integer; begin av:=0; for i:=1 to n do av:=av+a[i]; av:=av/n; Тогда в программе average (av,n,a);

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 12.05.2008, 18:23 Оценка за ответ: 5 Комментарий оценки: Огромное спасибо!

Вопрос № 136.529

Здравствуйте! Решите пожалуйста задачу! Дан текстовый файл, содержащий целые числа. Найти количество отрицательных чисел.

Отправлен: 12.05.2008, 20:08 Вопрос задал: Аксютчев Иван Владимирович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Николай Владимирович / Н.В. Здравствуйте, Аксютчев Иван Владимирович! Программа в приложении. Исходные данные должны быть записаны в файле "input.txt". Удачи! Приложение: var f : textfile; a : integer; res : integer; begin Assign(f,'input.txt'); Reset(f); res := 0; while not EOF(f) do begin Read(f,a); if a < 0 then inc(res); end; WriteLn('Otricatelnyh chisel: ',res); end.

Ответ отправил: Николай Владимирович / Н.В. (статус: Профессор) Россия, Москва WWW: nvsoft.org ICQ: 420720 ---- Ответ отправлен: 12.05.2008, 21:05 Оценка за ответ: 5

Вопрос № 136.537

даны действительные числа x, y, z. получить max(x,y,z) и min (x,y,z) язык turbo pascal

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

Отвечает: Николай Владимирович / Н.В. Здравствуйте, Saske! Программа в приложении. Функции max и min возвращают соответственно максимальное и минимальное значения из двух указанных чисел. Далее с их помощью минимальное из первых двух чисел сравнивается с третьим числом и выводится результат. Пишите, если будут вопросы. Удачи! Приложение: function max(a,b:real):real; begin if a >= b then max := a else max := b; end; function min(a,b:real):real; begin if a <= b then min := a else min := b; end; var x,y,z : real; begin WriteLn('Input x,y,z:'); ReadLn(x,y,z); writeln('max:',max(max(x,y),z)); writeln('min:',min(min(x,y),z)); ReadLn; end.

Ответ отправил: Николай Владимирович / Н.В. (статус: Профессор) Россия, Москва WWW: nvsoft.org ICQ: 420720 ---- Ответ отправлен: 12.05.2008, 20:58 Оценка за ответ: 5 Комментарий оценки: Спасибо огромное

Вопрос № 136.546

Решите задачу. Дана строка. Подсчитать количество символов в данной строке.

Отправлен: 12.05.2008, 21:01 Вопрос задал: Аксютчев Иван Владимирович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 9)

Отвечает: Николай Владимирович / Н.В. Здравствуйте, Аксютчев Иван Владимирович! Для определения количества символов в строке (длины строки) есть функция length(). var s : string; begin   WriteLn('input string');   ReadLn(s);   WriteLn(length(s));   ReadLn; end. Если нужно что-то другое, уточните, пожалуйста, задачу в мини-форуме. Удачи!

Ответ отправил: Николай Владимирович / Н.В. (статус: Профессор) Россия, Москва WWW: nvsoft.org ICQ: 420720 ---- Ответ отправлен: 12.05.2008, 21:09 Оценка за ответ: 1

Вопрос № 136.554

Сдравствуйте уважаемые эксперты! Помогите пожалуйста с задачей : нужно написать программу, которая бы выдавала на экране пирамиду с квадратным основанием. Основание пирамиды параллельно плоскости XOZ. Одна из граней параллельна оси OZ. При этом, чтоб в пирамиде было заштрихованое сечение параллельное основанию. (Параметры задаваемые пользователем: h - высота пирамиды, hs - расстояние от основания до сечения, d - расстояние от плоскости XOZ до основания). Зарание спасибо!

Отправлен: 12.05.2008, 21:46 Вопрос задал: Якушев Алексей Павлович (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Зенченко Константин Николаевич Здравствуйте, Якушев Алексей Павлович! Программа в приложении. Выводятся оси координат, пирамида и сечение. Один из углов основания пирамиды находится на оси ОY. Удачи! Приложение: uses Graph,Crt; const a=5;{сторона основания пирамиды} k=15;{коэфициэнт} var a_x,a_y,b_x,b_y,c_x,c_y,d_x,d_y,e_x,e_y:integer;{координаты пирамиды} f_x,f_y,g_x,g_y,h_x,h_y,i_x,i_y:integer;{координаты сечения} d,h,hs,x_m,y_m:integer;{вводимые значения и размер экрана } x_y:real;{отношение размеров экрана} begin {вводим значения} write('h :');readln(h); write('hs:');readln(hs); write('d :');readln(d); {переходим в графический режим} x_m:=detect; InitGraph(x_m,y_m,''); if GraphResult<>GrOk then Halt(1); {получаем размер экрана} x_m:=GetMaxX; y_m:=GetMaxY; x_y:=x_m/y_m; {считаем точки основания пирамиды} a_x:= x_m div 2; a_y:= y_m div 2; b_x:=a_x - k*round(a*x_y); b_y:=a_y + k*a+round(a / x_y); c_x:=b_x + k*round(a * x_y * x_y); c_y:=b_y; d_x:=a_x + k*round(a * x_y * x_y); d_y:=a_y; {считаем вершину пирамиды} e_x:=a_x + (abs(a_x - c_x) div 2); e_y:=a_y + (abs(a_y - c_y) div 2) -k*h; {считаем точки сечения} f_x:=e_x - round((h-hs)*(abs(a_x-c_x)div 2)/h); f_y:=e_y + k * (h - hs) - round((h-hs)*(abs(a_y-c_y)div 2)/h); g_x:=e_x - round(((h-hs)*(abs(b_x-d_x)div 2)/h)) ; g_y:=e_y + k * (h - hs) + round((h-hs)*(abs(b_y-d_y)div 2)/h); h_x:=e_x + round((h-hs)*(abs(a_x-c_x)div 2)/h); h_y:=e_y + k * (h - hs)+round((h-hs)*(abs(a_y-c_y)div 2)/h); i_x:=e_x + round(((h-hs)*(abs(b_x-d_x)div 2)/h)); i_y:=e_y + k * (h - hs) - round((h-hs)*(abs(b_y-d_y)div 2)/h); {выводим координатные оси} SetColor(1); MoveTo(a_x,a_y+k*d); LineRel(0,-3*k*a); MoveTo(a_x,a_y+k*d); LineRel(3*k*a,0); MoveTo(a_x,a_y+k*d); LineRel(-3*k*a,round(3*k*a/x_y)); {выводим координатную сетку по осям} for h:=0 to 3*a do begin SetColor(2); Circle(a_x,a_y+(d-h)*k,1); Circle(a_x+h*k,a_y+k*d,1); Circle(a_x-h*k,a_y+k*d+(round(k*h/x_y)),1);{} end; {выводим задний план пирамиды, который будет закрашиватся} SetColor(15); MoveTo(b_x,b_y); LineTo(a_x,a_y); lineTo(e_x,e_y); lineTo(d_x,d_y); LineTo(a_x,a_y); {выводим сечение и закрашиваем его} SetColor(13); MoveTo(f_x,f_y); LineTo(g_x,g_y); LineTo(h_x,h_y); LineTo(i_x,i_y); LineTo(f_x,f_y); SetFillStyle(5,13); FloodFill(f_x+5,f_y+5,13); {выводим передний план пирамиды} SetColor(15); MoveTo(d_x,d_y); LineTo(c_x,c_y); LineTo(b_x,b_y); LineTo(e_x,e_y); LineTo(c_x,c_y); {подписываем оси координат} OutTextXY(a_x-k,k*(1+d),'Y'); OutTextXY(a_x+3*k*a,a_y+k*(1+d),'X'); OutTextXY(a_x-3*a*k,a_y+k*round((d+3*a)/x_y),'Z'); {любуемся} ReadKey; CloseGraph; end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 14.05.2008, 16:34 Оценка за ответ: 4

Отвечает: Николай Владимирович / Н.В. Здравствуйте, Якушев Алексей Павлович! Программа с комментариями в приложении. Все геометрические вычисления делал на бумаге - если они будут нужны, могу передать. Если будут какие-либо вопросы, пишите в мини-форум. Удачи! Приложение: Uses crt,graph; const x0 = 300; { левая нижняя координата основания } y0 = 300; L = 80; { длина стороны основания } ds = 5; { расстояние между линиями штриховки } Var i,driver,mode:integer; d, h, hs : integer; { параметры пирамиды, вводимые пользователем } dx, dx1 : integer; xs, ys : integer; { левая нижняя координата сечения } L2 : integer; { длина стороны сечения } begin { d := 50; h := 100; hs := 30; } Write('ВВедите высоту пирамиды: h='); ReadLn(h); Write('ВВедите расстояние от плоскости основания до сечения пирамиды: hs='); ReadLn(hs); Write('ВВедите расстояние от плоскости XOZ до основания пирамиды: d='); ReadLn(d); ClrScr; DetectGraph(driver,mode); InitGraph(driver,mode,'BGI'); { устанавливаем белый цвет } setcolor(15); { рисуем ось OX } MoveTo(x0+round(sqrt(2)*L/2), y0-round(sqrt(2)*L/2) + d); LineTo(x0+L*2, y0-round(sqrt(2)*L/2) + d); { рисуем стрелочку } LineTo(x0+L*2 -5, y0-round(sqrt(2)*L/2) + d-round(5*cos(pi/3))); LineTo(x0+L*2 -5, y0-round(sqrt(2)*L/2) + d+round(5*cos(pi/3))); LineTo(x0+L*2, y0-round(sqrt(2)*L/2) + d); { рисуем ось OY } MoveTo(x0+round(sqrt(2)*L/2), y0-round(sqrt(2)*L/2) + d); LineTo(x0+round(sqrt(2)*L/2), y0-round(sqrt(2)*L/2) - h - 10); { рисуем стрелочку } LineTo(x0+round(sqrt(2)*L/2)-round(5*cos(pi/3)), y0-round(sqrt(2)*L/2) - h - 10 +5); LineTo(x0+round(sqrt(2)*L/2)+round(5*cos(pi/3)), y0-round(sqrt(2)*L/2) - h - 10 +5); LineTo(x0+round(sqrt(2)*L/2), y0-round(sqrt(2)*L/2) - h - 10); { рисуем ось OZ } MoveTo(x0+round(sqrt(2)*L/2), y0-round(sqrt(2)*L/2) + d); LineTo(x0-round(L*sqrt(2)/4), y0+round(sqrt(2)*L/4) + d); { рисуем стрелочку } LineTo(x0-round(L*sqrt(2)/4)+2, y0+round(sqrt(2)*L/4) + d - 5); LineTo(x0-round(L*sqrt(2)/4)+5, y0+round(sqrt(2)*L/4) + d-2); LineTo(x0-round(L*sqrt(2)/4), y0+round(sqrt(2)*L/4) + d); { подписываем оси } setcolor(10); OutTextXY(x0+round(sqrt(2)*L/2), y0-round(sqrt(2)*L/2) + d+5, '0'); OutTextXY(x0+L*2+5, y0-round(sqrt(2)*L/2) + d,'x'); OutTextXY(x0+round(sqrt(2)*L/2)+5, y0-round(sqrt(2)*L/2) - h - 10,'y'); OutTextXY(x0-round(L*sqrt(2)/4)+5, y0+round(sqrt(2)*L/4) + d,'z'); { устанавливаем желтый цвет } setcolor(14); { рисуем квадратное основание } MoveTo(x0,y0); SetLineStyle(1, 0, 2); { устанавливаем стиль линии (пунктирная) } LineTo(x0+round(sqrt(2)*L/2), y0-round(sqrt(2)*L/2)); LineTo(x0+round(sqrt(2)*L/2)+L, y0-round(sqrt(2)*L/2)); SetLineStyle(0, 0, 2); { устанавливаем стиль линии (обычная) } LineTo(x0+L, y0); LineTo(x0, y0); { вершиной будем считать точку, которая проецируется с середину первого ребра} { рисуем все боковые ребра пирамиды (вершины квадрата, лежащего в основании) } MoveTo(x0+round(sqrt(2)*L/4), y0-round(sqrt(2)*L/4)-h); LineTo(x0, y0); MoveTo(x0+round(sqrt(2)*L/4), y0-round(sqrt(2)*L/4)-h); SetLineStyle(1, 0, 1); { устанавливаем стиль линии (пунктирная) } LineTo(x0+round(sqrt(2)*L/2), y0-round(sqrt(2)*L/2)); SetLineStyle(0, 0, 1); { устанавливаем стиль линии (обычная) } MoveTo(x0+round(sqrt(2)*L/4), y0-round(sqrt(2)*L/4)-h); LineTo(x0+round(sqrt(2)*L/2)+L, y0-round(sqrt(2)*L/2)); MoveTo(x0+round(sqrt(2)*L/4), y0-round(sqrt(2)*L/4)-h); LineTo(x0+L, y0); { устанавливаем цвет } setcolor(12); { рассчитываем точки, в которых сечение пересекает ребра пирамиды } dx := round(hs*L*sqrt(2)/4/h); { расстояние, на которое надо сдвинуться по оси Ox вправо относительно левой нижней точки основания пирамиды } dx1 := round( hs*L*sqrt(5)/2/h/sqrt(2) ); { расстояние, на которое надо сдвинуться по оси Ox влево относительно правой нижней точки основания пирамиды } L2 := L - round(dx1*cos(pi/6)) - dx; { длина стороны квадрата в сечении } { рисуем сечение } xs := x0 + dx; { координата x левой нижней точки сечения } ys := y0 - dx - hs; { координата x левой нижней точки сечения } MoveTo(xs, ys ); LineTo(xs + L2, ys ); LineTo(xs + L2 + round(L2/sqrt(2)), ys - round(L2/sqrt(2))); SetLineStyle(1, 0, 1); { устанавливаем стиль линии (пунктирная) } LineTo(xs + round(L2/sqrt(2)), ys - round(L2/sqrt(2))); LineTo(xs, ys); { заштриховываем сечение } SetLineStyle(0, 0, 2); { устанавливаем стиль линии (обычная, толщина = 2) } for i := 0 to (L2 div ds*2) div 2 do begin MoveTo(xs + ds*i, ys ); LineTo(xs + ds*i + round(L2/sqrt(2)), ys - round(L2/sqrt(2))); end; ReadLn; end.

Ответ отправил: Николай Владимирович / Н.В. (статус: Профессор) Россия, Москва WWW: nvsoft.org ICQ: 420720 ---- Ответ отправлен: 14.05.2008, 19:28 Оценка за ответ: 4

Вопрос № 136.556

даны натуральное число n и действительное х.вычислить sinx+sin(в квадрате)x+sin(в n степени) в этом слагаемом sin(в квадрате)x надо в квадрат возвести sin

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Saske! Задание нужно было написать так: Даны натуральное число n и действительное х. Вычислить: sum=sinx+(sin(х))^2+(sin(x))^3 . . . +(sin(x))^n; Решение очень простое. В цикле перемножаешь sin(x) само на себя 1,2,3 . . .n раз. Полученные произведения складываешь. Все. Код в приложении. Приложение: var x,sum,prz:real; {x, сумма, произведение} n,i:integer; begin write('n=');readln(n); write('x=');readln(x); sum:=0;prz:=1; for i:=1 to n do begin prz:=prz*sin(x); sum:=sum+prz; end; writeln('sum=',sum:6:3); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 13.05.2008, 10:52 Оценка за ответ: 5 Комментарий оценки: спасибо

Вопрос № 136.584

Добрый день, уважаемые знатоки программирования! Есть задача, которую мы никак не можем написать и просим помощи! ( Даны 2 матрицы A и B размерностью 5*5. заполнить их обе с помощью генератора случайных чисел. Элементы матриц - целые числа в диапазоне от -2 до 9, кроме 0. 1)найти матрицу С равную A*B 2)отранжировать столбцы матрицы С по возрастанию элементов предпоследней нечетной строки получив матрицу D. 3)транспонировать матрицу D 4)элементы главной диагонали матрицы D кратные 3м заменить на 1111. Заранее огромное спасибо всем, кто поможет!! =)

Отправлен: 13.05.2008, 04:49 Вопрос задала: Lera Iv. (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Lera Iv.! Решение задачи с небольшими пояснениями в приложении. Объяснять как создается и выводится матрица, как выполняется сортировка или перестановка обменом, замена элементов матрицы думаю не стоит, поскольку это вам должно быть известно. Если что подзабыли – в учебники. Умножение матриц выполнено точно так, как оно описано в учебниках, думаю тоже разберетесь. Программа длинная и если описывать каждый шаг, получится мини-мануал. Если что конкретно непонятно, пишите, спрашивайте. Чтобы не переписывать такой длинный код попробую прикрепить саму программу. Успехов в учебе! Приложение: uses crt; const n=5; var a,b,c,d:array[1..n,1..n] of integer; i,j,k,s,x:integer; begin clrscr; randomize; {Zapolnenie matric bez nolej} writeln('Matrica A:'); for i:=1 to n do begin for j:=1 to n do begin repeat {в цикле выбираем числа из диапазона [-2,9], <>0} a[i,j]:=random(12)-2; until a[i,j]<>0; write(a[i,j]:4); end; writeln; end; readln; writeln('Matrica B:'); for i:=1 to n do begin for j:=1 to n do begin repeat b[i,j]:=random(12)-2; until b[i,j]<>0; write(b[i,j]:4); end; writeln; end; readln; {Umnozenie matric} for k:=1 to n do for j:=1 to n do begin c[k,j]:=0; for i:=1 to n do begin {считаем сумму произведений элементов i-ой строки А на элементы i-го столбца В} c[k,j]:=c[k,j]+a[k,i]*b[i,j]; end; end; writeln('Matrica C:'); for i:=1 to n do begin for j:=1 to n do write(c[i,j]:5); writeln; end; readln; {Ranzirovanie matricy C} s:=3; for j:=1 to n-1 do for k:=1 to n-1 do if c[s,k]>c[s,k+1] then begin for i:=1 to n do begin {сортируем обменом все строки по возрастанию строки 3} x:=c[i,k];c[i,k]:=c[i,k+1];c[i,k+1]:=x; end; end; writeln('Matrica D:'); for i:=1 to n do begin for j:=1 to n do begin d[i,j]:=c[i,j]; write(d[i,j]:5); end; writeln; end; readln; {Transponirovanie matricy D} for i:= 1 to n do for j:=1 to n do if j<i then begin {симметрично меняем элементы под главной диагональю с элементами над главной диагональю} x:=d[i,j];d[i,j]:=d[j,i];d[j,i]:=x; end; writeln('Matrica D_trans:'); for i:=1 to n do begin for j:=1 to n do write(d[i,j]:5); writeln; end; readln; {Zamena elementov glavnoj diagonali} for i:=1 to n do if d[i,i] mod 3=0 then {главная диагональ} begin d[i,i]:=1111; end; writeln('Matrica D_zamena:'); for i:=1 to n do begin for j:=1 to n do write(d[i,j]:5); writeln; end; readln end. Прикреплённый файл: Загрузить >> Срок хранения файла на сервере RusFAQ.ru составляет 30 суток с момента отправки ответа.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 13.05.2008, 09:54

Вопрос № 136.622

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

Отправлен: 13.05.2008, 12:59 Вопрос задал: Сухарев Дмитрий Владимирович (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Delph Здравствуйте, Сухарев Дмитрий Владимирович! Очень похожий вопрос уже задавался: вопрос № 135337. Свою программу для того вопроса слегка подкорректировал под Ваш вариант задачи (смотрите приложение). Приложение: Program Pr135337_1; Uses CRT; Const N = 10; Var i, j, r: Integer; Arr : Array[1 .. N] of integer; Begin ClrScr; Randomize; WriteLn('Исходный случайно сформированный массив:'); for i := 1 to N do begin Arr[i] := Random(100); Write(Arr[i]:3); end; WriteLn; WriteLn; WriteLn('Обработанный массив:'); for i := 1 to N do begin { r отреагирует на чётность числа. При нечётных i оно станет равно 2, при чётных - нулю. } r := (i mod 2) * 2; { В зависимости от чётности i вложенный цикл выполнится либо один раз, либо 3. } for j := 0 to r do Write(Arr[i]:3); end; ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 13.05.2008, 13:45 Оценка за ответ: 5

Отвечает: Зенченко Константин Николаевич Здравствуйте, Сухарев Дмитрий Владимирович! Вариант с изменением самого массива. Удачи! Приложение: const n=10; var a:array[1..4*n]of integer; b,c,d:integer; begin {создаем массив} randomize; for b:=1 to n do begin a[b]:=random(33); write(a[b]:4); end; writeln; {обрабатываем массив} b:=n; d:=n; while b>0 do begin while odd(b)do begin {индекс нечетный, сдвигаем все элементы массива} for c:=d downto b do a[c+2]:=a[c]; {увеличиваем размер масиива} inc(d,2); {копируем элемент массива} a[b+1]:=a[b]; {к следующему В} dec(b); end; {к следующему В} dec(b); end; {выводим результат} for b:=1 to d do write(a[b]:3); end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 13.05.2008, 14:13 Оценка за ответ: 5

Вопрос № 136.652

с клавиатуры вводится n целых чисел а1,а1,...аn. в процессе ввода выводите на экран:а1, 2*а2, 3*а3...n*an.

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Saske! Программа в приложении. Удачи! Приложение: const n=10; var a,b:integer; begin for b:=1 to n do begin write('a',b,':='); readln(a); writeln(b,'*a',b,':=',b*a:6); end; end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 13.05.2008, 16:06 Оценка за ответ: 5

Вопрос № 136.667

Уважаемые эксперты!помогите пожалуйста решить следующее: Выполнить обработку элементов прямоугольной матрицы А, имеющей N строк и M столбцов. Исключить из матрицы строку с номером L. Сомкнуть строки матрицы.Желательно решить на Free Pascal. Спасибо!))

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

Отвечает: Delph Здравствуйте, Igor lukashov! В приложении - решение Вашей задачки. С константами N и M можете поразвлекаться, меняя размерность матрицы. Программа написана и отлажена в среде Free Pascal, но без проблем выполнится и на Turbo Pascal. Приложение: Program Pr136667; Uses CRT; Const N = 10; M = 16; Var i, j, L: Integer; Matr : Array[1..N, 1..M] of Integer; Begin ClrScr; Randomize; WriteLn('Исходная случайно заполненная матрица:'); for i := 1 to N do begin for j := 1 to M do begin { заполнение матрицы случайными числами от 0 до 99 } Matr[i, j] := Random(100); Write(Matr[i, j]:4); end; WriteLn; end; WriteLn; Repeat Write('Введите номер строки от 1 до ', N, ': '); ReadLn(L); Until (1 <= L) and (L <= N); { Удаление строки из массива } for i := L to N - 1 do for j := 1 to M do Matr[i, j] := Matr[i + 1, j]; for i := 1 to N - 1 do begin for j := 1 to M do Write(Matr[i, j]:4); Writeln; end; WriteLn; Write('Нажмите <Enter> для продолжения...'); ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 13.05.2008, 18:30 Оценка за ответ: 5

Вопрос № 136.673

Есть такая тема: возвести 3 в 512-тую степень и напечатать 125 цифру(слева) получившегося числа. Я как только не бился, longing вмещает 2000000 чисел, а там больше. Догадываюсь, что массивом, но как? Помогите!

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

Отвечает: Gh0stik Здравствуйте, Квашнин Олег Петрович! Конечно больше ... ;). Данная задача решается с использованием массива, в котором число хранится поразрядно - в каждой ячейке один разряд числа. Сам алгоритм возведения в степень очень похож на умножение в столбик, только с соответствующими коррективами. Вот решение: const n=3; power=512; var a:array [1..500] of integer;     i,j,x,mem:integer;     s:string; begin   a[500]:=n; mem:=0; {число храним в массиве, в первый разряд заносим само число}   for i:=2 to power do {повторяем цикл столько раз в зависимости от степени}      for j:=500 downto 1 do   {заполняем число поразрядно}      begin x:=a[j]*n; {умножаем текущий разряд на 3}         a[j]:=(x+mem) mod 10; {записываем в ячейку только одну цифру - текущий разряд}         mem:=(x+mem) div 10; {старшие разряды запоминаем}      end;   j:=1; while a[j]=0 do inc(j); {поскольку массив мы заполняли справа налево, то необходимо найти позицию первой цифры числа в массиве}   writeln(a[j+125-1]); {выводим на экран 125-ю цифру слева}   write('(',n,'^',power,')='); for i:=j to 500 do write(a[i]); {для полноты выведем все число целиком}   readln; end. А вот результат: 3 (3^512)=193233498322889151054540687220195810554014657616033285501845376289024667 46415537000017939429786029354390082329294586119505153509101332940884098040478728 63954256055013372739948277806232240737233812104339966824227659179150465898588299 5272436541441 Good Luck! --------- Непечатный жаргон - это тот язык, которым решительно все программисты владеют в совершенстве.

Ответ отправил: Gh0stik (статус: Академик) Украина, Славянск Организация: Славянский государственный педагогический университет (Кафедра алгебры) WWW: http://gh0stik.rusfaq.ru/ ICQ: 289363162 ---- Ответ отправлен: 13.05.2008, 19:35

Отвечает: Denisss Здравствуйте, Квашнин Олег Петрович! Пример находится в приложении. Функции для работы с длинными числами взяты отсюда: Длинная арифметика. Алгоритм вычисления степени взят там же. Перемножение двух длинных чисел реализовано самостоятельно. PS У меня 125-я цифра слева получилась равная трем. Удачи! Приложение: program Q136673; const {Основание} OSN = 10000; {Максимальное количество элементов в массиве} {3^512 = 1.93e+244, значит нужно приблизительно 244/4=61 элемента} {берем с небольшим запасом} MAX_DIGIT = 100; type TLong = array[0..MAX_DIGIT] of LongInt; PLong = ^TLong; {Вывод длинного числа на экран} procedure writeLong(const A: PLong); var s, ls: String; i: Integer; begin str(OSN div 10, ls); write(A^[A^[0]]); for i:= Pred(A^[0]) downto 1 do begin str(A^[i], s); while (Length(s) < Length(ls)) do s:= '0' + s; write(s); end; writeln; end; {Перемножение длинного числа на недлинное} procedure mulLong(const A: TLong; const K: Integer; var C: TLong); var i: Integer; t: LongInt; begin fillChar(C, sizeof(C), #0); if (K = 0) then inc(C[0]) else begin for i:= 1 to A[0] do begin t:= A[i] * K + C[i]; C[Succ(i)]:= t div OSN; C[i]:= t mod OSN; end; if (C[Succ(A[0])] > 0) then C[0]:= Succ(A[0]) else C[0]:= A[0]; end; end; {Сумма двух длинных чисел} procedure sumLong2(const A, B: TLong; var C: TLong); var i, k: Integer; t: LongInt; begin fillChar(C, sizeof(C), #0); if (A[0] > B[0]) then k:= A[0] else k:= B[0]; for i:= 1 to k do begin t:= A[i] + B[i] + C[i]; C[Succ(i)]:= t div OSN; C[i]:= t mod OSN; end; if (C[Succ(k)] = 0) then C[0]:= k else C[0]:= Succ(k); end; {Копирование одного длинного числа в другое} procedure copyLong(const A: TLong; var C: TLong); begin move(A, C, sizeof(A)); end; {Умножение длинного числа на OSN} procedure shlLong1(var A: TLong); var i: Integer; begin Inc(A[0]); for i:= A[0] downto 1 do A[i]:= A[Pred(i)]; A[1]:= 0; end; {Перемножение двух длинных чисел} procedure mulLong2(const A, B: PLong; var C: TLong); var t1, t2, ts2, ts3, tt: PLong; s1, s2: TLong; i: Integer; begin {Определяем какое число длиннее} if (A^[0] > B^[0]) then begin t1:= A; t2:= B; end else begin t1:= B; t2:= A; end; {s2:= 0;} fillChar(s2, sizeof(s2), #0); s2[0]:= 1; ts2:= @s2; ts3:= @C; for i:= t2^[0] downto 2 do begin {Умножаем} mulLong(t1^, t2^[i],s1); {Добавляем} sumLong2(s1, ts2^, ts3^); {Умножаем на OSN} shlLong1(ts3^); {Меняем местами} tt:= ts3; ts3:= ts2; ts2:= tt; end; {Последний раз умножаем} mulLong(t1^, t2^[1], s1); {Убеждаемся, что в s2 находится то, что нужно} if (ts2 <> @s2) then copyLong(ts2^, s2); {Прибавляем} sumLong2(s1, s2, C); end; {Получаем N-ю цифру числа A} function getDigit(const A: TLong; const N: Integer): Byte; var s, ls: String; Result: Byte; i, len: Integer; begin str(OSN div 10, ls); str(A[A[0]], s); {Количество цифр у числа A} len:= Length(s) + Length(ls)*(A[0] - 1); if ((len < N) or (N <= 0)) then Result:= 0 else begin i:= 1 + (len - N) div Length(ls); str(A[i], s); i:= Length(ls) - (len - N) mod Length(ls); while (Length(s) < Length(ls)) do s:= '0' + s; Result:= Ord(s[i]) - Ord('0'); end; getDigit:= Result; end; var pw, k: Integer; t1, t2, t3, tt: PLong; begin pw:= 512; {Первое число - a} getMem(Pointer(t1), sizeof(TLong)); t1^[0]:= 1; t1^[1]:= 3; {Второе число - b} getMem(Pointer(t2), sizeof(TLong)); t2^[0]:= 1; t2^[1]:= 1; {Третье число - c} getMem(Pointer(t3), sizeof(TLong)); k:= pw; {* ** Алгоритм вычисления степени длинных чисел взят здесь: ** http://cit.vvsu.ru/MIRROR/Science/DL-AR/stepen.html *} while (k <> 0) do begin {Если к четное} if ((k and 1) = 0) then begin {Делим на 2} k:= k shr 1; { c:= c*c; } mulLong2(t1, t1, t3^); tt:= t3; t3:= t1; t1:= tt; end else begin { k:= k - 1; } Dec(k); {b:= b*c; } mulLong2(t1, t2, t3^); tt:= t3; t3:= t2; t2:= tt; end; end; {Выводим b} {writeLong(t2);} {Выводим 125-ю цифру полученного числа} writeln(getDigit(t2^, 125)); {Освобождаем память} freeMem(Pointer(t1), sizeof(TLong)); freeMem(Pointer(t2), sizeof(TLong)); freeMem(Pointer(t3), sizeof(TLong)); WriteLn('Press any key...'); Readln; end. --------- Будь осторожен, когда молишься ради чего-то, потому что можешь это получить...

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

Вопрос № 136.683

Здравствуйте! Язык программирования: Паскаль. Я написал прогу, которая считает сумму соседних элементов массива. Она хорошо работает, но если я делаю массив, состоящий из 20 элементов (размерность массива вводится с клавиатуры), то по окончании вычислений она как бы "зависает", т.е. ни на что не реагирует. По идее, после расчетов она должна высвечивать результаты и по нажатии Enter выйти в среду разработки. Так, вот результаты она высвечивает, но по нажатии Enter не закрывается, если я введу кол-во елементов массива больше 13. ВОПРОС: скажите, пожалуйста, это баг Паскаля или у меня в проге что-то не так? Прога в приложении. Огромное спасибо! Приложение: uses crt; const n=10; type mas= array [1..n+1] of integer; procedure massiv; var a,c:mas; n,i,sum,y,h:integer; begin write ('Vvedite razmernost massiva: '); readln (n); clrscr; for i:=1 to n do begin write ('Vvedite ',i,' el massiva: '); readln (a[i]); end; writeln; sum:=a[1]+a[2]; sum:=abs(sum); c[1]:=sum; a[n+1]:=0; for i:=1 to n do begin c[i+1]:=a[i]+a[i+1]+a[i+2]; end; for i:=1 to n do begin h:=abs(c[i]); writeln ('El massiva "C": ',h); end; readln; end; begin clrscr; massiv; end.

Отправлен: 13.05.2008, 19:01 Вопрос задал: BOOM (статус: 10-ый класс) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 6)

Отвечает: Disasm Здравствуйте, BOOM! Вначале Вы задаете массив mas рамерностью 11, а потом пытаетесь использовать массив больше указаной размерности. Такой глюк будет уже при задании количества елементов массива больше 11, т.е. начиная с 12. Попробуйте увеличить константу const хотя бы до 20.

Ответ отправил: Disasm (статус: 1-ый класс) Ответ отправлен: 14.05.2008, 10:54 Оценка за ответ: 5

Отвечает: Евчик Сергей Александрович Здравствуйте, BOOM! 1. a[n+1]:=0; - если введено размерность = 11 то обнулять будет нечего.. 2. for i:=1 to n do begin c[i+1]:=a[i]+a[i+1]+a[i+2]; end; А когда у Вас i станет = 9??? Нужно брать for i:=1 to n-2 do 2. Вы задаете константой размерность массива const n=10. Т.о. у Вас создается массив лишь на 10 элементов. Надеюсь я Вам помог...

Ответ отправил: Евчик Сергей Александрович (статус: 3-ий класс) Ответ отправлен: 14.05.2008, 19:16 Оценка за ответ: 5 Комментарий оценки: Благодарю.

Вопрос № 136.687

Здравствуйте. Помогите, пожалуйста, написать программу: дано простое число P. Найти и вывести следующее за ним простое число. Спасибо.

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

Отвечает: Николай Владимирович / Н.В. Здравствуйте, Ljubik! Программа в приложении. Удачи! Приложение: function is_simple(p:integer):boolean; {определяет, является ли число простым} var i : integer; res : boolean; begin i := 2; res := true; while res and (i < p) do begin res := p mod i <> 0; inc(i); end; is_simple := res; end; var p : integer; begin ReadLn(p); inc(p); while not is_simple(p) do begin inc(p); end; writeLn(p); ReadLn; end.

Ответ отправил: Николай Владимирович / Н.В. (статус: Профессор) Россия, Москва WWW: nvsoft.org ICQ: 420720 ---- Ответ отправлен: 13.05.2008, 19:36

Отвечает: Зенченко Константин Николаевич Здравствуйте, Ljubik! Смотрите приложение. По программе: - функция F рекурсивно вызывает сама себя с новыми значениями(от числа Р до 1) и возвращает значение TRUE если число простое; - функция С рекурсивно вызывает сама себя c новым значением (от Р до следующего простого числа); Программа выдает результат ввиде TRUE следующее простое число или FALSE когда число Р не простое. Удачи! Приложение: var p:integer; {рекурсивная функция контроля простого числа} function F(x,y:integer):boolean; begin if y<1 then F:=false else if y=1 then F:=true else F:=F(x,y-1) and ((x mod y)>0); end; {рекурсивная функция поиска следующего числа} function C(z:integer):integer; begin if F(z,z-1) then C:=z else C:=C(z+1); end; begin {сама программа} write('P:');readln(p); if F(p,p-1) then writeln(F(p,p-1),C(p+1):7) else writeln(f(p,p-1)); end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

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

Вопрос № 136.700

Здравствуйте,уважаемые эксперты! Вновь обращаюсь к вам за помощью. Помогите,пожалуйста,составить программу которая выводит в текстовой файл data1.txt в два столбца значения переменной x и функции f(x)=(x-1) в квадрате минус 0.5 в степени x.

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Денисов Игорь Александрович! Программа в приложении формирует файл с таким содержимым F(1.010):=0.00497. Удачи! Приложение: var x:real; y:text; {сама функция} function F(x:real):real; begin F:=(x-1)*(x-1)-exp(ln(0.5)*x); end; begin assign(y,'data1.txt'); rewrite(y); x:=0;{начальное значение} while x<3 do begin writeln(y,'F(',x:2:3,'):=',F(x):2:5); x:=x+0.01;{шаг проверки} end; close(y); end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 13.05.2008, 20:44 Оценка за ответ: 5

Вопрос № 136.707

Помогите написать процедуру введения квадратной матрицы порядка n и процедуру формирования вектора, элементы которого равняются количеству нулевых элементов соответствующих рядов квадратной матрицы.

Отправлен: 13.05.2008, 21:13 Вопрос задал: Вася Рогов Иванович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 7)

Отвечает: Denisss Здравствуйте, Вася Рогов Иванович! Пример с комментариями находится в приложении. Удачи! Приложение: program Q136707; uses Crt; const N = 3; type TMatrix = array[1..N, 1..N] of Integer; TVector = array[1..N] of Integer; {Процедура ввода квадратной матрицы} procedure inputMatrix(var Mx: TMatrix); var i, j: Integer; begin for i:= 1 to N do for j:= 1 to N do begin write('M[', i, ', ', j, '] = '); readln(Mx[i, j]); end; end; {Процедура формирования вектора} procedure formVect(var V: TVector; const Mx: TMatrix); var i, j, zs: Integer; begin for i:= 1 to N do begin zs:= 0; for j:= 1 to N do if (Mx[i, j] = 0) then Inc(zs); V[i]:= zs; end; end; var {Квадратная матрица} M: TMatrix; {Вектор} V: TVector; i: Integer; begin {Очищаем экран} ClrScr; {Заполняем матрицу} inputMatrix(M); {Формируем вектор} formVect(V, M); {Выводим вектор на экран} for i:= 1 to N-1 do write(V[i], ', '); writeln(V[N]); {Ожидаем, когда пользователь нажмет любую кнопку} writeln; writeln('Press any key...'); readln; end. --------- Будь осторожен, когда молишься ради чего-то, потому что можешь это получить...

Ответ отправил: Denisss (статус: Профессионал) Россия, Москва ICQ: 281599577 ---- Ответ отправлен: 13.05.2008, 22:24 Оценка за ответ: 4 Комментарий оценки: Пасиб:) Если кто еще варианты имеет, то шлите, пожайлуста. Заранее спасибо!

Вопрос № 136.720

Уважаемые эксперты,помогите пожалуйста решитть следующее: выполнить обработку элементов прямоугольной матрицы А, имеющий N строк и М столбцов. Добавить к элементам каждой строки такой новый элемент, чтобы сумма положительных элементов стала бы равна модулю суммы отрицательных элементов. Результат оформить в виде матрицы из N строк и М+1 столбцов. Спасибо!)

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

Отвечает: Ulyana Здравствуйте, Igor lukashov! Массив задается генератором случайных чисел. Далее находится сумма отрицательных элементов и положительных элементов в строке. После чего находится разность модуля суммы отрицательных и положительных, и эта разница записывается в новый столбец. В 1-ой программе изменяется исходная матрица, во 2-ой создается новая матрица. Приложение: program a1; const n=5; m=10; var sum_minus, sum_plus,i,j:integer; a:array [1..n,1..m+1] of integer; begin randomize; for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(10)-5; write(a[i,j]:4); end; writeln; end; for i:=1 to n do begin sum_minus:=0; sum_plus:=0; for j:=1 to m do if a[i,j]<0 then sum_minus:=sum_minus+a[i,j] else sum_plus:=sum_plus+a[i,j]; a[i,m+1]:=abs(sum_minus)-sum_plus; end; writeln('Result:'); for i:=1 to n do begin for j:=1 to m+1 do begin write(a[i,j]:4); end; writeln; end; writeln('Press ENTER'); readln; end. ---------------------------------------------------------------------------- program a2; const n=5; m=10; var sum_minus, sum_plus,i,j:integer; a:array [1..n,1..m] of integer; b:array [1..n,1..m+1] of integer; begin randomize; for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(10)-5; write(a[i,j]:4); b[i,j]:=a[i,j]; end; writeln; end; for i:=1 to n do begin sum_minus:=0; sum_plus:=0; for j:=1 to m do if a[i,j]<0 then sum_minus:=sum_minus+a[i,j] else sum_plus:=sum_plus+a[i,j]; b[i,m+1]:=abs(sum_minus)-sum_plus; end; writeln('Result:'); for i:=1 to n do begin for j:=1 to m+1 do begin write(b[i,j]:4); end; writeln; end; writeln('Press ENTER'); readln; end.

Ответ отправила: Ulyana (статус: 1-ый класс) Ответ отправлен: 13.05.2008, 23:08

Вопрос № 136.778

Здравствуйте уважаемые эксперты! Подскажите пожалуйста есть ли в Pascal функция аналогичная функции в Liberty Basic, тоесть вывод на печать "LPRINT". Надеюсь на Ваша ответ, заранее спасибо!

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

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Sashka! Для печати в Pascal можно использовать функцию WriteLn. Но для этого надо добавить в Uses модуль Printer. Для того чтобы функция выводила строку на печать, надо вызвать её с параметром LST. Вот так: WriteLn(LST, 'Строка для печати'); Таким образом можно печатать только на LPT принтере. В приложении пример. Удачи!!! Приложение: Uses Printer; begin WriteLn(LST, 'Hello, World!'); end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: Студент) Ответ отправлен: 14.05.2008, 14:56 Оценка за ответ: 5 Комментарий оценки: Большое спасибо! А чего-то аналогичного для usb-принтеров нет???

Вопрос № 136.798

Уважаемые эксперты!!прошу помощи ибо очень нужна :)помогите пожалуйсто решить задачу:) Дана матрица размером МхN. Упорядочить ее столбцы по воз- растанию элементов k-й строки.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Петров Игорь Ильич! Решение задачи с небольшими пояснениями в приложении. Приложение: uses crt; var m,n,k,i,j,p,x:integer; a:array[1..50,1..50]of integer; label 1; {метка} begin clrscr; write('Vvedite kolichestvo strok m=');readln(m); write('Vvedite kolichestvo stolbcov n=');readln(n); writeln('vvedite chislo 1<=k<=m'); 1: write('k=');readln(k); if (k<1)or(k>m)then {проверяем к} begin writeln('Nedopustimoe znachenie k'); readln; goto 1; end; randomize; writeln('Ishodnaja matrica:'); for i:=1 to m do begin for j:=1 to n do begin a[i,j]:=random(20); write(a[i,j]:4) end; writeln end; readln; {sortirovka po vozrastaaniu v k stroke} for j:=1 to n-1 do for p:=1 to n-1 do if a[k,p]>a[k,p+1] then {по возрастанию в строке к} begin for i:=1 to m do begin x:=a[i,p]; a[i,p]:=a[i,p+1]; {переставляем во всех строках} a[i,p+1]:=x end end; {vyvod obrabotannoj matrichy} writeln('Rezultat:'); for i:=1 to m do begin for j:=1 to n do write(a[i,j]:4); writeln end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 14.05.2008, 15:35

Вопрос № 136.832

Уважаемые эксперты! Помогите, пожалуйста, решить задачу: 1. Дан массив данных об автомобилях заводского гаража (формирование массива из файла): номер, марка, год выпуска, пробег, фамилия шофёра. Вывести: - сообщение о том, есть ли в гараже автомобиль заданной марки (да или нет)ж - список машин, подготовленных на списание (старше 1980 года с пробегом более 50 000км), в списке указаны все данные, кроме фамилии шофёра; -все записи, упорядоченные по признаку: фамилии шофёров в алфавитном порядке. Заранее огромное спасибо! Swallow.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Ласточка! Решение задачи с пояснениями в приложении. Приложение: uses crt; const n=5; {можно побольше} type Tgaraz=record {тип запись с полями по условию} nom:string[20]; mar:string[20]; god:word; prb:longint; fam:string[20]; end; var sp:array[1..n] of Tgaraz; {список автомобилей} i,k,j:integer; m:string[10]; {переменная для вызова марки} buf:Tgaraz; {буфер при сортировке} begin clrscr; for i:=1 to n do {вводим данные} begin writeln('Mashina ',i,':'); write('Nomer mashiny: ');readln(sp[i].nom); write('Marka mashiny: ');readln(sp[i].mar); write('God vypuska: ');readln(sp[i].god); write('Probeg: ');readln(sp[i].prb); write('Familia shofera: ');readln(sp[i].fam); end; writeln; write('Vvedite marku mashiny:'); readln(m); k:=0; for i:=1 to n do if sp[i].mar=m then {если марка совпадает, считаем} begin k:=k+1; end; if k>0 then writeln('Takaja marka est!') else writeln('Takoj marki net!'); writeln; writeln('Spisok mashin k spisaniu:'); for i:=1 to n do if (sp[i].god<1980)and(sp[i].prb>50000)then begin write('Nomer ',sp[i].nom,' Marka ',sp[i].mar); write(' God vypuska ',sp[i].god,' Probeg ',sp[i].prb); writeln; end; writeln; writeln('Spisok po familii shofera:'); {сортируем список по возрастанию значений поля фамилия(по алфавиту)} for i:=1 to n-1 do for j:=1 to n-1 do if sp[j].fam>sp[j+1].fam then begin buf:=sp[j]; sp[j]:=sp[j+1]; sp[j+1]:=buf; end; for i:=1 to n do {выводим весь список} begin write(' Familia ',sp[i].fam,' Nomer ',sp[i].nom,' Marka ',sp[i].mar); write(' God vypuska ',sp[i].god,' Probeg ',sp[i].prb); writeln; end; readln end. Прикреплённый файл: Загрузить >> Срок хранения файла на сервере RusFAQ.ru составляет 30 суток с момента отправки ответа.

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

Вопрос № 136.839

Помогите пожалуста с задачей: Тема подпрограммы. Даны 6 элементные вещественные векторы х и у, и квадратные матрицы шестого порядка А, В и С. Вычислить: (Ах,Ву)+(Сх,у)(х,Ву). Спасибо

Отправлен: 14.05.2008, 20:08 Вопрос задал: Михайлов Евгений Юрьевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Михайлов Евгений Юрьевич! Вообщем немного почитал и подумал и пришел к следующим выводам. 1. (Ах,Вх) вовсе не означает обязательно умножение, перед скобками должно стоять указание на действие в виде служебного слова. Но если вы говорите, что умножение, будем делать умножение. 2. Результатом Ах, Ву, Сх будет матрица [6,1]. 3. Результатом (Ах,Ву), (Сх,у), (х,Ву) будет произведение матрицы [6,1] на матрицу [1,6] т.е. число. 4. Дальше идут действия с числами. По программе. - для создания матриц и векторов, а также умножения матрицы на вектор сделал процедуры, чтобы не повторяться по 2-3 раза. - матрицы и вектора заполнил числами из интервала [1,8], т.к. даже 10 иногда дает выход за пределы типа Longint. - переменным дал обозначения, чтобы было понятно, какое действие делаем. Код в приложении, если что непонятно, пишите. Приложение: uses crt; const n=6; type Tvect=array[1..n]of integer; Tmatr=array[1..n] of Tvect; var a,b,c:Tmatr; x,y,ax,by,cx:Tvect; axby,cxy,xby:longint; sum:real; i,j:integer; Procedure VvMatr(var m:Tmatr); begin for i:=1 to n do begin for j:=1 to n do begin m[i,j]:=random(8)+1; write(m[i,j]:3); end; writeln; end; end; Procedure VvVect(var m:Tvect); begin for i:=1 to n do begin m[i]:=random(10)+1; write(m[i],' '); end; end; Procedure PrzMatVec(m:Tmatr;p:Tvect;var q:Tvect); begin for i:=1 to n do begin q[i]:=0; for j:=1 to n do begin q[i]:=q[i]+m[i,j]*p[j]; end; write(q[i],' '); end; writeln; end; begin clrscr; randomize; Writeln('Matrica A:'); VvMatr(a); readln; Writeln('Vector x:'); VvVect(x); readln; Writeln('Vector A*x:'); PrzMatVec(a,x,ax); readln; Writeln('Matrica B:'); VvMatr(b); readln; Writeln('Vector y:'); VvVect(y); readln; Writeln('Vector B*y:'); PrzMatVec(b,y,by); readln; Writeln('Matrica C:'); VvMatr(c); readln; Writeln('Vector x:'); VvVect(x); readln; Writeln('Vector C*x:'); PrzMatVec(c,x,cx); readln; axby:=0; for i:=1 to n do axby:=axby+ax[i]*by[i]; writeln('axby=',axby); cxy:=0; for i:=1 to n do cxy:=cxy+cx[i]*y[i]; writeln('cxy=',cxy); xby:=0; for i:=1 to n do xby:=xby+x[i]*by[i]; writeln('xby=',xby); sum:=axby+cxy/xby; writeln('Rezultat=',sum:6:2); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 15.05.2008, 15:06 Оценка за ответ: 5 Комментарий оценки: Большое спасибо, все доступно и понятно

Вопрос № 136.858

Уважаемые эксперты!)помогите пожалуйста решить задачу:заданы М строк символов, которые вводятся с клавиатуры. Каждая строка представляет собой слово. Напечатать те из них которые являются перевертышами. Например: abba. Спасибо!)

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Igor lukashov! Решение задачи с пояснениями в приложении. Приложение: uses crt; const m=5; {можно больше} var s:array[1..m]of string;{массив строк} i,n,j,k:integer; begin; clrscr; for i:=1 to m do readln(s[i]); {вводим слова} writeln; writeln('Palindromy:'); for i:=1 to m do begin n:=length(s[i]);k:=0; for j:=1 to n div 2 do {от начала до середины слова} if s[i][j]=s[i][n-j+1] then {если симметричные буквы равны} begin k:=k+1; {считаем} end; if k=n div 2 then {если все пары равны, выводим на печать} writeln(s[i]); end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 15.05.2008, 20:16

Вопрос № 136.863

Пусть элементами равностороннего треугольника являются: сторона а; площадь S; высота h; радиус вписанной окружности r; радиус описанной окружности R. Составить программу, которая по заданному номеру и значению соответствующего элемента вычисляла бы значение всех остальных элементов треугольника.

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

Отвечает: -=Dr. Штопор=- Здравствуйте, Raevil! Программа в приложении, если будут вопросы касательно программы и используемых формул, обращайтесь Приложение: program p136863; var a,s,h,r,RR:real; c:char; BEGIN writeln('Что известно?'); writeln('1 - сторона'); writeln('2 - площадь'); writeln('3 - высота'); writeln('4 - радиус вписанной окружности'); writeln('5 - радиус описанной окружности'); readln(c); case c of '1':begin writeln('Введите сторону'); readln(a); s:=a*a*sqrt(3)/4; h:=2*s/a; r:=0.5*a/sqrt(3); RR:=a/sqrt(3); end; '2':begin writeln('Введите площадь'); readln(s); a:=sqrt(4*S/sqrt(3)); h:=2*S/a; r:=0.5*a/sqrt(3); RR:=a/sqrt(3); end; '3':begin writeln('Введите высоту'); readln(h); a:=sqrt(4*h*h/3); s:=a*a*sqrt(3)/4; r:=0.5*a/sqrt(3); RR:=a/sqrt(3); end; '4':begin writeln('Введите радиус вписанной окружности'); readln(r); a:=2*r*sqrt(3); s:=a*a*sqrt(3)/4; h:=2*s/a; RR:=a/sqrt(3); end; '5':begin writeln('Введите радиус описанной окружности'); readln(RR); a:=RR*sqrt(3); s:=a*a*sqrt(3)/4; h:=2*s/a; r:=0.5*a/sqrt(3); end; end; writeln('Сторона - ',a:0:2); writeln('Площадь - ',s:0:2); writeln('Высота - ',h:0:2); writeln('Радиус вписанной окружности - ',r:0:2); writeln('Радиус описанной окружности - ',RR:0:2); end. --------- Tantum possumus, quantum scimus

Ответ отправил: -=Dr. Штопор=- (статус: 9-ый класс) Ответ отправлен: 15.05.2008, 08:58

Отвечает: Delph Здравствуйте, Raevil! В справочнике по математике нашёл следующие формулы для равностороннего треугольника: 1) площадь S = Sqrt(3) * a^2 / 4; 2) высота h = Sqrt(3) * a / 2; 3) радиус вписанной окружности R = a * Sqrt(3) / 6; 4) радиус описанной окружности R = a * Sqrt(3) / 3. Из этих формул легко вывести обратные, посчитав основной параметр треугольника - длину его стороны. А далее по длине стороны узнаём все остальные параметры. Приложение: Program Pr136863; Uses CRT; Var a, x, Sqrt3: Real; ch: Char; Begin ClrScr; { Вычисляем квадратный корень от 3 для дальнейшего использования } Sqrt3 := Sqrt(3); WriteLn('Выберите вводный параметр:'); WriteLn('1) сторона треугольника a;'); WriteLn('2) его площадь S;'); WriteLn('3) высота h;'); WriteLn('4) радиус вписанной окружности Rin;'); WriteLn('5) радиус описанной окружности Rout.'); Write('Нажмите клавишу от 1 до 5: '); { Ждём ввода цифры от 1 до 5, игнорируя всё остальное } Repeat ch := ReadKey; Until ch in ['1'..'5']; WriteLn(ch); WriteLn; case ch of '1': begin Write('Сторона a = '); ReadLn(a); end; '2': begin Write('Площадь S = '); ReadLn(x); a := Sqrt(4 * x / Sqrt3); end; '3': begin Write('Высота h = '); ReadLn(x); a := 2 * x / Sqrt3; end; '4': begin Write('Радиус вписанной окружности Rin = '); ReadLn(x); a := 2 * Sqrt3 * x; end; '5': begin Write('Радиус описанной окружности Rout = '); ReadLn(x); a := Sqrt3 * x; end; end; WriteLn; WriteLn('Параметры треугольника:'); WriteLn('Сторона a = ', a:10:6); WriteLn('Его площадь S = ', (Sqrt3 * a * a / 4):10:6); WriteLn('Высота h = ', (sqrt3 * a / 2):10:6); WriteLn('Радиус вписанной окр. Rin = ', (a * Sqrt3 / 6):10:6); WriteLn('Радиус описанной окр. Rout = ', (a * Sqrt3 / 3):10:6); ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 15.05.2008, 09:15

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