From 18ef526984952eb7b669b75bead213a5f8e749fa Mon Sep 17 00:00:00 2001 From: "Alejandro R. Mosteo" Date: Sun, 24 Sep 2006 00:24:44 +0000 Subject: [PATCH] M agpl-containers-bulk.ads A agpl-cr-mutable_assignment-heuristics.adb A agpl-cr-mutable_assignment-heuristics.ads A agpl-cr-containers.ads M agpl-cr-cost_matrix-utils.adb A agpl-cr-cost_cache.adb A agpl-cr-mutable_assignment-auctions.adb A agpl-cr-cost_cache.ads A agpl-cr-mutable_assignment-auctions.ads M agpl-optimization-annealing-solver.adb A agpl-cr-mutable_assignment-or_mutations.adb A agpl-cr-mutable_assignment-or_mutations.ads M agpl-cr-cost_matrix.adb A agpl-cr-assignment-utils.adb M agpl-cr-cost_matrix.ads A agpl-cr-assignment-utils.ads A agpl-cr-mutable_assignment-moves.adb M agpl-cr-mutable_assignment.adb A agpl-cr-mutable_assignment-moves.ads M agpl-cr-mutable_assignment.ads A agpl-cr-cost_cache-handle.ads --- agpl-containers-bulk.ads | 3 + agpl-cr-assignment-utils.adb | 33 + agpl-cr-assignment-utils.ads | 33 + agpl-cr-containers.ads | 28 + agpl-cr-cost_cache-handle.ads | 32 + agpl-cr-cost_cache.adb | 55 ++ agpl-cr-cost_cache.ads | 57 ++ agpl-cr-cost_matrix-utils.adb | 6 +- agpl-cr-cost_matrix.adb | 4 +- agpl-cr-cost_matrix.ads | 7 +- agpl-cr-mutable_assignment-auctions.adb | 271 ++++++ agpl-cr-mutable_assignment-auctions.ads | 56 ++ agpl-cr-mutable_assignment-heuristics.adb | 128 +++ agpl-cr-mutable_assignment-heuristics.ads | 52 ++ agpl-cr-mutable_assignment-moves.adb | 349 +++++++ agpl-cr-mutable_assignment-moves.ads | 59 ++ agpl-cr-mutable_assignment-or_mutations.adb | 236 +++++ agpl-cr-mutable_assignment-or_mutations.ads | 40 + agpl-cr-mutable_assignment.adb | 977 ++------------------ agpl-cr-mutable_assignment.ads | 69 +- agpl-optimization-annealing-solver.adb | 10 +- 21 files changed, 1531 insertions(+), 974 deletions(-) create mode 100644 agpl-cr-assignment-utils.adb create mode 100644 agpl-cr-assignment-utils.ads create mode 100644 agpl-cr-containers.ads create mode 100644 agpl-cr-cost_cache-handle.ads create mode 100644 agpl-cr-cost_cache.adb create mode 100644 agpl-cr-cost_cache.ads create mode 100644 agpl-cr-mutable_assignment-auctions.adb create mode 100644 agpl-cr-mutable_assignment-auctions.ads create mode 100644 agpl-cr-mutable_assignment-heuristics.adb create mode 100644 agpl-cr-mutable_assignment-heuristics.ads create mode 100644 agpl-cr-mutable_assignment-moves.adb create mode 100644 agpl-cr-mutable_assignment-moves.ads create mode 100644 agpl-cr-mutable_assignment-or_mutations.adb create mode 100644 agpl-cr-mutable_assignment-or_mutations.ads diff --git a/agpl-containers-bulk.ads b/agpl-containers-bulk.ads index 7b7209d..ba34626 100644 --- a/agpl-containers-bulk.ads +++ b/agpl-containers-bulk.ads @@ -49,4 +49,7 @@ package Agpl.Containers.Bulk is package Vectors is new Ada.Containers.Indefinite_Vectors (Index_Type, Element_Type); + package String_Element_Maps is new + Ada.Containers.Indefinite_Ordered_Maps (String, Element_Type); + end Agpl.Containers.Bulk; diff --git a/agpl-cr-assignment-utils.adb b/agpl-cr-assignment-utils.adb new file mode 100644 index 0000000..87079a6 --- /dev/null +++ b/agpl-cr-assignment-utils.adb @@ -0,0 +1,33 @@ +with Agpl.Cr.Containers; use Agpl.Cr.Containers; + +package body Agpl.Cr.Assignment.Utils is + + ----------------- + -- Concatenate -- + ----------------- + + procedure Concatenate (Dst : in out Object; Src : Object) is + Agents : constant Agent_Lists.List := Src.Get_Agents; + + procedure Do_It (I : Agent_Lists.Cursor) is + Ag_Src : constant Cr.Agent.Object'Class := Agent_Lists.Element (I); + begin + if Dst.Contains (Ag_Src.Get_Name) then + declare + Ag_Dst : Cr.Agent.Object'Class := Dst.Get_Agent (Ag_Src.Get_Name); + T : Task_Lists.List := Ag_Dst.Get_Tasks; + begin + Task_Utils.Concatenate (T, Ag_Src.Get_Tasks); + Ag_Dst.Set_Tasks (T); + Dst.Set_Agent (Ag_Dst); + end; + else + Dst.Set_Agent (Ag_Src); + end if; + end Do_It; + + begin + Agents.Iterate (Do_It'Access); + end Concatenate; + +end Agpl.Cr.Assignment.Utils; diff --git a/agpl-cr-assignment-utils.ads b/agpl-cr-assignment-utils.ads new file mode 100644 index 0000000..2e3182b --- /dev/null +++ b/agpl-cr-assignment-utils.ads @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +package Agpl.Cr.Assignment.Utils is + + pragma Preelaborate; + + procedure Concatenate (Dst : in out Object; Src : Object); + +end Agpl.Cr.Assignment.Utils; diff --git a/agpl-cr-containers.ads b/agpl-cr-containers.ads new file mode 100644 index 0000000..ab11969 --- /dev/null +++ b/agpl-cr-containers.ads @@ -0,0 +1,28 @@ +pragma Warnings (Off); +with Agpl.Cr.Agent.Containers; +with Agpl.Cr.Agent.Utils; +with Agpl.Htn.Tasks.Containers; +with Agpl.Htn.Tasks.Utils; + +with Ada.Containers.Indefinite_Ordered_Maps; + +package Agpl.Cr.Containers is + + pragma Preelaborate; + + package Agent_Containers renames Agpl.Cr.Agent.Containers; + package Agent_Lists renames Agent.Containers.Lists; + package Agent_Maps renames Agent.Containers.Maps; + package Agent_Vectors renames Agent.Containers.Vectors; + package Agent_Utils renames Agent.Utils; + + package Task_Containers renames Agpl.Htn.Tasks.Containers; + package Task_Lists renames Agpl.Htn.Tasks.Containers.Lists; + package Task_Maps renames Agpl.Htn.Tasks.Containers.Maps; + package Task_Vectors renames Agpl.Htn.Tasks.Containers.Vectors; + package Task_Utils renames Agpl.Htn.Tasks.Utils; + + package String_Cost_Maps is new + Ada.Containers.Indefinite_Ordered_Maps (String, Costs); + +end Agpl.Cr.Containers; diff --git a/agpl-cr-cost_cache-handle.ads b/agpl-cr-cost_cache-handle.ads new file mode 100644 index 0000000..713739a --- /dev/null +++ b/agpl-cr-cost_cache-handle.ads @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +-- A generic interface for cost caching strategies. + +with Agpl.Generic_Handle; + +package Agpl.Cr.Cost_Cache.Handle is new + Agpl.Generic_Handle (Object'Class); diff --git a/agpl-cr-cost_cache.adb b/agpl-cr-cost_cache.adb new file mode 100644 index 0000000..d8aac72 --- /dev/null +++ b/agpl-cr-cost_cache.adb @@ -0,0 +1,55 @@ +with Agpl.Cr.Agent.Dummy; + +package body Agpl.Cr.Cost_Cache is + + ------------------- + -- Get_Plan_Cost -- + ------------------- + + function Get_Plan_Cost + (This : in Object'Class; + Agent : in Cr.Agent.Object'Class) + return Costs + is + T : constant Htn.Tasks.Containers.Lists.List := Agent.Get_Tasks; + Prev : Htn.Tasks.Task_Id := Htn.Tasks.No_Task; + use Htn.Tasks.Containers.Lists; + + Total, + Partial : Cr.Costs := 0.0; + I : Htn.Tasks.Containers.Lists.Cursor := T.First; + begin + while Has_Element (I) loop + Partial := Get_Cost (This, + Cr.Agent.Get_Name (Agent), + Prev, Htn.Tasks.Get_Id (Element (I))); + if Partial = Cr.Infinite then + Total := Infinite; + else + Total := Total + Partial; + end if; + exit when Partial = Cr.Infinite; + Prev := Htn.Tasks.Get_Id (Element (I)); + Next (I); + end loop; + return Total; + end Get_Plan_Cost; + + ------------------- + -- Get_Plan_Cost -- + ------------------- + + function Get_Plan_Cost + (This : in Object'Class; + Agent : in String; + Tasks : in Htn.Tasks.Containers.Lists.List) + return Costs + is + Ag : Cr.Agent.Dummy.Object; + begin + Ag.Set_Name (Agent); + Ag.Set_Tasks (Tasks); + return Get_Plan_Cost (This, Ag); + end Get_Plan_Cost; + +end Agpl.Cr.Cost_Cache; diff --git a/agpl-cr-cost_cache.ads b/agpl-cr-cost_cache.ads new file mode 100644 index 0000000..ecc1e25 --- /dev/null +++ b/agpl-cr-cost_cache.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +-- A generic interface for cost caching strategies. + +with Agpl.Cr.Agent; +with Agpl.Htn.Tasks; +with Agpl.Htn.Tasks.Containers; + +package Agpl.Cr.Cost_Cache is + + pragma Preelaborate; + + -- type Object is interface; + type Object is abstract tagged null record; + + function Get_Cost + (This : in Object; + Agent : in String; + Ini : in Htn.Tasks.Task_Id; + Fin : in Htn.Tasks.Task_Id) return Costs is abstract; + + function Get_Plan_Cost + (This : in Object'Class; + Agent : in Cr.Agent.Object'Class) return Costs; + -- Say the full cost of an agent plan. + + function Get_Plan_Cost + (This : in Object'Class; + Agent : in String; + Tasks : in Htn.Tasks.Containers.Lists.List) return Costs; + -- Evaluate a plan with a given agent + +end Agpl.Cr.Cost_Cache; diff --git a/agpl-cr-cost_matrix-utils.adb b/agpl-cr-cost_matrix-utils.adb index 2a6dc15..98ac24f 100644 --- a/agpl-cr-cost_matrix-utils.adb +++ b/agpl-cr-cost_matrix-utils.adb @@ -67,7 +67,8 @@ package body Agpl.Cr.Cost_Matrix.Utils is Htn.Tasks.No_Task, V.First_Element.Get_Id, Get_Cost - (Src, Agent.Get_Name, + (Object'Class (Src), + Agent.Get_Name, Htn.Tasks.No_Task, V.First_Element.Get_Id)); end if; @@ -78,7 +79,8 @@ package body Agpl.Cr.Cost_Matrix.Utils is V.Element (I).Get_Id, V.Element (I + 1).Get_Id, Get_Cost - (Src, Agent.Get_Name, + (Object'Class (Src), + Agent.Get_Name, V.Element (I).Get_Id, V.Element (I + 1).Get_Id)); end loop; diff --git a/agpl-cr-cost_matrix.adb b/agpl-cr-cost_matrix.adb index f1078e7..997599b 100644 --- a/agpl-cr-cost_matrix.adb +++ b/agpl-cr-cost_matrix.adb @@ -102,7 +102,7 @@ package body Agpl.Cr.Cost_Matrix is Cr.Agent.Get_Name (Al.Element (A)), Htn.Tasks.No_Task, Htn.Tasks.Get_Id (Tl.Element (Fin)), - Get_Cost (This, + Get_Cost (Object'Class (This), Cr.Agent.Get_Name (Al.Element (A)), Htn.Tasks.Get_Id (Tl.Element (Ini)), Htn.Tasks.Get_Id (Tl.Element (Fin)))); @@ -238,7 +238,7 @@ package body Agpl.Cr.Cost_Matrix is I : Htn.Tasks.Containers.Lists.Cursor := T.First; begin while Has_Element (I) loop - Partial := Get_Cost (This, + Partial := Get_Cost (Object'Class (This), Cr.Agent.Get_Name (Agent), Prev, Htn.Tasks.Get_Id (Element (I))); if Partial = Cr.Infinite then diff --git a/agpl-cr-cost_matrix.ads b/agpl-cr-cost_matrix.ads index 0d2b048..47d0625 100644 --- a/agpl-cr-cost_matrix.ads +++ b/agpl-cr-cost_matrix.ads @@ -29,6 +29,7 @@ with Ada.Strings.Hash; with Agpl.Cr.Agent; with Agpl.Cr.Agent.Containers; +with Agpl.Cr.Cost_Cache; with Agpl.Htn.Tasks; with Agpl.Htn.Tasks.Containers; @@ -36,7 +37,7 @@ package Agpl.Cr.Cost_Matrix is pragma Preelaborate; - type Object is private; + type Object is new Cost_Cache.Object with private; -- Here we store a mapping of Agent x Start Task x End Task --> Costs -- This structure will be later used by assigners to compute an assignation. @@ -133,7 +134,7 @@ private use Att_Maps; - type Object is record + type Object is new Cost_Cache.Object with record Matrix : Map; end record; @@ -143,6 +144,6 @@ private pragma Inline (Key); -- Construct a suitable key for indexing. - Empty_Object : constant Object := (others => <>); + Empty_Object : constant Object := (Cost_Cache.Object with others => <>); end Agpl.Cr.Cost_Matrix; diff --git a/agpl-cr-mutable_assignment-auctions.adb b/agpl-cr-mutable_assignment-auctions.adb new file mode 100644 index 0000000..50f24cb --- /dev/null +++ b/agpl-cr-mutable_assignment-auctions.adb @@ -0,0 +1,271 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +-- The difference with Expres.Mutable_assignment is that that one used several +-- hacks for the problem we had at hand at that time. + +-- This one strives to be a really general, problem-independent solution. + +with Agpl.Trace; use Agpl.Trace; + +with Ada.Numerics.Elementary_Functions; + +package body Agpl.Cr.Mutable_Assignment.Auctions is + + --------------------- + -- Do_Auction_Task -- + --------------------- + + procedure Do_Auction_Task (This : in out Object; + Undo : out Undo_Info) + is + U : Undo_Internal (Move_Task); + begin + if This.Num_Assigned_Tasks <= 1 then + This.Do_Identity (Undo); + return; + end if; + + U.Description := + "LOG AUCTION"; + + declare + use Ada.Numerics.Elementary_Functions; + Src : Task_Context_Ptr := + This.Select_Random_Task (All_Assigned_Tasks); + Src_Copy : Task_Context := Task_Context (Src.all); + Checks : constant Positive := + Natural (Log (Float (This.Num_Assigned_Tasks))) + 1; + + Best_Prev, + Best_Next : Task_Context_Ptr; + Best_Cost : Costs := Infinite; + Best_Name : Ustring; + begin + This.Add_Undo_Move (Src, U); + Undo.Handle.Set (U); + This.Do_Remove_Task (Src); + + Log ("Checking" & Checks'Img & " of" & This.Num_Assigned_Tasks'Img & + " possible insertions", Debug, Detail_Section); + + for I in 1 .. Checks loop + declare + Curr_Target, + Curr_Prev, + Curr_Next : Task_Context_Ptr; + Curr_Cost : Costs; + begin + This.Select_Random_Insertion (All_Assigned_Tasks, + Curr_Prev, + Curr_Target, + Curr_Next); + Curr_Cost := This.Evaluate_Cost_Inserting + (Curr_Prev, + Src_Copy.Job, + Curr_Next, + Agent_Id (Get_Attribute (Curr_Target, Owner))); + + if Curr_Cost < Best_Cost then + Best_Cost := Curr_Cost; + Best_Prev := Curr_Prev; + Best_Next := Curr_Next; + Best_Name := +String (Get_Attribute (Curr_Target, Owner)); + end if; + end; + end loop; + + if Best_Cost < Cr.Infinite then + This.Do_Insert_Task (Best_Prev, + Src_Copy, + Best_Next, + Agent_Id (+Best_Name)); + else + This.Do_Insert_Task (This.Get_Task_Context (Src_Copy.Prev), + Src_Copy, + This.Get_Task_Context (Src_Copy.Next), + Get_Attribute (Src_Copy, Owner)); + This.Do_Identity (Undo); + end if; + end; + end Do_Auction_Task; + + -------------------------------- + -- Do_Exhaustive_Auction_Task -- + -------------------------------- + + procedure Do_Exhaustive_Auction_Task (This : in out Object; + Undo : out Undo_Info) + is + U : Undo_Internal (Move_Task); + begin + if This.Num_Assigned_Tasks <= 1 then + This.Do_Identity (Undo); + return; + end if; + + U.Description := + "FULL AUCTION"; + + declare + use Ada.Numerics.Elementary_Functions; + Src : Task_Context_Ptr := + This.Select_Random_Task (All_Assigned_Tasks); + Src_Copy : Task_Context := Task_Context (Src.all); + + Best_Prev, + Best_Next : Task_Context_Ptr; + Best_Cost : Costs := Infinite; + Best_Name : Ustring; + + procedure Do_It (I : in Solution_Context_Maps.Cursor) is + use Solution_Context_Maps; + begin + if Element (I) in Task_Context then + declare + C : constant Task_Context := Task_Context (Element (I)); + Prev : constant Task_Context_Ptr := + This.Get_Task_Context (C.Prev); + Next : constant Task_Context_Ptr := + This.Get_Task_Context (C.Job); + Cost : Costs; + begin + Cost := This.Evaluate_Cost_Inserting + (Prev, + Src_Copy.Job, + Next, + Agent_Id (Get_Attribute (C, Owner))); + + if Cost < Best_Cost then + Best_Cost := Cost; + Best_Prev := Prev; + Best_Next := Next; + Best_Name := +String (Get_Attribute (C, Owner)); + end if; + end; + end if; + end Do_It; + + begin + This.Add_Undo_Move (Src, U); + Undo.Handle.Set (U); + This.Do_Remove_Task (Src); + + This.Contexts.Iterate (Do_It'Access); + + if Best_Cost < Cr.Infinite then + This.Do_Insert_Task (Best_Prev, + Src_Copy, + Best_Next, + Agent_Id (+Best_Name)); + else + This.Do_Insert_Task (This.Get_Task_Context (Src_Copy.Prev), + Src_Copy, + This.Get_Task_Context (Src_Copy.Next), + Get_Attribute (Src_Copy, Owner)); + This.Do_Identity (Undo); + end if; + end; + end Do_Exhaustive_Auction_Task; + + ---------------------------- + -- Do_Guided_Auction_Task -- + ---------------------------- + + procedure Do_Guided_Auction_Task (This : in out Object; + Undo : out Undo_Info) + is + U : Undo_Internal (Move_Task); + begin + if This.Num_Assigned_Tasks <= 1 then + This.Do_Identity (Undo); + return; + end if; + + U.Description := + "GUIDED+LOG AUCTION"; + + declare + use Ada.Numerics.Elementary_Functions; + Worst_Agent : constant Agent_Id := + Agent_Id (+This.Minmax.Last_Element.Agent); + Best_Agent : constant Agent_Id := + Agent_Id (+This.Minmax.First_Element.Agent); + Src : Task_Context_Ptr := + This.Select_Random_Task (Agent_Tasks_Bag (Worst_Agent)); + Src_Copy : Task_Context := Task_Context (Src.all); + Checks : constant Positive := + Natural (Log (Float (This.Num_Assigned_Tasks))) + 1; + + Best_Prev, + Best_Next : Task_Context_Ptr; + Best_Cost : Costs := Infinite; + Best_Name : Ustring; + begin + This.Add_Undo_Move (Src, U); + Undo.Handle.Set (U); + This.Do_Remove_Task (Src); + + Log ("Checking" & Checks'Img & " of" & This.Num_Assigned_Tasks'Img & + " possible insertions", Debug, Detail_Section); + + for I in 1 .. Checks loop + declare + Curr_Target, + Curr_Prev, + Curr_Next : Task_Context_Ptr; + Curr_Cost : Costs; + begin + This.Select_Random_Insertion (Agent_Tasks_Bag (Best_Agent), + Curr_Prev, + Curr_Target, + Curr_Next); + Curr_Cost := This.Evaluate_Cost_Inserting + (Curr_Prev, + Src_Copy.Job, + Curr_Next, + Best_Agent); + if Curr_Cost < Best_Cost then + Best_Cost := Curr_Cost; + Best_Prev := Curr_Prev; + Best_Next := Curr_Next; + Best_Name := +String (Best_Agent); + end if; + end; + end loop; + if Best_Cost < Cr.Infinite then + This.Do_Insert_Task (Best_Prev, + Src_Copy, + Best_Next, + Agent_Id (+Best_Name)); + else + This.Do_Insert_Task (This.Get_Task_Context (Src_Copy.Prev), + Src_Copy, + This.Get_Task_Context (Src_Copy.Next), + Get_Attribute (Src_Copy, Owner)); + This.Do_Identity (Undo); + end if; + end; + end Do_Guided_Auction_Task; + +end Agpl.Cr.Mutable_Assignment.Auctions; diff --git a/agpl-cr-mutable_assignment-auctions.ads b/agpl-cr-mutable_assignment-auctions.ads new file mode 100644 index 0000000..23d6125 --- /dev/null +++ b/agpl-cr-mutable_assignment-auctions.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- 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.Mutable_Assignment.Moves; + +package Agpl.Cr.Mutable_Assignment.Auctions is + + pragma Elaborate_Body; + + -- use UNDO_MOVE_TASK for all moves in this package + + -- O (log) + procedure Do_Auction_Task (This : in out Object; + Undo : out Undo_Info); + -- As undo, use the Undo_Move_Task + -- Cost is kept logaritmic checking only a log fraction of all insertion points. + + procedure Do_Guided_Auction_Task (This : in out Object; + Undo : out Undo_Info); + -- Guided in originating agent + -- As undo, use the Undo_Move_Task + + -- O (n) + procedure Do_Exhaustive_Auction_Task (This : in out Object; + Undo : out Undo_Info); + -- As undo, use the Undo_Move_Task + -- Will try all possible insertions + + procedure Undo_Move_Task (This : in out Object; Undo : in Undo_Info) + renames Moves.Undo_Move_Task; + -- Will un-move all movements, in the Undo_Info stack, not just one. + +end Agpl.Cr.Mutable_Assignment.Auctions; diff --git a/agpl-cr-mutable_assignment-heuristics.adb b/agpl-cr-mutable_assignment-heuristics.adb new file mode 100644 index 0000000..90954dc --- /dev/null +++ b/agpl-cr-mutable_assignment-heuristics.adb @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +-- The difference with Expres.Mutable_assignment is that that one used several +-- hacks for the problem we had at hand at that time. + +-- This one strives to be a really general, problem-independent solution. + +with Agpl.Cr.Agent.Handle; +with Agpl.Cr.Plan_Assigner; +with Agpl.Cr.Plan_Assigner.Greedy1; +with Agpl.Cr.Tasks.Insertions; +with Agpl.Trace; use Agpl.Trace; + +package body Agpl.Cr.Mutable_Assignment.Heuristics is + + -------------------- + -- Do_Heuristic_2 -- + -------------------- + + procedure Do_Heuristic_2 (This : in out Object; + Undo : out Undo_Info) + is + U : Undo_Internal (From_Scratch); + begin + U.Ass := This.To_Assignment; + U.Description := +"Heuristic 2"; + Undo.Handle.Set (U); + + declare + use Cr.Assignment; + New_Assignment : constant Cr.Assignment.Object := + Plan_Assigner.Greedy1.Assign + ((Plan_Assigner.Object with null record), + Get_Agents_Without_Tasks (U.Ass), + This.Context.Ref.Plan, + This.Context.Ref.Costs, + This.Context.Ref.Criterion); + begin +-- New_Assignment.Print_Assignment; + + if New_Assignment.Is_Valid then + Set_Assignment (This, New_Assignment, This.Context.Ref.Criterion); + else + Log ("Plan_Assigner.Greedy1 failed!", Warning, Log_Section); + end if; + -- Note: here Minimax will not be used since there are no new tasks. + end; + exception + when E : Constraint_Error => + Log ("Plan_Assigner.Greedy1 failed!", Warning, Log_Section); + Log (Report (E), Warning); + end Do_Heuristic_2; + + ---------------------- + -- Do_Agent_Reorder -- + ---------------------- + + procedure Do_Agent_Reorder (This : in out Object; + Undo : out Undo_Info) + is + U : Undo_Internal (From_Scratch); + Agent : constant Agent_Id := + Agent_Id + (+Agent_Context + (This.Select_Random_Context (All_Agents).all).Agent_Name); + begin + declare + New_Ass : Assignment.Object := This.To_Assignment; + Ag : Cr.Agent.Object'Class := New_Ass.Get_Agent (String (Agent)); + Tasks : Task_Lists.List := Ag.Get_Tasks; + begin + U.Description := +"AGENT REORDER Nē"; + U.Ass := New_Ass; + Undo.Handle.Set (U); + + Ag.Clear_Tasks; + while not Tasks.Is_Empty loop + declare + New_Ag : Cr.Agent.Handle.Object; + Cd, Ct : Cr.Costs; + Ok : Boolean; + begin + Cr.Tasks.Insertions.Greedy (Ag, + Tasks.First_Element, + New_Ag, + Cd, Ct, Ok); + if not Ok then + Log ("Failed to reorder agent tasks", Warning, Log_Section); + This.Do_Identity (Undo); + return; + else + Ag := New_Ag.Get; + Tasks.Delete_First; + end if; + end; + end loop; + New_Ass.Set_Agent (Ag); + New_Ass.Set_Valid; +-- New_Ass.Print_Summary; + This.Set_Assignment (New_Ass, This.Context.Ref.Criterion); + end; + end Do_Agent_Reorder; + +end Agpl.Cr.Mutable_Assignment.Heuristics; diff --git a/agpl-cr-mutable_assignment-heuristics.ads b/agpl-cr-mutable_assignment-heuristics.ads new file mode 100644 index 0000000..c1da4f6 --- /dev/null +++ b/agpl-cr-mutable_assignment-heuristics.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +package Agpl.Cr.Mutable_Assignment.Heuristics is + + pragma Elaborate_Body; + + procedure Undo_From_Scratch (This : in out Object; Undo : in Undo_Info) + renames Mutable_Assignment.Undo_From_Scratch; + -- Undo for all heuristics + + procedure Do_Heuristic_1 (This : in out Object; + Undo : out Undo_Info) + renames Mutable_Assignment.Do_Heuristic_1; + -- Will consider all agents and tasks to provide some "good" assignment. + -- The current tasks are re-assigned in a "best pair" greedy fashion. + -- So no OR node switchings happen. + + procedure Do_Heuristic_2 (This : in out Object; + Undo : out Undo_Info); + -- This heuristic will consider the best of *all* tasks in every possible + -- expansion; freeze the plan with the chosen task; repeat until no more T. + + -- O (n^2) + procedure Do_Agent_Reorder (This : in out Object; + Undo : out Undo_Info); + -- Greedy reordering of an agent tasks + +end Agpl.Cr.Mutable_Assignment.Heuristics; diff --git a/agpl-cr-mutable_assignment-moves.adb b/agpl-cr-mutable_assignment-moves.adb new file mode 100644 index 0000000..851297a --- /dev/null +++ b/agpl-cr-mutable_assignment-moves.adb @@ -0,0 +1,349 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +-- The difference with Expres.Mutable_assignment is that that one used several +-- hacks for the problem we had at hand at that time. + +-- This one strives to be a really general, problem-independent solution. + +with Agpl.Trace; use Agpl.Trace; + +package body Agpl.Cr.Mutable_Assignment.Moves is + + use type Htn.Tasks.Task_Id; + + ------------------ + -- Do_Move_Task -- + ------------------ + + procedure Do_Move_Task (This : in out Object; + Undo : out Undo_Info) + is + begin + if This.Num_Assigned_Tasks <= 1 then + This.Do_Identity (Undo); + return; + end if; + + declare + Src : Task_Context_Ptr := + This.Select_Random_Task (All_Assigned_Tasks); + Src_Copy : Task_Context := Task_Context (Src.all); + U : Undo_Internal (Move_Task); + begin + U.Description := + "MOVE"; + + This.Add_Undo_Move (Src, U); + Undo.Handle.Set (U); + This.Do_Remove_Task (Src); + + declare + Target : Task_Context_Ptr; + + New_Prev, + New_Next : Task_Context_Ptr; + begin + This.Select_Random_Insertion (All_Assigned_Tasks, + New_Prev, + Target, + New_Next); + declare + New_Owner : constant Agent_Id := Get_Attribute (Target, Owner); + begin + Do_Insert_Task (This, + New_Prev, + Src_Copy, + New_Next, + New_Owner); + end; + end; + end; + end Do_Move_Task; + + --------------------------------- + -- Do_Move_Task_Changing_Owner -- + --------------------------------- + + procedure Do_Move_Task_Changing_Owner (This : in out Object; + Undo : out Undo_Info) + is + U : Undo_Internal (Move_Task); + begin + if This.Num_Assigned_Tasks <= 1 then + This.Do_Identity (Undo); + return; + end if; + + U.Description := + "MOVE+OWNER"; + + declare + Src : Task_Context_Ptr := + This.Select_Random_Task (All_Assigned_Tasks); + Src_Copy : Task_Context := Task_Context (Src.all); + + New_Owner : constant Agent_Id := + Agent_Id + (+ Agent_Context + (This.Select_Random_Context + (All_Agents).all).Agent_Name); + + begin + This.Add_Undo_Move (Src, U); + Undo.Handle.Set (U); + This.Do_Remove_Task (Src); + + declare + Prev, Curr, Next : Task_Context_Ptr; + begin + This.Select_Random_Insertion + (Agent_Tasks_Bag (New_Owner), + Prev, + Curr, + Next); + This.Do_Insert_Task (Prev, + Src_Copy, + Next, + New_Owner); + end; + end; + end Do_Move_Task_Changing_Owner; + + ---------------------------------------- + -- Do_Guided_Move_Task_Changing_Owner -- + ---------------------------------------- + + procedure Do_Guided_Move_Task_Changing_Owner (This : in out Object; + Undo : out Undo_Info) + is + U : Undo_Internal (Move_Task); + begin + if This.Num_Assigned_Tasks <= 1 then + This.Do_Identity (Undo); + return; + end if; + + U.Description := + "MOVE+GUIDED+OWNER"; + + declare + Worst_Agent : constant Agent_Id := + Agent_Id (+This.Minmax.Last_Element.Agent); + Src : Task_Context_Ptr := + This.Select_Random_Task (Agent_Tasks_Bag (Worst_Agent)); + Src_Copy : Task_Context := Task_Context (Src.all); + New_Owner : constant Agent_Id := + Agent_Id + (+ Agent_Context + (This.Select_Random_Context + (All_Agents).all).Agent_Name); + begin + This.Add_Undo_Move (Src, U); + Undo.Handle.Set (U); + This.Do_Remove_Task (Src); + + declare + Prev, Curr, Next : Task_Context_Ptr; + begin + This.Select_Random_Insertion + (Agent_Tasks_Bag (New_Owner), + Prev, + Curr, + Next); + This.Do_Insert_Task (Prev, + Src_Copy, + Next, + New_Owner); + end; + end; + end Do_Guided_Move_Task_Changing_Owner; + + ------------------- + -- Do_Swap_Order -- + ------------------- + + procedure Do_Swap_Order (This : in out Object; + Undo : out Undo_Info) + is + U : Undo_Internal (Move_Task); + begin + if This.Num_Assigned_Tasks <= 1 then + This.Do_Identity (Undo); + return; + end if; + + U.Description := + "SWAP ORDER"; + + declare + Src : Task_Context_Ptr := + This.Select_Random_Task (All_Assigned_Tasks); + Src_Copy : Task_Context := Task_Context (Src.all); + Next : constant Task_Context_Ptr := + This.Get_Task_Context (Src.Next); + begin + if Next /= null then + This.Add_Undo_Move (Src, U); + Undo.Handle.Set (U); + This.Do_Remove_Task (Src); + This.Do_Insert_Task (Next, + Src_Copy, + This.Get_Task_Context (Next.Next), + Agent_Id (Get_Attribute (Next, Owner))); + else + This.Do_Identity (Undo); + end if; + end; + end Do_Swap_Order; + + ------------------- + -- Do_Swap_Tasks -- + ------------------- + + procedure Do_Swap_Tasks (This : in out Object; + Undo : out Undo_Info) + is + U : Undo_Internal (Move_Task); + begin + if This.Num_Assigned_Tasks <= 3 then + This.Do_Identity (Undo); + return; + end if; + + U.Description := + "SWAP ANY"; + + declare + Src : Task_Context_Ptr := + This.Select_Random_Task (All_Assigned_Tasks); + Src_Copy : Task_Context := Task_Context (Src.all); + Prev_1 : constant Htn.Tasks.Task_id := Src.Prev; + Next_1 : constant Htn.Tasks.Task_id := Src.Next; + Owner_1 : constant Agent_Id := + Agent_Id (Get_Attribute (Src, Owner)); + begin + This.Add_Undo_Move (Src, U); + Undo.Handle.Set (U); + This.Do_Remove_Task (Src); + + declare + Target : Task_Context_Ptr; + + New_Prev, + New_Next : Task_Context_Ptr; + Watchdog : Natural := 0; + begin + loop + This.Select_Random_Insertion (All_Assigned_Tasks, + New_Prev, + Target, + New_Next); + exit when Target.Job /= Prev_1 and then + Target.Job /= Next_1; + Watchdog := Watchdog + 1; + if Watchdog > 100 then + raise Program_Error + with "Moving target failed (" & + This.Num_Assigned_Tasks'Img & " assigned tasks)"; + end if; + end loop; + + declare + Target_Copy : Task_Context := Task_Context (Target.all); + New_Owner : constant Agent_Id := Get_Attribute (Target, Owner); + begin + Do_Insert_Task (This, + New_Prev, + Src_Copy, + New_Next, + New_Owner); + + This.Add_Undo_Move (Target, U); + Undo.Handle.Set (U); + This.Do_Remove_Task (Target); + + if Prev_1 /= No_Task then + declare + Prev : constant Task_Context_Ptr := + This.Get_Task_Context (Prev_1); + Next : constant Task_Context_Ptr := + This.Get_Task_Context (Prev.Next); + begin + This.Do_Insert_Task + (Prev, Target_Copy, Next, Owner_1); + end; + elsif Next_1 /= No_Task then + This.Do_Insert_Task + (This.Get_Task_Context + (This.Get_Task_Context (Next_1).Prev), + Target_Copy, + This.Get_Task_Context (Next_1), + Owner_1); + else + This.Do_Insert_Task + (null, Target_Copy, null, Owner_1); + end if; + end; + end; + end; + end Do_Swap_Tasks; + + -------------------- + -- Undo_Move_Task -- + -------------------- + + procedure Undo_Move_Task (This : in out Object; Undo : in Undo_Info) is + U : Undo_Internal renames Undo.Handle.Ref.all; + begin + case U.Kind is + when Identity => + null; + when Move_Task => + for I in reverse U.Move_Stack.First .. U.Move_Stack.Last loop + declare + Move : Undo_Move_Task_Info renames U.Move_Stack.Vector (I); + Src : Task_Context_Ptr := + This.Get_Task_Context (Move.Moved_One); + begin + This.Do_Move_Task + (After_This => This.Get_Task_Context (Move.Was_After), + Src => Src, + Before_This => This.Get_Task_Context (Move.Was_Before), + New_Owner => Agent_Id (+Move.Owner_Was)); + + if Move.Minsum_Was /= This.Minsum then + Log ("Cost was " & Cr.Image (Move.Minsum_Was, 10) & + " but is " & Cr.Image (This.Minsum, 10) & + " (" & Cr.Image (This.Minsum - Move.Minsum_Was, 10) & ")", + Error, Log_Section); + -- Cr.Cost_Matrix.Print (This.Context.Ref.Costs); + This.Reevaluate_Costs; + -- raise Program_Error with "Undo breached cost integrity!"; + end if; + end; + end loop; + when others => + raise Program_Error; + end case; + end Undo_Move_Task; + +end Agpl.Cr.Mutable_Assignment.Moves; diff --git a/agpl-cr-mutable_assignment-moves.ads b/agpl-cr-mutable_assignment-moves.ads new file mode 100644 index 0000000..426cd27 --- /dev/null +++ b/agpl-cr-mutable_assignment-moves.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +package Agpl.Cr.Mutable_Assignment.Moves is + + pragma Elaborate_Body; + + procedure Undo_Move_Task (This : in out Object; Undo : in Undo_Info); + -- Will un-move all movements, in the Undo_Info stack, not just one. + + -- O (log) + procedure Do_Move_Task (This : in out Object; + Undo : out Undo_Info); + + -- O (log) + procedure Do_Move_Task_Changing_Owner (This : in out Object; + Undo : out Undo_Info); + -- Moves a task at random, but choses the owner before hand. In this way, + -- no agent can end without tasks (as happens when just using Move_Task + -- As undo, use the Undo_Move_Task + + procedure Do_Guided_Move_Task_Changing_Owner (This : in out Object; + Undo : out Undo_Info); + -- Like previous, but task is chosen from the worst cost agent + + procedure Do_Swap_Order (This : in out Object; + Undo : out Undo_Info); + -- Switches two consecutive tasks + -- As undo, use the Undo_Move_Task + + procedure Do_Swap_Tasks (This : in out Object; + Undo : out Undo_Info); + -- Switches two arbitrary tasks + -- As undo, use the Undo_Move_Task + +end Agpl.Cr.Mutable_Assignment.Moves; diff --git a/agpl-cr-mutable_assignment-or_mutations.adb b/agpl-cr-mutable_assignment-or_mutations.adb new file mode 100644 index 0000000..a14cee7 --- /dev/null +++ b/agpl-cr-mutable_assignment-or_mutations.adb @@ -0,0 +1,236 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +-- The difference with Expres.Mutable_assignment is that that one used several +-- hacks for the problem we had at hand at that time. + +-- This one strives to be a really general, problem-independent solution. + +with Agpl.Htn.Plan_Node; +with Agpl.Random; +with Agpl.Trace; use Agpl.Trace; + +with Ada.Containers; + +package body Agpl.Cr.Mutable_Assignment.Or_Mutations is + + Expensive_Checks : constant Boolean := False; + + use type Ada.Containers.Count_Type; + + ----------------------- + -- Do_Switch_Or_Node -- + ----------------------- + + procedure Do_Switch_Or_Node (This : in out Object; + Undo : out Undo_Info) + is + U : Undo_Internal (Switch_Or_Node); + + Placeholder_Usable : Boolean := False; + Placeholder : Undo_Move_Task_Info; + + procedure Descend_Adding (Node : in Htn.Plan.Subplan) is + use Htn.Plan_Node; + begin + case Get_Kind (Node) is + when Task_Node => + if Get_Expanded (Node) then + -- Compound, do nothing: + Descend_Adding (Get_Expansion (Node)); + else + -- Create a new task and insert at random + declare + Tc : Task_Context; + begin + Tc.Job := Get_Task (Node).all.Get_Id; + if Placeholder_Usable then + Placeholder_Usable := False; + This.Do_Insert_Task + (This.Get_Task_Context (Placeholder.Was_After), + Tc, + This.Get_Task_Context (Placeholder.Was_Before), + + Placeholder.Owner_Was); + else + declare + Target : constant Task_Context_Ptr := + This.Select_Random_Task (All_Assigned_Tasks); + begin + This.Do_Insert_Task + (This.Get_Task_Context (Target.Prev), + Tc, + Target, + Get_Attribute (Target, Owner)); + end; + end if; + end; + end if; + when And_Node => + declare + Children : constant Node_Vectors.Vector := + Get_Children (Node); + begin + for I in Children.First_Index .. Children.Last_Index loop + Descend_Adding (Children.Element (I)); + end loop; + end; + when Or_Node => + declare + Oc : Or_Context := + (Solution_Context with + Node => Node, + Branch => Node_Vectors.Element + (Get_Children (Node), + (Random.Get_Integer + (Node_Vectors.First_Index (Get_Children (Node)), + Node_Vectors.Last_Index (Get_Children (Node)))))); + begin + This.Add_To_Bag (Oc, All_Active_Or_Nodes); + This.Contexts.Insert (Oc.Key, Oc); + end; + end case; + end Descend_Adding; + + use Htn.Plan_Node; + begin + if This.Bag_Length (All_Active_Or_Nodes) < 1 then + This.Do_Identity (Undo); + return; + end if; + + declare + Target : constant Solution_Context_Ptr := + This.Select_Random_Context (All_Active_Or_Nodes); + Ctx : Or_Context renames Or_Context (Target.all); + + Children : Node_Vectors.Vector := Get_Children (Ctx.Node); + begin + + if Children.Length <= 1 then + This.Do_Identity (Undo); + return; + end if; + + U.Description := + "SWITCH OR-NODE"; + + Log ("GOING TO SWITCH", Never); + + loop + declare + New_Child : constant Htn.Plan.Subplan := + Children.Element + (Random.Get_Integer + (Children.First_Index, Children.Last_Index)); + pragma Unbounded_Time; + begin + if New_Child /= Ctx.Branch then + U.Actived_Or_Branch := New_Child; + This.Descend_Removing (Ctx.Branch, U); + + -- in 50% ocassions, we reuse the place were the switched task was: + if Random.Get_Integer (0, 1) = 1 then + Placeholder_Usable := True; + Placeholder := U.Or_Stack.Vector (U.Or_Stack.First); + end if; + + Descend_Adding (New_Child); + Ctx.Branch := New_Child; + exit; + end if; + end; + end loop; + + Undo.Handle.Set (U); + + if Expensive_Checks and then not This.Is_Sane then + raise Program_Error; + end if; + end; + exception + when others => + This.Context.Ref.Plan.Print_Tree_Summary; + This.Debug_Dump_Contexts; + raise; + end Do_Switch_Or_Node; + + ----------------- + -- Undo_Switch -- + ----------------- + + procedure Undo_Switch (This : in out Object; Undo : in Undo_Info) is +-- procedure Descend_Adding (Node : Htn.Subplan) is +-- begin +-- -- Re-add necessary or-nodes +-- -- Re-insert necessary tasks. +-- end Descend_Adding; + Dummy_Undo : Undo_Internal (Switch_Or_Node); + U : Undo_Internal renames Undo.Handle.Ref.all; + begin + Log ("UNDOING SWITCH", Debug, Detail_Section); + case U.Kind is + when Identity => + null; + when Switch_Or_Node => + This.Descend_Removing (U.Actived_Or_Branch, Dummy_Undo); + + -- Add all tasks: + for I in reverse U.Or_Stack.First .. U.Or_Stack.Last loop + declare + Tc : Task_Context; + begin + Tc.Job := U.Or_Stack.Vector (I).Moved_One; + This.Do_Insert_Task + (After_This => + This.Get_Task_Context + (U.Or_Stack.Vector (I).Was_After), + Src => Tc, + Before_This => + This.Get_Task_Context + (U.Or_Stack.Vector (I).Was_Before), + New_Owner => Agent_Id (+U.Or_Stack.Vector (I).Owner_Was)); + + This.Add_Or_Contexts (This.Context.Ref.Plan.Get_Node (Tc.Job)); + + if This.Minsum /= U.Or_Stack.Vector (I).Minsum_Was then + raise Program_Error + with "Undo (Switch) breached integrity; MinSum is" & + This.Minsum'Img & " but should be" & + U.Or_Stack.Vector (I).Minsum_Was'Img; + end if; + + if Expensive_Checks and then not This.Is_Sane then + raise Program_Error; + end if; + end; + end loop; + when others => + raise Program_Error; + end case; + + Log ("UNDONE SWITCH", Debug, Detail_Section); + end Undo_Switch; + +end Agpl.Cr.Mutable_Assignment.Or_Mutations; diff --git a/agpl-cr-mutable_assignment-or_mutations.ads b/agpl-cr-mutable_assignment-or_mutations.ads new file mode 100644 index 0000000..9aa3e8a --- /dev/null +++ b/agpl-cr-mutable_assignment-or_mutations.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +-- The difference with Expres.Mutable_assignment is that that one used several +-- hacks for the problem we had at hand at that time. + +-- This one strives to be a really general, problem-independent solution. + +package Agpl.Cr.Mutable_Assignment.Or_Mutations is + + pragma Elaborate_Body; + + procedure Do_Switch_Or_Node (This : in out Object; + Undo : out Undo_Info); + procedure Undo_Switch (This : in out Object; Undo : in Undo_Info); + +end Agpl.Cr.Mutable_Assignment.Or_Mutations; diff --git a/agpl-cr-mutable_assignment.adb b/agpl-cr-mutable_assignment.adb index ec712e9..b0b824c 100644 --- a/agpl-cr-mutable_assignment.adb +++ b/agpl-cr-mutable_assignment.adb @@ -31,10 +31,7 @@ with Agpl.Conversions; use Agpl.Conversions; -with Agpl.Cr.Agent.Handle; with Agpl.Cr.Assigner.Greedy_Minmax_Exhaustive; -with Agpl.Cr.Plan_Assigner; -with Agpl.Cr.Plan_Assigner.Greedy1; with Agpl.Cr.Tasks.Insertions; with Agpl.Htn.Plan.Utils; with Agpl.Htn.Plan.Utils.Random; @@ -44,12 +41,11 @@ with Agpl.Random; with Agpl.Trace; use Agpl.Trace; with Ada.Containers; -with Ada.Numerics.Elementary_Functions; with Ada.Numerics.Generic_Elementary_Functions; package body Agpl.Cr.Mutable_Assignment is - Expensive_Checks : constant Boolean := False; + Expensive_Checks : constant Boolean := True; File : constant String := "[Mutable_Assignment] "; @@ -60,8 +56,6 @@ package body Agpl.Cr.Mutable_Assignment is package Acm renames Agent_Cost_Maps; - No_Task : Htn.Tasks.Task_Id renames Htn.Tasks.No_Task; - function S is new Conversions.To_Str (Optimization.Annealing.Probability); function To_String is new Conversions.Fixed_To_Str (Cr.Costs); @@ -80,11 +74,6 @@ package body Agpl.Cr.Mutable_Assignment is return Task_Context_Ptr (Cp); end "+"; - function S (Key : in Solution_Context_Key) return String is - begin - return +Ustring (Key); - end S; - --------------- -- Add_Agent -- --------------- @@ -471,94 +460,6 @@ package body Agpl.Cr.Mutable_Assignment is end; end Do_Heuristic_1; - -------------------- - -- Do_Heuristic_2 -- - -------------------- - - procedure Do_Heuristic_2 (This : in out Object; - Undo : out Undo_Info) - is - U : Undo_Internal (From_Scratch); - begin - U.Ass := This.To_Assignment; - U.Description := +"Heuristic 2"; - Undo.Handle.Set (U); - - declare - use Cr.Assignment; - New_Assignment : constant Cr.Assignment.Object := - Plan_Assigner.Greedy1.Assign - ((Plan_Assigner.Object with null record), - Get_Agents_Without_Tasks (U.Ass), - This.Context.Ref.Plan, - This.Context.Ref.Costs, - This.Context.Ref.Criterion); - begin --- New_Assignment.Print_Assignment; - - if New_Assignment.Is_Valid then - Set_Assignment (This, New_Assignment, This.Context.Ref.Criterion); - else - Log (File & "Plan_Assigner.Greedy1 failed!", Warning); - end if; - -- Note: here Minimax will not be used since there are no new tasks. - end; - exception - when E : Constraint_Error => - Log (File & "Plan_Assigner.Greedy1 failed!", Warning); - Log (Report (E), Warning); - end Do_Heuristic_2; - - ---------------------- - -- Do_Agent_Reorder -- - ---------------------- - - procedure Do_Agent_Reorder (This : in out Object; - Undo : out Undo_Info) - is - U : Undo_Internal (From_Scratch); - Agent : constant Agent_Id := - Agent_Id - (+Agent_Context - (This.Select_Random_Context (All_Agents).all).Agent_Name); - begin - declare - New_Ass : Assignment.Object := This.To_Assignment; - Ag : Cr.Agent.Object'Class := New_Ass.Get_Agent (String (Agent)); - Tasks : Task_Lists.List := Ag.Get_Tasks; - begin - U.Description := +"AGENT REORDER Nē"; - U.Ass := New_Ass; - Undo.Handle.Set (U); - - Ag.Clear_Tasks; - while not Tasks.Is_Empty loop - declare - New_Ag : Cr.Agent.Handle.Object; - Cd, Ct : Cr.Costs; - Ok : Boolean; - begin - Cr.Tasks.Insertions.Greedy (Ag, - Tasks.First_Element, - New_Ag, - Cd, Ct, Ok); - if not Ok then - Log ("Failed to reorder agent tasks", Warning, Log_Section); - This.Do_Identity (Undo); - return; - else - Ag := New_Ag.Get; - Tasks.Delete_First; - end if; - end; - end loop; - New_Ass.Set_Agent (Ag); - New_Ass.Set_Valid; --- New_Ass.Print_Summary; - This.Set_Assignment (New_Ass, This.Context.Ref.Criterion); - end; - end Do_Agent_Reorder; - ----------------- -- Do_Identity -- ----------------- @@ -661,509 +562,6 @@ package body Agpl.Cr.Mutable_Assignment is Src := This.Ptr (Src_Copy.Key); end Do_Move_Task; - --------------------- - -- Do_Auction_Task -- - --------------------- - - procedure Do_Auction_Task (This : in out Object; - Undo : out Undo_Info) - is - U : Undo_Internal (Move_Task); - begin - if This.Num_Assigned_Tasks <= 1 then - This.Do_Identity (Undo); - return; - end if; - - U.Description := + "LOG AUCTION"; - - declare - use Ada.Numerics.Elementary_Functions; - Src : Task_Context_Ptr := - This.Select_Random_Task (All_Assigned_Tasks); - Src_Copy : Task_Context := Task_Context (Src.all); - Checks : constant Positive := - Natural (Log (Float (This.Num_Assigned_Tasks))) + 1; - - Best_Prev, - Best_Next : Task_Context_Ptr; - Best_Cost : Costs := Infinite; - Best_Name : Ustring; - begin - This.Add_Undo_Move (Src, U); - Undo.Handle.Set (U); - This.Do_Remove_Task (Src); - - Log ("Checking" & Checks'Img & " of" & This.Num_Assigned_Tasks'Img & - " possible insertions", Debug, Detail_Section); - - for I in 1 .. Checks loop - declare - Curr_Target, - Curr_Prev, - Curr_Next : Task_Context_Ptr; - Curr_Cost : Costs; - begin - This.Select_Random_Insertion (All_Assigned_Tasks, - Curr_Prev, - Curr_Target, - Curr_Next); - Curr_Cost := This.Evaluate_Cost_Inserting - (Curr_Prev, - Src_Copy.Job, - Curr_Next, - Agent_Id (Get_Attribute (Curr_Target, Owner))); - - if Curr_Cost < Best_Cost then - Best_Cost := Curr_Cost; - Best_Prev := Curr_Prev; - Best_Next := Curr_Next; - Best_Name := +String (Get_Attribute (Curr_Target, Owner)); - end if; - end; - end loop; - - if Best_Cost < Cr.Infinite then - This.Do_Insert_Task (Best_Prev, - Src_Copy, - Best_Next, - Agent_Id (+Best_Name)); - else - This.Do_Insert_Task (This.Get_Task_Context (Src_Copy.Prev), - Src_Copy, - This.Get_Task_Context (Src_Copy.Next), - Get_Attribute (Src_Copy, Owner)); - This.Do_Identity (Undo); - end if; - end; - end Do_Auction_Task; - - -------------------------------- - -- Do_Exhaustive_Auction_Task -- - -------------------------------- - - procedure Do_Exhaustive_Auction_Task (This : in out Object; - Undo : out Undo_Info) - is - U : Undo_Internal (Move_Task); - begin - if This.Num_Assigned_Tasks <= 1 then - This.Do_Identity (Undo); - return; - end if; - - U.Description := + "FULL AUCTION"; - - declare - use Ada.Numerics.Elementary_Functions; - Src : Task_Context_Ptr := - This.Select_Random_Task (All_Assigned_Tasks); - Src_Copy : Task_Context := Task_Context (Src.all); - - Best_Prev, - Best_Next : Task_Context_Ptr; - Best_Cost : Costs := Infinite; - Best_Name : Ustring; - - procedure Do_It (I : in Solution_Context_Maps.Cursor) is - use Solution_Context_Maps; - begin - if Element (I) in Task_Context then - declare - C : constant Task_Context := Task_Context (Element (I)); - Prev : constant Task_Context_Ptr := - This.Get_Task_Context (C.Prev); - Next : constant Task_Context_Ptr := - This.Get_Task_Context (C.Job); - Cost : Costs; - begin - Cost := This.Evaluate_Cost_Inserting - (Prev, - Src_Copy.Job, - Next, - Agent_Id (Get_Attribute (C, Owner))); - - if Cost < Best_Cost then - Best_Cost := Cost; - Best_Prev := Prev; - Best_Next := Next; - Best_Name := +String (Get_Attribute (C, Owner)); - end if; - end; - end if; - end Do_It; - - begin - This.Add_Undo_Move (Src, U); - Undo.Handle.Set (U); - This.Do_Remove_Task (Src); - - This.Contexts.Iterate (Do_It'Access); - - if Best_Cost < Cr.Infinite then - This.Do_Insert_Task (Best_Prev, - Src_Copy, - Best_Next, - Agent_Id (+Best_Name)); - else - This.Do_Insert_Task (This.Get_Task_Context (Src_Copy.Prev), - Src_Copy, - This.Get_Task_Context (Src_Copy.Next), - Get_Attribute (Src_Copy, Owner)); - This.Do_Identity (Undo); - end if; - end; - end Do_Exhaustive_Auction_Task; - - ---------------------------- - -- Do_Guided_Auction_Task -- - ---------------------------- - - procedure Do_Guided_Auction_Task (This : in out Object; - Undo : out Undo_Info) - is - U : Undo_Internal (Move_Task); - begin - if This.Num_Assigned_Tasks <= 1 then - This.Do_Identity (Undo); - return; - end if; - - U.Description := + "GUIDED+LOG AUCTION"; - - declare - use Ada.Numerics.Elementary_Functions; - Worst_Agent : constant Agent_Id := - Agent_Id (+This.Minmax.Last_Element.Agent); - Best_Agent : constant Agent_Id := - Agent_Id (+This.Minmax.First_Element.Agent); - Src : Task_Context_Ptr := - This.Select_Random_Task (Agent_Tasks_Bag (Worst_Agent)); - Src_Copy : Task_Context := Task_Context (Src.all); - Checks : constant Positive := - Natural (Log (Float (This.Num_Assigned_Tasks))) + 1; - - Best_Prev, - Best_Next : Task_Context_Ptr; - Best_Cost : Costs := Infinite; - Best_Name : Ustring; - begin - This.Add_Undo_Move (Src, U); - Undo.Handle.Set (U); - This.Do_Remove_Task (Src); - - Log ("Checking" & Checks'Img & " of" & This.Num_Assigned_Tasks'Img & - " possible insertions", Debug, Detail_Section); - - for I in 1 .. Checks loop - declare - Curr_Target, - Curr_Prev, - Curr_Next : Task_Context_Ptr; - Curr_Cost : Costs; - begin - This.Select_Random_Insertion (Agent_Tasks_Bag (Best_Agent), - Curr_Prev, - Curr_Target, - Curr_Next); - Curr_Cost := This.Evaluate_Cost_Inserting - (Curr_Prev, - Src_Copy.Job, - Curr_Next, - Best_Agent); - if Curr_Cost < Best_Cost then - Best_Cost := Curr_Cost; - Best_Prev := Curr_Prev; - Best_Next := Curr_Next; - Best_Name := +String (Best_Agent); - end if; - end; - end loop; - if Best_Cost < Cr.Infinite then - This.Do_Insert_Task (Best_Prev, - Src_Copy, - Best_Next, - Agent_Id (+Best_Name)); - else - This.Do_Insert_Task (This.Get_Task_Context (Src_Copy.Prev), - Src_Copy, - This.Get_Task_Context (Src_Copy.Next), - Get_Attribute (Src_Copy, Owner)); - This.Do_Identity (Undo); - end if; - end; - end Do_Guided_Auction_Task; - - ------------------ - -- Do_Move_Task -- - ------------------ - - procedure Do_Move_Task (This : in out Object; - Undo : out Undo_Info) - is - begin - if This.Num_Assigned_Tasks <= 1 then - This.Do_Identity (Undo); - return; - end if; - - declare - Src : Task_Context_Ptr := - This.Select_Random_Task (All_Assigned_Tasks); - Src_Copy : Task_Context := Task_Context (Src.all); - U : Undo_Internal (Move_Task); - begin - U.Description := + "MOVE"; - - This.Add_Undo_Move (Src, U); - Undo.Handle.Set (U); - This.Do_Remove_Task (Src); - - declare - Target : Task_Context_Ptr; - - New_Prev, - New_Next : Task_Context_Ptr; - begin - This.Select_Random_Insertion (All_Assigned_Tasks, - New_Prev, - Target, - New_Next); - declare - New_Owner : constant Agent_Id := Get_Attribute (Target, Owner); - begin - Do_Insert_Task (This, - New_Prev, - Src_Copy, - New_Next, - New_Owner); - end; - end; - end; - end Do_Move_Task; - - --------------------------------- - -- Do_Move_Task_Changing_Owner -- - --------------------------------- - - procedure Do_Move_Task_Changing_Owner (This : in out Object; - Undo : out Undo_Info) - is - U : Undo_Internal (Move_Task); - begin - if This.Num_Assigned_Tasks <= 1 then - This.Do_Identity (Undo); - return; - end if; - - U.Description := + "MOVE+OWNER"; - - declare - Src : Task_Context_Ptr := - This.Select_Random_Task (All_Assigned_Tasks); - Src_Copy : Task_Context := Task_Context (Src.all); - - New_Owner : constant Agent_Id := - Agent_Id - (+ Agent_Context - (This.Select_Random_Context - (All_Agents).all).Agent_Name); - - begin - This.Add_Undo_Move (Src, U); - Undo.Handle.Set (U); - This.Do_Remove_Task (Src); - - declare - Prev, Curr, Next : Task_Context_Ptr; - begin - This.Select_Random_Insertion - (Agent_Tasks_Bag (New_Owner), - Prev, - Curr, - Next); - This.Do_Insert_Task (Prev, - Src_Copy, - Next, - New_Owner); - end; - end; - end Do_Move_Task_Changing_Owner; - - ---------------------------------------- - -- Do_Guided_Move_Task_Changing_Owner -- - ---------------------------------------- - - procedure Do_Guided_Move_Task_Changing_Owner (This : in out Object; - Undo : out Undo_Info) - is - U : Undo_Internal (Move_Task); - begin - if This.Num_Assigned_Tasks <= 1 then - This.Do_Identity (Undo); - return; - end if; - - U.Description := + "MOVE+GUIDED+OWNER"; - - declare - Worst_Agent : constant Agent_Id := - Agent_Id (+This.Minmax.Last_Element.Agent); - Src : Task_Context_Ptr := - This.Select_Random_Task (Agent_Tasks_Bag (Worst_Agent)); - Src_Copy : Task_Context := Task_Context (Src.all); - New_Owner : constant Agent_Id := - Agent_Id - (+ Agent_Context - (This.Select_Random_Context - (All_Agents).all).Agent_Name); - begin - This.Add_Undo_Move (Src, U); - Undo.Handle.Set (U); - This.Do_Remove_Task (Src); - - declare - Prev, Curr, Next : Task_Context_Ptr; - begin - This.Select_Random_Insertion - (Agent_Tasks_Bag (New_Owner), - Prev, - Curr, - Next); - This.Do_Insert_Task (Prev, - Src_Copy, - Next, - New_Owner); - end; - end; - end Do_Guided_Move_Task_Changing_Owner; - - ------------------- - -- Do_Swap_Order -- - ------------------- - - procedure Do_Swap_Order (This : in out Object; - Undo : out Undo_Info) - is - U : Undo_Internal (Move_Task); - begin - if This.Num_Assigned_Tasks <= 1 then - This.Do_Identity (Undo); - return; - end if; - - U.Description := + "SWAP ORDER"; - - declare - Src : Task_Context_Ptr := - This.Select_Random_Task (All_Assigned_Tasks); - Src_Copy : Task_Context := Task_Context (Src.all); - Next : constant Task_Context_Ptr := - This.Get_Task_Context (Src.Next); - begin - if Next /= null then - This.Add_Undo_Move (Src, U); - Undo.Handle.Set (U); - This.Do_Remove_Task (Src); - This.Do_Insert_Task (Next, - Src_Copy, - This.Get_Task_Context (Next.Next), - Agent_Id (Get_Attribute (Next, Owner))); - else - This.Do_Identity (Undo); - end if; - end; - end Do_Swap_Order; - - ------------------- - -- Do_Swap_Tasks -- - ------------------- - - procedure Do_Swap_Tasks (This : in out Object; - Undo : out Undo_Info) - is - U : Undo_Internal (Move_Task); - begin - if This.Num_Assigned_Tasks <= 2 then - This.Do_Identity (Undo); - return; - end if; - - U.Description := + "SWAP ANY"; - - declare - Src : Task_Context_Ptr := - This.Select_Random_Task (All_Assigned_Tasks); - Src_Copy : Task_Context := Task_Context (Src.all); - Prev_1 : constant Htn.Tasks.Task_id := Src.Prev; - Next_1 : constant Htn.Tasks.Task_id := Src.Next; - Owner_1 : constant Agent_Id := - Agent_Id (Get_Attribute (Src, Owner)); - begin - This.Add_Undo_Move (Src, U); - Undo.Handle.Set (U); - This.Do_Remove_Task (Src); - - declare - Target : Task_Context_Ptr; - - New_Prev, - New_Next : Task_Context_Ptr; - Watchdog : Natural := 0; - begin - loop - This.Select_Random_Insertion (All_Assigned_Tasks, - New_Prev, - Target, - New_Next); - exit when Target.Job /= Prev_1 and then - Target.Job /= Next_1; - Watchdog := Watchdog + 1; - if Watchdog > 100 then - raise Program_Error with "Moving target failed"; - end if; - end loop; - - declare - Target_Copy : Task_Context := Task_Context (Target.all); - New_Owner : constant Agent_Id := Get_Attribute (Target, Owner); - begin - Do_Insert_Task (This, - New_Prev, - Src_Copy, - New_Next, - New_Owner); - - This.Add_Undo_Move (Target, U); - Undo.Handle.Set (U); - This.Do_Remove_Task (Target); - - if Prev_1 /= No_Task then - declare - Prev : constant Task_Context_Ptr := - This.Get_Task_Context (Prev_1); - Next : constant Task_Context_Ptr := - This.Get_Task_Context (Prev.Next); - begin - This.Do_Insert_Task - (Prev, Target_Copy, Next, Owner_1); - end; - elsif Next_1 /= No_Task then - This.Do_Insert_Task - (This.Get_Task_Context - (This.Get_Task_Context (Next_1).Prev), - Target_Copy, - This.Get_Task_Context (Next_1), - Owner_1); - else - This.Do_Insert_Task - (null, Target_Copy, null, Owner_1); - end if; - end; - end; - end; - end Do_Swap_Tasks; - ---------------------- -- Descend_Removing -- ---------------------- @@ -1218,141 +616,6 @@ package body Agpl.Cr.Mutable_Assignment is end case; end Descend_Removing; - ----------------------- - -- Do_Switch_Or_Node -- - ----------------------- - - procedure Do_Switch_Or_Node (This : in out Object; - Undo : out Undo_Info) - is - U : Undo_Internal (Switch_Or_Node); - - Placeholder_Usable : Boolean := False; - Placeholder : Undo_Move_Task_Info; - - procedure Descend_Adding (Node : in Htn.Plan.Subplan) is - use Htn.Plan_Node; - begin - case Get_Kind (Node) is - when Task_Node => - if Get_Expanded (Node) then - -- Compound, do nothing: - Descend_Adding (Get_Expansion (Node)); - else - -- Create a new task and insert at random - declare - Tc : Task_Context; - begin - Tc.Job := Get_Task (Node).all.Get_Id; - if Placeholder_Usable then - Placeholder_Usable := False; - This.Do_Insert_Task - (This.Get_Task_Context (Placeholder.Was_After), - Tc, - This.Get_Task_Context (Placeholder.Was_Before), - + Placeholder.Owner_Was); - else - declare - Target : constant Task_Context_Ptr := - This.Select_Random_Task (All_Assigned_Tasks); - begin - This.Do_Insert_Task - (This.Get_Task_Context (Target.Prev), - Tc, - Target, - Get_Attribute (Target, Owner)); - end; - end if; - end; - end if; - when And_Node => - declare - Children : constant Node_Vectors.Vector := - Get_Children (Node); - begin - for I in Children.First_Index .. Children.Last_Index loop - Descend_Adding (Children.Element (I)); - end loop; - end; - when Or_Node => - declare - Oc : Or_Context := - (Solution_Context with - Node => Node, - Branch => Node_Vectors.Element - (Get_Children (Node), - (Random.Get_Integer - (Node_Vectors.First_Index (Get_Children (Node)), - Node_Vectors.Last_Index (Get_Children (Node)))))); - begin - This.Add_To_Bag (Oc, All_Active_Or_Nodes); - This.Contexts.Insert (Oc.Key, Oc); - end; - end case; - end Descend_Adding; - - use Htn.Plan_Node; - begin - if This.Bag_Length (All_Active_Or_Nodes) < 1 then - This.Do_Identity (Undo); - return; - end if; - - declare - Target : constant Solution_Context_Ptr := - This.Select_Random_Context (All_Active_Or_Nodes); - Ctx : Or_Context renames Or_Context (Target.all); - - Children : Node_Vectors.Vector := Get_Children (Ctx.Node); - begin - - if Children.Length <= 1 then - This.Do_Identity (Undo); - return; - end if; - - U.Description := + "SWITCH OR-NODE"; - - Log ("GOING TO SWITCH", Never); - - loop - declare - New_Child : constant Htn.Plan.Subplan := - Children.Element - (Random.Get_Integer - (Children.First_Index, Children.Last_Index)); - pragma Unbounded_Time; - begin - if New_Child /= Ctx.Branch then - U.Actived_Or_Branch := New_Child; - This.Descend_Removing (Ctx.Branch, U); - - -- in 50% ocassions, we reuse the place were the switched task was: - if Random.Get_Integer (0, 1) = 1 then - Placeholder_Usable := True; - Placeholder := U.Or_Stack.Vector (U.Or_Stack.First); - end if; - - Descend_Adding (New_Child); - Ctx.Branch := New_Child; - exit; - end if; - end; - end loop; - - Undo.Handle.Set (U); - - if Expensive_Checks and then not This.Is_Sane then - raise Program_Error; - end if; - end; - exception - when others => - This.Context.Ref.Plan.Print_Tree_Summary; - This.Debug_Dump_Contexts; - raise; - end Do_Switch_Or_Node; - -------------------- -- Do_Remove_Task -- -------------------- @@ -1758,19 +1021,8 @@ package body Agpl.Cr.Mutable_Assignment is ------------------------ function Num_Assigned_Tasks (This : in Object) return Natural is - Len : Natural; - procedure Query (Key : Bag_Key; - Bag : Solution_Context_Bags.Object) - is - pragma Unreferenced (Key); - begin - Len := Bag.Length; - end Query; begin - Solution_Context_Bag_Maps.Query_Element - (This.Bags.Find (All_Assigned_Tasks), - Query'Access); - return Len; + return This.Bag_Length (All_Assigned_Tasks); end Num_Assigned_Tasks; --------- @@ -2202,6 +1454,7 @@ package body Agpl.Cr.Mutable_Assignment is A : constant Cr.Agent.Object'Class := Element (I); T : constant Htn.Tasks.Containers.Lists.List := A.Get_Tasks; J : Htn.Tasks.Containers.Lists.Cursor := T.First; + Prev : Htn.Tasks.Task_Id := No_Task; begin -- Create its task assignment and bag declare @@ -2213,34 +1466,55 @@ package body Agpl.Cr.Mutable_Assignment is This.Contexts.Insert (Agent_Key (A.Get_Name), Ag_Ctx); end; - -- Create task contexts + -- Create task contexts for tasks in our plan while Has_Element (J) loop - declare - C : aliased Task_Context; - begin - C.Job := Element (J).Get_Id; - if Has_Element (Previous (J)) then - C.Prev := Element (Previous (J)).Get_Id; - end if; - if Has_Element (Next (J)) then - C.Next := Element (Next (J)).Get_Id; - end if; - Set_Attribute (C'Access, Owner, Cr.Agent.Get_Name (A)); - - -- Add to all tasks - This.Add_To_Bag (C, All_Assigned_Tasks); - -- Add to its agent - This.Add_To_Bag (C, Agent_Tasks_Bag (A.Get_Name)); - - This.Contexts.Insert - (Solution_Context_Key (Task_Key (C.Job)), C); - - -- Create OR contexts - This.Add_Or_Contexts - (This.Context.Ref.Plan.Get_Node (C.Job)); - - Next (J); - end; + if This.Context.Ref.Plan.Contains (Element (J).Get_Id) and then + not Htn.Plan_Node.Get_Finished (This.Context.Ref.Plan.Get_Node + (Element (J).Get_Id)) + then + declare + C : aliased Task_Context; + function Next_Id (K : Task_Lists.Cursor) return Htn.Tasks.Task_Id + is + Plan : Htn.Plan.Object renames This.Context.Ref.Plan; + Nx : Task_Lists.Cursor := Next (K); + begin + if not Has_Element (Nx) then + return No_Task; + elsif Plan.Contains (Element (Nx).Get_Id) and then + not Htn.Plan_Node.Get_Finished + (Plan.Get_Node (Element (Nx).Get_Id)) + then + return Element (Nx).Get_Id; + else + return Next_Id (Nx); + pragma Optimization_Opportunity ("Unroll recursivity"); + end if; + end Next_Id; + begin + C.Job := Element (J).Get_Id; + C.Prev := Prev; + Prev := C.Job; + C.Next := Next_Id (J); + Set_Attribute (C'Access, Owner, Cr.Agent.Get_Name (A)); + + -- Add to all tasks + This.Add_To_Bag (C, All_Assigned_Tasks); + -- Add to its agent + This.Add_To_Bag (C, Agent_Tasks_Bag (A.Get_Name)); + + This.Contexts.Insert + (Solution_Context_Key (Task_Key (C.Job)), C); + + -- Create OR contexts + This.Add_Or_Contexts + (This.Context.Ref.Plan.Get_Node (C.Job)); + end; + else + Log ("Set assignment: discarding unplanned task", + Debug, Log_Section); + end if; + Next (J); end loop; end Process_Agent; @@ -2248,11 +1522,11 @@ package body Agpl.Cr.Mutable_Assignment is use Cr.Agent.Containers.Lists; use Htn.Tasks.Containers.Lists; A : constant Cr.Agent.Object'Class := Element (I); - T : constant Htn.Tasks.Containers.Lists.List := A.Get_Tasks; - J : Htn.Tasks.Containers.Lists.Cursor := First (T); + T : constant Task_Lists.List := A.Get_Tasks; + J : Task_Lists.Cursor := T.First; begin while Has_Element (J) loop - Pending_Tasks.Delete (Element (J).Get_Id); + Pending_Tasks.Exclude (Element (J).Get_Id); Next (J); end loop; end Remove_Agent_Tasks; @@ -2404,12 +1678,16 @@ package body Agpl.Cr.Mutable_Assignment is Plan : in Htn.Plan.Object; Assign : in Boolean := True) is - C : Static_Context_Access renames This.Context.Ref; + C : Static_Context_Access renames This.Context.Ref; + Prev_Ass : Assignment.Object; begin + if Assign then + Prev_Ass := This.To_Assignment; + end if; Clear_Dynamic_Part (This); C.Plan := Htn.Plan.Inflate (Plan); if Assign then - This.Set_Assignment (This.To_Assignment, + This.Set_Assignment (Prev_Ass, This.Context.Ref.Criterion); end if; end Set_Tasks; @@ -2529,121 +1807,6 @@ package body Agpl.Cr.Mutable_Assignment is null; end Undo_Identity; - -------------------- - -- Undo_Move_Task -- - -------------------- - - procedure Undo_Move_Task (This : in out Object; Undo : in Undo_Info) is - U : Undo_Internal renames Undo.Handle.Ref.all; - begin - case U.Kind is - when Identity => - null; - when Move_Task => - for I in reverse U.Move_Stack.First .. U.Move_Stack.Last loop - declare - Move : Undo_Move_Task_Info renames U.Move_Stack.Vector (I); - Src : Task_Context_Ptr := - This.Get_Task_Context (Move.Moved_One); - begin - This.Do_Move_Task - (After_This => This.Get_Task_Context (Move.Was_After), - Src => Src, - Before_This => This.Get_Task_Context (Move.Was_Before), - New_Owner => Agent_Id (+Move.Owner_Was)); - - if Move.Minsum_Was /= This.Minsum then - Log ("Cost was " & To_String (Move.Minsum_Was, 10) & - " but is " & To_String (This.Minsum, 10) & - " (" & To_String (This.Minsum - Move.Minsum_Was, 10) & ")", - Error, Log_Section); - -- Cr.Cost_Matrix.Print (This.Context.Ref.Costs); - This.Reevaluate_Costs; - -- raise Program_Error with "Undo breached cost integrity!"; - end if; - end; - end loop; - when others => - raise Program_Error; - end case; - end Undo_Move_Task; - - ----------------- - -- Undo_Switch -- - ----------------- - - procedure Undo_Switch (This : in out Object; Undo : in Undo_Info) is --- procedure Descend_Adding (Node : Htn.Subplan) is --- begin --- -- Re-add necessary or-nodes --- -- Re-insert necessary tasks. --- end Descend_Adding; - Dummy_Undo : Undo_Internal (Switch_Or_Node); - U : Undo_Internal renames Undo.Handle.Ref.all; - begin - Log ("UNDOING SWITCH", Debug, Detail_Section); - case U.Kind is - when Identity => - null; - when Switch_Or_Node => - This.Descend_Removing (U.Actived_Or_Branch, Dummy_Undo); - - -- Add all tasks: - for I in reverse U.Or_Stack.First .. U.Or_Stack.Last loop - declare - Tc : Task_Context; - begin - Tc.Job := U.Or_Stack.Vector (I).Moved_One; - This.Do_Insert_Task - (After_This => - This.Get_Task_Context - (U.Or_Stack.Vector (I).Was_After), - Src => Tc, - Before_This => - This.Get_Task_Context - (U.Or_Stack.Vector (I).Was_Before), - New_Owner => Agent_Id (+U.Or_Stack.Vector (I).Owner_Was)); - - This.Add_Or_Contexts (This.Context.Ref.Plan.Get_Node (Tc.Job)); - - if This.Minsum /= U.Or_Stack.Vector (I).Minsum_Was then - raise Program_Error - with "Undo (Switch) breached integrity; MinSum is" & - This.Minsum'Img & " but should be" & - U.Or_Stack.Vector (I).Minsum_Was'Img; - end if; - - if Expensive_Checks and then not This.Is_Sane then - raise Program_Error; - end if; - end; - end loop; - when others => - raise Program_Error; - end case; - - Log ("UNDONE SWITCH", Debug, Detail_Section); - end Undo_Switch; - - function Proper_Cost (This : in Costs) return Costs; - pragma Inline (Proper_Cost); - - ----------------- - -- Proper_Cost -- - ----------------- - - function Proper_Cost (This : in Costs) return Costs is - begin - if This = Infinite then - return Cost_For_Invalid_Task; - else - return This; - end if; - end Proper_Cost; - -- If a cost is infinite, turn it into zero. - -- Necessary for incremental evaluations of solutions since going to - -- Costs'Last will cause loss of the known cost. - ----------------------------- -- Evaluate_Cost_Inserting -- ----------------------------- @@ -2696,9 +1859,23 @@ package body Agpl.Cr.Mutable_Assignment is To_String (Plus_2, 10) & " " & To_String (Minus, 10), Debug, Detail_Section); - return Cr.Evaluate (This.Context.Ref.Criterion, - Minmax => Cost + Plus_1 + Plus_2 - Minus, - Minsum => Plus_1 + Plus_2 - Minus); + if Plus_1 = Cr.Infinite or else Plus_2 = Cr.Infinite then + return Cr.Infinite; + elsif Minus = Cr.Infinite then + raise Program_Error with "Minus shouldn't never equal Inf."; + else + return Cr.Evaluate (This.Context.Ref.Criterion, + Minmax => Cost + Plus_1 + Plus_2 - Minus, + Minsum => Plus_1 + Plus_2 - Minus); + end if; + exception + when E : others => + Log ("Evaluate_Cost_Inserting [Plus1/Plus2/Minus]: " & + Cr.Image (Plus_1) & " " & + Cr.Image (Plus_2) & " " & + Cr.Image (Minus), Error, Log_Section); + Log ("Exception: " & Report (E), Error, Log_Section); + raise; end Evaluate_Cost_Inserting; ---------------------------- diff --git a/agpl-cr-mutable_assignment.ads b/agpl-cr-mutable_assignment.ads index 0b8857e..961aa66 100644 --- a/agpl-cr-mutable_assignment.ads +++ b/agpl-cr-mutable_assignment.ads @@ -136,8 +136,8 @@ package Agpl.Cr.Mutable_Assignment is -- *HOWEVER* the Costs must contemplate the starting task! -- All dynamic data structures will be -- cleared. You should call Create_Some_Solution or To_Assignment - -- subsequently, unless Assign is true that causes: - -- This.Set_Assignment (This.To_Assignment); + -- subsequently, unless Assign is true that causes an initial greedy + -- assignment, trying to keep the previous assignment. procedure Create_Some_Solution (This : in out Object; Criterion : in Assignment_Criteria); @@ -165,72 +165,14 @@ package Agpl.Cr.Mutable_Assignment is procedure Undo_Identity (This : in out Object; Undo : in Undo_Info); -- Test mutation, does nothing! - procedure Undo_From_Scratch (This : in out Object; Undo : in Undo_Info); - -- Undo for heuristics - procedure Do_Heuristic_1 (This : in out Object; Undo : out Undo_Info); -- Will consider all agents and tasks to provide some "good" assignment. -- The current tasks are re-assigned in a "best pair" greedy fashion. -- So no OR node switchings happen. - procedure Do_Heuristic_2 (This : in out Object; - Undo : out Undo_Info); - -- This heuristic will consider the best of *all* tasks in every possible - -- expansion; freeze the plan with the chosen task; repeat until no more T. - - -- O (n^2) - procedure Do_Agent_Reorder (This : in out Object; - Undo : out Undo_Info); - -- Greedy reordering of an agent tasks - - -- O (log) - procedure Do_Auction_Task (This : in out Object; - Undo : out Undo_Info); - -- As undo, use the Undo_Move_Task - -- Cost is kept logaritmic checking only a log fraction of all insertion points. - - procedure Do_Guided_Auction_Task (This : in out Object; - Undo : out Undo_Info); - -- Guided in originating agent - -- As undo, use the Undo_Move_Task - - -- O (n) - procedure Do_Exhaustive_Auction_Task (This : in out Object; - Undo : out Undo_Info); - -- As undo, use the Undo_Move_Task - -- Will try all possible insertions - - -- O (log) - procedure Do_Move_Task (This : in out Object; - Undo : out Undo_Info); - procedure Undo_Move_Task (This : in out Object; Undo : in Undo_Info); - -- Will un-move all movements, in the Undo_Info stack, not just one. - - -- O (log) - procedure Do_Move_Task_Changing_Owner (This : in out Object; - Undo : out Undo_Info); - -- Moves a task at random, but choses the owner before hand. In this way, - -- no agent can end without tasks (as happens when just using Move_Task - -- As undo, use the Undo_Move_Task - - procedure Do_Guided_Move_Task_Changing_Owner (This : in out Object; - Undo : out Undo_Info); - -- Like previous, but task is chosen from the worst cost agent - - procedure Do_Swap_Order (This : in out Object; - Undo : out Undo_Info); - -- Switches two consecutive tasks - -- As undo, use the Undo_Move_Task - - procedure Do_Swap_Tasks (This : in out Object; - Undo : out Undo_Info); - -- Switches two arbitrary tasks - -- As undo, use the Undo_Move_Task - - procedure Do_Switch_Or_Node (This : in out Object; - Undo : out Undo_Info); - procedure Undo_Switch (This : in out Object; Undo : in Undo_Info); + procedure Undo_From_Scratch (This : in out Object; Undo : in Undo_Info); + -- Undo for heuristics ----------------- -- CONVERSIONS -- @@ -244,6 +186,7 @@ package Agpl.Cr.Mutable_Assignment is Criterion : in Assignment_Criteria); -- The assignment given will be used as current solution. -- Any unassigned tasks will be greedily inserted in arbitrary order. + -- Any tasks in Ass but not in This.Plan will be discarded. -- The criterion is used only for previously unassigned tasks. -- The dynamic structures will be prepared. @@ -505,6 +448,8 @@ private -- Can be expensive, use it only for debugging. -- TASKS -- + No_Task : Htn.Tasks.Task_Id renames Htn.Tasks.No_Task; + procedure Adjust_Chain_Removing (This : in out Object; Job : in Task_Context_Ptr); procedure Adjust_Chain_Inserting (This : in out Object; diff --git a/agpl-optimization-annealing-solver.adb b/agpl-optimization-annealing-solver.adb index cb587d7..9dc32dc 100644 --- a/agpl-optimization-annealing-solver.adb +++ b/agpl-optimization-annealing-solver.adb @@ -202,24 +202,24 @@ package body Agpl.Optimization.Annealing.Solver is To_String (Float (M.Accepted) * 100.0 / Float (Total_Good)) & "%/" & To_String (Float (M.Taken) * 100.0 / Float (Total_Moves)) & "%", - Always, Log_Section); + Informative, Log_Section); end Do_Inform; begin Stats.Iterate (Do_Count'Access); - Log ("", Always, Log_Section); + Log ("", Informative, Log_Section); Stats.Iterate (Do_Inform'Access); - Log ("", Always, Log_Section); + Log ("", Informative, Log_Section); Log ("TOTAL MOVES (accept/total): " & To_String (Total_Good) & "/" & To_String (Total_Moves) & " (" & To_String (Float (Total_Good) * 100.0 / Float (Total_Moves)) & "%)", - Always, Log_Section); + Informative, Log_Section); - Log ("", Always, Log_Section); + Log ("", Informative, Log_Section); end Print_Stats; -----------------