{A ver si es esto esta en modo gráfico}
program topografia;
uses
crt, dos;
type
string12 = string[12];
var
x, y : integer;
screenx, screeny : word;
page, bpp : byte;
posxx, posyy, posx, posy : integer;
function realstring(n : real) : string12;
var
nus : string12;
begin
realstring := '';
str(n:8:4,nus);
realstring := copy(nus,1,length(nus));
end;
function integerstring(n : integer) : string12;
var
s : string12;
begin
str(n,s);
integerstring := copy(s,1,length(s));
end;
procedure iniciografico;
var
i : integer;
entorno : string;
begin
asm
mov ax,4f02h
mov bx,$101
int 10h
end;
bpp := 16;
screenx := 640;
screeny := 480;
end;
procedure closegraficos;
begin
asm
mov ah,00h
mov al,03h
int 10h
end;
bpp := 0;
screenx := 80;
screeny := 24;
end;
procedure putpixel(x, y : word; c : byte);
var
banco : word;
despla : longint;
begin
despla := longint(y) * 640 + x;
banco := despla shr 16;
despla := despla - (banco shl 16);
if banco <> page then
begin
page := banco;
asm
mov ax,4F05h
mov dx,banco
int 10h
end;
end;
asm
mov ax,0A000h
mov es,ax
mov di,word(despla)
mov al,c
mov es:[di],al
end;
end;
Procedure Clearscreen;
var
t, l : integer;
begin
for l := 1 to 480 do
begin
for t := 1 to 640 do
putpixel(t,l,0);
end;
end;
procedure outtextxy(x, y : word; texto : string);
var
lx, ly : word;
col, bit, posf, font, posi : byte;
i, t : integer;
begin
ly := y;
for posi := 1 to Length(texto) do
begin
lx := x;
y := ly;
for posf := 0 to 7 do
begin
font := mem[$ffa6:$e + (ord(texto[posi]) shl 3) + posf];
for bit := 7 downto 0 do
begin
if (font and (1 shl bit)) <> 0 then
putpixel(x, y, 15);
x := x + 1;
end;
y := y + 1;
x := lx;
end;
x := x + 8;
end;
end;
procedure linea(x1, y1, x2, y2 : Integer; color : byte);
var
dd, dx, dy, ai, bi, xi, yi : Integer;
begin
if (x1 < x2) then
begin
xi := 1;
dx := x2 - x1;
end
else
begin
xi := - 1;
dx := x1 - x2;
end;
if (y1 < y2) then
begin
yi := 1;
dy := y2 - y1;
end
else
begin
yi := - 1;
dy := y1 - y2;
end;
putPixel(x1, y1, color);
if (dx > dy) then
begin
ai := (dy - dx) * 2;
bi := dy * 2;
dd := bi - dx;
repeat
if (dd >= 0) then
begin
y1 := y1 + yi;
dd := dd + ai;
end
else
dd := dd + bi;
x1 := x1 + xi;
putPixel(x1, y1, color);
until (x1 = x2);
end
else
begin
ai := (dx - dy) * 2;
bi := dx * 2;
dd := bi - dy;
repeat
if (dd >= 0) then
begin
x1 := x1 + xi;
dd := dd + ai;
end
else
dd := dd + bi;
y1 := y1 + yi;
putPixel(x1, y1, color);
until (y1 = y2);
end;
end;
procedure cuadricula(xl, yl, cu : integer);
var
t, yy, xx : integer;
begin
yy := round(cu * 0.15);
xx := yy * cu;
for t := 0 to cu do
begin
linea(xl,yl + (t * yy),xl + xx,yl + (t * yy),15);
linea(xl + (t * yy),yl,xl + (t * yy),yl + xx, 15);
end;
posxx := xl;
posyy := yl;
posx := trunc((xl + xx) / 2);
posy := trunc((yl + xx) / 2);
end;
procedure borrado(xb, yb : integer);
var
t, i : integer;
begin
for t := 0 to 7 do
for i := 0 to 7 do
putpixel(xb + t,yb + i,0);
end;
function entradato(xd, yd : integer) : real;
var
error, d, xi, yi : integer;
tec : char;
dato : string12;
ton : real;
begin
d := 1;
repeat
tec := readkey;
if tec in[#48..#57,#46] then
begin
dato[d] := tec;
dato[0] := chr(d);
outtextxy(xd + (d * 8),yd,dato[d]);
d := d + 1;
if d > 12 then
d := 12;
end;
if tec = #8 then
begin
d := d - 1;
if d < 1 then
d := 1;
borrado(xd + (d * 8),yd);
dato[d] := ' ';
dato[0] := chr(d);
outtextxy(xd + (d * 8),yd,' ');
end;
until tec = #13;
val(dato,ton,error);
if error <> 0 then
begin
delete(dato,error,1);
val(dato,ton,error);
end;
entradato := ton;
end;
procedure calculo_orientacion;
var
orient, ejx, ejy, ejxx, ejyy : real;
i, d : integer;
begin
outtextxy(100,269,'Entre Posicion x : ');
ejx := entradato(244,269);
outtextxy(100,279,'Entre Posicion xx : ');
ejxx := entradato(244,279);
outtextxy(100,289,'Entre Posicion y : ');
ejy := entradato(244,289);
outtextxy(100,299,'Entre Posicion yy : ');
ejyy := entradato(244,299);
orient := (ejx - ejxx) / (ejy - ejyy);
outtextxy(100,309,'La Orientacion Es = ' + realstring(orient));
for i := 0 to 5 do
for d := 0 to 5 do
putpixel(posx + trunc(ejx) + i,posy + trunc(ejy) + d,10);
linea(posx + trunc(ejx),posy + trunc(ejy),
posx + trunc(ejxx),posy + trunc(ejyy),10);
for i := 0 to 5 do
for d := 0 to 5 do
putpixel(posx + trunc(ejxx) + i,posy + trunc(ejyy) + d,10);
end;
procedure altitud_media;
var
yc : array[1..8] of real;
t, marca, i : integer;
gf, ent, altu, almed : real;
begin
marca := 6;
outtextxy(100,271,'Entre Mediciones Alturas [Y]');
i := 1;
while i < (marca + 1) do
begin
outtextxy(100,291 + (i * 8),'Entre Altura Num.[' +
integerstring(i) + '] y : ');
ent := entradato(308,291 + (i * 8));
yc[i] := ent;
ent := 1;
i := i + 1;
end;
altu := 0;
gf := 0;
for t := 1 to i - 1 do
begin
altu := altu + yc[t];
if gf < yc[t] then
gf := yc[t];
end;
almed := (altu / (i - 1));
linea(posx,(posy * 2),posx,(posy * 2) - trunc(gf),13);
linea(posx - 5,(posy * 2),posx - 5,(posy * 2) - trunc(almed),10);
outtextxy(100,291 + ((i + 1) * 8),'La Altura Media Es : ' +
realstring(almed));
end;
procedure cortes_topograficos(marca : integer);
var
ent, xc, xxc, yyc : real;
yc : array[1..8] of real;
p, desp, t, i : integer;
begin
if marca > 6 then
marca := 6;
if marca < 1 then
marca := 1;
xc := 4;
xxc := 220;
i := 1;
ent := 1;
outtextxy(100,271,'Entre Mediciones Alturas [Y]');
while i < (marca + 1) do
begin
outtextxy(100,291 + (i * 8),'Entre Altura Num.[' +
integerstring(i) + '] y : ');
ent := entradato(308,291 + (i * 8));
yc[i] := ent;
ent := 1;
i := i + 1;
end;
if trunc(xxc) > 240 then
xxc := 240;
if trunc(xc) < 1 then
xc := 1;
linea(posxx + trunc(xc), posyy + (posy + posy div 2) - 4,
posxx + trunc(xxc), posyy + (posy + posy div 2) - 4,10);
desp := trunc((xxc - xc) / i);
t := 1;
p := 1;
repeat
linea((posxx + trunc(xc)) + p, posyy + (posy + posy div 2) - 4,
(posxx + trunc(xc)) + p, (posyy + (posy + posy div 2) - 4) -
trunc(yc[t]),10);
t := t + 1;
p := p + round(marca * 7);
until t > i - 1;
p := 0;
for t := 1 to i - 2 do
begin
linea((posxx + trunc(xc)) + p,(posyy + (posy + posy div 2) - 4) -
trunc(yc[t]),(posxx + trunc(xc)) + round(marca * 7) + p,
(posyy + (posy + posy div 2) - 4) - trunc(yc[t + 1]),10);
p := p + round(marca * 7);
end;
end;
procedure menu;
var
tex : char;
sal : boolean;
begin
sal := false;
repeat
Clearscreen;
outtextxy(4,30,'**** Menu General ****');
outtextxy(4,50,'1 = Generacion De Una Reticula');
outtextxy(4,60,'2 = Calculo De La Altitud Media');
outtextxy(4,70,'3 = Obtencion De Cortes Topograficos');
outtextxy(4,80,'4 = Calculo De Orientaciones');
outtextxy(4,90,'5 = Salir');
repeat
tex := readkey;
until tex in[#49..#53];
Clearscreen;
case tex of
#49 : begin
outtextxy(100,2,'Reticu');
cuadricula(100,20,40);
readln;
end;
#50 : begin
outtextxy(100,2,'Reticu');
cuadricula(100,20,40);
altitud_media;
readln;
end;
#51 : begin
outtextxy(100,2,'Reticu');
cuadricula(100,20,40);
cortes_topograficos(6);
readln;
end;
#52 : begin
outtextxy(100,2,'Reticu');
cuadricula(100,20,40);
calculo_orientacion;
readln;
end;
#53 : sal := true;
end;
until sal = true;
end;
begin
iniciografico;
menu;
closegraficos;
end.
Crear cuenta