Помощь - Поиск - Пользователи - Календарь
Полная версия: Паскаль-программа, которая продуцирует цепочки в трёхсимвольном алфавите с записью их в файл...
Форум «Всё о Паскале» > Pascal, Object Pascal > Задачи
sergey121212
10.01.2012 1:41
Создать Паскаль-программу, которая будет продуцировать цепочки в трёхсимвольном алфавите с записью их в файл, причем длина L цепочек ограничена: 4 <= L <= 8. Содержит одно сочетание «аb», заканчивается на «b» и символы «b» и «с» не стоят рядом Общее количество цепочек в файле должна быть не больше 20.

Вот что получилось сделал чтобы было ограничивалась от 4 до 8 и сделал чтобы было не больше 20 , но не могу сделать чтобы "Содержит одно сочетание «аb», заканчивается на «b»(сделал) и символы «b» и «с» не стоят рядом"

Код

Program pr01;
uses Crt;
const
  alf: string = 'ABC';
  n = 20;
type
  mass = array [1..n] of string;
function InMass(a: mass; s: string): boolean;
var
  i: integer;
begin
  InMass := False;
  for i := 1 to n do begin
    if a[i] = s then begin
      InMass := True;
      exit;
    end;
  end;
end;
function P(l: integer): string;
var
  i: integer;
  st: string;
begin
  st := '';
  for i := 1 to l do begin
    st := st + alf[random(length(alf))+1];
  end;
  P := st;
end;
var
  i,j,l1,l2,l3: integer;
  s: mass;
  st: string;
begin
  ClrScr;
  Randomize;
  i := 1;
  while i <= n do begin
    l1 := random(5)+3;
    st := P(l1)+'B';
    if InMass(s, st) then continue;

    s[i] := st;
    i := i + 1;
  end;

  for i := 1 to n do begin
    for j := i to n do begin
      if length(s[i]) > length(s[j]) then
      begin
        st := s[i];
        s[i] := s[j];
        s[j] := st;
      end;
    end;
  end;
  
  for i := 1 to n do begin
    write(i:2,' ');
    Write(s[i]);
    writeln(' len=',length(s[i]));
  end;
end.
Федосеев Павел
11.01.2012 3:55
Я не зарегистрирован на форуме, но вопрос заинтересовал.

Мне видится решение в следующем...

Общие соображения:
1) исходя из "заканчивается на «b»" получаем цепочку вида 'x...xB'
2) исходя из "символы «b» и «с» не стоят рядом" получаем цепочку вида 'x...xAB'
3) исходя из "символы «b» и «с» не стоят рядом" и "Содержит одно сочетание «аb»" получим, что символ 'B' или больше не встречается в цепочке или стоит самым первым, т.е. 'BAx...xAB', 'BBAx...xAB' или 'x...xAB' (где x - символы 'A' или 'C').

Таким образом, цепочки из L символов формируются так:
1) символ 1 выбирается из алфавита "ABC"
2) символы со 2 по L-2 формируются из алфавита на два символа "AB" или "AC" в зависимости от значения предыдущего символа. Формируются случайно или перебором (цикл или рекурсия)
3) два последних символа (L-1, L) принимаются равными 'AB'

Примерно, так

...
  пусть RandomChar возвращает случайный символ из строки-параметра
...
  S[1]:=RandomChar('ABC');
  for i:=2 to L-2 do begin
    if S[i-1]='B' then
      NextChar:=RandomChar('AB')
    else
      NextChar:=RandomChar('AC');
    S:=S+NextChar;
  end;
  S:=S+'AB';



Но, мне кажется, что есть алгоритм пооптимальнее.
TarasBer
11.01.2012 13:44
В конце тоже может быть сколько угодно B
То есть строка имеет вид

B...BA...AB...B
Крайние троеточия состоят только из B, среднее - из A и C
sergey121212
11.01.2012 23:27
А можете пожалуйста написать полный код программы т.к. что то не получается?

Добавлено через 16 мин.
не работает RandomChar

Добавлено через 16 мин.
Также мне нужно чтобы строки на повторялись вот задание


Создать Паскаль - программу, которая будет продуцировать цепочки в трьохсимвольному алфавите с записью их в файл, причем длина L цепочек ограничено: 4 <= L <= 8; для каждой цепочки, отобранного в файл, должно выполняться условие Содержит одно сочетание «аb», заканчивается на «b» и символы «b» и «с» не стоят рядом Общее количество цепочек в файле должна быть не более 20

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

Код


program pr01;

uses crt;
var n,i,k,r1,r2:integer; s:string;  f1,f2:boolean;  f:file of string;
begin randomize; clrscr;
assign(f,'f.txt');
rewrite(f);
      write('n=');
      readln(n);
      writeln;
      k:=0;
      for i:=1 to n do
      begin if ((i-1)mod 20)=0 then k:=k+1;
            s:='b';
            r2:=random(5);
            f1:=false;
            f2:=false;
            repeat begin
                   r1:=random(3);
                   if ((r1=0)and(length(s)<7)and(f1=false)) then begin s:='c'+'a'+s;
                                                                        f1:=true;
                                                                  end;
                   if ((r1=1)and(f2=false)) then begin f1:=false;
                                                       f2:=true;
                                                       s:=s+'c';
                                                 end;
                   if r1=2 then begin f1:=false;
                                      s:=s+'b';
                                end;
                   end until ((length(s)>3+r2));
            begin
            insert('b',s, pos('bc',s));
            delete(s, pos('bc',s),2);
            insert('a',s, pos('cb',s));
             delete(s, pos('cb',s),2);  end;
            writeln(s);write(f,s);
      end;

  close(f);
end.


TarasBer
12.01.2012 13:40
> не работает RandomChar

Ну дык сам напиши же.
sergey121212
12.01.2012 20:32
так помоги написать
sergey121212
12.01.2012 21:26
Вот сделал наконец-то

Код

uses crt;
var r1,p,n,r2,k,i,m:integer;
l:array[1..100] of string;
s,t:string;
f:file of string;
begin   clrscr;
assign(f,'f.txt');
rewrite(f);
randomize;
l[1]:='';
k:=1; n:=0;
repeat
begin
r2:=random(5)+2;
p:=r2;
if r2<>0 then
begin
s:='';
m:=0;
repeat
begin
r1:=random(4);
if (r1=0) and (length(s)<6) and (m=0) then
begin
m:=m+1;
s:=s+'ab';
t:='b'
end;
if (r1=1) and (t<>'b') then begin t:='c'; s:=s+'c'; end;
if (r1=2) and (length(s)<6) then begin t:='a'; s:=s+'a'; end;
if (r1=3) and (t<>'c') and (t<>'a') then begin t:='b'; s:=s+'b'; end;
end;
until ((length(s)>r2));
if (m>0) and (t<>'c') and (t<>'a') then s:=s+'b' else s:='';
end;
for i:=1 to k do
if s<>l[i] then n:=n+1;
if n=k then
begin
k:=k+1;
l[k]:=s;
write(f,l[k]);
end;
n:=0;
end;
until k>20;
writeln;
writeln;
writeln('Нужные слова : ');;
reset(f);
for i:=1 to k-1 do
begin
read(f,l[i]);
writeln(l[i]);
end;
close(f);
end.
Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.