IPB
ЛогинПароль:

> Прочтите прежде чем задавать вопрос!

1. Заголовок темы должен быть информативным. В противном случае тема удаляется ...
2. Все тексты программ должны помещаться в теги [code=pas] ... [/code], либо быть опубликованы на нашем PasteBin в режиме вечного хранения.
3. Прежде чем задавать вопрос, см. "FAQ", если там не нашли ответа, воспользуйтесь ПОИСКОМ, возможно такую задачу уже решали!
4. Не предлагайте свои решения на других языках, кроме Паскаля (исключение - только с согласия модератора).
5. НЕ используйте форум для личного общения, все что не относится к обсуждению темы - на PM!
6. Одна тема - один вопрос (задача)
7. Проверяйте программы перед тем, как разместить их на форуме!!!
8. Спрашивайте и отвечайте четко и по существу!!!

 
 Ответить  Открыть новую тему 
> Типизированные файлы, матрица
сообщение
Сообщение #1


Новичок
*

Группа: Пользователи
Сообщений: 39
Пол: Мужской
Реальное имя: leahov

Репутация: -  0  +


Ещё одна задача
Пусть матрица A целых чисел размером 10 на 10 записана по строкам в файле. Найдите все совпадающие между собой строки и столбцы и выведите их номера.

uses crt;
var a: array[1..10,1..10] of Integer; {Матрица}
x,y: Integer;

procedure Iskat;
var Flag: Boolean;
begin
for x:=1 to 10 do
begin
Flag:=True;
for y:=1 to 10 do if a[x,y]<>a[y,x] then Flag:=False;
if Flag then WriteLn(x);
end;
end;

begin
Clrscr;
TextAttr:=7;
Randomize;
for x:=1 to 10 do for y:=1 to 10 do a[x,y]:=Random(2); {Заполняем массив}
Iskat;
for x:=1 to 10 do
begin
for y:=1 to 10 do Write(a[x,y]:5,' '); {Столбец(y) - строка(x)}
WriteLn;
end;
end.


Она показывает матрицу, но не выводит результат совпадающие между собой строки и столбцы, как енто сделать?
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


Новичок
*

Группа: Пользователи
Сообщений: 39
Пол: Мужской
Реальное имя: leahov

Репутация: -  0  +


похоже что всё таки это не из этой оперы
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


Новичок
*

Группа: Пользователи
Сообщений: 26
Пол: Мужской
Реальное имя: Владимир

Репутация: -  0  +


А где у тебя файл?

И ещё совподать должны строки со столбцами или строки со строками а столбцы со столбцами?
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


Гость






leahov, а ты внимательно смотрел на свою процедуру Iskat ? Тебе надо сначала проходить по всем возможным комбинациям строк (2 вложенных цикла) и сравнивать элементы этих строк между собой, потом - проходить по всем комбинациям столбцов, и их сравнивать. А ты сделал... Хм... Непонятно что...

Цитата
Найдите все совпадающие между собой строки и столбцы
Задание, кстати, неоднозначное...
 К началу страницы 
+ Ответить 
сообщение
Сообщение #5


Новичок
*

Группа: Пользователи
Сообщений: 39
Пол: Мужской
Реальное имя: leahov

Репутация: -  0  +


оп, звиняйте, я не весь код влил

это вообща код из моей другой задачи, извините перепутал
С этой я ещё не начинал. Тогда начнем с разбора - значит по этой задаче мне нужно из какого-то файла взять матрицу, найти в ней совпадающие строки со столбцами. Вопрос - в этом текстовом файле должна уже быть матрица или програмно туда её засовывать?
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #6


Новичок
*

Группа: Пользователи
Сообщений: 26
Пол: Мужской
Реальное имя: Владимир

Репутация: -  0  +


Цитата

Вопрос - в этом текстовом файле должна уже быть матрица или програмно туда её засовывать?


Я думаю, что должна быть записана в файле.
Цитата

Пусть матрица A целых чисел размером 10 на 10 записана по строкам в файле
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #7


Новичок
*

Группа: Пользователи
Сообщений: 39
Пол: Мужской
Реальное имя: leahov

Репутация: -  0  +


Ребят, в общем если можете помочь решить два задания буду очень благодарен, так чтоб не мучать вас всякими своими вопросами. Обещаю, что тоже буду их делать отдельно от Вас. Вот задания
1) Пусть матрица A целых чисел размером 10 x 10 записана по строкам в файле. Найдите все совпадающие между собой строки и столбцы и выведите их номера.
2) Пусть дан текстовый файл. Отыскать слово, рас-положенное в середине текста. Если таких слов окажется два (при четном количестве слов в тексте), запросить у пользователя выбрать одно из слов. Записать в новый текстовый файл все слова, в которых не содержатся литеры, присутствующие в найденном слове.
Ещё раз повторяю, я тоже буду их решать.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #8


Новичок
*

Группа: Пользователи
Сообщений: 26
Пол: Мужской
Реальное имя: Владимир

Репутация: -  0  +


Ты их реши,а если не будет что-то получаться задашь вопрос.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #9


Новичок
*

Группа: Пользователи
Сообщений: 39
Пол: Мужской
Реальное имя: leahov

Репутация: -  0  +


у меня просто срок сдачи в понедельник, дома интернета нет, я решаю тут в тихаря на работе, но через полчаса вырубят свет и всё! Да, я знаю что Вы не обязаны мне помогать, но в виде исключения, пожалуйста помогите. Осталось сделать только эти два задания и всё, прощай Pascal. На следующих курсах информатики не будет, а так не хочется сдавать его весной. В библиотеке нашел только один учебник Немнюгина. кое что беру из него, но там тоже не всё для меня понятно. Так что ещё раз прошу, если есть возможность помочь, буду очень благодарен.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #10


Гуру
*****

Группа: Пользователи
Сообщений: 1 117
Пол: Мужской
Реальное имя: Богдан

Репутация: -  11  +


Цитата
Пусть матрица A целых чисел размером 10 x 10 записана по строкам в файле. Найдите все совпадающие между собой строки и столбцы и выведите их номера.

Вот. Вроде все работает. Считывания сможешь сам организовать?
Только x и y прировняй 10
const x=5;
y=5;
type main=array[1..x,1..y] of integer;

procedure find_string(mas:main);
var i,j,k:integer;
b:boolean;
begin
for k:=1 to y-1 do
begin
for i:=k+1 to y do
begin
b:=true;
for j:=1 to x do
if mas[k,j]<>mas[i,j] then b:=false;
if b=true then writeln(k,' ',i);
end;
end;
end;

procedure find_colonne(mas:main);
var i,j,k:integer;
b:boolean;
begin
for k:=1 to x-1 do
begin
for i:=k+1 to x do
begin
b:=true;
for j:=1 to y do
if mas[j,k]<>mas[j,i] then b:=false;
if b=true then writeln(k,' ',i);
end;
end;
end;


Вот пример на котором я проверял:
const mas:array[1..5,1..5] of integer=((1,1,1,2,2),
(1,1,1,2,2),
(1,1,1,2,2),
(1,1,1,6,6),
(1,1,1,2,2));
var i,j:integer; temp:main;
begin
clrscr;
for i:=1 to 5 do
begin
for j:=1 to 5 do
begin
temp[i,j]:=mas[i,j];
write(temp[i,j],' ');
end;
writeln;
end;
writeln;
find_string(temp);
writeln;
find_colonne(temp);
readln;
end.


Сообщение отредактировано: volvo -


--------------------
Лао-Цзы :
Знать много и не выставлять себя знающим есть нравственная высота. Знать мало и выставлять себя знающим есть болезнь. Только понимая эту болезнь, мы можем избавиться от нее.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #11


Новичок
*

Группа: Пользователи
Сообщений: 39
Пол: Мужской
Реальное имя: leahov

Репутация: -  0  +


Bokul спасибо. вроде довел до рабочего состояния
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #12


Новичок
*

Группа: Пользователи
Сообщений: 39
Пол: Мужской
Реальное имя: leahov

Репутация: -  0  +


Уважаемые знатоки Паскаля
Так и не смог написать что-то стоящее по заданию:
Пусть дан текстовый файл. Отыскать слово, рас-положенное в середине текста. Если таких слов окажется два (при четном количестве слов в тексте), запросить у пользователя выбрать одно из слов. Записать в новый текстовый файл все слова, в которых не содержатся литеры, присутствующие в найденном слове.
Пересмотрел кучу раз форум, но так и не смог найти что-то похожее. Завис с этим заданием, отправили домой до завтра решить её иначе пересдача осенью. Причем жестоко, собрать коммисию, договориться с ними, потом с деканом, на выделение аудитории - в общем мороки полно. Пожалуйста напишите код задачи !mol1.gif !help.gif
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #13


Гуру
*****

Группа: Пользователи
Сообщений: 1 117
Пол: Мужской
Реальное имя: Богдан

Репутация: -  11  +


Цитата
Пусть дан текстовый файл. Отыскать слово, рас-положенное в середине текста. Если таких слов окажется два (при четном количестве слов в тексте), запросить у пользователя выбрать одно из слов. Записать в новый текстовый файл все слова, в которых не содержатся литеры, присутствующие в найденном слове.

Вот вроде сделал... smile.gif

Алгоритм: сначала проходимся по файлу и считаем количество слов (пробелов)(function count_words), потом
находим нужные слова(procedure find_words). Если их двое, то выбираем одно из них. Создаем новый файл, в который записываем слова, букв которых нет в выбранном слове.

program big_help;
uses crt;
procedure create_file(s:string);
var t:text;
temp:string;
begin
temp:='ab bc c bd km b ';
assign(t,s);
rewrite(t);
writeln(t,temp);
close(t);
end;

function count_words(s:string):integer;
var f:text;
n:integer;
temp:string;
ch:char;
begin
assign(f,s);
reset(f);
n:=0;
while not eof(f) do
begin
read(f,ch);
if (ch=' ') or (ch=#13) then
inc(n);
end;
count_words:=n;
close(f);
end;

function choose_word(r1,r2:string):string;
var ch:char;
begin
writeln('Press 1 if you want to choose first word : ',r1, ' and 2 if second : ',r2);
ch:=readkey;
if ch='1' then choose_word:=r1;
if ch='2' then choose_word:=r2;
end;

procedure find_words(n:integer; s:string; var res1,res2:string);
var f:text;
i,buf1,buf2:integer;
ch:char;
begin
i:=0;
res1:='';
res2:='';
if (n mod 2)=0 then
begin
buf1:=n div 2;
buf2:=n div 2 + 1;
end
else
begin
buf1:=n div 2 + 1;
buf2:=-1;
end;
assign(f,s);
reset(f);
while not eof(f) do
begin
read(f,ch);
if (ch=' ') or (ch=#13) then inc(i);
if (i=buf1-1) and (ch<>' ') then
res1:=res1+ch;
if (i=buf2-1) and (ch<>' ') then
res2:=res2+ch;
end;
close(f);
end;

procedure result_file(path1,path2,res:string);
var f1,f2:text;
ch:char;
buf:string;
i:integer;
b:boolean;
begin
assign(f1,path1);
assign(f2,path2);
reset(f1);
rewrite(f2);
buf:='';
b:=true;
while not eof(f1) do
begin
read(f1,ch);
if ch=' ' then
begin
for i:=1 to length(buf) do
if pos(buf[i],res)<>0 then
b:=false;
if b=true then write(f2,buf+' ');
b:=true;
buf:='';
end
else
buf:=buf+ch;
end;
close(f1);
close(f2);
end;
var num:integer; res1,res2,res:string;
begin
clrscr;
create_file('d:\temp.dat');
num:=count_words('d:\temp.dat');
find_words(num,'d:\temp.dat',res1,res2);
if res2<>'' then res:=choose_word(res1,res2)
else res:=res1;
result_file('d:\temp.dat','d:\res.dat',res);
readln;
end.


Сообщение отредактировано: volvo -


--------------------
Лао-Цзы :
Знать много и не выставлять себя знающим есть нравственная высота. Знать мало и выставлять себя знающим есть болезнь. Только понимая эту болезнь, мы можем избавиться от нее.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #14


Новичок
*

Группа: Пользователи
Сообщений: 39
Пол: Мужской
Реальное имя: leahov

Репутация: -  0  +


Bokul спасибо добрый человек!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #15


Гость






Нужен еще вариант?
uses crt;
type
Tst=Array[1..2] of string;

var
center_word: string;

function check(s: string): boolean;
var
to_do: boolean;
i: integer;
begin
to_do := true; i := 1;
while to_do and (i <= length(s)) do begin
to_do := (pos(s[i], center_word) = 0); inc(i);
end;
check := to_do;
end;

function ProcessWords(to_check: boolean;
var f, g: text; var st: Tst): integer;
const chars = [#10, #13, #26, ' '];
var
ch, foo: char;
i, _word_count, first, second: integer;
_word: string;
begin
second := maxInt;

for i := 1 to 2 - byte(to_check) do begin
_word_count := 0;
reset(f);
read(f, ch);

while not seekeof(f) do begin

while ch in chars do read(f, ch);

if ch <> #26 then _word := ch;

while not (ch in chars) do begin

read(f, ch);
if not (ch in chars) then _word := _word + ch
else break;

end;
if _word <> '' then begin

inc(_word_count);
if to_check then begin

if check(_word) then writeln(g, _word);

end;

if _word_count = first then st[1] := _word;
if _word_count = second then begin
st[2] := _word;
break;
end;

end;

end;
first := (_word_count div 2) + (_word_count mod 2);
second := first + (1 - (_word_count mod 2));
end;


ProcessWords := 1 + (second - first);
end;

var
st: Tst;
f, g: text;
i, n: integer;
begin
clrscr;
assign(f, '01.txt'); reset(f);
assign(g, '02.txt'); rewrite(g);
n := ProcessWords(false, f, g, st);
if n = 2 then begin
write('select the word: ');
for i := 1 to n do write('"' + st[i] + '" ');
write('[1, 2] -> '); readln(i);
center_word := st[i];
end
else center_word := st[1];

writeln('working with word: ', center_word);
ProcessWords(true, f, g, st);

close(f); close(g);
end.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #16


Профи
****

Группа: Пользователи
Сообщений: 705
Пол: Мужской

Репутация: -  20  +


Ну раз пошла такая пьянка, вот тебе вариант для комикадзе wacko.gif
uses crt;
const sl:set of char =['a'..'z','A'..'Z'];
var t:file of char;
y:text;
c:char;
b:boolean;
s1,s2:string;
i,kll,kol:integer;
begin
assign(t,'c:\readme.txt'); reset(t);
assign(y,'c:\readme.out'); rewrite(y);
b:=true;
kol:=0; clrscr;
for i:=0 to 1 do begin
repeat
read(t,c);
if (c in sl) and b then if i=0 then inc (kol) else inc (kll);
b:=not(c in sl);
until ((eof(t) and (i=0))) or ((kll=(kol div 2)) and (i=1));
if i=0 then begin reset (t); b:=true; kll:=0; end;
end;
b:=false;
repeat
if c in sl then
if kll=kol div 2 then s1:=s1+c else s2:=s2+c;
read(t,c);
if (c in sl) and b then inc (kll);
b:=not(c in sl);
until kll=(1+kol div 2+byte(odd(kol+1)));
if odd(kol+1) then begin
writeln ('Колво слов в тексте четно (',kol,'), какое нужно ?');
writeln ('1-',s1); writeln ('2-',s2);
repeat c:=readkey; until c in ['1','2'];
if c='2' then s1:=s2;
end;
reset(t);
s2:=''; b:=false;
repeat
if (c in sl) and b then s2:=s2+c else begin s2:=''; end;
read(t,c); b:=(c in sl);
if not(b) then begin
b:=true;
for i:=1 to length(s2) do b:=(pos(s2[i],s1)=0) and b;
if b and (length(s2)>0) then writeln (y,s2); b:=false;
end;
until eof(t);
close(t); close(y);
end.

smile.gif
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 




- Текстовая версия 23.08.2017 22:32
Хостинг предоставлен компанией "Веб Сервис Центр" при поддержке компании "ДокЛаб"