Версия для печати темы
Нажмите сюда для просмотра этой темы в обычном формате
Форум «Всё о Паскале» _ Задачи _ Типизированные файлы
Автор: leahov 3.06.2006 16:17
Ещё одна задача
Пусть матрица 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.
Она показывает матрицу, но не выводит результат совпадающие между собой строки и столбцы, как енто сделать?
Автор: leahov 3.06.2006 16:30
похоже что всё таки это не из этой оперы
Автор: RaV 3.06.2006 16:33
А где у тебя файл?
И ещё совподать должны строки со столбцами или строки со строками а столбцы со столбцами?
Автор: volvo 3.06.2006 16:35
leahov, а ты внимательно смотрел на свою процедуру Iskat ? Тебе надо сначала проходить по всем возможным комбинациям строк (2 вложенных цикла) и сравнивать элементы этих строк между собой, потом - проходить по всем комбинациям столбцов, и их сравнивать. А ты сделал... Хм... Непонятно что...
Автор: leahov 3.06.2006 16:45
оп, звиняйте, я не весь код влил
это вообща код из моей другой задачи, извините перепутал
С этой я ещё не начинал. Тогда начнем с разбора - значит по этой задаче мне нужно из какого-то файла взять матрицу, найти в ней совпадающие строки со столбцами. Вопрос - в этом текстовом файле должна уже быть матрица или програмно туда её засовывать?
Автор: RaV 3.06.2006 16:49
Вопрос - в этом текстовом файле должна уже быть матрица или програмно туда её засовывать?
Я думаю, что должна быть записана в файле.
Пусть матрица A целых чисел размером 10 на 10 записана по строкам в файле
Автор: leahov 3.06.2006 17:01
Ребят, в общем если можете помочь решить два задания буду очень благодарен, так чтоб не мучать вас всякими своими вопросами. Обещаю, что тоже буду их делать отдельно от Вас. Вот задания
1) Пусть матрица A целых чисел размером 10 x 10 записана по строкам в файле. Найдите все совпадающие между собой строки и столбцы и выведите их номера.
2) Пусть дан текстовый файл. Отыскать слово, рас-положенное в середине текста. Если таких слов окажется два (при четном количестве слов в тексте), запросить у пользователя выбрать одно из слов. Записать в новый текстовый файл все слова, в которых не содержатся литеры, присутствующие в найденном слове.
Ещё раз повторяю, я тоже буду их решать.
Автор: RaV 3.06.2006 17:17
Ты их реши,а если не будет что-то получаться задашь вопрос.
Автор: leahov 3.06.2006 17:25
у меня просто срок сдачи в понедельник, дома интернета нет, я решаю тут в тихаря на работе, но через полчаса вырубят свет и всё! Да, я знаю что Вы не обязаны мне помогать, но в виде исключения, пожалуйста помогите. Осталось сделать только эти два задания и всё, прощай Pascal. На следующих курсах информатики не будет, а так не хочется сдавать его весной. В библиотеке нашел только один учебник Немнюгина. кое что беру из него, но там тоже не всё для меня понятно. Так что ещё раз прошу, если есть возможность помочь, буду очень благодарен.
Автор: Bokul 3.06.2006 23:53
Вот. Вроде все работает. Считывания сможешь сам организовать?
Только 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.
Автор: leahov 5.06.2006 13:23
Bokul спасибо. вроде довел до рабочего состояния
Автор: leahov 5.06.2006 15:17
Уважаемые знатоки Паскаля
Так и не смог написать что-то стоящее по заданию:
Пусть дан текстовый файл. Отыскать слово, рас-положенное в середине текста. Если таких слов окажется два (при четном количестве слов в тексте), запросить у пользователя выбрать одно из слов. Записать в новый текстовый файл все слова, в которых не содержатся литеры, присутствующие в найденном слове.
Пересмотрел кучу раз форум, но так и не смог найти что-то похожее. Завис с этим заданием, отправили домой до завтра решить её иначе пересдача осенью. Причем жестоко, собрать коммисию, договориться с ними, потом с деканом, на выделение аудитории - в общем мороки полно. Пожалуйста напишите код задачи 
Автор: Bokul 6.06.2006 7:27
Вот вроде сделал...
Алгоритм: сначала проходимся по файлу и считаем количество слов (пробелов)(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.
Автор: leahov 6.06.2006 11:05
Bokul спасибо добрый человек!
Автор: volvo 6.06.2006 11:53
Нужен еще вариант?
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.
Автор: Malice 6.06.2006 13:43
Ну раз пошла такая пьянка, вот тебе вариант для комикадзе 
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.