Digital Differential Analyzer

dda.adb

package body DDA is
	
	procedure Line_Excluding_Last (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer)) 
	is
		function Sign (X : Integer) return Integer is
		begin
			if X > 0 then
				return 1;
			elsif X < 0 then
				return -1;
			else
				return 0;
			end if;
		end Sign;
		Width : constant Integer := abs (X2 - X1);
		Height : constant Integer := abs (Y2 - Y1);
		Step_X : constant Integer := Sign (X2 - X1);
		Step_Y : constant Integer := Sign (Y2 - Y1);
		D : Integer;
		X, Y : Integer;
	begin
		if Width >= Height then
			D := Width / 2;
			X := X1;
			Y := Y1;
			while X /= X2 loop
				Point (X, Y);
				D := D + Height;
				if D >= Width then
					Y := Y + Step_Y;
					D := D - Width;
				end if;
				X := X + Step_X;
			end loop;
		else
			D := Height / 2;
			X := X1;
			Y := Y1;
		  while Y /= Y2 loop
				Point (X, Y);
				D := D + Width;
				if D >= Height then
					X := X + Step_X;
					D := D - Height;
				end if;
				Y := Y + Step_Y;
			end loop;
		end if;
	end Line_Excluding_Last;
	
	procedure Line (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer)) is
	begin
		Line_Excluding_Last (X1, Y1, X2, Y2, Point);
		Point (X2, Y2);
	end Line;
	
	procedure Rectangle (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer))
	is
		X_S : constant Integer := Integer'Min (X1, X2);
		X_E : constant Integer := Integer'Max (X1, X2);
		Y_S : constant Integer := Integer'Min (Y1, Y2);
		Y_E : constant Integer := Integer'Max (Y1, Y2);
	begin
		for X in X_S .. X_E loop
			Point (X, Y1);
			if Y1 /= Y2 then
				Point (X, Y2);
			end if;
		end loop;
		for Y in Y_S + 1 .. Y_E - 1 loop
			Point (X1, Y);
			if X1 /= X2 then
				Point (X2, Y);
			end if;
		end loop;
	end Rectangle;
	
	procedure Rectangle_Filling (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer))
	is
		X_S : constant Integer := Integer'Min (X1, X2);
		X_E : constant Integer := Integer'Max (X1, X2);
		Y_S : constant Integer := Integer'Min (Y1, Y2);
		Y_E : constant Integer := Integer'Max (Y1, Y2);
	begin
		for Y in Y_S .. Y_E loop
			for X in X_S .. X_E loop
				Point (X, Y);
			end loop;
		end loop;
	end Rectangle_Filling;
	
	procedure Ellipse_Internal (X1, Y1, X2, Y2 : Integer;
		Paint : not null access procedure (X1, Y1, X2, Y2 : Integer)) 
	is
		Center_X : constant Integer := (X1 + X2) / 2;
		Center_Y : constant Integer := (Y1 + Y2) / 2;
		Diff_X : constant Integer := (X1 + X2) mod 2;
		Diff_Y : constant Integer := (Y1 + Y2) mod 2;
		Radius_X : constant Integer := abs (X2 - X1) / 2;
		Radius_Y : constant Integer := abs (Y2 - Y1) / 2;
		mul_4_b : Integer;
		mul_2_b : Integer;
		mul_1_b : Integer;
		x : Integer;
		y : Integer;
		f : Integer;
		h : Integer;
	begin
		if Radius_X >= Radius_Y then
			mul_4_b := (4 * radius_x * radius_x) / (radius_y * radius_y);
			mul_2_b := mul_4_b / 2;
			mul_1_b := mul_2_b / 2;
			x := radius_x;
			y := 0;
			f := ((-2) * radius_x + 1 + mul_2_b);
			h := ((-4) * radius_x + 2 + mul_1_b);
			while x > 0 loop
				Paint (center_x - x         , center_y - y,
				      center_x - x         , center_y + y + Diff_Y);
				Paint (center_x + x + Diff_X, center_y - y,
				      center_x + x + Diff_X, center_y + y + Diff_Y);
				if f < 0 then
					y := y + 1;
					f := f + mul_4_b * y + mul_2_b;
					h := h + mul_4_b * y;
					if h >= 0 then
						x := x - 1;
						f := f - 4 * x;
						h := h - 4 * x - 2;
					end if;
				elsif h >= 0 then
					x := x - 1;
					f := f - 4 * x;
					h := h - 4 * x - 2;
				else
					x := x - 1;
					y := y + 1;
					f := f + mul_4_b * y - 4 * x + mul_2_b;
					h := h + mul_4_b * y - 4 * x + 2;
				end if;
			end loop;
			if Diff_X = 0 then
				Paint (center_x, center_y - y,
				      center_x, center_y + y + Diff_Y);
			end if;
		else
			mul_4_b := (4 * radius_y * radius_y) / (radius_x * radius_x);
			mul_2_b := mul_4_b / 2;
			mul_1_b := mul_2_b / 2;
			x := 0;
			y := radius_y;
			f := ((-2) * radius_y + 1 + mul_2_b);
			h := ((-4) * radius_y + 2 + mul_1_b);
			while y > 0 loop
				Paint (center_x - x         , center_y - y,
				      center_x + x + Diff_X, center_y - y);
				Paint (center_x - x         , center_y + y + Diff_Y,
				      center_x + x + Diff_X, center_y + y + Diff_Y);
				if f < 0 then
					x := x + 1;
					f := f + mul_4_b * x + mul_2_b;
					h := h + mul_4_b * x;
					if h >= 0 then
						y := y - 1;
						f := f - 4 * y;
						h := h - 4 * y - 2;
					end if;
				elsif h >= 0 then
					y := y - 1;
					f := f - 4 * y;
					h := h - 4 * y - 2;
				else
					y := y - 1;
					x := x + 1;
					f := f + mul_4_b * x - 4 * y + mul_2_b;
					h := h + mul_4_b * x - 4 * y + 2;
				end if;
			end loop;
			if Diff_Y = 0 then
				Paint (center_x - X,          center_y,
				      center_x + X + Diff_X, center_y);
			end if;
		end if;
	end Ellipse_Internal;
	
	procedure Ellipse (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer)) 
	is
		procedure Paint (X1, Y1, X2, Y2 : Integer) is
		begin
			Point (X1, Y1);
			Point (X2, Y2);
		end Paint;
	begin
		Ellipse_Internal (X1, Y1, X2, Y2, Paint'Access);
	end Ellipse;
	
	procedure Ellipse_Filling (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer)) 
	is
		procedure Paint_H (X1, Y1, X2, Y2 : Integer) is
			pragma Unreferenced (Y2);
		begin
			for X in X1 .. X2 loop
				Point (X, Y1);
			end loop;
		end Paint_H;
		procedure Paint_V (X1, Y1, X2, Y2 : Integer) is
			pragma Unreferenced (X2);
		begin
			for Y in Y1 .. Y2 loop
				Point (X1, Y);
			end loop;
		end Paint_V;
		Paint : access procedure (X1, Y1, X2, Y2 : Integer);
	begin
		if abs (X2 - X1) < abs (Y2 - Y1) then
			Paint := Paint_H'Access;
		else
			Paint := Paint_V'Access;
		end if;
		Ellipse_Internal (X1, Y1, X2, Y2, Paint);
	end Ellipse_Filling;
	
end DDA;

dda.ads

package DDA is
	
	procedure Line_Excluding_Last (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer));
	
	procedure Line (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer));
	
	procedure Rectangle (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer));
	
	procedure Rectangle_Filling (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer));
	
	procedure Ellipse (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer));
	
	procedure Ellipse_Filling (X1, Y1, X2, Y2 : Integer;
		Point : not null access procedure (X, Y : Integer));
	
end DDA;