Skip to content

Instantly share code, notes, and snippets.

@ytomino
Created March 6, 2011 07:29
Show Gist options
  • Save ytomino/857111 to your computer and use it in GitHub Desktop.
Save ytomino/857111 to your computer and use it in GitHub Desktop.
Digital Differential Analyzer
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;
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;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment