diff algorithm

difference.adb

with Ada.Unchecked_Deallocation;
with System.Pool_Local;
package body Difference is

	procedure Diff (
		Left, Right : in Container_Type;
		Notify : not null access procedure (
			Left_Low : Index_Type; Left_High : Index_Type'Base;
			Right_Low : Index_Type; Right_High : Index_Type'Base)) 
	is
		function "+" (Left : Index_Type'Base; Right : Length_Type'Base) return Index_Type'Base is
		begin
			return Index_Type'Base'Val (Index_Type'Base'Pos (Left) + Right);
		end "+";
		function "-" (Left : Index_Type'Base; Right : Length_Type'Base) return Index_Type'Base is
		begin
			return Index_Type'Base'Val (Index_Type'Base'Pos (Left) - Right);
		end "-";
		Fixed_Pool : Storage_Pool;
		Local_Pool : System.Pool_Local.Unbounded_Reclaim_Pool;
		type Path;
		type Path_Access is access Path;
		for Path_Access'Storage_Pool use Fixed_Pool;
		type Path is record
			Previous : Path_Access;
			X : Length_Type;
			Y : Length_Type;
			Count : Length_Type;
			Reference_Count : Natural;
		end record;
		procedure Release (X : in out Path_Access) is
			procedure Free is new Ada.Unchecked_Deallocation (Path, Path_Access);
		begin
			if X /= null then
				X.Reference_Count := X.Reference_Count - 1;
				if X.Reference_Count = 0 then
					declare
						Previous : Path_Access := X.Previous;
					begin
						Free (X);
						Release (Previous);
					end;
				end if;
			end if;
		end Release;
		type Container_Access is access constant Container_Type;
		for Container_Access'Storage_Size use 0;
		Left_Length : constant Length_Type := Length (Left);
		Right_Length : constant Length_Type := Length (Right);
		Larger : Container_Access;
		Larger_First : Index_Type;
		Larger_Last : Index_Type'Base;
		Larger_Length : Length_Type;
		Smaller : Container_Access;
		Smaller_First : Index_Type;
		Smaller_Last : Index_Type'Base;
		Smaller_Length : Length_Type'Base;
	begin
		if Left_Length < Right_Length then
			Smaller := Left'Unrestricted_Access;
			Smaller_Length := Left_Length;
			Larger := Right'Unrestricted_Access;
			Larger_Length := Right_Length;
		else
			Smaller := Right'Unrestricted_Access;
			Smaller_Length := Right_Length;
			Larger := Left'Unrestricted_Access;
			Larger_Length := Left_Length;
		end if;
		case Direction is
			when Forward =>
				Smaller_Last := Last_Index (Smaller.all);
				Larger_Last := Last_Index (Larger.all);
			when Backward =>
				Smaller_First := First_Index (Smaller.all);
				Larger_First := First_Index (Larger.all);
		end case;
		declare
			Work_Length : constant Length_Type := Smaller_Length + Larger_Length + 3;
			type FP_Array is array (Length_Type range 0 .. Work_Length - 1) of Length_Type'Base;
			type Path_Array is array (FP_Array'Range) of Path_Access;
			type FP_Array_Access is access FP_Array;
			for FP_Array_Access'Storage_Pool use Local_Pool;
			type Path_Array_Access is access Path_Array;
			for Path_Array_Access'Storage_Pool use Local_Pool;
			FP : FP_Array_Access := new FP_Array'(others => -1);
			Path : Path_Array_Access := new Path_Array'(others => null);
			Offset : constant Length_Type := Smaller_Length + 1;
			Length_Delta : constant Length_Type := Larger_Length - Smaller_Length;
			function Snake (k, fpa, fpb : Length_Type'Base) return Length_Type is
				Result : Length_Type;
				X : Length_Type'Base;
				Y : Length_Type'Base;
				Count : Length_Type;
				Pre_K : Length_Type'Base;
				New_Path : Path_Access;
			begin
				if fpa > fpb then
					Y := fpa;
					Pre_K := K - 1;
				else
					Y := fpb;
					Pre_K := K + 1;
				end if;
				x := y - k;
				Count := 0;
				case Direction is
					when Forward =>
						while x < Smaller_Length and then y < Larger_Length 
							and then Element (Smaller.all, Smaller_Last - x) = Element (Larger.all, Larger_Last - y)
						loop
							X := X + 1;
							Y := Y + 1;
							Count := Count + 1;
						end loop;
					when Backward =>
						while x < Smaller_Length and then y < Larger_Length 
							and then Element (Smaller.all, Smaller_First + x) = Element (Larger.all, Larger_First + y)
						loop
							X := X + 1;
							Y := Y + 1;
							Count := Count + 1;
						end loop;
				end case;
				New_Path := new Diff.Path;
				New_Path.Previous := Path (Pre_K + Offset);
				if K /= Pre_K then
					if New_Path.Previous /= null then
						New_Path.Previous.Reference_Count := New_Path.Previous.Reference_Count + 1;
					end if;
					Release (Path (K + Offset));
				end if;
				New_Path.X := X;
				New_Path.Y := Y;
				New_Path.Count := Count;
				New_Path.Reference_Count := 1;
				Path (K + Offset) := New_Path;
				Result := y;
				return Result;
			end Snake;
		begin
			for P in 0 .. Smaller_Length loop
				for K in -P .. Length_Delta - 1 loop
					fp (k + offset) := snake (k, fp (k - 1 + offset) + 1, fp (k + 1 + offset));
				end loop;
				for K in reverse Length_Delta .. Length_Delta + P loop
					fp (k + offset) := snake (k, fp (k - 1 + offset) + 1, fp (k + 1 + offset));
				end loop;
				if FP (Length_Delta + Offset) = Larger_Length then
					declare
						Tracing_Path : Path_Access := Path (Length_Delta + Offset);
						Smaller_Position : Length_Type := Smaller_Length;
						Larger_Position : Length_Type := Larger_Length;
					begin
						while Tracing_Path /= null loop
							if Tracing_Path.X < Smaller_Position or else Tracing_Path.Y < Larger_Position then
								declare
									Smaller_Last_Position : constant Length_Type'Base := Smaller_Position - 1;
									Larger_Last_Position : constant Length_Type'Base := Larger_Position - 1;
								begin
									while Tracing_Path.Previous /= null
										and then (Tracing_Path.X = Smaller_Position or else Tracing_Path.Y = Larger_Position)
										and then Tracing_Path.Count = 0
									loop
										Smaller_Position := Tracing_Path.X - Tracing_Path.Count;
										Larger_Position := Tracing_Path.Y - Tracing_Path.Count;
										Tracing_Path := Tracing_Path.Previous;
									end loop;
									if Smaller = Left'Unrestricted_Access then
										case Direction is
											when Forward =>
												Notify (Smaller_Last - Smaller_Last_Position, Smaller_Last - Tracing_Path.X,
													Larger_Last - Larger_Last_Position, Larger_Last - Tracing_Path.Y);
											when Backward =>
												Notify (Smaller_First + Tracing_Path.X, Smaller_First + Smaller_Last_Position,
													Larger_First + Tracing_Path.Y, Larger_First + Larger_Last_Position);
										end case;
									else
										case Direction is
											when Forward =>
												Notify (Larger_Last - Larger_Last_Position, Larger_Last - Tracing_Path.Y,
													Smaller_Last - Smaller_Last_Position, Smaller_Last - Tracing_Path.X);
											when Backward =>
												Notify (Larger_First + Tracing_Path.Y, Larger_First + Larger_Last_Position,
													Smaller_First + Tracing_Path.X, Smaller_First + Smaller_Last_Position);
										end case;
									end if;
								end;
							end if;
							Smaller_Position := Tracing_Path.X - Tracing_Path.Count;
							Larger_Position := Tracing_Path.Y - Tracing_Path.Count;
							Tracing_Path := Tracing_Path.Previous;
						end loop;
					end;
					return;
				end if;
			end loop;
			pragma Assert (False);
		end;
	end Diff;

end Difference;

difference.ads

with System.Storage_Pools;
package Difference is
	
	type Direction is (Forward, Backward);
	
	generic
		type Storage_Pool is new System.Storage_Pools.Root_Storage_Pool with private;
		type Index_Type is (<>);
		type Element_Type (<>) is limited private;
		type Container_Type (<>) is limited private;
		type Length_Type is range <>;
		Direction : in Difference.Direction := Forward;
		with function Length (Container : Container_Type) return Length_Type is <>;
		with function Element (Container : Container_Type; Index : Index_Type) return Element_Type is <>;
		with function First_Index (Container : Container_Type) return Index_Type is <>;
		with function Last_Index (Container : Container_Type) return Index_Type is <>;
		with function "="(Left, Right : Element_Type) return Boolean is <>;
	procedure Diff (
		Left, Right : in Container_Type;
		Notify : not null access procedure (
			Left_Low : Index_Type;
			Left_High : Index_Type'Base;
			Right_Low : Index_Type;
			Right_High : Index_Type'Base));
	
end Difference;