type pver=^tver;
     pe=^te;
     te=record
      e:pe;
      ver:pver;
     end;
     tver=record
      s:string;
      e:pe;
     end;
type trec=record
      s:string;
      ver:pver;
     end;
var i,n:word;
    s:string;
    pb,ver:pver;
    fir:boolean;
procedure add(s:string;ver:pver);
var e:pe;
    vt:pver;
begin
 if s='' then exit;
 e:=ver^.e;
 while e<>nil do begin
  if copy(s,1,pos('\',s)-1)=e^.ver^.s then begin
   delete(s,1,pos('\',s));
   add(s,e^.ver);
   exit;
  end;
  e:=e^.e;
 end;
 new(vt);
 vt^.e:=nil;
 if pos('\',s)>0 then vt^.s:=copy(s,1,pos('\',s)-1) else
 vt^.s:=s;
 new(e);
 e^.ver:=vt;
 e^.e:=ver^.e;
 ver^.e:=e;
 if pos('\',s)>0 then begin
  delete(s,1,pos('\',s));
  add(s,vt);
 end;
end;
procedure writ(ver:pver;ur:word);
var a:array [1..600] of trec;
    t:trec;
    kol,u,i:word;
    e:pe;
begin
 kol:=0;
 e:=ver^.e;
 while e<>nil do begin
  inc(kol);
  a[kol].s:=e^.ver^.s;
  a[kol].ver:=e^.ver;
  e:=e^.e;
 end;
 if kol=0 then exit;
 for u:=1 to kol-1 do
 for i:=1 to kol-u do if a[i].s>a[i+1].s then begin
  t:=a[i];
  a[i]:=a[i+1];
  a[i+1]:=t;
 end;
 for i:=1 to kol do begin
{  if not fir then writeln;
  fir:=false;}
  for u:=1 to ur do write(' ');
  writeln(a[i].s);
  writ(a[i].ver,ur+1);
 end;
end;
begin
 new(pb);
 pb^.e:=nil;
 readln(n);
 for i:=1 to n do begin
  readln(s);
  add(s,pb);
 end;
 fir:=true;
 writ(pb,0);
end.

This test help me.
2
GAMES\GGG
GAMES

Thanks your test!