Курилка Другие языки программирования Сессия

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

Вот сами задачи:
1.

В массиве А[n] каждый элемент, кроме первого, заменить суммой всех предыдущих элементов.
2.
Дана матрица. Упорядочить элементы столбцов матрицы по неубыванию, а сами столбцы по возрастанию минимальных элементов столбцов. Использовать быструю сортировку, реализовав метод в виде подпрограммы.
3.

В заданном предложении символы самого длинного слова заменить символами «*». Напечатать исходный и преобразованный тексты.
4.

Создать файл, содержащий сведения о товарах, имеющихся на складе. Каждая запись имеет поля: наименование товара; количество единиц товара; дата поступления товара на склад. На экран и в отдельный файл вывести список товаров в алфавитном порядке, хранящихся более одного месяца, стоимость которых превышает 100000 рублей. В другой файл вывести в алфавитном порядке список товаров, поступивших на склад в феврале месяце. Программа должна выполнять следующие дополнительные функции: создание новой базы данных; открытие базы из файла; сохранение базы в файл; добавление записей; удаление записей; поиск записей по одному из полей; сортировку по одному из полей методом, указанным в задаче 3; вывод базы данных на экран; выход из программы. Для реализации основных действий алгоритма использовать подпрограммы. Для обработки записей реализовать динамическую структуру данных односвязный список.
5. задание скрином...
Заранее всем спасибо...

1я решена

Спойлер

program Z2_7;
uses crt;
var a:array[1..20] of integer;
i:integer;
begin
clrscr;
randomize;
for i:=1 to 20 do
begin
a:=random(10);
write(a,' ');
end;
writeln;
write(a[1],' ');
for i:=2 to 20 do
begin
a:=a[i-1]+a;
write(a,' ');
end;
readln;
end.
[/CODE]
Третья тоже..
program z4_14;
uses crt;
const rz=['_',':',';',',',' ','.','?','!'];
var s,s1:string;
n,i,k,mx,i1:integer;
begin
clrscr;
writeln('Введите предложение');
readln(s);
n:=length(s);
i:=1;
mx:=0;
while i<=n do
if not(s in rz)and ((i=1)or(s[i-1] in rz)) then
begin
k:=i;s1:='';
while (k<=n)and not(s[k] in rz) do
begin
s1:=s1+s[k];
k:=k+1;
end;
if length(s1)>mx then
begin
mx:=length(s1);
i1:=i;
end;
i:=i+length(s1);
end
else i:=i+1;
writeln('Самое длинное слово ',copy(s,i1,mx));
for i:=i1 to i1+mx-1 do
s:='*';
writeln('Замена');
write(s);
end.

да я и сам делал такие контрольные раньше на закааз, а текперь время просто поджимает....

Пожалуйста провекрте кто-нибудь на своем компе....

не могу выбрать другой вариант менюшки кроме 1

Спойлер

crt;
type
Tovar = record {Описание записей}
name: string[20];
made: string[15];
kol: integer;
cena: integer;
day: 1..31;
moth: 1..12;
year: integer;
end;
ZKnote = ^Knote;
Knote = record {Узел стека}
Next: ZKnote; {указатель на следующий узел}
info: Tovar; {полезная информация}
end;
Stapel = record {Стек}
Spitze: ZKnote; {Spitze - вершина (стека)}
end;
massiv = array[1..100] of tovar; {описание типа массива, требующегося для сортировки}
var
S: stapel;
x: tovar; {переменные x, i, требующиеся для временного хранения записи}
n: integer;
f1: file of tovar;
sname, sename: string;
key: boolean; {Нужна для некоторых операций, служит в качестве "флажка"}
usl: char; {Переменная служит для проверки условия, в зависимости от знач. usl зависит будет ли выполнено условие}
ma: massiv; {Массив для сортировки}
pos: integer;
procedure menu; forward; {опережающее объявление подпрограммы menu}
procedure menu1; forward; {опережающее объявление подпрограммы menu1}
procedure menu_search_R; forward; {опережающее объявление подпрограммы menu_search_R}
{-----------------------------------СТЕК----------------------------------------}
{добавление элемента в стек}
procedure Add(var S: Stapel; x: Tovar);
var
z: ZKnote;
begin
new(z); {создаем новый узел}
z^.next := S.Spitze; {он будет находиться перед вершиной}
z^.info := x;
S.Spitze := z; {Делаем z вершиной стека}
end;
{Возвращает true, если стек пуст}
function IsFree(var S: Stapel): boolean;
begin
IsFree := S.Spitze = nil;
end;
{Возвращает число из вершины стека и затем уничтожает вершину}
function Gib(var S: Stapel): Tovar;
var
z: ZKnote;
begin
if IsFree(S) = true then begin
exit; end; {если стек пуст, возвращаем -1}
z := S.Spitze^.Next; {запоминаем следующий узел}
Gib := S.Spitze^.Info; {вытаскиваем инф-цию из вершины}
dispose(S.Spitze); {уничтожаем вершину}
S.Spitze := z; {делаем z вершиной}
end;
{Печать элементов стека (начиная с головы стека)}
procedure Print(var S: Stapel);
var
z: ZKnote;
begin
if IsFree(S) = true then begin
write('Стек пуст');
readln;
exit
end;
z := S.Spitze;
while z <> nil do
begin
writeln(z^.info.name:18, ' ', z^.info.made:15, ' ', z^.info.kol:8, ' ', z^.info.cena:11, ' ', z^.info.day:11, '.', z^.info.moth:2, '.', z^.info.year:4);
z := z^.Next; {переходим к след. элементу стека}
end;
end;
procedure SaveFile (var S: Stapel);
var
z: ZKnote;
begin
z := S.Spitze;
while z <> nil do
begin
write(f1, z^.info);
z := z^.Next; {переходим к след. элементу стека}
end;
close(f1);
end;
{Уничтожает стек}
procedure Tod(var S: Stapel);
var
z: ZKnote;
begin
while S.Spitze <> nil do
begin
z := S.Spitze;
S.Spitze := S.Spitze^.Next;
dispose(z);
end;
end;
{Удаления элементов в стеке}
procedure DelElem(var S: Stapel; pos: integer);
var
i: integer;
z: ZKnote;
begin
if IsFree(S) = true then begin
write('Стек пуст');
readln;
exit
end;
i:=0; {будет считать позиции}
z:=S.Spitze;
while (z <> nil) and (i <> pos) do {пока z не укажет в "пустоту" или мы не найдём искомый элемент}
begin
z:=z^.next; {переходим на следующий элемент}
inc(i) {увеличиваем значение счётчика}
end;
if z=nil then {если элемента нет выводим соответствующие сообщения и выходим}
begin
Writeln('Элемента под номером ' ,pos, ' нет');
readln;
exit
end;
dispose(z); {если мы не вышли, то элемент есть и его следует удалить}
Writeln('Удалено'); {сообщаем о выполнении действия}
readln;
end;
{--------------------------------Создание базы-------------------------------------------}
procedure CreatBase;
begin
clrscr;
write('Введите название новой базы данных: '); readln(sname);
assign(f1, sname + '.txt');
rewrite(f1);
end;
{--------------------------------загрузка базы-------------------------------------------}
procedure LoadBase;
begin
clrscr;
write('Введите название базы данных: '); readln(sname);
if FileExists(sname + '.txt') = true then write('База загружена')
else write('База не найдена');
assign(f1, sname+'.txt');
reset(f1);
while not Eof(f1) do
begin
read(f1, x);
Add(S, x);
end;
end;
{--------------------------------Ввод базы-------------------------------------------}
procedure Vvod;
begin
clrscr;
usl := 'y';
n := 1;
while usl = 'y' do
begin
write('Введите название '); readln(x.name);
write('Введите производитель '); readln(x.made);
write('Введите количесвто '); readln(x.kol);
write('Введите цена '); readln(x.cena);
write('Введите день '); readln(x.day);
write('Введите месяц '); readln(x.moth);
write('Введите год '); readln(x.year);
writeln;
Add(S, x); {добавление в стек}
write('Добавить ещё? y - Да, n - Нет ');
readln(usl);
if usl = 'y' then inc(n);
end;
end;
{---------------------------------CОРТИРОВКА ПО КОЛИЧЕСТВУ------------------------------------------}
procedure ShellSort(var S2: Stapel; param: integer; x: tovar);
const
steps = 12;
var
i, j, l, k, p, n, fsize: Integer;
s: array [1..steps] of Integer;
z: ZKnote;
begin
k := 1;
{ Формируем последовательность чисел -
шаги, с которыми выбираем сортируемые подмассивы }
for i := steps downto 1 do
begin
s := k;
k := k * 2 + 1;
end;
{ Сортировки подмассивов вплоть до шага 1 -
обычной сортировки пузырьком }
for k := 1 to steps do
begin
l := s[k];
{ Для каждого шага l нужно отсортировать l подмассивов }
for p := 1 to l do
begin
i := filesize(f1) - l;
n := 1;
{ Сортировка подмассива пузырьком с остановкой }
{ Подмассив - это (A[p], A[p+l], A[p+2*l], ...) }
while n > 0 do
begin
n := 0;
j := p;
while j <= i do
begin
case param of
1: {сортировка по названию товара}
begin
if ma[j].name > ma[j + l].name then
begin
x := ma[j];
ma[j] := ma[j + l];
ma[j + l] := x;
n := 1;
end;
end;
2: {сортировка по производителю товара}
begin
if ma[j].made > ma[j + l].made then
begin
x := ma[j];
ma[j] := ma[j + l];
ma[j + l] := x;
n := 1;
end;
end;
3: {сортировка по количеству товара}
begin
if ma[j].kol > ma[j + l].kol then
begin
x := ma[j];
ma[j] := ma[j + l];
ma[j + l] := x;
n := 1;
end;
end;
4: {сортировка по цене товара}
begin
if ma[j].cena > ma[j + l].cena then
begin
x := ma[j];
ma[j] := ma[j + l];
ma[j + l] := x;
n := 1;
end;
end;
5: {сортировка по месяцу поступленя товара}
begin
if ma[j].moth > ma[j + l].moth then
begin
x := ma[j];
ma[j] := ma[j + l];
ma[j + l] := x;
n := 1;
end;
end;
end;
j := j + l;
end;
i := i - l;
end;
end;
end;
close(f1);
rewrite(f1); {Запись в файл}
for j := 1 to fsize do {добавляем элемены в стек}
begin
write(f1, ma[j]);
end;
close(f1);
end;
{--------------------------------Поиск базы-------------------------------------------}
procedure Search(var S: Stapel; param: integer);
var z: ZKnote;
begin
clrscr;
key := false; {Флажок для проверки нахождения товара}
write('Название товара: '); readln(sename);
writeln('Название':12, 'Производитель':17, 'Количество':15, 'Цена':10, 'Дата':13);
while not EOF(f1) do
begin
case param of
1:
begin
z := S.Spitze;
while z<>nil do
begin
if z^.info.name = sename then
begin
key := true;
end;
z:=z^.Next;
end;
end;
2:
begin
z := S.Spitze;
while z<>nil do
begin
if z^.info.made = sename then
begin
key := true;
end;
z:=z^.Next;
end;
end;
3:
begin
z := S.Spitze;
while z<>nil do
begin
if inttostr(z^.info.kol) = sename then
begin
key := true;
end;
z:=z^.Next;
end;
end;
4:
begin
z := S.Spitze;
while z<>nil do
begin
if inttostr(z^.info.cena) = sename then
begin
key := true;
end;
z:=z^.Next;
end;
end;
5:
begin
z := S.Spitze;
while z<>nil do
begin
if inttostr(z^.info.moth) = sename then
begin
key := true;
end;
z:=z^.Next;
end;
end;
end;
end;
if key = false then WriteLn('Товар не найден':40);
readln;
menu;
end;
{---------------------------------МЕНЮ------------------------------------------}
procedure menu_print(item_select: integer);
var
item: array[1..8] of string;
item_razd: string;
i: integer;
begin
clrscr;
item_razd := '';
writeln(' ---=Главное меню=---');
item[1] := '·Создать базу товаров ';
item[2] := '·Загрузить из файла ';
item[3] := '·Добавить товар ';
item[4] := '·Удалить товар ';
item[5] := '·Поиск товара ';
item[6] := '·Просмотреть базу товаров ';
item[7] := '·О программе ';
item[8] := '·Выйти из программы ';
for i := 1 to 8 do
begin
if (item_select = i) then begin
write(item_razd);
textcolor(black);
textbackground(white);
writeln(item);
textcolor(white);
textbackground(black);
end
else begin
write(item_razd);
writeln(item);
end;
end;
HideCursor;
end;
//-----------------------Графическое Оформление Меню--------------------------//
//------------------------------Работа Меню-----------------------------------//
procedure menu;
var
c: char;
n: integer;
begin
n := 1;
menu_print(n);
c := readkey;
while c <> #13 do
begin
if (c = #0) then
case ord(readkey) of
40:
if (n = 8) then n := 1
else inc(n);
38:
if (n = 1) then n := 8
else dec(n);
end;
menu_print(n);
c := readkey;
end;
case n of
1: { Создать базу товаров }
begin
clrscr;
CreatBase;
Vvod;
SaveFile(s);
menu;
end;
2: { Загругить из файла }
begin
LoadBase;
readln;
menu;
end;
3: { Добавить товар }
begin
Vvod;
menu;
end;
4: { Удалить товар }
begin
clrscr;
print(S);
writeln;
write('Введите номер элемента кот. хотели бы удалить '); readln(pos);
DelElem(S, pos);
menu;
end;
5: { Поиск товара }
begin
clrscr;
menu_search_R;
end;
6: { Просмотреть базу товаров }
begin
clrscr;
menu1;
end;
7: { О программе }
begin
clrscr;
writeln('Создать файл, содержащий сведения о товарах, имеющихся на складе. Каждая запись имеет поля: наименование товара; количество единиц товара; дата поступления товара на склад. На экран и в отдельный файл вывести список товаров в алфавитном порядке, хранящихся более одного месяца, стоимость которых превышает 100000 рублей. В другой файл вывести в алфавитном порядке список товаров, поступивших на склад в феврале месяце.');
readln;
menu;
end;
8: exit;
end;
end;
//------------------------------Работа Меню-----------------------------------//
{---------------------------------МЕНЮ------------------------------------------}
procedure menu_print1(item_select: integer);
var
item: array[0..5] of string;
item_razd: string;
i: integer;
begin
clrscr;
item_razd := ' ';
item[0] := '<-- ';
item[1] := 'Название';
item[2] := ' Производитель ';
item[3] := 'Количество ';
item[4] := ' Цена ';
item[5] := ' Дата';
write(item_razd);
for i := 0 to 5 do
begin
if (item_select = i) then begin
write(item_razd);
textcolor(black);
if (i = 0) then textbackground(red)
else textbackground(white);
write(item);
textcolor(white);
textbackground(black);
end
else begin
write(item_razd);
write(item);
end;
end;
HideCursor;
writeln;
print(s);
end;
//-----------------------Графическое Оформление Меню--------------------------//

//---------------------Просмотреть базу товаров-------------------------------//
procedure menu1;
var
c: char;
n: integer;
begin
if FileExists(sname + '.txt') = false then begin {проверка был ли открыт файл, если нет, то выход в гл. меню}
write('База не была загружена!!!'); readln; menu;
end {проверка, был ли открыт файл}
else begin
n := 1; {пункт меню выбранный поумолчанию}
menu_print1(n); {вызов процедуры граф. отображения меню}
c := readkey;
while c <> #13 do
begin
if (c = #0) then
case (ord(readkey)) of
39:
if (n = 5) then n := 0
else inc(n);
37:
if (n = 0) then n := 5
else dec(n);
end;
menu_print1(n);{вызов процедуры граф. отображения меню}
c := readkey;
end;
if (n = 0) then {если выбран 0-й пункт меню, то выход в гл. меню}
menu
else begin
menu1;
end;
end;
end;
//------------------------------Работа Меню-----------------------------------//
{---------------------------------МЕНЮ------------------------------------------}
procedure menu_search(item_select: integer);
var
item: array[1..6] of string;
item_razd: string;
i: integer;
begin
clrscr;
item_razd := '';
writeln('---=Меню поиска=---');
item[1] := '·Название ';
item[2] := '·Производитель ';
item[3] := '·Количество ';
item[4] := '·Цена ';
item[5] := '·Месяц ';
item[6] := 'Назад ';
write(item_razd);
for i := 1 to 6 do
begin
if (item_select = i) then begin
write(item_razd);
textcolor(black);
textbackground(white);
writeln(item);
textcolor(white);
textbackground(black);
end
else begin
write(item_razd);
writeln(item);
end;
end;
HideCursor;
writeln;
end;
//-----------------------Графическое Оформление Меню--------------------------//
//------------------------------Работа Меню-----------------------------------//
procedure menu_search_R;
var
c: char;
n: integer;
begin
if FileExists(sname + '.txt') = false then begin write('База не была загружена!!!'); readln; menu; end {проверка, был ли открыт файл}
else begin
n := 1; {пункт меню выбранный поумолчанию}
menu_search(n); {вызов процедуры граф. отображения меню}
c := readkey;
while c <> #13 do
begin
if (c = #0) then
case (ord(readkey)) of
40:
if (n = 6) then n := 1
else inc(n);
38:
if (n = 1) then n := 6
else dec(n);
end;
menu_search(n); {вызов процедуры граф. отображения меню}
c := readkey;
end;
if (n = 6) then menu
else Search(S, n);
end;
end;
begin
Menu;
end.

Всем спасибо! Было очень приятно пообщаться=)

Никто не может помоч??? Ладно... буду сам змагаться=)))

выложи свои задачи на 1с лансер, тебе их тупо за отзыв решат)))

спасбо за совет.... но как нить уже сам=)

Хотя тебе это наверное уже нафиг ненадо, но из любопытства..

5 - навскидку как-то так..

Код:

Процедура КнопкаСформироватьНажатие(Кнопка)
перем x,y,f;
Для i = 1 По 10 Цикл
x = i/10;
y = 2 + x/(6 + x/(10 + x/(14 + x/(18 + x/22))));
f = (y + x)/(y - x);
Сообщить(f);
КонецЦикла;
КонецПроцедуры

спасибо=)) это уже решена...
осталась 2 и 4

В первой задачке непонятно немного.
Если в массиве числа от 1 до N, ну скажем до 100, то примерно так..

Код:

ubound = array.ubound();

For x = 0 To ubound Do
array[x] = (array[x] + array[ubound])*(ubound/2);
EndDo;

array это входной массив заполненный от 1 до 100

Если же там в массиве может быть все что угодно + произвольная длина...

Код:

Процедура КнопкаСформироватьНажатие(Кнопка)
incomingArray = New array();
incomingArray.add(445);
incomingArray.add(345);
incomingArray.add(7875645444);
incomingArray.add(-32211);
incomingArray.add(55);
incomingArray.add(21);
incomingArray.add(199199);

result  = New array(incomingArray.UBound()+1);
For x = 0 To incomingArray.UBound() Do
summ = 0;

For y = 0 To x Do
summ = summ + incomingArray[y];
EndDo;
result[x] = summ;
EndDo;

КонецПроцедуры

Хотя наверняка можно сделать и изящнее

вторую и четвертую я не очень понял..
Что за матрица? таблица чтоль? и как именно сортировать то?
дай пример короче)

Четвертая.. что-то много там хотят..
Надо по кускам. Ты уже что-то сделал или голяк?

согласен... но все же интересуют только
2. Дана матрица. Упорядочить элементы столбцов матрицы по неубыванию, а сами столбцы по возрастанию минимальных элементов столбцов. Использовать быструю сортировку, реализовав метод в виде подпрограммы.

и
4.
Создать файл, содержащий сведения о товарах, имеющихся на складе. Каждая запись имеет поля: наименование товара; количество единиц товара; дата поступления товара на склад. На экран и в отдельный файл вывести список товаров в алфавитном порядке, хранящихся более одного месяца, стоимость которых превышает 100000 рублей. В другой файл вывести в алфавитном порядке список товаров, поступивших на склад в феврале месяце. Программа должна выполнять следующие дополнительные функции: создание новой базы данных; открытие базы из файла; сохранение базы в файл; добавление записей; удаление записей; поиск записей по одному из полей; сортировку по одному из полей методом, указанным в задаче 3; вывод базы данных на экран; выход из программы. Для реализации основных действий алгоритма использовать подпрограммы. Для обработки записей реализовать динамическую структуру данных односвязный список.

Хотя все равно спасибо!

Что значит упорядочить по неубыванию? давай пример до и после
что есть и что надо получить

Тож парюсь над этим вопросом- поидее по возрастанию

есть матрица
1 2 3
4 7 2
3 5 6

сперва получить
1 2 2
3 6 3
4 7 6 - т.е мперва сортировка столбцов по неубыванию...

и потом найти мин элементы в столбцах и по их возрастанию их переставить....

Что-то я все равно не вникаю в суть задачи...

"2. Дана матрица. Упорядочить элементы столбцов матрицы по неубыванию, а сами столбцы по возрастанию минимальных элементов столбцов. Использовать быструю сортировку, реализовав метод в виде подпрограммы."

Мне кажется её всю нужно перефразировать с преподом.

То есть какая-то таблица с цифрами, их надо перетасовать.
1. упорядочить элементы столбцов по возрасчтанию.

1 2 3
6 1 3
2 4 6
то есть получится:
1 1 3
2 2 3
6 4 6
Так чтоль....
Далее порядок столбцов по возрастанию наименьшего элемента.. тут более менее понятно.
А вот что такое быстрая сортировка - вообще туман! Мне например это ниочем не говорит.
.... сделать как угодно и обозвать это "быстрая сортировка"? ))

Да мне хоть как сделать.. препод по принципу до сессии со студентами не разговаривает!

спс=))