1------------------------------------------------------------------------------ 2-- GtkAda - Ada95 binding for Gtk+/Gnome -- 3-- -- 4-- Copyright (C) 2014-2015, AdaCore -- 5-- -- 6-- This library is free software; you can redistribute it and/or modify it -- 7-- under terms of the GNU General Public License as published by the Free -- 8-- Software Foundation; either version 3, or (at your option) any later -- 9-- version. This library is distributed in the hope that it will be useful, -- 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12-- -- 13-- As a special exception under Section 7 of GPL version 3, you are granted -- 14-- additional permissions described in the GCC Runtime Library Exception, -- 15-- version 3.1, as published by the Free Software Foundation. -- 16-- -- 17-- You should have received a copy of the GNU General Public License and -- 18-- a copy of the GCC Runtime Library Exception along with this program; -- 19-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20-- <http://www.gnu.org/licenses/>. -- 21-- -- 22------------------------------------------------------------------------------ 23 24with Ada.Containers.Doubly_Linked_Lists; 25with Ada.Text_IO; use Ada.Text_IO; 26with Ada.Unchecked_Deallocation; 27 28package body Gtkada.Canvas_View.Rtrees is 29 30 package Box_Lists is new Ada.Containers.Doubly_Linked_Lists (Box_Access); 31 32 function Choose_Leaf_Node 33 (Self : Rtree; Rect : Model_Rectangle) return Box_Access; 34 -- Choose the best node to insert Rect into, starting at the root. 35 -- It never returns a leaf node, only a node that accepts children. 36 37 function Least_Enlargement 38 (Nodes : Box_Array; Rect : Model_Rectangle) 39 return not null Box_Access; 40 -- Returns the node from Nodes that would require the least enlargement to 41 -- contain Rect. 42 43 procedure Linear_Pick_Seeds 44 (Width, Height : Gdouble; 45 Nodes : Box_Array; 46 Node1, Node2 : out Box_Access); 47 -- Select, among the children of a box (Nodes), the two that are less 48 -- likely to be in the same parent after a split. This uses the linear 49 -- search proposed in the original paper on R-Trees. 50 -- Width and Height are the total dimensions of the box. 51 52 procedure Internal_Find 53 (Self : Rtree; 54 Rect : Model_Rectangle; 55 Callback : not null access procedure (Node : Box_Access)); 56 -- Calls Callback for each item in the given area. 57 58 procedure Add_Child (Self : Box_Access; Child : Box_Access); 59 -- Add a new child. This doesn't update the bounding boxes or ensures that 60 -- the number of children is kept below the threshold. 61 62 procedure Recompute_Bounding_Box (Self : Box_Access); 63 -- Recompute the tightest bounding box for all children of Self. 64 65 --------------- 66 -- Add_Child -- 67 --------------- 68 69 procedure Add_Child (Self : Box_Access; Child : Box_Access) is 70 begin 71 for C in Self.Children'Range loop 72 if Self.Children (C) = null then 73 Self.Children (C) := Child; 74 Child.Parent := Self; 75 return; 76 end if; 77 end loop; 78 end Add_Child; 79 80 ---------------------------- 81 -- Recompute_Bounding_Box -- 82 ---------------------------- 83 84 procedure Recompute_Bounding_Box (Self : Box_Access) is 85 C : Box_Access; 86 P : Box_Access := Self; 87 begin 88 while P /= null loop 89 C := P.Children (P.Children'First); 90 if C = null then 91 P.Rect := (0.0, 0.0, 0.0, 0.0); 92 else 93 P.Rect := C.Rect; 94 95 for Child in P.Children'First + 1 .. P.Children'Last loop 96 C := P.Children (Child); 97 exit when C = null; 98 Union (P.Rect, C.Rect); 99 end loop; 100 end if; 101 102 P := P.Parent; 103 end loop; 104 end Recompute_Bounding_Box; 105 106 ----------------------- 107 -- Least_Enlargement -- 108 ----------------------- 109 110 function Least_Enlargement 111 (Nodes : Box_Array; Rect : Model_Rectangle) 112 return not null Box_Access 113 is 114 Best_Choice : Box_Access; 115 Best_Choice_Enlarge : Gdouble := Gdouble'Last; 116 Ltree : Box_Access; 117 New_Width, New_Height, Enlarge, Old_Ratio : Gdouble; 118 begin 119 for C in Nodes'Range loop 120 Ltree := Nodes (C); 121 exit when Ltree = null; 122 123 Old_Ratio := Ltree.Rect.Width * Ltree.Rect.Height; 124 New_Width := Gdouble'Max 125 (Ltree.Rect.X + Ltree.Rect.Width, Rect.X + Rect.Width) 126 - Gdouble'Min (Ltree.Rect.X, Rect.X); 127 New_Height := Gdouble'Max 128 (Ltree.Rect.Y + Ltree.Rect.Height, Rect.Y + Rect.Height) 129 - Gdouble'Min (Ltree.Rect.Y, Rect.Y); 130 Enlarge := abs (New_Width * New_Height - Old_Ratio); 131 132 if Enlarge < Best_Choice_Enlarge then 133 Best_Choice := Ltree; 134 Best_Choice_Enlarge := Enlarge; 135 end if; 136 end loop; 137 return Best_Choice; 138 end Least_Enlargement; 139 140 ---------------------- 141 -- Choose_Leaf_Node -- 142 ---------------------- 143 144 function Choose_Leaf_Node 145 (Self : Rtree; Rect : Model_Rectangle) return Box_Access 146 is 147 Best_Choice : Box_Access := Self.Root; 148 C : Box_Access; 149 begin 150 -- Stop when we can go no further down in the tree (nodes below are 151 -- leaves) 152 153 loop 154 C := Best_Choice.Children (Best_Choice.Children'First); 155 exit when C = null or else C.Object /= null; 156 157 Best_Choice := Least_Enlargement (Best_Choice.Children, Rect); 158 end loop; 159 return Best_Choice; 160 end Choose_Leaf_Node; 161 162 ----------------------- 163 -- Linear_Pick_Seeds -- 164 ----------------------- 165 166 procedure Linear_Pick_Seeds 167 (Width, Height : Gdouble; 168 Nodes : Box_Array; 169 Node1, Node2 : out Box_Access) 170 is 171 -- Find extreme rectangles along all dimensions. 172 -- Along each dimensions, find the entry whose rectangle has the 173 -- highest low side, and the one with the lowest high-side. Record 174 -- the separations. 175 176 X_High : Box_Access := Nodes (Nodes'First); -- highest low x 177 X_Low : Box_Access := X_High; 178 Highest_Low_X : Gdouble := X_Low.Rect.X; 179 Lowest_High_X : Gdouble := X_High.Rect.X + X_High.Rect.Width; 180 181 Y_High : Box_Access := Nodes (Nodes'First); -- highest low y 182 Y_Low : Box_Access := Y_High; 183 Highest_Low_Y : Gdouble := Y_Low.Rect.Y; 184 Lowest_High_Y : Gdouble := Y_High.Rect.Y + Y_High.Rect.Height; 185 186 N : Box_Access; 187 Candidate_X, Candidate_Y : Gdouble; 188 begin 189 for C in Nodes'First + 1 .. Nodes'Last loop 190 N := Nodes (C); 191 exit when N = null; 192 193 if N.Rect.X >= Highest_Low_X then 194 X_Low := N; 195 Highest_Low_X := N.Rect.X; 196 elsif N.Rect.X + N.Rect.Width <= Lowest_High_X then 197 X_High := N; 198 Lowest_High_X := N.Rect.X + N.Rect.Width; 199 end if; 200 201 if N.Rect.Y >= Highest_Low_Y then 202 Y_Low := N; 203 Highest_Low_Y := N.Rect.Y; 204 elsif N.Rect.Y + N.Rect.Height <= Lowest_High_Y then 205 Y_High := N; 206 Lowest_High_Y := N.Rect.Y + N.Rect.Height; 207 end if; 208 end loop; 209 210 -- Adjust the shape of the rectangle cluster 211 -- Normalize the separations by dividing by the width of the entire 212 -- set along the corresponding dimensions. 213 214 Candidate_X := abs (Lowest_High_X - Highest_Low_X) / Width; 215 Candidate_Y := abs (Lowest_High_Y - Highest_Low_Y) / Height; 216 217 -- Select the most extreme pair (the pair with the greatest normalized 218 -- separation along any dimensions) 219 220 if Candidate_X > Candidate_Y 221 and then X_Low /= X_High 222 then 223 Node1 := X_Low; 224 Node2 := X_High; 225 elsif Y_Low /= Y_High then 226 Node1 := Y_Low; 227 Node2 := Y_High; 228 else 229 -- One node encapsulates all the others. 230 Node1 := X_Low; 231 for C in Nodes'Range loop 232 if Nodes (C) /= Node1 then 233 Node2 := Nodes (C); 234 exit; 235 end if; 236 end loop; 237 end if; 238 end Linear_Pick_Seeds; 239 240 ------------------- 241 -- Internal_Find -- 242 ------------------- 243 244 procedure Internal_Find 245 (Self : Rtree; 246 Rect : Model_Rectangle; 247 Callback : not null access procedure (Node : Box_Access)) 248 is 249 use Box_Lists; 250 To_Analyze : Box_Lists.List; 251 Current, C : Box_Access; 252 begin 253 -- The implementation is non-recursive to improve efficiency 254 255 if Self.Root /= null then 256 To_Analyze.Append (Box_Access'(Self.Root)); 257 while not To_Analyze.Is_Empty loop 258 Current := To_Analyze.First_Element; 259 To_Analyze.Delete_First; 260 261 for Child in Current.Children'Range loop 262 C := Current.Children (Child); 263 exit when C = null; 264 265 if Rect = No_Rectangle 266 or else Intersects (Rect, C.Rect) 267 then 268 if C.Object /= null then 269 Callback (C); 270 else 271 To_Analyze.Append (C); 272 end if; 273 end if; 274 end loop; 275 end loop; 276 end if; 277 end Internal_Find; 278 279 ---------- 280 -- Find -- 281 ---------- 282 283 function Find 284 (Self : Rtree; Rect : Model_Rectangle) return Items_Lists.List 285 is 286 use Items_Lists; 287 Results : Items_Lists.List; 288 procedure Append (Node : Box_Access); 289 procedure Append (Node : Box_Access) is 290 begin 291 Results.Append (Node.Object); 292 end Append; 293 begin 294 Internal_Find (Self, Rect, Append'Access); 295 return Results; 296 end Find; 297 298 ------------ 299 -- Insert -- 300 ------------ 301 302 procedure Insert 303 (Self : in out Rtree; 304 Item : not null access Abstract_Item_Record'Class) 305 is 306 Child : constant Box_Access := new Box' 307 (Max_Children_Plus_1 => 0, 308 Rect => Item.Model_Bounding_Box, 309 Object => Abstract_Item (Item), 310 others => <>); 311 Parent, P, P2 : Box_Access; 312 N1, N2 : Box_Access; 313 New_Parent : Box_Access; 314 Old_Root : Box_Access; 315 begin 316 if Self.Root = null then 317 Self.Root := new Box' 318 (Max_Children_Plus_1 => Self.Max_Children + 1, 319 others => <>); 320 end if; 321 322 if Self.Root.Children (Self.Root.Children'First) = null then 323 -- Initial insertion in an empty tree 324 Add_Child (Self.Root, Child); 325 Recompute_Bounding_Box (Self.Root); 326 327 else 328 -- Compute the best node to insert the new child. The returned node 329 -- has leaves as children (i.e. they don't themselves contain nodes) 330 331 Parent := Choose_Leaf_Node (Self, Child.Rect); 332 Add_Child (Parent, Child); 333 334 -- Walk up the tree and resize the bounding boxes as needed 335 336 P := Parent; 337 while P /= null loop 338 Union (P.Rect, Child.Rect); 339 P := P.Parent; 340 end loop; 341 342 -- Now split the nodes as needed when they are full: starting with 343 -- the new parent A, we check if it has too many children. If yes, 344 -- its parent will have one more child B. The children of A are then 345 -- shared between A and B, where the algorithm tries to minimize the 346 -- area of both A and B. 347 -- Parent might now have too many children as well, so we go up the 348 -- tree and normalize the nodes (we might eventually have to create 349 -- a new root). This ensures a balanced tree. 350 351 P := Parent; 352 while P /= null and then P.Children (P.Children'Last) /= null loop 353 Linear_Pick_Seeds 354 (Width => P.Rect.Width, 355 Height => P.Rect.Height, 356 Nodes => P.Children, 357 Node1 => N1, 358 Node2 => N2); 359 360 New_Parent := new Box' 361 (Max_Children_Plus_1 => Self.Max_Children + 1, 362 Rect => N2.Rect, 363 others => <>); 364 Add_Child (New_Parent, N2); 365 366 declare 367 Nodes : constant Box_Array := P.Children; 368 begin 369 P.Children := (1 => N1, others => null); 370 P.Rect := N1.Rect; 371 372 for C in Nodes'Range loop 373 exit when Nodes (C) = null; 374 if Nodes (C) /= N1 and then Nodes (C) /= N2 then 375 P2 := Least_Enlargement ((P, New_Parent), Nodes (C).Rect); 376 Add_Child (P2, Nodes (C)); 377 Union (P2.Rect, Nodes (C).Rect); 378 end if; 379 end loop; 380 end; 381 382 -- If we are splitting the root node, we need to create a new 383 -- root 384 385 if P.Parent = null then 386 Old_Root := Self.Root; 387 Self.Root := new Box' 388 (Max_Children_Plus_1 => Self.Max_Children + 1, 389 Rect => Old_Root.Rect, 390 others => <>); 391 Add_Child (Self.Root, Old_Root); 392 Add_Child (Self.Root, New_Parent); 393 Union (Self.Root.Rect, New_Parent.Rect); 394 else 395 Add_Child (P.Parent, New_Parent); 396 end if; 397 398 P := P.Parent; 399 end loop; 400 end if; 401 end Insert; 402 403 ----------- 404 -- Clear -- 405 ----------- 406 407 procedure Clear (Self : in out Rtree) is 408 procedure Unchecked_Free is new Ada.Unchecked_Deallocation 409 (Box'Class, Box_Access); 410 procedure Recurse (B : in out Box_Access); 411 procedure Recurse (B : in out Box_Access) is 412 begin 413 for C in B.Children'Range loop 414 exit when B.Children (C) = null; 415 Recurse (B.Children (C)); 416 end loop; 417 Unchecked_Free (B); 418 end Recurse; 419 begin 420 if Self.Root /= null then 421 Recurse (Self.Root); 422 end if; 423 end Clear; 424 425 -------------- 426 -- Is_Empty -- 427 -------------- 428 429 function Is_Empty (Self : Rtree) return Boolean is 430 begin 431 return Self.Root = null; 432 end Is_Empty; 433 434 ---------------- 435 -- Dump_Debug -- 436 ---------------- 437 438 procedure Dump_Debug (Self : Rtree) is 439 procedure Internal (B : Box_Access; Prefix : String); 440 procedure Internal (B : Box_Access; Prefix : String) is 441 begin 442 if B.Object /= null then 443 Put_Line 444 (Prefix & "[leaf " 445 & Gdouble'Image (B.Rect.X) & Gdouble'Image (B.Rect.Y) 446 & Gdouble'Image (B.Rect.Width) & 'x' 447 & Gdouble'Image (B.Rect.Height) 448 & ']'); 449 else 450 Put_Line 451 (Prefix & "[" 452 & Gdouble'Image (B.Rect.X) & Gdouble'Image (B.Rect.Y) 453 & Gdouble'Image (B.Rect.Width) & 'x' 454 & Gdouble'Image (B.Rect.Height)); 455 for C in B.Children'Range loop 456 exit when B.Children (C) = null; 457 Internal (B.Children (C), Prefix & " "); 458 end loop; 459 Put_Line (Prefix & "]"); 460 end if; 461 end Internal; 462 begin 463 if Self.Root /= null then 464 Internal (Self.Root, ""); 465 end if; 466 end Dump_Debug; 467 468 ------------------ 469 -- Bounding_Box -- 470 ------------------ 471 472 function Bounding_Box (Self : Rtree) return Model_Rectangle is 473 begin 474 if Self.Root = null then 475 return (0.0, 0.0, 0.0, 0.0); 476 else 477 return Self.Root.Rect; 478 end if; 479 end Bounding_Box; 480 481 --------------------- 482 -- For_Each_Object -- 483 --------------------- 484 485 procedure For_Each_Object 486 (Self : Rtree; 487 Callback : not null access procedure 488 (Item : not null access Abstract_Item_Record'Class); 489 In_Area : Model_Rectangle := No_Rectangle) 490 is 491 procedure Append (Node : Box_Access); 492 pragma Inline (Append); 493 494 procedure Append (Node : Box_Access) is 495 begin 496 Callback (Node.Object); 497 end Append; 498 begin 499 Internal_Find (Self, In_Area, Append'Access); 500 end For_Each_Object; 501 502end Gtkada.Canvas_View.Rtrees; 503