Шпоры по МПиПА / Деревья / Модуль с работы с деревьями / Pascal / Исходник / tree

program tree(input,output);

const
   left	 = 1;
   right = 2;

type
   str	   = string(30);
   longstr = string(160);
   dtype   = str;
   node	   = record
		key : dtype;
		go : array [1..2] of ^ node;
	     end;  
   ptr	   = ^ node;
   {text = file of char; }

var	  
   root	    : ^ node;
   qry	    : array [1..10] of str;
   qry_len  : integer;
   buff	    : longstr;

procedure readqry(line :longstr);
type
   quote = (single, double);
var
   e	 : char;
   i,t,z : integer;
   sp	 : integer;
   s	 : boolean;
   useq	 : boolean;
   qtype : quote;
begin
   qry[1]:='';
   i:=1;
   s:=false;
   useq:=false;
   z:=length(line);
   t:=0;
   while not (t=z) do begin
      inc(t);
      e:=line[t];
      sp:=0;
      if useq then begin
	     if (e="'") then begin
	     useq:=false;
	     sp:=5;
	     end;
      end
      else
      case e of
	' ' :
	 sp:=1; { space }
	"'" :
      begin
	 useq:=true;
	 sp:=2;
      end;
      end; { case }

      if (sp=0) then begin
	 qry[i]:=qry[i] + e;
	 s:=true;
      end
      else
      if s then begin
	 inc(i);
	 qry[i]:='';
	 s:=false;
      end;
   end;
   qry_len:=i;
end; { readqry }

procedure qry_help;
begin
   writeln('ME Tree help
  Commands:
[a]dd ([l]eft,[r]ight,root) [f]rom (key) new (new key) - add new key
[p]rint (? key, def=root) - print simple tree
[g]raph (? key, def=root) - print graph of tree
save (filename) - save current tree
[at]tach (filename) to (key) - attach save to someone key
[d]elete (key) - delete key with sub
stat - print tree stats
help - this screen
Hint: type "$ tree (filename)" for auto open this file on start');
end; { qry_help }  

function p_find (t:ptr;x:dtype;var res:ptr):boolean;
begin
   if (t=nil) then
      p_find:=false
   else begin
      if (x=t^.key) then begin
	 p_find:=true;
	 res:=t;
      end
      else
	 p_find:=(p_find(t^.go[left],x,res) or p_find(t^.go[right],x,res));
   end;
end; { p_find }

procedure delete (x : dtype);
var
   q : ptr;
procedure link_delete (t : ptr;x:dtype;var res:ptr);
begin
   if (t<>nil) then begin
      if (t^.go[left]<>nil) then
	 if (x=t^.go[left]^.key) then begin
	    res:=t^.go[left];
	    t^.go[left]:=nil;
	 end    
	 else
	    if (t^.go[2]<>nil) then begin
	       if (x=t^.go[right]^.key) then begin
		  res:=t^.go[right];
		  t^.go[right]:=nil;
	       end;
	    end;
      link_delete(t^.go[left],x,res);
      link_delete(t^.go[right],x,res);
   end;
end; { link_delete }

procedure del_item (t : ptr);
begin
   if (t<>nil) then begin
      if (t^.go[left]<>nil) then
	 del_item (t^.go[left]);
      if (t^.go[right]<>nil) then
	 del_item (t^.go[right]);
      dispose(t);
   end;
end; { del_item }

begin
   q:=root;
   link_delete(root,x,q);
   writeln(q^.key);
   del_item(q);

end; { delete }

procedure qry_add_root;
begin
   if (root=nil) then
      new(root);
   root^.key:=qry[3];
   root^.go[left]:=nil;
   root^.go[right]:=nil;
end; { qry_add_root }

procedure qry_add;
var
   q,p : ^ node;
   dir : integer;
begin
   if (qry[2]='left') or (qry[2]='l') then
      dir:=left;
   if (qry[2]='right') or (qry[2]='r') then
      dir:=right;
   if (qry[2]='root') then begin
      qry_add_root;
      exit;
   end;
   q:=root;
   if p_find(root,qry[4],q) then begin
      new(p);
      q^.go[dir]:=p;
      p^.key:=qry[6];
      p^.go[left]:=nil;
      p^.go[right]:=nil;
   end
   else
      writeln('Wrong key');
end; { qry_add }
   
procedure print_item (x:ptr;deep:integer);
var
   i : integer;
begin
   write('  ');
   for i:=1 to deep do
      write ('>>>');
   if not (x=nil) then begin
      write(x^.key);
      writeln;
      if not (x^.go[left]=x^.go[right]) then begin
	 print_item (x^.go[left],deep+1);
	 print_item (x^.go[right],deep+1);
      end;
   end
   else
      writeln('(nil)');
end; { print_item }
   
procedure qry_print;
var
   st : ^ node;
begin
   writeln('Simple tree:');
   if (qry_len>1) then begin
      if not (p_find(root,qry[2],st)) then begin
	 st:=root
      end;
   end
   else
      st:=root;
   print_item(st,0);
end; { qry_print }

procedure qry_save;
var
   fl : text;
   q  : ^ node;

procedure save_item (t : ptr);
begin
   if (t<>nil) then begin
      if (t^.go[left]<>nil) then
	 writeln(fl,'a l f ',t^.key,' new ',t^.go[left]^.key);
      if (t^.go[right]<>nil) then
	 writeln(fl,'a r f ',t^.key,' new ',t^.go[right]^.key);
      save_item(t^.go[left]);
      save_item(t^.go[right]);
   end;
end; { save_item }

begin
   if (qry_len<2) then
      rewrite(fl,'test')
   else
      rewrite(fl,qry[2]);
   writeln(fl,'a root ',root^.key);
   save_item(root);

end; { qry_save }

procedure attach(fname	: str);
var
   fl	     : text;
   oldroot,q : ^ node;
   skip	     : boolean;
begin
   writeln('before reset');
   readln;
   reset(fl,fname);       
   writeln('after reset');
   readln;
   skip:=false;
   if (qry[4]='root') or (root=nil) then begin
      skip:=true;
      writeln('skip');
   end;
   
   if (p_find(root,qry[4],q)) or skip then begin
      if not skip then begin
	 oldroot:=root;
	 root:=q;
	 delete(root^.key);
      end;
      
      while not eof(fl) do begin
	 readln(fl,buff);
	 readqry(buff);
	 qry_add;
      end;
      if not skip then
	 root:=oldroot;
   end;
   readln;
end; { attach }

procedure qry_attach;
begin
   if (qry[2]='to') then
      attach('test')
   else
      attach(qry[2]);
end; { qry_attach }

procedure qry_graph;
type
   pnode = record
	      key  : ^ node;
	      prev : ^ pnode;
	      wide : integer;
	   end;	   
   pptr	 = ^ pnode;

var
   p_start : ^ pnode;
   line_ch : array [1..10] of pptr;
   q	   : ^ node;
   maxdeep : integer;
   k	   : string(80);
   sp_node : ^ node;
   st	   : ^ node;
   i	   : integer;
	   
procedure cache_tree (x	: ptr;deep:integer;wide:integer;p:pptr);
begin
   if (deep>maxdeep) then begin
      new(p_start);
      line_ch[deep]:=p_start;
      line_ch[deep]^.key:=x;
      line_ch[deep]^.prev:=nil;
      line_ch[deep]^.wide:=wide;
      maxdeep:=deep;
   end
   else begin
      new(p_start);
      p_start^.prev:=line_ch[deep];
      line_ch[deep]:=p_start;
      line_ch[deep]^.key:=x;
      line_ch[deep]^.wide:=wide;
   end;
   if (x^.go[right]<>nil) then
      cache_tree (x^.go[right],deep+1,wide*2,p);
   if (x^.go[left]<>nil) then
      cache_tree (x^.go[left],deep+1,wide*2-1,p);
end; { cache_tree }

procedure write_center (line : dtype;space:integer);
var
   i,l,r : integer;
begin
   l:=length(line);
   r:=((space-l) div 2)+1;
   for i:=1 to r do
      write(' ');
   write(line);
   for i:=r+l to space-1 do
      write(' ');
end; { write_center }
   
procedure print_layer (deep : integer);
var
   i,t,y,n,p,o : integer;
   s	       : ^ pnode;
   off	       : boolean;
begin
   p:=1;
   for i:=2 to deep do
      p:=p*2;
   t:=(80 div p);
   o:=(80 mod p);
   y:=0;
   writeln;
   s:=line_ch[deep];
   off:=false;
   if (deep>1) then
      while true do begin
	 n:=line_ch[deep]^.wide-y;
	 y:=line_ch[deep]^.wide;
	 if (n>1) then 
	    write_center (' ',trunc((n-1)*(80/p)));
	 i:=line_ch[deep]^.wide mod 2;
	 if (i=0) then begin
	    write_center ('\',t div 2);
	    write_center ('',t-(t div 2));
	 end
	 else begin
	    write_center ('',t-(t div 2));
	    write_center ('/',t div 2);
	 end;
	 line_ch[deep]:=line_ch[deep]^.prev;
	 if (line_ch[deep]=nil) then
	    break;
      end;
   y:=0;
   writeln;
   line_ch[deep]:=s;
   while true do begin
      n:=line_ch[deep]^.wide-y;
      y:=line_ch[deep]^.wide;
      if (n>1) then
	 write_center (' ',trunc((n-1)*(80/p)));
      write_center (line_ch[deep]^.key^.key,t);
      s:=line_ch[deep];
      line_ch[deep]:=line_ch[deep]^.prev;
      dispose(s);
      if (line_ch[deep]=nil) then
	 break;
   end;
end; { print_layer }
   
begin
   if (qry_len>1) then begin
      if not (p_find(root,qry[2],st)) then begin
	 st:=root
      end;
   end
   else
      st:=root;
   new(p_start);
   maxdeep:=0;
   cache_tree(st,1,1,p_start);
   i:=10;
   writeln('Graph of tree:');
   for i:=1 to maxdeep do
      print_layer(i);
   writeln;
end; { qry_graph }
   
procedure qry_delete;
begin
   delete(qry[2]);
end; { qry_delete }

procedure qry_stat;
var
   lfs	 : integer;
   mdeep : integer;
   nok	 : integer;
   
procedure tree_go (t : ptr;deep:integer);
begin
   if (t<>nil) then begin
      inc(nok);
      if (deep>mdeep) then
	 mdeep:=deep;
      if (t^.go[left]=t^.go[right]) then
	 inc(lfs)
      else begin
	 tree_go (t^.go[left],deep+1);
	 tree_go (t^.go[right],deep+1);
      end;
   end;
end; { tree_go }

begin
   lfs:=0;
   mdeep:=0;
   nok:=0;
   tree_go(root,1);
   writeln ('Tree params:
- num of uzlov: ',nok,'
- num of leafs: ',lfs,'
- max deep:     ',mdeep);
end; { qry_stat }

procedure readquery;
begin
   if (qry[1]='add') or (qry[1]='a') then
      qry_add;
   if (qry[1]='print') or (qry[1]='p') then
      qry_print;
   if (qry[1]='save') then
      qry_save;
   if (qry[1]='attach') or (qry[1]='at') then
      qry_attach;
   if (qry[1]='graph') or (qry[1]='g') then
      qry_graph;
   if (qry[1]='delete') or (qry[1]='d') then
      qry_delete;
   if (qry[1]='stat') then
      qry_stat;
   if (qry[1]='help') then
      qry_help;
   if (qry[1]='exit') or (qry[1]='q') or (qry[1]='bye') then
      halt;
end; { readquery }

begin
   qry_help;
   root:=nil;
   if (paramcount>0) then
      attach(paramstr(1));
   while not eof do begin
      readln(buff);
      readqry(buff);
      readquery;
   end;
   readln;
end. { tree }