Pascal/Turbo Pascal - Graficos en Pascal

   
Vista:

Graficos en Pascal

Publicado por ramon (2072 intervenciones) el 09/03/2013 19:20:52
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
(*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*)
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

Graficos en Pascal

Publicado por ramon (2072 intervenciones) el 08/04/2013 19:39:19
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
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
{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]}
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

Graficos en Pascal

Publicado por ramon (2072 intervenciones) el 08/04/2013 19:57:16
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
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
{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}
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

Graficos en Pascal

Publicado por ramon (2072 intervenciones) el 23/04/2013 23:41:13
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
{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),
 (180,252,252),(180,232,252),(180,216,252),(180,196,252),(0,0,112),
 (28,0,112),(56,0,112),(84,0,112),(112,0,112),(112,0,84),(112,0,56),
 (112,0,28),(112,0,0),(112,28,0),(112,56,0),(112,84,0),(112,112,0),
 (84,112,0),(56,112,0),(28,112,0),(0,112,0),(0,112,28),(0,112,56),
 (0,112,84),(0,112,112),(0,84,112),(0,56,112),(0,28,112),(56,56,112),
 (68,56,112),(84,56,112),(96,56,112),(112,56,112),(112,56,96),(112,56,84),
 (112,56,56),(112,68,56),(112,84,56),(112,96,56),(112,112,56),(96,112,56),
 (84,112,56),(68,112,56),(56,112,56),(56,112,68),(112,56,68),(56,112,84),
 (56,112,96),(56,112,112),(56,96,112),(56,84,112),(56,68,112),(80,80,112),
 (88,80,112),(96,80,112),(104,80,112),(112,80,112),(112,80,104),(112,80,96),
 (112,80,88),(112,80,80),(112,88,80),(112,96,80),(112,104,80),(112,112,80),
 (104,112,80),(96,112,80),(88,112,80),(80,112,80),(80,112,88),(80,112,96),
 (80,112,104),(80,112,112),(80,104,112),(80,96,112),(80,88,112),(0,0,64),
 (16,0,64),(32,0,64),(48,0,64),(64,0,64),(64,0,48),(64,0,32),(64,0,16),
 (64,0,0),(64,16,0),(64,32,0),(64,48,0),(64,64,0),(48,64,0),(32,64,0),
 (16,64,0),(0,64,0),(0,64,16),(0,64,32),(0,64,48),(0,64,64),(0,48,64),
 (0,32,64),(0,16,64),(32,32,64),(40,32,64),(48,32,64),(56,32,64),(64,32,64),
 (64,32,56),(64,32,48),(64,32,40),(64,32,32),(64,40,32),(64,48,32),(64,56,32),
 (64,64,32),(56,64,32),(48,64,32),(40,64,32),(32,64,32),(32,64,40),(32,64,48),
 (32,64,56),(32,64,64),(32,56,64),(32,48,64),(32,40,64),(44,44,64),(48,44,64),
 (52,44,64),(60,44,64),(64,44,64),(64,44,60),(64,44,52),(64,44,48),(64,44,44),
 (64,48,44),(64,52,44),(64,60,44),(64,64,44),(60,64,44),(52,64,44),(48,64,44),
 (44,64,44),(44,64,48),(44,64,52),(44,64,60),(44,64,64),(44,60,64),(44,52,64),
 (44,48,64),(255,255,255));
 
   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;
    color256_16 :  palcolores;
    colacti, sal, mouse : boolean;
    cabecera : cabeceravesa;
    infovesa : informacionvesa;
    page, currentblock, temp, BPP : Byte;
    cbank, modo : word;
    regs : registers;
    k, xm, ym, x, y, screeny, screenx : Integer;
    maxx, maxy : word;
    opci, tecla : char;
    colorpixel, jpgszin : bgr;
    esta : boolean;
    tamano : longint;
    modosl : pModoList;
    coll : regcolor;
    colort : byte;
    zonat  : tomazona;
 
  procedure asignacolormatriz(col : integer);
  function bytestring(n : byte) : string;
  function intstring(n : integer) : string;
  function wordstring(n : word) : string;
  function hexstr(val : word; cnt : byte) : string;
  procedure SetPalette(paleta : palcolores; cu : integer);
  procedure informacioncabeceravesa;
  procedure setvideo(mo : word);
  procedure closegraph;
  procedure putpixel12(xp, yp : word;colo : byte);
  function getpixel12(xp, yp : word) : byte;
  procedure putpixel256(xp, yp : word;colo : byte);
  function getpixel256(xp, yp : word) : byte;
  procedure setbanco(xp, yp : Integer);
  procedure getpixel24bit(xx, yy : longint;var coll);
  procedure putpixel24bit(xx, yy : longint; regcol : regcolor);
  procedure ponpixeltodos(xp, yp : word; colo : byte);
  function tomapixeltodos(xt, yt : word) : byte;
  procedure outtextxy(x, y : integer;texto : string);
  procedure ponquitamouse(xm, ym : word; ponquita : boolean);
  function estamouse : boolean;
  function posx_raton : integer;
  function posy_raton : integer;
  procedure pon_posicion_raton(xg, yg : word);
  function boton_raton : word;
  procedure asignacolor(colort : byte);
  procedure lineh(x1, y1, x2 : word;co : byte);
  procedure linev(x1, y1, y2 : word;co : byte);
  procedure boton(xb, yb, xxb, yyb : word; actib : boolean);
  procedure borrazona(xz, yz, xxz, yyz : word);
 
  implementation
 
   procedure asignacolormatriz(col : integer);
   begin
      coll[0] := RojGeeBlu[col][2];
      coll[1] := RojGeeBlu[col][1];
      coll[2] := RojGeeBlu[col][0];
   end;
 
  function bytestring(n : byte) : string;
  var
     s : string[5];
   begin
      str(n,s);
      bytestring := s;
   end;
 
   function intstring(n : integer) : string;
  var
     s : string[5];
   begin
      str(n,s);
      intstring := s;
   end;
 
   function wordstring(n : word) : string;
   var
     s : string[12];
    begin
       str(n,s);
       wordstring := copy(s,1,sizeof(s));
    end;
 
  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;
 
   procedure SetPalette(paleta : palcolores; cu : integer);assembler;
   asm
     les dx,paleta
     mov ax,1012h
     mov bx,0
     mov cx,cu
     int 10h
   end;
 
 procedure informacioncabeceravesa;assembler;
   asm
      mov ax,4f00h
      mov bx,seg cabecera.identif[1]
      mov es,bx
      mov di,offset cabecera.identif
      int 10h
   end;
 
  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;
     colacti := false;
     if modo = $101 then
      begin
         if (maxcolor + 1) <= 256 then
         begin
         for k := 0 to maxcolor do
         begin
         color256_16[k][0] := RojGeeBlu[k][0];
         color256_16[k][1] := RojGeeBlu[k][1];
         color256_16[k][2] := RojGeeBlu[k][2];
         end;
           SetPalette(color256_16,maxcolor + 1);
           colort := maxcolor;
        end
       else
          begin
             for k := 0 to 255 do
             begin
                color256_16[k][0] := RojGeeBlu[k][0];
                color256_16[k][1] := RojGeeBlu[k][1];
                color256_16[k][2] := RojGeeBlu[k][2];
            end;
          end;
         SetPalette(color256_16,255);
         colort := 255;
      end;
      if modo = $12 then
      begin
         for k := 0 to 15 do
             begin
                color256_16[k][0] := RojGeeBlu[k][0];
                color256_16[k][1] := RojGeeBlu[k][1];
                color256_16[k][2] := RojGeeBlu[k][2];
            end;
              SetPalette(color256_16,16);
              colort := 15;
         end;
        if modo = $111 then
        begin
          colort := maxcolor;
          coll[0] := RojGeeBlu[colort,0];
          coll[1] := RojGeeBlu[colort,1];
          coll[2] := RojGeeBlu[colort,2];
        end;
     end;
 
  procedure closegraph;assembler;
  asm
    mov ah,00h
    mov al,03h
    int 10h
  end;
 
 
 
 {en dos partes esta la 1}
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

Graficos en Pascal

Publicado por ramon (2072 intervenciones) el 23/04/2013 23:42:54
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
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
{segunda parte de la unit}
 
 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;
 
 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;
 
   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 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
       asignacolormatriz(colo);
       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;
 
   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 tchar(letra : char; x, y : integer; coltexto : byte);
  type
     zdef = array[0..255,0..7] of byte;
     zptr = ^zdef;
     var
       ch : char;
       i, k, masca : byte;
       const
          fptr : zptr = nil;
    begin
       if modo = $111 then
       begin
          asignacolormatriz(coltexto);
       end;
       if fptr = nil then
       begin
          regs.ah := $11;
          regs.al := $30;
          regs.bh := 3;
          intr($10,regs);
          fptr := ptr(regs.es, regs.bp);
      end;
        for i := 0 to 7 do
        begin
           masca := fptr^[ord(letra),i];
           for k := 0 to 7 do
           begin
               if masca and 128 <> 0 then
               ponpixeltodos(x + k,y + i,coltexto);
               masca := masca shl 1;
            end;
        end;
    end;
 
 procedure outtextxy(x,y : integer;texto : string);
 var
   i : integer;
   coltexto : byte;
  begin
      if maxcolor < 256 then
      coltexto := maxcolor
    else
      coltexto := 255;
      for i := 1 to length(texto) do
      begin
          tchar(texto[i],x,y,coltexto);
          inc(x,8);
      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
            r := coll[2];
            g := coll[1];
            b := coll[0];
            mouse := false;
           if (modo = $101) or (modo = $12) then
           begin
             if modo = $101 then
             begin
             colo := maxcolor;
             col1 := 7;
             end;
             if modo = $12 then
             begin
             colo := 15;
             col1 := 7;
             end;
            end;
             if modo = $111 then
             begin
                coll[0] := RojGeeBlu[maxcolor][2];
                coll[1] := RojGeeBlu[maxcolor][1];
                coll[2] := RojGeeBlu[maxcolor][0];
             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[7,2];
                 coll[1] := RojGeeBlu[7,1];
                 coll[2] := RojGeeBlu[7,0];
                 ponpixeltodos((xm - 1) + mx,(ym - 1) + my,colo);
                 end;
                end;
              end;
              mouse := true;
              coll[0] := r;
              coll[1] := g;
              coll[2] := b;
         end;
 
       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 asignacolor(colort : byte);
   begin
       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;
 
   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 boton(xb, yb, xxb, yyb : word; actib : boolean);
   var
     j, h : word;
     colo1, colo2 : byte;
     r, g, b : byte;
   begin
      if actib = true then
      begin
         if modo = $101 then
         begin
         colo1 := 7;
         if maxcolor <= 255 then
         colo2 := maxcolor
       else
         colo2 := 255;
         end;
         if modo = $12 then
         begin
            colo1 := 7;
            colo2 := 15;
         end;
         if modo = $111 then
         begin
            colo1 := 7;
            colo2 := maxcolor;
         end;
      end
    else
       begin
         if modo = $101 then
         begin
          colo2 := 7;
          if maxcolor <= 255 then
          colo1 := maxcolor
       else
         colo1 := 255;
         end;
          if modo = $12 then
          begin
            colo2 := 7;
            colo1 := 15;
         end;
          if modo = $111 then
          begin
             colo2 := 7;
             colo1 := maxcolor;
          end;
       end;
      if modo = $111 then
     begin
          r := coll[0];
          g := coll[1];
          b := coll[2];
          coll[0] := RojGeeBlu[colo1][2];
          coll[1] := RojGeeBlu[colo1][1];
          coll[2] := RojGeeBlu[colo1][0];
          for h := 0 to 4 do
          begin
          lineh(xb + h, yb + h,xxb - h,colo1);
          linev(xb + h,yb + h,yyb - h,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, yyb - j, xxb - j,colo2);
             linev(xxb - j,yb + j,yyb - j,colo2);
         end;
      end;
      if (modo = $101) or (modo = $12) then
      begin
      for j := 0 to 4 do
      begin
      lineh(xb + j,yb + j,xxb - j,colo1);
      lineh(xb + j, yyb - j,xxb - j,colo2);
      end;
       for h := 0 to 4 do
       begin
          linev(xb + h,yb + h,yyb - h,colo1);
          linev(xxb - h, yb + h,yyb - h,colo2);
       end;
     end;
       if modo = $111 then
       begin
          coll[0] := r;
          coll[1] := g;
          coll[2] := b;
       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;
 
 
   begin
      fillchar(zonat,sizeof(zonat),0);
   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

Graficos en Pascal

Publicado por ramon (2072 intervenciones) el 16/05/2013 16:56:19
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
{Continuamos}
 
 program prumivesa1;
 uses
    crt, dos, mivesa1;
  {Iconos Para el menu Normal mente desde archivos pero como es un
   poco dificil desde aqui los creo para facilitar el ejemplo}
   const
  iconocolor : array[0..15,1..16,1..16] of byte = (
   ((1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2),
    (1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2),
    (1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2),
    (1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2),
    (1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2),
    (1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2),
    (1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2),
    (1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2),
    (3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4),
    (3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4),
    (3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4),
    (3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4),
    (3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4),
    (3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4),
    (3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4),
    (3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4)),
   ((0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,1,1,0,0,0,0,0,0,1,0,0,0),
    (0,0,0,0,1,0,1,0,0,0,0,1,1,0,0,0),
    (0,0,0,0,1,0,0,1,0,0,1,0,1,0,0,0),
    (0,0,0,0,1,0,0,0,1,1,0,0,1,0,0,0),
    (0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0),
    (0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0),
    (0,0,0,1,0,0,0,0,0,0,0,0,1,0,0,0),
    (0,0,1,0,0,0,0,0,0,0,0,0,0,1,0,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (1,1,1,1,1,0,0,0,0,1,1,1,1,1,1,1),
    (0,0,0,0,1,0,0,0,1,0,0,0,0,0,0,0),
    (0,0,0,0,1,0,0,1,0,0,0,0,0,0,0,0),
    (0,0,0,0,1,0,1,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0)),
   ((0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0),
    (1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1),
    (1,0,1,0,1,1,0,1,1,0,1,1,0,1,0,1),
    (1,0,1,0,0,0,0,0,0,0,0,0,0,1,0,1),
    (1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1),
    (1,0,1,0,0,0,0,0,0,0,0,0,0,1,0,1),
    (1,0,1,0,0,0,0,0,0,0,0,0,0,1,0,1),
    (1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1),
    (1,0,1,0,0,0,0,0,0,0,0,0,0,1,0,1),
    (1,0,1,0,0,0,0,0,0,0,0,0,0,1,0,1),
    (1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1),
    (1,0,1,0,0,0,0,0,0,0,0,0,0,1,0,1),
    (1,0,1,0,0,0,0,0,0,0,0,0,0,1,0,1),
    (1,0,0,1,0,1,1,0,1,1,0,1,1,0,0,1),
    (1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1),
    (0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0)),
   ((0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,0),
    (0,0,0,0,0,0,0,0,1,0,0,0,0,0,1,1),
    (0,0,0,0,0,0,0,1,0,0,0,0,0,1,0,1),
    (0,0,0,0,0,0,1,0,0,0,0,0,1,0,0,1),
    (0,0,0,0,0,1,0,0,0,0,0,1,0,0,1,0),
    (0,0,0,0,1,0,0,0,0,0,1,0,0,1,0,0),
    (0,0,0,1,0,0,0,0,0,1,0,0,1,0,0,0),
    (0,0,1,1,1,1,1,1,1,0,0,1,0,0,0,0),
    (0,0,1,0,0,0,0,0,1,0,1,0,0,0,0,0),
    (0,0,1,0,0,0,0,0,1,1,0,0,0,0,0,0),
    (0,0,0,1,1,1,1,1,1,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)),
   ((0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,1,0,0,1,0,0,0,0,0),
    (0,0,0,0,0,0,1,0,0,1,0,1,0,0,0,0),
    (0,2,2,2,2,2,0,0,2,2,1,1,1,0,0,0),
    (2,2,2,0,1,0,0,2,2,1,1,1,1,1,0,0),
    (2,2,2,1,0,0,2,2,1,1,1,1,1,1,1,0),
    (2,2,0,1,1,1,2,1,1,1,1,1,0,0,0,1),
    (2,2,2,0,1,1,1,1,1,1,1,0,0,2,2,1),
    (2,2,2,0,0,1,1,1,1,1,0,2,2,2,1,0),
    (2,2,2,0,0,0,1,1,1,2,2,2,2,1,0,0),
    (2,2,2,0,0,0,0,1,2,2,2,2,1,0,0,0),
    (2,2,2,0,0,0,0,0,1,2,2,1,0,0,0,0),
    (0,2,2,0,0,0,0,0,0,1,1,0,0,0,0,0),
    (0,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,2,0,0,0,0,0,0,0,0,0,0,0,0,0)),
   ((0,0,0,0,0,0,0,0,0,0,0,1,1,1,0,0),
    (0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,0),
    (0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,0),
    (0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,0),
    (0,0,0,0,0,0,1,1,1,1,1,1,1,1,0,0),
    (0,0,0,0,0,0,0,1,1,1,1,1,1,0,0,0),
    (0,0,0,0,0,0,1,0,1,1,1,1,0,0,0,0),
    (0,0,0,0,0,1,0,0,0,1,1,0,0,0,0,0),
    (0,0,0,0,1,0,0,2,1,0,1,0,0,0,0,0),
    (0,0,0,1,0,0,2,1,0,0,0,0,0,0,0,0),
    (0,0,1,0,0,2,1,0,0,0,0,0,0,0,0,0),
    (0,1,0,0,2,1,0,0,0,0,0,0,0,0,0,0),
    (1,0,0,2,1,0,0,0,0,0,0,0,0,0,0,0),
    (1,2,2,1,2,2,2,0,0,0,0,0,0,0,0,0),
    (1,1,1,2,2,2,2,2,0,0,0,0,0,0,0,0),
    (2,2,2,2,2,2,0,0,0,0,0,0,0,0,0,0)),
   ((0,0,0,0,0,1,1,1,1,0,0,0,0,0,0,0),
    (0,0,0,1,1,0,0,1,0,1,1,0,0,0,0,0),
    (0,0,1,0,0,0,1,1,1,1,1,1,0,0,0,0),
    (0,0,1,0,0,0,1,1,1,1,1,1,0,0,0,0),
    (0,1,0,0,0,0,0,1,1,1,1,1,1,0,0,0),
    (0,1,0,0,0,0,0,1,1,1,1,1,1,0,0,0),
    (0,1,0,0,0,0,1,1,1,1,1,1,1,0,0,0),
    (0,1,0,0,0,1,1,1,1,1,1,0,1,0,0,0),
    (0,0,1,0,1,1,1,1,1,1,0,1,0,0,0,0),
    (0,0,1,1,1,1,1,1,1,0,0,1,0,0,0,0),
    (0,0,0,1,1,1,1,1,0,0,1,1,1,0,0,0),
    (0,0,0,0,0,1,1,1,1,0,0,0,1,1,0,0),
    (0,0,0,0,0,0,0,0,0,0,1,0,0,1,1,1),
    (0,0,0,0,0,0,0,0,0,0,0,1,0,0,1,1),
    (0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0)),
   ((0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,0),
    (0,0,0,0,0,0,0,0,0,0,0,1,2,2,2,0),
    (0,0,0,0,0,0,0,0,0,0,0,1,2,0,1,0),
    (0,0,0,0,0,0,0,0,0,0,1,1,2,0,1,0),
    (0,0,0,0,0,0,0,0,0,0,1,0,0,1,0,0),
    (0,0,0,0,0,0,0,0,0,1,0,1,1,1,0,0),
    (0,0,0,0,0,0,0,0,0,1,0,0,1,0,0,0),
    (0,0,0,0,0,0,0,0,1,0,0,1,1,0,0,0),
    (0,0,0,0,0,0,0,0,1,0,2,1,0,0,0,0),
    (0,0,0,0,0,0,0,1,0,0,1,1,0,0,0,0),
    (0,0,0,0,0,0,0,1,1,2,1,0,0,0,0,0),
    (0,0,0,0,0,0,0,1,1,1,1,0,0,0,0,0),
    (0,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)),
   ((0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,1,0,0,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,1,0,0,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,1,0,0,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,1,0,0,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,1,0,0,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,1,0,0,1,0,0,0,0,0,0),
    (0,0,0,0,0,1,0,0,0,0,1,0,0,0,0,0),
    (0,0,0,0,1,0,0,0,0,0,0,1,0,0,0,0),
    (0,0,0,0,1,1,1,1,1,1,1,1,0,0,0,0),
    (0,0,0,0,1,1,1,1,1,1,1,1,0,0,0,0),
    (0,0,0,0,1,0,0,0,0,0,0,1,0,0,0,0),
    (0,0,0,0,1,0,1,0,1,0,0,1,0,0,0,0),
    (0,0,0,0,1,0,1,0,1,0,0,1,0,0,0,0),
    (0,0,0,0,1,0,1,0,1,0,0,1,0,0,0,0),
    (0,0,0,1,1,1,1,1,1,1,1,1,0,0,0,0)),
   ((0,0,3,0,3,0,0,1,0,0,0,0,0,0,0,0),
    (0,3,0,3,0,1,1,1,1,1,1,0,0,0,0,0),
    (3,0,3,0,3,0,1,0,0,0,1,1,0,0,0,0),
    (0,3,0,3,0,0,1,0,0,1,0,0,1,0,0,0),
    (3,0,3,3,0,0,1,0,1,1,0,0,0,1,0,0),
    (0,3,0,0,0,0,1,1,1,0,0,0,0,0,1,0),
    (3,0,3,0,0,0,0,1,3,3,0,0,0,0,0,1),
    (0,3,0,0,0,0,0,0,1,3,3,3,0,0,0,1),
    (3,0,3,0,0,0,0,0,0,1,3,3,3,3,1,0),
    (0,3,0,0,0,0,0,0,0,0,1,2,2,1,0,0),
    (3,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0),
    (0,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)),
   ((0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,1,1,1,1,0,0,0,0,0,0,0),
    (0,0,0,0,1,0,1,1,1,0,0,0,0,0,0,0),
    (0,0,0,0,1,0,1,1,1,1,0,0,0,0,0,0),
    (0,0,0,1,0,0,0,1,1,1,0,0,0,0,0,0),
    (0,0,0,1,0,0,0,1,1,1,1,0,0,0,0,0),
    (0,0,0,1,1,1,1,1,1,1,1,0,0,0,0,0),
    (0,0,1,0,0,0,0,0,1,1,1,1,0,0,0,0),
    (0,0,1,0,0,0,0,0,0,1,1,1,0,0,0,0),
    (1,1,1,1,0,0,0,1,1,1,1,1,1,1,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)),
   ((1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,1,1,0,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,1,1,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,1,1,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)),
   ((0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)),
   ((0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
    (0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0),
    (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)),
   ((1,1,0,0,1,1,1,1,1,1,0,0,1,1,0,0),
    (1,0,1,1,2,2,2,2,2,2,1,1,0,0,1,0),
    (1,0,0,2,2,2,2,2,2,2,2,2,0,0,1,0),
    (1,0,0,2,2,2,2,2,4,4,2,2,0,0,1,0),
    (1,0,0,2,2,2,2,2,4,4,2,2,0,0,1,0),
    (1,0,0,2,2,2,2,2,4,4,2,2,0,0,1,0),
    (1,0,0,0,2,2,2,2,2,2,2,0,0,0,1,0),
    (1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0),
    (1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0),
    (1,1,3,3,3,3,3,3,3,3,3,3,3,1,1,0),
    (1,1,3,3,3,3,3,3,3,3,3,3,3,1,1,0),
    (1,1,3,3,3,3,3,3,3,3,3,3,3,1,1,0),
    (1,1,3,3,3,3,3,3,3,3,3,3,3,1,1,0),
    (1,1,0,0,3,3,3,3,3,3,3,0,0,1,1,0),
    (1,1,0,0,3,3,3,3,3,3,3,0,0,1,1,0),
    (1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0)),
   ((0,4,4,4,4,4,4,4,4,4,4,4,4,4,4,0),
    (0,4,4,4,4,4,4,4,4,4,4,4,4,4,4,0),
    (0,4,4,1,1,1,1,1,1,1,1,2,2,4,4,0),
    (0,4,4,1,1,1,1,1,1,1,2,2,2,4,4,0),
    (0,4,4,1,1,1,1,1,1,2,2,2,2,4,4,0),
    (0,4,4,1,1,1,1,1,2,2,2,2,2,4,4,0),
    (0,4,4,1,1,1,1,2,2,2,2,2,2,4,4,0),
    (0,4,4,1,1,1,2,2,2,2,2,2,2,4,4,0),
    (0,4,4,1,1,1,2,2,2,2,2,2,2,4,4,0),
    (0,4,4,1,1,1,2,2,2,2,2,2,2,4,4,0),
    (0,4,4,1,1,1,2,3,3,2,2,2,2,4,4,0),
    (0,4,4,1,1,1,2,3,3,2,2,2,2,4,4,0),
    (0,4,4,1,1,1,2,2,2,2,2,2,2,4,4,0),
    (0,4,4,1,1,1,2,2,2,2,2,2,2,4,4,0),
    (0,4,4,3,1,1,2,2,2,2,2,2,2,4,4,0),
    (0,4,4,3,3,1,2,2,2,2,2,2,2,4,4,0)));
 
    {variables para el ejemplo}
 var
    tempx, tempy : word;
    color256_16 :  palcolores;
    colort : byte;
    error : integer;
    lony, xaspect, yaspect : word;
    Xasp, Yasp : word;
    salir, colacti : boolean;
    teclado : char;
    inicix, iniciy, finalx, finaly : word;
 
   {Procedimiento para salvar el dibujo como bmp de 24 bit}
   procedure salvabmp(nomb : string;x1, y1, x2, y2 : longint;colorbmp : byte);
   type
        datosbmp = record
           bftype1 : char;
           bftype2 : char;
           bfsize  : longint;
           bfreserved1 : word;
           bfreserved2 : word;
           bfoffbits : longint;
           bisize : longint;
           biwidth : longint;
           biheight : longint;        {Cavecera para el bmp}
           biplanes : word;
           bibitCount : Word;
           bicompression : longint;
           bisizeimage : longint;
           bixpelspermeter : longint;
           biypelspermeter : longint;
           biclrused : longint;
           biclrimportant : longint;
         end;
    Const
        Zero_Array : Array[1..4] Of Byte = (0, 0, 0, 0);   {para el color}
  var
    f : File;
    datos : datosbmp;
    bytes_per_raster : longint;
    raster_pad : integer;
    x, y : longint;               {Variables solo para el procedimiento}
    l : Byte;
    intx, inty : longint;
    col1 : regcolor;
    Begin
        if x1 > x2 then
        begin
           intx := x1;
           x1 := x2;
           x2 := intx;
        end;
       if y1 > y2 then        {Comprobacion de los valores x1 x2 y1 y2 y}
       begin                  { puestos swegun balores de peque¤o a mayor}
          inty := y1;
          y1 := y2;
          y2 := inty;
       end;
       if colorbmp = 24 then
       begin
        red := coll[0];
        blue := coll[1];                 {tomamos colores}
        green := coll[2];
        bytes_per_raster := (X2 - X1 + 1) * 3;  {byte por linea segun x1 y x2}
        if bytes_per_raster mod 4 = 0 then
        raster_pad := 0
      else
        raster_pad := 4 - (bytes_per_raster mod 4) ;
        bytes_per_raster := bytes_per_raster + raster_pad;
               with datos do
                   begin
                        bftype1 := 'B';
                        bftype2 := 'M';
                         bfsize := 0;
                    bfreserved1 := 0;            {ponemos los datos del bmp}
                    bfreserved2 := 0;
                      bfoffbits := sizeof(datos);
                         bisize := 40;
                        biwidth := X2 - X1 + 1;
                       biheight := Y2 - Y1 + 1;
                       biplanes := 1;
                     bibitcount := 24;
                  bicompression := 0;
                    bisizeimage := bytes_per_raster * biheight;
                bixpelspermeter := 0;
                biypelspermeter := 0;
                      biclrused := 0;
                 biclrimportant := 0;
                         bfsize := sizeof(datos) + bisizeimage;
               end;
            end;
            assign(f,nomb);    {creamos archivo y guardamos}
            rewrite(f,1);
            blockwrite(f, datos, sizeof(datos));
            for y := y2 downto y1 do
            begin
                for x := x1 to x2 do
                begin
                   l := tomapixeltodos(X, Y);
                   col1 := coll;
                   blockwrite(f, col1[2], 1);
                   blockwrite(f, col1[1], 1);
                   blockwrite(f, col1[0], 1);
                 end;
                if raster_pad > 0 then
                blockwrite(f, zero_array, raster_pad);
            end;
               close(f);  {cerramos el archivo}
            {forma de llamar a este procedimiento}
            {panxini,panyini,ponfinx,panfiny : word = Zona dibujo
             Uso = salvabmp('Miprue.bmp',panxini,panyini,panfinx,panfiny,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

Graficos en Pascal

Publicado por ramon (2072 intervenciones) el 17/05/2013 11:27:01
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
{sigiente}
 
 procedure asignacolormatriz(col : integer);
   begin
      coll[0] := RojGeeBlu[col][2];
      coll[1] := RojGeeBlu[col][1];    {Asignamos el color a la matriz}
      coll[2] := RojGeeBlu[col][0];
   end;
 
   procedure tchar(letra : char; x, y : integer; coltexto : byte);
  type
     zdef = array[0..255,0..7] of byte;
     zptr = ^zdef;
     var
       ch : char;
       i, k, masca : byte;
       const
          fptr : zptr = nil;
    begin
       if fptr = nil then
       begin
          regs.ah := $11;
          regs.al := $30;           {localizamos caracter y lo escribimos}
          regs.bh := 3;
          intr($10,regs);
          fptr := ptr(regs.es, regs.bp);
      end;
        for i := 0 to 7 do
        begin
           masca := fptr^[ord(letra),i];
           for k := 0 to 7 do
           begin
               if masca and 128 <> 0 then
               ponpixeltodos(x + k,y + i,coltexto);
               masca := masca shl 1;
            end;
        end;
    end;
 
 procedure outtextxy(x,y : integer;coltexto : byte;texto : string);
 var
   i : integer;
  begin
      for i := 1 to length(texto) do
      begin
          tchar(texto[i],x,y,coltexto);  {escribimos un testo masimo 255}
          inc(x,8);                      {caracteres}
      end;
  end;
 
  procedure circulo(xc, yc, radio : integer; color : byte);
   var
     ang : integer;
     x1, y1 : integer;
  begin
     ang := 0;      {dibujamos un circulo de longitud radio}
   repeat
     x1 := round(radio * cos(ang));
     y1 := round(radio * sin(ang));
     ponpixeltodos(x1 + xc, y1 + yc, color);
     inc(ang);
   until ang > 1256;
  end;
 
  procedure rectangulo(rx, ry, rxx, ryy : integer; color : byte);
  var
    hj : integer;
    xg, yg : integer;
  begin
      if rx > rxx then
      begin
         xg := rx;
         rx := rxx;
         rxx := xg;
      end;                    {dibujamos un rectangulo de rx,ry,rxx,ryy}
      if ry > ryy then        {tama¤o}
      begin
          yg := ry;
          ry := ryy;
          ryy := yg;
      end;
      for  hj := rx to rxx do
      begin
        ponpixeltodos(hj,ry,color);
        ponpixeltodos(hj,ryy,color);
      end;
      for hj := ry to ryy do
      begin
        ponpixeltodos(rx,hj,color);
        ponpixeltodos(rxx,hj,color);
      end;
  end;
 
 procedure Linea(x1, y1, x2, y2 : word; color : byte);
  var
     d, dx, dy,
     ai, bi,
     xi, yi : integer;
     intx, inty : word;
  begin
     if x1 > x2 then
     begin
        intx := x1;
        x1 := x2;
        x2 := intx;
     end;
     if y1 > y2 then
     begin
        inty := y1;
        y1 := y2;
        y2 := inty;
     end;
     if (x1 < x2) then
  begin
    xi := 1;
    dx := x2 - x1;
  end                     {Dibujamos una lines}
  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 ponicono(xi, yi : word;nu : integer);
   var
     ii, uu : integer;
     r, g, b : byte;
   begin
      if modo = $111 then
      begin
          r := coll[0];
          g := coll[1];
          b := coll[2];
      end;                           {ponemos uno de los iconos}
      for uu := 1 to 16 do
        for ii := 1 to 16 do
        begin
        if iconocolor[nu,uu,ii] = 1 then
        begin
        if modo = $111 then
        begin
           asignacolormatriz(14);
        end;
        ponpixeltodos(xi + ii,yi + uu,14);
        end;
        if iconocolor[nu,uu,ii] = 2 then
        begin
        if modo = $111 then
        begin
           asignacolormatriz(2);
        end;
        ponpixeltodos(xi + ii,yi + uu,2);
        end;
        if iconocolor[nu,uu,ii] = 3 then
        begin
        if modo = $111 then
        begin
           asignacolormatriz(3);
        end;
        ponpixeltodos(xi + ii,yi + uu,3);
        end;
        if iconocolor[nu,uu,ii] = 4 then
        begin
        if modo = $111 then
        begin
           asignacolormatriz(4);
        end;
        ponpixeltodos(xi + ii,yi + uu,4);
        end;
       end;
        if modo = $111 then
        begin
          coll[0] := r;
          coll[1] := g;
          coll[2] := b;
       end;
   end;
 
   procedure presentacolores;
   var
     sz, sr : word;
     vv, tt, co : integer;
   begin
     vv := 1;
     tt := 49;
     if modo = $12 then
     begin
        for co := 0 to 15 do
        begin
         for sz := 1 to 7 do
          for sr := 1 to 7 do
          ponpixeltodos(8 + (vv + sz),tt + sr,co);
          vv := vv + 8;
          if vv > 48 then
          begin                    {presentamos los colores disponibles}
             vv := 1;              {vasado en el array RojGeeBlu  de nuestra}
             tt := tt + 8;         {unidad}
          end;
           colort := 15;
        end;
     end
   else
     begin
     for co := 0 to maxcolor do
     begin
         if modo = $111 then
         asignacolor(co);
         for sz := 1 to 7 do
          for sr := 1 to 7 do
          ponpixeltodos(8 + (vv + sz),tt + sr,co);
          vv := vv + 8;
          if vv > 48 then
          begin
             vv := 1;
             tt := tt + 8;
          end;
       end;
     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

Graficos en Pascal

Publicado por ramon (2072 intervenciones) el 17/05/2013 12:40:05
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
{mas}
 
procedure menusuperior(fondo : byte);
   var
     z1, z2 : word;
     co, r, g, b : byte;
     mues, colo2 : byte;
     c, j : integer;
   begin
       boton(4,5,maxx - 10,42,true);
       if modo = $111 then
       begin
       r := coll[0];
       g := coll[1];            {presentamos el menu superior}
       b := coll[2];
       co := fondo;
       coll[0] := RojGeeBlu[co][2];
       coll[1] := RojGeeBlu[co][1];
       coll[2] := RojGeeBlu[co][0];
       end
    else
       co := fondo;
       for z2 := 9 to 36 do
       begin
       lineh(9, z2,maxx - 15,co);
       end;
     if modo = $111 then
      begin
         coll[0] := r;
         coll[1] := g;
         coll[2] := b;
      end;
      boton(12,11,37,36,false);
      ponicono(16,15,0);
      boton(41,10,67,36,false);
      ponicono(46,15,1);
      boton(71,10,97,36,false);
      ponicono(76,15,2);
      boton(101,10,127,36,false);
      ponicono(105,17,3);
      boton(131,10,157,36,false);
      ponicono(135,15,4);
      boton(161,10,187,36,false);
      ponicono(166,15,5);
      boton(191,10,217,36,false);
      ponicono(196,15,6);
      boton(221,10,247,36,false);
      ponicono(224,15,7);
      boton(251,10,277,36,false);
      ponicono(256,15,8);
      boton(281,10,307,36,false);
      ponicono(286,17,9);
      boton(311,10,337,36,false);
      ponicono(317,17,10);
      boton(341,10,367,36,false);
      ponicono(346,15,11);
      boton(371,10,397,36,false);
      ponicono(376,15,12);
      boton(401,10,427,36,false);
      ponicono(406,15,13);
      boton(431,10,457,36,false);
      ponicono(436,15,14);
      boton(597,10,623,36,false);
      ponicono(601,14,15);
      boton(5,43,61,maxy - 4,true);
      boton(63,44,maxx - 10,maxy - 4,false);
      boton(68,maxy - 38,maxx - 14,maxy - 8,true);
      if modo = $111 then
      begin
       r := coll[0];
       g := coll[1];
       b := coll[2];
       colo2 := maxcolor;
       coll[0] := RojGeeBlu[colo2][2];
       coll[1] := RojGeeBlu[colo2][1];
       coll[2] := RojGeeBlu[colo2][0];
      end
    else
       begin
          if modo = $12 then
          begin
          colo2 := 15;
          end;
          if modo = $101 then
          begin
             colo2 := maxcolor;
          end;
       end;
        outtextxy(77,maxy - 26,colo2,'Mensajes : ');
        outtextxy(maxx - 164,maxy - 26,colo2,'Tecla ESC Finaliza');
        if modo = $12 then
        mues := 15
      else
        mues := maxcolor;
        outtextxy(467,22,mues,'Color = [      ]');
        for c := 1 to 49 do
          for j := 1 to 5 do
           ponpixeltodos(537 + c,22 + j,mues);
      end;
 
   procedure lapizero;
   var
     xl, yl, xxl, yyl : word;
     xrt, yrt : word;
   begin
 
       delay(160);
       xrt := 300;
       yrt := 100;
       pon_posicion_raton(xrt,yrt);
       ponquitamouse(xrt,yrt,true);
    repeat
        if (xrt <> posx_raton) or (yrt <> posy_raton) then
        begin
           ponquitamouse(xrt,yrt,false);
           xrt := posx_raton;
           yrt := posy_raton;
           ponquitamouse(xrt,yrt,true);
        end;
    until boton_raton = 1;
    xl := xrt;
    yl := yrt;
    xxl := xl;
    yyl := yl;
    ponpixeltodos(xxl,yyl,colort);
   repeat
        if (xrt <> posx_raton) or (yrt <> posy_raton) then
        begin
           ponquitamouse(xrt,yrt,false);
           xrt := posx_raton;
           yrt := posy_raton;
           xl := xrt - 3;
           yl := yrt - 3;
           ponquitamouse(xrt,yrt,true);
        end;
          if boton_raton = 1 then
          begin
          if (xl >= inicix) and (yl >= iniciy) and (xl <= finalx) and
                                                   (yl <= finaly) then
            linea(xxl, yyl, xl, yl,colort);
            xxl := xl;
            yyl := yl;
          end;
   until boton_raton = 2;
 
 
    ponquitamouse(xrt,yrt,false);
   end;
 
   procedure tomadecision(xd, yd : integer);
   var
     j, c : integer;
     tocol : integer;
   begin
  case yd of
  17..33 : begin
   case xd of
   17..33 : begin
               boton(12,11,37,36,true);
               delay(160);
               presentacolores;
               borrazona(100,80,260,90);
               outtextxy(100,80,colort,'Menu Colores');
               boton(12,11,37,36,false);
            end;
   47..63 : begin
                boton(41,11,67,36,true);
                delay(160);
                borrazona(100,80,260,90);
                outtextxy(100,80,colort,'Seleccion de Forma');
                boton(41,11,67,36,false);
            end;
   78..93 : begin                      {Tomamos decisiones segun peticion}
                boton(71,10,97,36,true);
                delay(160);
                borrazona(100,80,260,90);
                outtextxy(100,80,colort,'Seleccion de cuadrado');
                boton(71,10,97,36,false);
            end;
 108..123 : begin
                boton(101,10,127,36,true);
                delay(160);
                borrazona(100,80,260,90);
                outtextxy(100,80,colort,'Borrador');
                boton(101,10,127,36,false);
            end;
 137..153 : begin
                boton(131,10,157,36,true);
                delay(160);
                borrazona(100,80,260,90);
                outtextxy(100,80,colort,'Relleno color');
                boton(131,10,157,36,false);
            end;
  167..183 : begin
                boton(161,10,187,36,true);
                delay(160);
                borrazona(100,80,260,90);
                outtextxy(100,80,colort,'Seleccion color');
                boton(161,10,187,36,false);
            end;
  197..214 : begin
                boton(191,10,217,36,true);
                delay(160);
                borrazona(100,80,260,90);
                outtextxy(100,80,colort,'Ampliacion');
                boton(191,10,217,36,false);
            end;
  227..243 : begin
                boton(221,10,247,36,true);
                delay(160);
                borrazona(100,80,260,90);
                lapizero;
                {outtextxy(100,80,colort,'Lapiz');}
                boton(221,10,247,36,false);
            end;
  257..273 : begin
                boton(251,10,277,36,true);
                delay(160);
                borrazona(100,80,260,90);
                outtextxy(100,80,colort,'Pincel');
                boton(251,10,277,36,false);
            end;
  287..304 : begin
                boton(281,10,307,36,true);
                delay(160);
                borrazona(100,80,260,90);
                outtextxy(100,80,colort,'Aerografo');
                boton(281,10,307,36,false);
            end;
   317..334 : begin
                boton(311,10,337,36,true);
                delay(160);
                borrazona(100,80,260,90);
                outtextxy(100,80,colort,'Texto');
                boton(311,10,337,36,false);
              end;
   347..363 : begin
                 boton(341,10,367,36,true);
                 delay(160);
                 borrazona(100,80,260,90);
                 outtextxy(100,80,colort,'Linea');
                 boton(341,10,367,36,false);
              end;
   377..393 : begin
                 boton(371,10,397,36,true);
                 delay(160);
                 borrazona(100,80,260,90);
                 outtextxy(100,80,colort,'Curva');
                 boton(371,10,397,36,false);
              end;
   407..423 : begin
                 boton(401,10,427,36,true);
                 delay(160);
                 borrazona(100,80,260,90);
                 outtextxy(100,80,colort,'Rectangulo');
                 boton(401,10,427,36,false);
              end;
   436..453 : begin
                 boton(431,10,457,36,true);
                 delay(160);
                 borrazona(100,80,260,90);
                 outtextxy(100,80,colort,'Disco');
                 boton(431,10,457,36,false);
              end;
   604..619 : begin
                boton(598,10,622,36,true);
                delay(160);
                borrazona(100,80,260,90);
                outtextxy(100,80,colort,'Salir');
                boton(598,10,622,36,false);
                salir := true;
              end;
            end;
          end;
        end;
  case xd of
 11..56 : case yd of
          50..472 : begin
                    tocol := tomapixeltodos(xd,yd);
                    if tocol = 0 then
                    colort := colort
                  else
                    colort := tocol;
                    for c := 1 to 49 do
                      for j := 1 to 5 do
                      ponpixeltodos(537 + c,22 + j,colort);
                    end;
              end;
        end;
   end;
 
 
 
   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');  {elegimos el modo video}
      gotoxy(10,8);write(' 0 = Nada Sale');    {que deseamos activar}
      gotoxy(10,10);write('Prueva Grafica');
      repeat
       opci := readkey;
      until opci in[#49,#50,#51,#48,#52];
    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);
      colort := maxcolor;
      inicix := 69;
      iniciy := 50;
      finalx := 625;
      finaly := 443;
      mouse := estamouse;
      setvideo(modo);
      lony := 0;                 {activamos todos los sistemas pora el menu}
      salir := false;            {que es lo que aqui tratamos}
      menusuperior(8);
      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);
          tomadecision(x,y);
                              {aqui se jeneran las decisiones adoctadas}
                              {demomento solo activamos color para ver}
          ponquitamouse(x,y,true); {como funciona la toma de color}
       end;                    {presentando cada menu con el color tomado}
       if keypressed then      {de inicio el blanco}
       teclado := readkey;
       until (teclado = #27) or (salir = true);
       ponquitamouse(x,y,false);
       closegraph;
  end.
 
  {Con esto trato de que vallais conociendo como bamos a trabajer con
   nuesta unidad la cual ira siendo aumentada con nuebos procedimientos
   y funciones como por ejemplo la escritura de texto o la carga y
   salvado se nuestros dibujos en formato bmp de momento despues en
   otros formatos espero mejoreis el munu realizando otros con otras
   figuras y formas todo a buestra imajinacion, encada opcion del
   menu se ejecutara un proceso en este caso ire ejecutando los que
   tengo marcados para irnos aclarando con cada caso, os comento que los
   procedimientos o funciones deven de estar colocadod antes del
   procedimiento tomadecision para poder ejecutarlos suerte}
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

Graficos en Pascal

Publicado por ramon (2072 intervenciones) el 10/07/2013 21:52: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
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
{En esta pasamos al texto gráfico}
 
{Se pude ejecutar en directo para probarlo luego añadirlo al anterior y
 ejecutarlo en el menu poniendo cada cosa en su lugar correspondiente.
 Fijaros en los archivos de los fuentes de letras}
 
 program leras;
 uses
   crt, dos, mivesa1;
 
  const
    maxfonts = 16;
    maxchars = 255;
    horizdir = 0;
    vertdir = 1;
 
    linepatterns : array[0..15] of boolean =
     (true,true,true,true,true,true,true,true,
      true,true,true,true,true,true,true,true);
 
     solidln = 0;
     dottedln = 1;
     centedln = 2;
     dashedln = 3;
     userbidln = 4;
     normwidth = 1;
     thickwidth = 3;
     prefix_size = $80;
     bgipath : string = 'c:\tp\bgi\'; {Modificar al camino al buestro}
     signature = '+';
 
 
  type
    opcodes = (finchar, nada, mover, dibuja);
    tfheader = record
            header_size : word;
            font_name   : array[1..4] of char;
            font_size   : word;
            font_major  : byte;
            font_minor  : byte;
            min_major   : byte;
            min_minor   : byte;
        end;
 
      theader =  record
           Signature   : char;
           Nr_chars    : integer;
           Reserved    : byte;
           First_char  : byte;
           cdefs       : integer;
           scan_flag   : byte;
           org_to_cap  : shortint;
           org_to_base : shortint;
           org_to_dec  : shortint;
           _reserved   : array[1..4] of char;
           Unused      : byte;
        end;
      tcharsettranstable = array[char] of char;
      pcharsettranstable = ^tcharsettranstable;
      toffsettable = array[0..maxchars] of integer;
      twidthtable  = array[0..maxchars] of byte;
      tbitmapchar = array[0..7,0..7] of byte;
 
      tfontrec = record
             name        : string[8];
             header      : THeader;
             pheader     : TFHeader;
             offsets     : TOffsetTable;
             widths      : TWidthTable;
             instrlength : longint;
             instr       : pchar;
           end;
 
   tstroke = record
              opcode : byte;
              x      : integer;
              y      : integer;
      end;
 
     tstrokes = array[0..1000] of tstroke;
 
     textsettingstype = record
             font      : word;
             direction : word;
             charsize  : word;
             horiz     : word;
             vert      : word;
           end;
 
     linesettingstype = record
             linestyle : word;
             pattern : word;
             thickness : word;
           end;
 
   const
      graphstringtranstable: pcharsettranstable = nil;
 
   var
    installedfonts : longint;
    fonts : array[1..maxfonts] of tfontrec;
    strokes : tstrokes;
    regs : registers;
    currenttextinfo : textsettingstype;
    currentxratio, currentyratio : real;
    currentwritemode : integer;
    defaultfontdata: array[#0..#255] of tbitmapchar;
    currentcolor : word;
    lineInfo : linesettingstype;
    currentx, currenty : integer;
    x, y : integer;
    yoffset : word;
    modoorijen : integer;
 
   procedure linea_color(x1, y1, x2, y2 : integer; color : byte);
   var
     i1, longx, longy, nunpixeles, decision,inc_decis1, inc_decis2,
     x3, incx1, incx2, y3, incy1, incy2 : integer;
  begin
     longx := abs(x2 - x1);
     longy := abs(y2 - y1);
     if longx >= longy then
     begin
         nunpixeles := longx + 1;
         decision := (2 * longy) - longx;
         inc_decis1 := (longy - longx) shl 1;
         inc_decis2 := longy shl 1;
         incx1 := 1;
         incx2 := 1;
         incy1 := 1;
         incy2 := 0;
     end
  else
     begin
         nunpixeles := longy + 1;
         decision := (2 * longx) - longy;
         inc_decis1 := (longx - longy) shl 1;
         inc_decis2 := longx shl 1;
         incx1 := 1;
         incx2 := 0;
         incy1 := 1;
         incy2 := 1;
      end;
   if x1 > x2 then
   begin
       incx1 := - incx1;
       incx2 := - incx2;
   end;
   if y1 > y2 then
   begin
      incy1 := - incy1;
      incy2 := - incy2;
  end;
  x3 := x1;
  y3 := y1;
  for i1 := 1 to nunpixeles do
  begin
      ponpixeltodos(x3,y3,color);
      if decision >= 0 then
      begin
         decision := decision + inc_decis1;
         x3 := x3 + incx1;
         y3 := y3 + incy1;
     end
  else
     begin
        decision := decision + inc_decis2;
         x3 := x3 + incx2;
         y3 := y3 + incy2;
      end;
    end;
  end;
 
  procedure asignacolormatriz(col : integer);
   begin
      coll[0] := rojgeeblu[col][2];
      coll[1] := rojgeeblu[col][1];
      coll[2] := rojgeeblu[col][0];
   end;
 
 procedure cursor(xx, yy : word; cc : char);
 var
    c, s : integer;
    colos : byte;
 begin
     if cc = 'e' then
     colos := 15
   else
     colos := 0;
    if modo = $111 then
    begin
       if cc = 'e' then
       asignacolormatriz(colos)
     else
       asignacolormatriz(colos);
    end;
     for c := 1 to 8 do
       for s := 1 to 8 do
       ponpixeltodos(xx + s,yy + c,colos);
 end;
 
  procedure rectangulo(rx, ry, rxx, ryy : integer; color : byte);
  var
    hj : integer;
    xg, yg : integer;
  begin
      if rx > rxx then
      begin
         xg := rx;
         rx := rxx;
         rxx := xg;
      end;
      if ry > ryy then
      begin
          yg := ry;
          ry := ryy;
          ryy := yg;
      end;
      for  hj := rx to rxx do
      begin
        ponpixeltodos(hj,ry,color);
        ponpixeltodos(hj,ryy,color);
      end;
      for hj := ry to ryy do
      begin
        ponpixeltodos(rx,hj,color);
        ponpixeltodos(rxx,hj,color);
      end;
  end;
 
  procedure outtext_char;
  type
     zdef = array[0..255,0..7] of byte;
     zptr = ^zdef;
     var
       ch : char;
       leta : integer;
       i, k, masca : byte;
       colfondo : byte;
       const
          fptr : zptr = nil;
    begin
       colfondo := 255;
       for leta := 0 to 255 do
       begin
       if fptr = nil then
       begin
          regs.ah := $11;
          regs.al := $30;
          regs.bh := 3;
          intr($10,regs);
          fptr := ptr(regs.es, regs.bp);
      end;
      asignacolor(colort);
      if colfondo = 255 then
      for i := 0 to 7 do
      begin
          masca := fptr^[ord(chr(leta)),i];
          for k := 0 to 7 do
          begin
              if masca and 128 <> 0 then
              defaultfontdata[chr(leta),i,k] := 1;
              masca := masca shl 1;
           end;
        end
     else
        for i := 0 to 7 do
        begin
           masca := fptr^[ord(chr(leta)),i];
           for k := 0 to 7 do
           begin
               if masca and 128 <> 0 then
               defaultfontdata[chr(leta),i,k] := 1
            else
               defaultfontdata[chr(leta),i,k] := 0;
               masca := masca shl 1;
            end;
          end;
        end;
    end;
 
 procedure getlinesettings(var activelineInfo : linesettingstype);
 begin
    activelineinfo := lineinfo;
 end;
 
  procedure setlinestyle(linestyle : word; pattern : word; thickness : word);
   var
    i: byte;
    j: byte;
    fallo : boolean;
   begin
    if (linestyle > 4) or ((thickness <> 1) and (thickness <> 3)) then
      fallo := true
    else
      begin
       lineinfo.thickness := thickness;
       lineinfo.linestyle := linestyle;
       case linestyle of
            4 : lineinfo.pattern := pattern;
            0 : lineinfo.pattern := $ffff;
            3 : lineinfo.pattern := $F8F8;
            1 : lineinfo.pattern := $CCCC;
            2 : lineinfo.pattern := $FC78;
       end;
       j := 16;
       for i := 0 to 15 do
        begin
         dec(j);
         if (word($01 shl i) AND lineinfo.pattern) <> 0 then
            linepatterns[j] := true
         else
            linepatterns[j] := false;
        end;
      end;
   end;
 
  procedure setlength(s : string; len : longint);
   begin
       if len > 255 then
       len := 255;
       s[0] := chr(len);
   end;
 
  function convertstring(const origstring : string) : string;
  var
    i : Integer;
    convresult : string;
 begin
    if graphstringtranstable = nil then
    convertstring := origstring
  else
    begin
    setlength(convresult, length(origstring));
    for i := 1 to length(origstring) do
      convresult[i] := graphstringtranstable^[origstring[i]];
      convertstring := copy(convresult,1,length(origstring));
  end;
 end;
 
  function testfont(p : pchar) : boolean;
  begin
   testfont := (p[0] = 'P') and (p[1] = 'K') and (p[2] = #8) and (p[3] = #8);
  end;
 
  function installuserfont(const fontfilename : string) : integer;
  begin
     if installedfonts = maxfonts then
     begin
       Installuserfont := 0;
       exit;
     end;
         inc(installedfonts);
         fonts[installedfonts].name := fontfilename;
         fonts[installedfonts].instr := nil;
         fonts[installedfonts].instrlength := 0;
         installuserfont := installedfonts;
      end;
 
   procedure gettextsettings(var textinfo : textsettingstype);
   begin
      textinfo := currenttextinfo;
   end;
 
  function textheight(const textstring : string) : word;
   begin
    if currenttextinfo.font = 0 then
       textheight := 8 * currenttextinfo.charsize
    else
      textheight := trunc((fonts[currenttextinfo.font].header.org_to_cap -
      fonts[currenttextinfo.font].header.org_to_dec) * currentyratio);
      end;
 
    function textwidth(const textstring : string) : word;
    var
      i, x : integer;
      c : byte;
      s : String;
      begin
         x := 0;
         if currenttextinfo.font = 0 then
         textwidth := length(textstring) * 8 * currenttextinfo.charsize
       else
         begin
	   s := convertstring(textstring);
           for i := 1 to length(s) do
           begin
             c := byte(s[i]);
             if (c - fonts[currenttextinfo.font].header.first_char >=
                     fonts[currenttextinfo.font].header.nr_chars) then
             continue;
             x := x + byte(fonts[currenttextinfo.font].widths[c]);
           end;
             textwidth := round(x * currentxratio) ;
         end;
      end;
 
  function decode(by1, by2 : char; var x, y : integer) : integer;
      var
       b1, b2 : shortint;
     Begin
       b1 := shortint(by1);
       b2 := shortint(by2);
       decode := integer(((b1 and $80) shr 6) + ((b2 and $80) shr 7));
 {$R-}
       b1 := b1 and $7f;
       b2 := b2 and $7f;
       if (b1 and $40) <> 0 then
       b1 := b1 or $80;
       if (b2 and $40) <> 0 then
       b2 := b2 or $80;
       x := integer(b1);
       y := integer(b2);
 {$R+}
   end;
 
  function unpack(buf : pchar; index : integer;
                   var stroke : tstrokes): integer;
  var
    po : tstrokes;
    num_ops : integer;
    opcode, i, opc : word;
    counter : integer;
    lindex : integer;
    jx, jy : integer;
  begin
     num_ops := 0;
     counter := index;
     lindex := 0;
  while true do
  begin
    Inc(num_ops);
    opcode := decode( buf[counter], buf[counter + 1] ,jx, jy );
    inc(counter,2);
    if (opcode = ord(finchar) ) then
    break;
  end;
     counter := index;
     for i := 0 to num_ops - 1 do
      Begin
        opc := decode(buf[counter], buf[counter + 1], po[lindex].x,
                                                      po[lindex].y);
        inc(counter,2);
        po[lindex].opcode := opc;
        Inc(lindex);
      end;
       stroke := po;
       unpack := num_ops;
     end;
 
 procedure gettextposition(var xpos,ypos : integer; const textstring : string);
 begin
    if currenttextinfo.font = 0 then
      begin
       if currenttextinfo.direction = horizdir then
       begin
        case currenttextinfo.horiz of
       1 : xpos := (textwidth(textstring) shr 1);
       0 : xpos := 0;
       2 : xpos := textwidth(textstring);
       end;
         case currenttextinfo.vert of
       1 : ypos := - (textheight(textstring) shr 1);
       0 : ypos := - textheight(textstring);
       2 : ypos := 0;
        end;
       end
     else
        begin
         case currenttextinfo.horiz of
     1 : xpos := (textheight(textstring) shr 1);
     0 : xpos := textheight(textstring);
     2 : xpos := textheight(textstring);
        end;
        case currenttextinfo.vert of
     1 : ypos := (textwidth(textstring) shr 1);
     0 : ypos := 0;
     2 : ypos := textwidth(textstring);
        end;
      end;
     end
  else
     begin
       if currenttextinfo.direction = horizdir then
       begin
         case currenttextinfo.horiz of
     1 : xpos := (textwidth(textstring) shr 1);
     0 : xpos := 0;
     2 : xpos := textwidth(textstring);
        end;
        case currenttextinfo.vert of
     1 : ypos := (textheight(textstring) shr 1);
     0 : ypos := 0;
     2 : ypos := textheight(textstring);
        end;
     end
  else
       begin
         case currenttextinfo.horiz of
     1 : xpos := (textheight(textstring) shr 1);
     0 : xpos := 0;
     2 : xpos := textheight(textstring);
         end;
         case currenttextinfo.vert of
     1 : ypos := (textwidth(textstring) shr 1);
     0 : ypos := 0;
     2 : ypos := textwidth(textstring);
         end;
     end;
   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

Graficos en Pascal

Publicado por ramon (2072 intervenciones) el 11/07/2013 21:38:56
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
{Parte 2}
 
 procedure outtextxy(x, y : integer; textstring : string);
  type
   tpoint = record
      x, y : integer;
    end;
 var
   xpos, ypos : integer;
   convstring : string;
   i, j, k, c : longint;
   counter    : longint;
   cnt1, cnt2 : integer;
   cnt3, cnt4 : integer;
   charsize   : integer;
   writemode  : word;
   curx2, cury2, xpos2, ypos2, x2, y2 : real;
   oldvalues : linesettingstype;
   fontbitmap : tbitmapchar;
         chr : char;
   curx2i, cury2i, xpos2i, ypos2i : longint;
 begin
    asignacolor(15);
    currentcolor := 15;
    writemode := currentwritemode;
    currentwritemode := 0;
    gettextposition(xpos, ypos, textstring);
    x := x - xpos;
    y := y + ypos;
    xpos := x;
    ypos := y;
    convstring := convertstring(textstring);
    charsize := currenttextinfo.charsize;
  if currenttextinfo.font = 0 then
   begin
     c := length(convstring);
     if currenttextinfo.direction = 0 then
     begin
       for i := 0 to c - 1 do
       begin
         xpos := x + (i * 8) * charsize;
         fontbitmap := tbitmapchar(defaultfontdata[convstring[i + 1]]);
         if charsize = 1 then
         Begin
           for j := 0 to 7 do
            for k := 0 to 7 do
            if fontbitmap[j,k] <> 0 then
            ponpixeltodos(xpos + k, j + y, currentcolor);
         end
      else
         Begin
           j := 0;
           cnt3 := 0;
           while j <= 7 do
            begin
              for cnt4 := 0 to charsize - 1 do
               begin
                 k := 0;
                 cnt2 := 0;
            while k <= 7  do
             begin
               for cnt1 := 0 to charsize - 1 do
                begin
                 If fontbitmap[j,k] <> 0 then
             ponpixeltodos(xpos + cnt1 + cnt2, y + cnt3 + cnt4, currentcolor);
              end;
                inc(k);
                inc(cnt2,charsize);
            end;
         end;
            inc(j);
            inc(cnt3,charsize);
        end;
      end;
    end;
   end
 else
    begin
      for i := 0 to c - 1 do
       begin
         chr := convstring[i + 1];
         fontbitmap := tbitmapchar(defaultfontdata[chr]);
         ypos := y - (i shl 3) * charsize;
         if charsize = 1 then
         Begin
           for j := 0 to 7 do
            for k := 0 to 7 do
            if fontbitmap[j,k] <> 0 then
            ponpixeltodos(xpos + j, ypos - k, currentcolor);
         end
       else
         Begin
           j := 0;
           cnt3 := 0;
       while j <= 7 do
        begin
           for cnt4 := 0 to charsize - 1 do
            begin
              k := 0;
              cnt2 := 0;
           while k <= 7  do
             begin
               for cnt1 := 0 to charsize - 1 do
                begin
                  if fontbitmap[j,k] <> 0 then
         ponpixeltodos(xpos + cnt3 - cnt4, ypos + cnt1 - cnt2, currentcolor);
       end;
         inc(k);
         inc(cnt2,charsize);
     end;
  end;
      inc(j);
      inc(cnt3,charsize);
      end;
     end;
    end;
   end;
  end
 else
     begin
        getlinesettings(oldvalues);
        setlinestyle(solidln, oldvalues.pattern, normwidth);
     if Currenttextinfo.direction = vertdir then
       xpos := xpos + textheight(convstring);
       curx2 := xpos;
       xpos2 := curx2;
       x2 := xpos2;
       cury2 := ypos;
       ypos2 := cury2;
       y2 := ypos2;
     for i:=1 to length(convstring) do
      begin
         c := byte(convstring[i]);
         unpack(fonts[currenttextinfo.font].instr,
                fonts[currenttextinfo.font].offsets[c], strokes );
         counter := 0;
         while true do
         begin
         if currenttextinfo.direction = 1 then
         begin
           xpos2 := x2 - (strokes[counter].y * currentyratio);
           ypos2 := y2 - (strokes[counter].x * currentxratio);
         end
      else
        begin
          xpos2 := x2 + (strokes[counter].x * currentxratio) ;
          ypos2 := y2 - (strokes[counter].y * currentyratio) ;
        end;
      case opcodes(strokes[counter].opcode) of
  finchar : break;
     nada : begin
      end;
     mover : begin
             curx2 := xpos2;
             cury2 := ypos2;
             end;
     dibuja : begin
             curx2i := trunc(curx2);
             cury2i := trunc(cury2);
             xpos2i := trunc(xpos2);
             ypos2i := trunc(ypos2);
             Linea_color(curx2i, cury2i, xpos2i, ypos2i,currentcolor);
             curx2 := xpos2;
             cury2 := ypos2;
             end;
         else
            begin
            end;
         end;
           inc(counter);
         end;
         if currenttextinfo.direction = 1 then
          y2 := y2 - (byte(fonts[currenttextInfo.font].widths[c]) *
                                                   currentxratio)
     else
         x2 := x2 + (byte(fonts[currenttextinfo.font].widths[c]) *
                                                    currentxratio);
     end;
       setlinestyle(oldvalues.linestyle, oldvalues.pattern,
                                       oldvalues.thickness);
      end;
        currentwritemode := writemode;
    end;
 
  procedure outtext(textstring : string);
  var
    x, y : integer;
    begin
       x := currentx;
       y := currenty;
       outtextxy(currentx, currenty, textstring);
       if (currenttextinfo.direction = 0) and
           (currenttextinfo.horiz = 0) then
       inc(x,textwidth(textstring));
         currentx := x;
         currenty := y;
     end;
 
    procedure settextjustify(horiz, vert : word);
    begin
      if (horiz < 0) or (horiz > 2) or
            (vert < 0) or (vert > 2) then
      begin
         exit;
      end;
         currenttextinfo.horiz := horiz;
         currenttextinfo.vert := vert;
     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

Graficos en Pascal

Publicado por ramon (2072 intervenciones) el 11/07/2013 21:48:59
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
{Parte 3}
 
procedure settextstyle(font,direction : word; charsize : word);
    var
      f1 : file;
      prefix : array[0..prefix_size - 1] of char;
      length, current : longint;
      fontdata : pchar;
      hp : pchar;
       i : longint;
    begin
    case font of
  0 : ;
  1 : installuserfont('trip');
  2 : installuserfont('litt');
  3 : installuserfont('sans');
  4 : installuserfont('goth');
  5 : installuserfont('scri');
  6 : installuserfont('simp');
  7 : installuserfont('tscr');
  8 : installuserfont('lcom');
  9 : installuserfont('euro');
 10 : installuserfont('bold');
   end;
    if font > installedfonts then
    begin
       exit;
    end;
      currenttextinfo.font := font;
      if (direction <> 0) and (direction <> 1) then
      direction := 0;
      currenttextinfo.direction := direction;
      if (currenttextinfo.Font = 0) and (charsize > 10) then
      currenttextinfo.charsize := 10
   else
     if charsize < 1 then
     currenttextinfo.charsize := 1
   else
      currenttextinfo.charsize := charsize;
      if (charsize <> 0) then
      case charsize of
   1 : begin
        currentxratio := 0.55;
        currentyratio := 0.55;
       end;
   2 : begin
        currentxratio := 0.65;
        currentyratio := 0.65;
       end;
   3 : begin
         currentxratio := 0.75;
         currentyratio := 0.75;
       end;
   4 : begin
         currentxratio := 1.0;
         currentyratio := 1.0;
       end;
   5 : begin
         currentxratio := 1.3;
         currentyratio := 1.3;
       end;
   6 : begin
         currentxratio := 1.65;
         currentyratio := 1.65
       end;
   7 : begin
         currentxratio := 2.0;
         currentyratio := 2.0;
       end;
   8 : Begin
         currentxratio := 2.5;
         currentyratio := 2.5;
       end;
   9 : Begin
         currentxratio := 3.0;
         currentyratio := 3.0;
       end;
   10 : begin
          currentxratio := 4.0;
          currentyratio := 4.0;
        end
      end;
   if (font > 0) and not assigned(fonts[font].instr) then
   begin
     assign(f1,bgipath + fonts[font].name + '.chr');
 {$i-} reset(f1,1); {$i+}
     if ioresult <> 0 then
     begin
        currenttextinfo.font := 0;
        exit;
     end;
        blockread(f1, Prefix, Prefix_Size);
        hp := prefix;
        i := 0;
        while (hp[i] <> chr($1a)) do
        inc(i);
        move(hp[i + 1],fonts[font].pheader,sizeof(tfheader));
           BlockRead(f1,fonts[font].header,sizeof(theader));
           BlockRead(f1,fonts[font].offsets[fonts[font].header.first_char],
                     fonts[font].header.nr_chars * sizeof(integer));
           blockread(f1,fonts[font].widths[fonts[font].header.first_char],
                             fonts[font].header.nr_chars * sizeof(byte));
           current := filepos(f1);
           seek(f1, filesize(f1));
           length := filepos(f1);
           seek(f1, current);
           getmem(fontdata, length + 1);
           blockread(f1, fontdata^, length - current);
           fontdata[length - current + 1] := #0;
       if fonts[font].header.signature <> signature then
         begin
            currenttextinfo.font := 0;
            freemem(fontdata, length + 1);
            exit;
          end;
             fonts[font].instr := fontdata;
             fonts[font].instrlength := length + 1;
         if not testfont(prefix) then
          begin
             currenttextinfo.font := 0;
             freemem(fontdata, length + 1);
             end;
              close(f1);
           end;
      end;
 
   procedure inicio;
   begin
      installedfonts := 0;
      maxx := infovesa.tamx;
      maxy := infovesa.tamy;
      currentx := 0;
      currenty := 0;
      yoffset := 0;
      installuserfont('Trip');
      installuserfont('Litt');
      installuserfont('Sans');
      installuserfont('Goth');
      installuserfont('Scri');
      installuserfont('Simp');
      installuserfont('Tscr');
      installuserfont('Lcom');
      installuserfont('Euro');
      installuserfont('Bold');
      settextjustify(0,1);
      outtext_char;
   end;
 
   procedure cursorborra(xc, yc : word; pres : boolean);
   var
     c1, c2 : integer;
     colo : byte;
    begin
        if pres = true then
        colo := 15
      else
        colo := 0;
        if modo = $111 then
         asignacolor(colo);
        for c1 := 1 to 8 do
         for c2 := 1 to 4 do
         ponpixeltodos(xc + c1,yc + c2,colo);
    end;
 
   procedure escrivetexto(xw, yw : word; cual, tam, dir : integer);
   var
     xt, yt : word;
     eltexto : string[164];
     td : char;
     ik : integer;
     z1, z2, salto, lon : integer;
   begin
   case tam of
 0 : begin lon := (620 - 72) div 8; salto := 10; end;
 1 : begin lon := (620 - 72) div 8; salto := 10; end;
 2 : begin lon := (620 - 72) div 16; salto := 18; end;
 3 : begin lon := (620 - 72) div 24; salto := 26; end;
 4 : begin lon := (620 - 72) div 32; salto := 34; end;
   end;
   if modo = $111 then
    asignacolor(15);
      rectangulo(72,54,622,70,15);
      rectangulo(73,55,621,69,15);
      rectangulo(74,56,620,68,15);
      outtextxy(78,62,'Texto : ');
      ik := 1;
      xt := 150;
      yt := 62;
      SetTextStyle(0, 0, 0);
      cursorborra(xt + (ik - 1) * 8,yt,true);
    repeat
         td := readkey;
         if td in[#32..#126,#164,#165] then
         begin
            cursorborra(xt + (ik - 1) * 8,yt,false);
            eltexto[ik] := td;
            eltexto[0] := chr(ik);
            outtextxy(xt + (ik - 1) * 8,yt,eltexto[ik]);
            ik := ik + 1;
            if ik > lon then
            ik := lon;
            cursorborra(xt + (ik - 1) * 8,yt,true);
         end;
          if td = #8 then
          begin
             cursorborra(xt + (ik - 1) * 8,yt,false);
             ik := ik - 1;
             if ik < 1 then
             ik := 1;
             eltexto[ik] := ' ';
             eltexto[0] := chr(ik);
             for z1 := 1 to 8 do
              for z2 := 1 to 8 do
              ponpixeltodos(xt + ((ik - 1) * 8) - 1 + z2,(yt - 4) + z1,0);
              cursorborra(xt + (ik - 1) * 8,yt,true);
          end;
    until td = #13;
      cursorborra(xt + (ik - 1) * 8,yt,false);
      for z2 := 53 to 71 do
       for z1 := 72 to 623 do
        ponpixeltodos(z1,z2,0);
      inicio;
      SetTextStyle(cual, dir, tam);
      outtextxy(xw,yw,eltexto);
      SetTextStyle(0, 0, 0);
   end;
 
   procedure pontexto(xc, yc : word);
   var
   ki, ti, pox, poy, curx, cury : word;
   tienex, tieney : word;
   let : char;
   lt, tm, di : integer;
   begin
      lt := 0;
      tm := 0;
      di := 0;
      rectangulo(72,54,622,70,15);
      rectangulo(73,55,621,69,15);
      rectangulo(74,56,620,68,15);
      colort := 15;
      if modo = $111 then
       asignacolor(colort);
      inicio;
      outtextxy((620 - 74) div 2 - 20,62,'Elija Tipo De Letra');
      rectangulo(72,72,178,178,15);
      rectangulo(73,73,177,177,15);
      rectangulo(74,74,176,176,15);
       outtextxy(78,80,'1 = trip');
       outtextxy(78,90,'2 = litt');
      outtextxy(78,100,'3 = sans');
      outtextxy(78,110,'4 = goth');
      outtextxy(78,120,'5 = scri');
      outtextxy(78,130,'6 = simp');
      outtextxy(78,140,'7 = tscr');
      outtextxy(78,150,'8 = lcom');
      outtextxy(78,160,'9 = euro');
      outtextxy(78,170,'0 = mormal');
     repeat
      let := readkey;
    until let in['0','1','2','3','4','5','6','7','8','9'];
    case let of
  '0' : lt := 0;
  '1' : lt := 1;
  '2' : lt := 2;
  '3' : lt := 3;
  '4' : lt := 4;
  '5' : lt := 5;
  '6' : lt := 6;
  '7' : lt := 7;
  '8' : lt := 8;
  '9' : lt := 9;
    end;
   if modo = $111 then
       asignacolor(0);
   for ki := 58 to 67 do
    for ti := (620 - 74) div 2 - 20 to ((620 - 74) div 2 - 20) + 240 do
    ponpixeltodos(ti,ki,0);
   outtextxy((620 - 74) div 2 - 20,62,'Elija Tama¤o De Letra');
   rectangulo(190,72,363,88,15);
   rectangulo(191,73,362,87,15);
   rectangulo(192,74,361,86,15);
   outtextxy(199,81,'0 / 1 / 2 / 3 / 4');
   repeat
      let := readkey;
   until let in['0','1','2','3','4'];
   case let of
 '0' : tm := 0;
 '1' : tm := 1;
 '2' : tm := 2;
 '3' : tm := 3;
 '4' : tm := 4;
   end;
   if modo = $111 then
   asignacolor(0);
   for ki := 58 to 67 do
    for ti := (620 - 74) div 2 - 20 to ((620 - 74) div 2 - 20) + 240 do
    ponpixeltodos(ti,ki,0);
    outtextxy((620 - 74) div 2 - 20,62,'Elija Orientacion De Letra');
   rectangulo(400,72,543,110,15);
   rectangulo(401,73,542,109,15);
   rectangulo(402,74,541,108,15);
   outtextxy(407,81,'0 = Normal');
   outtextxy(407,91,'1 = horizontal');
   outtextxy(407,101,'2 = vertical');
   repeat
   let := readkey;
   until let in['0','1','2'];
   case let of
 '0' : di := 0;
 '1' : di := 0;
 '2' : di := 1;
   end;
   if modo = $111 then
   asignacolor(0);
   for ki := 53 to 179 do
     for ti := 70 to 623 do
     ponpixeltodos(ti,ki,0);
   outtextxy(140,maxy - 23,'Posicione El Mouse Para El Texto');
      curx := xc;
      cury := yc;
      tienex := maxx - 1;
      tieney := maxy - 1;
      ventana_raton(70,53,624,441);
      pon_posicion_raton(300,100);
      pox := posx_raton;
      poy := posy_raton;
      ponquitamouse(pox,poy,true);
    repeat
       if (pox <> posx_raton) or (poy <> posy_raton) then
       begin
          ponquitamouse(pox,poy,false);
          pox := posx_raton;
          poy := posy_raton;
          ponquitamouse(pox,poy,true);
       end;
    until boton_raton = 1;
    delay(160);
    ponquitamouse(pox,poy,false);
    if modo = $111 then
     asignacolor(0);
    for ki := maxy - 28 to maxy - 14 do
     for ti := 139 to 460 do
     ponpixeltodos(ti,ki,0);
    escrivetexto(pox,poy,lt,tm,di);
    ventana_raton(1,1,maxx - 1,maxy - 1);
   end;
 
   procedure enelmenutexto;
   begin
      SetTextStyle(0, 0, 1);
      pontexto(40,10);
   end;
 
      begin
      modoorijen := lastmode;
      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,#52];
    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);
      if modo = $12 then
      colort := 15;
      if modo = $101 then
      colort := 15;
      if modo = $111 then
      begin
      asignacolor(15);
      end;
      setvideo(modo);
      enelmenutexto;
 
      readkey;
      closegraph;
      textmode(modoorijen);
  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