Skip to content

Commit

Permalink
M agpl-cr-mutable_assignment.adb
Browse files Browse the repository at this point in the history 
M    agpl-cr-mutable_assignment.ads
  • Loading branch information
@mosteo
mosteo committed Sep 12, 2006
1 parent 0b211a9 commit 904696e
Show file tree
Hide file tree
Showing 2 changed files with 67 additions and 42 deletions.
85 changes: 55 additions & 30 deletions agpl-cr-mutable_assignment.adb
View file
Original file line number Diff line number Diff line change
Expand Up @@ -379,7 +379,7 @@ package body Agpl.Cr.Mutable_Assignment is

procedure Do_Heuristic_1 (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info)
Undo : in out Undo_Info)
is
A : Cr.Assignment.Object := This.To_Assignment;
begin
Expand Down Expand Up @@ -411,7 +411,7 @@ package body Agpl.Cr.Mutable_Assignment is

procedure Do_Heuristic_2 (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info)
Undo : in out Undo_Info)
is
begin
Undo.Ass := This.To_Assignment;
Expand Down Expand Up @@ -447,16 +447,16 @@ package body Agpl.Cr.Mutable_Assignment is

procedure Do_Agent_Reorder (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info)
Undo : in out Undo_Info)
is
Agent : constant Agent_Id :=
Agent_Id
(+Agent_Context
(This.Select_Random_Context (All_Agents).all).Agent_Name);
begin
Desc := +"AGENT REORDER N²";
Log ("Reordering agent", Always);
This.To_Assignment.Print_Assignment;
-- Log ("Reordering agent", Always);
-- This.To_Assignment.Print_Assignment;

declare
New_Ass : Assignment.Object := This.To_Assignment;
Expand All @@ -465,7 +465,7 @@ package body Agpl.Cr.Mutable_Assignment is
U : Undo_Info;
begin
U.Ass := New_Ass;
Undo.Ass := New_Ass;
Undo := U;
Ag.Clear_Tasks;
while not Tasks.Is_Empty loop
declare
Expand All @@ -489,7 +489,7 @@ package body Agpl.Cr.Mutable_Assignment is
end loop;
New_Ass.Set_Agent (Ag);
New_Ass.Set_Valid;
New_Ass.Print_Summary;
-- New_Ass.Print_Summary;
This.Set_Assignment (New_Ass, This.Context.Ref.Criterion);
end;
end Do_Agent_Reorder;
Expand Down Expand Up @@ -602,7 +602,7 @@ package body Agpl.Cr.Mutable_Assignment is

procedure Do_Auction_Task (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info)
Undo : in out Undo_Info)
is
begin
if This.Num_Assigned_Tasks <= 1 then
Expand Down Expand Up @@ -647,6 +647,7 @@ package body Agpl.Cr.Mutable_Assignment is
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;
Expand All @@ -655,10 +656,19 @@ package body Agpl.Cr.Mutable_Assignment is
end if;
end;
end loop;
This.Do_Insert_Task (Best_Prev,
Src_Copy,
Best_Next,
Agent_Id (+Best_Name));

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 (Desc, Undo);
end if;
end;
end Do_Auction_Task;

Expand All @@ -668,7 +678,7 @@ package body Agpl.Cr.Mutable_Assignment is

procedure Do_Guided_Auction_Task (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info)
Undo : in out Undo_Info)
is
begin
if This.Num_Assigned_Tasks <= 1 then
Expand All @@ -682,6 +692,8 @@ package body Agpl.Cr.Mutable_Assignment is
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);
Expand All @@ -706,7 +718,7 @@ package body Agpl.Cr.Mutable_Assignment is
Curr_Next : Task_Context_Ptr;
Curr_Cost : Costs;
begin
This.Select_Random_Insertion (Agent_Tasks_Bag (Worst_Agent),
This.Select_Random_Insertion (Agent_Tasks_Bag (Best_Agent),
Curr_Prev,
Curr_Target,
Curr_Next);
Expand All @@ -723,10 +735,18 @@ package body Agpl.Cr.Mutable_Assignment is
end if;
end;
end loop;
This.Do_Insert_Task (Best_Prev,
Src_Copy,
Best_Next,
Agent_Id (+Best_Name));
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 (Desc, Undo);
end if;
end;
end Do_Guided_Auction_Task;

Expand All @@ -736,7 +756,7 @@ package body Agpl.Cr.Mutable_Assignment is

procedure Do_Move_Task (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info)
Undo : in out Undo_Info)
is
Src : Task_Context_Ptr :=
This.Select_Random_Task (All_Assigned_Tasks);
Expand Down Expand Up @@ -780,7 +800,7 @@ package body Agpl.Cr.Mutable_Assignment is

procedure Do_Move_Task_Changing_Owner (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info)
Undo : in out Undo_Info)
is
begin
if This.Num_Assigned_Tasks <= 1 then
Expand Down Expand Up @@ -827,7 +847,7 @@ package body Agpl.Cr.Mutable_Assignment is

procedure Do_Guided_Move_Task_Changing_Owner (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info)
Undo : in out Undo_Info)
is
begin
if This.Num_Assigned_Tasks <= 1 then
Expand Down Expand Up @@ -874,7 +894,7 @@ package body Agpl.Cr.Mutable_Assignment is

procedure Do_Swap_Order (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info) is
Undo : in out Undo_Info) is
begin
if This.Num_Assigned_Tasks <= 1 then
Do_Identity (This, Desc, Undo);
Expand Down Expand Up @@ -909,7 +929,7 @@ package body Agpl.Cr.Mutable_Assignment is

procedure Do_Swap_Tasks (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info) is
Undo : in out Undo_Info) is
begin
if This.Num_Assigned_Tasks <= 2 then
Do_Identity (This, Desc, Undo);
Expand Down Expand Up @@ -1251,6 +1271,8 @@ package body Agpl.Cr.Mutable_Assignment is
This.Last_Mutation_Exists := True;
This.Last_Mutation_Undo.Was_Valid := This.Valid;

-- This.Debug_Dump_Contexts;

M.Vector (I).Doer (This,
This.Last_Mutation_Description,
This.Last_Mutation_Undo);
Expand Down Expand Up @@ -1633,9 +1655,9 @@ package body Agpl.Cr.Mutable_Assignment is
-----------

procedure Reset (This : in out Undo_Info) is
Empty_Undo : Undo_Info;
begin
This.Ass.Clear;
This.Move_Stack.Clear;
This := Empty_Undo;
end Reset;

-----------------------------
Expand Down Expand Up @@ -1825,7 +1847,7 @@ package body Agpl.Cr.Mutable_Assignment is
-- in some greedy fashion.

Log ("There are" & Pending_Tasks.Length'Img & " new pending tasks.",
Debug, Log_Section);
Debug, Detail_Section);

-- Do something with unassigned plan tasks
while not Pending_Tasks.Is_Empty loop
Expand Down Expand Up @@ -1915,6 +1937,11 @@ package body Agpl.Cr.Mutable_Assignment is
is
use Attribute_Maps;
begin
if Attr = Owner then
if Val = "" then
raise Program_Error;
end if;
end if;
Include (Context.Attributes, Attr, Val);
end Set_Attribute;

Expand Down Expand Up @@ -1956,9 +1983,7 @@ package body Agpl.Cr.Mutable_Assignment is
-- Locate any:
while Has_Element (I) loop
if Element (I) in Task_Context then
if Get_Attribute (Element (I), Owner) = String (Agent) and then
Element (I) in Task_Context
then
if Get_Attribute (Element (I), Owner) = String (Agent) then
Curr := Task_Context (Element (I));
Found := True;
exit;
Expand Down Expand Up @@ -2025,7 +2050,7 @@ package body Agpl.Cr.Mutable_Assignment is
Undo : in Undo_Info)
is
begin
Log ("Undoing from scratch", Always, Section => Detail_Section);
Log ("Undoing from scratch", Debug, Section => Detail_Section);
Set_Assignment (This, Undo.Ass, This.Context.Ref.Criterion);
end Undo_From_Scratch;

Expand Down
24 changes: 12 additions & 12 deletions agpl-cr-mutable_assignment.ads
View file
Original file line number Diff line number Diff line change
Expand Up @@ -66,7 +66,7 @@ package Agpl.Cr.Mutable_Assignment is

type Mutation_Doer is access procedure (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info);
Undo : in out Undo_Info);

type Mutation_Undoer is access procedure (This : in out Object;
Undo : in Undo_Info);
Expand Down Expand Up @@ -164,65 +164,65 @@ package Agpl.Cr.Mutable_Assignment is

procedure Do_Heuristic_1 (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info);
Undo : in 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;
Desc : out Ustring;
Undo : out Undo_Info);
Undo : in 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;
Desc : out Ustring;
Undo : out Undo_Info);
Undo : in out Undo_Info);
-- Greedy reordering of an agent tasks

-- O (log)
procedure Do_Auction_Task (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info);
Undo : in 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;
Desc : out Ustring;
Undo : out Undo_Info);
-- Guided in both originating agent and inserting agent
Undo : in out Undo_Info);
-- Guided in originating agent
-- As undo, use the Undo_Move_Task

-- O (log)
procedure Do_Move_Task (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info);
Undo : in 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;
Desc : out Ustring;
Undo : out Undo_Info);
Undo : in 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;
Desc : out Ustring;
Undo : out Undo_Info);
Undo : in out Undo_Info);
-- Like previous, but task is chosen from the worst cost agent

procedure Do_Swap_Order (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info);
Undo : in out Undo_Info);
-- Switches two consecutive tasks
-- As undo, use the Undo_Move_Task

procedure Do_Swap_Tasks (This : in out Object;
Desc : out Ustring;
Undo : out Undo_Info);
Undo : in out Undo_Info);
-- Switches two arbitrary tasks
-- As undo, use the Undo_Move_Task

Expand Down

0 comments on commit 904696e

Please sign in to comment.