diff options
Diffstat (limited to 'src/kompsos.adb')
| -rw-r--r-- | src/kompsos.adb | 204 |
1 files changed, 82 insertions, 122 deletions
diff --git a/src/kompsos.adb b/src/kompsos.adb index 3981005..b2ff1a2 100644 --- a/src/kompsos.adb +++ b/src/kompsos.adb @@ -56,34 +56,34 @@ package body Kompsos is - -- Worlds -- + -- Mu_Worlds -- - procedure Free is new Ada.Unchecked_Deallocation (World, World_Access); + procedure Free is new Ada.Unchecked_Deallocation (Mu_World'Class, World_Access); procedure Adjust - (This : in out World) is + (This : in out Mu_World) is begin case This.Engine.Kind is when No_Gen => null; when Fresh_Gen => - This.Engine.FrG_World := new World'(This.Engine.FrG_World.all); + This.Engine.FrG_World := new Mu_World'Class'(This.Engine.FrG_World.all); when Unify_Gen => - This.Engine.UniG_World := new World'(This.Engine.UniG_World.all); + This.Engine.UniG_World := new Mu_World'Class'(This.Engine.UniG_World.all); when Disjunct1_Gen => - This.Engine.Dis1G_World := new World'(This.Engine.Dis1G_World.all); + This.Engine.Dis1G_World := new Mu_World'Class'(This.Engine.Dis1G_World.all); when Disjunct2_Gen => - This.Engine.Dis2G_World1 := new World'(This.Engine.Dis2G_World1.all); - This.Engine.Dis2G_World2 := new World'(This.Engine.Dis2G_World2.all); + This.Engine.Dis2G_World1 := new Mu_World'Class'(This.Engine.Dis2G_World1.all); + This.Engine.Dis2G_World2 := new Mu_World'Class'(This.Engine.Dis2G_World2.all); when Recurse_Gen => - This.Engine.RecG_World := new World'(This.Engine.RecG_World.all); + This.Engine.RecG_World := new Mu_World'Class'(This.Engine.RecG_World.all); end case; end Adjust; procedure Finalize - (This : in out World) is + (This : in out Mu_World) is begin case This.Engine.Kind is when No_Gen => @@ -160,15 +160,15 @@ package body Kompsos is function T - (Item1, Item2 : in Term) + (Item1, Item2 : in Term'Class) return Term is begin return My_Term : Term do My_Term.Actual := new Term_Component'( Kind => Pair_Term, Count => 1, - Left => Item1, - Right => Item2); + Left => Term (Item1), + Right => Term (Item2)); end return; end T; @@ -348,7 +348,7 @@ package body Kompsos is -- Lazy World Generation -- function Has_State - (This : in out World; + (This : in out Mu_World; Index : in Positive) return Boolean is begin @@ -358,7 +358,7 @@ package body Kompsos is procedure Roll_Fresh_Gen - (This : in out World) is + (This : in out Mu_World) is begin This.Engine.FrG_World.Rollover; if This.Engine.FrG_World.Possibles.Last_Index < This.Engine.FrG_Index then @@ -376,7 +376,7 @@ package body Kompsos is procedure Roll_Unify_Gen - (This : in out World) + (This : in out Mu_World) is Extended : State; begin @@ -402,7 +402,7 @@ package body Kompsos is procedure Roll_Disjunct1_Gen - (This : in out World) is + (This : in out Mu_World) is begin This.Engine.Dis1G_World.Rollover; if This.Engine.Dis1G_World.Possibles.Last_Index < This.Engine.Dis1G_Index then @@ -417,7 +417,7 @@ package body Kompsos is procedure Roll_Disjunct2_Gen - (This : in out World) + (This : in out Mu_World) is Temp_World : World_Access; Temp_Index : Positive; @@ -445,7 +445,7 @@ package body Kompsos is procedure Roll_Recurse_Gen - (This : in out World) is + (This : in out Mu_World) is begin This.Engine.RecG_World.Rollover; if This.Engine.RecG_World.Possibles.Last_Index < This.Engine.RecG_Index then @@ -467,7 +467,7 @@ package body Kompsos is -- This is intentional to get better behaviour with infinite Worlds. procedure Rollover - (This : in out World) is + (This : in out Mu_World) is begin case This.Engine.Kind is when No_Gen => null; @@ -481,7 +481,7 @@ package body Kompsos is procedure Roll_Until - (This : in out World; + (This : in out Mu_World; Index : in Positive) is begin while This.Possibles.Last_Index < Index and This.Engine.Kind /= No_Gen loop @@ -496,51 +496,38 @@ package body Kompsos is -- Public API Operations -- ----------------------------- - -- Query -- - - function Failed - (This : in out World) - return Boolean is - begin - return not This.Has_State (1); - end Failed; - - - - -- Fresh -- function Fresh - (This : in out World) - return Variable is + (This : in out Mu_World'Class) + return Term is begin return This.Fresh (+""); end Fresh; function Fresh - (This : in out World; + (This : in out Mu_World'Class; Name : in String) - return Variable is + return Term is begin return This.Fresh (+Name); end Fresh; function Fresh - (This : in out World; + (This : in out Mu_World'Class; Name : in Ada.Strings.Unbounded.Unbounded_String) - return Variable is + return Term is begin - return My_Var : constant Variable := (Ident => This.Next_Ident, Name => Name) do - This := (Ada.Finalization.Controlled with - Possibles => State_Vectors.Empty_Vector, - Next_Ident => This.Next_Ident + 1, - Engine => - (Kind => Fresh_Gen, - FrG_World => new World'(This), - FrG_Index => 1, - FrG_Name => Name)); + return My_Term : constant Term := T (Variable'(Ident => This.Next_Ident, Name => Name)) do + This.Engine := + (Kind => Fresh_Gen, + FrG_World => new Mu_World'Class'(This), + FrG_Index => 1, + FrG_Name => Name); + This.Next_Ident := This.Next_Ident + 1; + This.Possibles := State_Vectors.Empty_Vector; end return; end Fresh; @@ -550,71 +537,35 @@ package body Kompsos is -- Unify -- function Unify - (This : in World; - Left : in Variable; + (This : in Mu_World; + Left : in Term'Class; Right : in Element_Type) - return World is + return Mu_World is begin - return This.Unify (T (Left), T (Right)); + return This.Unify (Left, T (Right)); end Unify; procedure Unify - (This : in out World; - Left : in Variable; + (This : in out Mu_World; + Left : in Term'Class; Right : in Element_Type) is begin - This := This.Unify (T (Left), T (Right)); - end Unify; - - - function Unify - (This : in World; - Left, Right : in Variable) - return World is - begin - return This.Unify (T (Left), T (Right)); - end Unify; - - - procedure Unify - (This : in out World; - Left, Right : in Variable) is - begin - This := This.Unify (T (Left), T (Right)); + This := This.Unify (Left, T (Right)); end Unify; function Unify - (This : in World; - Left : in Variable; - Right : in Term'Class) - return World is - begin - return This.Unify (T (Left), Right); - end Unify; - - - procedure Unify - (This : in out World; - Left : in Variable; - Right : in Term'Class) is - begin - This := This.Unify (T (Left), Right); - end Unify; - - - function Unify - (This : in World; + (This : in Mu_World; Left, Right : in Term'Class) - return World is + return Mu_World is begin - return Result : constant World := (Ada.Finalization.Controlled with + return Result : constant Mu_World := (Ada.Finalization.Controlled with Possibles => State_Vectors.Empty_Vector, Next_Ident => This.Next_Ident, Engine => (Kind => Unify_Gen, - UniG_World => new World'(This), + UniG_World => new Mu_World'(This), UniG_Index => 1, UniG_Term1 => Term (Left), UniG_Term2 => Term (Right))); @@ -622,7 +573,7 @@ package body Kompsos is procedure Unify - (This : in out World; + (This : in out Mu_World; Left, Right : in Term'Class) is begin This := This.Unify (Left, Right); @@ -634,49 +585,50 @@ package body Kompsos is -- Disjunct -- function Disjunct - (Left, Right : in World) - return World is + (Left, Right : in Mu_World) + return Mu_World is begin - return Result : constant World := (Ada.Finalization.Controlled with + return Result : constant Mu_World := (Ada.Finalization.Controlled with Possibles => State_Vectors.Empty_Vector, Next_Ident => ID_Number'Max (Left.Next_Ident, Right.Next_Ident), Engine => (Kind => Disjunct2_Gen, - Dis2G_World1 => new World'(Left), + Dis2G_World1 => new Mu_World'(Left), Dis2G_Index1 => 1, - Dis2G_World2 => new World'(Right), + Dis2G_World2 => new Mu_World'(Right), Dis2G_Index2 => 1)); end Disjunct; procedure Disjunct - (This : in out World; - Right : in World) is + (This : in out Mu_World; + Right : in Mu_World) is begin This := Disjunct (This, Right); end Disjunct; function Disjunct - (Inputs : in World_Array) - return World is + (Inputs : in Mu_World_Array) + return Mu_World is begin if Inputs'Length = 0 then - return Failed : constant World := (Ada.Finalization.Controlled with + return Failed : constant Mu_World := (Ada.Finalization.Controlled with Possibles => State_Vectors.Empty_Vector, Next_Ident => 0, Engine => (Kind => No_Gen)); elsif Inputs'Length = 1 then return Inputs (Inputs'First); else - return Result : World := (Ada.Finalization.Controlled with + return Result : Mu_World := (Ada.Finalization.Controlled with Possibles => State_Vectors.Empty_Vector, Next_Ident => 0, -- dummy Engine => (Kind => Disjunct2_Gen, - Dis2G_World1 => new World'(Inputs (Inputs'First)), + Dis2G_World1 => new Mu_World'(Inputs (Inputs'First)), Dis2G_Index1 => 1, - Dis2G_World2 => new World'(Disjunct (Inputs (Inputs'First + 1 .. Inputs'Last))), + Dis2G_World2 => + new Mu_World'(Disjunct (Inputs (Inputs'First + 1 .. Inputs'Last))), Dis2G_Index2 => 1)) do Result.Next_Ident := ID_Number'Max @@ -688,8 +640,8 @@ package body Kompsos is procedure Disjunct - (This : in out World; - Inputs : in World_Array) is + (This : in out Mu_World; + Inputs : in Mu_World_Array) is begin This := Disjunct (This & Inputs); end Disjunct; @@ -700,21 +652,21 @@ package body Kompsos is -- Recurse -- function Recurse - (This : in World) - return World is + (This : in Mu_World) + return Mu_World is begin - return Result : constant World := (Ada.Finalization.Controlled with + return Result : constant Mu_World := (Ada.Finalization.Controlled with Possibles => State_Vectors.Empty_Vector, Next_Ident => This.Next_Ident, Engine => (Kind => Recurse_Gen, - RecG_World => new World'(This), + RecG_World => new Mu_World'(This), RecG_Index => 1)); end Recurse; procedure Recurse - (This : in out World) is + (This : in out Mu_World) is begin This := This.Recurse; end Recurse; @@ -725,9 +677,9 @@ package body Kompsos is -- Forced Evaluation -- function Take - (This : in World; + (This : in Mu_World; Count : in Natural) - return World is + return Mu_World is begin if Count = 0 then return (Ada.Finalization.Controlled with @@ -735,7 +687,7 @@ package body Kompsos is Next_Ident => ID_Number'First, Engine => (Kind => No_Gen)); end if; - return Result : World := This do + return Result : Mu_World := This do Result.Roll_Until (Count); if Result.Possibles.Last_Index > Count then Result.Possibles.Set_Length (Ada.Containers.Count_Type (Count)); @@ -746,7 +698,7 @@ package body Kompsos is procedure Take - (This : in out World; + (This : in out Mu_World; Count : in Natural) is begin This := This.Take (Count); @@ -754,7 +706,7 @@ package body Kompsos is procedure Force - (This : in out World; + (This : in out Mu_World; Count : in Positive) is begin This.Roll_Until (Count); @@ -762,7 +714,7 @@ package body Kompsos is procedure Force_All - (This : in out World) is + (This : in out Mu_World) is begin while This.Engine.Kind /= No_Gen loop This.Rollover; @@ -770,6 +722,14 @@ package body Kompsos is end Force_All; + function Failed + (This : in out Mu_World) + return Boolean is + begin + return not This.Has_State (1); + end Failed; + + end Kompsos; |