old/PAS/BTree.pas

Uses CRT;
Type
  UT = char;                            {�®«ì§®¢ â¥«ì᪨© ⨯}
  PBTree = ^TBTree;                     {“ª § â¥«ì ­  ¤¥à¥¢®}
  TBTree = record                       {�à®áâ® ¤¥à¥¢®}
    info : UT;                          {‡­ ç¥­¨¥}
    count: word;                        {Š®«¨ç¥á⢮}
    Left : PBTree;                      {‹¥¢ ï ¢¥â¢ì}
    Right: PBTree;                      {�à ¢ ï ¢¥â¢ì}
  end;

Function NewChild(info:UT) : PBtree;    {”ã­ªæ¨ï ᮧ¤ ­¨ï ­®¢®© ¢¥â¢¨}
var
 ne : PBTree;                           {“ª § â¥«ì ­  १ã«ìâ â}
begin
 New(ne);
 Ne^.info  := Info;                     {‡ ¯®«­ï¥¬ §­-¥}
 Ne^.Left  := nil;
 Ne^.Right := nil;
 Ne^.count := 1;                        {Š®«-¢® - 1}
 NewChild  := ne;
end; {NewChild}
{---------------------------------}
Procedure DelBranch(br:PBTree);         {“¤ «¥­¨¥ ¢¥â¢¨, ¢¬¥áâ¨ á ¤¥â쬨}
begin
  if br^.left <> nil then DelBranch(br^.left);  {…᫨ ¥áâì «¥¢ë© ॡ¥­®ª -
                                                 㤠«ï¥¬ ¥£®}
  if br^.right <> nil then DelBranch(br^.right);{€ ¥á«¨ ¥áâì ¨ ¯à ¢ë© - ¨
                                                 ¥£® ⮦¥!}
  Dispose(br);                                  {‘®¡á⢥­­® 㤠«¥­¨¥}
end;{DelBranch}
{---------------------------------}
Procedure SetLRootRInfo(info:UT;Br:PBTree);     {„®¡ ¢«¥­¨¥ ­®¢®£® §­-ï ­ 
                                                 ­  ¢¥â¢ì}
begin
  if info < Br^.info then                       {�®áë« ¥¬ ­  «¥¢®}
   begin
     if (Br^.Left=nil) then Br^.Left := NewChild(info)  {…᫨ ­¨ª®£® - ¢¥è ¥¬}
     else SetLRootRInfo(info,BR^.Left);            {ˆ­ ç¥ - á¯ã᪠¥¬ ­  «¥¢®}
   end
  else                                 {€ ¥á«¨ â ª®©-¦¥ - 㢥«¨ç¨¢ ¥¬ ª®«-¢®}
   if (info=Br^.info) then inc(Br^.count)
  else                                 {‡­ ç¨â ®­® - á¯à ¢ }
   begin
     if (Br^.Right=nil) then            {…᫨ ­¨ª®£® - ¢¥è ¥¬ ­ ¯à ¢®}
       Br^.Right := NewChild(info)
     else SetLRootRInfo(info,BR^.Right);  {ˆ­ ç¥ - á¯ã᪠¥¬ ­  ¯à ¢®}
   end;
end;{SetLRootRInfo}
{---------------------------------}
Function MakeLRootRTree(st:string;count:word):PBTree;
  {‘®§¤ ­¨¥ ¤¢®¨ç­®£® ¤¥à¥¢  ¤«ï ¯®¨áª }
var
  ret : PBTree;
  pos : byte;
Begin
  ret := NewChild(st[1]);
  for pos := 2 to count do SetLRootRInfo(st[pos],ret);
  MakeLRootRTree := ret;
End; {MakeLRootRTree}
{---------------------------------}
var
  h : word;                         {ƒ«®¡ «ì­ ï ¯¥à¥¬¥­­ ï - ­®¬¥à ã஢­ï}
Procedure FindInfo(info:UT;Br:PBTree); {�®¨áª §­-ï ¢ ¤¥à¥¢¥, á ¯®¤áç¥â®¬ H}
begin
 if (Br<>nil) then begin
 if (info<Br^.Info) then begin inc(h); FindInfo(info,Br^.Left) end
 else if (info>Br^.Info) then begin inc(h); FindInfo(info,Br^.Right) end;
 end
 else h := 0;
end;

Var
  test  : string;
  BTree : PBTree;
  ch    : char;
BEGIN
  WriteLn('‚¢¥¤¨â¥ ¬ áᨢ ¤«ï ᮧ¤ ­¨ï ¤¢®¨ç­®£® ¤¥à¥¢  ¯®¨áª  ¬¥â®¤®¬ Left->Root->Right');
  ReadLn(test);
  BTree := MakeLRootRTree(test,Length(test));
  h := 1;
  WriteLn('‚¢¥¤¨â¥ ᨬ¢®« ¤«ï ¯®¨áª  ¯® ¤¥à¥¢ã: ');
  ch := ReadKey;
  FindInfo(ch,BTree);
  DelBranch(BTree);
  if (h<>0) then
    WriteLn('‘¨¬¢®« ''',ch,''' ­ ©¤¥­ ­  ',h,'-®¬ ã஢­¥')
  else
    WriteLn('‘¨¬¢®« ''',ch,''' ­¥ ­ ©¤¥­');
  ReadKey;
END.