diff --git a/agpl-cr-assigner-greedy_exhaustive.adb b/agpl-cr-assigner-greedy_exhaustive.adb index 4cfd546..fc2e500 100644 --- a/agpl-cr-assigner-greedy_exhaustive.adb +++ b/agpl-cr-assigner-greedy_exhaustive.adb @@ -24,6 +24,7 @@ -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- ------------------------------------------------------------------------------ +with Agpl.Chronos; with Agpl.Cr.Agent.Handle; with Agpl.Cr.Assignment; with Agpl.Cr.Tasks.Insertions; @@ -76,6 +77,7 @@ package body Agpl.Cr.Assigner.Greedy_Exhaustive is raise Program_Error; -- Shouldn't be reached. end Remove_From_Pending; + Timer : Chronos.Object; begin -- Set agents declare @@ -90,7 +92,9 @@ package body Agpl.Cr.Assigner.Greedy_Exhaustive is -- Assign tasks: while not Pending.Is_Empty loop - Log ("Pending:" & Pending.Length'Img, Always); + Log ("Pending:" & Pending.Length'Img & " (" & Timer.Image & ")", + Always); + Timer.Reset; declare New_Ass : Cr.Assignment.Object; @@ -98,12 +102,14 @@ package body Agpl.Cr.Assigner.Greedy_Exhaustive is use Htn.Tasks; begin -- Insert best task in best agent: - Cr.Tasks.Insertions.Greedy (A, - Pending, - Costs, - This.Criterion, - New_Ass, - Id_Used); + Cr.Tasks.Insertions.Greedy + (A, + Pending, + Costs, + This.Criterion, + New_Ass, + Id_Used, + This.Randomize); if Id_Used /= No_Task then A := New_Ass; Remove_From_Pending (Id_Used); diff --git a/agpl-cr-assigner-greedy_exhaustive.ads b/agpl-cr-assigner-greedy_exhaustive.ads index f10389d..13f5faf 100644 --- a/agpl-cr-assigner-greedy_exhaustive.ads +++ b/agpl-cr-assigner-greedy_exhaustive.ads @@ -34,11 +34,14 @@ package Agpl.Cr.Assigner.Greedy_Exhaustive is -- O (T * A * T * T) ~ O (n^4) - pragma Preelaborate; + -- pragma Preelaborate; type Object is new Assigner.Object with record + Randomize : Boolean := False; Criterion : Assignment_Criteria := Criterion_Time_Critical; end record; + -- Random is true, when two agents are tied in a step, the winner is chosen + -- at random. function Assign (This : in Object; diff --git a/agpl-cr-assigner-greedy_minmax_exhaustive.ads b/agpl-cr-assigner-greedy_minmax_exhaustive.ads index e28c7bb..f43fb8c 100644 --- a/agpl-cr-assigner-greedy_minmax_exhaustive.ads +++ b/agpl-cr-assigner-greedy_minmax_exhaustive.ads @@ -34,7 +34,7 @@ package Agpl.Cr.Assigner.Greedy_Minmax_Exhaustive is -- O (T * A * T * T) ~ O (n^4) - pragma Preelaborate; + -- pragma Preelaborate; type Object (Keep_Order : Boolean) is new Assigner.Object with null record; -- If Keep_Order, any tasks in an Agent passed to Agents will be kept in diff --git a/agpl-cr-assignment.adb b/agpl-cr-assignment.adb index ac2d3c9..7347656 100644 --- a/agpl-cr-assignment.adb +++ b/agpl-cr-assignment.adb @@ -33,6 +33,8 @@ with Agpl.Htn.Tasks.Utils; package body Agpl.Cr.Assignment is + package Agent_Lists renames Cr.Agent.Containers.Lists; + package Task_Lists renames Htn.Tasks.Containers.Lists; function To_String is new Conversions.To_Str (Costs); --------- @@ -403,6 +405,61 @@ package body Agpl.Cr.Assignment is Minsum => Get_Cummulative_Cost (This, C)); end Get_Cost; + ------------------------- + -- Get_Cost_Until_Task -- + ------------------------- + + function Get_Cost_Until_Task (This : in Object; + Job : in Agpl.Htn.Tasks.Task_Id; + Criterion : in Assignment_Criteria) + return Agpl.Cr.Costs + is + Agents : constant Agent_Lists.List := This.Get_Agents; + Minmax, + Minsum : Cr.Costs := 0.0; + + ----------------- + -- Check_Agent -- + ----------------- + + procedure Check_Agent (I : Agent_Lists.Cursor) is + Tasks : constant Task_Lists.List := Agent_Lists.Element (I).Get_Tasks; + Acum : Cr.Costs := 0.0; + T : Task_Lists.Cursor := Tasks.First; + use Agent_Lists; + use Task_Lists; + use type Htn.Tasks.Task_Id; + begin + while Task_Lists.Has_Element (T) loop + if T /= Tasks.First then + Acum := Acum + Element (I).Get_Cost (Element (Previous (T)), + Element (T)); + else + Acum := Acum + Element (I).Get_Cost (Element (T)); + end if; + + if Element (T).Get_Id = Job then + Minmax := Acum; + exit; + end if; + Task_Lists.Next (T); + end loop; + end Check_Agent; + + procedure Check_Minsum (I : Agent_Lists.Cursor) is + use Agent_Lists; + begin + Minsum := Minsum + Cr.Costs'Min (Minmax, Element (I).Get_Plan_Cost); + end Check_Minsum; + + begin + Agents.Iterate (Check_Agent'Access); + Agents.Iterate (Check_Minsum'Access); + return Cr.Evaluate (Criterion, + Minmax => Minmax, + Minsum => Minsum); + end Get_Cost_Until_Task; + ------------------------ -- Invalid_Assignment -- ------------------------ diff --git a/agpl-cr-assignment.ads b/agpl-cr-assignment.ads index b7d2ef4..62fc398 100644 --- a/agpl-cr-assignment.ads +++ b/agpl-cr-assignment.ads @@ -99,6 +99,12 @@ package Agpl.Cr.Assignment is Criterion : in Assignment_Criteria) return Costs; -- Uses one of the two previous according to the Criterion + function Get_Cost_Until_Task (This : in Object; + Job : in Agpl.Htn.Tasks.Task_Id; + Criterion : in Assignment_Criteria) + return Agpl.Cr.Costs; + -- Says the cost incurred until finishing + function Invalid_Assignment return Object; -- Returns an invalid assignment. diff --git a/agpl-cr-plan_assigner-greedy1.ads b/agpl-cr-plan_assigner-greedy1.ads index bb5a564..2bca19a 100644 --- a/agpl-cr-plan_assigner-greedy1.ads +++ b/agpl-cr-plan_assigner-greedy1.ads @@ -29,7 +29,7 @@ package Agpl.Cr.Plan_Assigner.Greedy1 is - pragma Preelaborate; + -- pragma Preelaborate; Log_Section : constant String := "agpl.cr.plan_assigner.greedy1"; diff --git a/agpl-cr-tasks-insertions.adb b/agpl-cr-tasks-insertions.adb index bad0354..15935e2 100644 --- a/agpl-cr-tasks-insertions.adb +++ b/agpl-cr-tasks-insertions.adb @@ -1,6 +1,8 @@ with Agpl.Cr.Agent.Containers; with Agpl.Cr.Agent.Utils; use Agpl.Cr.Agent.Utils; +with Agpl.Dynamic_Vector; with Agpl.Htn.Tasks.Utils; +with Agpl.Random; -- with Agpl.Text_Io; use Agpl.Text_Io; package body Agpl.Cr.Tasks.Insertions is @@ -298,12 +300,17 @@ package body Agpl.Cr.Tasks.Insertions is Costs : in Cost_Matrix.Object; Criterion : in Assignment_Criteria; New_Ass : out Assignment.Object; - Success : out Boolean) + Success : out Boolean; + Random : in Boolean := False) is Agents : constant Agent.Containers.Lists.List := Ass.Get_Agents; - Best_Agent : Agent.Handle.Object; - Best_Cost : Cr.Costs := Infinite; + package Candidate_Vectors is + new Dynamic_Vector (Cr.Agent.Handle.Object); + + Candids : Candidate_Vectors.Object (First => 1); + + Best_Cost : Cr.Costs := Cr.Infinite; procedure Check_Agent (I : in Cr.Agent.Containers.Lists.Cursor) is New_Agent : Cr.Agent.Handle.Object; @@ -330,9 +337,12 @@ package body Agpl.Cr.Tasks.Insertions is Minmax => New_Total, Minsum => New_Delta); - if New_Cost < Best_Cost then - Best_Cost := New_Cost; - Best_Agent := New_Agent; + if New_Cost < Cr.Infinite and then New_Cost = Best_Cost then + Candids.Append (New_Agent); + elsif New_Cost < Best_Cost then + Best_Cost := New_Cost; + Candids.Clear; + Candids.Append (New_Agent); end if; end if; end Check_Agent; @@ -341,10 +351,16 @@ package body Agpl.Cr.Tasks.Insertions is Agent.Containers.Lists.Iterate (Agents, Check_Agent'Access); - if Best_Agent.Is_Valid then + if not Candids.Is_Empty then Success := True; - New_Ass.Set_Agent (Best_Agent.Get); --- Put_Line ("Assigned to " & Best_Agent.Get.Get_Name); + if Random then + New_Ass.Set_Agent + (Candids.Vector + (Agpl.Random.Get_Integer + (Candids.First, Candids.Last)).Get); + else + New_Ass.Set_Agent (Candids.Vector (Candids.First).Get); + end if; else Success := False; end if; @@ -359,7 +375,8 @@ package body Agpl.Cr.Tasks.Insertions is Costs : in Cost_Matrix.Object; Criterion : in Assignment_Criteria; New_Ass : out Assignment.Object; - Inserted : out Htn.Tasks.Task_Id) + Inserted : out Htn.Tasks.Task_Id; + Random : in Boolean := False) is Pending : constant Htn.Tasks.Containers.Vectors.Vector := Htn.Tasks.Utils.To_Vector (Tasks); @@ -381,7 +398,8 @@ package body Agpl.Cr.Tasks.Insertions is Costs, Criterion, Temp_Ass, - Partial_Success); + Partial_Success, + Random); if Partial_Success then Temp_Cost := Temp_Ass.Get_Cost (Costs, Criterion); if Temp_Cost < Best_Cost then diff --git a/agpl-cr-tasks-insertions.ads b/agpl-cr-tasks-insertions.ads index b0f3db9..110011b 100644 --- a/agpl-cr-tasks-insertions.ads +++ b/agpl-cr-tasks-insertions.ads @@ -37,7 +37,7 @@ use Agpl; package Agpl.Cr.Tasks.Insertions is - pragma Preelaborate; + -- pragma Preelaborate; type Insertion_Procedures is access procedure (A : in Agent.Object'Class; @@ -101,19 +101,23 @@ package Agpl.Cr.Tasks.Insertions is Costs : in Cost_Matrix.Object; Criterion : in Assignment_Criteria; New_Ass : out Assignment.Object; - Success : out Boolean); + Success : out Boolean; + Random : in Boolean := False); -- Insert a task in the best place of the best agent of an assignment -- The results are given in New_Ass, with Success true. + -- If random, a random agent is chosen on tie. If not, the first one wins procedure Greedy (Ass : in Assignment.Object; Tasks : in Htn.Tasks.Containers.Lists.List; Costs : in Cost_Matrix.Object; Criterion : in Assignment_Criteria; New_Ass : out Assignment.Object; - Inserted : out Htn.Tasks.Task_Id); + Inserted : out Htn.Tasks.Task_Id; + Random : in Boolean := False); -- Insert the best task of the list in the best agent. -- Just *one* task is inserted. -- Inserted can be No_Task if failure. + -- If random, a random agent is chosen on tie. If not, the first one wins procedure Greedy_Tail (Agent : in Cr.Agent.Object'Class; Tasks : in Htn.Tasks.Containers.Lists.List; diff --git a/agpl-gdk/agpl-gdk-managed.adb b/agpl-gdk/agpl-gdk-managed.adb index f012b7a..c5fdd64 100644 --- a/agpl-gdk/agpl-gdk-managed.adb +++ b/agpl-gdk/agpl-gdk-managed.adb @@ -1,23 +1,21 @@ with Agpl.Trace; use Agpl.Trace; with Gtk.Main; pragma Elaborate_All (Gtk.Main); +with Gtk.Widget; use Gtk.Widget; +with Gtk.Window; use Gtk.Window; -- with Ada.Tags; use Ada.Tags; - with Ada.Text_Io; use Ada.Text_Io; +-- with Ada.Text_Io; use Ada.Text_Io; package body Agpl.Gdk.Managed is - Started : Boolean := False; + use Widget_List; task Gtk_Task is - entry Start; - entry Execute (This : in out Gtk_Code'Class); -- Dispatch on This.Execute inside the Gtk thread. - entry Shutdown; - end Gtk_Task; -------------------- @@ -26,11 +24,7 @@ package body Agpl.Gdk.Managed is procedure Execute_In_Gtk (This : in out Gtk_Code'Class) is begin - if not Started then - raise Program_Error; - else - Gtk_Task.Execute (This); - end if; + Gtk_Task.Execute (This); end Execute_In_Gtk; ----------- @@ -39,8 +33,7 @@ package body Agpl.Gdk.Managed is procedure Start is begin - Gtk_Task.Start; - Started := True; + null; end Start; -------------- @@ -49,7 +42,7 @@ package body Agpl.Gdk.Managed is procedure Shutdown is begin - Gtk_Task.Shutdown; + null; end Shutdown; -------------- @@ -57,44 +50,51 @@ package body Agpl.Gdk.Managed is -------------- task body Gtk_Task is - Done : Boolean := False; + + function Num_Windows return Natural is + begin + return Integer'Max (Integer (Length (List_Toplevels)) - 1, 0); + end Num_Windows; + begin - select - accept Start; - or - accept Shutdown; - Done := True; - or - terminate; - end select; - - if not Done then - Gtk.Main.Init; - end if; - - while not Done loop + Gtk.Main.Init; + + loop begin - -- Execute codes - select - accept Execute (This : in out Gtk_Code'Class) do - select - delay 5.0; - Log ("Gtk_Task: Aborted managed code (too busy)", Warning); - then abort - Managed.Execute (This); - end select; - exception - when E : others => - Log ("Gtk_Task: In managed code: " & Report (E), Error); - end Execute; - or - accept Shutdown; - Done := True; - -- Gtk.Main.Main_Quit; - -- No need to leave, since we're not in a blocking loop. - or - delay 0.01; - end select; + if Num_Windows = 0 then + -- Execute codes + select + accept Execute (This : in out Gtk_Code'Class) do + select + delay 5.0; + Log ("Gtk_Task: Aborted managed code (too busy)", Warning); + then abort + Managed.Execute (This); + end select; + exception + when E : others => + Log ("Gtk_Task: In managed code: " & Report (E), Error); + end Execute; + or + terminate; + end select; + else + select + accept Execute (This : in out Gtk_Code'Class) do + select + delay 5.0; + Log ("Gtk_Task: Aborted managed code (too busy)", Warning); + then abort + Managed.Execute (This); + end select; + exception + when E : others => + Log ("Gtk_Task: In managed code: " & Report (E), Error); + end Execute; + or + delay 0.01; + end select; + end if; -- Process events declare diff --git a/agpl-gdk/agpl-gdk-managed.ads b/agpl-gdk/agpl-gdk-managed.ads index 8d9c0d5..04ca05f 100644 --- a/agpl-gdk/agpl-gdk-managed.ads +++ b/agpl-gdk/agpl-gdk-managed.ads @@ -40,14 +40,13 @@ package Agpl.Gdk.Managed is -- decoupled from other code flown. procedure Start; - -- You must explicitely start the management, since this library can be - -- included even if you don't plan to use it... + -- Deprecated. No effect. procedure Execute (This : in out Gtk_Code) is abstract; -- Override this with the code required. procedure Shutdown; - -- Call this to kill the Gtk thread. + -- Deprecated. No effect. private diff --git a/agpl-graphs-bellman_ford.adb b/agpl-graphs-bellman_ford.adb index 20d48b6..9a6e1e0 100644 --- a/agpl-graphs-bellman_ford.adb +++ b/agpl-graphs-bellman_ford.adb @@ -175,7 +175,7 @@ package body Agpl.Graphs.Bellman_Ford is return This.Costs.Get; end if; - Put_Line ("Computing graph costs..."); + -- Put_Line ("Computing graph costs..."); for I in Result.First_Row .. Result.Last_Row loop declare Row : constant Cost_Array := Costs_From_Source (This, I); @@ -319,4 +319,36 @@ package body Agpl.Graphs.Bellman_Ford is end; end Test_Package; + ------------------ + -- Is_Connected -- + ------------------ + + function Is_Connected (This : in Graph) return Boolean is + C : constant Cost_Matrix := This.Get_Costs; + begin + for Row in C.First_Row .. C.Last_Row loop + for Col in C.First_Col .. C.Last_Col loop + if C.Get (Row, Col) > 1_000_000_000 then + Put_Line ("Too big cost:" & C.Get (Row, Col)'Img); + return False; + end if; + end loop; + end loop; + + return True; + end Is_Connected; + + ----------- + -- Clear -- + ----------- + + procedure Clear (This : in out Graph) is + begin + This.C_Edges.Clear; + This.Vertices.Clear; + This.Min_Vertex := Vertex_Index'Last; + This.Max_Vertex := Vertex_Index'First; + This.Costs.Clear; + end Clear; + end Agpl.Graphs.Bellman_Ford; diff --git a/agpl-graphs-bellman_ford.ads b/agpl-graphs-bellman_ford.ads index 5fb4247..e6741f7 100644 --- a/agpl-graphs-bellman_ford.ads +++ b/agpl-graphs-bellman_ford.ads @@ -80,8 +80,13 @@ package Agpl.Graphs.Bellman_Ford is function Max_Vertex (This : in Graph) return Vertex_Index; + function Is_Connected (This : in Graph) return Boolean; + -- Says if the graph has a single connex component. + + procedure Clear (This : in out Graph); + procedure Test_Package; -- Run a simple sanity check. - -- Will raise Program_Error if bad (!) + -- Will raise Program_Error if bad (!) private diff --git a/agpl-random.adb b/agpl-random.adb index f08d3bf..0a126b3 100644 --- a/agpl-random.adb +++ b/agpl-random.adb @@ -31,6 +31,15 @@ package body Agpl.Random is return Discrete'Val (Get_Integer (Min, Max)); end Uniform_Discrete; + --------------- + -- Get_Float -- + --------------- + + function Get_Float (Min, Max : in Float) return Float is + begin + return Uniform * (Max - Min) + Min; + end Get_Float; + ----------------- -- Get_Integer -- ----------------- diff --git a/agpl-random.ads b/agpl-random.ads index 9492a11..a21bdca 100644 --- a/agpl-random.ads +++ b/agpl-random.ads @@ -47,6 +47,9 @@ package Agpl.Random is function Uniform return Uniformly_Distributed; -- Quick obtention of a random point in [0.0 .. 1.0] + function Get_Float (Min, Max : in Float) return Float; + -- Get a float in [Min .. Max] + generic type Discrete is (<>); function Uniform_Discrete return Discrete; diff --git a/concorde/agpl-cr-assigner-mtsp_concordefake.adb b/concorde/agpl-cr-assigner-mtsp_concordefake.adb new file mode 100644 index 0000000..fcc38df --- /dev/null +++ b/concorde/agpl-cr-assigner-mtsp_concordefake.adb @@ -0,0 +1,193 @@ +------------------------------------------------------------------------------ +-- AGPL -- +-- -- +-- Copyright (C) 2003 -- +-- A. Mosteo. -- +-- -- +-- Authors: A. Mosteo. (public@mosteo.com) -- +-- -- +-- If you have any questions in regard to this software, please address -- +-- them to the above email. -- +-- -- +-- This program 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 of the License, or (at -- +-- your option) any later version. -- +-- -- +-- This program 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 this library; if not, write to the Free Software Foundation, -- +-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- +------------------------------------------------------------------------------ + +with Agpl.Cr.Agent.Utils; +with Agpl.Cr.Tasks.Starting_Pose; +with Agpl.Htn.Tasks.Containers; +with Agpl.Optimization.Concordefake; +with Agpl.Trace; use Agpl.Trace; + +package body Agpl.Cr.Assigner.MTSP_Concordefake is + + use Agpl.Optimization; + + ------------ + -- Assign -- + ------------ + + function Assign + (This : in Object; + Agents : in Agent.Containers.Lists.List; + Tasks : in Htn.Tasks.Containers.Lists.List; + Costs : in Cr.Cost_Matrix.Object) + return Assignment.Object + is + pragma Unreferenced (This); + Jobs : Htn.Tasks.Containers.Vectors.Vector; + Ag : constant Cr.Agent.Object'Class := Agents.First_Element; + Result : Assignment.Object; + Agvect : Agent.Containers.Vectors.Vector := + Agent.Utils.To_Vector (Agents); + + -------------------- + -- Agent_For_Task -- + -------------------- + + function Agent_For_Task (T : in Htn.Tasks.Object'Class) + return Agent.Object'Class + is + begin + if T in Cr.Tasks.Starting_Pose.Object then + for I in Agvect.First_Index .. Agvect.Last_Index loop + if Agvect.Element (I).Get_Name = + Cr.Tasks.Starting_Pose.Object (T).Get_Name then + return Agvect.Element (I); + end if; + end loop; + raise Program_Error; + else + return Ag; + end if; + end Agent_For_Task; + + begin + -- Create the tasks vector + -- Use a starting task for each agent: + declare + use Cr.Agent.Containers.Lists; + I : Cursor := Agents.First; + begin + while Has_Element (I) loop + Jobs.Append (Cr.Tasks.Starting_Pose.Create (Element (I).Get_Name)); + Next (I); + end loop; + end; + + -- Add the tasks: + declare + use Htn.Tasks.Containers.Lists; + I : Cursor := Tasks.First; + begin + while Has_Element (I) loop + if Element (I) in Cr.Tasks.Starting_Pose.Object then + raise Constraint_Error with "No Starting_Pose tasks allowed"; + end if; + Jobs.Append (Element (I)); + Next (I); + end loop; + end; + + -- Create the concorde things and solve + declare + use Optimization.Concordefake; + Start : Start_Matrix (1 .. Salesmen (Agents.Length)); + C : Optimization.Concordefake.Cost_Matrix := + Cost_Matrices.Create (Cities (Jobs.Length), + Cities (Jobs.Length)); + use Cost_Matrix; + begin + for I in Start'Range loop + Start (I) := Cities (I); + end loop; + + for I in Jobs.First_Index .. Jobs.Last_Index loop + declare + -- Choose the agent for the starting task + -- If is not a Starting_Task, any will do: + Apt_Agent : constant Agent.Object'Class := + Agent_For_Task (Jobs.Element (I)); + begin + for J in Jobs.First_Index .. Jobs.Last_Index loop + if Get_Cost (Costs, + Apt_Agent.Get_Name, + Jobs.Element (I).Get_Id, + Jobs.Element (J).Get_Id) < Infinite + then + C.Set + (Cities (I), + Cities (J), + Concordefake.Costs + (Get_Cost (Costs, + Apt_Agent.Get_Name, + Jobs.Element (I).Get_Id, + Jobs.Element (J).Get_Id))); + else + C.Set (Cities (I), + Cities (J), + Concordefake.Inf); + end if; + end loop; + end; + end loop; + +-- Optimization.Concorde.Print_Problem (C); + + declare + -- Solve + Tour : constant Normal_Tour := + Create (Start, + Solve_Mtsp (Start, + C, + No_Return => True)); + use Cr.Agent.Containers.Lists; + A : Cursor := Agents.First; + begin + -- Reconstruct agents + for I in 1 .. Tour.Last loop + declare + New_Agent : Cr.Agent.Object'Class := Element (A); + begin + Next (A); + -- Set the name of the starting task, I think the tour + -- can be rotated (error somewhere????) + declare + Name : constant String := + Cr.Tasks.Starting_Pose.Object + (Jobs.Element + (Positive (Tour.City (I, 1)))).Get_Name; + begin + if Name /= New_Agent.Get_Name then + Log ("Agent mismatch! " & Name & " should be " & + New_Agent.Get_Name, Error); + raise Constraint_Error; + end if; + end; + + -- Assign tasks, skipping the forced starting pose + for J in 2 .. Tour.Last (I) loop + New_Agent.Add_Task (Jobs.Element + (Positive (Tour.City (I, J)))); + end loop; + Result.set_Agent (New_Agent); + end; + end loop; + end; + end; + + return Result; + end Assign; + +end Agpl.Cr.Assigner.MTSP_Concordefake; diff --git a/concorde/agpl-cr-assigner-mtsp_concordefake.ads b/concorde/agpl-cr-assigner-mtsp_concordefake.ads new file mode 100644 index 0000000..02c412f --- /dev/null +++ b/concorde/agpl-cr-assigner-mtsp_concordefake.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- AGPL -- +-- -- +-- Copyright (C) 2003 -- +-- A. Mosteo. -- +-- -- +-- Authors: A. Mosteo. (public@mosteo.com) -- +-- -- +-- If you have any questions in regard to this software, please address -- +-- them to the above email. -- +-- -- +-- This program 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 of the License, or (at -- +-- your option) any later version. -- +-- -- +-- This program 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 this library; if not, write to the Free Software Foundation, -- +-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- +------------------------------------------------------------------------------ + +with Agpl.Cr.Cost_Matrix; + +package Agpl.Cr.Assigner.MTSP_Concordefake is + + type Object is new Assigner.Object with null record; + + function Assign + (This : in Object; + Agents : in Agent.Containers.Lists.List; + Tasks : in Htn.Tasks.Containers.Lists.List; + Costs : in Cr.Cost_Matrix.Object) + return Assignment.Object; + -- Using the concorde solver. + -- Works only with homogeneous robots, since costs are provided by the + -- first agent in the list. + -- Optimization is always MinSum + -- Tasks *Mustn't* contain starting tasks + +end Agpl.Cr.Assigner.Mtsp_Concordefake; diff --git a/concorde/agpl-optimization-concordefake.adb b/concorde/agpl-optimization-concordefake.adb new file mode 100644 index 0000000..790e7a3 --- /dev/null +++ b/concorde/agpl-optimization-concordefake.adb @@ -0,0 +1,840 @@ +with Agpl.Trace; use Agpl.Trace; + +with Interfaces.C.Strings; +with Ada.Text_IO; use Ada.Text_IO; + +package body Agpl.Optimization.Concordefake is + + use type C.int; + + --------------- + -- Get_Big_M -- + --------------- + -- Compute a M big enough (sum of all other non-inf costs) + function Get_Big_M (Cost : in Cost_Matrix) return Costs is + Big_M : Costs := 0; + begin + for Row in Cost.First_Row .. Cost.Last_Row loop + for Col in Cost.First_Col .. Cost.Last_Col loop + -- exit when Col > Row; -- Fails with asymmetric problems!!! + if Cost.Get (Row, Col) /= Inf and then Cost.Get (Row, Col) > 0 then + pragma Beware ("I'm not sure this is correct, because the ATSP --> TSP transform uses -Big_M in some places. Alors?"); + -- Big_M := Big_M + abs (Cost.Get (Row, Col)); + + Big_M := Costs'Max (Big_M, abs (Cost.Get (Row, Col))); + pragma Atchung ("This is wrong for sure..."); + end if; + end loop; + end loop; + + Log ("Big M is" & Big_M'Img, Debug, Log_Section); + + -- return Big_M; + return Big_M * Costs (Cost.Rows); + pragma Danger ("The above is also suspicious..."); + -- Big_M should be the sum of all costs + -- But when we have negative ones? -> ABS -> Too big + -- Sum only positives --> seems to work, but gives errors in large problems + -- Get the maximum one and make big_M = Max times Rows. Seems to work but + -- be warned!! + end Get_Big_M; + + --------------- + -- Solve_TSP -- + --------------- + + function Solve_TSP + (Start : in Start_Matrix; + Cost : in Cost_Matrix) + return Result_Matrix + is + + type Int_Cost_Array is array + (1 .. C.Int (Cost.Rows * (Cost.Rows + 1) / 2)) of C.int; + pragma Convention (C, Int_Cost_Array); + + type Int_Sol_Array is array + (1 .. C.Int (Cost.Rows)) of C.int; + pragma Convention (C, Int_Sol_Array); + +-- procedure Solve (Err : out C.int; +-- ncount : C.int; +-- costs : in Int_Cost_Array; +-- argc : C.int; +-- argv : in out C.Strings.chars_ptr_array; +-- sol : in out Int_Sol_Array); +-- pragma Import (C, Solve, "solve_tsp_problem"); +-- pragma Import_Valued_Procedure (Solve, "solve_tsp_problem"); + + Min_Cost : Costs := Inf; + New_Cost : Cost_Matrix := Cost; + begin + if Cost.First_Row /= 1 or else Cost.First_Col /= 1 or else + Start'First /= 1 + then + raise Constraint_Error; + end if; + + pragma Assert (Cost.Rows = Cost.Cols); + + -- Print_Problem (Cost); + + -- Check symmetry and get min cost: + for From in Cost.First_Row .. Cost.Last_Row loop + for To in Cost.First_Col .. Cost.Last_Col loop + exit when To > From; + if Cost.Get (From, To) /= Cost.Get (To, From) then + raise Constraint_Error with "TSP is not symmetric"; + end if; + Min_Cost := Costs'Min (Min_Cost, Cost.Get (From, To)); + end loop; + end loop; + + declare + Co : Int_Cost_Array; + I : C.Int := Co'First; + R : C.int; + Sol : Int_Sol_Array; + + -- Argv : C.Strings.chars_ptr_array := (1 .. 1 => C.Strings.Null_Ptr); + Big_M : constant Costs := Get_Big_M (Cost); + begin + -- Assign values to the C matrix, moving them to the optimal range: + -- At the same time, keep new costs in another matrix. + for Row in Cost.First_Row .. Cost.Last_Row loop + for Col in Cost.First_Col .. Cost.First_Col + Row - Cost.First_Row loop + if Cost.Get (Row, Col) = Inf then + Co (I) := C.Int (Big_M - Min_Cost); + else + Co (I) := C.int (Cost.Get (Row, Col) - Min_Cost); + end if; + New_Cost.Set (Row, Col, Costs (Co (I))); + New_Cost.Set (Col, Row, New_Cost.Get (Row, Col)); + I := I + 1; + end loop; + end loop; + + -- Instead of solving, we read from the given file... + -- Solve (R, Sol'Length, Co, 0, Argv, Sol); + declare + F : File_Type; + package Int_Io is new Integer_Io (C.Int); + use Int_Io; + begin + R := 0; + Open (F, Name => +Solution_File, Mode => In_File); + for I in Sol'Range loop + Get (F, Sol (I)); + Put_Line ("Read:" & Sol (I)'Img); + end loop; + Close (F); + end; + + if R /= 0 then + raise No_Solution; + else + -- Create the solution vector, in the appropriate permutation. + declare + Result : Result_Matrix (1 .. 1, 1 .. Sol'Length); + Pos : C.Int := Sol'First; + begin + -- Locate the starting city: + while Cities (Sol (Pos) + 1) /= Start (Start'First) loop + Pos := Pos + 1; + if Pos > Sol'Last then + raise Constraint_Error; -- Shouldn't happen + end if; + end loop; + + for I in Sol'Range loop + Result (1, + Stages (I)) := + Cities (Sol (Pos) + 1); -- Add one because we're 1-based + + Pos := Pos + 1; + if Pos > Sol'Last then + Pos := Sol'First; + end if; + end loop; + +-- Put_Line ("Raw solution:"); +-- for I in Sol'Range loop +-- Put (Integer 'Image(Integer (Sol (I) + 1))); +-- end loop; +-- New_Line; + +-- Put_Line ("TSP solution:"); +-- Print_Solution (New_Cost, Start, Result, No_Return => False); + + return Result; + end; + end if; + end; + end Solve_TSP; + + ---------------- + -- Solve_ATSP -- + ---------------- + + function Solve_ATSP (Start : in Start_Matrix; + Cost : in Cost_Matrix) return Result_Matrix + is + Big_M : constant Costs := Get_Big_M (Cost); -- Inf for practical purposes + New_Cost : Cost_Matrix := + Create (First_Row => Cost.First_Row, + Last_Row => Cost.Last_Row * 2, + First_Col => Cost.First_Row, + Last_Col => Cost.Last_Row * 2, + Default => Inf); + -- New transformed cost matrix + + N : constant Cities := Cities (Cost.Rows); -- Number of nodes + begin + if Cost.First_Row /= 1 or else Cost.First_Col /= 1 or else Start'First /= 1 then + raise Constraint_Error; + end if; + pragma Assert (Cost.Rows = Cost.Cols); + + -- Check if it's symmetric... + declare + Asym : Boolean := False; + begin + Outer: + for R in Cost.First_Row .. Cost.Last_Row loop + for C in Cost.First_Col .. Cost.Last_Col loop + if Cost.Get (R, C) /= Cost.Get (C, R) then + Asym := True; + exit Outer; + end if; + end loop; + end loop Outer; + if not Asym then + Log ("Problem is symmetric, skipping transformation...", + Debug, Log_Section); + return Solve_TSP (Start, Cost); + end if; + end; + + -- Print_Problem (Cost); + + for I in Cost.First_Row .. Cost.Last_Row loop + New_Cost.Set (I + N, I, -Big_M); + New_Cost.Set (I, I + N, -Big_M); -- For symmetry, but innecesary. + -- This should be Big_M according to Reinelt. + end loop; + + -- WARNING!! HERE WE ARE EXPLICITELY REMOVING LOOP COSTS. + -- I THINK THIS DOESN'T AFFECT ANYTHING, BUT... + for I in Cost.First_Row .. Cost.Last_Row loop + for J in Cost.First_Col .. Cost.Last_Col loop + if I /= J and then Cost.Get (I, J) /= Inf then + New_Cost.Set (I + N, J, Cost.Get (I, J)); + New_Cost.Set (J, I + N, Cost.Get (I, J)); -- For symmetry, but innecesary. + end if; + end loop; + end loop; + + -- Print_Problem (New_Cost); + + -- Get result and undo transformation: + declare + Sol : constant Result_Matrix := Solve_TSP (Start, New_Cost); + Real_Sol : Result_Matrix (1 .. 1, 1 .. Stages (N)); + Pos : Stages := Real_Sol'First (2); + begin + for I in Sol'Range (2) loop + if Sol (Sol'First, I) <= N then + Real_Sol (Real_Sol'First, Pos) := Sol (Sol'First, I); + Pos := Pos + 1; + end if; + end loop; + + pragma Assert (Pos = Real_Sol'Last (2) + 1); + + -- Get the proper order in the symmetric solution: + declare + First_Sol_Cost : constant Costs := + Get_Total_Cost (Cost, Real_Sol, False); + Second_Sol_Cost : Costs; + Reverse_Sol : Result_Matrix (Real_Sol'Range (1), + Real_Sol'Range (2)); + Pos : Stages := Reverse_Sol'First (2); + begin + -- Print_Solution (Cost, Start, Real_Sol, True); + + Reverse_Sol (Reverse_Sol'First, Pos) := Real_Sol (Real_Sol'First, 1); + Pos := Pos + 1; -- This is to keep the first city ordering. + + for I in reverse Real_Sol'Range (2) loop + exit when I = Real_Sol'First (2); -- Already assigned before + Reverse_Sol (Reverse_Sol'First, Pos) := Real_Sol (Real_Sol'First, I); + Pos := Pos + 1; + end loop; + pragma Assert (Pos = Reverse_Sol'Last (2) + 1); + + -- Return the proper asymmetric solution: + Second_Sol_Cost := Get_Total_Cost (Cost, Reverse_Sol, False); + if Costs'Min (First_Sol_Cost, Second_Sol_Cost) > Big_M then + Log ("Straight sol cost:" & First_Sol_Cost'Img, Error); + Log ("Reverse sol cost:" & Second_Sol_Cost'Img, Error); + Log ("Big_M:" & Big_M'Img, Error); + raise No_Solution; -- Forbidden link used! + end if; + + -- Check that the costs in the solutions match!! + pragma Omitted_Check_By_Fakeness; +-- if Get_Total_Cost (New_Cost, Sol, No_Return => False) + +-- (Big_M * Costs (N)) /= +-- Costs'Min (First_Sol_Cost, Second_Sol_Cost) then +-- raise Program_Error; -- Solution isn't optimal, some error happened. +-- end if; + + Log ("Cost TSP :" & Get_Total_Cost (New_Cost, Sol, False)'Img, + Debug, Log_Section); + Log ("Cost ATSP: " & Costs'Min (First_Sol_Cost, Second_Sol_Cost)'Img, + Debug, Log_Section); + + if Second_Sol_Cost < First_Sol_Cost then +-- Put_Line ("ATSP solution"); +-- for I in Reverse_Sol'Range (2) loop +-- Put (Reverse_Sol (1, I)'Img); +-- end loop; +-- New_Line; + return Reverse_Sol; + else +-- Put_Line ("ATSP solution"); +-- for I in Real_Sol'Range (2) loop +-- Put (Real_Sol (1, I)'Img); +-- end loop; +-- New_Line; + return Real_Sol; + end if; + end; + end; + end Solve_ATSP; + + ---------------- + -- Solve_MTSP -- + ---------------- + + function Solve_MTSP (Start : in Start_Matrix; + Cost : in Cost_Matrix; + No_Return : in Boolean := False) return Result_Matrix + is + N : constant Cities := Cities (Cost.Rows); -- Number of nodes + M : constant Salesmen := Start'Length; -- Number of travelers + + New_Cost : Cost_Matrix := + Create (First_Row => Cost.First_Row, + Last_Row => Cost.First_Row + N + Cities (M) - 1, + First_Col => Cost.First_Col, + Last_Col => Cost.First_Col + N + Cities (M) - 1, + Default => Inf); + begin + if Cost.First_Row /= 1 or else Cost.First_Col /= 1 or else Start'First /= 1 then + raise Constraint_Error; + end if; + pragma Assert (Cost.Rows = Cost.Cols); + + -- If just a salesman, don't even do the transform: + if Start'Length = 1 and then not No_Return then + Log ("Problem is single salesman, skipping transformation...", + Debug, Log_Section); + return Solve_ATSP (Start, Cost); -- ----- EARLY EXIT POINT + end if; + + -- If No_Return, special case: + if No_Return then + return Solve_MTSP_No_Return (Start, Cost); + end if; + + -- Keep original costs: + for Row in Cost.First_Row .. Cost.Last_Row loop + for Col in Cost.First_Col .. Cost.Last_Col loop + New_Cost.Set (Row, Col, Cost.Get (Row, Col)); + end loop; + end loop; + + -- Artificial cities costs + for Row in New_Cost.First_Row .. Cost.Last_Row loop + for Col in New_Cost.First_Col .. Cost.Last_Col loop + if Row > Cost.Last_Row and then Col = Row + 1 then + -- From artificial i to i + 1 + -- New_Cost.Get (Row, Col) := 0; + null; -- I deviate here from Helmberg suggestion; I prefer that + -- each traveller explicitely visits its own city. + elsif Row = New_Cost.Last_Row and then Col = Cost.Last_Col + 1 then + -- From artificial i_m to i + -- New_Cost.Get (Row, Col) := 0; + null; -- I deviate here from Helmberg suggestion; I prefer that + -- each traveller explicitely visits its own city. + elsif Row > Cost.Last_Row and then Col <= Cost.Last_Col then + -- From artificial to real + declare + Salesman : constant Salesmen range 1 .. M := Salesmen (Row - N); + Starting : constant Cities range 1 .. N := Start (Start'First + Salesman - 1); + begin + if Col = Starting then + New_Cost.Set (Row, Col, 0); -- Already there + else + New_Cost.Set (Row, Col, Cost.Get (Starting, Col)); + end if; + end; + elsif Row <= Cost.Last_Row and then Col > Cost.Last_Col then + -- From real to artificial + declare + Salesman : Salesmen range 1 .. M := Salesmen (Col - N); + Starting : Cities range 1 .. N; + begin + -- Displace salesman index, since now false city i + 1 correspond to salesman i + if Salesman = 1 then + Salesman := M; + else + Salesman := Salesman - 1; + end if; + -- And set the starting city for this salesman: + Starting := Start (Start'First + Salesman - 1); + + if Row = Starting then + New_Cost.Set (Row, Col, 0); -- Already there + else + New_Cost.Set (Row, Col, Cost.Get (Row, Starting)); + end if; + end; + elsif Row > Cost.Last_Row and then Col > Cost.Last_Col then + -- From artificial to artificial: already at Infinite cost. + null; + elsif Row <= Cost.Last_Row and then Col <= Cost.Last_Col then + -- From real to real, already assigned before + null; + else + raise Program_Error; -- Something have we forgotten! + end if; + end loop; + end loop; + + -- DEBUG: cost for transformed problem: + -- Put_Line ("----------------------------"); + -- Print_Problem (New_Cost); + -- Put_Line ("----------------------------"); + + -- Get ATSP solution: + declare + ATSP_Sol : constant Result_Matrix := Solve_ATSP ((1 .. 1 => N + 1), + New_Cost); + Artif : Cities range 1 .. N + Cities (M); + begin + -- We have now a solution that shall have N + 1, N + 2 .. N + M cities + -- visited in that order. If not, something is wrong! + -- COULD BE TRUE WHEN JUST 2 SALESMEN?? SHOULD WE ORDER IT IN THAT CASE!! + -- Verification: + Artif := ATSP_Sol (ATSP_Sol'First, ATSP_Sol'First (2)); + pragma Assert (Artif = N + 1); + for I in ATSP_Sol'First (2) + 1 .. ATSP_Sol'Last (2) loop + if ATSP_Sol (ATSP_Sol'First, I) > N then + if ATSP_Sol (ATSP_Sol'First, I) /= Artif + 1 then + raise Program_Error; + else + Artif := Artif + 1; + end if; + end if; + end loop; + + -- DEBUG: ATSP transformation result: + Print_Solution (New_Cost, (1 .. 1 => N + 1), ATSP_Sol, No_Return); + + -- Get the MTSP solution: + declare + Salesman : Salesmen range 1 .. M; + Sol : Result_Matrix (1 .. M, 1 .. Stages (N)); + Pos : Stages range Sol'First (2) .. Sol'Last (2) + 1; + begin + for I in ATSP_Sol'Range (2) loop + -- New traveller? + if ATSP_Sol (ATSP_Sol'First, I) > N then + + -- Prepare everything for a new salesman: + Salesman := Salesmen (ATSP_Sol (ATSP_Sol'First, I) - N); + Pos := Sol'First (2); + + -- Fill its solution with its starting/final city: + for J in Sol'Range (2) loop + Sol (Salesman, J) := Start (Salesman); + end loop; + + else + -- Regular city, add to current salesman tour! + Sol (Salesman, Pos) := ATSP_Sol (ATSP_Sol'First, I); + Pos := Pos + 1; + end if; + end loop; + + return Sol; + end; + end; + end Solve_MTSP; + + -------------------------- + -- Solve_MTSP_No_Return -- + -------------------------- + -- When No_Return, the transformation is other: we no longer need the + -- "signaling start" false cities. We simply set all the return to a base + -- costs to zero, and when a new base is visited this is the start of the + -- agent placed there. + function Solve_MTSP_No_Return (Start : in Start_Matrix; + Cost : in Cost_Matrix) return Result_Matrix + is + Mod_Cost : Cost_Matrix := Cost; + + ------------- + -- Is_Base -- + ------------- + + function Is_Base (X : in Cities) return Boolean is + begin + for I in Start'Range loop + if Start (I) = X then + return True; + end if; + end loop; + return False; + end Is_Base; + + ----------------------- + -- Salesman_For_Base -- + ----------------------- + + function Salesman_For_Base (X : in Cities) return Salesmen is + begin + pragma Assert (Is_Base (X), "No base of any salesman"); + for I in Start'Range loop + if Start (I) = X then + return I; + end if; + end loop; + + raise Program_Error; + end Salesman_For_Base; + + -- Big_M : constant Costs := Get_Big_M (Cost); + begin + pragma Assert (Mod_Cost.First_Row = 1 and then Mod_Cost.First_Col = 1); + Log ("Doing No_Return transformation...", Debug, Log_Section); + + -- Nullify costs of returning to base + for From in Mod_Cost.First_Row .. Cost.Last_Row loop + for To in Mod_Cost.First_Col .. Cost.Last_Col loop + if Is_Base (To) then + Mod_Cost.Set (From, To, 0); + end if; + end loop; + end loop; + + -- Print_Problem (Mod_Cost); + + declare + aSol : constant Result_Matrix := + Solve_ATSP ((1 => Start (Start'First)), Mod_Cost); + Sol : Result_Matrix (1 .. Start'Length, 1 .. Stages (Cost.Rows)); + + Salesman : Salesmen := Sol'First; + Stage : Stages := Sol'First (2) + 1; + begin + -- Fill solution with starting/final cities: + for Man in Sol'Range loop + for J in Sol'Range (2) loop + Sol (Man, J) := Start (Man); + end loop; + end loop; + + -- Unfold transformation + for Pos in aSol'Range (2)loop + if Is_Base (aSol (1, Pos)) then + -- Switch to Salesman starting there: + Salesman := Salesman_For_Base (aSol (1, Pos)); + Stage := Sol'First (2) + 1; + else + -- Assign this city to current salesman: + Sol (Salesman, Stage) := aSol (1, Pos); + Stage := Stage + 1; + end if; + end loop; + + return Sol; + end; + end Solve_MTSP_No_Return; + + -------------------- + -- Get_Total_Cost -- + -------------------- + + function Get_Total_Cost + (Cost : in Cost_Matrix; + Sol : in Result_Matrix; + No_Return : in Boolean) + return Costs + is + Total : Costs := 0; + begin + if Sol'Length = 1 and then + Normalize_Tour (Sol (1, 1), Sol)'Length (2) = Sol'Length (2) then + -- It is a proper normalized single solution: + + for City in Sol'First (2) + 1 .. Sol'Last (2) loop + begin + Total := Total + Cost.Get (Sol (1, City - 1), + Sol (1, City)); + exception + when Constraint_Error => + return Inf; + end; + end loop; + + if not No_Return then + begin + Total := Total + Cost.Get (Sol (1, Sol'Last (2)), + Sol (1, Sol'First (2))); + exception + when Constraint_Error => + return Inf; + end; + end if; + + else + -- Compound or unnormalized tour: + for Man in Sol'Range loop + Total := Total + Get_Total_Cost (Cost, + Normalize_Tour (Sol (Man, 1), + Sol), + No_Return); + end loop; + end if; + + return Total; + end Get_Total_Cost; + + ---------------------- + -- Get_Max_Min_Cost -- + ---------------------- + + function Get_Min_Max_Cost + (Cost : in Cost_Matrix; + Sol : in Result_Matrix; + No_Return : in Boolean) + return Costs + is + Worst : Costs := Costs'First; + begin + for Salesman in Sol'Range (1) loop + declare + -- Construct a solution involving just a salesman + Single_Sol : Result_Matrix (1 .. 1, Sol'Range (2)); + begin + for I in Sol'Range (2) loop + Single_Sol (1, I) := Sol (Salesman, I); + end loop; + Worst := Costs'Max (Worst, Get_Total_Cost (Cost, Single_Sol, No_Return)); + end; + end loop; + + return Worst; + end Get_Min_Max_Cost; + + -------------------- + -- Normalize_Tour -- + -------------------- + + function Normalize_Tour (Start : in Cities; + Sol : in Result_Matrix) return Result_Matrix + is + Man : Salesmen; + Pos : Stages; + Ok : Boolean := False; + begin + -- Locate which salesman is the one with that starting city: + -- And where his starting city is: + for Men in Sol'Range loop + if Sol (Men, Sol'First (2)) = Start or else Sol (Men, Sol'Last (2)) = Start then + Man := Men; + Ok := True; + exit; + end if; + end loop; + + if not Ok then + raise Program_Error; + end if; + + if Sol (Man, Sol'First (2)) = Start then + Pos := Sol'First (2) + 1; + else + Pos := Sol'First (2); + end if; + + declare + New_Sol : Result_Matrix (1 .. 1, 1 .. Sol'Length (2) + 1); + Last : Stages; + begin + for I in New_Sol'Range (2) loop + New_Sol (1, I) := Start; + end loop; + for Stage in New_Sol'First (2) + 1 .. New_Sol'Last (2) - 1 loop + exit when (Sol (Man, Pos) = Start and then not + (Pos < Sol'Last (2) and then Sol (Man, Pos + 1) /= Start)) + or else Pos > Sol'Last (2); + New_Sol (1, Stage) := Sol (Man, Pos); + Pos := Pos + 1; + end loop; + + for I in New_Sol'First (2) + 1 .. New_Sol'Last (2) loop + if New_Sol (1, I) = Start then + Last := I; + exit; + end if; + end loop; + + declare + Good_Sol : Result_Matrix (1 .. 1, 1 .. Last - 1); + begin + for J in Good_Sol'Range (2) loop + Good_Sol (1, J) := New_Sol (1, J); + end loop; + return Good_Sol; + end; + end; + end Normalize_Tour; + + ------------------- + -- Print_Problem -- + ------------------- + + procedure Print_Problem (Cost : in Cost_Matrix) + is + package Int_Io is new Integer_Io (Costs); + use Int_Io; + begin + Int_Io.Default_Width := 5; + New_Line; + for I in Cost.First_Row .. Cost.Last_Row loop + for J in Cost.First_Col .. Cost.Last_Col loop + if Cost.Get (I, J) = Inf then + Put (" XXX"); + else + Put (Cost.Get (I, J)); + end if; + end loop; + New_Line; + end loop; + end Print_Problem; + + -------------------- + -- Print_Solution -- + -------------------- + + procedure Print_Solution (Cost : in Cost_Matrix; + Start: in Start_Matrix; + Sol : in Result_Matrix; + No_Return : in Boolean) + is + begin + for Salesman in Sol'Range (1) loop + Put_Line ("Salesman" & Salesman'Img); + declare + Tour : constant Result_Matrix := Normalize_Tour (Start (Salesman), Sol); + begin + for City in Tour'Range (2) loop + Put (Tour (1, City)'Img); + end loop; + Put_Line (" (" & Get_Total_Cost (Cost, Tour, No_Return)'Img & ")"); + end; + end loop; + + Put_Line ("Total cost: " & Get_Total_Cost (Cost, Sol, No_Return)'Img); + Put_Line ("Min-max cost: " & Get_Min_Max_Cost (Cost, Sol, No_Return)'Img); + end Print_Solution; + + ------------ + -- Create -- + ------------ + + function Create (Num_Men : in Salesmen) return Normal_Tour is + Empty : City_Vector; + Result : Normal_Tour; + begin + for I in 1 .. Num_Men loop + Result.Tours.Append (Empty); + end loop; + + return Result; + end Create; + + ------------ + -- Create -- + ------------ + + function Create (Start : in Start_Matrix; + Sol : in Result_Matrix) return Normal_Tour + is + Result : Normal_Tour; + begin + for I in Start'Range loop + declare + Tour : constant Result_Matrix := Normalize_Tour (Start (I), Sol); + Vec : City_Vector; + begin + for J in Tour'Range (2) loop + Vec.Append (Tour (Tour'First, J)); + end loop; + Result.Tours.Append (Vec); + end; + end loop; + + return Result; + end Create; + + ----------------- + -- Append_City -- + ----------------- + + procedure Append_City (This : in out Normal_Tour; + Man : in Salesmen; + City : in Cities) + is + begin + This.Tours.Vector (Integer (Man)).Append (City); + end Append_City; + + ---------- + -- City -- + ---------- + + function City (This : in Normal_Tour; + Man : in Salesmen; + Stage : in Stages) return Cities + is + begin + return This.Tours.Vector (Integer (Man)).Vector (Integer (Stage)); + end City; + + ---------- + -- Last -- + ---------- + + function Last (This : in Normal_Tour) return Salesmen + is + begin + return Salesmen (This.Tours.Last); + end Last; + + ---------- + -- Last -- + ---------- + + function Last (This : in Normal_Tour; + Man : in Salesmen) return Stages + is + begin + return Stages (This.Tours.Vector (Integer (Man)).Last); + end Last; + +end Agpl.Optimization.Concordefake; diff --git a/concorde/agpl-optimization-concordefake.ads b/concorde/agpl-optimization-concordefake.ads new file mode 100644 index 0000000..c41e036 --- /dev/null +++ b/concorde/agpl-optimization-concordefake.ads @@ -0,0 +1,166 @@ +------------------------------------------------------------------------------ +-- AGPL -- +-- -- +-- Copyright (C) 2003 -- +-- A. Mosteo. -- +-- -- +-- Authors: A. Mosteo. (public@mosteo.com) -- +-- -- +-- If you have any questions in regard to this software, please address -- +-- them to the above email. -- +-- -- +-- This program 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 of the License, or (at -- +-- your option) any later version. -- +-- -- +-- This program 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 this library; if not, write to the Free Software Foundation, -- +-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- +------------------------------------------------------------------------------ + +-- Binding to the C concorde TSP solver. +-- With transformations ATSP -> TSP, mATSP -> TSP + +with Agpl.Dynamic_Vector; +with Agpl.Generic_Dense_Matrix; +with Agpl.Types.Ustrings; use Agpl.Types.Ustrings; + +with Interfaces.C; + +-- Attempt at recovering the solution from a concorde .sol file + +package Agpl.Optimization.Concordefake is + + pragma Elaborate_Body; + + Solution_File : Ustring; + -- Fill this in with the desired file to attempt!! + + package C renames Interfaces.C; + + Log_Section : constant String := "concorde"; + + No_Solution : exception; + + type Costs is new C.int; -- Costs must be given as integers. + + Inf : constant Costs; + -- Use this value for invalid routes. + + type Salesmen is new Positive; + type Cities is new Positive; + type Stages is new Positive; + + package Cost_Matrices is new Generic_Dense_Matrix (Cities, Costs); + subtype Cost_Matrix is Cost_Matrices.Matrix; use Cost_Matrices; + -- Indexes are from-city, to-city + -- For symmetric problems, just the lower half of the matrix must be filled. + + type Result_Matrix is array (Salesmen range <>, + Stages range <>) of Cities; + -- First index is the salesman index. + -- Second index is the stage index. + -- The value says which city is visited in each stage. + -- When no more moves, the same city will be reported. + + type Start_Matrix is array (Salesmen range <>) of Cities; + -- Index is the salesman index. + -- Value is in which city it starts. + + function Solve_TSP (Start : in Start_Matrix; + Cost : in Cost_Matrix) return Result_Matrix; + -- May raise No_Solution. + -- Just the lower half of Cost will be considered. + + function Solve_ATSP (Start : in Start_Matrix; + Cost : in Cost_Matrix) return Result_Matrix; + -- May raise No_Solution. + -- Do the standard transformation ATSP -> TSP and solve. + + function Solve_MTSP (Start : in Start_Matrix; + Cost : in Cost_Matrix; + No_Return : in Boolean := False) return Result_Matrix; + -- May raise No_Solution; + -- Do the Helmberg MTSP -> ATSP transformation and solve. + -- If No_Return, cost of each traveler coming to base isn't used during solving. + -- Bear in mind that each agent has to have its own starting city (no single depot). + + function Get_Total_Cost (Cost : in Cost_Matrix; + Sol : in Result_Matrix; + No_Return : in Boolean) return Costs; + -- Total cost incurred by all salesmen. + + function Get_Min_Max_Cost (Cost : in Cost_Matrix; + Sol : in Result_Matrix; + No_Return : in Boolean) return Costs; + -- Cost of the worst salesman. + + function Normalize_Tour (Start : in Cities; + Sol : in Result_Matrix) return Result_Matrix; + -- Will extract the tour of a single salesman, whose start is at Start. + -- The resulting matrix will have only a single salesman index = 1. + -- The lenght of its tour will be clipped to the actual cities visited. + -- First city will always be Start, last city the last one visited. + + type Normal_Tour is tagged private; + -- A normalized store for mtsp tour solutions. + -- The starting city for every man is at index 1. + + function Create (Num_Men : in Salesmen) return Normal_Tour; + -- Empty Normal_Tour for Num_Men travelers. + + function Create (Start : in Start_Matrix; + Sol : in Result_Matrix) return Normal_Tour; + -- Get a complete solution and return a normalized one. + + procedure Append_City (This : in out Normal_Tour; + Man : in Salesmen; + City : in Cities); + -- Add City to the end of Man's tour. + + function City (This : in Normal_Tour; + Man : in Salesmen; + Stage : in Stages) return Cities; + -- Get city for Salesman at given Stage. + + function Last (This : in Normal_Tour) return Salesmen; + -- Get last salesman. + + function Last (This : in Normal_Tour; + Man : in Salesmen) return Stages; + -- Get last stage for some salesman. + + procedure Print_Problem (Cost : in Cost_Matrix); + + procedure Print_Solution (Cost : in Cost_Matrix; + Start: in Start_Matrix; + Sol : in Result_Matrix; + No_Return : in Boolean); + -- To stdout + +private + + Inf : constant Costs := Costs'Last; + + package Cities_Vector is new Agpl.Dynamic_Vector (Cities); + subtype City_Vector is Cities_Vector.Object (First => 1); + + package Tour_Vector is new Agpl.Dynamic_Vector (City_Vector); + + type Normal_Tour is tagged record + Tours : Tour_Vector.Object (First => 1); + end record; + -- That's is, an array of arrays of cities. + -- First array is indexed by salesman, second one by stage. + + function Solve_MTSP_No_Return (Start : in Start_Matrix; + Cost : in Cost_Matrix) return Result_Matrix; + -- Used internally to do the No_Return special case. + +end Agpl.Optimization.Concordefake;