1------------------------------------------------------------------------------
2--                  GtkAda - Ada95 binding for Gtk+/Gnome                   --
3--                                                                          --
4--                   Copyright (C) 1998-2013 E. Briot                       --
5--                     Copyright (C) 2014-2015, AdaCore                     --
6--                                                                          --
7-- This library is free software;  you can redistribute it and/or modify it --
8-- under terms of the  GNU General Public License  as published by the Free --
9-- Software  Foundation;  either version 3,  or (at your  option) any later --
10-- version. This library is distributed in the hope that it will be useful, --
11-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
12-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.                            --
13--                                                                          --
14-- As a special exception under Section 7 of GPL version 3, you are granted --
15-- additional permissions described in the GCC Runtime Library Exception,   --
16-- version 3.1, as published by the Free Software Foundation.               --
17--                                                                          --
18-- You should have received a copy of the GNU General Public License and    --
19-- a copy of the GCC Runtime Library Exception along with this program;     --
20-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
21-- <http://www.gnu.org/licenses/>.                                          --
22--                                                                          --
23------------------------------------------------------------------------------
24
25with Ada.Containers.Hashed_Maps;
26with Ada.Containers.Ordered_Multisets;
27
28package body Gtkada.Canvas_View.Astar is
29
30   Abort_Path : constant := 200;
31   --  Maximum number of Coordinates to examine before an abort.
32
33   type Star_Coordinate is record
34      P    : Coordinate;
35      Gval : Integer;  --  How far we have already gone in the A* algorithm
36      Hval : Integer;  --  Estimate how far is left in the A* algorith
37      Parent : Coordinate;
38   end record;
39
40   function "<" (P1, P2 : Star_Coordinate) return Boolean;
41
42   package Coordinate_Set is new Ada.Containers.Ordered_Multisets
43     (Element_Type => Star_Coordinate);
44   use Coordinate_Set;
45
46   function Hash (P : Coordinate) return Ada.Containers.Hash_Type;
47   package Coordinate_Htable is new Ada.Containers.Hashed_Maps
48     (Key_Type        => Coordinate,
49      Element_Type    => Coordinate,  --  The Coordinate we were coming from
50      Hash            => Hash,
51      Equivalent_Keys => "=",
52      "="             => "=");
53   use Coordinate_Htable;
54
55   function Search
56     (Tree : Coordinate_Set.Set; P : Coordinate) return Coordinate_Set.Cursor;
57   --  Search in tree for a record matching P
58
59   ----------
60   -- Hash --
61   ----------
62
63   function Hash (P : Coordinate) return Ada.Containers.Hash_Type is
64      --  The technique to assign a unique key to (X, Y) is:
65      --      1  2  4  7 11 16 22
66      --      3  5  8 12 17 23
67      --      6  9 13 18 24
68      --     10 14 19 25
69      --     15 20 26
70      --     21 27
71      --     28
72      --  The index is computed with:
73      --    index (X, Y) = (X + Y - 1) * (X + Y - 2) / 2 + Y
74
75      use Ada.Containers;
76      Tmp : constant Integer := P.X + P.Y - 1;
77   begin
78      return Hash_Type (Tmp * (Tmp - 1) / 2 + P.Y) mod Hash_Type'Last;
79   end Hash;
80
81   ---------
82   -- "<" --
83   ---------
84
85   function "<" (P1, P2 : Star_Coordinate) return Boolean is
86   begin
87      return P1.Gval + P1.Hval < P2.Gval + P2.Hval;
88   end "<";
89
90   ------------
91   -- Search --
92   ------------
93
94   function Search
95     (Tree : Coordinate_Set.Set; P : Coordinate) return Coordinate_Set.Cursor
96   is
97      Iter : Coordinate_Set.Cursor := First (Tree);
98   begin
99      while Iter /= Coordinate_Set.No_Element loop
100         exit when Element (Iter).P = P;
101         Next (Iter);
102      end loop;
103
104      return Iter;
105   end Search;
106
107   ---------------
108   -- Find_Path --
109   ---------------
110
111   function Find_Path
112     (Self     : User_Data;
113      From, To : Coordinate;
114      Parent   : Coordinate) return Coordinate_Array
115   is
116      Open     : Coordinate_Set.Set;
117      Visited  : Coordinate_Htable.Map;
118      N        : Star_Coordinate;
119      Next     : Coordinate;
120      Iter     : Coordinate_Set.Cursor;
121      Cost     : Integer;
122      Count    : Natural;
123      Nodes_Removed : Integer := 0;
124      Stored   : Coordinate;
125      PIter    : Coordinate_Htable.Cursor;
126      Success  : Boolean;
127   begin
128      --  Insert the original node in the open list
129      Insert (Open, (P        => From,
130                     Gval     => 0,
131                     Hval     => Heuristic_Dist (Self, From, To),
132                     Parent   => Parent),
133              Iter);
134
135      while not Is_Empty (Open) loop
136         Iter := First (Open);
137         N := Element (Iter);
138         Delete (Open, Iter);
139
140         Insert (Visited,
141                 Key => N.P,
142                 New_Item => N.Parent,
143                 Position => PIter,
144                 Inserted => Success);
145
146         Nodes_Removed := Nodes_Removed + 1;
147         if Nodes_Removed >= Abort_Path then
148            return (1 => From, 2 => To);
149         end if;
150
151         exit when N.P = To;
152
153         for Num in 1 .. Positive'Last loop
154            Next := Next_Point (Self, N.P, Num);
155            exit when Next = No_Coordinate;
156
157            if Next /= N.Parent then
158               Cost := Heuristic_Cost (Self, N.Parent, N.P, Next);
159
160               if Cost > 0 then
161                  --  Is this Coordinate already in the closed list ?
162                  if Find (Visited, Next) = Coordinate_Htable.No_Element then
163                     Iter := Search (Open, Next);
164                     if Iter = Coordinate_Set.No_Element then
165                        Insert (Open,
166                                (P      => Next,
167                                 Gval   => N.Gval + Cost,
168                                 Hval   => Heuristic_Dist (Self, Next, To),
169                                 Parent => N.P),
170                                Iter);
171                     elsif N.Gval + Cost < Element (Iter).Gval then
172                        Delete (Open, Iter);
173                        Insert (Open,
174                                (P      => Next,
175                                 Gval   => N.Gval + Cost,
176                                 Hval   => Heuristic_Dist (Self, Next, To),
177                                 Parent => N.P),
178                                Iter);
179                     end if;
180                  end if;
181               end if;
182            end if;
183         end loop;
184      end loop;
185
186      PIter := Find (Visited, To);
187      Count  := 0;
188
189      if Has_Element (PIter) then
190         Stored := To;
191         while Stored /= From loop
192            Stored := Element (Visited, Stored);
193            Count := Count + 1;
194         end loop;
195      end if;
196
197      if Count = 0 then
198         return (From, To);
199      else
200         declare
201            Arr   : Coordinate_Array (1 .. Count + 1);
202            Index : Natural := Arr'Last;
203         begin
204            Stored := To;
205            while Stored /= From loop
206               Arr (Index) := Stored;
207               Stored      := Element (Visited, Stored);
208               Index       := Index - 1;
209            end loop;
210
211            Arr (1) := From;
212
213            Clear (Open);
214
215            --  Free the memory
216            Clear (Visited);
217            return Arr;
218         end;
219      end if;
220   end Find_Path;
221
222   --------------------------
223   -- Manhattan_Next_Point --
224   --------------------------
225
226   function Manhattan_Next_Point
227     (Self : User_Data; From : Coordinate; Nth : Positive) return Coordinate
228   is
229      pragma Unreferenced (Self);
230   begin
231      case Nth is
232         when 1 =>
233            return (From.X, From.Y - 1);
234         when 2 =>
235            return (From.X + 1, From.Y);
236         when 3 =>
237            return (From.X, From.Y + 1);
238         when 4 =>
239            return (From.X - 1, From.Y);
240         when others =>
241            return No_Coordinate;
242      end case;
243   end Manhattan_Next_Point;
244
245end Gtkada.Canvas_View.Astar;
246