-- GHDL Run Time (GRT) - binary balanced tree.
-- Copyright (C) 2002 - 2014 Tristan Gingold
--
-- GHDL is free software; you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 2, or (at your option) any later
-- version.
--
-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-- for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with GCC; see the file COPYING. If not, write to the Free
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
--
-- As a special exception, if other files instantiate generics from this
-- unit, or you link this unit with other files to produce an executable,
-- this unit does not by itself cause the resulting executable to be
-- covered by the GNU General Public License. This exception does not
-- however invalidate any other reasons why the executable file might be
-- covered by the GNU Public License.
with Grt.Errors; use Grt.Errors;
package body Grt.Avls is
function Get_Height (Tree: AVL_Tree; N : AVL_Nid) return Ghdl_I32 is
begin
if N = AVL_Nil then
return 0;
else
return Tree (N).Height;
end if;
end Get_Height;
procedure Check_AVL (Tree : AVL_Tree; N : AVL_Nid)
is
L, R : AVL_Nid;
Lh, Rh : Ghdl_I32;
H : Ghdl_I32;
begin
if N = AVL_Nil then
return;
end if;
L := Tree (N).Left;
R := Tree (N).Right;
H := Get_Height (Tree, N);
if L = AVL_Nil and R = AVL_Nil then
if Get_Height (Tree, N) /= 1 then
Internal_Error ("check_AVL(1)");
end if;
return;
elsif L = AVL_Nil then
Check_AVL (Tree, R);
if H /= Get_Height (Tree, R) + 1 or H > 2 then
Internal_Error ("check_AVL(2)");
end if;
elsif R = AVL_Nil then
Check_AVL (Tree, L);
if H /= Get_Height (Tree, L) + 1 or H > 2 then
Internal_Error ("check_AVL(3)");
end if;
else
Check_AVL (Tree, L);
Check_AVL (Tree, R);
Lh := Get_Height (Tree, L);
Rh := Get_Height (Tree, R);
if Ghdl_I32'Max (Lh, Rh) + 1 /= H then
Internal_Error ("check_AVL(4)");
end if;
if Rh - Lh > 1 or Rh - Lh < -1 then
Internal_Error ("check_AVL(5)");
end if;
end if;
end Check_AVL;
procedure Compute_Height (Tree : in out AVL_Tree; N : AVL_Nid)
is
begin
Tree (N).Height :=
Ghdl_I32'Max (Get_Height (Tree, Tree (N).Left),
Get_Height (Tree, Tree (N).Right)) + 1;
end Compute_Height;
procedure Simple_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid)
is
R : AVL_Nid;
V : AVL_Value;
begin
-- Rotate nodes.
R := Tree (N).Right;
Tree (N).Right := Tree (R).Right;
Tree (R).Right := Tree (R).Left;
Tree (R).Left := Tree (N).Left;
Tree (N).Left := R;
-- Swap vals.
V := Tree (N).Val;
Tree (N).Val := Tree (R).Val;
Tree (R).Val := V;
-- Adjust bal.
Compute_Height (Tree, R);
Compute_Height (Tree, N);
end Simple_Rotate_Right;
procedure Simple_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid)
is
L : AVL_Nid;
V : AVL_Value;
begin
L := Tree (N).Left;
Tree (N).Left := Tree (L).Left;
Tree (L).Left := Tree (L).Right;
Tree (L).Right := Tree (N).Right;
Tree (N).Right := L;
V := Tree (N).Val;
Tree (N).Val := Tree (L).Val;
Tree (L).Val := V;
Compute_Height (Tree, L);
Compute_Height (Tree, N);
end Simple_Rotate_Left;
procedure Double_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid)
is
R : AVL_Nid;
begin
R := Tree (N).Right;
Simple_Rotate_Left (Tree, R);
Simple_Rotate_Right (Tree, N);
end Double_Rotate_Right;
procedure Double_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid)
is
L : AVL_Nid;
begin
L := Tree (N).Left;
Simple_Rotate_Right (Tree, L);
Simple_Rotate_Left (Tree, N);
end Double_Rotate_Left;
procedure Insert (Tree : in out AVL_Tree;
Cmp : AVL_Compare_Func;
Val : AVL_Nid;
N : AVL_Nid;
Res : out AVL_Nid)
is
Diff : Integer;
Op_Ch, Ch : AVL_Nid;
begin
Diff := Cmp.all (Tree (Val).Val, Tree (N).Val);
if Diff = 0 then
Res := N;
return;
end if;
if Diff < 0 then
if Tree (N).Left = AVL_Nil then
Tree (N).Left := Val;
Compute_Height (Tree, N);
-- N is balanced.
Res := Val;
else
Ch := Tree (N).Left;
Op_Ch := Tree (N).Right;
Insert (Tree, Cmp, Val, Ch, Res);
if Res /= Val then
return;
end if;
if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then
-- Rotate
if Get_Height (Tree, Tree (Ch).Left)
> Get_Height (Tree, Tree (Ch).Right)
then
Simple_Rotate_Left (Tree, N);
else
Double_Rotate_Left (Tree, N);
end if;
else
Compute_Height (Tree, N);
end if;
end if;
else
if Tree (N).Right = AVL_Nil then
Tree (N).Right := Val;
Compute_Height (Tree, N);
-- N is balanced.
Res := Val;
else
Ch := Tree (N).Right;
Op_Ch := Tree (N).Left;
Insert (Tree, Cmp, Val, Ch, Res);
if Res /= Val then
return;
end if;
if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then
-- Rotate
if Get_Height (Tree, Tree (Ch).Right)
> Get_Height (Tree, Tree (Ch).Left)
then
Simple_Rotate_Right (Tree, N);
else
Double_Rotate_Right (Tree, N);
end if;
else
Compute_Height (Tree, N);
end if;
end if;
end if;
end Insert;
procedure Get_Node (Tree : in out AVL_Tree;
Cmp : AVL_Compare_Func;
N : AVL_Nid;
Res : out AVL_Nid)
is
begin
if Tree'First /= AVL_Root or N /= Tree'Last then
Internal_Error ("avls.get_node");
end if;
Insert (Tree, Cmp, N, AVL_Root, Res);
Check_AVL (Tree, AVL_Root);
end Get_Node;
function Find_Node (Tree : AVL_Tree;
Cmp : AVL_Compare_Func;
Val : AVL_Value) return AVL_Nid
is
N : AVL_Nid;
Diff : Integer;
begin
N := AVL_Root;
if Tree'Last < AVL_Root then
return AVL_Nil;
end if;
loop
Diff := Cmp.all (Val, Tree (N).Val);
if Diff = 0 then
return N;
end if;
if Diff < 0 then
N := Tree (N).Left;
else
N := Tree (N).Right;
end if;
if N = AVL_Nil then
return AVL_Nil;
end if;
end loop;
end Find_Node;
end Grt.Avls;