home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
games
/
egagraph.zip
/
BOXDEMO.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1987-07-23
|
20KB
|
669 lines
program BoxDemo;
(* ================================================= *)
(* = This program demonstraits the fast EGA line = *)
(* = drawing routine. The program has other GOOD = *)
(* = stuff in it..so use what you can..any way = *)
(* = you can..at you own expense..good luck = *)
(* = graphicsing. = *)
(* = = *)
(* = James Billmeyer = *)
(* = Soft-Touch Computer Systems = *)
(* = 7716 Balboa Blvd., Unit D = *)
(* = Van Nuys, Ca. 91406 = *)
(* = (818) 781-4400 = *)
(* ================================================= *)
const
middle_horizontal = 320;
middle_vertical = 175;
horizontal_scale = 1.53241;
vertical_scale = 1.0000;
longitudinal_scale = 0.5005657;
(* ===================================== *)
type
cgtype = string[3];
str10 = string[10];
border_type = (DB,NB);
projection_type = (PARALLEL,PERSPECTIVE);
model_type = (LARGE,SMALL);
line_info = record
x1,
y1,
x2,
y2,
color : integer;
end;
object_lines = array[1..9] of line_info;
coord_type = record
x,
y,
z : real;
end;
object_info = record
name : string[10];
number_of_surface : integer;
number_of_lines : integer;
old_number_of_lines : integer;
surface_to_view : string[48];
lines_to_view : string[24];
vertex : array[1..4] of coord_type;
lines : object_lines;
old_lines : object_lines;
coord_reset : integer;
coordinates,
end_coordinates : coord_type;
otheta,
ophi,
obeta : real;
end;
trig_type = record
sin0,
cos0,
sin1,
cos1,
sin2,
cos2 : real;
end;
var
projection : projection_type;
line : line_info;
test,
oldtest : object_info;
trig_set : trig_type;
model : model_type;
xdir,ydir,i,j,
tx,ty,tz,
color,
loop,
xscrn,yscrn,
xscrn0,yscrn0,
total_surfaces,
wxmin,wymin,wxmax,wymax : integer;
ok,
dir,firstime : boolean;
dist,
xwrld,ywrld,zwrld,
theta,beta,phi,
x_scale,y_scale,z_scale : real;
procedure drawline(x1,y1,x2,y2,color : integer); External 'LINE.BIN';
procedure get_object_from_file(var object: object_info; object_name: str10);
(* ================================================ *)
(* = The get_object_from_file procedure loads = *)
(* = object information into the arrays. = *)
(* ================================================ *)
begin
with object do
begin
name := 'Test';
number_of_surface := 3;
lines_to_view := '123847561328457614352786';
surface_to_view := '011103090510070901060205021204100612081103080407';
coordinates.x := 0.00;
coordinates.y := 0.00;
coordinates.z := 0.00;
end_coordinates.x := 0.00;
end_coordinates.y := 0.00;
end_coordinates.z := 0.00;
ophi := 0.00;
obeta := 0.00;
otheta := 0.00;
vertex[1].x := -12.00;
vertex[1].y := -12.00;
vertex[2].x := 12.00;
vertex[2].y := -12.00;
vertex[3].x := -12.00;
vertex[3].y := -12.00;
vertex[4].x := -12.00;
vertex[4].y := 12.00;
vertex[4].z := 12.00;
vertex[1].z := 12.00;
vertex[2].z := 12.00;
vertex[3].z := -12.00;
end;
end; (* proc Array_load *)
Procedure Phi_change(var trig_set: trig_type; dir: boolean);
(* ================================================ *)
(* = The procedure Phi_change adds or subtracts = *)
(* = from the angle phi depending on the dir = *)
(* ================================================ *)
begin (* proc Phi_change *)
if dir then
phi := phi + 0.04
else
phi := phi - 0.04;
trig_set.sin0 := sin(phi);
trig_set.cos0 := cos(phi);
end; (* proc Phi_change *)
Procedure Beta_change(var trig_set: trig_type; dir: boolean);
(* ================================================ *)
(* = The procedure Phi_change adds or subtracts = *)
(* = from the angle phi depending on the dir = *)
(* ================================================ *)
begin (* proc beta_change *)
if dir then
beta := beta + 0.04
else
beta := beta - 0.04;
trig_set.sin1 := sin(beta);
trig_set.cos1 := cos(beta);
end; (* proc beta_change *)
Procedure theta_change(var trig_set: trig_type; dir: boolean);
(* ================================================ *)
(* = The procedure theta_change add or subtract = *)
(* = from the angle phi depending on the dir = *)
(* ================================================ *)
begin (* proc theta_change *)
if dir then
theta := theta + 0.05
else
theta := theta - 0.05;
trig_set.sin2 := sin(theta);
trig_set.cos2 := cos(theta);
end; (* proc theta_change *)
procedure Rotate(x,y,z: real; trig_set: trig_type; var xwrld,ywrld,zwrld: real);
(* ==================================== *)
(* = This routine calculates the 3D = *)
(* = transformation matrix. = *)
(* ==================================== *)
var
group1,group2,group3 : real;
begin
with trig_set do
begin
group1 := -y * sin0 + z * cos0;
group2 := y * cos0 + z * sin0;
group3 := x * cos1 - group1 * sin1;
xwrld := group3 * cos2 + group2 * sin2;
ywrld := group2 * cos2 - group3 * sin2;
zwrld := x * sin1 - group1 * cos1;
end;
end;
Procedure Parallel_projection(var xscrn,yscrn: integer; xwrld,ywrld,zwrld: real);
(* ================================================ *)
(* = Parallel_projection procedure converts = *)
(* = world coordinates to screen coordinates in = *)
(* = parallel projection. = *)
(* ================================================ *)
var
ratio : real;
begin (* proc Parallel_projection *)
xscrn := round(middle_horizontal + x_scale * xwrld);
yscrn := round(middle_vertical + y_scale * ywrld);
end; (* proc Parallel_projection *)
procedure gwindow(xmin,ymin,xmax,ymax: integer; border: border_type);
(**************************************************)
(* This procedure sets the graphics window and *)
(* will draw the window border if directed. *)
(* DB => draw border *)
(* NB => no border *)
(**************************************************)
begin
wxmin := xmin + 1;
wymin := ymin + 1;
wxmax := xmax - 1;
wymax := ymax - 1;
if border = DB then
begin
drawline(xmin,ymin,xmax,ymin,1);
drawline(xmin,ymax,xmax,ymax,1);
drawline(xmax,ymin,xmax,ymax,1);
drawline(xmin,ymin,xmin,ymax,1);
end;
end;
procedure clipper(var x1,y1,x2,y2: integer);
(**************************************************)
(* This procedure uses the Cohen-Sutherland *)
(* algorithm for line clipping. *)
(**************************************************)
type
outcode = array[1..4] of boolean;
var
accept,reject,done : boolean;
outcode1,outcode2 : outcode;
procedure outcodes(x,y: integer; var outcodeset: outcode);
(**************************************************)
(* This procedure returns the outcodes for the *)
(* point (x,y) *)
(**************************************************)
var
i : integer;
begin
for i := 1 to 4 do
outcodeset[i] := false;
if x < wxmin then
outcodeset[4] := true
else if x > wxmax then
outcodeset[3] := true;
if y > wymax then
outcodeset[2] := true
else if y < wymin then
outcodeset[1] := true;
end;
function reject_check(outcode1,outcode2: outcode): boolean;
(**************************************************)
(* This function checks to see if the line lies *)
(* outside the window. *)
(**************************************************)
var
i : integer;
begin
reject_check := false;
for i := 1 to 4 do
if (outcode1[i] and outcode2[i]) then
begin
reject_check := true;
i := 4;
end;
end;
function accept_check(outcode1,outcode2: outcode): boolean;
(**************************************************)
(* This function checks to see if the line lies *)
(* inside the window. *)
(**************************************************)
var
i : integer;
begin
accept_check := true;
for i := 1 to 4 do
if (outcode1[i] or outcode2[i]) then
accept_check := false;
end;
procedure swap;
(**************************************************)
(* This procedure swaps the point1 and point2 *)
(* values. *)
(**************************************************)
var
pointemp : integer;
outcodetemp : outcode;
begin
pointemp := x1;
x1 := x2;
x2 := pointemp;
pointemp := y1;
y1 := y2;
y2 := pointemp;
outcodetemp := outcode1;
outcode1 := outcode2;
outcode2 := outcodetemp;
end;
begin
accept := false;
reject := false;
done := false;
outcodes(x1,y1,outcode1);
outcodes(x2,y2,outcode2);
repeat
reject := reject_check(outcode1,outcode2);
if reject then
done := true
else
begin
accept := accept_check(outcode1,outcode2);
if accept then
done := true
else
begin
if not (outcode1[1] or outcode1[2] or outcode1[3] or outcode1[4]) then
swap;
if outcode1[1] then
begin
x1 := x1 + (x2 - x1) * (wymin - y1) div (y2 - y1);
y1 := wymin;
end
else if outcode1[2] then
begin
x1 := x1 + (x2 - x1) * (wymax - y1) div (y2 - y1);
y1 := wymax;
end
else if outcode1[3] then
begin
y1 := y1 + (y2 - y1) * (wxmax - x1) div (x2 - x1);
x1 := wxmax;
end
else if outcode1[4] then
begin
y1 := y1 + (y2 - y1) * (wxmin - x1) div (x2 - x1);
x1 := wxmin;
end
end;
end;
if not done then
outcodes(x1,y1,outcode1);
until done;
if reject then
begin
x1 := wxmin;
y1 := wymin;
x2 := wxmin;
y2 := wymin;
end;
end;
Procedure calc_object_lines(var object: object_info);
(* ================================================ *)
(* = The Draw_Scrn procedure draw an object on = *)
(* = the screen. = *)
(* ================================================ *)
const
surface0 = $A0A;
surface1 = $AC;
surface2 = $CC0;
surface3 = $505;
surface4 = $53;
surface5 = $330;
line_loc : array[1..12] of integer = ($800,$400,$200,$100,$80,$40,$20,$10,$8,$4,$2,$1);
var
x_wrld,
y_wrld,
z_wrld : array[1..8] of real;
i,j,
sindex,index,
first,second,
dummy,
view_surface,
line_count,
lines_drawn,
line_mask : integer;
x,y,z,
x_temp,
y_temp,
z_temp : real;
begin (* proc calculate_lines *)
for i := 1 to 4 do
with object.vertex[i] do
begin
if model = SMALL then
z := 0;
Rotate((x + object.coordinates.x),
(y + object.coordinates.y),
(z + object.coordinates.z),trig_set,xwrld,ywrld,zwrld);
x_wrld[i] := xwrld;
y_wrld[i] := ywrld;
z_wrld[i] := zwrld;
end;
x_temp := x_wrld[2] - x_wrld[1];
y_temp := y_wrld[2] - y_wrld[1];
z_temp := z_wrld[2] - z_wrld[1];
x_wrld[8] := x_temp + x_wrld[3]; x_wrld[7] := x_temp + x_wrld[4];
x_wrld[5] := x_wrld[3] - x_wrld[1] + x_wrld[4]; x_wrld[6] := x_temp + x_wrld[5];
y_wrld[8] := y_temp + y_wrld[3]; y_wrld[7] := y_temp + y_wrld[4];
y_wrld[5] := y_wrld[3] - y_wrld[1] + y_wrld[4]; y_wrld[6] := y_temp + y_wrld[5];
z_wrld[8] := z_temp + z_wrld[3]; z_wrld[7] := z_temp + z_wrld[4];
z_wrld[5] := z_wrld[3] - z_wrld[1] + z_wrld[4]; z_wrld[6] := z_temp + z_wrld[5];
with object do
begin
lines_drawn := 0;
line_count := 0;
old_lines := lines;
old_number_of_lines := number_of_lines;
if model = LARGE then
begin
if int(z_wrld[5] - z_wrld[4]) > 0 then
lines_drawn := lines_drawn or surface0
else if int(z_wrld[5] - z_wrld[4]) < 0 then
lines_drawn := lines_drawn or surface3;
if int(z_wrld[7] - z_wrld[4]) < 0 then
lines_drawn := lines_drawn or surface1
else if int(z_wrld[7] - z_wrld[4]) > 0 then
lines_drawn := lines_drawn or surface4;
if int(z_wrld[1] - z_wrld[4]) > 0 then
lines_drawn := lines_drawn or surface5
else if int(z_wrld[1] - z_wrld[4]) < 0 then
lines_drawn := lines_drawn or surface2;
end
else
lines_drawn := lines_drawn or $2;
for j := 1 to 12 do
begin
line_mask := lines_drawn;
if (line_mask and line_loc[j]) > 0 then
begin
line_count := line_count + 1;
index := j * 2 - 1;
val(copy(lines_to_view,(index),1),first,dummy);
val(copy(lines_to_view,(index + 1),1),second,dummy);
Parallel_projection(line.x1,line.y1,x_wrld[first],y_wrld[first],z_wrld[first]);
Parallel_projection(line.x2,line.y2,x_wrld[second],y_wrld[second],z_wrld[second]);
lines[line_count] := line;
clipper(lines[line_count].x1,lines[line_count].y1,lines[line_count].x2,lines[line_count].y2);
end;
end;
number_of_lines := line_count;
end;
end; (* proc calculate_lines *)
Procedure draw_object(var object: object_info);
(* ================================================ *)
(* = The Draw_Scrn procedure draw an object on = *)
(* = the screen. = *)
(* ================================================ *)
var
i : integer;
begin (* proc Draw_Scrn *)
with object do
for i := 1 to number_of_lines do
with lines[i] do
begin
drawline(x1,y1,x2,y2,i);
end;
end; (* proc Draw_Scrn *)
Procedure erase_object(var object: object_info);
(* ================================================ *)
(* = The Draw_Scrn procedure draw an object on = *)
(* = the screen. = *)
(* ================================================ *)
var
i : integer;
begin (* proc Draw_Scrn *)
with object do
for i := 1 to old_number_of_lines do
with old_lines[i] do
begin
drawline(x1,y1,x2,y2,0);
end;
end; (* proc Draw_Scrn *)
procedure color_display(selection:cgtype);
(* ================================================ *)
(* = The selectmonitor procedure changes the = *)
(* = current monitor selection from monochrome = *)
(* = to color graphics or vice-aversa. = *)
(* ================================================ *)
var
displayvar : integer absolute $0000:$0410;
begin (* proc colordsply *)
if selection = 'on' then
begin
displayvar := (displayvar and 207) or 16;
hires;
end
else if selection = 'off' then
begin
displayvar := displayvar or 48;
textmode;
end;
end; (* proc colordsply *)
procedure SetEGAMode(mode : integer);
type
regset = record
ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
end;
var
registers : regset;
begin
with registers do
begin
ax := mode;
intr($10,registers);
end;
END;
procedure EGA43;
begin
inline($b8/$12/$11/ (* mov ax,1112 *)
$b3/$00/ (* mov bl,00 *)
$cd/$10/ (* int 10 *)
$2b/$c0/ (* sub ax,ax *)
$1e/ (* push ds *)
$8e/$d8/ (* mov ds,ax *)
$ff/$36/$87/$04/ (* push [0487] *)
$80/$0e/$87/$04/$01/ (* or byte ptr [0487],01 *)
$b9/$00/$06/ (* mov cx,06 *)
$b4/$01/ (* mov ah,01 *)
$cd/$10/ (* int 10 *)
$8f/$06/$87/$04/ (* pop [0487] *)
$1f); (* pop ds *)
(* $ba/$b4/$03/ *) (* mov dx,03b4 *)
(* $b8/$14/$07/ *) (* mov ax,0714 *)
(* $ef); *) (* out dx,ax *)
end;
begin (* main program *)
dir := true;
tx := 0;
ty := 0;
tz := 0;
dist := 15.0;
z_scale := longitudinal_scale;
x_scale := horizontal_scale * (dist / 10);
y_scale := vertical_scale * (dist / 10);
(* hires; *)
(* ega43; *)
SetEGAMode(18);
color := 32;
theta := 1.0;
phi := 1.0;
beta := 1.0;
Phi_change(trig_set,dir);
Theta_change(trig_set,dir);
beta_change(trig_set,dir);
model := LARGE;
get_object_from_file(test,'TEST');
projection := PARALLEL;
gwindow(250,20,380,199,DB);
Phi_change(trig_set,dir);
Theta_change(trig_set,dir);
beta_change(trig_set,dir);
calc_object_lines(test);
draw_object(test);
Writeln('┌───────┐');
writeln('│ Start │');
writeln('└───────┘');
for loop := 1 to 500 do
begin
Phi_change(trig_set,dir);
Theta_change(trig_set,dir);
beta_change(trig_set,dir);
calc_object_lines(test);
erase_object(test);
draw_object(test);
end;
Writeln('┌──────┐');
writeln('│ Done │');
writeln('└──────┘');
delay(3000);
SetEGAMode(03);
end. (* main program *)
