WAAAAAAAAAAAAA HHHHEEEELLLLPPPP Послано Oleg 11 дек 2002 18:10 var i,j,k,n,l,m,m1:longint; a,b,c,r:array [0..10000] of integer; stack :array [0..1,0..10000] of integer; function search(k:integer):integer; var i,j,l:integer; begin l:=0; if k>1 then if c[a[k]]=0 then begin c[a[k]]:=c[k]+1; l:=1; end; for i:=1 to n do begin if a[i]=k then if c[i]=0 then begin c[i]:=c[k]+1; l:=1; end; end; search:=l; end; begin read(n); for i:=2 to n do read(a[i]); for i:=1 to n do b[a[i]]:=1; for k:=1 to n do begin if b[k]=0 then continue; fillchar(stack,sizeof(stack),0); fillchar(c,sizeof(c),0); c[k]:=1; l:=0; while l=0 do begin for i:=1 to n do if c[i]>0 then l:=search(i); l:=1-l; end; l:=0; for i:=1 to n do if c[i]>l then l:=c[i]; if l>m then begin fillchar(r,sizeof(r),0); m1:=0; m:=l; end; inc(m1); r[m1]:=k; end; for i:=1 to m1-1 do write(r[i],' '); writeln(r[m1]); end. TL Послано Oleg 12 дек 2002 06:51 var i,j,k,n,l,m,m1:longint; a,b,c,r:array [0..10000] of integer; function search(k:integer):integer; var i,j,l:integer; begin l:=0; if k>1 then if c[a[k]]=0 then begin c[a[k]]:=c[k]+1; l:=1; end; for i:=1 to n do if a[i]=k then if c[i]=0 then begin c[i]:=c[k]+1; l:=1; end; search:=l; end; begin read(n); for i:=2 to n do begin read(a[i]); b[a[i]]:=1; end; for k:=1 to n do begin fillchar(c,sizeof(c),0); c[k]:=1; l:=0; while l=0 do begin for i:=1 to n do if c[i]>0 then if search(i)=1 then l:=1; l:=1-l; end; l:=0; for i:=1 to n do if c[i]>l then l:=c[i]; if (l<m) or (m=0) then begin fillchar(r,sizeof(r),0); m1:=0; m:=l; end; if l=m then begin inc(m1); r[m1]:=k; end; end; for i:=1 to m1-1 do write(r[i],' '); writeln (r[m1]); end. my olgoritm is O(n*n*n); int`s bad; Can you give me algoritm ints WWWAAA to HELP Послано Oleg 12 дек 2002 08:54 var i,j,k,n,m,k1:integer; a,b,c :array [1..10000] of integer; s:array [0..1,0..10000] of integer; procedure push(k,x:integer); begin inc(s[k,0]); s[k,s[k,0]]:=x; end; function pop(k:integer):integer; begin if s[k,0]>0 then begin pop:=s[k,s[k,0]]; dec(s[k,0]); end else pop:=-1; end; function search(k:integer):integer; var i,j,l:integer; begin l:=0; if k>1 then if c[a[k]]=0 then begin c[a[k]]:=c[k]+1; l:=1; push(1-k1,a[k]); end; for i:=1 to n do if a[i]=k then if c[i]=0 then begin c[i]:=c[k]+1; l:=1; push(1-k1,i); end; search:=l; end; procedure Init; var i : integer; begin read(n); b[1] := 0; for i := 2 to n do b[i] := 1; for i := 2 to n do begin read(a[i]); inc(b[a[i]]); end; end; begin Init; k1:=0; for i:=1 to n do if b[i]=1 then begin push(k,i); c[i]:=1; end; if n>2 then repeat while true do begin i:=pop(k1); if i=-1 then break; search(i); end; k1:=1-k1; until (pop(0)=-1) and (pop(1)=-1); j:=0; for i:=1 to n do if j<c[i] then j:=c[i]; k := 0; for i:=1 to n do begin if c[i]=j then begin k:= k+1; b[k] := i; end; end; for i := 1 to k-1 do begin write(b[i],' '); end; write(b[k]); end. to all I got AC Послано Oleg 12 дек 2002 13:46 i can giv AC program if you give 1013 my E-mail Послано Oleg 12 дек 2002 13:50 Tuphanov@eastnet.febras.ru ac 1059 -> ac any program Послано Oleg 18 дек 2002 09:38 if you give me ac program 1089 or 1189 or 1013 or 1012 or else then i give you 1059 ac Re: to all I got AC I can email you 1013 please email me 1056 and I will reply your email with the solution to 1013. Thanks Email me at drajmsadeq@yahoo.com |