1--  Copyright Simon Wright <simon@pushface.org>
2
3--  This package is free software; you can redistribute it and/or
4--  modify it under terms of the GNU General Public License as
5--  published by the Free Software Foundation; either version 2, or
6--  (at your option) any later version. This package is distributed in
7--  the hope that it will be useful, but WITHOUT ANY WARRANTY; without
8--  even the implied warranty of MERCHANTABILITY or FITNESS FOR A
9--  PARTICULAR PURPOSE. See the GNU General Public License for more
10--  details. You should have received a copy of the GNU General Public
11--  License distributed with this package; see file COPYING.  If not,
12--  write to the Free Software Foundation, 59 Temple Place - Suite
13--  330, Boston, MA 02111-1307, USA.
14
15--  $Revision$
16--  $Date$
17--  $Author$
18--
19--  Tests for AVL Trees.
20
21with AUnit.Assertions; use AUnit.Assertions;
22with AUnit.Test_Cases; use AUnit.Test_Cases;
23with Ada.Text_IO; use Ada.Text_IO;
24
25with BC.Containers.Trees;
26with BC.Containers.Trees.AVL;
27with Global_Heap;
28
29with Tests.Support;
30
31pragma Warnings (Off, Ada.Text_IO);
32--  May not be referenced for released versions
33
34package body Tests.AVL_Trees is
35
36   package Containers is new BC.Containers
37     (Item => Tests.Support.Item,
38      "=" => Tests.Support."=");
39
40   package Trees is new Containers.Trees;
41
42   package TA is new Trees.AVL
43     (Storage => Global_Heap.Storage,
44      "<" => Tests.Support ."<");
45   use TA;
46
47   function To_String (The_Tree : AVL_Tree) return String;
48
49   subtype Item is Tests.Support.Item;
50   use type Tests.Support.Item;
51
52
53   type Case_1 is new Test_Case with null record;
54   function Name (C : Case_1) return AUnit.Message_String;
55   procedure Register_Tests (C : in out Case_1);
56
57
58   -----------------------
59   --  Test procedures  --
60   -----------------------
61
62   procedure Initially_Empty (C : in out Test_Case'Class);
63   procedure Initially_Empty (C : in out Test_Case'Class) is
64      pragma Unreferenced (C);
65      T : AVL_Tree;
66   begin
67      Assert (To_String (T) = "",
68              "expecting """", got """ & To_String (T) & """");
69      Assert (Extent (T) = 0, "extent not 0");
70      Assert (Is_Null (T), "tree not null");
71      Assert (not Is_Member (T, Item'('a', 0)), "('a', 0) is a member");
72      declare
73         Found : Boolean := True;
74      begin
75         Delete (T, Item'('a', 0), Found);
76         Assert (not Found, "('a', 0) found on deletion");
77      end;
78   end Initially_Empty;
79
80
81   procedure One_Element (C : in out Test_Case'Class);
82   procedure One_Element (C : in out Test_Case'Class) is
83      pragma Unreferenced (C);
84      T : AVL_Tree;
85      Not_Found : Boolean;
86   begin
87      Not_Found := False;
88      Insert (T, Item'('a', 0), Not_Found);
89      Assert (Not_Found, "('a', 0) was found");
90      Assert (To_String (T) = "a",
91              "expecting ""a"", got """ & To_String (T) & """");
92      Assert (Extent (T) = 1, "extent not 1");
93      Assert (not Is_Null (T), "tree is null");
94      Assert (Is_Member (T, Item'('a', 0)), "('a', 0) is not a member");
95      Assert (Is_Member (T, Item'('a', 1)), "('a', 1) is not a member");
96      Assert (Is_Member (T, Item'('A', 0)), "('A', 0) is not a member");
97      Assert (not Is_Member (T, Item'('b', 0)), "('b', 0) is a member");
98      Assert (not Is_Member (T, Item'('B', 0)), "('B', 0) is a member");
99      declare
100         T2 : AVL_Tree := T;
101         Found : Boolean := False;
102      begin
103         Delete (T2, Item'('a', 0), Found);
104         Assert (Found, "('a', 0) found on deletion");
105         Assert (Extent (T2) = 0, "extent not 0 after deleting ('a', 0)");
106      end;
107      declare
108         T2 : AVL_Tree := T;
109         Found : Boolean := False;
110      begin
111         Delete (T2, Item'('A', 0), Found);
112         Assert (Found, "('A', 0) found on deletion");
113         Assert (Extent (T2) = 0, "extent not 0 after deleting ('A', 0)");
114      end;
115      declare
116         Found : Boolean := True;
117      begin
118         Delete (T, Item'('b', 0), Found);
119         Assert (not Found, "('b', 0) found on deletion");
120      end;
121      Not_Found := True;
122      Insert (T, Item'('a', 1), Not_Found);
123      Assert (not Not_Found, "('a', 1) was not found");
124      Assert (Extent (T) = 1, "extent not 1 after inserting ('a', 1)");
125      Not_Found := True;
126      Insert (T, Item'('A', 2), Not_Found);
127      Assert (not Not_Found, "('A', 2) was not found");
128      Assert (Extent (T) = 1, "extent not 1 after inserting ('A', 2)");
129   end One_Element;
130
131
132   ----------------------------------------
133   --  Support/framework implementations --
134   ----------------------------------------
135
136   function To_String
137     (The_Tree : AVL_Tree) return String is
138      procedure Add_Char (Elem : Support.Item; OK : out Boolean);
139      procedure Get_Result is new Visit (Apply => Add_Char);
140      Result : String (1 .. Extent (The_Tree));
141      Last : Natural := 0;
142      procedure Add_Char (Elem : Support.Item; OK : out Boolean) is
143      begin
144         OK := True;
145         Last := Last + 1;
146         Result (Last) := Elem.C;
147      end Add_Char;
148   begin
149      Get_Result (The_Tree);
150      pragma Assert (Last = Result'Last, "too short");
151      return Result;
152   end To_String;
153
154
155   function Name (C : Case_1) return AUnit.Message_String is
156      pragma Warnings (Off, C);
157   begin
158      return new String'("AVL Trees");
159   end Name;
160
161
162   procedure Register_Tests (C : in out Case_1) is
163   begin
164      Registration.Register_Routine
165        (C,
166         Initially_Empty'Access,
167         "tests with no elements");
168      Registration.Register_Routine
169        (C,
170         One_Element'Access,
171         "tests with one element");
172   end Register_Tests;
173
174
175   function Suite return AUnit.Test_Suites.Access_Test_Suite is
176      Result : constant AUnit.Test_Suites.Access_Test_Suite
177        := new AUnit.Test_Suites.Test_Suite;
178   begin
179      AUnit.Test_Suites.Add_Test (Result, new Case_1);
180      return Result;
181   end Suite;
182
183
184end Tests.AVL_Trees;
185