Pascal/Turbo Pascal - Graficos en Pascal

(*Por la cantidad de informacion en esta pagina [Compiladr de pascal 7.7] la

cual os recomiendo para segir el proceso de programacion en pascal paso a

abrir una nueva para el sistema de programacion de graficos.

Empezaremos creando una unidad para nuestros graficos los cuales nos

permitiran de momento trabajar con pantallas de 640x480 con 16/256/24bit de

colores.

Iremos esplicando poco a poco cada proceso provandolo individual mente y

despues crearemos la unidad con todos ellos.

Lo primero que tenemos que realizar es la comprovacion de la presencia y

toma de datos de nuestra targeta grafica os comento que estaremos con el

estandar vesa que hoy es lo normal.

 En la vesa tenemos dor registros de infoemacion no todos se empleara pero

 para que la conoccais la iremos presentando.*)

 program unidadgf;

 {$G+} (*Generaci¢n de C¢digo 80286 en el estado {$G-} codiga 8086*)

 {$N+} (*Coprocesador Num‚rico en el estado {$N-} rutinas de librer¡a*)

 (*Conmuta entre los dos modelos diferentes de generaci¢n de c¢digos*)

 uses

    crt, dos; (*unidades estandar de pascal*)

 type

      pModoList = ^tModoList; (*Puntero a los modos de video soportados*)

      tModoList = Array[0..65] of word; (*Array de modos soportados*)

      (*Primer registro de informacion vesa*)

        cabeceravesa = record

              identif : array[1..4] of char; (*Identificacion [vesa]*)

              version : array[1..2] of byte; (*Version de la vesa*)

              targeta : pchar;               (*Nombre de la casa*)

              capabilities : longint;  (*Compatibilidad*)

              Modosvideo : pmodolist;  (*Modos de video de la tarjeta*)

              memoriatama : word;  (*Tama¤o de la memoria*)

              revision : word;  (*Fecho revision*)

              nombrevendor : pchar; (*Nonbre del vendedor*)

              nombreproducto : pchar; (*Nombre del producto*)

              revisionproducto : pchar; (*Fecha revision del producto*)

              reserbado : array[0..221] of byte; (*Reservados*)

              datosmas : array[0..255] of byte; (*Reservados*)

              end;

     (*Segundo registro de informacion vesa*)

   informacionvesa = record

      attributes : word; (*atributos de modo*)

           winAa : byte; (*atributos ventana A*)

           winBa : byte; (*atributos ventana B*)

         granula : word; (*granularidad ventana*)

          winize : word; (*tama¤o ventana*)

         segwinA : word; (*inicio segmento ventana A*)

         segwinB : word; (*inicio segmento ventana B*)

     winfunction : pointer;(*puntero a funcion ventana*)

    bytesporline : word; (*bytes por linea de exploracion*)

            tamx : word; (*resolucion horizontal x*)

            tamy : word; (*resolucion vertical y*)

         charcex : byte; (*ancho de caracter  x *)

         charcey : byte; (*altura de los caracteres y *)

      memoplanes : byte; (*num. de planos de memoria*)

       bitspixel : byte; (*bits por pixel*)

        numbanks : byte; (*num. de bancos*)

         memtype : byte; (*Tipo de memoria o modelo*)

        sizebank : byte; (*tama¤o banco en  kb*)

        numpages : byte; (*num. de paginas*)

        reserve1 : byte; (*reserbado*)

         redsize : byte; (*tama¤o de la mascara roja directa color en bits*)

          redpos : byte; (*posicion de bit LSB de mascara roja*)

        greesize : byte; (*tama¤o de la mascara verde directa color en bits*)

         greepos : byte; (*posicion de bit LSB de mascara verde*)

        bluesize : byte; (*tama¤o de la mascara azul directa color en bits*)

         bluepos : byte; (*posicion de bit LSB de mascara azul*)

         ressize : byte; (*tama¤o de la mascara reservados*)

          respos : byte; (*posicion de bit LSB de reservados*)

    dircolorinfo : byte; (*atributos Directos Modo de color*)

    linvidbuffer : pointer; (*puntero al buffer*)

        reserve4 : array[1..210] of byte; (*reservado*)

         end;

    bgr = array[0..3] of byte; (*array para el color*)

      dibujo = record     (*registro para el puntero del raton*)

               xg : integer; (*posicion x del raton*)

               yg : integer; (*posicion y del raton*)

            imag : array[0..15,0..15] of byte; (*pantalla de la posicion*)

                                               (* del raton*)

            colores : array[0..15,0..15] of bgr;(*colores tomados*)

         end;

   const

     loximag = 15; (*longitud x de la imagen*)

     loyimag = 15; (*longitud y de la imagen*)

      blue : byte = 255; (*variable de color verde*)

     green : byte = 255; (*variable de color azul*) (*estado inicial*)

       red : byte = 255; (*variable de color rojo*)

   (*Nuestro raton*)

   raton : array[0..15,0..15] of byte = (

             (1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0),

             (1,8,1,0,0,0,0,0,0,0,0,0,0,0,0,0),

             (1,8,8,1,0,0,0,0,0,0,0,0,0,0,0,0),

             (1,8,8,8,1,0,0,0,0,0,0,0,0,0,0,0),

             (1,8,8,8,8,1,0,0,0,0,0,0,0,0,0,0),

             (1,8,8,8,8,8,1,0,0,0,0,0,0,0,0,0),

             (1,8,8,8,8,8,8,1,0,0,0,0,0,0,0,0),

             (1,8,8,8,8,8,8,8,1,0,0,0,0,0,0,0),

             (1,8,8,8,8,8,8,8,8,1,0,0,0,0,0,0),

             (1,8,8,8,8,8,1,1,1,1,1,0,0,0,0,0),

             (1,8,8,1,1,8,1,0,0,0,0,0,0,0,0,0),

             (1,1,1,0,1,8,8,1,0,0,0,0,0,0,0,0),

             (1,1,0,0,1,8,8,1,0,0,0,0,0,0,0,0),

             (0,0,0,0,0,1,8,8,1,0,0,0,0,0,0,0),

             (0,0,0,0,0,1,8,8,1,0,0,0,0,0,0,0),

             (0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0));

  var

    mous : dibujo; (*para el raton*)

    sal, mouse : boolean; (*para la presencia o ausencia del raton*)

    cabecera : cabeceravesa; (*para la cabecera vesa*)

    infovesa : informacionvesa; (*para la informacion vesa*)

    page, currentblock, temp, BPP : Byte; (*para nuestra vesa datos*)

    cbank, modo : word;  (*para nuestra vesa datos*)

    regs : registers; (*para los datos del raton*)

    xm, ym, x, y, screeny, screenx : Integer; (*datos de posiciones*)

    maxx, maxy : word; (*lo mismo de antes*)

    tecla : char; (*para el teclado*)

    colorpixel, jpgszin : bgr;  (*para el color*)

    esta : boolean; (*para el estado vesa*)

    tamano : longint; (*para la memoria video*)

    modosl : pModoList; (*modos video*)

   (*funcion conversion word a string*)

   function wordstring(n : word) : string;

   var

     s : string[12];

    begin

       str(n,s);

       wordstring := copy(s,1,sizeof(s));

    end;

  (*conversion a exadecimal un word*)

  function hexstr(val : word; cnt : byte) : string;

  const

   HexTbl : array[0..15] of char = '0123456789ABCDEF';

  var

  i : longint;

  begin

    hexstr[0] := char(cnt);

  for i := cnt downto 1 do

   begin

     hexstr[i] := hextbl[val and $f];

     val := val shr 4;

   end;

 end;

 (*recojemos los datos de la cabecera vesa*)

 procedure informacioncabeceravesa;assembler;

   asm

      mov ax,4f00h

      mov bx,seg cabecera.identif[1]

      mov es,bx

      mov di,offset cabecera.identif

      int 10h

   end;

  (*comprovamos se esiste el modo vesa y cargamos los datos*)

  procedure setvideo(mo : word);

  var

    segm, ofsm : word;

   begin

   informacioncabeceravesa;

   esta := true;

   asm

      mov ax,4f02h

      mov bx,mo

      int 10h

      cmp ax,4fh

      je @exit

      mov ah,00h

      mov al,3

      int 10H

      mov esta,false

      @exit:

   end;

   if esta = false then

   begin

      writeln('<<< Error Grafico Sistema Vesa No Presente >>>');

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

      readln;

      halt;

   end;

   segm := seg(infovesa);

   ofsm := ofs(infovesa);

   asm

      push es

      mov ax,4f01h

      mov cx,mo

      mov es,segm

      mov di,ofsm

      int 10h

      mov segm,es

      mov ofsm,di

      pop es

   end;

     maxx := infovesa.tamx;

     maxy := infovesa.tamy;

     screeny := maxy;

     screenx := maxx;

     page := 0;

     currentblock := 0;

     temp := 0;

     BPP := 16;

 end;

  (*cerramos el modo grafico vesa pasando a texto*)

  procedure closegraph;assembler;

  asm

    mov ah,00h

    mov al,03h

    int 10h

  end;

  (*programa principal comprovamos lo dicho*)

  begin

      clrscr;

      modo := $101;

      setvideo(modo);

      if esta = true then

      begin

       closegraph;

       writeln;

       writeln('   Identificacion : ',cabecera.identif[1],cabecera.identif[2],

                   cabecera.identif[3],cabecera.identif[4]);

       writeln('   Version          : ',cabecera.version[2],'.',

                                                cabecera.version[1]);

       writeln('   Fabricante       : ',cabecera.targeta);

       tamano := cabecera.memoriatama;

       tamano := (tamano * 64000) div 1024;

       writeln('   Memoria Tama¤o   : ',tamano,' Kb');

       writeln('   Modos Soportados ');

       x := 0;

       sal := false;

     repeat

       if cabecera.Modosvideo^[x] < 655 then

       write('  $',hexstr(cabecera.Modosvideo^[x],3))

     else

       sal := true;

       x := x + 1;

     until (sal = true) or (x > 65);

       writeln;

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

       readln;

      end;

  end.

  (*Con esto podeis practicar la prosima pintaremos y moveremos el raton*)

{Como dije en la anterior en esta presentaremos y moveremos el ratón por la pantalla  de nuestro

ordenador y tomaremos decisiones de colores de presentación solo emplearemos 16 colores

para nuestra entrada posterior mente añadiremos muchos mas.

Con esto espero practiquéis asta la siguiente entrega.

Fijaros que realizo los procesos de diferente forma esto es para que podáis ver mejor como

 se puede trabajar con pascal de diferente maneras.

 program unidadgf;

 {$G+} (*Generaci¢n de C¢digo 80286 en el estado {$G-} codiga 8086*)

 {$N+} (*Coprocesador Num‚rico en el estado {$N-} rutinas de librer¡a*)

 (*Conmuta entre los dos modelos diferentes de generaci¢n de c¢digos*)

 uses

    crt, dos; (*unidades estandar de pascal*)

 type

      pModoList = ^tModoList; (*Puntero a los modos de video soportados*)

      tModoList = Array[0..65] of word; (*Array de modos soportados*)

      (*Primer registro de informacion vesa*)

        cabeceravesa = record

              identif : array[1..4] of char; (*Identificacion [vesa]*)

              version : array[1..2] of byte; (*Version de la vesa*)

              targeta : pchar;               (*Nombre de la casa*)

              capabilities : longint;  (*Compatibilidad*)

              Modosvideo : pmodolist;  (*Modos de video de la tarjeta*)

              memoriatama : word;  (*Tama¤o de la memoria*)

              revision : word;  (*Fecho revision*)

              nombrevendor : pchar; (*Nonbre del vendedor*)

              nombreproducto : pchar; (*Nombre del producto*)

              revisionproducto : pchar; (*Fecha revision del producto*)

              reserbado : array[0..221] of byte; (*Reservados*)

              datosmas : array[0..255] of byte; (*Reservados*)

              end;

     (*Segundo registro de informacion vesa*)

   informacionvesa = record

      attributes : word; (*atributos de modo*)

           winAa : byte; (*atributos ventana A*)

           winBa : byte; (*atributos ventana B*)

         granula : word; (*granularidad ventana*)

          winize : word; (*tama¤o ventana*)

         segwinA : word; (*inicio segmento ventana A*)

         segwinB : word; (*inicio segmento ventana B*)

     winfunction : pointer;(*puntero a funcion ventana*)

    bytesporline : word; (*bytes por linea de exploracion*)

            tamx : word; (*resolucion horizontal x*)

            tamy : word; (*resolucion vertical y*)

         charcex : byte; (*ancho de caracter  x *)

         charcey : byte; (*altura de los caracteres y *)

      memoplanes : byte; (*num. de planos de memoria*)

       bitspixel : byte; (*bits por pixel*)

        numbanks : byte; (*num. de bancos*)

         memtype : byte; (*Tipo de memoria o modelo*)

        sizebank : byte; (*tama¤o banco en  kb*)

        numpages : byte; (*num. de paginas*)

        reserve1 : byte; (*reserbado*)

         redsize : byte; (*tama¤o de la mascara roja directa color en bits*)

          redpos : byte; (*posicion de bit LSB de mascara roja*)

        greesize : byte; (*tama¤o de la mascara verde directa color en bits*)

         greepos : byte; (*posicion de bit LSB de mascara verde*)

        bluesize : byte; (*tama¤o de la mascara azul directa color en bits*)

         bluepos : byte; (*posicion de bit LSB de mascara azul*)

         ressize : byte; (*tama¤o de la mascara reservados*)

          respos : byte; (*posicion de bit LSB de reservados*)

    dircolorinfo : byte; (*atributos Directos Modo de color*)

    linvidbuffer : pointer; (*puntero al buffer*)

        reserve4 : array[1..210] of byte; (*reservado*)

         end;

    bgr = array[0..3] of byte; (*array para el color*)

    regcolor = array[0..2] of byte;

      dibujo = record     (*registro para el puntero del raton*)

               xg : integer; (*posicion x del raton*)

               yg : integer; (*posicion y del raton*)

            imag : array[0..15,0..15] of byte; (*pantalla de la posicion*)

                                               (* del raton*)

            colores : array[0..15,0..15] of regcolor;(*colores tomados*)

         end;

     palcolores = array[0..255,0..2] of byte;

   const

     loximag = 15; (*longitud x de la imagen*)

     loyimag = 15; (*longitud y de la imagen*)

      blue : byte = 255; (*variable de color verde*)

     green : byte = 255; (*variable de color azul*) (*estado inicial*)

       red : byte = 255; (*variable de color rojo*)

   (*Nuestro raton*)

   raton : array[0..15,0..15] of byte = (

             (1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0),

             (1,8,1,0,0,0,0,0,0,0,0,0,0,0,0,0),

             (1,8,8,1,0,0,0,0,0,0,0,0,0,0,0,0),

             (1,8,8,8,1,0,0,0,0,0,0,0,0,0,0,0),

             (1,8,8,8,8,1,0,0,0,0,0,0,0,0,0,0),

             (1,8,8,8,8,8,1,0,0,0,0,0,0,0,0,0),

             (1,8,8,8,8,8,8,1,0,0,0,0,0,0,0,0),

             (1,8,8,8,8,8,8,8,1,0,0,0,0,0,0,0),

             (1,8,8,8,8,8,8,8,8,1,0,0,0,0,0,0),

             (1,8,8,8,8,8,1,1,1,1,1,0,0,0,0,0),

             (1,8,8,1,1,8,1,0,0,0,0,0,0,0,0,0),

             (1,1,1,0,1,8,8,1,0,0,0,0,0,0,0,0),

             (1,1,0,0,1,8,8,1,0,0,0,0,0,0,0,0),

             (0,0,0,0,0,1,8,8,1,0,0,0,0,0,0,0),

             (0,0,0,0,0,1,8,8,1,0,0,0,0,0,0,0),

             (0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0));

    maxcolor = 15;

    RojGeeBlu : array[0..maxcolor,0..2] of byte = (

  (0,0,0),(0,0,255),(0,255,0),(0,240,255),(255,0,0),(128,0,255),

  (128,64,0),(192,192,192),(128,128,128),(128,255,255),(0,255,128),

  (128,255,255),(255,128,0),(128,128,255),(255,240,0),(255,255,255));

  var

    mous : dibujo; (*para el raton*)

    sal, mouse : boolean; (*para la presencia o ausencia del raton*)

    cabecera : cabeceravesa; (*para la cabecera vesa*)

    infovesa : informacionvesa; (*para la informacion vesa*)

    page, currentblock, temp, BPP : Byte; (*para nuestra vesa datos*)

    cbank, modo : word;  (*para nuestra vesa datos*)

    regs : registers; (*para los datos del raton*)

    k, xm, ym, x, y, screeny, screenx : Integer; (*datos de posiciones*)

    maxx, maxy : word; (*lo mismo de antes*)

    opci, tecla : char; (*para el teclado*)

    colorpixel, jpgszin : bgr;  (*para el color*)

    esta : boolean; (*para el estado vesa*)

    tamano : longint; (*para la memoria video*)

    modosl : pModoList; (*modos video*)

    color256_16 :  palcolores;

    coll : regcolor;

    colort : byte;

   (*funcion conversion byte a string*)

   function bytestring(n : byte) : string;

  var

     s : string[5];

   begin

      str(n,s);

      bytestring := s;

   end;

   (*funcion conversion word a string*)

   function wordstring(n : word) : string;

   var

     s : string[12];

    begin

       str(n,s);

       wordstring := copy(s,1,sizeof(s));

    end;

  (*conversion a exadecimal un word*)

  function hexstr(val : word; cnt : byte) : string;

  const

   HexTbl : array[0..15] of char = '0123456789ABCDEF';

  var

  i : longint;

  begin

    hexstr[0] := char(cnt);

  for i := cnt downto 1 do

   begin

     hexstr[i] := hextbl[val and $f];

     val := val shr 4;

   end;

 end;

 (*recojemos los datos de la cabecera vesa*)

 procedure informacioncabeceravesa;assembler;

   asm

      mov ax,4f00h

      mov bx,seg cabecera.identif[1]

      mov es,bx

      mov di,offset cabecera.identif

      int 10h

   end;

  (*comprovamos se esiste el modo vesa y cargamos los datos*)

  procedure setvideo(mo : word);

  var

    segm, ofsm : word;

   begin

   informacioncabeceravesa;

   esta := true;

   asm

      mov ax,4f02h

      mov bx,mo

      int 10h

      cmp ax,4fh

      je @exit

      mov ah,00h

      mov al,3

      int 10H

      mov esta,false

      @exit:

   end;

   if esta = false then

   begin

      writeln('<<< Error Grafico Sistema Vesa No Presente >>>');

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

      readln;

      halt;

   end;

   segm := seg(infovesa);

   ofsm := ofs(infovesa);

   asm

      push es

      mov ax,4f01h

      mov cx,mo

      mov es,segm

      mov di,ofsm

      int 10h

      mov segm,es

      mov ofsm,di

      pop es

   end;

     maxx := infovesa.tamx;

     maxy := infovesa.tamy;

     screeny := maxy;

     screenx := maxx;

     page := 0;

     currentblock := 0;

     temp := 0;

     BPP := 16;

 end;

  (*cerramos el modo grafico vesa pasando a texto*)

  procedure closegraph;assembler;

  asm

    mov ah,00h

    mov al,03h

    int 10h

  end;

  procedure SetPalette(paleta : palcolores; cu : integer);assembler;

   asm

     les dx,paleta

     mov ax,1012h

     mov bx,0

     mov cx,cu

     int 10h

   end;

 {Putpixel y getpixel para 640x480x16 colores}

 procedure putpixel12(xp, yp : word;colo : byte);assembler;

 asm

    mov ah,0Ch

    mov bh,0

    mov al,byte(colo)

    mov bx,0

    mov cx,xp

    mov dx,yp

    int 10h

 end;

 function getpixel12(xp, yp : word) : byte;assembler;

 asm

   mov ah,0dh

   mov dx,yp

   mov cx,xp

   int 10h

 end;

 {Putpixel y getpixel para 640x480x256 colores}

 procedure putpixel256(xp, yp : word;colo : byte);

 var

    banco : word;

    despla : longint;

   begin

       despla := (longint(yp) * maxx) + xp;

       banco := despla shr bpp;

       despla := despla - (banco shl bpp);

       if banco <> page then

       begin

        page := banco;

        asm

          mov ax,4F05h

          mov dx,banco

          int 10h

        end;

     end;

       mem[$A000 : (yp * maxx) + xp] := colo;

  end;

  function getpixel256(xp, yp : word) : byte;

  var

    banco : word;

    despla : longint;

   begin

       despla := (longint(yp) * maxx) + xp;

       banco := despla shr bpp;

       despla := despla - (banco shl bpp);

       if banco <> page then

       begin

        page := banco;

        asm

          mov ax,4F05h

          mov dx,banco

          int 10h

        end;

     end;

       getpixel256 := mem[$A000 : (yp * maxx) + xp];

   end;

   {Putpixel y getpixel para 640x480x24bit 16581375 colores}

   procedure setbanco(xp, yp : Integer);

   Begin

     temp := (((longint(yp) * screenx * (bpp shr 3) + xp)) 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 putpixel24bit(xp1, yp1 : word; rp, gp, bp : byte);

   begin

      setbanco(xp1 * 2,yp1);

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

                                                                      rp;

      setbanco(xp1 * 2 + 1,yp1);

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

                                                                      gp;

      setbanco(xp1 * 2 + 2,yp1);

      mem[$a000 : ((xp1 + yp1 * screenx) * 2 + 2) - currentblock shl 16] :=

                                                                      bp;

   end;

   function getpixel24bit(xp1,yp1 : word) : byte;

   begin

   setbanco(xp1 * 2,yp1);

   red := mem[$a000 : ((xp1 + yp1 * screenx) * 2) - currentblock shl 16];

   setbanco(xp1 * 2 + 1,yp1);

   green := mem[$a000 : ((xp1 + yp1 * screenx) * 2 + 1) - currentblock shl 16];

   setbanco(xp1 * 2 + 2,yp1);

   blue := mem[$a000 : ((xp1 + yp1 * screenx) * 2 + 2) - currentblock shl 16];

   end;}

   procedure getpixel24bit(xx, yy : longint;var coll);assembler;

   asm

      db 66h;mov bx,word ptr[xx]

      cmp bx,maxx

      jae @exit

      db 66h;mov ax,word ptr[yy]

      cmp ax,maxy

      jae @exit

      shl bx,1

      db 66h;xor dx,dx

      mov dx,infovesa.bytesporline

      db 66h; mul dx;

      db 66h;add ax,bx

      mov di,ax

      db 66h;shr ax,16

      cmp ax,cbank

      je @tomacolor

      mov cbank,ax

      mov dx,ax

      mov bx,00h

      call infovesa.winfunction

  @tomacolor:

      mov es,sega000

      mov ax,[es:di]

      mov bx,ax

      shl bx,3

      shl bh,2

      mov cl,ah

      and cl,11111000b

      les di,coll

      mov [es:di],bx

      mov [es:di + 2],cx

  @exit:

 end;

  procedure putpixel24bit(xx, yy : longint; regcol : regcolor);assembler;

  asm

      db 66h;mov bx,word ptr[xx]

      cmp bx,maxx

      jae @exit

      db 66h;mov ax,word ptr[yy]

      cmp ax,maxy

     jae @exit

      db 66h;shl bx,1

      db 66h;xor dx,dx

      mov dx,infovesa.bytesporline

      db 66h; mul dx;

      db 66h;add ax,bx

      mov di,ax

      db 66h;shr ax,16

      cmp ax,cbank

      je @poncolor

       mov cbank,ax

       mov dx,ax

       mov bx,00h

       call infovesa.winfunction

  @poncolor:

       les si,regcol

       mov ax,[es:si]

       and ax,1111110011111000b

       mov ch,[es:si + 2]

       and ch,11111000b

       shr ah,2

       shr ax,3

       or ah,ch

       mov es,sega000

       stosw

   @exit:

  end;

   procedure ponpixeltodos(xp, yp : word; colo : byte);

   begin

       if modo = $111 then

       begin

       putpixel24bit(xp, yp,coll);

       end;

       if modo = $101 then

       begin

          putpixel256(xp, yp, colo);

       end;

       if modo = $12 then

       begin

          putpixel12(xp, yp, colo);

       end;

   end;

{Esto va en dos partes esta es la [1]}

{Parte [2]}

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

   var

      lx, ly : word;

      cok, bit, posf, font, posi : byte;

      i, t : integer;

      r, g, b : byte;

  begin

     ly := y;

   if modo = $111 then

   begin

   cok := maxcolor;

   r := coll[0];

   g := coll[1];

   b := coll[2];

   coll[0] := RojGeeBlu[cok,0];

   coll[1] := RojGeeBlu[cok,1];

   coll[2] := RojGeeBlu[cok,2];

   end;

   if (modo = $101) or (modo = $12) then

   begin

   SetPalette(color256_16,maxcolor + 1);

   cok := maxcolor;

   end;

   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, cok);

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

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

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

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

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

       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, cok);

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

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

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

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

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

       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, cok);

          x := x + 1;

          end;

          y := y + 1;

          x := lx;

        end;

          x := x + 8;

       end;

        if modo = $111 then

        begin

           coll[0] := r;

           coll[1] := g;

           coll[2] := b;

        end;

     end;

   function tomapixeltodos(xt, yt : word) : byte;

   begin

       if modo = $111 then

       begin

          getpixel24bit(xt, yt,coll);

       end;

       if modo = $101 then

       begin

          tomapixeltodos := getpixel256(xt, yt);

       end;

        if modo = $12 then

        begin

            tomapixeltodos := getpixel12(xt, yt);

        end;

   end;

    procedure ponquitamouse(xm, ym : word; ponquita : boolean);

   var

      dd, r, g, b, col1, colo : byte;

      mx, my : word;

   begin

       if ponquita = true then

       begin  {ponemos mouse}

             r := coll[0];

            g := coll[1];

            b := coll[2];

            mouse := false;

           if (modo = $101) or (modo = $12) then

           begin

             if modo = $101 then

             begin

             colo := maxcolor;

             col1 := maxcolor - 8;

             end;

             if modo = $12 then

             begin

             colo := 15;

             col1 := 7;

             end;

            end;

             if modo = $111 then

             begin

                coll[0] := RojGeeBlu[maxcolor][0];

                coll[1] := RojGeeBlu[maxcolor][1];

                coll[2] := RojGeeBlu[maxcolor][2];

             end;

           for mx := 0 to loximag do

             for my := 0 to loyimag do

             begin

             if modo = $111 then

             begin

             dd := tomapixeltodos((xm - 1) + mx,(ym - 1) + my);

             mous.colores[mx,my][0] := coll[0];

             mous.colores[mx,my][1] := coll[1];

             mous.colores[mx,my][2] := coll[2];

             end

           else

             mous.imag[mx,my] := tomapixeltodos((xm - 1) + mx,(ym - 1) + my);

             end;

               for mx := 0 to loximag do

                 for my := 0 to loyimag do

                 begin

                 if raton[my,mx] = 1 then

                 begin

                 ponpixeltodos((xm - 1) + mx,(ym - 1) + my,colo);

                 end;

                 if raton[my,mx] = 8 then

                 begin

                 ponpixeltodos((xm - 1) + mx,(ym - 1) + my,col1);

                 end;

            end;

              if modo = $111 then

              begin

               for mx := 0 to loximag do

                 for my := 0 to loyimag do

                 begin

                 if raton[my,mx] = 1  then

                 begin

                 coll[0] := RojGeeBlu[maxcolor][2];

                 coll[1] := RojGeeBlu[maxcolor][1];

                 coll[2] := RojGeeBlu[maxcolor][0];

                 ponpixeltodos((xm - 1) + mx,(ym - 1) + my,colo);

                 end;

                 if raton[my,mx] = 8 then

                 begin

                 coll[0] := RojGeeBlu[13,2];

                 coll[1] := RojGeeBlu[13,1];

                 coll[2] := RojGeeBlu[13,0];

                 ponpixeltodos((xm - 1) + mx,(ym - 1) + my,colo);

                 end;

                end;

              end;

              mouse := true;

              coll[0] := r;

              coll[1] := g;

              coll[2] := b;

         end;

        {quitamos mouse}

       if ponquita = false then

       begin

           r := coll[0];

           g := coll[1];

           b := coll[2];

           if (modo = $101) or (modo = $12) then

           begin

           for mx := 0 to loximag do

             for my := 0 to loyimag do

             begin

             ponpixeltodos((xm - 1) + mx,(ym - 1) + my,mous.imag[mx,my]);

             end;

            end;

              if modo = $111 then

              begin

                 for mx := 0 to loximag do

                  for my := 0 to loyimag do

                  begin

                    coll[0] := mous.colores[mx,my][0];

                    coll[1] := mous.colores[mx,my][1];

                    coll[2] := mous.colores[mx,my][2];

                    ponpixeltodos((xm - 1) + mx,(ym - 1) + my,15);

                  end;

              end;

           mouse := false;

           coll[0] := r;

           coll[1] := g;

           coll[2] := b;

       end;

   end;

   function estamouse : boolean;

   begin

      estamouse := false;

      mouse := false;

      regs.ax := $00;

      intr($33,regs);

      mouse := regs.ax <> $00;

      estamouse := mouse;

   end;

  function posx_raton : integer;

  begin

      regs.ax := $03;

      intr($33,regs);

      posx_raton := regs.cx;

  end;

  function posy_raton : integer;

  begin

      regs.ax := $03;

      intr($33,regs);

      posy_raton := regs.dx;

  end;

  procedure pon_posicion_raton(xg, yg : word);

  begin

      regs.ax := $04;

      regs.cx := xg;

      regs.dx := yg;

      intr($33,regs);

  end;

   function boton_raton : word;

   begin

      regs.ax := $03;

      intr($33,regs);

      boton_raton := regs.bx;

   end;

   procedure lineh(x1, y1, x2 : word;co : byte);

   var

      t, xx, l : word;

   begin

       if x1 > x2 then

       begin

          xx := x1;

          x1 := x2;

          x2 := xx;

       end;

       t := x2 - x1;

       for l := 0 to t do

       ponpixeltodos(x1 + l,y1,co);

   end;

   procedure linev(x1, y1, y2 : word;co : byte);

   var

      t, xx, l : word;

   begin

       if y1 > y2 then

       begin

          xx := y1;

          y1 := y2;

          y2 := xx;

       end;

       t := y2 - y1;

       for l := 0 to t do

       ponpixeltodos(x1,y1 + l,co);

   end;

  procedure Linea(x1, y1, x2, y2 : word; color : byte);

  var

     d, 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;

  ponpixeltodos(x1, y1, color);

  if dx > dy then

  begin

    ai := (dy - dx) * 2;

    bi := dy * 2;

    d  := bi - dx;

    repeat

      if (d >= 0) then

      begin

        inc(y1, yi);

        inc(d, ai);

      end

      else

        inc(d, bi);

      inc(x1, xi);

      ponpixeltodos(x1, y1,color);

    until (x1 = x2);

    end

  else

    begin

    ai := (dx - dy) * 2;

    bi := dx * 2;

    d  := bi - dy;

    repeat

      if (d >= 0) then

      begin

        inc(x1, xi);

        inc(d, ai);

      end

      else

        inc(d, bi);

      inc(y1, yi);

      ponpixeltodos(x1, y1, color);

    until (y1 = y2);

    end;

  end;

   procedure rectangulo(xr, yr, xxr, yyr : word; col : byte);

   begin

       linea(xr,yr,xxr,yr,col);

       linea(xr,yyr,xxr,yyr,col);

       linea(xr,yr,xr,yyr,col);

       linea(xxr,yr,xxr,yyr,col);

   end;

   procedure boton(xb, yb : word; actib : boolean);

   var

     j, h : word;

     colo1, colo2 : byte;

     r, g, b : byte;

   begin

      if modo = $111 then

     begin

          r := red;

          g := green;

          b := blue;

          colo1 := maxcolor;

          colo2 := 7;

          coll[0] := RojGeeBlu[colo1][2];

          coll[1] := RojGeeBlu[colo1][1];

          coll[2] := RojGeeBlu[colo1][0];

          for j := 0 to 4 do

          begin

          lineh(xb + j,(yb + 4) + j,((xb + 16) + (14 * 4)) - j,colo1);

          linev(xb + j,(yb + 4) + j,((yb + 22) + (14 * 4)) - j,colo1);

          end;

          coll[0] := RojGeeBlu[colo2][2];

          coll[1] := RojGeeBlu[colo2][1];

          coll[2] := RojGeeBlu[colo2][0];

          for j := 0 to 4 do

          begin

      lineh(xb + j,((yb + 8) + (5 * 14)) - j,((xb + 16) + (14 * 4)) - j,colo2);

      linev((xb + 2) + (14 * 5) - j,(yb + 4) + j,((yb + 22) + (14 * 4)) - j,colo2);

      end;

      end;

      if modo = $101 then

      begin

      colo1 := maxcolor;

      colo2 := 7;

      end;

      if modo = $12 then

      begin

      colo1 := 15;

      colo2 := 7;

      end;

      if (modo = $101) or (modo = $12) then

      begin

      for j := 0 to 4 do

      begin

      lineh(xb + j,(yb + 4) + j,((xb + 16) + (14 * 4)) - j,colo1);

      lineh(xb + j,((yb + 8) + (5 * 14)) - j,((xb + 16) + (14 * 4)) - j,colo2);

      end;

       for h := 0 to 4 do

       begin

          linev(xb + h,(yb + 4) + h,((yb + 22) + (14 * 4)) - h,colo1);

   linev((xb + 2) + (14 * 5) - h,(yb + 4) + h,((yb + 22) + (14 * 4)) - h,colo2);

       end;

     end;

       if modo = $111 then

       begin

          red := r;

          green := g;

          blue := b;

       end;

   end;

   procedure presenta_colores(xc, yc, cual : word);

   var

     t, p : word;

   begin

      p := 0;

      t := 0;

      boton(xc - 4,yc,true);

      if esta = true then

      begin

      if (modo = $101) or (modo = $12) then

      begin

      for k := 0 to maxcolor do

      begin

          color256_16[k,0] := RojGeeBlu[k][0] shr 2;

          color256_16[k,1] := RojGeeBlu[k][1] shr 2;

          color256_16[k,2] := RojGeeBlu[k][2] shr 2;

      end;

      if cual = $101 then

      SetPalette(color256_16,maxcolor + 1);

      if cual = $12 then

      begin

         SetPalette(color256_16,16);

      end;

    end;

      for k := 0 to maxcolor do

      begin

      if cual = $111 then

      begin

       coll[0] := RojGeeBlu[k][0];

       coll[1] := RojGeeBlu[k][1];

       coll[2] := RojGeeBlu[k][2];

       end;

       for x := 1 to 14 do

       begin

         for y := 1 to 14 do

         begin

         ponpixeltodos((xc + 15) + (p * 16) - x,(yc + 10) + (t * 16) + y,k);

         end;

        end;

          p := p + 1;

          if p > 3 then

          begin

          p := 0;

          t := t + 1;

          end;

      end;

     end;

   end;

   procedure borrazona(xz, yz, xxz, yyz : word);

   var

     z1, z2 : word;

     co, r, g, b : byte;

   begin

       if modo = $111 then

       begin

       r := coll[0];

       g := coll[1];

       b := coll[2];

       coll[0] := 0;

       coll[1] := 0;

       coll[2] := 0;

       end

    else

       co := 0;

       for z1 := xz to xxz do

         for z2 := yz to yyz do

         ponpixeltodos(z1, z2,co);

      if modo = $111 then

      begin

         coll[0] := r;

         coll[1] := g;

         coll[2] := b;

      end;

   end;

   procedure tomacolor(xc, yc : word; var colort : byte);

   begin

      case yc of

  25..35 : case xc of

       13..25 : colort := 0;

       30..41 : colort := 1;

       44..57 : colort := 2;

       60..72 : colort := 3;

           end;

  38..51 : case xc of

       13..25 : colort := 4;

       30..41 : colort := 5;

       44..57 : colort := 6;

       60..72 : colort := 7;

           end;

 56..67 : case xc of

       13..25 : colort := 8;

       30..41 : colort := 9;

       44..57 : colort := 10;

       60..72 : colort := 11;

          end;

 71..83 : case xc of

       13..25 : colort := 12;

       30..41 : colort := 13;

       44..57 : colort := 14;

       60..72 : colort := 15;

          end;

      end;

   end;

   procedure asignacolor(xx, yy : word);

   begin

       tomacolor(xx,yy,colort);

       if modo = $111 then

       begin

          coll[0] := RojGeeBlu[colort,0];

          coll[1] := RojGeeBlu[colort,1];

          coll[2] := RojGeeBlu[colort,2];

       end

     else

        colort := colort;

   end;

  (*programa principal comprovamos lo dicho*)

  begin

      clrscr;

      gotoxy(10,3);write('***** Elija Opcion Modo Video *****');

      gotoxy(10,5);write(' 1 = 640X480X16');

      gotoxy(10,6);write(' 2 = 640X480X256');

      gotoxy(10,7);write(' 3 = 640X480X16M');

      gotoxy(10,8);write(' 0 = Nada Sale');

      gotoxy(10,10);write('Prueva Grafica');

      repeat

       opci := readkey;

      until opci in[#49,#50,#51,#48];

    if opci in[#49,#50,#51] then

    begin

      case opci of

   #49 : modo := $12;

   #50 : modo := $101;

   #51 : modo := $111;

   end;

  end;

  if opci = #48 then

  halt(1);

      mouse := estamouse;

      setvideo(modo);

       presenta_colores(10,10,modo);

       outtextxy(14,3,'Colores');

       outtextxy(100,3,'Use mouse Boton Izquierdo colores Derecho Fin');

       outtextxy(100,13,'Rectangulo');

       rectangulo(100,23,176,60,colort);

       outtextxy(100,maxy - 10,'Uso Del Mouse Y presentacion de colores');

       pon_posicion_raton(300,100);

       x := posx_raton;

       y := posy_raton;

       ponquitamouse(x,y,true);

     repeat

        if (x <> posx_raton) or (y <> posy_raton) then

        begin

           ponquitamouse(x,y,false);

           x := posx_raton;

           y := posy_raton;

           if x < 4 then

           x := 4;

           if x > maxx - 15 then

           x := maxx - 15;

           ponquitamouse(x,y,true);

           delay(50);

        end;

       if boton_raton = 1 then

       begin

          ponquitamouse(x,y,false);

          asignacolor(x,y);

          outtextxy(100,13,'Rectangulo');

          rectangulo(100,23,176,60,colort);

          ponquitamouse(x,y,true);

       end;

    until (boton_raton = 2) or (keypressed);

       ponquitamouse(x,y,false);

       closegraph;

  end.

{Asta la prosima}

{A qui tenemos nuestra init grafica poco a poco iremos preparando cosas con he ya}

 unit mivesa1;

 {$G+,N+}

 interface

 uses

    crt, dos;

 type

      pModoList = ^tModoList;

      tModoList = Array[0..65] of word;

        cabeceravesa = record

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

              version : array[1..2] of byte;

              targeta : pchar;

              capabilities : longint;

              Modosvideo : pmodolist;

              memoriatama : word;

              revision : word;

              nombrevendor : pchar;

              nombreproducto : pchar;

              revisionproducto : pchar;

              reserbado : array[0..221] of byte;

              datosmas : array[0..255] of byte;

              end;

   informacionvesa = record

      attributes : word;

           winAa : byte;

           winBa : byte;

         granula : word;

          winize : word;

         segwinA : word;

         segwinB : word;

     winfunction : pointer;

    bytesporline : word;

            tamx : word;

            tamy : word;

         charcex : byte;

         charcey : byte;

      memoplanes : byte;

       bitspixel : byte;

        numbanks : byte;

         memtype : byte;

        sizebank : byte;

        numpages : byte;

        reserve1 : byte;

         redsize : byte;

          redpos : byte;

        greesize : byte;

         greepos : byte;

        bluesize : byte;

         bluepos : byte;

         ressize : byte;

          respos : byte;

    dircolorinfo : byte;

    linvidbuffer : pointer;

        reserve4 : array[1..210] of byte;

         end;

    bgr = array[0..3] of byte;

    regcolor = array[0..2] of byte;

      dibujo = record

               xg : integer;

               yg : integer;

            imag : array[0..15,0..15] of byte;

            colores : array[0..15,0..15] of regcolor;

         end;

     palcolores = array[0..255,0..2] of byte;

     tomazona = array[1..8056] of byte;

   const

     loximag = 15;

     loyimag = 15;

      blue : byte = 255;

     green : byte = 255;

       red : byte = 255;

 maxcolor = 249;

 RojGeeBlu : array[0..maxcolor,0..2] of byte = (

 (0,0,0),(0,0,168),(0,168,0),(0,168,168),(168,0,0),(168,0,168),

 (168,84,0),(168,168,168),(84,84,84),(84,84,252),(84,252,84),

 (84,252,252),(252,84,84),(252,84,252),(252,252,84),(252,252,252),

 (8,8,8),(20,20,20),(32,32,32),(44,44,44),(56,56,56),(68,68,68),

 (80,80,80),(96,96,96),(112,112,112),(128,128,128),(144,144,144),

 (160,160,160),(180,180,180),(200,200,200),(224,224,224),(252,252,252),

 (0,0,252),(64,0,252),(252,252,252),(124,0,252),(188,0,252),(252,0,252),

 (252,0,188),(252,0,124),(252,0,64),(252,0,0),(252,64,0),(252,124,0),

 (252,188,0),(252,252,0),(188,252,0),(124,252,0),(64,252,0),(0,252,0),

 (0,252,64),(0,252,124),(0,252,188),(0,252,252),(0,188,252),(0,124,252),

 (0,64,252),(124,124,252),(156,124,252),(188,124,252),(220,124,252),

 (252,124,252),(252,124,220),(252,124,188),(252,124,156),(252,124,124),

 (252,156,124),(252,188,124),(252,220,124),(252,252,124),(220,252,124),

 (188,252,124),(156,252,124),(124,252,124),(124,252,156),(124,252,188),

 (124,252,220),(124,252,252),(124,220,252),(124,188,252),(124,156,252),

 (180,180,252),(196,180,252),(216,180,252),(232,180,252),(252,180,252),

 (252,180,232),(252,180,216),(252,180,196),(252,180,180),(252,196,180),

 (252,216,180),(252,232,180),(252,252,180),(232,252,180),(216,252,180),

 (196,252,180),(180,252,180),(180,252,196),(180,252,216),(180,252,232),