CD Actual 1/PC Actual CD 01.iso/trucos/pascal/pascal.cd

Text File | 1995-01-04 | 38.4 KB | 2,292 lines

PASCAL

GRABAR Y RECUPERAR PANTALLAS DE TEXTO

Programando en Turbo Pascal, hay ocasiones en las que se necesita
«salvar» la pantalla con la que estamos trabajando, y restaurarla
después de hacer algo (mostrar un pequeño menú de ayuda, hacer una
pregunta, etc). Esta es la utilidad de estas dos rutinas, la primera
de ellas, llamado «Savescreen», se encarga de guardar la memoria de
video directamente en un archivo. Su formato es el siguiente:

Savescreen(Nombre);

donde «Nombre» es el nombre del archivo con el que se guardará la
pantalla.

El segundo procedimiento se encarga de 'restaurar' la pantalla. Su
formato es el siguiente:

Restscreen(Nombre);

donde «Nombre» es el nombre del archivo a restaurar.

Estos procedimientos están probados, y funcionan para pantallas del tipo
80 x 25, 16 Colores, es decir para pantallas de texto. El tamaño que se
graba es de 4000 bytes, porque la pantalla es de 80 columnas x 25 filas
= 2000 bytes, pero como cada caracter lleva asociado un atributo, esto
hace un total de 2000 x 2 = 4000 bytes.


procedure savescreen(__name:string);

var

 f :file;

 p :pointer;

begin

 assign(f,__name);

 rewrite(f);

 { abre el fichero. si existe, lo destruye. }

 close(f);

 { cierra el fichero. }

 reset(f,1);

 { abre el fichero otra vez. }

 p:=ptr($b800,$0000);

 { el puntero p^ apunta a la dirección $b800:0000 }

 blockwrite(f,p^,4000);

 { guarda la pantalla }

 close(f);

end;


procedure restscreen(__name:string);

var

 f :file;

 p :pointer;

begin

 {$i-}

 assign(f,__name);

 reset(f);

 { comprueba si exite el fichero especificado. }

 close(f);

 {$i+}

 if ioresult=0 then begin

 assign(f,__name);

 reset(f,1);

 p:=ptr($b800,$0000);

 { el puntero p^ apunta a la dirección $b800:0000 }

 blockread(f,p^,4000);

 { lee los datos y los pone en pantalla }

 close(f);

 end;

end;

Daniel Sánchez Teodoro

Granada



NUMEROS CON PUNTOS

Estas dos funciones escritas en Pascal permiten la escritura de un
número con los puntos de separación de millares. Este tipo de
funciones tienen gran utilidad en aplicaciones (por ejemplo de
contabilidad) en las que se deseen presentar resultados de cantidades
con cierta calidad.

La primera (UsingLong) sirve para números «LongInt» y la segunda
(Usingreal) para números reales y hace uso de la anterior.

Function UsingLong (n:LongInt):string;

Const

 Punto='.';

Var

 f,Largo : byte;

 s : String;

 Signo : String[1];

Begin

 If n<0 Then Signo := '-'

 Else

 Signo := '';

 n:=Abs(n);

 Str(n,s);

 For f := 1 to 3 do

 If Length(s) >= 4*f Then

 Insert (Punto,s,Length(s)-f*4+2);

 UsingLong:=Signo+s;

End;

Function UsingReal(r:Real; deci:byte): String;

Var

 m : Real;

 n : LongInt;

 s,t : String;

Begin

 n := Trunc(r);

 s := UsingLong(n);

 m := Frac(r);

 m := Abs(m);

 If deci >0 Then

 Begin

 Str (m:deci+2:deci,t);

 t := Copy (t,2,length(t)-1);

 s := s+t;

 End;

 UsingReal := s;

End;


José M. Serrano

Lérida



CAMBIAR LA TABLA DE CARACTERES

El procedimiento «xchr» permite transformar un carácter en cualquier
otro que nosotros diseñemos. Para ello nos crearemos una tabla de 8
columnas por 16 filas como la del ejemplo y calcularemos los valores
teniendo en cuenta que para cada una de las columnas de una fila son
128, 64, 32, 16, 8, 4, 2 y 1. Para cada fila sumamos los valores
correspondientes a las columnas que tachemos para crear el carácter.
Un ejemplo:

 ........ 00

 ........ 00

 ..****.. 60

 ..****.. 60

 ..*..... 32

 ..**.... 48

 ...**... 24

 ....**.. 12

 ........ 00

 ..****.. 60

 ..****.. 60

 ........ 00

 ...**... 24

 ...**... 24

 ........ 00

 ........ 00

Una vez que hemos calculado los bytes correspondientes a las 16 filas
(las cifras representadas a la derecha), los colocamos en un
array de la siguiente forma:

MIO :array [0..15] of BYTE= (00, 00, 60, 60, 32, 48, 24, 12, 00, 60,
60, 00, 24, 24, 0, 0 );

Con todos estos datos podemos generar el siguiente programa para
cambiar el juego de caracteres.

uses dos;

type font16 = array [ 0..15] of byte;

const

 ONDAS :font16 =

 ($94, $84, $48, $30, $00, $C1, $22, $14, $94, $84, $48, $30, $00, $C1,
 $22, $14);

 MIO :font16=

 (00, 00, 60, 60, 32, 48, 24, 12, 00, 60, 60, 00, 24, 24, 0, 0);

procedure xchr(CH:CHAR ;VAR s);

var regs:registers;

{ La variable s no tiene tipo declarado para que usemos bien matrices
 de 16 bytes o de 8 según el tipo de fuente actual }

begin

regs.dx:=ord(ch);

with regs do

begin

 ah:=$11;

 al:=$00;

 bh:=16;

 bl:=8;

 cx:=1;

 es:=seg (S);

 bp:=ofs (S);

end;

intr ($10,regs);

{ Sólo es soportada por EGA, MCGA y VGA (y no CGA o MDA) }

end;

begin

 xchr ('A',ondas);

 writeln ('AAAA');

end.


Nota del L.T.: Este programa sólo cambia el código de un carácter,
pero no es difícil (aunque sí laborioso) cambiar totalmente el juego
de caracteres. Simplemente deberemos generar un array para cada uno
de los 255 caracteres. Una buena idea es ponerlo todo de forma que
cargue la tabla de caracteres desde un bucle, para automatizar el
proceso.

Alberto Vallejo Martínez

Burgos


DIRECTORIOS «DIRECTOS»

A pesar de que el Borland Pascal incluye una orden para crear
directorios («MKDir»), esta rutina incorpora la interesante novedad de
que permite crear múltiples directorios a la vez, unos dentro de
otros, sin tener que crearlos uno por uno.

A este procedimiento se le pasa un «string» con el directorio completo
(podemos añadir al resultado de «getdir» el directorio a crear), y dos
variables booleanas que indican si el directorio es imposible de crear
por ser incorrecto sintácticamente, unidad inexistente o bien si ya
existía. Hay que advertir que dichas variables deben estar
inicializadas a «false».

PROCEDURE Creardir (dir:String; VAR error, existe:BOOLEAN);

VAR dir2:String;

 ind,io:Integer;

 faux:File;

BEGIN

 {$i-}

 ind:=Length(dir);

 dir2:=dir;

 IF (ind<>0) AND (dir[ind]<>':') THEN

 BEGIN

 WHILE (dir2[Length(dir2)] <>'\') AND (Length(dir2)<>0) DO

 Delete(dir2,Length(dir2),1);

 Delete(dir2,Length(dir2),1);

 IF Length(dir2)>0 THEN Creardir(dir2,error,existe)

 ELSE error:=true

 END

 ELSE IF ind=0 THEN error:=true

 ELSE BEGIN

 Assign(faux,dir+'\prueba.dat');

 Rewrite(faux);

 IF ioresult=0 THEN BEGIN

 Close(faux);

 Erase(faux)

 END

 ELSE error:=true

 END;

 IF not(error) THEN error:=ind=0;

 IF (ind<>0) AND (dir[ind]<>':') AND NOT (error) THEN

 BEGIN

 IF NOT error THEN mkdir(dir);

 io:=ioresult;

 IF existe THEN existe:= io=5;

 IF NOT (error) THEN error:= (io<>0) AND (io<>5)

 END;

END;

Julio Maiques Pena

Valencia



BITES SIGNIFICATIVOS

En Pascal no hay ninguna función estándar que nos traduzca los bites
significativos de un valor de tipo binario, algo de gran utilidad si
nos interesa, por ejemplo, manejar los atributos de un fichero. Con
una función en ensamblador, sin embargo, resolvemos el problema en tan
solo unas cuantas líneas. La función es como sigue:

Function BiteActivo(BiteBuscado, Lugar:Word):boolean;assembler;

asm

mov ax, BiteBuscado

and ax, Lugar

cmp ax,0 {si es 0, no se haya activo}

je @1 {false =0}

mov ax,1 {true=1}

@1:

end;

Fco. Javier Delgado Martínez

Madrid


SONIDO POR INTERRUPCIONES

Este es un truco residente que hace sonar el teclado de forma curiosa.
Con las teclas «+», «-», y con los números 1 al 9, se puede variar el
tono y duración del sonido respectivamente. Sólo suena cuando se
pulsa alguna tecla, para ello el programa mira directamente la tecla
pulsada en el buffer.

program sonido;

{$M 1024,0,0}

uses crt,dos;

 var progr:procedure;

 regs:registers;

 ofs,entrada:word;

 mul,mul2:integer;

{$F+}

 procedure rutina;interrupt;

 var b,d:integer;

begin

 entrada:=memw[$40:$1c];

 if entrada<>30 then

 begin

 entrada:=entrada-2; { letra -2 bytes es tu letra }

 end

 else entrada:=60;

 ofs:=memw[$40:entrada];

 b:=lo(ofs); { número de letra }

 if b=43 then mul:=mul+1;

 if b=45 then mul:=mul-1 ;

 if (b>=49) and (b<=57) then mul2:=b-48;

 mul:=abs(mul);

 for d:=b*100 downto 0 do sound((d*mul div 2)+b);

 nosound;

 progr;

end;

 {$F-}

begin

 mul:=1;

 mul2:=1;

writeln(' SONIDO v1.00 ');

getintvec($9,@progr);

setintvec ($9,addr(rutina));

keep(0);

end.

Jorge Juan Aresté Espi

Muro (Alicante)


RUTINAS PARA EL TECLADO

Las siguientes rutinas proporcionan un mayor control sobre el teclado.
La primera de ellas, AceleraTeclado, sirve (como su propio nombre
parece indicar) para acelerar considerablemente la respuesta del
teclado. Su utilización es bien sencilla, y puede ser de gran
utilidad para determinados juegos que requieran una rápida respuesta.
Las otras dos, MaskOutKbd y UnMaskKbd tienen como función la de
activar y desactivar el teclado.

Procedure AceleraTeclado;

assembler; asm

 mov ax,$305

 xor bx,bx

 int 16h

end;

Procedure MaskOutKbd; Assembler;

asm

 in al,21

 or al,00000010b

 out 21h,al

end;

Procedure UnMaskKbd; Assembler;

asm

 in al,21

 or al,11111101b

 out 21h,al

end;

La siguiente función lee una tecla del teclado o bien del buffer del
teclado, y devuelve una variable numérica de formato Word, de modo que
en el byte más alto obtenemos el código de rastreo y en el byte más
bajo el código ASCII. Para obtener ambos valores podemos emplear las
funciones Hi y Lo, para obtener los bytes más significativos y menos
significativos respectivamente.

El uso de ambos valores combinados es interesante pues podemos
distinguir la pulsación de las flechas del cursor, del teclado
numérico, la pulsación de «Alt» o «Ctrl» con otra tecla, etc. También
es interesante el uso del byte de rastreo, pues este dato no
diferencia, dada una tecla en particular, si se ha pulsado mayúscula o
minúscula o en combinación con «Ctrl» o «Alt». En resumen, cada tecla
tiene un código de rastreo asignado. La lista de todos los códigos
obtenidos al pulsar cada tecla es demasiado extensa para incluirla
aquí, pero todo es cuestión de ir probando. Por ejemplo, el código de
rastreo para la letra «A» es el 30 (1E en Hexadecimal), tanto
mayúscula como minúscula, aunque su código ASCII es 65 para la
mayúscula y 97 si es minúscula. Si pulsamos «Ctrl+A» obtenemos 3001,
y si pulsamos «Alt+A» obtenemos 3000.

Function LeeTecla : Word; Assembler;

Asm

 xor ax,ax

 int $16

End;

Definiendo al principio del programa las siguientes variables:

Var

 TeclaCabeza : Word Absolute 0:$41A;

 TeclaCola : Word Absolute 0:$41C;

De esta forma, TeclaCabeza contiene el código de la tecla que se
encuentra al principio del buffer del teclado, mientras que en la
variable TeclaCola se almacena el código de la tecla que se encuentra
en la cola del buffer.

También podemos utilizar el siguiente procedimiento, que se encarga de
limpiar el buffer de teclado de una forma rápida y efectiva.

Procedure LimpiaBuffer;

Begin

 TeclaCabeza:= TeclaCola;

End;

Podemos comparar TeclaCabeza con TeclaCola; en caso de obtener valores
diferentes podemos afirmar que se ha pulsado una tecla. De esta forma
obtenemos una nueva y sencilla forma para la función «KeyPressed». Lo
podemos hacer directamente comparando ambos valores mediante un If
TeclaCabeza<>TeclaCola Then.... O podemos emplear la siguiente
función en ensamblador que hace el mismo trabajo.

Function TeclaPulsada : Boolean; Assembler;

asm

 xor ax,ax

 mov es,ax

 mov ax,[es:TeclaCabeza]

 sub ax,[es:TeclaCola]

 jz @@1

 mov ax,1

@@1:

 sti

end;

Hemos de recordar que las funciones y procedimientos que hacen uso del
ensamblador incorporado en Turbo Pascal, sólo podrán ser compiladas en
versiones posteriores a la 6.0, primera versión en que se incorporó
esta capacidad.

Santos Herranz Domingo

Madrid



ESPACIO EN EL DISCO

Cada vez que efectuamos un «dir» de un directorio del disco se nos
muestra la información de los bytes ocupados y los que quedan libres.
Aunque esta información es más que suficiente, gracias a este programa
podremos conseguir un resultado más vistoso de esta información. La
función de este programa es la de crear una barra de porcentaje con la
cantidad del disco duro que tenemos ocupado.

Además, no sólo nos muestra el tanto por ciento de disco ocupado, sino
que para mayor información el programa nos indica los bytes totales,
los ocupados y los que nos quedan libres.

Program BarDisk;

Uses Crt, Dos;

Var total, Libre, Tanto: LongInt;

 Numero: String;

 i: Byte;

Function PuntoMil (n: LongInt): String;

Var f: Byte;

 s: String;

Begin

 Str(n,s);

 For f:=1 to 3 do

 If length (s) >= 4*f then

 Insert('.',s, Length(s) - f*4+2);

 PuntoMil:=s;

End;

Begin

 Total:=DiskSize(0) div 1024;

 Libre:=DiskFree(0) div 1024;

 Tanto:=((Total-Libre) *100) div Total;

 TextColor(3);

 GotoXY(24,WhereY);

 WriteLn(Tanto,'% de espacio en disco ocupado');

 {Dibuja barra y coloca porcentajes}

 For i:=3 To 78 do

 Begin

 GotoXY (i,WhereY);

 Write (#176);

 End;

 textColor(14);

 Tanto:= ((Total-Libre)*78) div Total;

 For i:=3 to Tanto do

 Begin

 GotoXY(i,WhereY);

 Write(#219);

 End;

 TextColor(3);

 WriteLn;

 GotoXY(3,WhereY); Write(#179,'0%');

 GotoXY(38,WhereY); Write(#179,'50%');

 GotoXY(74,WhereY); WritelN('100%',#179);

 WriteLn;

 { Coloca datos del disco }

 Numero := PuntoMil (DiskSize(0));

 WriteLn(#175#32, Numero, ' bytes totales ');

 Numero := PuntoMil (DiskSize(0)-DiskFree(0));

 WriteLn(#175#32, Numero, ' bytes ocupados');

 Numero := PuntoMil (DiskFree(0));

 WriteLn(#175#32, Numero, ' bytes libres');

 TextColor(7);

 WriteLn;

End.

Juan Antonio Fernández Moreno

Huelva


ZOOM GRAFICO

Este programa incluye la rutina «deforma», que permitirá efectuar
ampliaciones y reducciones, y en general cualquier tipo de deformación
de una zona de la pantalla.

Para su uso sólo hemos de llamar a «deforma» con las coordenadas x, y
de la esquina superior izquierda de la imagen a deformar; tras éstas,
las coordenadas x, y de la esquina inferior izquierda de la imagen a
deformar. Después de teclear las cuatro coordenadas introducimos las
mismas, pero esta vez dando las coordenadas donde queremos situar la
imagen. Hay que notar que no tienen por qué tener el mismo tamaño, ya
que el procedimiento se encarga de deformar la imagen para adecuarla a
las coordenadas de destino.

En el programa de ejemplo podemos ver un ejemplo del uso de la rutina
para efectuar un zoom hacia afuera.

program Uso_de_Deforma;

uses Crt;

type

 pantalla = array [0..199,0..319] of byte;

var

 pantallaPTR : ^pantalla;

 z : integer;

procedure deforma(x1,y1,x2,y2,x3,y3,x4,y4 : integer);

var

 x,y,dx1,dy1,dx3,dy3 : integer;

begin

 dx1:=x2-x1;

 dy1:=y2-y1;

 dx3:=x4-x3;

 dy3:=y4-y3;

 for y:=0 to dy3 do

 for x:=0 to dx3 do

pantallaPTR^[y+y3,x+x3]:=pantallaPTR^[((y*dy1)div dy3)+y1,((x*dx1)div
dx3)+x1];

 end;

begin

 asm

 mov ax,13h

 int 10h

 end;

 pantallaPTR := ptr($a000,0); (*este puntero apunta a la pantalla*)

 for z:=0 to 100 do

 pantallaPTR^[random(29),random(29)]:=random(255);

 for z:=10 to 150 do

 begin

 deforma(0,0,29,29,100,40,100+z,40+z);

 delay(50);

 end;

end.

Antonio Ruiz

Málaga



INFORMACION SOBRE EL RATON

El siguiente programa, realizado en Turbo Pascal, efectúa un completo
test del ratón mostrando la siguiente información: número de botones,
IRQ utilizada, tamaño del buffer de estado, versión del driver, idioma
utilizado y tipo de ratón (serie, bus, etc.). Además, activa el
cursor para que lo podamos ver en pantalla.

Todas las llamadas a las distintas funciones del ratón se realizan a
través de la interrupción 33h. Como se puede comprobar, esta
interrupción está muy utilizada en este programa.

Program MTest (Mouse_Test);

Uses Crt, Dos;

Const aTipo: Array [1..5] Of string [8]=('Bus', 'Sere', 'InPort',
'PS/2', 'HP');

 aIdio: Array [0..8] Of string = ('Inglés', 'Francés', 'Holandés',
 'Alemán','Sueco','Finlandés', 'Español','Portugués','Italiano');

Var regs:Registers;

 Botones: Byte;

Begin

 Regs.AX:=0;

 INTr($33,regs);

 WriteLn;

 If regs.AX=0 Then

 Begin

 WriteLn('No se encontró el driver del ratón.');

 Halt;

 End

 Else

 Begin

 Botones:=regs.BX;

 {Dibuja Mouse}

 TextColor(15);

 WriteLn(#186:6);

 WriteLn(#219#177#219#177#219:8);

 WriteLn(#219#219#219#219#219:8);

 WriteLn('Driver del ratón en memoria.');

 WriteLn;

 {Coloca datos y activa ratón}

 regs.AX:=$24;

 INTr($33, regs);

 WriteLn('Versión del driver: ', regs.BH, '.', regs.BL);

 WriteLn('Tipo del ratón....: ', (aTipo[regs.CH] ));

 WriteLn('Número de botones.: ', botones);

 WriteLn('Instalado en IRQ..: ', regs.CL);

 regs.AX:=$23;

 INTr($33,regs);

 WriteLn('Idioma............: ', (aIdio[regs.BX]));

 regs.AX:=$15;

 INTr($33,regs);

 WriteLn('Buffer de estado..: ', regs.BX, ' bytes');

 Regs.AX:=1;

 INTr($33,regs);

 Repeat Until KeyPressed;

 regs.AX:=2;

 INTr($33,regs);

 TextColor(7);

 WriteLn;

 End;

End.

Juan Antonio Fernández Moreno

Huelva


VISUALIZADOR DE FICHEROS BMP

Este es un interesante programa que nos permite visualizar ficheros
BMP de 256 colores con codificación RGB. Aunque admite ficheros de
cualquier resolución, en las imágenes mayores de 320 x 200 sólo se
visualizarán las primeras 320 columnas y las primeras 200 filas; el
resto no se visualizará.

Para su ejecución deberemos introducir «VER_BMP nombre_fichero
[.BMP]». Esta rutina no comprueba la existencia de tarjeta gráfica
VGA, ni tampoco la existencia del fichero BMP introducido como
parámetro; de manera que si se introduce un nombre no válido o no se
dispone de VGA se provocará un error de ejecución.

Recordemos que sólo visualiza ficheros BMP con codificación RGB y con
256 colores, de manera que si una imagen no puede visualizarse será
por cualquiera de estos tres motivos: bmpfile.bfType distinto de
CABEZA_BMP (no es un fichero BMP); bmpinfo.biBitCount distinto de 8
(no es un fichero de 256 colores), o bmpinfo.biCompression distinto de
0 (no tiene codificacion RGB).

Notas acerca de la rutina y los ficheros BMP

Dadas las diferentes características de VGA y BMP es necesario
reconvertir la paleta almacenada en un fichero BMP a un formato válido
para la VGA, ya que los valores que almacena el fichero BMP para cada
componente de color estan entre 0 y 255, mientras que la VGA sólo
maneja valores entre 0 y 63 para cada componente de color.

Por otra parte, la estructura de la paleta de un BMP asigna 4 bytes
para cada color, almacenando los colores en el siguiente orden: azul,
verde y rojo; mientras que la paleta que debe ser pasada a los
registros DAC de la VGA sólo tiene 3 bytes para cada color de la
paleta y los colores deben ir en el orden inverso, es decir, rojo,
verde y azul.

Por último, la longitud de una línea de imagen almacenada en un
fichero BMP siempre es múltiplo de 4, por lo que una imagen con un
ancho que no sea múltiplo de dicha cantidad tendrá bytes basura, que
no deben ser visualizados (de hecho, tendrá tantos bytes basura como
los necesarios para igualar la longitud al múltiplo de 4 superior más
próximo).

Dado que la inicialización del modo de vídeo se hace en ensamblador no
es necesario disponer del driver BGI correspondiente. Aunque, eso sí,
para poder compilarlo necesitaremos al menos la versión 6.0 de Turbo
Pascal.

Por otra parte, hay que señalar que las líneas:

cont := port[$3da]; port[$3c0] := $20;

cont := port[$3da]; port[$3c0] := $20;

posibilitan que sólo se muestre la imagen una vez que ésta esté entera
en la pantalla. De ahí que si queremos que la imagen vaya siendo
dibujada línea a línea, baste con eliminarlas.

Una última aclaración: las líneas de imagen de un fichero BMP se almacenan
en orden inverso a como aparecerán en la pantalla, esto es, la primera
línea de imagen en el fichero se corresponde con la última que aparece en
pantalla. Es por esto que el bucle en el que se transfiere la imagen del
archivo a la pantalla vaya de valores mayores a menores.

Program Ver_BMP;

Uses

 crt, dos;

Const

 CABEZA_BMP = $4D42;

Type

 BitmapFileHeader = Record

 bfType :word;

 bfSize :longint;

 bfReserved1,

 bfReserved2 :word;

 bfOffbits :longint;

 end;

 BitmapInfoHeader = record

 biSize, biWidth,

 biHeight :longint;

 biPlanes,

 biBitCount :word;

 biCompression,

 biSizeImage,

 biXpelsperMeter,

 biYpelsPerMeter,

 biClrUsed,

 biClrImportant :longint;

 end;

 RGBQuad = record

 rgbBlue, rgbGreen, rgbRed, rgbReserved :byte;

 end;

 rgbDAC = record

 rgbRed, rgbGreen, rgbBlue :byte;

 end;

 RGBQpaleta = array[0..255] of RGBquad;

 RGBpaleta = array[0..255] of rgbDAC;

 linea320 = array[0..319] of byte;

Var

 fichero :file;

 name :string;

 bmpFile :bitmapFileHeader;

 bmpInfo :bitmapInfoHeader;

 bmpPalet :RGBQpaleta;

 Paleta :rgbPaleta;

 linea :^linea320;

 suma :byte;

 scanline, mover, cont :word;

 regs :registers;

 buffergraf :array [0..64000] of byte absolute $a000:$00;

Begin

 name := paramstr(1);

 if pos('.',name) < 1 then

 name := name + '.bmp';

 assign(fichero, name);

 reset(fichero, 1);

 blockread(fichero, bmpfile, sizeof(bmpfile));

 blockread(fichero, bmpinfo, sizeof(bmpinfo));

 if (bmpfile.bfType <> CABEZA_BMP) or (bmpinfo.biBitCount <> 8) or

 (bmpinfo.biCompression <> 0) then

 writeln ('No se puede Visualizar el fichero')

 else begin

 blockread (fichero, bmpPalet[0], sizeof(bmpPalet));

 for cont := 0 to 255 do begin

 paleta[cont].rgbRed := bmpPalet[cont].rgbRed div 4;

 paleta[cont].rgbGreen := bmpPalet[cont].rgbGreen div 4;

 paleta[cont].rgbBlue := bmpPalet[cont].rgbBlue div 4;

 end;

 cont := bmpinfo.biWidth mod 4;

 case cont of

 1: suma := 3;

 2: suma := 2;

 3: suma := 1;

 else

 suma := 0;

 end;

 scanline := bmpinfo.biWidth + suma;

 if bmpinfo.biWidth > 320 then

 mover := 320

 else

 mover := bmpinfo.biWidth;

 asm

 mov ax, 0013h

 int 10h

 end;

 regs.ax := $1012;

 regs.bx := $00;

 regs.cx := $100;

 regs.es := seg(paleta[0]);

 regs.dx := ofs(paleta[0]);

 intr($10, regs);

 getmem(linea, scanline);

 cont := port[$3da];

 port[$3c0] := $00;

 if bmpinfo.biheight > 200 then begin

 seek(fichero, filepos(fichero)+ scanline * (bmpinfo.biheight-200));

 bmpinfo.biheight := 200

 end;

 for cont := (bmpinfo.biheight - 1) downto 0 do begin

 blockread(fichero, linea^[0], scanline);

 move (linea^[0], bufferGraf[cont*320], mover);

 end;

 cont := port[$3da];

 port[$3c0] := $20;

 close(fichero);

 freemem(linea, scanline);

 repeat until keypressed;

 asm

 mov ax, 0003h

 int 10h

 end;

 end;

end.

Carlos Soto García

Las Rozas (Madrid)


RUTINAS GRAFICAS

La introducción a la programación del modo de vídeo 13h de la VGA ha
tenido gran aceptación entre todos nuestros lectores. Buena prueba de
ello es que estamos recibiendo gran cantidad de rutinas para este modo
de vídeo. Un buen ejemplo es la siguiente unidad para Turbo Pascal
6.0 ó posterior, que contiene diversas rutinas (la mayoría en
ensamblador) de gran interés para el mencionado modo de 320x200x256.

La unidad contiene los siguientes procedimientos:

LeePcx: Este procedimiento descomprime un fichero en formato
gráfico PCX de 320x200x256 (con la condición de que el tamaño del
fichero no exceda de 64 Kbytes) y almacena el resultado en una zona de
memoria. También devuelve la paleta del fichero.

MueveGraf: Se encarga de escribir en pantalla un gráfico
descomprimido con el procedimiento anterior. También sirve para mover
gráficos que sean una imagen exacta de la memoria de pantalla. Es
equivalente a la instrucción «move» de Turbo Pascal.

LeeSprite: Captura una región de la pantalla y la almacena en
una región de memoria especificada. El formato del gráfico es el
siguiente: en la posición 0 con un tamaño de una palabra se guarda el
ancho del dibujo; en la posición 2 con un tamaño de una palabra se
guarda el alto del dibujo, y a partir de la posición 4 con un tamaño
de (ancho x alto) bytes se guarda el dibujo grabado por filas.

PonSprite: Devuelve a la pantalla una región capturada con el
procedimiento «LeeSprite». Además, permite realizar operaciones
lógicas entre el dibujo y lo que hay en pantalla. Para seleccionar
qué operación lógica vamos a usar existen las constantes
mskNormal, mskXor, mskOr, mskAnd y
mskNot. Estas constantes vienen dadas en la siguiente tabla
donde se indican también sus valores numéricos, y las operaciones
lógicas que se realizan entre los puntos de la pantalla y del
Sprite.

MskNormal 0 MOV

MskXOR 1 XOR

MskOR 2 OR

MskAND 3 AND

MskNOT 4 NOT

Unit Graficos;

Interface

Const

 {-- Constantes del fundido --}

 funRojo = 0;

 funAzul = 1;

 funVerde = 2;

 {-- Operaciones lógicas del procedimiento PonSprite --}

 mskNormal = 0;

 mskXOR = 1;

 mskOR = 2;

 mskAND = 3;

 mskNOT = 4;

Type

 TPaleta = Array[0..767] of Byte;

 Procedure LeePcx(var Graf;Total:Word;var Pal:TPaleta;var Imagen);

 Procedure MueveGraf(var Graf);

 Procedure PonSprite(X,Y:Word;Mask:Byte;var Graf);

 Procedure LeeSprite(x1,y1,x2,y2:Word;var Graf);

 Procedure PonPunto(X,Y:Word;Color:Byte);

 Procedure Escribe(X,Y:Word;Texto:String;Color:Byte);

Implementation

Var

 Seg1F,

 Ofs1F : Word;

Procedure LeePcx; Assembler;

{ Descomprime un fichero PCX en formato 320x200x256. Se asume que la

 información que se pasa como gráfico es correcta. El fichero ha de tener

 menos de 64k. El dibujo resultante se almacena en la variable IMAGEN y la

 paleta correspondiente en PAL. }

Var

 Cont : Word;

Asm

 Push Ds

 { CONT indica dónde empieza la paleta }

 Mov Ax,Total

 Mov Cont,Ax

 Sub Cont,768

 { Cada valor de la paleta ha de ser dividido por 4 }

 Lds Si,Graf { Se cargan dos punteros a la variable GRAF }

 Les Di,Pal

 Add Si,Cont { Se colocan donde empieza la paleta }

 Cld

 Mov Cx,768 { Hay 256*3 elementos }

 Mov Bl,4

 Xor Dx,Dx { Para dividir no se usa DX ni AH }

 Xor Ah,Ah

@Divide:

 Lodsb

 Xor Ah,Ah

 Div Bl { Divide cada byte por 4 }

 Stosb

 Loop @Divide

 { Con Es:Di se direccionará la memoria de vídeo }

 Les Di,Imagen

 { Se salta la cabecera. Usa Ds:Di para leer de la variable }

 Lds Si,Graf

 Add Si,128

 Mov Dx,Cont

 { El byte alto del contador no se va a usar }

 Xor Ch,Ch

@Bucle:

 Lodsb { Carga el byte actual }

 Cmp Al,192 { Si es menor de 192 sólo se dibuja una vez }

 Jb @NoRepite

 Sub Al,192 { Calcula cuantas veces se ha de dibujar }

 Mov Cl,Al

 Lodsb { Lee el color que se habrá de escribir }

 Jmp @Escribe

@NoRepite:

 Mov Cx,1 { Sólo hay que imprimir un pixel }

@Escribe:

 Stosb { Escribe el color }

 Loop @Escribe { tantas veces como haga falta }

 Cmp Si,Dx { Comprueba si hemos llegado al final }

 Jnz @Bucle

 Pop Ds { Se tiene que restaurar DS }

End; { PROCEDURE LeePcx }

Procedure MueveGraf;Assembler;

Asm

 Push Ds

 Lds Si,Graf

 Mov Ax,0A000h

 Mov Es,Ax

 Xor Di,Di

 Mov Cx,32000

 Rep Movsw

 Pop Ds

End; { PROCEDURE MueveGraf }

Procedure PonSprite;Assembler;

{ Escribe en pantalla un sprite de los creados por el procedimient LeeSprite,

 haciendo una operación lógica al escribirlo. }

Var

 Ancho,Alto : Word;

Asm

 Push Ds

 Dec X

 Dec Y

 Les Di,Graf { Lee el alto y ancho del gráfico }

 Mov Ax,word ptr [Es:Di]

 Mov Ancho,Ax { que se encuentran en las dos primeras palabras }

 Mov Ax,Es:[Di+2]

 Mov Alto,Ax

 Lds Si,Graf { Carga la dirección del gráfico }

 Add Si,4 { El gráfico en sí comienza en [Graf+4] }

 Mov Ax,320

 Xor Dx,Dx

 Mul Y

 Add Ax,X

 Mov Di,Ax { Calcula la posición de inicio }

 Mov Ax,0A000h

 Mov Es,Ax

 Mov Cx,Alto { El bucle se ejecutará tantas veces como alto sea }

 Mov Dl,Mask

@Repite:

 Push Cx

 Mov Cx,Ancho

@Escribe:

 Lodsb

@Normal:

 Cmp Dl,0

 Jne @XOR

 Jmp @FinCase

@XOR:

 Cmp Dl,1

 Jne @OR

 Xor Al,byte ptr [Es:Di]

 Jmp @FinCase

@OR:

 Cmp Dl,2

 Jne @AND

 Or Al,byte ptr [Es:Di]

 Jmp @FinCase

@AND:

 Cmp Dl,3

 Jne @NOT

 And Al,byte ptr [Es:Di]

 Jmp @FinCase

@NOT:

 Not Al

 Jmp @FinCase

@FinCase:

 Stosb

 Loop @Escribe

 Pop Cx

 Mov Bx,320 { Salta a la siguiente línea }

 Sub Bx,Ancho

 Add Di,Bx

 Loop @Repite

 Pop Ds

End; { PROCEDURE PonSprite }


Procedure LeeSprite;Assembler;

{ Lee una región de la pantalla y la almacena en un buffer }

Var

 Ancho,Alto : Word;

Asm

 Push Ds

 Les Di,Graf

 Xor Ah,Ah

 Mov Ax,x2

 Sub Ax,x1

 Inc Ax

 Mov word ptr [Es:Di],Ax

 Mov Ancho,Ax

 Mov Ax,y2

 Sub Ax,y1

 Inc Ax

 Mov word ptr [Es:Di+2],Ax

 Mov Alto,Ax

 Add Di,4

 Dec Y1

 Dec X1

 Mov Ax,320

 Xor Dx,Dx

 Mul Y1

 Add Ax,X1

 Mov Si,Ax { Calcula la posición de origen }

 Mov Ax,0A000h

 Mov Ds,Ax

 Mov Cx,Alto

@Repite:

 Push Cx

 Mov Cx,Ancho { Almacena cada línea }

 Rep Movsb

 Pop Cx

 Mov Bx,320 { Salta a la siguiente línea }

 Sub Bx,Ancho

 Add Si,Bx

 Loop @Repite

 Pop Ds

End; { PROCEDURE LeeSprite }

Procedure PonPunto;Assembler;

{ Escribe un punto de un color determinado }

Asm

 Dec X

 Dec Y

 Xor Dx,Dx

 Mov Ax,320

 Mul Y

 Add Ax,X

 Mov Di,Ax

 Mov Ax,0A000h

 Mov Es,Ax

 Mov Al,Color

 Mov Es:[Di],Al

End; { PROCEDURE PonPunto }

Procedure Escribe;

{ Usando la tabla que hay en la posición $F000:$FA6E y que contiene

 los caracteres CGA se escribe un texto. }

Var

 Linea : Byte;

 Byt,

 Bit,Codigo: Byte;

 Caracter : String[1];

 Car,Xx,Yy : Integer;

 Segm,Ofss : Word;

Begin

 Xx:=x;

 Yy:=y;

 For Car := 0 to Length(Texto)-1 do

 Begin

 Caracter:=Copy(Texto,Car+1,1);

 Codigo:=Ord(Caracter[1]);

 { Si el carácter es mayor de 127 no aparece en la tabla estándar. Aparece

 en una tabla en cuya dirección se encuentra el vector de interrupción

 1Fh. }

 If Codigo<128 then

 Begin

 Segm:=$F000;

 Ofss:=$FA6E+Codigo*8;

 End

 Else

 Begin

 Segm:=Seg1F;

 Ofss:=Ofs1F+Codigo*8;

 End;

 { Escribe el carácter. Escribe las 8 líneas de barrido. }

 For Byt:=0 to 7 do

 Begin

 Linea:=Byte(Ptr(Segm,Ofss+Byt)^);

 Xx:=x+Car*8;

 Yy:=Y+Byt;

 { Cada línea de barrido se compone de 8 pixels }

 For Bit:=0 to 7 do

 Begin

 { No hay que escribir }

 If Linea < $7F then

 Xx:=Xx+1

 Else

 Begin

 { Escribe el punto }

 PonPunto(Xx,Yy,Color);

 Xx:=Xx+1;

 Linea:=Linea-$80;

 End;

 Linea:=Linea Shl 1;

 End;

 End;

 Yy:=Yy-7;

 End;

End; { PROCEDURE Escribe }


Begin

 Asm

 Mov Ah,35h

 Mov Al,1Fh

 Int 21h { Calcula la dirección de la tabla de caracteres ASCII }

 Mov Seg1F,Es

 Mov Ofs1F,Bx

 End;

End.

Miguel Hernández Martos

Las Gabias (Granada)


GRAFICOS FRACTALES

La función de este truco es generar gráficos fractales, más en
concreto de los conjuntos de Julia. Si deseáis tener más información
sobre este tipo de conjuntos os recomendamos leer el mencionado «PC
Práctico».

El programa es realmente sencillo, por lo que resulta fácil modificar
algunos parámetros para conseguir otros efectos y así comprender un
poco más este tipo de gráficos. Es fácil modificar los colores, el
tamaño del gráfico en pantalla y la región a visualizar.

Program Fractal;

Uses Graph, Crt;

Const

 PixelH=150;

 PixelV=100;

 { Tamaño en pixels del gráfico en pantalla }

 xsup=-1.8;

 ysup=1.8;

 xinf=-1.8;

 yinf=1.8;

 {región del fractal a mostrar }

Var

 a,b,DeltaX,DeltaY,NewY2,x,y,x1,x2,y1,y2,SumaCuadrados:Real;

 cont:Byte;

 i,j,gd,gm,color:Integer;

Begin

 ClrScr;

 WriteLn ('Es necesario introducir el valor de un número imaginario con
 notación x+yi');

 Write('Introduzca el valor de x=> ');

 ReadLn(a);

 Write('Introduzca el valor de y=> ');

 ReadLn(b);

 gm:=Detect;

 gd:=0;

 InitGraph(gd,gm,'');

 x1:=xsup;

 y1:=ysup;

 x2:=xinf;

 y2:=yinf;

 DeltaX:=(y1-x1)/PixelH;

 DeltaY:=(y2-x2)/PixelV;

 For i:= 1 To PixelH do

 Begin

 x1:=x1+DeltaX;

 NewY2:=y2;

 For j:=1 To PixelV do

 Begin

 NewY2:=NewY2-DeltaY;

 y:=NewY2;

 x:=x1;

 cont:=0;

 SumaCuadrados:=sqr(x)+sqr(y);

 While (Cont<50) And (SumaCuadrados<100) Do

 Begin

 x:=Sqr(x)-Sqr(y)+a;

 y:=2*x*b+b;

 SumaCuadrados:=sqr(x)+sqr(y);

 inc(cont);

 End;

{ En este bloque se asignan los colores a los puntos dependiendo de la
velocidad de escape del punto; se pueden modificar para jugar con el
gráfico }

 If SumaCuadrados>100 Then

 Begin

 If cont<3 Then color:=11

 Else If Cont<4 Then Color:=9

 Else If Cont<6 Then Color:=1

 Else If Cont<8 Then Color:=13

 Else If Cont<12 Then Color:=5

 Else If Cont<15 Then Color:=4

 Else If Cont<20 Then Color:=12

 Else If Cont<27 Then Color:=2

 Else If Cont<35 Then Color:=14

 Else If Cont<45 Then Color:=7

 Else Color:=8;

 PutPixel(i,j,color);

 End;

 End;

 End;

 ReadLn;

 CloseGraph;

End.

Para el correcto funcionamiento del programa deberemos poner el
driver BGI en el directorio en que se encuentre almacenado o
bien cambiar la línea:

InitGraph(gd,gm,'');

De forma que entre las comillas ponga el directorio donde se
encuentra el driver BGI que necesitamos usar.

Juan Carlos Romero

Trujillo (Cáceres)


SCROLL DE PELICULA

Seguro que más de una vez habéis deseado añadir en vuestros programas
alguna pantalla de presentación como las que aparecen en las películas
de cine. Pues bien, ahora es posible gracias al siguiente programa,
con el que podemos conseguir un impresionante efecto de scroll en modo
texto con una gran suavidad.

Se pueden añadir tantas líneas de texto como se deseen, incluso hasta
llenar toda la pantalla: basta con poner tantos «gotoxy (x,y); write
('Texto');» como sean necesarios. Los «delay» sirven para ajustar la
velocidad: si va demasiado lento basta con disminuir su valor,
mientras que si funciona muy rápido habrá que incrementarlo.

USES crt;

VAR

 b:word;

BEGIN

 ClrScr;

 Gotoxy(34,13);write('*** PC Actual ***');

 Gotoxy(33,14);write('Scroll de película');

 Gotoxy(1,24);

 REPEAT

 WHILE (Port[$3DA] AND 8)=0 DO ;

 Portw[$3D4] := $008;

 Writeln;

 Delay(15);

 FOR b:=0 TO $E DO

 BEGIN

 WHILE (Port[$3DA] AND 8)=0 DO ;

 Portw[$3D4]:=$108+B*256;

 Delay(15);

 END;

 UNTIL KeyPressed;

 Portw[$3D4]:=$08;

END.

Santos Herranz Domingo

Madrid



VUELO ESPACIAL

Seguro que uno de los salvapantallas más utilizados por los usuarios
habituales de Windows es el «Starfield simulation», ya que combina muy
acertadamente los ingredientes de sencillez y dinamismo. Pues bien,
con esta rutina también los usuarios del DOS podrán disfrutar de ese
conocido vuelo espacial.

Las aplicaciones de esta utilidad pueden ser diversas. Por ejemplo,
quienes comienzan a programar juegos de arcade la pueden encontrar
útil como escenario en el que desarrollar la acción. O quienes no
dispongan de un salvapantallas para DOS la pueden emplear como tal,
bien activándola cuando se ausenten, bien modificándola de modo que
quede residente (a tal fin, os recordamos que en nuestro número de
enero del 93 premiamos un truco titulado «Rutinas residentes», en el
que se indicaban los pasos a seguir).

La «velocidad» de nuestro viaje dependerá de la potencia del ordenador
sobre el que lo ejecutemos, por lo que a los pasajeros que sufran del
denominado «vértigo espacial» les puede interesar incluir un Delay (n)
en cualquier punto del código, donde «n» es un número entero que
indica un retardo en milisegundos.

USES Graph, Crt;

TYPE

 Pointrec = RECORD

 sX, sY, ox, oy: LongInt;

 oapo, apo, c : Byte;

 END;

VAR

 Parr : Array[1..255] Of Pointrec;

 GD,GM,mx,my,I,cc,j,smx,smy : Integer;

 kl : LongInt;

 ch : Char;

 rx,ry,tx,ty : LongInt;

 starnum,decv : Byte;

BEGIN

 IF paramcount=0 THEN starnum:=120 ELSE val(paramstr(1),starnum,i);

 IF starnum<30 THEN starnum:=120;

 DetectGraph(GD,GM);

{la siguiente línea indica el path donde se sitúan los controladores
gráficos *.bgi dentro de nuestro disco duro}

 InitGraph(GD,GM,'d:\bp\bgi');

 mx:=getmaxx; my:=getmaxy; smx:=mx div 2; smy:=my div 2;

 decv:=starnum div 30;

 Randomize;

 FillChar(Parr,SizeOF(Parr),0);

 FOR i:=1 TO starnum DO WITH Parr[i] DO

 BEGIN

 sx:=(random(Succ(mx))-smx)*80; sy:=(random(Succ(my))-smy)*60;

 apo:=random(200)+decv;

 c:=Random(7)+1;

 ox:=sx; oy:=sy; oapo:=apo;

 END;

 REPEAT

 FOR i:=1 TO starnum DO WITH Parr[i] DO

 BEGIN

 oapo:=apo; ox:=sx; oy:=sy;

 dec(apo,decv);

 RX:=(sx div SUCC(apo))+smx;

 RY:=(sy div SUCC(apo))+smy;

 TX:=(ox div SUCC(oapo))+smx;

 TY:=(oy div SUCC(oapo))+smy;

 IF (RX>640) OR (RY>480) OR (RX<0) OR (RY<0) OR (APO<decv) THEN

 BEGIN

 sx:=(random(Succ(mx))-smx)*80; sy:=(random(Succ(my))-smy)*60;

 apo:=200+decv;

 RX:=(sx div SUCC(apo))+smx; RY:=(sy div SUCC(apo))+smy;

 END;

 IF apo>120 THEN cc:=C ELSE cc:=C+8;

 PutPixel(TX,TY,0); PutPixel(RX,RY,cc);

 IF OAPO<70 THEN PutPixel(TX+1,TY+1,0);

 IF APO<70 THEN PutPixel(RX+1,RY+1,cc);

 IF OAPO<60 THEN PutPixel(TX+1,TY,0);

 IF APO<60 THEN PutPixel(RX+1,RY,cc);

 IF OAPO<50 THEN PutPixel(TX,TY+1,0);

 IF APO<50 THEN PutPixel(RX,RY+1,cc);

 IF OAPO<40 THEN PutPixel(TX-1,TY-1,0);

 IF APO<40 THEN PutPixel(RX-1,RY-1,cc);

 IF OAPO<30 THEN PutPixel(TX+2,TY+2,0);

 IF APO<30 THEN PutPixel(RX+2,RY+2,cc);

 IF OAPO<20 THEN BEGIN

 PutPixel(TX+2,TY-1,0); PutPixel(TX-1,TY+2,0);

 END;

 IF APO<20 THEN BEGIN

 PutPixel(RX+2,RY-1,cc); PutPixel(RX-1,RY+2,cc);

 END;

 END;

 UNTIL KeyPressed;

 WHILE KeyPressed DO ch:= ReadKey;

 Closegraph;

END.

Antonio Delgado García

Madrid

Nota del Laboratorio: El programa funciona ejecutando «stars» o
«stars n», donde «n» es un parámetro que indica el número de estrellas
que aparecerán en pantalla. Si se introduce sin parámetro sólo
aparecerán 120 estrellas. Este programa detecta la tarjeta gráfica y
se adapta a su resolución.