Pascal/Turbo Pascal - Umpoco de Pascal

   
Vista:

Umpoco de Pascal

Publicado por ramon (2072 intervenciones) el 11/09/2012 16:16:31
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
{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;
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder

Umpoco de Pascal

Publicado por ramon (2072 intervenciones) el 11/09/2012 16:18:28
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
{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;
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Umpoco de Pascal

Publicado por ramon (2072 intervenciones) el 11/09/2012 16:19:34
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
{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.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Umpoco de Pascal

Publicado por ramon (2072 intervenciones) el 11/09/2012 16:23:52
{Al principio del programa encontrareis una linea como esta.
const
Camino : string = 'c:\tp\fotos12\'; {Camino donde estan las Imagenes}
------------------
Tendréis que cambiarla según vuestras direcciones donde tengáis metidas las imágenes
a visualizar.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar