Сколько различных ожерелий можно составить?

[Viachka]

Сколько различных ожерелий можно составить?

Доброго времени суток, помогите написать программу на PascalABC:

Сколько различных ожерелий можно составить из 2-ух белых, 2-ух синих и 2-ух красных бусин. Напечатать возможные варианты и их кол-во.:tehnari_ru_837:

 

[Vladimir_S]

Сколько различных ожерелий можно составить из 2-ух белых, 2-ух синих и 2-ух красных бусин.

Это-то элементарно, и Паскаль не нужен. У меня получается, что количество вариантов есть (6!)/(2³)=90. Поясню. В числителе дроби - полное количество перестановок из шести бусин. Естественно, мы должны исключить повторяющиеся варианты, которые возникают из-за неразличимости бусин в паре одного цвета, а поскольку таких пар - три, вот и получается 2³=8 в знаменателе.

Напечатать возможные варианты и их кол-во.

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

 

[Viachka]

А правильно ли будет сделать вот так:
function f(z : byte) : real; begin if (z <= 1) then f := 1 else f := f(z - 1) * z; end;
И ищё вопрос как правильно вывести результат на экран.

 

[Vladimir_S]

А правильно ли будет сделать вот так:
function f(z : byte) : real; begin if (z <= 1) then f := 1 else f := f(z - 1) * z; end;
И ищё вопрос как правильно вывести результат на экран.

Правильно. Но это всего лишь рекурсивная функция вычисления факториала.
1. И что Вы с ней делать собираетесь?
2. А зачеркивать-то зачем?
3. Какой результат Вы собираетесь выводить?

 

[Viachka]

1. Я собираюсь её использовать как функцию, которая вычисляет вариации.
2. Случайно получилось.
3. Вывести все вариации в отдельном окне.

 

[Vladimir_S]

3. Вывести все вариации в отдельном окне.

Так в этом-то и загвоздка. Очень непростая задача.

 

[Vladimir_S]

Ну так, программу-то я нарисовал, вот только не знаю, будет ли Вам с этого прок. Потому что я предупреждал - задача сложная, и не знаю, сумеете ли разобраться в коде. Ну, спрашивайте, если что - постараюсь объяснить. Обозначение цветов бусин:
w (white) - белая
b (blue) - синяя
r - (red) - красная.
И да, программа писалась и отлаживалась в НОРМАЛЬНОМ Паскале (в данном случае - Free), а за возможные глюки этого дебильного псевдо-лже-недопаскаля АВС я не отвечаю.

Var
 Q:Array[1..720,1..6] of Byte;
 i1,i2,i3,i4,i5,i6,m:byte;
 i,j,k,p:Integer;
 b,b1:boolean;
Begin
 p:=1;
 for i1:=1 to 6 do
  begin
   if (i1<3) then Q[p,1]:=1 else if (i1>4) then Q[p,1]:=3 else Q[p,1]:=2;
   for i2:=1 to 6 do
    if (i2<>i1) then
     begin
      if (i2<3) then Q[p,2]:=1 else if (i2>4) then Q[p,2]:=3 else Q[p,2]:=2;
      for i3:=1 to 6 do
       if (i3<>i1) and (i3<>i2) then
        begin
         if (i3<3) then Q[p,3]:=1 else if (i3>4) then Q[p,3]:=3 else Q[p,3]:=2;
         for i4:=1 to 6 do
          if (i4<>i3) and (i4<>i2) and (i4<>i1) then
           begin
            if (i4<3) then Q[p,4]:=1 else if (i4>4) then Q[p,4]:=3 else Q[p,4]:=2;
            for i5:=1 to 6 do
             if (i5<>i4) and (i5<>i3) and (i5<>i2) and (i5<>i1) then
              begin
               if (i5<3) then Q[p,5]:=1 else if (i5>4) then Q[p,5]:=3 else Q[p,5]:=2;
               for i6:=1 to 6 do
                if (i6<>i5) and (i6<>i4) and (i6<>i3) and (i6<>i2) and (i6<>i1) then
                 begin
                  if (i6<3) then Q[p,6]:=1 else if (i6>4) then Q[p,6]:=3 else Q[p,6]:=2;
                  Inc(p);
                  if p<721 then for m:=1 to 6 do Q[p,m]:=Q[p-1,m];
                 end;
              end;
           end;
        end;
     end;
  end;
 Dec(p);
 for i:=1 to p-1 do
  Repeat
   b1:=true;
   for j:=i+1 to p do
    begin
     b:=true;
     for m:=1 to 6 do if Q[i,m]<>Q[j,m] then b:=false;
     if b then
      begin
       for k:=j+1 to p do Q[k-1]:=Q[k];
       Dec(p);
       b1:=false;
      end;
    end;
  Until b1;
 Writeln('Number of variants = ',p);
 Writeln;
 for i:=0 to 17 do
  begin
   for j:=1 to 5 do
    begin
     for m:=1 to 6 do
      begin
       if Q[i*5+j,m]=1 then write('w');
       if Q[i*5+j,m]=2 then write('b');
       if Q[i*5+j,m]=3 then write('r');
      end;
     write('    ');
    end;
   writeln;
  end;
 Readln
End.