PROGRAMAS:
Programa Linea (usando la inst. putpixel).
Programa Linea (usando la función Random( ))
Programa linea (usando la función. Linerel( ))
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
El siguiente programa esta echo en modo texto, el cual escribe en
el centro de la pantalla la leyenda "UNIVERSIDAD DE GUADALAJARA", en
seguida una doble línea para separar una gráfica echa con
caracteres
ASCII, con dos categorias "PERSONAS" y "MES".
Todo el texto esta en color #7 (Gris Claro), que es el color por
defecto en modo texto, ya que no se indico ningun color, con la
función " TEXTCOLOR ".
*)
Program ModoTexto;
Uses
Crt;
Var
x : integer;
(* Procedimiento por el cual se escribe en el centro de la pantalla la
leyenda "UNIVERSIDAD DE GUADALAJARA" y en seguida una línea doble.
*)
Procedure presentacion;
begin
gotoxy (25,2);
write(' UNIVERSIDAD DE GUADALAJARA ');
gotoxy (1,3);
for x:=1 to 80 do
write(chr(205));
readln
end;
(* Procedimiento que asigna las categorias a la gráfica, las categorias
son: "PERSONAS" y "MES" *)
Procedure letras;
begin
gotoxy(1,10);
write('PERSONAS');
gotoxy(45,23);
write('MES');
end;
(* Procedimiento que dibuja la gráfica (en modo texto), con los
caracteres
del códio ASCII, el caraceter #179 "³", el #192 "À" y
el catacter #196 "Ä" *)
Procedure Lineas;
Var
a,b : integer;
begin
for b := 10 to 22 do
begin
gotoxy(9,b);
write(chr(179));
end;
gotoxy(9,22);
write(chr(192));
For a := 10 to 50 do
begin
gotoxy(a,22);
write(chr(196));
end;
end;
Begin
(* Llamada al procedimiento que escribe la leyenda y la doble línea
*)
presentación;
(* Llamada al procedimiento que indica las categorias de la gráfica
*)
letras;
(* Llamada al procedimiento que dibuja la gráfica *)
lineas;
end.
(* UNIVERSIDAD DE GUADALAJARA Coordinación de Sistemas Unidad de Cómputo Académico El siguiente programa realiza un ejemplo de la función "RECTANGLE" la cual dibuja un rectangulo o cuadrado en la pantalla, se especifican las coordenadas ( x , y ) del punto superior izquierdo del rectangulo así como el inferior derecho. El color por defecto es el color blanco, si no se especifica otro. *) Program Rectangulo; Uses CRT, GRAPH; Var Gd, Gm : Integer; begin (* Detección del modo gráfico *) Gd := Detect; (* inicialización del modo gráfico *) InitGraph(Gd, Gm, 'c:\tp\bgi'); (* Verificación de error en el modo gráfico *) if GraphResult <> grOk then Halt(1); Rectangle(280,150,40,30); Delay (5000); CloseGraph; (* Cerrar modo gráfico *) End.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
Este programa abre archivos "*.PCX", es decir, cualquier archivo
de gráficos con esa extensión es este programa es capaz de abrirlo
y mostrar ese gráfico.
*)
program pcxx;
uses crt,graph,dos;
(* Procedimiento para inicializar gráficos*)
PROCEDURE INICIAR_GRAFICOS;
VAR MONITOR,MODO,ERROR:INTEGER;
BEGIN
(* Detección del tipo de adaprador gráfico de su PC *)
MONITOR:=DETECT;
(* Inicializando el modo gráfico *)
INITGRAPH(MONITOR,MODO,'c:\tp\bgi ');
(* Verificación de errores en el modo gráfico*)
ERROR:=GRAPHRESULT;
IF ERROR<>GROK THEN
BEGIN
WRITELN('ERROR EN GRAFICOS ');DELAY(3000);
HALT;
END;
CLEARDEVICE;
END;
(* Procedimiento para contener los colores en los registros de proposito
general de su PC*)
Procedure SetRGBPalette(Col,R,G,B:byte);
Var Regs:registers;
begin
Fillchar(Regs,sizeof(Regs),0);
Regs.AX:=$1010;
Regs.BX:=col;
Regs.Dh:=R;
Regs.Ch:=G;
Regs.Cl:=B;
Intr ($10,Regs);
end;
Procedure Graba_Pcx(xmin,ymin,xmax,ymax:integer;nombre:string);
type
maping=arraY[0..15,1..3] of byte;
pcxinit=record
manufactura,version,codigofin,bitsporpixel:byte;
xmin,ymin,xmax,ymax,hres,vres:integer;
mapacolor:maping;
reservado,nplanes:byte;
bytesporlinea,typopaleta:integer;
sheet:array[1..58] of byte;
end;
const
Colors:maping=
( (0,0,0),(0,0,2),(0,2,0),
(0,2,2),(2,0,0),(2,0,2),
(2,2,0),(2,2,2),(1,1,1),
(1,1,3),(1,3,1),(1,3,3),
(3,1,1),(3,1,3),(3,3,1),
(3,3,3) );
Var
archi1:file of pcxinit;
archi:file of byte;
Hdr:pcxinit;
punto,contador,l:byte;
i,j,k,x,y:integer;
(* Esta función lee el color de una coordenada específica del archivo *.PCX
y debuelve el valor del color. *)
Function Lee_color(var x,y:integer):byte;
var co:byte;
begin
if y<=ymax then co:=Getpixel(x,y);
inc(x);
if x>xmax then begin
x:=xmin;
inc(y)
end;
Lee_color:=co
end;
Function Lee_byte:byte;
var l:byte;
begin
l:=Lee_color(x,y);
l:=l mod 16;
l:=Lee_color(x,y)+(16*l);
Lee_byte:=l
end;
Begin
Hdr.manufactura:=10;
Hdr.version:=5;
Hdr.codigofin:=1;
Hdr.bitsporpixel:=4;
Hdr.hres:=26;
Hdr.vres:=26;
Hdr.reservado:=0;
Hdr.nplanes:=1;
if odd(xmax-xmin+1) then Hdr.bytesporlinea:=(xmax-xmin+1) div 2
else Hdr.bytesporlinea:=((xmax-xmin+1) div 2)+1;
Hdr.typopaleta:=0;
for i:=0 to 15 do
for j:=1 to 3 do
Hdr.mapacolor[i,j]:=Colors[i,j]*85;
Hdr.xmin:=xmin;
Hdr.xmax:=xmax;
Hdr.ymin:=ymin;
Hdr.ymax:=ymax;
{$i-}
assign(archi1,nombre);
rewrite(archi1);
write(archi1,Hdr);
close(archi1);
{$i+}
assign(archi,nombre);
reset(archi);
seek(archi,128);
x:=xmin;
y:=ymin;
contador:=1;
l:=Lee_byte;
punto:=Lee_byte;
repeat
While (l=punto) and (contador<63) do
begin
inc(contador);
punto:=Lee_byte
end;
if ((contador=1) and (l<192)) then write(archi,l)
else begin
contador:=contador+192;
write(archi,contador);
write(archi,l);
end;
l:=punto;
contador:=1;
punto:=Lee_byte;
Until (y>ymax);
close(archi);
{$i+}
end;
Procedure Lee_Pcx_16(nombre:string);
{$r-}{$v-}
type
plano=^tplano;
tplano=array[0..38399] of byte;
maping=Array[0..15,1..3] of byte;
pcxinit=record
manufactura,version,codigofin,bitsporpixel:byte;
xmin,ymin,xmax,ymax,hires,vres:integer;
mapacolor:maping;
reservado,nplanes:byte;
bytesporlinea,typopaleta:integer;
sheet:array[1..58] of byte;
end;
Var
p:Array[0..5] of word;
archi1:file of pcxinit;
archi:file of byte;
Hdr:pcxinit;
punto,contador,l,npl:byte;
i,j,k,x,y:integer;
xmax,ymax,xmin,ymin,bpl:integer;
plane,color:word;
count,cuantos:longint;
plano0,plano1,plano2,plano3:plano;
Procedure Configura_Paleta(Colors:maping);
var i:byte;
Begin
for i:=0 to 5 do
SetRgbPalette(i,Colors[i,1] div 4,Colors[i,2] div 4,Colors[i,3] div 4);
for i:=6 to 15 do
begin
SetRgbPalette(21+i,Colors[i,1] div 4,Colors[i,2] div 4,Colors[i,3] div 4);
SetPalette(i,21+i);
end;
end;
Procedure Pon_Punto(var x,y:integer;co:byte);
begin
if y<=ymax then Putpixel(x,y,co);
inc(x);
if x>xmax then begin
x:=xmin;
inc(y)
end;
end;
Begin
{$i-}
assign(archi1,nombre);
reset(archi1);
read(archi1,Hdr);
close(archi1);
{$i+}
{$i-}
xmin:=Hdr.xmin;
ymin:=Hdr.ymin;
xmax:=Hdr.xmax;
ymax:=Hdr.ymax;
assign(archi,nombre);
reset(archi);
seek(archi,128);
{ Configura_Paleta(Hdr.mapacolor);}
x:=0;
y:=0;
case Hdr.bitsporpixel of
4: begin
repeat
contador:=1;
read(archi,l);
if (l and $c0)=$c0 then begin
contador:=l and $3f;
read(archi,punto)
end
else punto:=l;
for i:=1 to contador do
begin
pon_punto(x,y,punto div 16);
pon_punto(x,y,punto mod 16)
end;
until (Eof(Archi)) or (y>=ymax);
end;
1:begin
new(plano0);
new(plano1);
new(plano2);
new(plano3);
count:=0;plane:=0;
bpl:=Hdr.bytesporlinea;
npl:=Hdr.nplanes;
cuantos:=bpl* npl*(1+ymax-ymin);
for i:=0 to 3 do p[i]:=0;
repeat
contador:=1;
read(archi,l);
if (l and $c0)=$c0 then begin
contador:=l and $3f;
read(archi,punto)
end
else punto:=l;
for i:=1 to contador do
begin
while (p[plane]>=38399) do inc(plane);
case plane of
0: plano0^[p[0]]:=punto;
1: plano1^[p[1]]:=punto;
2: plano2^[p[2]]:=punto;
3: plano3^[p[3]]:=punto;
end;
inc(p[plane]);
if (p[plane] mod bpl)=(bpl-1) then begin
if plane=3 then inc(y);
plane:=(plane+1) mod npl;
end;
end;
count:=count+contador;
until (Eof(Archi)) or (plane>3) or (count=cuantos);
cleardevice;
for y:=0 to ymax do
for x:=24 to xmax-20 do begin
color:=(plano0^[(bpl*y)+(x div 8)] shr (7-(x mod 8))) and 1 ;
color:=color+2*((plano1^[bpl*y+(x div 8)] shr (7-(x mod 8))) and 1);
color:=color+4*((plano2^[bpl*y+(x div 8)] shr (7-(x mod 8))) and 1);
color:=color+8*((plano3^[bpl*y+(x div 8)] shr (7-(x mod 8))) and 1);
putpixel(x,y,color);
end;
dispose(plano0);dispose(plano1);dispose(plano2);dispose(plano3);
End;
End;
close(archi);
{$i+}
end;
Begin
iniciar_graficos;
readln;
Lee_Pcx_16('btete.pcx');{es importante que el archivo pcx este en el mismo}
SETCOLOR(0); {directorio que el programa ejecutable}
{CIRCLE(100,100,40);
SETFILLSTYLE(1,14);
FLOODFILL(100,100,0);
SETCOLOR(0);
LINE(0,450,150,450);}
{SETFILLSTYLE(1,LIGHTCYAN);
FLOODFILL(200,100,0);}
readln;
End.
(* UNIVERSIDAD DE GUADALAJARA Coordinación de Sistemas Unidad de Cómputo Académico El siguiente ejemplo escribe en la pantalla una línea horizontal con solo proyectar pixeles mediante la función "PUTPIXEL", y sin utilizar alguna función tal como: "LINE", "LINETO", "LINEREL" etc. El color por defecto es el color blanco. si no se especifica otro. *) Program LineaHoriz; uses Crt, Graph; var xi,xf,x,y : integer; Gd, Gm : Integer; begin (* Detección del modo gráfico de su PC*) Gd := Detect; (* Inicialización del modo gráfico*) InitGraph(Gd, Gm, 'c:\tp\bgi'); (* Verificación de errores en el modo gráfico*) if GraphResult <> grOk then Halt(1); xi:=10; xf:=100; y:=250; For x:= xi to xf do putpixel (x,y,15); (* Aquí, se escriben los pixeles, formando una línea*) delay(5000); end.
(* UNIVERSIDAD DE GUADALAJARA Coordinación de Sistemas Unidad de Cómputo Académico El siguiente ejemplo muestra como hacer una línea solo utiliznado la función "PUTPIXEL", sin utilizar la función "LINE","LINETO","LINEREL" etc. El color por defecto es el color blanco, si no se especifica otro. *) Program LineaVer; uses Crt, Graph; var yi,yf,x,y : integer; Gd, Gm : Integer; begin (* Detección del adaptador gráfico de su PC *) Gd := Detect; (* Inicialización del modo gráfico *) InitGraph(Gd, Gm, 'c:\tp\bgi'); (* Verificación de errores en el modo gráfico *) if GraphResult<>grOk then Halt(1); yi:=10; yf:=100; x:=250; For y:= yi to yf do putpixel (x,y,15); (* Aquí se escriben los pixeles en la pantalla *) delay(5000); end.
(* UNIVERSIDAD DE GUADALAJARA Coordinación de Sistemas Unidad de Cómputo Académico Este programa realiza una tarea simple, dibuja una línea a partir de la unidad gráfica básica, el pixel, hace una llamada a la función "PUTPIXEL" la cual coloca un pixel en la pantalla y por medio de un ciclo se colocan pixeles en la pantalla de tal forma que producen una línea. El color por defecto es el color blanco, si no se especifica otro color. *) Program Linea; Uses Graph, Crt; var x1,y1, x2,y2, i:integer; (* Función por la cual se inicializa el modo gráfico *) Procedure Iniciar; var gD : Integer; gM : Integer; ErrCode : Integer; begin gD := Detect; (* Detección del adaptador gráfico de su PC *) InitGraph(gD,gM,'c:\tp\bgi'); (* Inicialización del modo gráfico *) ErrCode := GraphResult; if ErrCode<>grOk then (* Verificación de error en el modo gráfico *) Halt(1); End; Begin Iniciar; i:=0; x1:=50; y1:=50; x2:=100; y2:= 100; PutPixel(x1,y1,15); (* Se dibujan un par de pixeles *) PutPixel(x2,y2,15); (* Que son el punto inicial y final de la línea *) while (x1+i <x2) do Begin PutPixel(x1+i,y1+i,15); (* Aquí se dibujan los pixeles *) i:=i+1; (* siguientes para completar una línea *) End; readln; CloseGraph; End.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
El siguiente programa realiza un ejemplo de como dibujar líneas
aleatorias en una cierta zona de la pantalla, utilizando al función
"RANDOMIZE".
El color por defecto es el color blanco, si no se dice lo contrario
*)
Program Linea;
uses
Crt, Graph;
var
Gd, Gm : Integer;
begin
(* Detección del modo gráfico de su PC*)
Gd := Detect;
(* Inicialización del modo gráfico *)
InitGraph(Gd, Gm, 'c:\tp\bgi');
(* Verificación de errores en el modo gráfico*)
if GraphResult<>grOk then
Halt(1);
Randomize; (* Inicialización de números aleatorios *)
repeat
Line (Random(200), Random(200), (* Dibuja aleatoriamente una línea en *)
Random(200), Random(200)); (* en espacio 0-200. tanto para x como*)
until KeyPressed; (* para y. *)
ReadLn;
CloseGraph;
end.
(* UNIVERSIDAD DE GUADALAJARA Coordinación de Sistemas Unidad de Cómputo Académico Este programa dibuja una línea con la función "LINEREL", la cual pone la figura a partir de las coordenadas anteriores, es decir las coordenadas que se utilizaron en el último proceso antes de llamar a esta función, hasta las coordenadas relativas (dx , dy) que son pasadas como par metro de la función. El color por defecto es el color blanco, si no se dice lo contrario. *) Program Linea; uses Graph; var Gd, Gm : Integer; begin Gd := Detect; (* Detección del modo gráfico de su PC *) InitGraph(Gd, Gm, 'c:\tp\bgi'); (* Inicialización del modo gráfico *) if GraphResult<>grOk then (* Verificación de error en el modo *) Halt(1); MoveTo(1,2); (* "Nos movemos" hacia la posición (1,2) *) LineRel(100, 100); (* Se dibuja la línea a partir de la posición (1,2) *) ReadLn; (* hasta la posición (101,102) *) CloseGraph; end.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
El siguiente programa realiza un ejemplo de la función "RECTANGLE"
la cual dibuja un rectangulo o cuadrado en la pantalla, se
especifican las coordenadas ( x , y ) del punto superior izquierdo
del rectangulo así como el inferior derecho.
El color por defecto es el color blanco, si no se especifica otro.
*)
Program Rectangulo;
Uses CRT, GRAPH;
Var
Gd, Gm : Integer;
begin
(* Detección del modo gráfico *)
Gd := Detect;
(* inicializaión del modo gráfico *)
InitGraph(Gd, Gm, 'c:\tp\bgi');
(* Verificación de error en el modo gráfico *)
if GraphResult<>grOk then
Halt(1);
Rectangle(280,150,40,30);
Delay (5000);
CloseGraph; (* Cerrar modo gráfico *)
End.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Computo Académico
El siguiente programa realiza un ejemplo de la función "CIRCLE"
la cual dibuja un círculo con coordenadas especificadas en los
par metros de la función, así también el radio.
El color por defecto es el color blanco, si no se especifica otro.
*)
Program circulo;
uses
Graph;
var
Gd, Gm: Integer;
Radius: Integer;
begin
(* Detección del modo gráfico de su PC *)
Gd := Detect;
(* Inicialización del modo gráfico *)
InitGraph(Gd, Gm, 'c:\tp\bgi');
(* Verificación de error en el modo gráfico *)
if GraphResult<>grOk then
Halt(1);
for Radius := 1 to 5 do
Circle(100, 100, Radius*10);
ReadLn;
CloseGraph;
end.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
El siguiente programa dibuja un circulo en la pantalla y dos líneas
que atraviezan el circulo por el centro, llama primeramente al
procedimiento "Circulo". El procedimiento dibuja un circulo, realizando
los calculos necesarios para poder dibujar tal figura.
El color por defecto es el color blanco, si no se especifica otro.
*)
Program circulo_ecuacion;
Uses Graph, crt;
Var
xc, yc, radio : integer;
Procedure iniciar;
Var
Gd, Gm : Integer;
begin
(* Detección del adatpador gráfico de su PC *)
Gd := Detect;
(* Inicialización del modo gráfico *)
InitGraph(Gd, Gm, 'c:\tp\bgi');
(* Verificación de error en el modo gráfico *)
if GraphResult<>grOk then
Halt(1);
end;
(* Este procedimiento inicializa primeramente el modo gráfico, llamado
al procedimiento " iniciar ", posteriormente, realiza los calculos
necesarios para dibujar una circunferencia en la pantalla, con dos
líneas que pasan por el centro de ella.
*)
Procedure circulo (xc, yc, radio : integer);
Const
fi = 1.33;
Var
dtheta, ct,st,x,y,xtemp : real;
Begin
iniciar;
radio:=20;
dtheta := 1/radio;
ct:=cos(dtheta);
st:=sin(dtheta);
x:=0; xc:=150; yc:=150;
y:=radio;
while y >= x do
begin
(* Las líneas siguientes dibujan el circulo *)
putpixel(round(xc+x),round(yc+y*fi),15);
putpixel(round(xc-x),round(yc+y*fi),15);
putpixel(round(xc+x),round(yc-y*fi),15);
putpixel(round(xc-x),round(yc-y*fi),15);
(* Estos cuatro renglones siguientes dibujan las líneas*)
putpixel(round(xc+y),round(yc+y*fi),15);
putpixel(round(xc-y),round(yc+y*fi),15);
putpixel(round(xc+y),round(yc-y*fi),15);
putpixel(round(xc-y),round(yc-y*fi),15);
xtemp:=x;
x:=(x*ct-y*st);
y:=(y*ct+xtemp*st)
end;
end;
Begin
Circulo(xc,yc,radio); (* Llamada al procedimiento *)
readln;
closegraph;
end.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
Este programa dibuja en la pantalla un círculo, a partir de pixeles
que se desplazan por el perímetro del círculo hasta llegar a completar
la figura.
El color por defecto es el blanco, si no se especifica otro.
*)
Program Rect_Circulo;
Uses Graph,Crt;
Var
xc,yc,radio : real;
Procedure Iniciar;
var
Gd,Gm:Integer;
begin
(* Detección del adaptador gráfico de su PC *)
Gd := Detect;
(* Inicialización del modo gráfico *)
InitGraph(Gd, Gm, 'c:\tp\bgi');
(* Verificación de error en el modo gráfico *)
if GraphResult<>grOk then
Halt(1);
end;
Procedure Trazar_Circ(xc,yc,radio:real);
Const
dos_Pi = 6.28318;
fi = 1.33;
Var
dtheta,ct,st,x:real;
y,xtemp:real;
cont:integer;
Begin
(* Se realizan los calculos suficientes para definir la figura*)
radio:=50;
xc:=300; yc:=250;
dtheta:=dos_Pi/21*radio;
ct:=cos(dtheta);
st:=sin(dtheta);
x:=0;
y:=radio;
moveto(round(xc+x),round(yc+y*fi));
for cont:= 1 to round(591*radio) do
begin
xtemp:=x;
x:=(x*ct-y*st);
y:=(y*ct+xtemp*st);
(* Dibujar los pixeles en el perímetro del círculo *)
putpixel(round(xc+x),round(yc+y*fi),15)
end;
end;
begin
iniciar; (* Inicializar gráficos *)
Trazar_circ(xc,yc,radio); (* dibujar el círculo*)
readln;
end.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
Este programa da un ejemplo de la función gráfica "ELLIPSE", la
cual dibuja una elipse los par metros de esta función son:
coordenadas ( x , y ), ngulo inicial y final, foco1 y foco2.
El color por defecto el el color blanco, si no se especifica otro.
*)
Program Elipse;
uses
Graph;
var
Gd, Gm: Integer;
begin
(* Detección del modo gráfico de su PC *)
Gd := Detect;
(* Inicialización del modo gráfico *)
InitGraph(Gd, Gm, 'c:\tp\bgi');
(* Verificación de error en el modo gráfico *)
if GraphResult<>grOk then
Halt(1);
Ellipse(100,100,0,360,30,50);
Ellipse(100,100,0,180,50,30);
ReadLn;
CloseGraph; (* Cierre de modo Gráfico *)
end.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas,
Unidad de Cómputo Académico *)
(* El siguiente programa es un ejemplo del funcionamiento la función
gráfica "BAR",la cual dibuja una barra de Histograma en las coordenadas
indicadas a la función.
El color por defecto si no se indica es el color blanco. *)
Program Barras;
(* Ejemplo de Bar *)
uses
Graph;
var
Gd, Gm, I, Width: Integer;
begin
(* Se detecta el típo de adaptador gráfico de su PC *)
Gd := Detect;
(* Se inicializa el modo gráfico *)
InitGraph(Gd, Gm, 'C:\TP\BGI');
(* Verificación de error al inicializar el modo gráfico *)
if GraphResult<>grOk then
Halt(1);
Width := 10;
(* Dibujo del Histograma *)
for I := 1 to 5 do
Bar(I*Width, I*10, Succ(I)*Width, 200);
ReadLn;
CloseGraph;
end.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Computo Académico
El siguiente programa es un ejemplo de la función "BAR3D" la cual
dibuja una barra de Histograma en 3 dimensiones, las coordenadas
son especificadas en los par metros de la función, así como la
profundidad de la barra y si deve estar abierta o cerrada en la
parte superior de la barra. Este último par metro es booleano,
puede expresarse con las constantes TopOn y TopOff, que indican
uno y cero respectivamente.
El color por defecto es el color blanco, si no se especifica lo
contrario.
*)
Program Barras3;
uses
Graph;
var
Gd, Gm: Integer;
y0, y1, y2, x1, x2: Integer;
begin
(* Detección del modo gráfico *)
Gd := Detect;
(* Inicialización del modo gráfico *)
InitGraph(Gd, Gm, 'c:\tp\bgi');
(* Verificación de error al inicializar el modo gráfico *)
if GraphResult<>grOk then
Halt(1);
y0 := 10;
y1 := 60;
y2 := 110;
x1 := 10;
x2 := 50;
Bar3D(x1, y0, x2, y1, 10, TopOn); (* Este Histograma es cerrado *)
Bar3D(x1, y1, x2, y2, 10, TopOff);(* Este Histograma es abierto *)
ReadLn;
CloseGraph;
end.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
El siguiente programa realiza un ejemplo de la fución "PIESLICE"
la cual dibuja un sector, los par metros de esta función son:
las coordenadas del centro del sector, el ngulo inicial y el
ngulo final del sector, y finalmente el radio del sector.
El color por defecto es el color blanco, si no se especifica otro.
*)
Program Sectores;
uses
Graph;
const
Radius = 30;
var
Gd, Gm : Integer;
begin
(* Detección del modo gráfico de su PC *)
Gd := Detect;
(* Inicialización del modo gráfico *)
InitGraph(Gd, Gm, 'c:\tp\bgi');
(* Verificación de error en la inicialización de los gráficos *)
if GraphResult<>grOk then
Halt(1);
(* Dibuja un sector con centro en 100, 100 con un ngulo inicial de 0
grados hasta 270 grados, y el radio de 30 pixeles de ancho. *)
PieSlice(100, 100, 0, 270, Radius);
ReadLn;
CloseGraph;
end.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
El siguiente programa realiza un ejemplo de la utilización de la
función "PIESLICE", para ver como se realiza una gráfica Estadistica
de Pastel, cada sector ( PIESLICE ),es representado con un relleno
distinto para poder distinguir cada uno de los sectores.
*)
Program pastel_Graph;
Uses
Graph, Crt;
type
STR5 = string[5];
const
{ En este arreglo estan contenidas todas las 8 categorias de la
gráfica de pastel, ademas de que cada gráfica representa un año
desde 1986 hasta 1989 }
Accounts : array[1..4,1..9] of integer =
(( 1986, 133, 35, 33, 17, 29, 15, 17, 32 ),
( 1987, 122, 41, 30, 25, 18, 24, 43, 21 ),
( 1988, 111, 65, 57, 14, 17, 39, 32, 17 ),
( 1989, 100, 60, 70, 12, 16, 13, 17, 12 ) );
{ Este arreglo contiene el nombre de las 8 categorias de la gráfica }
AccTypes : array[1..9] of STR5 =
( ' ', 'Motor', 'Acsry', 'Reprs', 'Govmt',
'Lease', 'Tires', 'Paint', 'Misc');
Var
GraphDriver, GraphMode, MaxColors, ErrorCode,
XWidth, YHeight, ZDepth,
XAxis, YAxis, ZAxis,
XOrg, YOrg,
MaxX, MaxY : integer;
Scale, AspR : Real;
(* Procedimiento de inicialización de gráficos *)
Procedure initialize;
Var
Xasp, yasp : Word;
Begin
(* Detección del adaptador gráfico de su PC *)
GraphDriver := DETECT;
(* Inicialización del modo gráfico *)
InitGraph (GraphDriver, GraphMode, 'c:\tp\bgi' );
ErrorCode:=GraphResult;
(* Verificación de algún error en el modo gráfico *)
If ErrorCode<>grOK then
begin
writeln('Error de graficos: ',
GraphErrorMsg(errorCode) );
halt(1);
end;
MaxColors := GetMaxColor + 1;
GetAspectRatio(xasp, yasp);
AspR:=xasp / yasp;
MaxX := GetMaxX;
MaxY := GetMaxY;
end;
(* Procedimiento por el cual se espera hasta que el usuario teclee algo*)
procedure pause;
Var
Ch : Char;
Begin
While keypressed do ch:= ReadKey;
Ch := readKey;
end;
(* Función que convierte cualquier entero en una cadena, y esta es retornada*)
function I2S (Value : integer) :string;
var
buffer : string[10];
begin
str(value, Buffer);
I2S := Buffer;
end;
{ El siguiente procedimiento dibuja toda una gráfica de pastel, con sus
8 categorías, y la divisón de cada una de ellas }
procedure PieGraph( DataSet, x, y : integer);
Const
BlankLine = $0000;
Var
i, m, r, s, t, HJust, VJust, Total, CapColor : integer;
ArcRec : ArcCoordsType;
Begin
m := 135;
Total := 0;
for i := 2 to 9 do
inc( Total, Accounts[ DataSet, i ] );
r:=Total div 4;
{ Se define el tipo de línea para dibujar los sectores }
SetLineStyle ( UserBitLn, BlankLine, NormWidth);
{ Se define el tipo de relleno para el sector }
SetFillStyle ( 0, 0 );
{ Se dibuja el sector }
PieSlice ( x, y, m, m+1, r+10 );
{ Se capturan la coordenadas del sector }
GetArcCoords ( ArcRec );
if MaxColors > 4 then
SetColor (White);
{ Se especifica el tipo de texto para escribir el año }
SetTextStyle (SansSerifFont, HorizDir, 2 );
{ Si indica la justificación del texto }
SetTextJustify (RightText, BottomText );
{ Y por ultimo se escribe el texto deceado, en este caso el año }
OutTextXY (ArcRec.xEnd, ArcRec.yEnd,
I2S (Accounts[ DataSet, 1 ] ) );
{ Nuevamente se cambia de tipo de letra por el tipo "DefaultFont" }
SetTextStyle( DefaultFont, HorizDir, 1 );
if maxColors > 4 then
SetColor (EGAYellow);
s := 0;
t := 0;
{ En este ciclo se dibujan sector por sector de la gráfica de pastel }
for i := 2 to 9 do
begin
{ Se obtine cada vez un tipo distinto de rellenado para diferenciar
un sector de otro }
SetFillStyle( i-1, i-1 );
if MaxColors > 4 then
SetColor( white );
{ Se especifica un tipo de línea solida para dibujar los sectores }
SetLineStyle ( SolidLn, 0, NormWidth );
{ Se realizan los calculos necesarios para completar el circulo }
inc( t, round( 360 * ( Accounts[ DataSet, i ]
/ Total ) + 0.5 ) );
if t > 360 then t := 360;
if ( i = 9 ) AND ( t<360 ) then t := 360;
{ Y finalmente se dibuja la gráfica }
PieSlice ( x, y, s, t, r );
{ Nuevamente se define el tipo de línea para dibujar }
SetLineStyle ( UserBitLn, BlankLine, NormWidth );
{ Y también se define el tipo de relleno }
SetFillstyle( 0, 0 );
CapColor := i+8;
{ Si el valor de colores es m s de 15, es decir el m ximo de colores
se inicializa nuevamente en 7 }
if CapColor > 15 then capcolor := 7;
if MaxColors > 4 Then SetColor ( CapColor );
m := round ( ( t-s ) / 2 + s );
{ Se dibuja el sector }
PieSlice( x, y, m, m+1, r+5 );
GetArcCoords( ArcRec );
if ArcRec.xEnd > x then HJust := LeftText
else HJust := RightText;
if ArcRec.yEnd > y then VJust := TopText
else VJust := BottomText;
{ Finalmente se define la justificación del texto y el texto
que corresponde a cada sector de la gráfica }
SetTextJustify( HJust, VJust );
OutTextXY( ArcRec.xEnd, ArcRec.yEnd,
AccTypes[i] );
s := t;
end;
end;
{ Este procedimeinto es el encargado de presentar las gráficas con todos
los datos necesarios }
procedure DrawGraphs;
Var
i : integer;
begin
ClearDevice; { Se limpia la pantalla }
GraphDefaults;
{ Se dibuja el marco la gráfica }
Rectangle( 0, 0, MaxX, MaxY);
{ Se dibuja la primera gráfica }
PieGraph( 1, GetMaxX div 4, GetMaxY div 4 );
{ Se dibuja la segunda gráfica }
PieGraph( 2, GetMaxX div 4, 3*GetMaxY div 4 );
{ Se dibuja la tercera gráfica }
PieGraph( 3, 3*GetMaxX div 4, GetMaxY div 4 );
{ Se dibuja la cuarta gráfica }
PieGraph( 4, 3*GetMaxX div 4, 3*GetMaxY div 4 );
end;
begin
Initialize; { Inicialización de gráficos }
DrawGraphs; { Se manda llamar el procedimiento para dibujar las gráficas }
Pause; { Espera una pausa antes de terminar el programa }
CloseGraph;
end.
{ UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
El siguiente programa muestra como se pueden realizar programas
para dibujos de tercera dimensión, este programa muestra un modelo
de automovil, el cual puede ser rotado para ser visto en varias
perspectivas, para poder ver estas perspectivas se utilza el teclado
numerico, la tecla 8 mueve hacia arriba el modelo, la tecla 2 mueve
el modelo hacia abajo, la tecla 4 mueve el modelo a la izquierda y
la tecla 6 mueve el modelo a la derecha.
Para salir del programa presione la tecla " Q ".
}
PROGRAM PRESENT;
uses Crt, Graph;
var
BE,ba,bi, GD,t, GM: Integer;
C: CHAR;
Xasp, Yasp: word;
rxasp, ryasp, p: real;
x,y,z: real;
ratio, Angular,prof: real;
switch: integer;
xa,ya,za: real;
R1,R2,R3: REAL;
CR1,CR2,CR3: REAL;
SR1,SR2,SR3: REAL;
s : string;
{ Este procedimiento es el que realiza el movimiento en 3D, utiliza las
variables en donde se guardan los datos de los c lculos de Cosenos y
Senos y obtiene la coordenada cartesiana en "X", "Y" y "Z" }
procedure move3d(x,y,z: real);
begin
xa:=cr1* x-sr1* z;
za:=sr1* x+cr1* z;
x:=cr2*xa+sr2* y;
ya:=cr2* y-sr2*xa;
z:=cr3*za-sr3*ya;
y:=sr3*za+cr3*ya;
moveto(round(angular* x/(prof-z))+320 ,175-round(Ratio*angular* y/(prof-z)) );
end;
{ Este procedimeinto junto con "MOVE3D" realizan el c lculo de la coordenada
y dibujo de la línea en esa posición }
procedure join3d(x,y,z: real);
var x1,y1,x2,y2:integer;
begin
x1:=getx;
y1:=gety;
move3d(x,y,z);
x2:=getx;
y2:=gety;
line(x1,y1,x2,y2); { Se dibuja la línea ya en 3D }
end;
{ Este procedimeinto utiliza los las propiedades de los otros
procedimeintos para calcular la posición en 3D y dibujar una línea
en tal posición }
procedure lini(x1,y1,z1,x2,y2,z2:real);
begin
move3d(x1,y1,z1);
join3d(x2,y2,z2);
end;
{ El siguinete procedimiento obtiene el c lculo con las funciones
trigonometricas "Seno" y "Coseno", y de los números enviados como
par metros, y este c lculo se deposita en las variables globales
"SR1","SR2","SR3","CR1","CR2" y "CR3" }
procedure setupang(a1,a2,a3: real);
begin
SR1:=sin(a1); CR1:=cos(a1);
SR2:=sin(a2); CR2:=cos(a2);
SR3:=sin(a3); CR3:=cos(a3);
end;
{ Esta función obtiene el angulo dado en radianes }
function radian( th: integer ): real;
begin
radian:=(pi/180.0*th);
end;
{ Este procedimiento obtiene las coordenadas cartesianas en 3D para el
eje Z en el dibujo de un circulo, y dibuja la línea corespondiente
a este punto para el circulo }
procedure circuloz(x1,y1,z1,r :real );
var
ang,inc : real;
begin
move3d(x1+r,y1,z1);
ang:=0.0;
inc:=pi/18;
while ang<= 2*pi+0.1 do
begin
join3d(x1+r*cos(ang),y1+r*sin(ang),z1);
ang:=ang+inc;
end;
end;
{ Este procedimiento obtiene las coordenadas cartesianas en 3D para el
eje Y en el dibujo de un circulo, y dibuja la línea corespondiente
a este punto para el circulo }
procedure circuloy(x1,y1,z1,r :real );
var
ang,inc : real;
begin
move3d(x1,y1,z1+r);
ang:=0.0; inc:=pi/18;
while ang<= 2*pi+0.1 do
begin
join3d(x1+r*sin(ang),y1,z1+r*cos(ang));
ang:=ang+inc;
end;
end;
{ Este procedimiento obtiene las coordenadas cartesianas en 3D para el
eje X en el dibujo de un circulo, y dibuja la línea corespondiente
a este punto para el circulo }
procedure circulox(x1,y1,z1,r :real );
var
ang,inc : real;
begin
move3d(x1,y1+r,z1);
ang:=0.0; inc:=pi/18;
while ang<= 2*pi+0.1 do
begin
join3d(x1,y1+r*cos(ang),z1+r*sin(ang));
ang:=ang+inc;
end;
end;
{ Este procedimiento obtiene las coordenadas cartesianas en 3D para el
eje Z en el dibujo de una elipse, y dibuja la línea corespondiente
a este punto para la elipse }
procedure ellipsez(x1,y1,z1,r,ex,ey,ani,anf :real );
var
ang,inc,r1,r2 : real;
begin
r1:=r*ex;
r2:=r*ey;
move3d(x1+r1*cos(ani),y1+r2*sin(ani),z1);
ang:=ani; inc:=pi/18;
while ang<= anf+0.1 do
begin
join3d(x1+r1*cos(ang),y1+r2*sin(ang),z1);
ang:=ang+inc;
end;
end;
{ Este procedimiento obtiene las coordenadas cartesianas en 3D para el
eje Y en el dibujo de una elipse, y dibuja la línea corespondiente
a este punto para la elipse }
procedure ellipsey(x1,y1,z1,r,ex,ez,ani,anf :real );
var
ang,inc,r1,r2 : real;
begin
r1:=r*ex;
r2:=r*ez;
move3d(x1+r1*sin(ani),y1,z1+r2*cos(ani));
ang:=ani; inc:=pi/18;
while ang<= anf+0.1 do
begin
join3d(r1*sin(ang),y1,r2*cos(ang));
ang:=ang+inc;
end;
end;
{ Este procedimiento obtiene las coordenadas cartesianas en 3D para el
eje X en el dibujo de una elipse, y dibuja la línea corespondiente
a este punto para la elipse }
procedure ellipsex(x1,y1,z1,r,ey,ez,ani,anf :real );
var
ang,inc,r1,r2 : real;
begin
r1:=r*ey;
r2:=r*ez;
move3d(x1,y1+r1*cos(ani),z1+r2*sin(ani));
ang:=ani; inc:=pi/18;
while ang<= anf+0.1 do
begin
join3d(x1,y1+r1*cos(ang),z1+r2*sin(ang));
ang:=ang+inc;
end;
end;
{---------------------------- Programa principal--------------------------- }
begin
GD := 9;
GM := 1;
{ Inicialización de gráficos }
InitGraph(GD, GM, 'c:\tp\bgi');
{ }
if GraphResult<>grOk then
Halt(1);
Angular:=600.0;
Prof:=1000; { Se tiene una profundidad de 1000 para ser visto mejor }
p:=-1;
switch := -1;
r1:=radian(0); { Se obtienen los grados radianes de cierto número }
r2:=radian(0);
r3:=radian(0);
setupang(r1,r2,r3); { Se obtienen los angulos en radianes de dichos números}
GetAspectRatio(Xasp, Yasp);
RXasp:=xasp;
RYasp:=yasp;
Ratio:=rXasp/rYasp;
c:='m';
prof:=prof+3;
x:=0.0;
y:=100.0;
setcolor(15); { Se toma el color Blanco para dibujar el modelo }
s:='-+64.028';
while c<>'Q' do begin
case c of
{ Si se presiona la tecla "-" el modelo es reducido }
'-' : prof:=prof+50;
{ Si se presiona la tecla "+" el modelo si amplia }
'+' : prof:=prof-50;
{ Si se presiona "0, 6, 4, 2, 8, ." el model solo rotar }
'0' : r1:=r1+radian(10);
'.' : r1:=r1-radian(10);
'6' : r2:=r2+radian(10);
'4' : r2:=r2-radian(10);
'2' : r3:=r3+radian(10);
'8' : r3:=r3-radian(10);
end;
setupang(r1,r2,r3); { Nuevamente se obtienen los angulos de los números }
setcolor(15);
{ Enseguida se dibuja cada línea que conforma el modelo, así
como los circulos y elipses del mismo en 3D }
lini(-200,100,400,200,100,400);
lini(200,100,400,200,100,-400);
lini(-200,100,-400,200,100,-400 );
lini(-200,100,400,-200,100,-400);
lini(200,100,100,-200,100,100);
lini(-200,100,100,-200,180,100);
lini(-200,180,100,200,180,100);
lini(200,180,100,200,100,100);
circuloz(-100,50,400,30);
circuloz(100,50,400,30);
lini(-200,100,400,-200,0,400);
lini(-200,0,400,200,0,400);
lini(200,0,400,200,100,400);
lini(200,0,400,200,0,300);
ellipsex(200,0,250,50,1,1,-pi/2,pi/2);
{ En seguida se muestra una pagina de memoria en la que se
guarda el dibujo del modelo para posteriormente modificarlo
y crear así un efecto de animación sobre dicho modelo }
if switch<0 then SetVisualPage(0)
else SetVisualPage(1);
switch:=switch*-1;
C:=upcase(READKEY);
if Pos(C,s)>0
then begin
{ En este caso se selecciona la p gina en la que se dibujara
el modelo, en esta pagina se redibuja con unas nuevas
coordenadas y despues sera mostrado y se apreciar el
efecto de animación }
if switch > 0 then SetActivePage(1) { Va a pagina oculta }
else SetActivePage(0);
cleardevice; { Se limpia la pantalla }
end;
end;
CLOSEGRAPH; { Se cierra el modo gráfico }
CLRSCR; { Y se vuelve al modo ASCII, entonces se limpia la pantalla }
END.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
El siguiente programa es un ejemplo de una animación simple,
abre un archivo, y comienza a hacer un desplazamiento de este junto
con una barra.
*)
Program avionazo;
uses crt{,dos,},graph;
type
dibujillo=array[0..51,0..87] of byte;
var
Dibujo:Dibujillo; (* Buffer para el archivo, aquí se guardar n *)
Fd:file of dibujillo; (* los bits del archivo leido.*)
k,m,i,j:integer;
G:Pointer;
modo,a,b:word;
gm,gd:integer;
begin
{detectgraph(monitor,modo);}
Gd := Detect;
(* Se inicializa el modo gráfico *)
InitGraph(Gd, Gm, 'C:\TP\BGI');
(* Verificación de error en el modo gráfico*)
if graphresult<>grOK then
halt;
{$i-} (* Directiva de Compilación de desctiva la verificación de erroes*)
Assign(Fd,'c:\windows\arbol.pcx'); (* Se asigna el archivo *)
Reset(Fd);
if ioresult<>0 then (* Si hubo un error al abrir el archivo el *)
halt (* programa termina*)
else
Read(Fd,Dibujo); (* Se lee el archivo y se cierra*)
Close(Fd);
{$i+}
randomize;
setfillstyle(1,lightcyan);
Bar(0,0,639,479); (* Se dibuja una barra de toda la pantalla*)
for m:=1 to 20 do
for i:=0 to 51 do
for j:=0 to 87 do
(* Segun el bit correspondiente *)
(* se comienza a dibujar el color*)
(* de ese bit.*)
putpixel(j,100+i,dibujo[i,j]);
(* Aquí, comienza el primer paso para la animación, se reserva memoria*)
Getmem(G,Imagesize(0,0,87,51));
(* Una vez reservada la memoria de graba o se trae la imagen*)
Getimage(0,100,87,151,G^);
(* Y ya la imagen en la memoria se imprime en pantlla*)
Putimage(0,100,G^,NormalPut);
modo:=Normalput;
setfillstyle(1,15);
(* En este ciclo se comienza el corrimiento *)
for i:=0 to 270 do
begin
bar(i*2,90,i,140); (* Se dibuja una barra variable *)
setcolor(0);
line(i*2,90,i,90); (* Unas líneasa que son el contorno de la barra*)
line(i*2,140,i,140);
setcolor(15);
line(i*2,115,i,115);
bar(i*2,90,i*2,140);
Putimage(i*2,100,G^,modo); (* Y finalmente se proyecta la imagen de
memoria, logrando así el corrimiento de
la imagen. *)
end;
readln;
end.
(* UNIVERSIDAD DE GUADALAJARA
Coordinación de Sistemas
Unidad de Cómputo Académico
El siguiente programa es un editor simple de Iconos en modo gráfico
su funcionamiento es simple, se tiene un enrejado que es la zona en donde
Ud. editar su ícono, a la derecha de la pantalla aparece una leyenda
"COLOR", y debajo de ella un color específico, esto indica el color que
se tiene actualmente para dibujar el ícono, se puede cabiar de color solo
con presionar la tecla "F2" si aparece una leyenda "ACTIVO" justo debajo
del color seleccionado indica que ese color est activo en este momento
para poder dibujar, para activar y desactivar colores se presiona "F1",
debajo aparecen las coordenadas en que se encuentra el cursor del editor
en ese momento, así como el color del pixel o del recuadro en esas
coordenadas.
Si presiona "F4", el editor mostrar su diseño de ícono reducido, presione
la tecla "Esc" para regresar al editor. Si oprime la tecla "F5" el editor
terminar su seción (exit), si presiona la tecla "F6" aparecera una ventana
que le pide el nombre de un archivo creado previamente con este editor,
si presiona la tecla "F7" también aparecer una ventana que indica con
que nombre se debe grabar el archivo actual. Si presiona la tecla "F8"
aparecer nuevamente su diseño de ícono solo que de una escala mayor que
la vista con "F4", oprima "Esc" para regresar al editor, si oprime la tecla
"F9" el diseño actual es borrado por completo, la forma de desplazar el
cursor atravez del enrejado es por medio de las teclas de flechas,
la tecla "INSERT" al ser presionada el cursor cambia de posición a la
posición rumbo nor-este de la ubicación actual, la tecla "HOME" mueve el
cursor hacia la posición nor-oeste de la posición actual, la tecla
"DELETE" mueve el cursor a la posición sur-este del punto actual del cursor,
la tecla "END" mueve el cursor a la posición sur-oeste, las teclas
"PageUp" sirve para subir la posición del número de color en la que estamos,
la tecla "PageDown" es la contraria a "PageUp", nos " mueve " posiciones
abajo del número de color en el que estamos. El número de colores va desde
0-255.
*)
program importa_del_PM;
USES
CRT,GRAPH,DOS;
CONST { Constantes para detectar las teclas oprimidas }
B_ESPACE=#8; ENTER=#13; ESCAPE=#27;
F1=';'; F2='<'; F3='='; F4='>'; F5='?';
F6='@'; F7='A'; F8='B'; F9='C'; F10='D';
F_ARR='H'; F_I='K'; F_D='M'; F_AB='P'; DEL='S'; INS='R';
HOME='G';FIN='O';F11='T';F12='U';PU='I';PD='Q';
TYPE ARCH=RECORD
INICIO:ARRAY[1..4] OF CHAR;
MATRIZ:ARRAY[1..52,1..11] OF BYTE;
TERMINO:CHAR;END;
CONV=ARRAY[0..51,0..87] OF BYTE;
PERMITIDOS=SET OF CHAR;
VAR MAT:ARCH; { Buffer del archivo }
ARCHIVO:FILE OF ARCH; { Declaración del archivo }
ARCHVGA:FILE OF CONV;
DIBUJO:CONV;CAD:STRING;
I,J,K,L:INTEGER;ALGO:CHAR;
MANO,MANO2:ARRAY[1..9] OF FILLPATTERNTYPE;
(* Este procedimiento como su nombre lo dice cambia el color con el que
se va a colorear. Cambiando los colores en los registros de proposito
general de su PC *)
PROCEDURE CAMBIA_COLOR(COLOR,ROJO,VERDE,AZUL:BYTE);
VAR
RES:REGISTERS;
BEGIN
FILLCHAR(RES,SIZEOF(RES),0);
WITH RES DO
BEGIN
AH:=$10;
AL:=$10;
BX:=COLOR;
DH:=ROJO;
CH:=VERDE;
CL:=AZUL;
INTR($10,RES);
END;
END;
{ Este precedimiento cambia el color y la trama en una cierta
zona del enrrejado del dibujo }
PROCEDURE BOX(X1,Y1,X2,Y2,TRAMA,COLOR:INTEGER);
VAR
TRAM:FILLPATTERNTYPE;
I:INTEGER;
BEGIN
FILLCHAR(TRAM,SIZEOF(TRAM),0);
CASE TRAMA OF
{ Se selecciona el modo de relleno para una zona del dibujo }
1..9:SETFILLSTYLE(TRAMA,COLOR);
10:BEGIN
FOR I:=1 TO 8 DO
BEGIN
TRAM[I]:=$AA;
{ Se selecciona un típo de paleta definida por el usuario }
SETFILLPATTERN(TRAM,COLOR);
END;
END;
11:BEGIN
FOR I:=1 TO 8 DO
BEGIN
IF ODD(I) THEN
TRAM[I]:=$FF ;
{ Se selecciona un típo de paleta definida por el usuario }
SETFILLPATTERN(TRAM,COLOR);
END;
END;
END;
BAR(X1,Y1,X2,Y2); { Una vez que se ha obtenido el color se dibuja la
barra de ese color }
END;
{ Este procedimiento dibuja en las coordenadas indicadas, una caja de la
trama y colores indicados }
PROCEDURE CAJA(X1,Y1,X2,Y2,TRAMA,C1,C2:WORD);
VAR I,J:INTEGER;
BEGIN
{ Se obtiene un típo de línea especificado por el usuario }
SETLINESTYLE(USERBITLN,TRAMA,NORMWIDTH);
{ En seguida se dibuja una caja con un color específico }
BOX(X1,Y1,X2,Y2,1,C1);
SETCOLOR(C2);
FOR I:=Y1 TO Y2 DO
IF ODD(I) THEN
LINE(X1,I,X2,I);
IF TRAMA<>0 THEN
{ Si la trama del dibujo es diferente de 0 se define una línea
por el usuario, y se hace una operación a nivel de bits con
la trama y el número hexadecimal FFFF, para determinar la línea }
SETLINESTYLE(USERBITLN,TRAMA XOR $FFFF,NORMWIDTH);
FOR I:=Y1 TO Y2 DO
IF NOT(ODD(I)) THEN
LINE(X1,I,X2,I);
END;
{ La siguiente funcion realiza una simple comparación de números, en la
cual al variable "NUMMAY" debe ser menor o igual a "NUMMEN" e igual a
"NUMMAY"}
FUNCTION INN(NUMMAY,NUMERO,NUMMEN:INTEGER):INTEGER;
BEGIN
IF NUMERO<NUMMEN THEN
NUMERO:=NUMMEN
ELSE
IF NUMERO>NUMMAY THEN
NUMERO:=NUMMAY;
INN:=NUMERO;
END;
{ Esta función devuelve la tecla presionada }
FUNCTION INKEY(VAR SECUNDARIO:BOOLEAN):CHAR;
VAR CAR:CHAR;
BEGIN
SECUNDARIO:=FALSE;
CAR:=READKEY;
IF (CAR=CHAR(0)) AND KEYPRESSED THEN
BEGIN
CAR:=READKEY;
SECUNDARIO:=TRUE;
END;
INKEY:=CAR;
END;
(* Rellena una zona del enrejado "X","Y" con color "CF", y el tipo
de relleno se define por "TRAMA".*)
PROCEDURE PAINT(X,Y,TRAMA,CF,CB:INTEGER);
BEGIN
SETFILLSTYLE(TRAMA,CF);
FLOODFILL(X,Y,CB);
END;
(* Este procedimiento dibuja el texto enviado por "CHAR4X8" dibuja
pixel por poxel las letras, no utiliza las funciones gráficas
para proyectar texto en la pantalla, sino que es manualmente el dibujo
del texto.*)
PROCEDURE DIBUJ(X,Y,ESTILO,COLOR:INTEGER;FIGURA_C:FILLPATTERNTYPE);
VAR I,J,NUM1,NUM2,RES,IT:BYTE;D_L,ITALICS:BOOLEAN;
BEGIN
RES:=0;SETCOLOR(0);D_L:=FALSE;ITALICS:=FALSE;IT:=0;
IF ESTILO=3 THEN
BEGIN
D_L:=TRUE;
ESTILO:=2
END;
IF ESTILO=4 THEN
BEGIN
IT:=1;
ESTILO:=2
END;
IF ESTILO=5 THEN
BEGIN
IT:=1;D_L:=TRUE;
ESTILO:=2
END;
FOR J:=0 TO (ESTILO*4-1) DO
BEGIN
I:=0;
NUM1:=FIGURA_C[J+1];
WHILE (NUM1>=1) DO
BEGIN
NUM2:=NUM1 DIV 2;
RES:=NUM1-(NUM2 *2);
NUM1:=NUM2;
IF RES=1 THEN BEGIN IF D_L THEN
BEGIN
(* Aquí se dibujan pixel por pixel*)
(* los caracteres de texto.*)
PUTPIXEL(X+8-I+(IT*((7-J) DIV 2)),Y+(J*2),COLOR);
PUTPIXEL(X+8-I+(IT*((7-J) DIV 2)),Y+(J*2)+1,COLOR);
END
ELSE PUTPIXEL(X+8-I+(IT*((7-J) DIV 2)),Y+J,COLOR);END;
I:=I+1;
END;
END;
END;
(*_______________________________________________________________________*)
(* Este procedimiento es llamado por "TEXT4X8" el cual le manda un caracter
y a su vez este procedimiento llama a "DIBUJ", para que este caracter
sea impreso en la pantalla .*)
PROCEDURE CHAR4X8(CARACTER:CHAR;XCOR,YCOR,COLOR,ESTILO:INTEGER);
VAR
COUNT,MASCARA,I,NIBBLE1,ASCII:BYTE;
SEGMENTO,PRINCIPIO:LONGINT;
FIGURA_C:FILLPATTERNTYPE;STYLE:INTEGER;
BEGIN
FILLCHAR(FIGURA_C,SIZEOF(FIGURA_C),0);
ASCII:=ORD(CARACTER);
SEGMENTO:=$F000;
PRINCIPIO:=$FA6E+(ASCII*8);
COUNT:=0;
STYLE:=ESTILO;
IF ESTILO>2 THEN ESTILO:=2;
CASE ESTILO OF
1:BEGIN
FOR I:=0 TO 3 DO
BEGIN
COUNT:=I*2;
NIBBLE1:=MEM[SEGMENTO:PRINCIPIO+COUNT] ;
FIGURA_C[I+1]:=NIBBLE1;
END;
FIGURA_C[8]:=(MEM[SEGMENTO:PRINCIPIO+7]);
IF (CARACTER IN['3','8','F','E','B','K','H','b','d','f']) THEN
FIGURA_C[5]:=FIGURA_C[4] OR 28;
IF (CARACTER IN['E','F']) THEN
FIGURA_C[6]:=FIGURA_C[6] AND 239;
IF (CARACTER='p') THEN FIGURA_C[7]:=FIGURA_C[7] OR 24;
IF (CARACTER IN['q','g']) THEN FIGURA_C[7]:=FIGURA_C[7] OR 12;
END;
2: BEGIN
FOR I:=0 TO 7 DO
FIGURA_C[I+1]:=(MEM[SEGMENTO:PRINCIPIO+I]);
END;
END;
(* Llamada al procedimiento para que dibuje el caracter.*)
DIBUJ(XCOR,YCOR,STYLE,COLOR,FIGURA_C);
END;
(*_______________________________________________________________________*)
(* Este procedimiento manda llamar a sus hijos para que sea impreso
en la pantalla el texto pasado como par metro, este texto es escrito
pixel por pixel, no se utilizan funciónes gráficas de texto. *)
PROCEDURE TEXTO4X8(TEXTO:STRING;XCOR,YCOR,COLOR,ESTILO:INTEGER);
VAR
COLUM,I:INTEGER;
BEGIN
COLUM:=XCOR;
FOR I:=1 TO LENGTH(TEXTO) DO
BEGIN
(* Llamada al procedimiento para que escriba el caracter.*)
CHAR4X8(TEXTO[I],COLUM,YCOR,COLOR,ESTILO);
COLUM:=COLUM+8;
END;
END;
(*_______________________________________________________________________*)
{ El siguiente procedimiento escribe en la pantalla (con texto especificado
por el programador no con funciones gráficas de texto), en la parte de
la patalla especificada por "COLUMNA" }
PROCEDURE CENT(FRASE:STRING;Y,XMEN,XMAY,COLOR,ESTILO:INTEGER);
VAR COLUMNA:INTEGER;
BEGIN
COLUMNA:=XMEN+(((XMAY-XMEN)-(LENGTH(FRASE)*8)) DIV 2);
TEXTO4X8(FRASE,COLUMNA,Y,COLOR,ESTILO);
END;
(*_______________________________________________________________________*)
{ Este procedimiento es usado cada vez que se intenta grabar o abrir un
archivo, porque es capaz de escribir en modo gráfico y la cadena escrita
se obtiene en la variable "CAD" }
PROCEDURE LEE_CADENA(VAR CAD:STRING;NUM:INTEGER;DAT:PERMITIDOS);
VAR
I,J,K,X,Y:INTEGER;
CAR:CHAR;
BEGIN
I:=1;
CAR:=' ';
X:=GETX;
Y:=GETY;
{ Escribir texto en las coordenadas "X", "Y", y de colr rojo }
TEXTO4X8(CAD,X,Y,RED,2);
MOVETO(X,Y);
CAR:=UPCASE(READKEY); { Verifica la primera tecla presionada }
{ Si la tecla presionada fue "ENTER" se mueve de posición, y dibuja
una caja de color blanco y la variable "CAD" toma el valor de ENTER }
IF CAR<>#13 THEN
BEGIN
BOX(X,Y,X+(LENGTH(CAD)*8),Y+8,1,WHITE);
FILLCHAR(CAD,SIZEOF(CAD),0);
MOVETO(X,Y);
END;
{ Si la tecla presionada es diferente de "ENTER" se inserta en la
variable "CAD" }
WHILE (CAR<>#13) DO
BEGIN
IF (CAR IN DAT) AND (I<=NUM) THEN
INSERT(CAR,CAD,I);
{ Si la tecla presionada es "BACKSPACE" se recorre una posición y
borra el caracter anterior con una barra blanca }
IF (CAR=#8) AND (I>1) THEN
BEGIN
DELETE(CAD,I-1,1);
MOVETO(X+((I-2)*8),Y);
BOX(GETX,GETY,GETX+8,GETY+8,1,WHITE);
END;
{ En caso de que la tecla oprimida haya sido "ESC" la variable
"CAD" no toma valor alguno }
IF CAR=#27 THEN BEGIN
BOX(X,Y,X+(LENGTH(CAD)*8),Y+8,1,WHITE);
MOVETO(X,Y);CAD:='';
END;
I:=LENGTH(CAD)+1;
MOVETO(X,Y);
TEXTO4X8(CAD,GETX,GETY,RED,2); { Si la tecla presionada es algún
caracter este se imprime en
la pantalla }
CAR:=UPCASE(READKEY); { Y espera a que presione la siguiente
tecla }
END;
MOVETO(X,Y+1);
END;
(*_______________________________________________________________________*)
(* Este procedimiento crea el enrajado de la zona donde se dibuja el ícono *)
PROCEDURE Rejilla(X,Y:INTEGER);
VAR I,J:INTEGER;
BEGIN
SETLINESTYLE(USERBITLN,$FFFF,NORMWIDTH);
SETCOLOR(BLUE);
FOR I:=0 TO 87 DO
FOR J:=0 TO 51 DO
RECTANGLE(X+(I*6),Y+(J*6),X+(I*6)+6,Y+(J*6)+6);
END;
{ Este procedimiento rellena una zona del dibujo de un cierto color }
PROCEDURE DIBUJA2(X,Y:INTEGER);
VAR I,J,K,H,COLOR:INTEGER;
COMODIN:BYTE;
BEGIN
WITH MAT DO BEGIN
FOR I:=0 TO 51 DO
FOR J:=0 TO 10 DO
FOR K:=7 DOWNTO 0 DO
BEGIN
{ Primero se obtiene el color para dibujar en la variable "COMODIN" }
COMODIN:=(MATRIZ[I+1,J+1] AND (1 SHL K)) DIV (1 SHL K) XOR 1;
COMODIN:=COMODIN*15;
{ Comienza a dibujar la zona del color determinado por "COMODIN" }
PAINT(X+2+((J*8)+7-K)*6,Y+((I)*6)+2,1,COMODIN,BLUE);
DIBUJO[I,(7-K)+(J*8)]:=COMODIN;
END;
END;
END;
PROCEDURE DIBUJA(X,Y,INC,DEC:INTEGER);
VAR
I,J,K,H,MONITOR,MODO,COLOR:INTEGER;
COMODIN:BYTE;
BEGIN
DETECTGRAPH(MONITOR,MODO);
IF (MONITOR=VGA) THEN
COLOR:=yellow
ELSE
COLOR:=1;
WITH MAT DO BEGIN
FOR I:=1 TO 52 DO
FOR J:=1 TO 11 DO
FOR K:=7 DOWNTO 0 DO
BEGIN
COMODIN:=(MATRIZ[I,J] AND (1 SHL K)) DIV (1 SHL K) XOR 1;
COMODIN:=COMODIN*COLOR;
SETCOLOR(COMODIN);
LINE(X+((J*8*INC DIV DEC)-(K*INC DIV DEC)),Y+I,
X+((INC-1) DIV DEC)+((J*8*INC DIV DEC)-(K*INC DIV DEC)),Y+I);
END;
END;
END;
{ El siguiente procedimiento dibuja en la pantalla el dibujo que ha creado
en una escala menor }
PROCEDURE DIBUJA_CH;
VAR
I,J:INTEGER;
COMODIN:POINTER;
SECUNDARIO:BOOLEAN;
K:CHAR;
BEGIN
{ Primero se guarda memoria sobre la cual se guardar la imagen }
GETMEM(COMODIN,IMAGESIZE(100,80,187,131));
{ Posteriormente se guarda la imagen en la memoria }
GETIMAGE(100,80,187,131,COMODIN^);
K:=' ';
FOR I:=0 TO 51 DO
FOR J:=0 TO 87 DO
{ Se presenta el dibujo en una escala menor }
PUTPIXEL(100+J,80+I,DIBUJO[I,J]);
REPEAT
K:=INKEY(SECUNDARIO); { No se hace otra acción hasta presionar "ESC" }
UNTIL (K=CHR(27));
{ Despues de imprime la imagen guardada en memoria }
PUTIMAGE(100,80,COMODIN^,NORMALPUT);
{ Y se libera la memoria en la que se guardo el imagen }
FREEMEM(COMODIN,IMAGESIZE(100,80,187,131));
END;
{ El siguente procedimiento dibuja una serie de cajas con un color y un
trama }
PROCEDURE DIBUJA3;
VAR
I,J,X,Y,CO:INTEGER;
ES:WORD;
BEGIN
X:=100;
Y:=10;
FOR I:=0 TO 51 DO
FOR J:=0 TO 87 DO
BEGIN
CO:=DIBUJO[I,J] DIV 16;{ Se obtiene el color de las líneasa de la caja }
IF DIBUJO[I,J]>15 THEN { Esta sentencia obtine el trama de la caja }
ES:=$AAAA
ELSE
ES:=0;
{ Una vrez obtenidos los datos se dibuja la caja }
CAJA(X+(J*6)+1,Y+(I*6)+1,X+(J*6)+5,Y+(I*6)+5,ES,DIBUJO[I,J],CO);
END;
END;
{ Este procedimiento realiza una operación parecida a la efectuada por el
procedimiento "DIBUJA_CH" proyecta el dibujo creado en una escala menor }
PROCEDURE DIBUJA4;
VAR
I,J:INTEGER;
SECUNDARIO:BOOLEAN;
K:CHAR;
COMODIN:POINTER;
BEGIN
{ Primero se reserva memoria para guardar la imagen }
GETMEM(COMODIN,IMAGESIZE(100,80,296,184));
{ Posteriormente se gurada la imagen en la memoria reservada }
GETIMAGE(100,80,296,184,COMODIN^);
K:=' ';
FOR I:=0 TO 51 DO
FOR J:=0 TO 87 DO
BEGIN { Y finalmente se dibuja la imagen }
BOX(100+(J*2),80+(I*2),101+(J*2),81+(I*2),1,DIBUJO[I,J]);
IF DIBUJO[I,J]>15 THEN
PUTPIXEL(101+(J*2),81+(I*2),DIBUJO[I,J] DIV 16);
END;
REPEAT
K:=INKEY(SECUNDARIO); { El programa no realiza otra acción hasta no
presionar "ESC" }
UNTIL (K=CHR(27));
{ Una vez precionado "ESC" se proyecta la imagen guardada en memoria }
PUTIMAGE(100,80,COMODIN^,NORMALPUT);
{ Y se libera esa memoria }
FREEMEM(COMODIN,IMAGESIZE(100,80,296,184));
END;
(* Este procedimiento graba en disco el archivo o dibujo ya echo. *)
PROCEDURE GRABA_EN_DISCO;
BEGIN
WRITE(ARCHVGA,DIBUJO);
CLOSE(ARCHVGA);
END;
(* Este procedimiento abre un archivo de disco creado previamente con
el editor. *)
PROCEDURE LLAMA_DE_DISCO;
BEGIN
READ(ARCHVGA,DIBUJO);
CLOSE(ARCHVGA);
END;
(* Este procedimiento actua segun sea "OPCION", si fue "F6", pide el
nombre del archivo para guardarlo en el disco, si fue "F7", pide
el nombre del archivo para abrirlo desde el disco. *)
PROCEDURE VENTANA_DISCO(OPCION:CHAR;VAR DIBUJO:CONV);
VAR I,J:INTEGER;WIN:POINTER;NOMBRE:STRING;
BEGIN
{$I-}
{ Primero se guarda la imagen donde se dibujara sobre ella }
GETMEM(WIN,IMAGESIZE(100,30,440,70));
GETIMAGE(100,30,440,70,WIN^);
{ Y posteriormente se dibuja la ventana de di logo }
CAJA(120,30,440,70,$CCCC,BLUE,BLACK);
BOX(140,40,420,60,1,WHITE);NOMBRE:='';
CASE OPCION OF
'G':BEGIN { Si la tecla fué F6 se grabar un archivo}
TEXTO4X8(' NOMBRE DEL ARCHIVO A GRABAR:',122,42,GREEN,4);
MOVETO(142,52);
{ Se lee el nombre del archivo }
LEE_CADENA(NOMBRE,25,['A'..'Z','.','\',':','0'..'9']);
IF NOMBRE<>'' THEN
BEGIN
ASSIGN(ARCHVGA,NOMBRE);{ Se asigna el archivo }
REWRITE(ARCHVGA); { Se borra lo que tenga }
WRITE(ARCHVGA,DIBUJO) { Y finalmente se guarda el dibujo }
END
END;
'L':BEGIN { Si la tecla fué F7 se abrir un archivo de disco }
TEXTO4X8(' NOMBRE DEL ARCHIVO A LLAMAR:',122,42,GREEN,4);
MOVETO(142,52);
{ Se lee el nombre del archivo }
LEE_CADENA(NOMBRE,25,['A'..'Z','.','\',':','0'..'9']);
IF NOMBRE<>''THEN { Si el nombre del archivo es diferente de ''
este archivo es guardado }
BEGIN
ASSIGN(ARCHVGA,NOMBRE); { Se asigna el archivo }
RESET(ARCHVGA); { Se borra el contenido }
READ(ARCHVGA,DIBUJO) { Y se lee el archivo de disco }
END
END;
END;
IF IORESULT<>0 THEN WRITE(CHR(7));
{ Finalmente se restablece la imagen }
PUTIMAGE(100,30,WIN^,NORMALPUT);
{$I+}
END;
{ Este procedimiento es el encargado de todo el trabajo ya que desde aquí
son llamdos todos los demas porcedimientos para la creación del dibujo,
según desee el usuario }
PROCEDURE CREA_IMAGEN(X1,Y1:INTEGER);
VAR X,Y,I,J,K,CO2,CO21:INTEGER;
DISP,SECUNDARIO:BOOLEAN;
OP:CHAR;
ESTILO,ES2:WORD;
CI2:STRING[20];
BEGIN
K:=0;
J:=0;
X:=X1;
Y:=Y1;
I:=0;
DISP:=FALSE;
SECUNDARIO:=FALSE;
{ Escribe el texto sobre el lugar en el que se visualizan
los diferentes colores }
TEXTO4X8('COLOR',30,100,BLUE,3);
REPEAT
IF I>16 THEN
ESTILO:=$AAAA
ELSE
ESTILO:=0;
CO2:=I DIV 16;
{ Se crea la caja o ventana donde se visualizan los colores }
CAJA(30,125,70,135,ESTILO,I,CO2);
{ Se dibuja l acaja donde se especifica el número de color y
posición }
BOX(36,280,98,320,1,WHITE);STR(I,CI2);
{ Imprime en la pantalla la palabra "COLOR" que indica el
número de color que se esta usando }
TEXTO4X8('COLOR: '+CI2,10,300,RED,2);
STR(J,CI2);
{ Imprime la letra "X" para indicar la coordenada en x del
cursor del editor }
TEXTO4X8('X: '+CI2,20,280,BROWN,2);
STR(K,CI2);
{ Imprime la letra "Y" para indicar la coordenada en y del
cursor del editor }
TEXTO4X8('Y: '+CI2,20,290,BROWN,2);
STR(DIBUJO[K,J],CI2);
{ Imprime la palabra "PIXEL" que indica la posición en
"X", "Y" del cursor del editor }
TEXTO4X8('PIXEL :'+CI2,10,310,GREEN,2);
{ Si se presioneo la tecla F1 entonces se cumplira est
condición y aparecer en la pantalla la leyenda
"ACTIVO" que significa que eses color en particular
esta siendo utilizado para dibujar }
IF DISP THEN
BEGIN BOX(30,230,80,240,1,CYAN);
TEXTO4X8('ACTIVO',30,231,RED,4);
END
{ En otro caso se dibujara una caja de color blanco }
ELSE
BOX(30,230,80,240,1,WHITE);
{ Este ciclo se asegura de que cuando se salga de
él se tenga la tecla presionada y ademas sea
una tecla de instrucción para el editor, ademas
dibuja una caja que hace el efecto de cursor
pulsante }
REPEAT
REPEAT
BOX(X+1,Y+1,X+5,Y+5,1,I);
BOX(X+1,Y+1,X+5,Y+5,1,I XOR 15);
UNTIL KEYPRESSED;
OP:=INKEY(SECUNDARIO);
UNTIL (OP IN[F_ARR,F_AB,F_I,F_D,F1,F2,F3,F5,F6,F4,F7,F8,F9,
PU,PD,INS,FIN,DEL,HOME])
AND SECUNDARIO;
IF DISP THEN
DIBUJO[K,J]:=I;
IF DIBUJO[K,J]<16 THEN
ES2:=0
ELSE
ES2:=$AAAA;
CO21:=DIBUJO[K,J] DIV 16;
CAJA(X+1,Y+1,X+5,Y+5,ES2,DIBUJO[K,J],CO21);
{ Si la variable secundario es verdadera quiere
decir que se ha oprimido una tecla y verificar
que acción corresponde a dicha tecla }
IF SECUNDARIO THEN
CASE OP OF
F_ARR:K:=INN(51,K-1,0);{ Flecha hacia arriba }
F_AB:K:=INN(51,K+1,0); { Flacha hacia abajo }
F_I:J:=INN(87,J-1,0); { Flecha a la izquierda }
F_D:J:=INN(87,J+1,0); { Flecha a la derecha }
INS:BEGIN J:=INN(87,J-1,0);K:=INN(51,K-1,0) END; { Tecla "INS" }
FIN:BEGIN J:=INN(87,J+1,0);K:=INN(51,K+1,0) END; { Tecla "FIN" }
DEL:BEGIN J:=INN(87,J-1,0);K:=INN(51,K+1,0) END; { Tecla "DEL" }
HOME:BEGIN J:=INN(87,J+1,0);K:=INN(51,K-1,0) END; { Tecla "HOME"}
F1:DISP:=NOT(DISP); { Tecla "F1"}
F2:I:=INN(255,I+1,0); { Tecla "F2"}
F3:I:=INN(255,I-1,0); { Tecla "F3"}
PD:I:=INN(255,I+16,0); { Tecla "Page Down"}
PU:I:=INN(255,I-16,0); { Tecla "Page Up"}
{ Tecla "F6"}
F6:BEGIN VENTANA_DISCO('G',DIBUJO);Rejilla(100,10);DIBUJA3 END;
{ Tecla "F7"}
F7:BEGIN VENTANA_DISCO('L',DIBUJO);Rejilla(100,10);DIBUJA3 END;
F4:DIBUJA_CH; { Tecla "F4"}
F8:DIBUJA4; { Tecla "F8"}
{ Tecla "F9"}
F9:BEGIN FILLCHAR(DIBUJO,SIZEOF(DIBUJO),15);DIBUJA3 END;
END;
X:=X1+(J*6);Y:=Y1+(K*6);
UNTIL (OP=F5);
END;
(* Procedimiento para inicializar gráficos *)
PROCEDURE INICIA_GRAFICOS;
VAR MONITOR,MODO:INTEGER;
BEGIN
(* Funcion que regresa el tipo de adaptador gráfico de su PC *)
DETECTGRAPH(MONITOR,MODO);
(* Inicializar los gráficos una vez encontrado el tipo de adaptador *)
INITGRAPH(MONITOR,MODO,'c:\TP\BGI');
IF (MONITOR=VGA) THEN
SETGRAPHMODE(VGAMED);
(* Verificación de error en el modo gráfico *)
IF GRAPHRESULT<>GROK THEN
HALT
END;
(*-------------------------------------------------------------------------*)
(* Programa Principal*)
BEGIN
INICIA_GRAFICOS;J:=0;K:=0; (* Inicializar gráficos *)
DIRECTVIDEO:=FALSE;
BOX(1,1,GETMAXX,GETMAXY,1,15); (* Dibuja una caja de color blanco *)
Rejilla(100,10);I:=0;
CREA_IMAGEN(100,10);
ALGO:=READKEY;
END.