Pascal/Turbo Pascal - Umpoco de Pascal

{Continuando con la programación en Pascal como quedo en [Compilador de pascal 7.7] y

 como comente aparte de los punteros que encontraremos en esta serie de programación

 gráfica empezare dejando un pequeño ejemplo de lo que se vera en el resto de la serie.

 En este caso es un programa que permite visualizar archivos de imagen tipo BMP de

 2 colores a 24 bits espero les guste esto es empezar.

 Como podréis apreciar el programa es una mezcla de pascal y ensamblador.

 esto es porque actual mente no se dispone de driveres de vídeo que trabajen con 24 bits y

 32 en pascal por lo cual debemos de preparar nuestros driveres para tal fin.

  Este programa esta echo con pascal 7.0 teniendo problemas para correr con freepascal.

 En cualquiera de sus versiones.

 Por causa del ensamblador del pascal 7.0 y del de freepascal Pudiéndose  acoplar a el de

 otra forma pero eso no entra en esta programación que solo trata pascal estándar pero mejorando

 los medios lo mejor que podamos al sistema actual de gráficos.

Se pasa en varias paginas por su tamaño.

 program a8bmp;

 {$N+}{$G+}

 uses

    crt, dos;

   type

      string3 = string[3];

      string8 = string[8];

   const

     Camino : string = 'c:\tp\fotos12\'; {Camino donde estan las Imagenes}

     exten : string3 = 'bmp'; {Extension del Archivo}

  type

      BufferType = Array [0..64000] of Byte; {Buffer virtual}

      BufferPointer = ^BufferType;    {Puntero al buffer virtual}

      camposcabecera = record       {Cavecera del BMP}

           idenbmp : array[0..1] of char;

           tamanobmp : longint;

           reserva1  : word;

           reserva2  : word;

           inicioimag : longint;

        end;

   campoinformacion = record     {Cavecera de datos del BMP}

           tamanocabe : longint;

           tamanox    : longint;

           tamanoy    : longint;

           planoscolor : word;

           bitspixel   : word;

           compresion  : longint;

           tamaimagen  : longint;

           resolucionx : longint;

           resoluciony : longint;

           numerocolor : longint;

           coloresimpo : longint;

        end;

     colorreg = record       {Registro de color del BMP}

           Blue : Byte;

          Green : Byte;

            Red : Byte;

          reser : Integer;

        end;

    regcolor = record       {Registro de la Imagen}

          regazul  : byte;

          regverde : byte;

          regrojo  : byte;

          regreser : byte;

        end;

    paletabmp = array[0..255] of regcolor;  {El array del Registro imagen}

    colorrgb = record    {Registri Paleta color}

          rojo : byte;

          verde : byte;

          azul : byte;

        end;

    paletargb = array[0..255] of colorrgb;  {El array de la Paleta}

    paletavesa = array[0..255,0..2] of byte; {El array de la Palete vesa}

    pModeList = ^tModeList; {Puntero al array de listado de modos de video}

    tModeList = Array [0..255] of word; {Array de listado de modos de video}

    informevesa = record      {Registro cavecera de la vesa}

                  asignatura : array[1..4] of char;

                  nversion   : word;

                  punterofar : pchar;

                  capacidad  : longint;

                  codigos    : pmodelist;

              end;

   datosvesa = record    {Registro de informacion de la vesa}

               modo_flag   : word;

               ventana1    : byte;

               ventana2    : byte;

               granulacion : word;

               tamaventana : word;

               segventana1 : word;

               segventana2 : word;

               areavisible : pointer;

               viteslinea  : word;

               resolucionx : word;

               resoluciony : word;

               anchocaract : byte;

               altocaract  : byte;

               nbitplanes  : byte;

               bitporpixel : byte;

               membloques  : byte;

               mem_modelo  : byte;

               tamamemblok : byte;

         end;

   var           {Variables comunes del programa}

     f : file;

     Buffer : ^BufferType;

     dato1  : informevesa;

     dato2  : datosvesa;

     infocabe : camposcabecera;

     infoinfo : campoinformacion;

     bmpcol   : paletabmp;

     imagcol  : paletargb;

     colores, resul1, resul2 : word;

     comp : string[4];

     regs : registers;

     nomarch : array[1..40] of string[12];

     cargamos : string;

     dirinfo : searchrec;

     cag : integer;

     b : array[1..4] of byte;

     fondo : byte;

     temp : Byte;

     BPP : Byte;

     memor : array[0..12000] of byte;

     p, t, z, x, y : integer;

     modo : word;

     currentmode : Word;

     colorespixel, page, currentblock : Byte;

     clear, blanco, color : colorreg;

     getmaxy, screeny, screenx : Integer;

     paletav : paletavesa;

     byt : array[1..1024] of byte;

     tom, tex : string[37];

     sal : boolean;

   procedure tomachivos(ext : string3);  {Procedimiento para cojer los

                                          archivos BMP para el menu}

    var

       ii : integer;

    begin

      findfirst(camino + '*.' + ext, archive, dirinfo);

      ii := 1;

      while doserror = 0 do

      begin

         nomarch[ii] := dirinfo.name;

         ii := ii + 1;

         if ii > 40 then

         ii := 40;

         findNext(dirinfo);

      end;

        cag := ii - 1;

   end;

  procedure menuarchivos;     {Menu para seleccionar la imagen BMP}

  var

     tec : char;

     gg, n, t, yy, xx, cot : integer;

  begin

      textbackground(0);

      clrscr;

      tomachivos(exten);

      clrscr;

      gotoxy(12,1);write('*** Elija Archivo A Visualizar ***');

      cot := 1;

      yy := 3;

      xx := 3;

      repeat

      textcolor(15);

      gotoxy(xx, yy);write(nomarch[cot]);

      xx := xx + 15;

      if xx > 60 then

      begin

         xx := 3;

         yy := yy + 1;

         if yy > 22 then

         yy := 22;

      end;

      cot := cot + 1;

      until cot > cag;

      xx := 3;

      yy := 3;

      cot := 1;

    repeat

      textbackground(2);

      gotoxy(xx - 1,yy);write('              ');

      textcolor(15);

      gotoxy(xx,yy);write(nomarch[cot]);

      textbackground(0);

      tec := readkey;

      gotoxy(xx - 1,yy);write('              ');

      textcolor(15);

      gotoxy(xx,yy);write(nomarch[cot]);

  if tec = #77 then

  begin

      xx := xx + 15;

      cot := cot + 1;

      if (xx > 48) and (cot < cag) then

      begin

         xx := 3;

         yy := yy + 1;

         end;

         if cot > cag then

         begin

            xx := xx - 15;

            cot := cag;

         end;

      end;

  if tec = #75 then

  begin

      xx := xx - 15;

      cot := cot - 1;

      if xx < 3 then

      begin

         xx := 48;

         if yy > 3 then

         yy := yy - 1;

      end;

       if cot < 1 then

       begin

           cot := 1;

           xx := 3;

       end;

  end;

   if tec = #80 then

   begin

       if (cag mod 4) = 0 then

       gg := 2

     else

       gg := 3;

       if (yy < round(cag / 4) + gg) and (cot < cag) then

       begin

       yy := yy + 1;

       t := 4;

       cot := cot + t;

      end;

   end;

   if tec = #72 then

   begin

       if yy > 3 then

       begin

       yy := yy - 1;

       t := 4;

       cot := cot - t;

      end;

   end;

   until tec = #13;

   cargamos := camino + nomarch[cot];

   textbackground(0);

   textcolor(15);

   clrscr;

  end;

  procedure cargacabecerayinformeycolor(archi : string);  {Procedimiento

                                                          para cargar las

                                                          caveceras del BMP}

  begin

     assign(f,archi);

  {$I-} reset(f,1); {$I+}

  if ioresult <> 0 then

  begin

     writeln('Archivo No Encontrado o Da¤ado pulse [Enter]');

     readln;

     halt(1);

  end;

  if exten = 'BMP' then

  begin

  blockread(f,infocabe,sizeof(camposcabecera),resul1);

  blockread(f,infoinfo,sizeof(campoinformacion),resul2);

  if infoinfo.bitspixel <= 8 then  {Cargamos los colores de la paleta si

                                    devemos cargarlos}

  blockread(f, bmpcol,infocabe.inicioimag - (resul1 + resul2),colores);

  close(f);

  end;

 end;

 procedure presentadatosbmp(nom : string); {Presentamos los datos del BMP}

 begin

     cargacabecerayinformeycolor(nom);

     if exten = 'BMP' then

     begin

     clrscr;

     writeln('***** Informacion Archivo *****');

     writeln('-------------------------------');

     writeln;

     writeln('Tipo De Archivo Es            = ',infocabe.idenbmp[0],

                               infocabe.idenbmp[1],'P');

     writeln('tama¤o cabecera y informacion = ',resul1 + resul2,' Bytes');

     writeln('Inicio Imagen En La Posicion  = ',infocabe.inicioimag,' Bytes');

     colorespixel := infoinfo.bitspixel;

     if infoinfo.bitspixel <= 8 then

     begin

     writeln('Tama¤o Paleta de color        = ',infocabe.inicioimag -

                                               (resul1 + resul2),' Bytes');

     writeln('Los Colores De La Paleta Son  = ',

               (infocabe.inicioimag - (resul1 + resul2)) div 4,' colores');

     end

  else

     writeln('Los Colores De La Paleta Son  = ',infoinfo.bitspixel);

     writeln('Los Planos De Color Son       = ',infoinfo.planoscolor);

     writeln('Tama¤o Del Archivo Total      = ',infocabe.tamanobmp,' Bytes');

     writeln('Tama¤o De La Imagen           = ',infoinfo.tamaimagen,' Bytes');

     writeln('Longitud  De X                = ',infoinfo.tamanox,' Pixeles');

     writeln('Longitud  De Y                = ',infoinfo.tamanoy,' Pixeles');

     case infoinfo.compresion of

   0 : comp := 'No';

   1 : comp := 'RLE8';

   2 : comp := 'RLE4';

    end;

     writeln('Compresion                    = ',comp);

     writeln('Resoluccion X                 = ',infoinfo. resolucionx);

     writeln('Resoluccion y                 = ',infoinfo. resoluciony);

     writeln('Numero Colores De La Imagen   = ',infoinfo.numerocolor);

     writeln('Numero De Colores Importantes = ',infoinfo.coloresimpo);

     writeln;

     writeln('***** Pulse [Enter] *****');

     readln;

   end;

 end;

{Continuación}

 function text(dd : string) : string; {Preparamos el Mensaje}

   begin

     text := ' ';

     tex := 'El Archivo Cargado Es = ';

     t := length(dd);

     fillchar(tom,13,' ');

     tom[0] := chr(12);

     p := 12;

     tom[0] := chr(p);

     sal := false;

    repeat

    if dd[t] <> '\' then

    begin

      tom[p] := dd[t];

      p := p - 1;

    end

  else

     begin

        sal := true;

     end;

    t := t - 1;

    until (sal = true) or (t < 1);

    for t := 1 to 12 do

    begin

    if tom[t] = ' ' then

    delete(tom,1,1);

    end;

     tex := tex + tom;

     text := tex;

   end;

   procedure putpixel(x, y : integer; colo : word); {Escrivimos un pixel

                                                     en pantalla asta 16

                                                     colores}

   begin

       {Reducimos La imagen para que entre en pantalla si es necesario}

       if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then

       begin

          x := round(x * (500 / infoinfo.tamanox));

          y := round(y * (350 / infoinfo.tamanoy));

       end;

     asm

      mov ah,0Ch

      mov al,byte(colo)

      mov bx,0

      mov cx,x

      mov dx,y

      int 10h

    end;

   end;

 procedure  ponpixeltodos(x, y : word; col : byte);{Ponemos todos los pixeles

                                                    sea cual sea su modo de

                                                    video}

 var

    banco : word;

    despla : longint;

    blue, green, red : byte;

  procedure setbtex(x1, y1 : Integer);

   Begin

     temp := (((longint(y1) * screenx * (bpp shr 3) + x1)) shr 16);

     if currentblock <> temp then

     begin

          asm

             mov ax,$4f05

             xor bh,bh

             mov dl,temp

             int $10

          end;

          currentblock := temp;

      end;

   end;

  begin

     blue := 255;

     green := 255;

     red := 255;

     if modo = $101 then {Para modo 256 colores}

     begin

       col := 255;

       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, col

        mov es:[di], al

     end;

   end;

   if modo = $12 then  {Para modo de 2/16 colores}

   begin

     asm

      mov ah,0Ch

      mov al,byte(col)

      mov bx,0

      mov cx,x

      mov dx,y

      int 10h

    end;

   end;

   if modo = $111 then  {Para modo de 24 bit}

   begin

        setbtex(x * 2,y);

        mem[$a000 : ((x + y * screenx) * 2 + 0) - currentblock shl 16] :=

          (blue shr 3) and 31 + ((green shr 3) shl 7) and 224;

        setbtex(x * 2 + 1,y);

        mem[$a000 : ((x + y * screenx) * 2 + 1) - currentblock shl 16] :=

          (((green shr 3) shr 2) and 7) + (((red shr 3) shl 3) and 248);

      end;

   end;

   procedure outtextxy(x, y : word; texto : string); {Escrivimos texto en

                                                      Pantalla}

   var

      lx, ly : word;

      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];

       if ord(texto[posi]) = 164 then   {Representacion de la ¤}

       begin

       if posf = 0 then

       begin

       ponpixeltodos((x - 1) + 1, y - 1, 15);

       ponpixeltodos((x - 1) + 2, y - 2, 15);

       ponpixeltodos((x - 1) + 3, y - 2, 15);

       ponpixeltodos((x - 1) + 4, y - 1, 15);

       ponpixeltodos((x - 1) + 5, y - 1, 15);

       ponpixeltodos((x - 1) + 6, y - 2, 15);

       end;

       font := mem[$ffa6:$e + (110 shl 3) + posf];

       end;

       if ord(texto[posi]) = 165 then  {Representacion de la ¥}

       begin

       if posf = 0 then

       begin

       ponpixeltodos((x - 1) + 1, y - 2, 15);

       ponpixeltodos((x - 1) + 2, y - 3, 15);

       ponpixeltodos((x - 1) + 3, y - 3, 15);

       ponpixeltodos((x - 1) + 4, y - 2, 15);

       ponpixeltodos((x - 1) + 5, y - 2, 15);

       ponpixeltodos((x - 1) + 6, y - 3, 15);

       end;

       font := mem[$ffa6:$e + (78 shl 3) + posf];

       end;

         for bit := 7 downto 0 do

         begin

          if (font and (1 shl bit)) <> 0 then

          ponpixeltodos(x, y, 15);

          x := x + 1;

          end;

          y := y + 1;

          x := lx;

        end;

          x := x + 8;

       end;

     end;

 procedure bmp16colores(nom : string);  {Cargamos BMP 16 colores}

 var

   pal : paletargb;

   xx, yy, cargado, longitux, tomados, longituy, colores : word;

   memoria, infor, planos : word;

   dirpixel, colorpixel : byte;

 procedure SetAllPalrgb(var pal ; n : integer);

 var

  i : byte;

 begin

  for i := 0 to 15 do

  begin

    asm

     mov bl,i

     mov bh,i

     mov ah,$10

     mov al,$00

     int $10

  end;

 end;

 asm

  mov ah,$10

  mov al,$12

  mov bx,0

  mov cx,n

  les dx,pal

  int $10

  end;

 end;

  procedure loadbmp(x, y : integer; name : string);

  var

    j, i : integer;

  begin

   assign(f,name);

   reset(f,1);

   infor := infoinfo.tamanocabe - 4;

   cargado := infor;

   planos := ord(infor <> 8);

   longitux := infoinfo.tamanox;

   longituy := infoinfo.tamanoy;

   colores := 1 shl infoinfo.bitspixel;

   tomados := 8 * (longitux div 8) + 8 * ord(longitux mod 8 <> 0);

   tomados := tomados div 2;

     for i := 0 to colores - 1 do

      begin

         pal[i].rojo := bmpcol[i].regrojo div 4;

         pal[i].verde := bmpcol[i].regverde div 4;

         pal[i].azul := bmpcol[i].regazul div 4;

      end;

         setallpalrgb(pal,colores);

         memoria := tomados * (12000 div tomados);

         cargado := memoria;

         xx := 0;

         yy := 0;

         seek(f,infocabe.inicioimag);

         while cargado = memoria  do

          begin

           blockread(f,memor,memoria,cargado);

             for j := 1 to cargado div tomados do

              for i := 0 to longitux - 1 do

               begin

                xx := x + i;

                yy := y + longituy - j;

                dirpixel := memor[(j - 1) * tomados + 1 + i div 2];

                colorpixel := (dirpixel shr 4) * ((i + 1) mod 2) +

                 (dirpixel and 15) * ((i + 2) mod 2) ;

                putpixel(xx,yy,colorpixel);

              end;

               y := y - cargado div tomados;

           end;

    close(f);

  end;

  begin

      Loadbmp(3,1,cargamos);

  end;

 procedure  bmp1colores(nom : string);  {Cargamos BMP de 2 colores}

 var

    k, j, i : integer;

 begin

      assign(f,nom);

      reset(f,1);

      seek(f,infocabe.inicioimag);

       for j := infoinfo.tamanoy - 1 downto 0 do

       begin

         i := 0;

         repeat

          blockread(f,b,4);

          k := 1;

           repeat

            if b[k] and $80 > 0 then

            putpixel(i,j,15)

        else

            putpixel(i,j,0);

            inc(i);

            b[k] := b[k] shl 1;

            if I mod 8 = 0 then

            inc(k);

          until k > 4;

        until i > infoinfo.tamanox - 1;

     end;

     close(f);

 end;

   {Estos procedimientos para la palketa de colores son 6}

   procedure establecer_un_registro_paleta(num, color : byte);

   begin

     asm

      mov bl,num       {Numero del registro}

      mov bh,color     {Numero de color}

      mov ah,10h       {Funcion}

      mov al,00h       {Subfuncion}

      int 10h          {Interruccion}

    end;

   end;

 procedure lee_registro_paleta(num : byte; var valor : byte);

 var

    colo : byte;

 begin

   asm

     mov bl,num      {Numero del registro}

     mov ah,10h      {Funcion}

     mov al,07h      {Subfuncion}

     int 10h         {Interruccion}

     mov colo,bh;   {Numero de color}

    end;

    valor := colo;

 end;

 procedure establece_registro_individual_paleta(num : integer; rojo,

                                                 verde, azul : byte);

 begin

  asm

    mov ah,10h      {Funcion}

    mov al,10h      {Subfuncion}

    mov bx,num      {Numero del registros}

    mov dh,rojo     {Tomamos valor del rojo}

    mov ch,verde    {Tomamos valor del verde}

    mov cl,azul     {Tomamos valor del azul}

    int 10h         {Interruccion}

  end;

 end;

 procedure lee_registro_individual_paleta(num : integer; var rojo,

                                             verde, azul : byte);

 var

    r, v, a : byte;

 begin

   asm

    mov ah,10h      {Funcion}

    mov al,15h      {Subfuncion}

    mov bx,num      {Numero del registros}

    int 10h         {Interruccion}

    mov r,dh        {Tomamos los valores de rojo}

    mov v,ch        {Tomamos los valores de verde}

    mov a,cl        {Tomamos los valores de azul}

   end;

     rojo := r;

     verde := v;

     azul := a;

 end;

  Procedure establecepaletacolores(nm : byte);

  var

    k, nu : byte;

    rojo, verde, azul : byte;

  begin

   for k := 0 to nm do

   begin

   lee_registro_paleta(k,nu);

   establecer_un_registro_paleta(k,k);

   lee_registro_individual_paleta(nu, rojo, verde, azul);

   establece_registro_individual_paleta(k, rojo, verde, azul);

   end;

 end;

   procedure ponpaletargb(var pal; num : integer);

   begin

     asm

      mov ah,10h {Funcion}

      mov al,12h {Subfuncion}

      mov bx,0h  {Numero del primer registro}

      mov cx,num {Numero del registros}

      les dx,pal {Direccion de la paleta o buffer}

      int 10h    {Interruccion}

    end;

  end;

  procedure iniciograf(modo : word); {Iniciamos Graficos Vesa}

  begin

   asm

      mov ax,4f02h {Inicio grafico vesa}

      mov bx,modo  {Modo video}

      int 10h      {Interruccion video}

     end;

     bpp := 16; {}

     screenx := 640; {Tama¤o pantalla x}

     screeny := 480; {Tama¤o Pantalla y}

  end;

  procedure closegraficos;  {Terminamos graficos Vesa}

  begin

  asm

   mov ah,00h

   mov al,03h

   int 10h

   end;

   bpp := 0;

   screenx := 80;

   screeny := 24;

  end;

{El total del Programa}

 procedure color24bits(xpos, ypos : integer); {Cargamos imagen 24 bit}

   procedure setblock(x1, y1 : Integer);

   Begin

     temp := (((longint(y1) * screenx * (bpp shr 3) + x1)) shr 16);

     if currentblock <> temp then

     begin

          asm

             mov ax,$4f05

             xor bh,bh

             mov dl,temp

             int $10

          end;

          currentblock := temp;

      end;

   end;

  procedure putpixel1(x1,y1 : Integer; color, clearcolor : colorreg);

  var

    z : byte;

   begin

   if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then

     begin

         x1 := round(x1 * (500 / infoinfo.tamanox));

         y1 := round(y1 * (350 / infoinfo.tamanoy));

     end;

   with color do

   begin

        setblock(x1 * 2,y1);

        mem[$a000 : ((x1 + y1 * screenx) * 2 + 0) - currentblock shl 16] :=

          (blue shr 3) and 31 + ((green shr 3) shl 7) and 224;

        setblock(x1 * 2 + 1,y1);

        mem[$a000 : ((x1 + y1 * screenx) * 2 + 1) - currentblock shl 16] :=

          (((green shr 3) shr 2) and 7) + (((red shr 3) shl 3) and 248);

   end;

  end;

  function presentabmp(xx, yy : Integer; nomb : String; docolors : boolean;

                                      clear : colorreg) : boolean;

    begin

     assign(f, nomb);

     reset(f,1);

     with infoinfo do

     if bitsPixel = 24 then

     begin

        blockread(f, memor, infocabe.inicioimag);

        z := (infoinfo.tamanox * bitspixel) shr 3;

          while z mod(4) <> 0 do Inc(z);

          color.reser := -1;

          bitspixel := (bitspixel shr 3);

        for y := infoinfo.tamanoy - 1 downto 0 do

        begin

          blockread(f, memor, z);

          for x := 0 to infoinfo.tamanox - 1 do

          begin

             color.blue  := ord(memor[x * bitspixel + 0]);

             color.green := ord(memor[x * bitspixel + 1]);

             color.red   := ord(memor[x * bitspixel + 2]);

             putpixel1(xx + x, yy + y, color, clear);

          end;

        end;

     end;

     close(f);

  end;

  begin

     modo := $111;

     iniciograf(modo);

     currentmode := modo;

     presentabmp(1,1,cargamos,true, blanco);

     if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then

     getmaxy := (round(infoinfo.tamanoy * (350 / infoinfo.tamanoy))) + 10

   else

     getmaxy := infoinfo.tamanoy + 10;

     outtextxy(40, getmaxy, text(cargamos));

     repeat

     until keypressed;

     closegraficos;

  end;

  procedure presentaimagen8(colr : array of regcolor); {presentamos Imagen

                                                        de 256 colores}

   var

     xx, yy, cont : integer;

     linea : longint;

   procedure putpixel256(x, y : word; c : byte);

   VAR

      banco : word;

      despla : longint;

   BEGIN

    if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then

    begin

          x := round(x * (500 / infoinfo.tamanox));

          y := round(y * (350 / infoinfo.tamanoy));

    end;

    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;

   begin

      assign(f,cargamos);

      reset(f,1);

         for cont := 0 to 255 do

         begin

            paletav[cont,0] := colr[cont].regrojo shr 2;

            paletav[cont,1] := colr[cont].regverde shr 2;

            paletav[cont,2] := colr[cont].regazul shr 2;

         end;

       modo := $101;

       iniciograf(modo);

       establecepaletacolores(255);

       ponpaletargb(paletav,255);

       seek(f,infocabe.inicioimag);

 linea := 4 * (infoinfo.tamanox div 4) + 4 * ord(infoinfo.tamanox mod 4 <> 0);

      for yy :=  infoinfo.tamanoy - 1 downto 0 do

      begin

        blockread(f,byt,linea);

        for xx := 0 to linea  do

        begin

           putpixel256(xx,yy,byt[xx]);

        end;

      end;

      close(f);

      if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then

     getmaxy := (round(infoinfo.tamanoy * (350 / infoinfo.tamanoy))) + 10

   else

     getmaxy := infoinfo.tamanoy + 10;

     outtextxy(40, getmaxy, text(cargamos));

      readkey;

      closegraficos;

   end;

  procedure cargaimagenesBmp; {Elije imagen a cargar segun elegida}

  begin

       presentadatosbmp(cargamos);

       if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then

       begin

          getmaxy := round(infoinfo.tamanoy * 0.50);

       end

     else

        getmaxy := infoinfo.tamanoy + 25;

       if (infoinfo.bitspixel = 1) or (infoinfo.bitspixel = 4) then

       begin

       asm

         mov ax,0012h

         int 10h

       end;

         modo := $12;

         if infoinfo.bitspixel = 4 then

         bmp16colores(cargamos);

         if infoinfo.bitspixel = 1 then

         bmp1colores(cargamos);

         if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then

     getmaxy := (round(infoinfo.tamanoy * (350 / infoinfo.tamanoy))) + 10

   else

         getmaxy := infoinfo.tamanoy + 10;

         outtextxy(40, getmaxy, text(cargamos));

         readkey;

       asm

         mov ax,0003h

         int 10h

       end;

      end;

      if infoinfo.bitspixel = 8 then

      begin

          presentaimagen8(bmpcol);

      end;

      if infoinfo.bitspixel = 24 then

      begin

          color24bits(0,0);

      end;

  end;

  procedure elijevisualizar;  {El menu jeneral}

  var

     salir : boolean;

     opci : char;

  begin

    salir := false;

    fondo := 0;

    repeat

      clrscr;

      writeln('***** Menu De Visualizacion Imagenes *****');

      writeln;

      writeln(' B = Imagenes BMP');

      writeln(' S = Salir');

      writeln;

      writeln('<<< Elija Opcion >>>');

     repeat

      opci := upcase(readkey);

     until opci in['B','J','S'];

    case opci of

  'B' : begin clrscr; exten := 'BMP'; menuarchivos; cargaimagenesBmp; end;

  'S' : salir := true;

  end;

    until salir = true;

  end;

  function estalavesa : boolean;

  begin

      asm

         mov ax,4f00h

         mov bx,seg dato1.asignatura[1]

         mov es,bx

         mov di,offset dato1.asignatura

         int 10h

      end;

      if (dato1.asignatura[1] = 'V') and (dato1.asignatura[2] = 'E') and

         (dato1.asignatura[3] = 'S') and (dato1.asignatura[4] = 'A') then

       estalavesa := true

     else

       estalavesa := false;

       closegraficos;

  end;

  begin

     if estalavesa then {Miramos si existe sistema compatible vesa}

     elijevisualizar {inicio del Programa}

   else

     begin

         clrscr;

         writeln('Sistema Vesa No Disponible en Este Equipo Pulse [Enter]');

         readln;

     end;

  end.