Типизированные файлы, матрица Опции

[leahov]

Ещё одна задача
Пусть матрица 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]

похоже что всё таки это не из этой оперы

[RaV]

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

И ещё совподать должны строки со столбцами или строки со строками а столбцы со столбцами?

[volvo]

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

Найдите все совпадающие между собой строки и столбцы

Задание, кстати, неоднозначное...

[leahov]

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

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

[RaV]

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

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

Пусть матрица A целых чисел размером 10 на 10 записана по строкам в файле

[leahov]

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

[RaV]

Ты их реши,а если не будет что-то получаться задашь вопрос.

[leahov]

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

[Bokul]

Пусть матрица 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 - 2.11.2006 21:34

[leahov]

Bokul спасибо. вроде довел до рабочего состояния

[leahov]

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

[Bokul]

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

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

Алгоритм: сначала проходимся по файлу и считаем количество слов (пробелов)(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 - 2.11.2006 21:34

[leahov]

Bokul спасибо добрый человек!

[volvo]

Нужен еще вариант?

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]

Ну раз пошла такая пьянка, вот тебе вариант для комикадзе

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.