Skip to content

Commit

Permalink
M concorde/agpl-optimization-concorde.adb
Browse files Browse the repository at this point in the history 
M    agpl-cr.ads
M    agpl-cr-assignment.adb
M    agpl-cr-assigner-greedy_fifo_tail.adb
M    agpl-cr-mutable_assignment.adb
M    agpl-cr-mutable_assignment.ads
  • Loading branch information
@mosteo
mosteo committed Sep 7, 2006
1 parent 9728e9f commit cd0419c
Show file tree
Hide file tree
Showing 6 changed files with 216 additions and 17 deletions.
2 changes: 2 additions & 0 deletions agpl-cr-assigner-greedy_fifo_tail.adb
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,6 +52,8 @@ package body Agpl.Cr.Assigner.Greedy_Fifo_Tail is
Costs : in Cr.Cost_Matrix.Object)
return Assignment.Object
is
pragma Unreferenced (This);

A : Assignment.Object;
-- The result we'll return.

Expand Down
7 changes: 7 additions & 0 deletions agpl-cr-assignment.adb
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,7 @@
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
------------------------------------------------------------------------------

with Agpl.Conversions;
with Agpl.Trace; use Agpl.Trace;

-- with Agpl.Cr.Agent.Handle;
Expand All @@ -32,6 +33,8 @@ with Agpl.Htn.Tasks.Utils;

package body Agpl.Cr.Assignment is

function To_String is new Conversions.To_Str (Costs);

---------
-- Add --
---------
Expand Down Expand Up @@ -467,6 +470,10 @@ package body Agpl.Cr.Assignment is
Next (I);
Log ("", Always);
end loop;

Log ("MinSum cost: " & To_String (This.Get_Cummulative_Cost), Always);
Log ("MinMax cost: " & To_String (This.Get_Max_Min_Cost), Always);
Log ("", Always);
end;
end Print_Assignment;

Expand Down
153 changes: 144 additions & 9 deletions agpl-cr-mutable_assignment.adb
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,8 +40,8 @@ with Agpl.Cr.Tasks.Insertions;
with Agpl.Htn.Plan_Node;
with Agpl.Htn.Plan.Utils;
with Agpl.Htn.Plan.Utils.Random;
with Agpl.Htn.Tasks.Containers;
with Agpl.Htn.Tasks.Maps;
with Agpl.If_Function;
with Agpl.Random;
with Agpl.Trace; use Agpl.Trace;

Expand Down Expand Up @@ -313,6 +313,77 @@ package body Agpl.Cr.Mutable_Assignment is
Log (Report (E), Warning);
end Do_Heuristic_2;

------------------
-- Do_Move_Task --
------------------

procedure Do_Move_Task (This : in out Object;
Src : in Task_Context_Access;
Bfr : in Task_Context_Access;
New_Owner : in Ustring)
is
function Coalesce is new If_Function (Task_Context_Access);
begin
Set_Attribute (Solution_Context_Pointer (Src), Owner, +New_Owner);

This.Update_Costs_Removing (This.Get_Task_Context (Src.Prev),
Src,
This.Get_Task_Context (Src.Next));

This.Update_Costs_Inserting
(Coalesce (Bfr /= null, This.Get_Task_Context (Bfr.Prev), null),
Src,
Bfr);
end Do_Move_Task;

------------------
-- Do_Move_Task --
------------------

procedure Do_Move_Task (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info)
is
procedure Do_It (Key : in Bag_Key;
Tasks : in out Solution_Context_Bags.Object)
is
pragma Unreferenced (Key);
Src_Idx : constant Positive :=
Random.Get_Integer (Tasks.First, Tasks.Last);
Src : constant Task_Context_Access :=
Task_Context_Access
(Tasks.Vector (Src_Idx).Ref);

Dst_Idx : Positive;
Dst : Task_Context_Access;

Undo_Move : Undo_Move_Task_Info;
begin
loop
Dst_Idx := Random.Get_Integer (Tasks.First, Tasks.Last);
exit when Dst_Idx /= Src_Idx;
end loop;
Dst := Task_Context_Access (Tasks.Vector (Dst_Idx).Ref);

Desc := + ("Move" & Src.Job'Img & " before" & Dst.Job'Img);
Undo_Move.Moved_One := Src.Job;
Undo_Move.Was_Before := Src.Next;
Undo.Move_Stack.Append (Undo_Move);

This.Do_Move_Task (Src,
This.Get_Task_Context (Dst.Next),
+Get_Attribute
(Solution_Context_Pointer (Dst), Owner));
end Do_It;
begin
if This.Num_Assigned_Tasks <= 1 then
Do_Identity (This, Desc, Undo);
else
This.Bags.Update_Element
(This.Bags.Find (All_Assigned_Tasks), Do_It'Access);
end if;
end Do_Move_Task;

-----------------
-- Do_Identity --
-----------------
Expand Down Expand Up @@ -400,7 +471,7 @@ package body Agpl.Cr.Mutable_Assignment is
function Evaluate_Minimax (This : in Object) return Costs is
begin
if This.Valid then
return This.Minimax.Last_Element.Cost;
return This.MinMax.Last_Element.Cost;
else
return Infinite;
end if;
Expand All @@ -413,7 +484,7 @@ package body Agpl.Cr.Mutable_Assignment is
function Evaluate_Totalsum (This : in Object) return Costs is
begin
if This.Valid then
return This.Totalsum;
return This.MinSum;
else
return Infinite;
end if;
Expand All @@ -431,6 +502,26 @@ package body Agpl.Cr.Mutable_Assignment is
return Element (Find (This.Attributes, Attr));
end Get_Attribute;

----------------------
-- Get_Task_Context --
----------------------

function Get_Task_Context (This : in Object;
Id : in Htn.Tasks.Task_Id)
return Task_Context_Access
is
use Solution_Context_Maps;
use Htn.Tasks;
begin
if Id = No_Task then
return null;
else
return Task_Context_Access
(Element
(This.Contexts.Find (Task_Key (Id))).Ref);
end if;
end Get_Task_Context;

----------------
-- Initialize --
----------------
Expand Down Expand Up @@ -566,6 +657,26 @@ package body Agpl.Cr.Mutable_Assignment is
raise;
end Normalize;

------------------------
-- Num_Assigned_Tasks --
------------------------

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;
end Num_Assigned_Tasks;

--------------------
-- Reassign_Tasks --
--------------------
Expand Down Expand Up @@ -643,17 +754,17 @@ package body Agpl.Cr.Mutable_Assignment is
Id : constant Agent_Id := Agent_Sets.Element (I);
Cost : constant Costs := Reevaluate_Agent_Cost (This, Id);
begin
This.Minimax.Insert ((Cost, +String (Id)));
This.MinMax.Insert ((Cost, +String (Id)));
This.Agent_Costs.Insert (Id, Cost);
end Ev;
begin
This.Totalsum := Reevaluate_Totalsum (This);
This.MinSum := Reevaluate_Totalsum (This);

This.Minimax.Clear;
This.MinMax.Clear;
This.Agent_Costs.Clear;
Agent_Sets.Iterate (This.Context.Ref.Agents, Ev'Access);

This.Valid := This.Totalsum < Infinite;
This.Valid := This.MinSum < Infinite;
end Reevaluate_Costs;

------------------------
Expand Down Expand Up @@ -1063,6 +1174,29 @@ 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
begin
null;
end Undo_Move_Task;

----------------------------
-- Update_Costs_Inserting --
----------------------------

procedure Update_Costs_Inserting
(This : in out Object;
Prev_In_List : in Task_Context_Access;
Curr_To_Be_Inserted : in Task_Context_Access;
Next_In_List : in Task_Context_Access)
is
begin
null;
end Update_Costs_Inserting;

---------------------------
-- Update_Costs_Removing --
---------------------------
Expand All @@ -1088,7 +1222,7 @@ package body Agpl.Cr.Mutable_Assignment is
Pr, Ne : Htn.Tasks.Task_Id := No_Task;
begin
This.Agent_Costs.Delete (Agent);
This.Minimax.Delete ((Cost, +String (Agent)));
This.MinMax.Delete ((Cost, +String (Agent)));

if Prev /= null then
Pr := Prev.Job;
Expand All @@ -1115,7 +1249,8 @@ package body Agpl.Cr.Mutable_Assignment is
Cost := Cost - Minus_1 - Minus_2 + Plus;

This.Agent_Costs.Insert (Agent, Cost);
This.Minimax.Insert ((Cost, +String (Agent)));
This.MinMax.Insert ((Cost, +String (Agent)));
This.Minsum := This.Minsum - Minus_1 - Minus_2 + Plus;
end Update_Costs_Removing;

end Agpl.Cr.Mutable_Assignment;
57 changes: 51 additions & 6 deletions agpl-cr-mutable_assignment.ads
View file
Original file line number Diff line number Diff line change
Expand Up @@ -35,6 +35,7 @@ with Agpl.Cr.Cost_Matrix;
with Agpl.Dynamic_Vector;
with Agpl.Htn.Plan;
with Agpl.Htn.Tasks;
with Agpl.Htn.Tasks.Containers;
with Agpl.Optimization.Annealing;
with Agpl.Smart_Access; pragma Elaborate_All (Agpl.Smart_Access);
with Agpl.Types.Ustrings; use Agpl.Types.Ustrings;
Expand Down Expand Up @@ -174,6 +175,12 @@ package Agpl.Cr.Mutable_Assignment is
-- 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.

procedure Do_Move_Task (This : in out Object;
Desc : out Ustring;
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.

-----------------
-- CONVERSIONS --
-----------------
Expand All @@ -191,6 +198,8 @@ package Agpl.Cr.Mutable_Assignment is

private

package Task_Lists renames Htn.Tasks.Containers.Lists;

-- Each registered mutation to be used
type Mutation_Handler is record
Doer : Mutation_Doer;
Expand Down Expand Up @@ -306,8 +315,22 @@ private
procedure Undo_From_Scratch (This : in out Object;
Undo : in Undo_Info);

-- This record is used to store one moved task so it can be replaced
-- where it was.
type Undo_Move_Task_Info is record
Moved_One : Htn.Tasks.Task_Id;
Was_Before : Htn.Tasks.Task_Id := Htn.Tasks.No_Task;
-- No id for the last task
end record;

package Undo_Move_Vectors is
new Agpl.Dynamic_Vector (Undo_Move_Task_Info, 2);

type Undo_Info is record
Ass : Assignment.Object; -- For scratch starting

Move_Stack : Undo_Move_Vectors.Object (First => 1);
-- LIFO stack of moved tasks. To undo, just undo movements from tail to H
end record;

------------
Expand All @@ -332,8 +355,8 @@ private
-- All assigned tasks

-- The current solution costs
Totalsum : Costs;
Minimax : Cost_Agent_Sets.Set;
MinSum : Costs;
MinMax : Cost_Agent_Sets.Set;
Agent_Costs : Agent_Cost_Maps.Map;

-- Undo information
Expand Down Expand Up @@ -366,6 +389,25 @@ private
-- Check for data structures sanity
-- Can be expensive, use it only for debugging.

-- Tasks
function Num_Assigned_Tasks (This : in Object) return Natural;

procedure Do_Move_Task (This : in out Object;
Src : in Task_Context_Access;
Bfr : in Task_Context_Access;
New_Owner : in Ustring);
-- Move a task from one point to another
-- Must maintain all integrity: adjust costs, before/after links, ownership
-- New owner is necessary if Bfr is No_Task!

procedure Do_Remove_Task (This : in out Object;
Job : not null Task_Context_Access);
-- Remove this task from assignation; update all data structures accordingly

function Get_Task_Context (This : in Object;
Id : in Htn.Tasks.Task_Id)
return Task_Context_Access;

-- Attributes
function Get_Attribute (This : in Solution_Context_Pointer;
Attr : in Solution_Context_Attributes) return String;
Expand Down Expand Up @@ -400,10 +442,6 @@ private
procedure Remove_From_All_Bags (This : in out Object;
Context : in Solution_Context_Pointer);

procedure Do_Remove_Task (This : in out Object;
Job : not null Task_Context_Access);
-- Remove this task from assignation; update all data structures accordingly

procedure Moving_Solution_Context (Context : in out Solution_Context_Access;
Bag : in out Bag_Context;
Prev,
Expand All @@ -425,6 +463,13 @@ private
procedure Reevaluate_Costs (This : in out Object);
-- Recompute all costs from scratch and update internal cache

procedure Update_Costs_Inserting
(This : in out Object;
Prev_In_List : in Task_Context_Access;
Curr_To_Be_Inserted : in Task_Context_Access;
Next_In_List : in Task_Context_Access);
-- Update the costs of inserting the Curr task.

-- O (log R)
procedure Update_Costs_Removing
(This : in out Object;
Expand Down
Loading

0 comments on commit cd0419c

Please sign in to comment.