Probleme de informatica

Problema 1

Se dau n orase. Se cunoaste distanta dintre oricare doua orase. Un distribuitor de carte cauta sa-si faca un depozit in unul dintre aceste orase. Se cere sa se gaseasca traseul optim de la depozit catre celelalte orase astfel incat distanta totala pe care o va parcurge pentru a distribui in toate celelalte n-1 orase sa fie minima. Sa se precizeze care ar fi orasul in care sa se afle depozitul pentru ca toate celelalte orase sa fie usor accesibile .

Rezolvare:

program oras_depozit;

uses crt;

type muchie=record

vf1, vf2, cost:integer;

end;

type vector=array[1..100] of longint;

vector1=array[1..100] of muchie;

matrice=array[1..50,1..50] of longint;

var n, i, j, k, v, cost:integer;

s, t:vector:

x:vector1;

a:matrice;

f:text;

procedure citire;

var i, j, m:integer;

begin

assign (f, 'depozit.txt');

reset (f);

readln (f, n); m:=0;

while not eof(f) do

begin

inc(m);

read (f,x[m].vf1);

read (f,x[m].vf2);

read (f,x[m].cost);

end;

for i:=1 to m do

begin

a[x[i].vf1, x[i].vf2:=x[i].cost];

a[x[i].vf2, x[i].vf1:=x[i].cost];

end;

writeln ('matricea costurilor este:');

for i:=1 to n do

begin

for j:=1 to n do

write (a[i,j], ' ');

writeln;

end;

end;

procedure prim;

var i, j, min:integer;

begin

for i:= to n do

s[i]:=v;

s[v]:=0

for i:=1 to n do

t[i]:=0;

cost:=0;

for k:=1 to n-1 do

begin

min:=maxint;

for i:=1 to n do

if (s[i]<>0) then

if (a[s[i], i]<min) and (a[s[i], i]<>0) then

begin

min:=a[s[i], i];

j:=1;

end;

t[j]:=s[j];

cost:=cost+a[j, s[j]];

s[j]:=0

for i:=1 to n do

if (s[i]<>0) then

if (a[i,s[i]]=0) or (a[i,s[i]]>a[i,j]) then

if a [i,j]<>0 theen

s[i]:=j;

end;

end;

function fii(x:integer):integer;

var k:integer;

begin

k:=0;

for i:=1 to n do

if t[i]=x then

inc(k);

fii:=k;

end;

procedure tata(v:integer);

var i:integer;

begin

for I:=1 to n do

if t[v]=i then

begin

t[i]:=v;

t[v]:=0;

end;

end;

procedure oras;

var max,i,j:integer;

begin

max:=0;

for i:=1 to n do

if fii(i)>max then

max:=fii(i);

writeln('orasele optime sunt:')

for i:=1 to n do

if fii(i)=max then

begin

write(i,' ');

tata(i);

write ('vectorul tata este:');

for j:=1 to n do write(t[j], ' ');

writeln;

end;

end;

begin

clrscr;

citire;

writeln('dati vf de pornire') ; readln(v) ;

prim ;

writeln('costul arborelui este :', cost) ;

oras;

readkey ;

end.

Problema 2

Se da un graf neorientat. Sa se creeze un arbore partial de cost minim care sa poata fi memorat apoi sub forma unei liste.

Rezolvare:

Program arbore_lista;

uses crt;

type muchie=record

vf1, vf2, cost:integer;

end;

type vector=array[1..50] of longint;

vector1=array[1..100]of muchie;

matrice=array[1..20,1..50]of longint

var n,i,j,k,v,cost,y,z,m:integer;

s,t,s1,t1:vector;

x:vector1;

a,a1:matrice;

f:text;

procedure citire;

var i,j,m:integer;

begin

assign (f, 'depozit.txt');

reset (f);

readln (f,n); m:=0;

while not eof (f) do

begin

inc(m);

read (f,x[m].vf1);

read (f,x[m].vf2);

read (f,x[m].cost);

readln (f);

end;

for i:=1 to m do

begin

a[x[i].vf1, x[i].vf2:=x[i].cost];

a[x[i].vf2, x[i].vf1:=x[i].cost];

end;

writeln ( 'matricea costurilor este:');

for i:=1 to n do

begin

for j:=1 to n do

write (a[i,j], ' ');

writeln

end;

end;

function fii (y:integer):integer;

var k,j:integer;

begin

k:=0;

for j:=1 to n do

if t[j]=y then

inc(k);

fii:=k;

end;

procedure prim (a:matrice);

var i,j,min:integer;

begin

min:=maxint;

for i:=1 to n do

if (s[i]<>0) then

if (a[s[i], i]<min) and (a[s[i],i]<>0

then

begin

min:=a[s[i], i];

j:=i;

end;

if (((s[j]<>v) and (fii(s[j])=0)) or (s[j]=v) and (fii(s[j])<=1))) then

begin

t[j]:=s[j];

cost:=cost+a[j,s[j]];

s[j]:=0;

for i:=1 to n do

if (s[i]<>0) then

if (a[i,s[i]]=0) or (a[i,s[i]]>a[i,j]) then

if a[i,j]<>0 then

s[i]:=j;

inc(m);

end;

else

begin

a1:=a;

a1[s[j],j]:=0;

prim (a1);

end;

end;

begin

clrscr;

citire;

writeln('dati vf de pornire'); readln(v);

m:=0;

for i:=1 to n do

s[i]:=v;

s[v]:=0;

for i:=1 to n do

t[i]:=0;

cost:=0;

repeat prim(a);

until m=n-1;

write ('vectorul tata este:');

for i:=1 to n do

write (t[i], ' ');

writeln;

writeln ('costul arborelui este:' , cost);

readkey;

end.

Problema 3

Se da un graf orientat si se cere sa se afle daca exista un arbore partial de cost minim. Dar o arborescenta de cost minim? Daca exista sa se afle care este este varful acesteia.

Rezolvare

program arborescenta;   

uses crt;

type muchie=record

vf1,vf2,cost:integer;

end;

type vector=array[1..100] of longint;

vector1=array[1..100] of muchie;

matrice=array[1..50,1..50] of longint;

var n,i,j,k,v,cost:integer;

s,t:vector;

x:vector1;

a:matrice;

f:text;

procedure citire;

var i,j,m:integer;

begin

assign(f,'orient.txt');

reset(f);

readln(f,n);m:=0;

while not eof(f) do

begin

inc(m);

read(f,x[m].vf1);

read(f,x[m].vf2);

read(f,x[m].cost);

readln(f);

end;

for i:=1 to m do

a[x[i].vf1,x[i].vf2]:=x[i].cost;

writeln('Matricea costurilor este:');

for i:=1 to n do

begin

for j:=1 to n do

write(a[i,j],' ');

writeln;

end;

end;

procedure prim;

var i,j,min:integer;

begin

for i:=1 to n do

s[i]:=v;

s[v]:=0;

for i:=1 to n do

t[i]:=0;

cost:=0;

for k:=1 to n-1 do

begin

min:=maxint;

for i:=1 to n do

if (s[i]<>0) then

if (a[s[i],i]<min) and (a[s[i],i]<>0) then

begin

min:=a[s[i],i];

j:=i;

end;

t[j]:=s[j];

cost:=cost+a[s[j],j];

s[j]:=0;

for i:=1 to n do

if (s[i]<>0) then

if (a[s[i],i]=0) or (a[s[i],i]>a[j,i]) then

if a[j,i]<>0 then

s[i]:=j;

end;

end;

begin

clrscr;

citire;

writeln('Dati vf de pornire!');readln(v);

prim;

writeln('Vectorul tata este:');

for i:=1 to n do

write(t[i],' ');

writeln('Costul arborelui este:',cost);

readkey;

end.

Problema 4

Se da un graf conex. Se cere impartirea acestuia in m arbori partiali de cost minim fiecare cu p varfuri. Sa se afiseze acesti arbori.

Rezolvare

program arbori;

uses crt;

type vector=array[1..100] of longint;

program m_arbori;

uses crt;

type vector=array[1..100] of longint;

matrice=array[1..50,1..50] of longint;

var n,i,j,k,v,cost,p,m:integer;

s,t:vector;

a:matrice;

f:text;

procedure citire;

var i,j:integer;

begin

assign(f,'prim.txt');

reset(f);

readln(f,n);

for i:=1 to n do

begin

for j:=1 to n do

read(f,a[i,j]);

readln(f);

end;

writeln('Matricea costurilor este:');

for i:=1 to n do

begin

for j:=1 to n do

write(a[i,j],' ');

writeln;

end;

end;

procedure prim;

var i,j,min,h:integer;

begin

cost:=0;

for h:=1 to p-1 do

begin

min:=maxint;

for i:=1 to n do

if (s[i]>0) then

if (a[s[i],i]<min) and (a[s[i],i]<>0) then

begin

min:=a[s[i],i];

j:=i;

end;

t[j]:=s[j];

cost:=cost+a[j,s[j]];

s[j]:=0;

write(j,' ');

for i:=1 to n do

if (s[i]>0) then

if (a[i,s[i]]=0) or (a[i,s[i]]>a[i,j]) then

if a[i,j]<>0 then

s[i]:=j;

t[j]:=-1;

s[j]:=-1;

for i:=1 to n do

begin

a[i,j]:=0;

a[j,i]:=0;

end;

end;

write('Costul arborelui este:',cost);

end;

begin

clrscr;

citire;

writeln('Dati vf de pornire!');readln(v);

write('m=');read(m);

write('p=');read(p);

for i:=1 to n do

s[i]:=v;

s[v]:=0;

for i:=1 to n do

t[i]:=0;

for k:=1 to m-1 do

begin

for i:=1 to n do

begin

if t[i]=0 then

begin

write(i,' ');

prim;

for j:=1 to n do

if t[j]=0 then s[j]:=i;

s[i]:=-1;writeln;

end;

s[v]:=-1;

t[v]:=-1;

end;

end;

readkey;

end.

Problema 5

Se defineste o muchie a unui graf neorientat ca fiind o inregistrare cu trei campuri, doua varfuri extremitati si un cost afisare. Sa se afiseze muchia de cost minim.

Rezolvare

Program cost;

type muchie=record;

vf1, vf2, cost:integer;

end;

var v:array[1..100] of muchie;

m,n:integer;

procedure citire;

var i:byte;

begin

read(m); read(n);

for i:=1to m do with v(i) do

repeat

read(vf1, vf2, cost);

until (vf1>=1)and(vf1<=n)and(vf2>=1)and(vf2<=n)and(vf1<>vf2)and

(cost>0);

min:=v[i].cost;

for i:=2to m do if v[i].cost=min then

min:=v[i].cost;

for i:=1 to m do if v[i].cost=min then

writeln(i);

end.

Problema 6

Se defineste o muchie a unui graf neorientat ca o inregistrare de trei corpuri, cele doua varfuri extremitati si un cost apreciat muchiei. Definim un graf neorientat ca vector al muchiilor. Se da n>=numarul de noduri. Sa se construiasca si sa se afle matricea de adiacenta si apoi sa se determine costul mediu.

Rezolvare:

Program matrice;

type muchie=record;

vf1, vf2, cost:integer;

end;

type mat:=array[1..100,1..100] of byte

var v:array[1..100] of muchie

i,j,m,n:integer; s:integer;

procedure citire;

var v:byte; med:real; s;integer;

begin

for i:=1 to n do

for j:=1 to n do a[i,j]:=0

begin

read (m,n)

for i:=1 to m with v[i] do begin

repeat

read (vf1, vf2, cost);

until(vf1>=1)and(vf1<=n)and(vf2>=1)and(vf2<=n)and(vf1<>vf2)and (cost>0);

a[vf1,vf2]:1

end;

for i:=1 to n do

for j:=1 to n do

write (a[i,j]);

end.

Problema 7

Se considera un graf neorientat cu n varfuri numerotate 1..n. Cele n varfuri reprezentand orase. Un automobil pleaca dintr-un oras start, trece prin toate orasele o singura data si revine in orasul din care a plecat. Sttind ca intre unele orase exista drumuri directe si intre altele nu sa se afiseze toate traseele pe care le poate urma automobilul.

Rezolvare :

Program orase ;

type mat=array[1..100,1..100] of 0..1;

vec=array[1..100] of byte;

var a:mat; st:vec; start, n :integer;

procedure citire;

var i:integer;

begin

read(n);

for i:=1to n do a[i,j]:=0;

for i:=1 to n-1 do

for j:=i+1to n do

begin

read a[i;j];

a[j,i]:=a[i,j]

end;

for i:=1 to n do st[i]:=0;

repeat

read (start)

until (start>=1)and(start<=n);

st[i]:=start

end;

procedure tipar(p:byte);

var i:byte;

begin

for i:=1 to p do write (st[p], ' ');

end;

function valid(p:byte):boolean;

var i:byte; t:boolean;

begin

t:=true

for i:=1 to p-1 do

if st[i]:=st[p] then t:=false

if a[st[p], st[p-1]]=o then t:=false

valid:=t;

end;

procedure bktr(p:byte);

var k:byte;

begin

for k:=1 to n do

begin

st[p]:=k;

if valid (p) then

if (p=n)and (a[st[1],st[p]]=1) then

tipar(p);

else bktr(p+1)

end;

end;

begin

bktr(2);

read(n);

end.

Problema 8

Sa se afiseze punctele izolate dintr-un graf neorientat.

Rezolvare:

Program puncte izolate

type mat=array[1..20,1..20]of integer;

var n:integer, a:mat;

procedure citire;

var i,j:integer;

begin

readln(n);

for i:=1 to n do a[i,j]:=0

for i:=1 to n-1 do

for j:=i+1 to n do

begin

repeat

read a[i;j]:=0

until a[i;j]:=1 or a[i,j]:=0 or a[j,i]:=1;

end;

end;

procedure izolare;

var s,i,j:integer;

begin

for i:=1 to n do

begin

s:=0;

for j:=1 to n do

s:=s+a[i,j];

if s=a then writeln (i, 'este nod izolat');

end;

citire izolate;

end.

Problema 9

Din fisierul text se afla numere intregi aflate pe un singur rand, separate prin spatii. Sa se verifice daca secventa de numere formeaza lant elementar sau neeelementar intr-un graf neorientat. Graful este dat prin matricea de adiacenta si se citeste de la tastatura.

Rezolvare:

Program lant

var a:array[1..50,1..50] of 0..1;

v:array[1..50] of byte;

n:byte; f:text;

procedure init;

var i,j:byte;

begin

readln(n);

for i:=1 to n do a[i,j]:=0;

for i:=1 to n-1 do

for j:=i+1 to n do

begin

read (a[i,j]);

a[j,i]:=a[i,j];

end;

end;

procedure vector;

var k,j:byte;

begin

assign(f, 'matrice.in');

reset(f)

k:=0;

while (not(eoln(f)))do

begin

inc(k);

read (f,v[k]);

end;

close(f);

for j:=1 to k do

write(v[j], ' ');

t:=true;

for j:=1 to k-1 do

if a[v[j],v[j+1]]:=0 then t:=false;

if t:=false then

begin

for i:=1 to k-1do

for j:=i+1 to k do

if v[i]=v[j] then t:=false;

end;

if t:true then writeln ('lantul e elementar');

else writen ('lantul e neelementar');

end;

begin

init;

vector;

end.

Problema 10

Sa se genereze toate grafurile neorientate de n varfuri.

Rezolvare :

Program graf ;

type mat=array[1..100,1..100] of 0..1;

vec=array[1..100] of 0..1;

var a:mat; st:vec; n:byte;

function final(p:byte):boolean;

begin

if p=n(n-1)/2 then final:=true;

else final:=false;

end;

procedure init;

var i:byte;

begin

for i:=1 to n do a[i;j]:=0

end;

procedure tipar(p:byte);

var i,j:byte;

begin

for i:=1 to n-1 do

for j:=i-1to n do

begin

a[i,j]:=st[n(i-1)-i(i+1)/2+j];

a[j,i]:=a[i,j];

end;

for i:= to n do

begin

for j:=1 to n do write (a[i,j], ' ');

writeln;

end;

end;

procedure bktr(p:byte);

var k:byte;

begin

for k:=0 to 1 do

begin

st[p]:=k;

if final (p) then tipar(p)

else bktr(p+1)

end;

end;

begin

init

bktr(1); readln;

end.

Problema11

Se dau 7 culori, codificate prin nr. 1, 2, ., 7. Afisati toate posibilitatile de alcatuire a unor drapele tricolore care sa contina numai culori dintre cele date, astfel incat: culoarea din mijloc sa apartina unui set dat de patru culori din randul celor 7 disponibile; a treia culoare nu poate sa fie c unde c este un nr. intreg cuprins intre 1 si 3; cele trei culori de pe drapel sa fie distincte.

Rezolvare:

program drapele;

const n=7;

type stiva=array [1..10] of integer;

var st:stiva;

ev,as:boolean;

n,k:integer;

procedure init(k:integer;var st:stiva);

begin st[k]:=0;

end;

procedure succesor(var as:boolean;var st:stiva;k:integer);

begin

if st[k]<7 then

begin st[k]:=st[k]+1;

as:=true;

end

else as:=false;

end;

procedure valid(var ev:boolean;var st:stiva;k:integer);

var i:integer;

begin

ev:=true;

for i:=1 to k-1 do if st[i]=st[k] then ev:=false;

if (st[3]=1) or (st[3]=3) or (st[3]=2) then ev:=false;

if st[3]=(1,2,3) then ev:=false;

for i:=1 to 4 do if st[2]<>st[i] then ev:=false;

end;

function solutie(k:integer):boolean;

begin

solutie:=(k=n);

end;

procedure tipar;

var i:integer;

begin

for i:=1 to n do write (st[i]);

writeln;

end;

begin;

k ;init(k,st);

while k>0 do

begin

repeat

succesor (as,st,k);

if as then valid(ev,st,k);

until (not as) or (as and ev);

if as then

if solutie(k) then tipar

else

begin

k:=k+1;

init(k,st)

end

else k:=k-1;

end;

readln;

end.

Problema12

Se dau n cuburi numerotate 1,2,,n, de laturi Li si culori Ci, i=1,2,,n (fiecare culoare este codificata printr-un caracter). Sa se afiseze toate turnurile care se pot forma luand k cuburi din cele n disponibile, astfel incat:

-laturile cuburilor din turn sa fie in ordine crescatoare;

-culorile a oricare doua cuburi alaturate din turn sa fie diferite.

Rezolvare:

program cuburi;

type stiva=array [1..100] of integer;

var st:stiva;

i,n,p,k:integer;

as,ev:boolean;

L:array [1..10] of integer;

C:array [1..10] of char;

procedure init(k:integer;var st:stiva);

begin

st[k]:=0;

end;

procedure succesor(var as:boolean;var st:stiva;k:integer);

begin

if st[k]<n then

begin

st[k]:=st[k]+1;

as:=true;

end

else as:=false;

end;

procedure valid(var ev:boolean;st:stiva;k:integer);

var i:integer;

begin

ev:=true;

for i:=1 to k-1 do if L[st[k]]<=L[st[i]] then ev:=false;

if C[st[k]]=C[st[k-1]] then ev:=false;

end;

function solutie(k:integer):boolean;

begin

solutie:=(k=p);

end;

procedure tipar;

var i:integer;

begin

for i:=1 to p do write(st[i],' ');

writeln;

end;

begin

write('n= ');read(n);

write('p= ');read(p);

for i:=1 to n do

begin

write('L[',i,']=');readln(L[i]);

write('C[',i,']=');readln(C[i]);

end;

k:=1;init(k,st);

while k>0 do

begin

repeat

succesor(as,st,k);

if as then valid(ev,st,k);

until (not as) or (as and ev);

if as then if solutie(k) then tipar

else

begin

k:=k+1;

init(k,st);

end

else k:=k-1;

end;

end.

Problema13

Scrieti un program care, folosind metoda backtracking, afiseaza toate modurile de a aranja elementele unui sir dat de numere intregi astfel incat in sirul rezultat sa nu existe doua elemente negative alaturate.

Rezolvare:

program sir;

type stiva=array[1..100] of integer;

vector=array[1..100] of integer;

var st:stiva;

n,k,i:integer;

as,ev:boolean;

a:vector;

procedure init(k:integer;var st:stiva);

begin

st[k]:=0

end;

procedure succesor(var as:boolean;var st:stiva;k:integer);

begin

if st[k]<n then

begin

st[k]:=st[k]+1;

as:=true;

end

else as:=false;

end;

procedure valid(var ev:boolean;st:stiva;k:integer);

var i:integer;

begin

ev:=true;

for i:=1 to k-1 do if st[k]=st[i] then ev:=false;

if (a[st[k]]<0) and (a[st[k-1]]<0) then ev:=false;

end;

function solutie(k:integer):boolean;

begin

solutie:=(k=n);

end;

procedure tipar;

var i:integer;

begin

for i:=1 to n do write(a[st[i]],' ');

writeln;

end;

begin

write('n=');readln(n);

for i:=1 to n do

begin

write('a[',i,']=');readln(a[i]);

end;

k:=1;init(k,st);

while k>0 do

begin

repeat

succesor(as,st,k);

if as then valid(ev,st,k);

until (not as) or (as and ev);

if as then if solutie(k) then tipar

else

begin

k:=k+1;

init(k,st);

end

else k:=k-1;

end;

end.

Problema14

Un comis-voiajor trebuie sa viziteze un numar n de orase. Initial, acesta se afla intr-unul dintre ele, notat 1. Comis-voiajorul doreste sa nu treaca de doua ori prin acelasi oras, iar la intoarcere sa revina in orasul 1. Cunoscand legaturile existente intre orase, se cere sa se tipareasca toate drumurile posibile pe care le poate efectua comis-voiajorul.

Rezolvare:

program comisv;

type stiva=array[1..100] of integer;

var st:stiva;

i,j,n,k:integer;

as,ev:boolean;

a:array[1..20,1..20] of integer;

procedure init(k:integer;var st:stiva);

begin

st[k]:=1;

end;

procedure succesor(var as:boolean;var st:stiva;k:integer);

begin

if st[k]<n then

begin

st[k]:=st[k]+1;

as:=true

end

else as:=false

end;

procedure valid(var ev:boolean;st:stiva;k:integer);

var i:integer;

begin

ev:=true;

if a[st[k-1],st[k]]=0 then ev:=false

else

for i:=1 to k-1 do if st[i]=st[k] then ev:=false;

if (k=n) and (a[1,st[k]]=0) then ev:=false

end;

function solutie(k:integer):boolean;

begin

solutie:=(k=n)

end

procedure tipar;

var i:integer;

begin

for i:=1 to n do

write('nodul=',st[i]);

end;

begin

write('nr. de noduri=');readln(n);

for i:= 1 to n do

for j:=1 to i-1 do

begin

write('a[',i,',',j,']='); readln(a[i,j]);

a[j,i]:=a[j,i];

end;

st[1]:=1; k:=2;

init(k,st);

while k>0 do

begin

repeat

succesor(as,st,k);

if as then valid(ev,st,k);

until (not as) or (as and ev);

if as then if solutie(k) then tipar

else

begin

k:=k+1;

init(k,st);

end

else k:=k-1;

end;

end.

Problema15

Sa se afiseze nodurile izolate dintr-un graf neorientat

Rezolvare:

Program noduri izolate;

type matrice=array[1..50,1..50]of byte

var a :matrice;

n, i, j:integer;

v1, v2=array[1..50] of byte;

procedure citire

var x,y:integer;

begin

readln(m,n)

for i:=1to n do

begin

v1[i]:=0, v2[i]:=0

end;

for j:=1 to n do

begin

repeat read (x,y) until (x>=1)and(x<=n)and(y>=1)and(y<=n)and(x<>y)

v1[x]=v1[x]+1;

v2[y]=v2[y]+1;

end;

for i:=1 to n do

if (v1[i]=v2[i])and(v1[i]=0)

then writeln(j);

end.

Problema16

Se citeste de la tastatura matricea de adiacenta asociata unui graf neorientat cu n noduri. Sa se scrie arcele grafurilor in fisierul arce.txt

Rezolvare:

Program arce;

var a:array[1..50,1..50]of 0..1

f:text, n:byte;

procedure citire;

var i,j:byte

begin

read(n)

for i:=1to n do a[i,j]:=0

for i:=1to n do j:=1 to n do read (a[i,j])

end

procedure rezolvare

var i,j:byte

begin

assign(f,'arce.txt'); rewrite(f);

for i:=1 to n do

for j:=1to n do

if a[i,j]:=1

then writln(f,i,' ',j);

close(f)

end;

begin

citire; rezolvare;

end.

Problema 17

Sa se tipareasca toate lanturile neelementare care trec prin varfurile v1 si v2.

Rezolvare:

Program lanturi;

var a:array[1..50,1..50]of 0..1;

st:array[1..50]of byte;

v1,v2,n:byte;

procedure init;

var i,j:byte;

begin

readln(n);

for i:=1 to n-1do

for j:=i+1to n do

begin

rea (a[i,j]); a[j,i]:=a[i,j]);

end;

repeat readln(v1, v2);

until (v1<>v2)and(v1<=n)and(v1>=1)and(v2>=1)and(v2<=n);

end;

procedure tipar(p:byte);

var i:byte;

begin

for i:=1 to p do write(s+i)

end;

function valid(p:byte):boolean;

var i:byte; t:boolean;

begin

t=true;

for i:=1 to p-1 do

if st[p]=st[i] then t:=false;

if a[st[p],st[p-1]]=0 then t:false;

valid:=t;

end;

function final(p:byte):boolean;

var t:boolean; i:byte;

begin

t:=false

for i:=1 to p do if v1=st[i] then

for j:=1 to p do if v2=st[i] then

if p=k then t:true;

final:=t

end;

procedure bktr(p:byte);

var l:byte;

begin

for l:=1 to n do

begin

st[p]:=l;

end;

valid (p) then

if final (p) then tipar(p);

else bktr(p+1);

end;

begin init;

for k:=3 to n do bktr(1);

end.