Рекурсия: Дается длина полоски из клеточек и 3 длины: полосок красного,синего и желтого цвета.Требуется набрать заданную длину

[MagAragorn]

Дается длина полоски из клеточек и 3 длины: полосок красного,синего и желтого цвета.Требуется заполнить первую полоску другими,но не ставить две одноцветных полоски друг за другом.Если ввод
3 1 1 1
Вывод 6.:
К С З
К З С
С К З
С З К
З С К
З К С

[Poma][a]

А вот представьте у Вас сломался компьютер. Деньги платить Вы не хотите.. Поэтому идете в компьютерную мастерскую за "советом". И с порога : "Комп сломался. Платить не буду. Чё делать?". Встречный вопрос : "А с какого перепугу мы должны Вам помогать?". Не.. ну я понимаю если бы было примерно так : "Утро доброе господа программисты. У меня возникла проблема вот какого плана : ... . Думаю решать так : .. . Подскажите в правильную сторону ли я движусь?Заранее спасибо!" Но нет.. ни о каком приветствии и тем более просьбы о помощи разговора нет..


Предлагаю решать так :
Читаем N, FrstCnt, ScndCnt, ThrCnt.
Генерим массив A.

count := 1;
for i := 1 to n FrstCnt do begin
       a[count] := 1;
       Inc (count)
end;

for i := 1 to ScndCnt do begin
       a[count] := 2;
       Inc (count)
end;

for i := 1 to Thr do begin
       a[count] := 3;
       Inc (count)
end;

Для красоты реализуем это с помощью процедурки..

А далее запускаем рекурсивное получение перестановок массива А

[1mutant1]

Вот вроде рабочий вариант, частично переделан из http://programmersforum.ru/showpost....6&postcount=27

отрезки не должны быть нулевой длины(надо править)
ну и m(кол-во отрезков)<=3, больше "работать" не должно. (тоже надо править)
Написал очень отвратительный код но оно вроде работает и вам же ехать, а не шашечки

uses crt;
type
        TSol = array [1..100] of Integer;

var
        n, m : Integer;
        a : array [1..100] of Integer;

procedure Solution (cnt, sum : Integer; b : TSol);
var
        i,y,fl,j : Integer;
        label a1;
begin
        if sum = n then  begin
                for i := 1 to m do if b[i]<>0 then
                       if a[b[i]] <> 0 then begin
                    if b[i]=1 then Write('R ');
                    if b[i]=2 then write('B ');
                    if b[i]=3 then write('Y ');
                         Write (a[b[i]], '+');
                end;
                WriteLn(#8, ' = ', n);
                goto a1;
        end;
        if cnt > m then
                Exit;

                i:=0;
        while (sum<>n) and (sum<n) and (i<m) do begin
        inc(i);
        y:=0;
        fl:=0;
            for j:=1 to m  do if (b[j]=i) then fl:=1;
            if fl=1 then continue;

            for j:=1 to m do
                if b[j]=0 then begin
                          b[j]:=i;
                            y:=1;
                            break;
                end;
            solution(cnt+1,sum+a[i],b);
            b[j]:=0;
        end;
a1:
end;
var
        b : TSol;
        ii : Integer;

begin
clrscr;
        ReadLn (n);
        m:=3;

        for ii := 1 to m do
                Read (a[ii]);

        for ii := 1 to m do begin
                b[1] := ii;
                Solution (1,a[ii], b);

        end;
end.

Спасибо говорть РОМАХЕ

[MagAragorn]

Спасибо вам огромное!!
Помогите еще одну подзадачу написать, пожалуйста)
Я пока пытаюсь разобраться в Вашем коде.
Еще одно условие:
Цвета могут повторяться сколько угодно,но за полоской одного цвета не может идти такая же полоска.
Например:
3
1 1 1
К С К
К З К
З С З
З К З
С З С
С К С
К С З
К З С
С К З
С З К
З С К
З К С
Вывод: 12.
Вот чуть чуть облегченная версия Вашего кода

type
        TSol = array [1..100] of Integer;

var
        n, m,l,ii : Integer;
        a,b : TSol;

procedure Solution (cnt, sum : Integer; b : TSol);
var
        i,y,fl,j : Integer;
begin
        if sum = n then  begin

                inc(l);
                Exit;
        end;
        if cnt > 3 then
                Exit;

                i:=0;
        while (sum<n) and (i<3) do begin
        inc(i);
        fl:=0;
            for j:=1 to 3  do if (b[j]=i) then fl:=1;
            if fl=1 then continue;

            for j:=1 to 3 do
                if b[j]=0 then begin
                          b[j]:=i;
                          break;
                end;
            solution(cnt+1,sum+a[i],b);
            b[j]:=0;
        end;
end;


begin
        ReadLn (n);

        for ii := 1 to 3 do
                Read (a[ii]);

        for ii := 1 to 3 do begin
                b[1] := ii;
                Solution (1,a[ii], b);

        end;
        Writeln(l);
        Readln;
        Readln;
end.

[MagAragorn]

Но ни в коем случае нельзя такого типа варианты
К К С
С С С и т.д.

[1mutant1]

Как вам уже говорили попробуйте "решить" сами, мой кусок кода доработать не проблема(у меня он уже есть доработанный)
Просто зачем ходить тогда на спец курс по программированию?
А от себя хочу добавить что нужно правильно формулировать задачу, если не нужен вывод элементов то у Poma][a в прошлой теме было отличное "красивое" решение где считается именно кол-во

Подумайте сами, когда что-то делаешь своими руками(головой) - это здорово и приносит удовольствие, если будут проблемы с кодом пишите.

[MagAragorn]

я разобрался,что в вашем коде за все отвечает вот эта строка:
for j:=1 to 3 do if (b[j]=i) then fl:=1;

if fl=1 then continue;
Пытаюсь с ней поразбираться)
Кстати,у вас работает тест 5 1 1 1, ответ 48.?

[Poma][a]

Спасибо говорть РОМАХЕ

Ни в коем разе!!

Подумайте сами, когда что-то делаешь своими руками(головой) - это здорово и приносит удовольствие

Золотые слова

Господин Мутант, а Вам не кажется что goto - ТАБУ. А показывать их школьникам - преступление )) (c) TinMan ?

[1mutant1]

Сообщение от MagAragorn

Кстати,у вас работает тест 5 1 1 1, ответ 48.?

да, работает
4 ----- 4
1 1 1-- 1 1 2
24----- 10
------------
6 ----- 6
1 1 1-- 1 1 2
96----- 28
------------
7------- 7
1 1 1 -- 1 1 2
192---- 48

[1mutant1]

Сообщение от Poma][a

Ни в коем разе!!
Господин Мутант, а Вам не кажется что goto - ТАБУ. А показывать их школьникам - преступление )) (c) TinMan ?

совершенно согласен, в целом там где я его использовал оно вообще не нужно и без него будет работать.
Каюсь, грешен, 300 лет ничего не писал