Форум программистов, компьютерный форум, киберфорум
Turbo Pascal
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.69/13: Рейтинг темы: голосов - 13, средняя оценка - 4.69
1 / 1 / 2
Регистрация: 10.04.2011
Сообщений: 40
1

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

12.10.2014, 13:01. Просмотров 2446. Ответов 3
Метки нет (Все метки)

Условие: Сколько различных бус можно составить из двух белых, двух синих и двух красных бусин? Напечатать все возможные варианты.
Решить нужно на языке Pascal. Что и как не знаю(
0
Лучшие ответы (1)
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
12.10.2014, 13:01
Ответы с готовыми решениями:

Сколько различных ожерелий можно составить из двух синих, двух белых и двух красных бусин
нашел такую задачу на форуме только решенную на паскале, там я ничего понять не смог, по сему прошу...

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

Сколькими различных способами можно надеть на нить семь бусин двух цветов -синего и белого
Сколькими различных способами можно надеть на нить семь бусин двух цветов -синего и белого

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

__________________
3
Эксперт Pascal/Delphi
6617 / 4450 / 4739
Регистрация: 05.06.2014
Сообщений: 21,864
12.10.2014, 19:08 2
Лучший ответ Сообщение было отмечено LoL_KO как решение

Решение

Не бус, а ожерелий.

(С) Vladimir_S
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
{Обозначение цветов бусин:
w (white) - белая
b (blue) - синяя
r - (red) - красная.}
 
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.
1
1642 / 1071 / 1081
Регистрация: 03.07.2013
Сообщений: 4,507
13.10.2014, 09:52 3
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
{ Алгоритм Нарайаны — нерекурсивный алгоритм, генерирующий по данной
 перестановке следующую за ней перестановку (в лексикографическом порядке).
 Придуман индийским математиком Пандитом Нарайаной в XIV веке. 
 
Каждая следующая перестановка строится следующим образом:
 
    На первом шаге программы, двигаясь с конца массива, сравниваем соседние
    элементы, если предыдущий (по расположению в массиве) элемент больше
    следующего, двигаемся дальше, если меньше, останавливаемся и запоминаем
    его номер (m), этот элемент будет изменен (на этом шаге он отмечается
    красным треугольником снизу, а потом просто красным цветом).
    
    Элементы, стоящие слева от m-го, не изменяем (они станут окрашенными
    в серый цвет). Среди элементов, стоящих справа, нужно выбрать элемент (k),
    который должен встать на место m-го. Это минимальный элемент среди тех,
    которые больше m-го (отмечается синим треугольником, потом просто
    синим цветом).
    
    Меняем m-ый и k-ый элементы.
    Осталось упорядочить по возрастанию элементы, стоящие справа от нового m-го
    элемента, но т.к. они упорядочены по убыванию, достаточно их обернуть
    (оборачиваемая часть обозначена стрелками). }
    
Type
  St6 = String[6];
Var
  RS : St6;
  m  : set of St6;
 
Function StRevers(St :String) : String;
Var
  ii  : Longint;
  St0 : String;
Begin
  St0:='';
 For ii:=length(St) downto 1 do
  St0:=St0+St[ii];
  StRevers:=St0;
end;
 
Function LexNext(S : String) : String;
Var
  len,m,k,t : Longint;
  Sch       : Char;
  cs        : String;
  flag      : Boolean;
Begin
  len:=Length(S); flag:=True;
  For m:=len-1 downto 1 do
    If S[m]<S[m+1] then Break;
  For k:=len downto m+1 do
    If S[k]>S[m] then
    Begin
      flag:=False;
      Break;
    end;
  If flag then LexNext:='' else
  Begin
    For t:=len downto m+1 do
      If (S[t]>S[m]) and (S[t]<=S[k]) then k:=t;
    cs:=S;
    Sch:=cs[m];
    cs[m]:=cs[k];
    cs[k]:=Sch;
    LexNext:=Copy(cs,1,m)+StRevers(Copy(cs,m+1,len-m));
  end;
end;
 
Begin
  m:=[];
  RS:='112233';
  While RS<>'' do
  Begin
    If not (RS in m) then
    Begin
      Include(m,RS);
      Writeln(RS);
    end;
    RS:=LexNext(RS);
  end;
end.
1
Эксперт Pascal/Delphi
2360 / 1279 / 1484
Регистрация: 29.08.2014
Сообщений: 4,602
13.10.2014, 16:32 4
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
var
  i,j,k,l,m,n:integer;
procedure check(i,j,k,l,m,n:integer);
var
  s,s1:string;
  a,b,c:integer;
begin
  s:=chr(48+ord(i))+chr(48+ord(j))+chr(48+ord(k))+chr(48+ord(l))+
     chr(48+ord(m))+chr(48+ord(n));
  s1:='';
  for a:=1 to 6 do if pos(s[a],s1)=0 then s1:=s1+s[a] else
      begin
        c:=0;
        for b:=1 to length(s1) do if s1[b]=s[a] then inc(c);
        if c=1 then s1:=s1+s[a];
      end;
  if length(s1)=6 then begin
     for b:=1 to 6 do
       if s1[b]='1' then write('B') else
       if s1[b]='2' then write('W') else write('R');
     writeln;
  end;
end;
begin
  for i:=1 to 3 do
    for j:=1 to 3 do
      for k:=1 to 3 do
        for l:=1 to 3 do
          for m:=1 to 3 do
            for n:=1 to 3 do
              check(i,j,k,l,m,n);
end.
Добавлено через 21 минуту
или чуть короче:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
var
  i,j,k,l,m,n:integer;
  h:array[1..3] of char;
procedure check(s:string);
var
  s1:string;
  a,b,c:integer;
begin
  s1:='';
  for a:=1 to 6 do if pos(s[a],s1)=0 then s1:=s1+s[a] else
      begin
        c:=0;
        for b:=1 to length(s1) do if s1[b]=s[a] then inc(c);
        if c=1 then s1:=s1+s[a];
      end;
  if length(s1)=6 then writeln(s1);
end;
begin
  h[1]:='B';h[2]:='R';h[3]:='W';
  for i:=1 to 3 do
    for j:=1 to 3 do
      for k:=1 to 3 do
        for l:=1 to 3 do
          for m:=1 to 3 do
            for n:=1 to 3 do
              check(h[i]+h[j]+h[k]+h[l]+h[m]+h[n]);
end.
1
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
13.10.2014, 16:32

Заказываю контрольные, курсовые, дипломные работы и диссертации здесь.

Задача на лемму Бернсайда: сколько различных ожерелий можно составить из девяти бусин трёх цветов?
Условие: Сколько различных ожерелий можно составить из девяти бусин трёх цветов? Нашёл похожую...

Определить, сколько n-значных чисел можно составить с помощью двух цифр 5 и 9
Сколько n-значных чисел можно составить с помощью двух цифр 5 и 9, в которых три одинаковых цифры...

Имеется 2 урны со следующим составом шаров: 1-ая урна - 6 синих и 3 красных; 2ая урна - 4 синих и 2 красных
Имеется 2 урны со следующим составом шаров: 1-ая урна - 6 синих и 3 красных; 2ая урна - 4 синих и 2...

Сосчитайте, сколько четырёхзначных чисел имеют одинаковые суммы двух первых и двух последних цифр
Сосчитайте, сколько четырёхзначных чисел имеют одинаковые суммы двух первых и двух последних цифр....


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
4
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.