Write (p^.Key,'('); q:=p^.Trail;

      While q<>Nil do

      begin Write (q^.Id^.Key); q:=q^.Next end;

      Write (')'); p:=p^.Next; Write (' ')

   end

END;

{ ----------------------------- }

PROCEDURE C_o_l_o_r (r: Lref);

{ Последовательная  раскраска графа  при помощи }

{ рекурсивного обхода  графа в глубину  }

{ r - указатель на структуру  Вирта }

{ MSet - глобальное множество  }

{ n - глобальная переменная }

var t,t1: Tref;

    Set1: Set of 0..255; { Вспомогательное  множество }

    i : Integer; { Параметр цикла }

    Fl : Boolean;

BEGIN

   t:=r^.Trail; r^.Flag:=FALSE;

   { Сейчас мы находимся в вершине r^.Key }

   { Исключим цвета  всех вершин, смежных  }

   { вершине r^.Key, из  множества MSet }

   t1:=t;

   While t1<>Nil do

   begin MSet:=MSet-[t1^.Id^.Color]; t1:=t1^.Next end;

   {Выбор цвета вершины: это "первый" элемент множества MSet }

   Fl:=TRUE; i:=1;

   While Fl do

   If i IN MSet then Fl:=FALSE else i:=i+1;

   r^.Color:=i; { Цвет присвоен! }

   Write ('(',r^.Key,',',r^.Color,') ');

   { Восстановление вспомогательного множества MSet }

   MSet:=[]; For i:=0 to n do MSet:=MSet+[i];

   While t<>Nil do

   Begin

      If t^.Id^.Flag then C_o_l_o_r (t^.Id);

      t:=t^.Next

   end

END;

{ --- }

BEGIN

   { Инициализация списка  заголовочных узлов  }

   New (Head); Tail:=Head;

   { Построение графа  и вывод его  структуры Вирта  }

   M_a_k_e_G_r_a_p_h (Head); P_r_i_n_t_G_r_a_p_h (Head);

   WriteLn;

   { Раскраска с помощью  рекурсивного обхода  графа в глубину  }

   { Инициализация }

   n:=0; { n - количество вершин  в графе }

   t:=Head; { Установлен рабочий  указатель }

   While t<>Tail do

   begin t^.Flag:=TRUE; t^.Color:=0; n:=n+1; t:=t^.Next

   end;

   { Построение вспомогательного  множества MSet }

   MSet:=[]; For i:=0 to n do MSet:=MSet+[i];

   Write ('Результат раскраски: '); C_o_l_o_r (Head);

   WriteLn

END.

uses crt;

var

   a,b:array[1..100] of integer;

   n:byte;

   sum:integer;

   f:boolean;

   i,j,k,h,s,m,z:integer;

begin

     {Vvodim vse podryat}

     clrscr;

     Writeln('Vvedite kolichestvo elimentov massiva<=100');

     Readln(n);

     for i:=1 to n do

     begin

     writeln(i,' :eliment');

     readln(a[i]);

     end;

     writeln('Vvedite sum');

     readln(sum);

     {Nachinaetsya glavniji cikl

     idem sverhu v niz}

For I := N Downto 1 Do

Begin

  B[1] := I;

  H := 1;

  K := Sum - A[I];

  F := False;

  Repeat

 

   For J := B[H]-1 Downto 1 Do

    Begin

     If A[J] <= K Then

      Begin

       Inc(H);

       B[H] := J;

       Dec(K, A[J]);

      End; { If A[J] <= K }

 

       If K = 0 Then

        Begin

         For M := 1 to H Do Write(A[B[M]], ' ');

         Inc(K, A[B[H]]);

         Dec(H);

         WriteLn;

        End;

 

    End;

 

   F := True;

   For M := H Downto 2 Do

     Begin

       If B[M] <> H-M+1 Then

       Begin   

        F := False;

        Dec(B[M]);

    H := M;

        K := Sum;

        For Z := 1 to H Do

         Dec(K, A[B[Z]]);

        Break;

       End;

     End;

  Until F;

 End;

     repeat until keypressed;

end.                     

uses crt;

var

   a,b:array[1..100] of integer;

   n:byte;

   sum:integer;

   f:boolean;

   i,j,k,h,s:integer;

begin

     {Vvodim vse podryat}

     clrscr;

     Writeln('Vvedite kolichestvo elimentov massiva<=100');

     Readln(n);

     for i:=1 to n do

     begin

     writeln(i,' :eliment');

     readln(a[i]);

     end;

     writeln('Vvedite sum');

     readln(sum);

     {Nachinaetsya glavniji cikl

     idem sverhu v niz}

     for i:=n downto 1 do

     begin

         s:=1;

         b[1]:=a[i];

         repeat

         h:=1;

         k:=sum-a[i]; {vichitaem naibol'shiji eliment podposledovatel'nosti

                      i nachinaem proveryat' so sledueshigo}

         if k=0 then begin write(a[i]);break;end {dobavil proverku pered

                                                  ciklom}

         else

         begin

         for j:=i-s downto 1 do

         begin

             if k<a[j] then continue else   {esli eliment bol'she k, to

                                                  idem k sleduushimu}

             begin

             k:=k-a[j];

             inc(h);b[h]:=a[j];            {sohronyaem na vsyakji sluchaji}

             if k=0 then break;            {esli k=0 vihodim iz cikla}

             end;

         end;

         if k=0 then          {proviryam esli k=0, to raspichativaem

                              posledovatel'nost', esli net

                              to posledovatel'nosti s dannim

                              naibol'shim chlenom izchrponi, perehodim k

                              sleduushimu}

         begin

             writeln;

             for j:=1 to h do write(b[j],' ');f:=true;inc(s);

         end else f:=false;

         end; {konec dobavki}

         until not f;

     end;

     repeat until keypressed;

end.