{ программа генерации перестановок N элементного 
  множества в лексикографическом порядке }

Program perms;
var i,j,h,n,k:integer;
    a:array[0..100] of integer;    { массив для хранения перестановки }

{процедура вывода полученной перестановки}
procedure output;
var i:integer;
begin
  writeln;
  for i:=1 to n do write(a[i],' ');
end;

begin
  readln(n);                      { ввод кол-ва элементов перестановки }
  fillchar(a,sizeof(a),0);        { инициализация массива }

 { ввод элементов начальной перестановки }
  for i:=1 to n do a[i]:=i;

  repeat
    output;                         { ввод текущей перестановки }
    i:=n;
    while a[i-1]>a[i] do dec(i);	 { поиск скачка }
    j:=i-1;
    h:=a[j];
    while a[i+1]>h do inc(i); 	{ поиск первого меньшего элемента }
    a[j]:=a[i];  a[i]:=h;
    i:=j+1; k:=n;
    while i<k do begin             { перестановка ”хвоста” }
       h:=a[i]; a[i]:=a[k]; a[k]:=h;
       inc(i); dec(k)               
    end
  until j=0;                        {}
end.

function SepWord(s:string):integer;
const
 r:set of char = [chr(0)..chr(255)]-['A'..'Z','a'..'z','1'..'9','0'];
var
 i:integer; SL:boolean;  ss:string;
 pl:integer;
begin
 sl:=false;  ss:='' ;  i:=1;   pl:=0;
 while i<=length(s) do begin
   if ((not(s[i] in r)) and (sl=false))  then sl:=true;
   if (not(s[i] in r)) and (sl=true) then ss:=ss+s[i];
   if ((s[i] in r)or(i=length(s)))  and (sl=true) then
   begin
     if ss[1]=ss[length(ss)] then inc(pl);
     ss:=''; sl:=false;
   end;
   inc(i)
 end;
 SepWord:=pl;
end;

var
 pl:integer;
 s:String;
begin
 writeln('Enter string....');
 readln(s);
 writeln('word count=',sepword(s));
 readln;
end.

{poschitac edenicy}

program Edenicy;
var n,i,c,chislo,j:integer;

begin

readln(chislo);

n:=0;

for i:=1 to chislo do

begin
     j:=i; c:=0;
     while j<>0 do begin
      if j mod 10 = 1 then inc©;
      j:=j div 10;
     end;
     if c>=2 then inc(n);

end;

writeln(n);
readln;
end.

var
  X, i, n: Integer;
begin
  Readln(X);

  n := 0;
  for i := 0 to 15 Do
    if (($0001 shl i) and X) <> 0 then inc(n);

  writeln(n);
end.

var
  X, p, n: Integer;
begin
  Readln(X);

  n := 0; p := 1;
  while X > 3 do begin
    inc(n); dec(X, 2);
  end;

  if X = 3 then begin
    write(' 3'); p := 3;
  end
  else inc(n);

  while n > 3 do begin
    write(' 3 3'); dec(n, 3);
    p := p * 9;
  end;

  while n > 0 do begin
    write(' 2'); dec(n);
    p := p * 2;
  end;

  writeln;
  writeln('Произведение = ', p);
end.