Pascal/Turbo Pascal - Compilador de pascal 7.7

   
Vista:

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 18/02/2012 23:58:30
Hola colegas, quiero aprender a programar en pascal me gusta porque es un lenguaje potente a pesar del tiempo que tiene. y tambien quiero conseguir la version 7.7 de este compilador ya que no he logrado conseguirla completa.

Si me pueden ayudar con manuales, paginas webs, ejemplos, cursos y bueno todo lo que tengan.

Yo tengo los instaladores de turbo pascal 5.5 completos son dos diskettes cuando quieran me escriben y se los mando.


Gracias......
Jose
jose-8602@hotmail.com
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 19/02/2012 13:49:42
Te aclarare algo de turbo pascal solo se encuentra disponible la versión 7.0 y en algunos casos
la 7.1 pero esta es la misma que la 7.0.
Esta versión con un poquito de trabajo te permite trabajar como desees tanto en modo texto
como en modo gráfico con resoluciones desde 320X200 asta 1280X1024 con colores desde
16-color, 256-color, 32768-color, 65536-color, 24-bit .
Des pues tienes versiones de free pascal o tmt pascal y editores como dvpas,gani y algun otro.
pero no pascal estándar como pascal 7.0.
Te recomiendo busques en google por turbo pascal 7.0 trabaje perfectamente con windows 7 pero
32bit no 64bit.
Si deseas mas datos pídelos te responderé.
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 03/03/2012 20:13:58
De verdad si me gustaria tener mas informacion sobre este tema ya que pienso que el pascal es muy potente de hecho logre leer un libro sobre programacion DOS que hacian la comparacion del codigo en C tambien del Pascal y el Emsamblador. para realizar el sistema operativo MS-DOS

Tambien vi un programa fuente hecho en pascal y al compilarlo y ejecutarlo me asombre de verdad...al ver que el sistema era Visual . No sabia que el Pascal tenia esta cualidad siendo para MS-DOS.

En fin si me gustaria adentrarme en este lenguaje y en Delphi que lamentablemente la Borland no siguio desarrollandoloss pero quiero aprenderlos bien algo completo que pueda hacer una aplicacion super Buena....

Este es mi otro correo : jose-8602@hotmail.com
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 04/03/2012 19:57:06
Aunque algunos piensan que esta viejo para nuestros días grave error los viejos son ellos que
sentados cómoda mente no quieren programar es mejor que se lo den echo .
Pero pascal puede trabajar perfectamente con windows todas sus series pero 32bits aunque
en algunos casos también con los de 64bits pero eso es otro tema.
Se pueden desarrollar miles de programas tanto en modo texto como en modo gráfico asta los
24 bits de color sin ningún problema.

Te aconsejo que lo aprendas y el te llevara a los demás sistemas de programación puesto que
las diferencias son mínimas, a no ser por las interfaces insertadas que en pascal tendrás que
crear tu pero eso es lo que enseña a programar precisamente conocer el como y porque.

Si necesitas pídela y te ayudare con gusto.
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 05/03/2012 22:07:16
Bueno Ramon claro que me gustaria aprender el Pascal de una manera profesional y si me puedes ayudar con mucho gusto acepto tu ayuda seria cuestion de comenzar bueno tu debes de tener manuales completos y aparte buena experiencia con este lenguaje .

Este es otro correo cualquier cosa me escribes: jose-8602@hotmail.com

Ahora estoy analizando un sistema de facturacion e inventario y tengo una parte programada en xHarbour.
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 14/03/2012 16:52:59
Hola Ramon como estas, es para saber si tienes o sabes en donde descargar el turbo pascal 7.0
en diskettes. Para comenzar a programar en Pascal y tambien para lo que conversamos sobre prestarme tu ayuda en pascal...


Gracias
Jose
correo: jose-8602@hotmail.com
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 14/03/2012 17:55:22
Entra en google e introduce (descargar turbo pascal 7) te saldrán muchos enlaces de descargas.
Cuando lo tengas dímelo y empezare a ayudarte en lo que pueda sobre pascal.
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 15/03/2012 17:06:49
De acuerdo algo mas tienes algun correo para poder escrbirte yo quiero descargar los instaladores completos en diskettes tu crees que se consiga...


Gracias
Jose
Correo: jose-8602@hotmail.com / cualquier cosa me escribes en este correo
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 15/03/2012 18:44:26
Todo lo que pueda ayudarte lo are desde este foro pues lo mismo que tu aprenderás lo aran otros
también que es el propósito que nos mueve el enseñar todo lo que este en nuestras manos.
De los discos pues te comento turbo pascal 7 viene en 5 discos pero no creo lo encuentres
ano ser que lavajes de propio Borland International que creo no estoy seguro lo libero.
Los de Internet suelen no estar completos pero funcionan todos bien por lo general.
Sigue por esta y iremos entrando en tema.
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 17/03/2012 19:31:00
Hola Ramon, ya descargue una version de turbo pascal 7.0 es un ejecutable de 2.50 mg es un instalador bueno hermano cuando quieras comenzamos a programar desde cero (0) hasta un nivel avanzado.

En cuanto a lo apreder todos en este foro tienes mucha razon estoy de acuerdo......
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 17/03/2012 21:46:44
Primero instalemos turbo pascal 7 en el ordenador creo te creara un directorio tp si no fuera asín
ponlo tu, dentro tendrás otros directorios que serán.
Bin / BGI / UNITS / DOC / EXEMPLES / i algún otro.
Si no es asín comenta meló,
Abre otra zona para mas limpieza de datos.
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gnail.com (1 intervención) el 27/03/2012 18:09:57
Hola Ramon ya lo instale y los directorios son estos y archivos en la carpeta principal TP:\

CARPETAS => BGI - BIN - DOC - SOURCE - UNITS - WORK
ARCHIVOS => _DEISREG.ISR - _ISREG32.DLL - DEISL1.ISU - README - README.EXE- UNZIP.EXE

LA CARPETA QUE FALTARIA SERIA EXAMPLES NO LA INSTALO
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 27/03/2012 19:39:20
{Bien entramos en tema para empezar conozcamos nuestro menú del editor un poquito el resto poco a poco ira saliendo}

[ La barra del menú de la zona superior de la pantalla ]

[File] =
New = Abre una nueva ventana de edici¢n;
Open = Selecciona el fichero que se quiere abrir;
Save = Guarda el Programa de la edici¢n activa a disco;
Save As = Guarda el Programa de la edioci¢n activa con nombre
diferente;
Save All = Guarda todos los Programas modificados en la edici¢n;
abiertas
Change Dir = Pone un directorio como directorio actual;
Print = Imprime el contenido de la edici¢n activa;
Printer setup = Pone el Camino y la informaci¢n de l¡nea de comando;
DOS shell = Sale de Turbo Pascal temporalmente para ejecutar un
comando del DOS o Ejecutar otro programa,
[ Para volver a Turbo Pascal, se teclea EXIT ];
Exit = Sale de Turbo Pascal y vuelve al DOS;

[Edit] =
Undo = Anula la Ultima edici¢n, que se realiz¢ sobre una l¡nea;
Redo = Restaura lo anulado con el £ltimo comando Undo;
Cut = Elimina el texto seleccionado del documento y lo pone
en el portapapeles,[De pascal no de windows];
Copy = Deja el texto seleccionado como esta y pasa al
portapapeles una copia de ello;
Paste = Inserta el texto seleccionado del portapapeles en la
edicion actual en la posici¢n del cursor;
Clear = Quita el texto seleccionado;
Show Clipboard = Abre el portapapeles;

[Search] =
Find = Entrada del texto que se quiere buscar;
Replace = Entrada del texto que se quiere buscar y
el texto que lo va a Sustituir;
Search Again = Repite el £ltimo comando [Find o Replace];
Go to Line Number = Entrar el n£mero de l¡nea a vuscar;
Show last compiler error = Informa del error de la £ltima compilaci¢n;
Find Error = Pide a Turbo Pascal que localize la posicion
de un error en timpo de ejecuci¢n;
Find Procedure = Entrar el nombre de un procedimiento o
funci¢n para buscarlo;

[Run] =
Run = Ejecuta el programa;
Step Over = Ejecuta la siguiente instrucci¢n actual;
Trace Into = Ejecuta el programa Paso a Paso;
Go to Cursor = Ejecuta el programa desde la barra de ejecuci¢n hasta
la l¡nea sobre la que est el cursor;
Program Reset = Corta la depuraci¢n actual en curso;
Parameters = Entrada de los argumentos en l¡nea de comandos del
programa que se quiere ejecutar exactamente;

[Compile] =
Compile = Compila el Programa Actual;
Make = Crea un fichero .EXE. si destinacion es disk;
Build = Actualiza todos los ficheros que forman el
programa en curso;
Destination = Guarda en disco (como un fichero .EXE) o en
memoria;
Primary file = Indica el fichero .PAS que se va a compilar;
Clear primary file = Anula la selecci¢n de archivo primario;
Information = informa sobre el £ltimo programa compilado;

[Debug] =
Breakpoints = Controla el uso de puntos de ruptura condicionales e
incondicionales;
Call stack = Muestra la secuencia de procedimientos que ha llamado
el programa
Register = Muestra el estado de los registros de la CPU;
Watch = Muestra expresiones y sus valores de forma que
se puede ver los resultados de los valores clave;
Output = Muestra el texto producido por cualquier linea de
comandos del DOS;
User screen = Ver resultados del programa en la pantalla completa;
Evaluate/Modify = Evaluar una variable o expresi¢n;
Add Watch = Entra una expresi¢n a inspecci¢nar en la ventana
Watches;
Add Breakpoint = Indica el uso de puntos de ruptura condicionales o
incondicionales;

[Tools] =
Messages = Salida de mensajes del programa;
Go to next = Salida de mensajes del programa;
Go to previous = Salida de mensajes del programa;
Installed tools = Modificar o eliminar las herramientas por defecto;

[Opcions] =
Compiler... = Configuracion del compilador;
Memory sizes...= Configuracion de memoria de los programas;
Linker... = Configuracion de varios par metros que afectan a la
forma en que Turbo Pascal enlaza los programas;
Debugger... = Configuracion de varios par metros que afectan al
depurador integrado;
Directories... = Configuracion de los directorios a usar cuando se
ejcuten y almacenen programas;
Tools = Configuracion del control a otro programa sin
abandonar el IDE;
Environment = Configuracion del [Editor/Mouse/Monitor/Colores];
Open = Recuperan los datos del fichero .TP
Save = Guarda las definiciones que se hicieron en el cuadro
de di logo Search;
Save as = Guarda los cambios de par metros hechos en el cuadro
de di logo Search;

[Window] = Manejador de las ventanas de pascal;

[Help] = Acceso a la ayuda en l¡nea;

El menu Inferior es una forma rapida de acceder a lo anterior como se
puede ver;


La configuración de [ Directorios] tendrá que quedar aproximada mente así dependiendo
del disco que utilices [ la barra exe & tpu directory = C:\TP
[ la barra Include directories = C:\TP
[ la barra Unit directories = C:\TP\unist;C:\TP
[ la barra Object directories = C:\TP;C:\TP\BIN encaso de que la unidad
fuera otra y no C cambiar.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
program prueba;
uses
   crt, dos;
  var
    minombre : string;
    ayo, mes, dia, diase : word;
  begin
      clrscr;
      writeln('Mi Nombre Es : ');
      readln(minombre);
      clrscr;
      gotoxy((80 div 2) - 10,24 div 2);write('Escribi el Nombre = ',minombre);
      getdate(ayo,mes,dia,diase);
      gotoxy((80 div 2) - 10,(24 div 2) + 2);write('En Fecha    = ',
                                                  dia,'/',mes,'/',ayo);
      readln;
  end.
 
{Esto solo es una prueba para ver si las direcciones son correctas si no dará error}

si todo funciona podemos empezar a la programación en pascal 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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 30/03/2012 21:59:46
Listo Ramon ya lo compile y ejecute

Me pide el nombre cuando lo introduzco luego me me muestra el nombre y la fecha del dia que ejecute el programa
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 30/03/2012 22:12:29
Entremos a conocer las constantes, los tipes, y las variables y algo
de arrays.

Las constantes:
Define un identificador de un valor constante dentro del bloque que contiene
la declaracion programa, procedimiento o funcion.
Las expresiones constantes puedes ser : chr, length, odd, ord, hi, lo, ptr,
abs, sizeof.
Ejemplo:
Const fijas
Numero = 3.1416; valor numerico fijo
......
......
Letra : array[1..4] of char = ('A','B','C','D');
un array de letras fijas

Const variables o con typo
Nombre : string = 'Juan Andres';
una constante variable podemos cambiar en nombre pero siempre
Arrancara con 'Juan Andres';
......
......
Num : real = 34.78; ; una constante variable podemos
cambiar el valor pero siempre arrancara con '34.78';

Los type especifica un identificador de tipo.
Array, fichero, objeto, puntero, real, registro, conjunto, o cadena.
Type
String20 = string[20]; Definimos un valor de 20 al string en vez
de los 255 que tiene;
Int = integer; Definimos a int como un numero integer;
Registro = record Definimos un registro de datos que contendra
un valor longint, un valor string20, y un
valor Integer;
Dni : longint;
Ciudad : string20;
Num : int;
End;


Las variables asocian un identificador con una posicion en memoria donde
Almacenara los valores entrados en ella o sea reservara memoria para ellas.
Var
Contador : integer; Con esta asignamos espacio en memoria para un
valor numerico integer;
F : file: Con esta establecemos un acceso a un fichero sin tipo;
Re : file of registro; Con esto establecemos un acceso a un fichero
con tipo;
Tecla : char; Con esto establecemos espacio en memoria para un
caracter;
.....
nombre : string; Con esto asignamos memoria para un string o sea
255 caracteres;
Regi : registro; Con esto establecemos espacio en memoria para un
registro completo;

Estas [const, type y var] podran ser usadas en todo el programa.
Pero si en vez de estar puestas en la cabecera del programa estubieran
dentro de un procedimiento o funcion ejemplo:
Procedure mas;
Var
Regi : registro;
Begin

End;
Regi solo lo podria manejar el procedimiento [mas].
No el resto del programa como en el caso anterior.

Como vereis en pascal existen unas reglas que tenemos que respetar para no
encontrar errores despues.
Existen unas palabras reservadas que son:

And, asm, array, begin, case, const, constructor, destructor, div,
Do, downto, else, end, exports, file, for, function, goto, if,
Implementation, in, inherited, inline, interface, label, library, mod,
nil, not, object, Of, or, packed, procedure, program, record, repeat,
set, shl, shr, string, then, To, type, unit, uses, var, while, with,
xor,obsolute, assembler, export, far, forward, Index, interrupt, near,
private, public, resident, virtual.

Tienen un significado fijo dentro de pascal no se pueden redefinir ni
usar como constantes, variables o types.

En turbo pascal no se distingue de mayusculas o minusculas por lo cual se
pueden usar Indistinta mente para las palabras reservadas una forma o
otra.

Las cadenas de caracteres o sea [string] tienen una entrada maxima de
255 caracteres pasada esa longitud los datos restantes se pierden.
Sin embargo pascal nos permite definir otras longitudes menores en
el string ejemplo:
type
string23 = string[23];
con esto tenemos un string de 23 caracteres sola mente en vez de 255.
con esto cuando no necesitamos 255 caracteres nos ahorramos memoria para
otras variables.
Para leer la longitud de una entrada vasta leer la posicion 0 de la cadena
osea para la cadena string23 leeriamos string23[0] su contenido sera la
longitud que tiene logicamente cuanto tenga datos entrados sino esa
posicion valdra 0.
Mas adelante veremos otras formas de ver esa longitud.

Los array su forma es :
numerp : array[1..5] of integer; define 5 entradas de valor integer en
un solo nombre o sea numerp pero la forma de acceso tanto para leer como
escribir sera [numerp[x] := 100, x sera el numero de posicion en el array
y 100 el valor de esa posicion.
A la hora de leer sera [numerp[x] y tendremos el valor de esa posicion.
Estos son algunas maneras de definir los array.
Interg = array[1..100] of Integer;
Datobyte = array['A'..'Z'] of Byte;
Matrireal = array[0..9, 0..9] of real;
matrichar = array[1..2,1..3,1..5] of char;

constantes con tipo array:
una constante de tipo array especifica los valores de los componentes
del array puede ser de cualquier tipo excepto un tipo fichero.

type
dias = (lunes,martes,miercoles);
semana = array[dias] of string[9];
const
lasemana : semana = ('lunes','martes','miercoles');

Arrays de caracteres:
Las constantes con tipo cadena empaquetada (arrays de caracteres) pueden
especificarse como caracteres simples o como cadenas.

const
numeros : array[0..9] of Char = ('0', '1', '2', '3', '4', '5',
'6', '7', '8', '9');

numeros : array[0..9] of Char = '0123456789';
seguiremos,
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 30/03/2012 22:15:59
De acuerdo hay tienes mas
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 02/04/2012 17:27: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
{Seguimos conociendo mas de pascal y programación}
 
  {Manejando la pantalla en modo testo:
 La pantalla esta formada por pixeles o puntos en el caso del
 modo texto tiene 1 a 80 X 1 a 25 o lo que es lo mismo 80X25.
 1........................................80
 1.
  .
  .
  .
  .
  .
  .
 25
 Podemos posicionarnos en la zona que queramos de estas dimensiones,
 lo cual nos permite el desplazamiento por ello por ejemplo:
 la instruccion [write('Pantalla');] nos presentaria la frase Pantalla,
 en la posicion 1/1 de la pantalla y el cursor seguiria en la line 1/1.
 Si pusieramos [write(' Pantalla');] la posicion de Pantalla estaria
 en 2/1 en lugar de 1/1 ya que delante de Pantalla tenemos insertado
 un caracter en blanco o sea un espacio.
 La sentencia [writeln('Pantalla');] seria lo mismo que lo anterior pero
 ahora la posicion del cursor en la pantalla seria 1/2 al causar la
 sentencia writeln un desplazamiento de linea acia abajo.
 Como podreis apreciar para escribir cosas peque¤as va que va pero cuando
 se intenta formatear la salida mal este sistema por ejemplo para poner
 un nombre en el centro de la pantalla seria una labor como se suele decir
 de chinos (pido disculpas a los chinos no intento ofender).
 
 Como podemos comprender tenemos que emplear otros medios mas practicos
 que write o writeln solos, esto se consigue con la instruccion gotoxy(x,y),
 hablemos un poco para comprenderla.
 El pascal nos sirve en su [unit crt] de la instruccion gotoxy con dos
 parametros pasados que son x e y en nuestro caso [x de 1 a 80] y
 [y de 1 a 25], <que hace> coloca el cursor en la posicion x e y de la
 pantalla para escribir lo que queramos en ella ejemplo:
 gotoxy(10,10);write('*');
 nos presentara el asterisco en la posicion 10,10 de la pantalla.
 (Comento) esto mismo lo podemos implementar con un procedimiento en
 enssamblador, o con funciones de la bios, pero eso sera mas adelante esto
 es mas facil de realizar de momento.
 Veamos un peque¤o ejemplo: }
 
 {program disparo;
 uses
    crt;
  var
    i, x, y : integer;
    tecla : char;
  begin
      clrscr;
      gotoxy(3,1);write('Dispara con barra espaciadora a los blancos flechas',
                     ' mueven [Enter] termina');
      gotoxy(10,4);write('***');
      gotoxy(40,4);write('***');
      gotoxy(70,4);write('***');
      x := 40;
      y := 22;
    repeat
      gotoxy(x,y - 1);write('!');
      gotoxy(x,y);write('*');
      gotoxy(x,y + 1);write('*');
      tecla := readkey;
      gotoxy(x,y - 1);write(' ');
      gotoxy(x,y);write(' ');
      gotoxy(x,y + 1);write(' ');
      if tecla = #32 then
      begin
         for i := 21 downto 4 do
         begin
             gotoxy(x,y);write('*');
             gotoxy(x,y + 1);write('*');
             gotoxy(x,i);write('!');
             delay(50);
             gotoxy(x,i);write(' ');
         end;
          gotoxy(x,y - 1);write('!');
      end;
      if tecla = #75 then
      begin
          x := x - 1;
          if x < 1 then
          x := 1;
      end;
      if tecla = #77 then
      begin
         x := x + 1;
         if x > 79 then
         x := 79;
      end;
   until tecla = #13;
  end.}
 
 {En este pequeño ejemplo aparte del goto y write presento un pequeño
  manejo del teclado fuera de read o readln que veremos proxima mente.
  Los numeros que se encuentran como [#77/#75/#13] corresponden a los
  valores numericos de las teclas de flecha, derecha, izquierda y   retun
  a sin como [#32] barra espaciadora.
  A unque mas adelante veremos como trabajar con estos datos.
 
  Espero practiquéis con el programa para que le toméis la medida al
  gotoxy puesto que trabajaremos con el en muchas ocasiones.
  debéis modificar la posición de los asteriscos en pantalla y probar
  en otras posiciones de ellas.
 
  A continuación tratemos un comando expuesto en este programa ese es
  readkey :
  este es una función de la unidad [crt] que nos devuelve un carácter
  del teclado o sea el carácter de la tecla pulsada este no es   presentado
  en pantalla solo lo entrega para ello empleamos una variable char   que
  recogerá dicho carácter, al mismo tiempo esta función nos retiene la
  ejecución del programa con lo cual podemos tomar decisiones en razón
  a lo que nos entregue readkey, un ejemplo es el desplazamiento a   derecha
  o izquierda y disparo dependiendo de la tecla pulsada.
  Iremos viendo como lo emplearemos en diversas ocasiones.}
  {Este programa os mostrara los números y caracteres de las teclas}
 
 
 { program teclado;
  uses
   crt;
   var
       tecla : char;
       x, y, nume : integer;
   begin
   clrscr;
   sound(100);
   delay(129);
   nosound;
   x := 1;
   y := 1;
   nume := 9;
   repeat
       textcolor(14);
       gotoxy(x,y);write(nume);
       textcolor(15);
       gotoxy(x + 4,y);write(tecla);
       inc(nume);
       tecla := chr(nume);
       inc(y,1);
       if y > 23 then
       begin
           y := 1;
           x := x + 8;
       end;
   until nume > 232;
   gotoxy(10,24);write('pulse una tecla o ESC');
   repeat
      tecla := readkey;
      if tecla = #0 then
      begin
      tecla := readkey;
      gotoxy(32,24);write('       ');
      gotoxy(32,24);write(ord(tecla),'  ',tecla);
      end
   else
      begin
          gotoxy(32,24);write('       ');
          gotoxy(32,24);write(ord(tecla),'  ',tecla);
      end;
   until tecla = #27;
   end. }
 
  {Veréis alguna instrucción nueva pero solo observarlas ya las
  Veremos mas adelante esto es para que valláis tomando nociones poco
  a poco.}
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 05/04/2012 03:49:33
Listo Ramon pasamos al otro tema.......
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 05/04/2012 16:29:02
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
{ hoy pasamos a tratar los comandos read y readln como entradas
   de valores en variables, retenciones ose espera y ficheros.
  [Read/readln] :
  Como sistema de entrada permite introducir datos el una variable
 cualquiera, pero no informara si la entrada en la variables numéricas
 se ingresa un carácter en vez de un numero, causando a la salida error.
 Ejemplo:
 var
    dat : string;
    nu : integer;
  begin
  read(dat); {Si entramas numero no pasa nada lo toma como carácter}
  {read(nu);} {Si entramos un carácter a la salida dará error de formato}
  {end;}
 
  {var
    dat : string;
    nu : integer;
  begin
  readln(dat);} {Si entramas numero no pasa nada lo toma como carácter}
  {readln(nu);} {Si entramos un carácter a la salida dará error de formato}
  {end;
 
  Diferencia entre [read y readln] read sigue la entrada en la línea y
  readln pasa a la siguiente línea.
 
En ficheros con tipo, lee un componente del fichero y lo introduce en
la variable.
Ejemplo:
type
regdato = record
         nombre : string;
         direccion : string;
         telefono : word;
        end;
 var
    f : file of regdato;
    dato : regdato;
    assign(f,'xxxxxx.xxx');
    reset(f);
    seek(f,0);
    read(f,dato);
    close(f);
  Leera el primer registro del fichero [f] completo.
 
  Para ficheros tipo texto, lee uno o m s valores y los introduce en una o
  m s variables.
  Ejemplo:
  var
    tex : text;
    cha : char;
    assign(tex,'xxxxxx.xxx');
    reset(tex);
    while not Eof(tex) do
    begin
        read(tex,cha);
        write(cha);
    end;
  Leerá todo el archivo de texto presentándolo en pantalla.}
 
  {Ejemplo:}
    program leetexto;  {Este Programa leerá un archivo de texto entero}
    uses
      crt;
    var
      f : text;
      dato : char;
      nombrearchivo : string;
 
   begin
      nombrearchivo := 'c:\tp\cursopas\numero3.pas'; {Archivo a leer}
      assign(f,nombrearchivo); {Le abrimos}
    {$I-} reset(f); {$I+}   {Comprobamos si existe error}
    if ioresult <> 0 then   {Si error salimos del programa}
    halt(1);   {Detiene el programa y vuelve al dos}
    while not Eof(F) do  {leemos asta el final de archivo}
    begin
      read(f,dato);  {Leemos los datos carácter a carácter}
      write(dato);  {Los presentamos en pantalla}
    end;
    close(f); {cerramos el archivo siempre que se abra un archivo
               se debe de cerrar para no perder los datos o que se
               dañen}
    readln;  {Detenemos la salida para ver que presento solo se
              verán las 25 líneas intimas}
  end.    {final del programa}
 
  {Con esto de momento quedan explicados los comandos read y readln
   practicar con entradas a variables y comprobación de las salida de
   archivos de texto este otro programa mostrara como se controla la
   entrada de datos sin read ni readln}
 
   program entradas;
   uses
     crt;
   var
     tecla : char;
     result, dato : string;
     dareal : real;
     dainte : integer;
     dastri : string;
     error, cont : integer;
 
   function datosalida(x1, y1 : integer; cual : char) : string;
   {las x1 y y1 posicionan la entrada donde queramos en la pantalla}
   begin
       cont := 1;
       datosalida := ' ';
       gotoxy(x1,y1);  {posicionamos cursor}
     repeat
       tecla := readkey;
       if cual in['n','N'] then  {solo entrada numérica}
       begin
          if tecla in[#48..#57,#46] then {verificamos que es numérica}
          begin
             dato[cont] := tecla;  {entramos el carácter pulsado}
             dato[0] := chr(cont); {en la variable dato y el numero
                                    de entradas de caracteres realizadas}
             gotoxy((x1 - 1) + cont,y1);write(dato[cont]); {lo presentamos}
             cont := cont + 1;   {incrementamos el contador}
             if cont > 255 then {comprobamos si la entrada es mayor que}
             cont := 255;       {la cadena no entramos mas datos de 255}
          end;
       end;
       if cual = ' ' then   {esto es como lo anterior pero en este caso}
       begin                {cualquier carácter es valida su entrada}
           dato[cont] := tecla;
           dato[0] := chr(cont);
           gotoxy((x1 - 1) + cont,y1);write(dato[cont]);
           cont := cont + 1;
           if cont > 255 then
           cont := 255;
       end;
       if tecla = #8 then  {aquí borramos las entradas realizadas}
       begin               {o erróneas}
           cont := cont - 1; {decremento contador}
           if cont < 1 then  {si es menor de 1 lo dejamos a 1}
           cont := 1;
           dato[cont] := ' ';  {borramos carácter de la posición cont}
           dato[0] := chr(cont);  {actualizamos entradas}
           gotoxy((x1 - 1) + cont,y1);write(dato[cont]); {lo presentamos}
       end;
     until (tecla = #13) or (tecla = #27);
     {si pulsamos enter finaliza entrada y actualiza si pulsa esc sale sin
      realizar nada deja [datosalida] limpio}
     if tecla = #13 then
     datosalida := copy(dato,1,length(dato)); {carga datos en función}
   end;
 
  begin
      clrscr;  {limpiamos pantalla}
      gotoxy(1,10);write('Entre Numero : ');
      result := datosalida(16,10,'n');{tomamos la entrada es numérica}
      val(result,dareal,error); {convertimos a numérica}
      if error > 0 then   {comprobamos si hay error en la conversión}
      begin
         delete(result,1,error); {si hay error lo quitamos}
         val(result,dareal,error); {volvemos a convertir}
      end;
      gotoxy(1,10);clreol; {borramos la entrada solo una línea}
      writeln(dareal:8:2); {presentamos resultados numéricos}
      readln; {espera asta pulsar enter}
      clrscr;  {limpiamos pantalla}
      gotoxy(1,10);write('Entre Texto : ');
      result := datosalida(15,10,' ');{tomamos la entrada es texto}
      gotoxy(1,10);clreol; {borramos la entrada solo una línea}
      writeln(result); {salida del testo no se modifica nada}
      readln; {espera asta pulsar enter}
  end.
 
{En esta veremos datos que no hemos tocado todavía  pero es bueno irles conociendo
 en la pro sima veremos las const,  arrays, record, types y algo de ensamblador de pascal
para ir abriendo boca}
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 09/04/2012 18:19: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
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
{veremos las const,  arrays, record, types y algo de ensamblador de pascal
  trabajando con const,arrays,record,types y ensamblador inicio programación}
 {las constantes como su nombre indica son valores fijos que podremos
  consultar durante todo el proceso del programa por ejemplo el valor
  pi = 3.1416 nos puede valer para cálculos en diferentes procedimientos
  o funciones sin tener que insertar el numero solo poniendo pi.
  Ejemplo:}
  uses
     crt;
  const
     pi = 3.1416; {fijaros que 3.1416 va con punto tener en cuenta que
                    la coma en pascal no vale para separar decimales
                    esto seria error pi := 3,1416}
   var
      diame : real;
   begin
      write('Entre diametro : ');
      read(diame);
      writeln;
      write('Circunferencia = ',pi * diame:8:2);
      readkey;
   end.
  {O cualquier otro servicio en que lo requiera como ya se comento existen
  las constantes variables las cuales se emplean cuando un valor de inicio
  queremos que varié durante el proceso.
  Ejemplo :}
  uses
    crt, dos;
  const
     horari : string = ' ';
 
  var
    ho, mi, se, de : Word;
 
  function worstring(w : word) : string; {Esta function nos convierte}
  var                                    {un numero word en estringe}
     s : string;                         {insertando un cero si solo}
  begin                                  {tuviera un numero 4 pondra}
      str(w:0,s);                        {04 en su lugar}
      if length(s) = 1 then
       s := '0' + s;
      worstring := s;
   end;
 
   begin
     clrscr;
    repeat
       gettime(ho,mi,se,de);
       horari := worstring(ho) + ':' + worstring(mi) + ':' + worstring(se);
       gotoxy(10,10);write('La Hora Es = ',horari);
    until keypressed;
   end.
 {Se puede ver como cambia la hora en la constante}
 
 {Los Arrays son variables múltiples en una sola variable se expresa así
  dias : array[0..6] of string[12]; esto sera Como variable,
 
  dias = array[0..6] of string[12]; esto seria como type;
 
  dias : array[0..6] of string[12] = ('Lunes','Martes','Miercoles','Jueves',
                                      'Viernes','Savado','Domingo');
  seria como constante.
 
  como veis el array puede tomar diferentes condiciones dependiendo de lo
  que queramos.
  En este caso toma 7 variables string de 12 caracteres que seria
  dias0 : string[12]; asta dias6 se maneja mejor el array que tantas
  variables.
  Como manejamos un array vamos a ver.}
  program arrays;
uses
   crt;
 const
   dias : array[0..6] of string[12] = ('Lunes','Martes','Miercoles',
                               'Jueves','Viernes','Savado','Domingo');
  type
    semana = array[0..3] of integer;
 
  var
    mes : semana;
    sem, cual : integer;
 
  begin
     clrscr;
     for sem := 0 to 3 do
     mes[sem] := sem + 1;
     for sem := 0 to 3 do
     begin
      write(' semana ',mes[sem]);
      for cual := 0 to 6 do
      begin
      write('  ',dias[cual]);
      end;
        writeln;
     end;
      readln;
  end.
 
  {vemos como cargamos los valores en el array mes que corresponde a
   semana y luego presentamos los datos y el contenido de la constante
   array días}
 
  {como manejamos un record en este entraran los arrays también}
  program recordes;
uses
   crt;
 type
   datos = array[1..6] of string[20];
   sueld = array[1..6] of real;
   currante = record
        nombre : string;
        dias : datos;
        dinese : sueld;
       end;
   var
     trabajo : currante;
     dat : string;
     dsem : string[20];
     sueldo : real;
     error, dr, cont : integer;
     tecla : char;
     suel, dato : string;
 
 
  function datosalida(x1, y1 : integer; cual : char) : string;
   begin
       cont := 1;
       datosalida := ' ';
       gotoxy(x1,y1);
     repeat
       tecla := readkey;
       if cual in['n','N'] then
       begin
          if tecla in[#48..#57,#46] then
          begin
             dato[cont] := tecla;
             dato[0] := chr(cont);
             gotoxy((x1 - 1) + cont,y1);write(dato[cont]);
             cont := cont + 1;
             if cont > 255 then
             cont := 255;
          end;
       end;
       if cual = ' ' then
       begin
          if (tecla = #8) or (tecla = #13) then
          begin
          end
        else
          begin
           dato[cont] := tecla;
           dato[0] := chr(cont);
           gotoxy((x1 - 1) + cont,y1);write(dato[cont]);
           cont := cont + 1;
           if cont > 255 then
           cont := 255;
       end;
     end;
       if tecla = #8 then
       begin
           cont := cont - 1;
           if cont < 1 then
           cont := 1;
           dato[cont] := ' ';
           dato[0] := chr(cont);
           gotoxy((x1 - 1) + cont,y1);write(dato[cont]);
       end;
     until (tecla = #13) or (tecla = #27);
     if tecla = #13 then
     datosalida := copy(dato,1,cont - 1);
   end;
 
   begin
      clrscr;
      gotoxy(2,2);write('Entre Nombre  : ');
      trabajo.nombre := datosalida(18,2,' ');
      dr := 1;
    repeat
      gotoxy(2,3);clreol;
      gotoxy(2,4);clreol;
      gotoxy(2,3);write('Entre El Dia  : ');
      dsem := datosalida(18,3,' ');
      trabajo.dias[dr] := copy(dsem,1,length(dsem));
      gotoxy(2,4);write('Dinero De Hoy : ');
      suel :=  datosalida(18,4,'n');
      val(suel,sueldo,error);
      if error > 0 then
      begin
         delete(suel,error,1);
         val(suel,sueldo,error);
      end;
      trabajo.dinese[dr] := sueldo;
      dr := dr + 1;
    until dr > 6;
    clrscr;
    writeln('Nombre = ',trabajo.nombre);
    for dr := 1 to 6 do
    begin
      write('El DIA : ',trabajo.dias[dr],'     Importe : ',
                                         trabajo.dinese[dr]:8:2);
    writeln;
    end;
    for dr := 1 to 6 do
    sueldo := sueldo + trabajo.dinese[dr];
    writeln('Sueldo total Semana = ',sueldo:8:2);
      readln;
   end.
  {En caso de querer guardar el registro solo tendremos que realizar
   esto.}
   procedure guardarecord(nom : string); {Este es el nombre del archivo}
   var
     f : file of currante;
   begin
       assign(f,nom);
    {$I-} reset(f); {$I+} {esto nos permite conozer si salio error}
    if ioresult <> 0 then {si es mayor de 0 el archivo no esiste}
    begin                 {por lo tanto lo creamos}
       rewrite(f); {Crea y abre un fichero nuevo}
       seek(f,0); {posicionamos el puntero en la posicion 0 del archivo}
       write(f,trabajo); {guardamos el registro}
       close(f); {cerramos el archivo}
     end
   else   {si la condicion anterios fue 0 se realiza lo sigiente}
       begin
          seek(f,filesize(f)); {posicionamos el puntero al final}
          write(f,trabajo);    {del archivo y guardamos los datos}
          close(f); {cerramos el archivo}
       end;
   end;
 
  {Este procedimiento guarda los datos anteriores del registro entrado
   del trabajador si quisiéramos cargar datos casi seria igual ejemplo:}
   procedure cargaregistro(nom : string);
   var
     f : file of currante;
     nomb : string;
     gf : longint;
     salir : boolean;
     suel : real;
   begin
      assign(f,nom);
    {$I-} reset(f); {$I+} {esto nos permite conozer si salio error}
    if ioresult <> 0 then {si es mayor de 0 el archivo no esiste}
    begin
       halt(1); {salimos el archivo no existe}
    end
  else    {el archivo existe lo cargamos}
      begin
          gotoxy(2,3);write('Entre Nombre Trabajador a Visualizar : ');
          gotoxy(41,3);read(nomb); {pedimos el nombre del trabajador}
        gf := 0;
        salir := false; {condicion para la salida true}
     repeat
        seek(f,gf);  {nos posicionamos en la primera posicion [0]}
        read(f,trabajo); {leemos el registro}
        if trabajo.nombre = nomb then  {comparamos el nombre}
        salir := true;  {si es igual salimos}
     gf := gf + 1;   {contador de registros}
     until (gf > filesize(f) - 1) or (salir = true); {salir o encontrado}
     close(f);             {o final del archivo y cerramos}
     if salir = true then  {si se encontro lo presentamos}
     begin
        writeln('Nombre = ',trabajo.nombre);
        for gf := 1 to 6 do
        begin
        write('El DIA : ',trabajo.dias[gf],'     Importe : ',
                                         trabajo.dinese[gf]:8:2);
    writeln;
    end;
    suel := 0;
    for gf := 1 to 6 do
    suel := suel + trabajo.dinese[gf];
    writeln('Sueldo total Semana = ',sueldo:8:2);
      readln;
     end;
   end;
  end;
 
 {como veis es facil todo es empezar a conocerlo}
 Los types nos permiten especificar:
  arrays, fichero, objeto, puntero, registro, conjunto :
 
 arrays :
 integers  = array[1..100] of Integer;
 chares = array['A'..'Z']   of byte;
 matrixreal = array[0..9, 0..9] of real;
 
 ficheros y registros :
 Persona = record
  nombre : string[15];
  apellido : string[25];
  direccion  : string[35];
 end;
  archivo = file of Persona;
 
  objeto :
   unpunto = objeto
          x, y : integer;
          procedure puntover(x,y);
          procedure puntovorra(x,y);
         end;
 
  punteros :
    puntbyte  = ^Byte;
    puntword  = ^Word;
    puntident = ^regident;
     regident = record
         nombre : string[30];
            dni : Word;
           sigi : puntident;
         end;
 
  conjuntos :
      dia = (lun, mar, mir, juv, vir, sav, dom);
      cart = set of char;
      num = set of 0..9;
      dias = set of dia;
 
 {Esto empieza como sigue se trata de un procedimiento y función
  en ensamblador dentro de un programa en pascal como también veréis
  se puede implementar con interrupciones del dos es solo para que
  tengáis un conocimiento algo mas avanzado para no bloquearos en
  su momento ya que camino conocido mejor se anda.}
 
program ejemplo;
 uses
   crt, dos;   {entrada de la unit dos para manejar las interruciones}
  var
    regs : registers; { Registers = record
                        case Integer of
                   0: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: Word);
                   1: (AL, AH, BL, BH, CL, CH, DL, DH: Byte);
                   end;}
    raton : boolean;  {variable para informacion del la presencia del mouse}
    pulsado : integer;
 
     function raton_presente : boolean; {comprovamos presencia false/true}
     begin
      regs.ah := $00;  {valores para ah} Înicia mouse}
      regs.al := $00;  {valores para al}
      intr($33,regs);  {interruccion del mouse}
      if regs.ax <> 0 then  {comprovamos si exite mouse}
      raton_presente := true {si}
    else
      raton_presente := false; {no}
  end;
 
     procedure muestra_ratonint;
     begin
      raton := false;  {informacion para el cierre}
      if raton_presente then  {si existe segimos}
      begin
          regs.ah := $00; {valor ah} {muestra cursor del mouse}
          regs.al := $01; {valor al}
          intr($33,regs); {interruccion}
          raton := true;  {si se cargo}
      end;
   end;
 
    procedure oculta_ratonint;
    begin
      if raton = true then {comprovacion se activo}
      begin
         regs.ah := $00; {valor ah}
         regs.al := $02; {valor al} {Oculta el cursor del mouse}
         intr($33,regs);  {interruccion}
         raton := false;  {anulamos true}
       end;
   end;
 
   function pulsa_botonint:word;
   begin
      regs.ah := $00; {indica el boton pulsado del mouse}
      regs.al := $05;
      intr($33,regs);
      pulsa_botonint := regs.ax;
  end;
 
   function raton_presenteasm : boolean;assembler;
    asm
      mov ah,$00
      mov al,$00
      int $33
    end;
 
  procedure muestra_ratonasm;assembler;
  asm
     mov ah,$00
     mov al,$01
     int $33
  end;
 
  procedure oculta_ratonasm;assembler;
  asm
    mov ah,$00
    mov al,$02
    int $33
  end;
 
  function pulsa_botonasm : word;assembler;
   asm
     mov ah,$00
     mov al,$05
     int $33
   end;
 
   begin
      clrscr;
       writeln('Mouse con Registros pulsa botones');
       muestra_ratonint;
       repeat
       case  pulsa_botonint of
     1 : begin gotoxy(20,10);write('Izq');end;
     2 : begin gotoxy(20,10);write('Drch');end;
     0 : begin gotoxy(20,10);write('    ');end;
       end;
       until keypressed;
       readln;
       oculta_ratonint;
       clrscr;
       writeln('Mouse en Ensamblador pulsa botones');
       if raton_presenteasm then
       muestra_ratonasm;
       repeat
       case  pulsa_botonasm of
     1 : begin gotoxy(20,10);write('Izq');end;
     2 : begin gotoxy(20,10);write('Drch');end;
     0 : begin gotoxy(20,10);write('    ');end;
       end;
       until keypressed;
       oculta_ratonasm;
  end.
 
  {Este programa muestra la llamada al Mouse de dos maneras pero
   el mismo resultado.
   Si tenéis dudas decírmelo intentare quitároslas.}
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 09/04/2012 22:21:59
Listo Ramon pasemos a otro tema.....
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 14/04/2012 19:41:19
{Empecemos a programar}
Un programa en pascal siempre empezara así
program primero; {Esta será la cabecera del programa}
{fijaros sin esta cabecera también se puede ejecutar

el}
{programa si ningún problema.}
uses {Nombrara a una unidad que usara el programa }
crt; {Unidad a utilizar}
const {definir valores constantes}
animal = 'Perro'; {Definimos la constante}
type {especifica un tipo de dato}
nombre = array[1..50] of char; {define el tipo sera un array char}
{de 50 caracteres no mas pero si menos}
var {declaración de variables se referencia a una

posición}
{en memoria de un tipo de dato}
minombre : nombre; {Aquí hago referencia a nombre de la sección

type}

procedure o function {Estas son las partes del programa que

realizan}
{alguna acción}
procedure posiciontexto(x, y : integer;texto : string);
begin
gotoxy(x,y);write(texto));
end;
{Comentemos este procedimiento que es lo que hace:}
{Identificador del procedimiento [posiciontexto] para su ejecución}
{después [x, y] los parámetros de posición del texto en pantalla}
{texto el parámetro a presentar.}
{[begin] El inicio del procedimiento}
{[gotoxy(x,y)] posiciona el cursor en la posición x,y de la

pantalla}
{para la escritura [write(texto)] presenta el texto en el lugar del}
{cursor [end;] final del procedimiento en este caso}
function sumamedia(p1, p2 : integer) : real;
begin
sumamedia := (p1 + p2) / 2;
end;
{Comentemos la función como en el caso anterior [sumamedia]

identifica}
{a la función para su uso [p1 y p2] son los datos pasados a la

función}
{como podéis ver son valores integer o sea enteros, pero la función}
{devolverá un valor real, [begin] inicia como antes la función}
{[sumamedia] realizara la suma de los dos datos pasados y los

dividirá}
{por dos para sacar la media como puede resultar un valor decimal

por}
{ello es real su salida si no daría error.}
{Así empieza un programa en pascal partir de esta estructura se}
{desarrollan todos los programas.}
{Cuando el programa que queremos realizar es muy largo creamos

unidades}
{que después llamamos desde el programa central con lo cual nuestro}
{programa resultara mas pequeño y mas entendible cuando se realiza

una}
{unidad o [unit] primero se ejecuta como programa para corregir

cualquier}
{fallo que pudiera haber que siempre los hay, después se pasa a

unidad}
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
{ejemplo:}
  program prueva;
  uses
    crt;
   type
      ciudad = record
             nombre : string[60];
             pais   : string[60];
             region : string[70];
           end;
 
  var
     datosciudades : ciudad;
     f : file of ciudad;
 
  procedure entradas;
  begin
     clrscr;
     gotoxy(1,1);write('NOMBRE ES    : ');
     readln(datosciudades.nombre);
     gotoxy(1,2);write('EL PAIS ES   : ');
     readln(datosciudades.pais);
     gotoxy(1,3);write('LA REGION ES : ');
     readln(datosciudades.region);
  end;
 
  procedure presenta;
  begin
     clrscr;
     gotoxy(1,1);write('NOMBRE ES    : ',datosciudades.nombre);
     gotoxy(1,2);write('EL PAIS ES   : ',datosciudades.pais);
     gotoxy(1,3);write('LA REGION ES : ',datosciudades.region);
     gotoxy(1,5|);write('Pulse [Enter]');
     readln;
  end;
 
  procedure guarda;
  begin
      assign(f,'TEMPORAL.DAT');
    {$I-} reset(f); {$I+}
    if ioresult <> 0 then
    begin
       rewrite(f);
       seek(f,0);
       write(f,datosciudades);
       close(f);
    end
  else
     begin
         seek(f,filesize(f));
         write(f,datosciudades);
         close(f);
     end;
  end;
 
  procedure menu;
  var
    tec : char;
    sal : boolean;
  begin
    sal := false;
    repeat
      clrscr;
      gotoxy(1,1);write('<<<< MENU GENERAL >>>>');
      gotoxy(1,3);write(' 1 = ENTRADAD');
      gotoxy(1,4);write(' 2 = PRESENTAR');
      gotoxy(1,5);write(' 3 = GUARDAR');
      gotoxy(1,6);write(' 4 = SALIR');
      gotoxy(1,8);write(' **** ELIJA OPCION ****');
      tec := readkey;
    case tec of
  #49 : entradas;
  #50 : presenta;
  #51 : guardar;
  #52 : sal := true;
    end;
   until sal = true;
  end;
 
  begin
     menu;
  end.
 
  {Una vez revisado el programa y funcionando todo bien se modifica}
  {para que sea unidad sigamos}
 
  unit prueva;
  interface
  uses
    crt;
   type
      ciudad = record
             nombre : string[60];
             pais   : string[60];
             region : string[70];
           end;
 
  var
     datosciudades : ciudad;
     f : file of ciudad;
 
   procedure entradas;
   procedure presenta;
   procedure guarda;
   procedure menu;
 
   implementation
  procedure entradas;
  begin
     clrscr;
     gotoxy(1,1);write('NOMBRE ES    : ');
     readln(datosciudades.nombre);
     gotoxy(1,2);write('EL PAIS ES   : ');
     readln(datosciudades.pais);
     gotoxy(1,3);write('LA REGION ES : ');
     readln(datosciudades.region);
  end;
 
  procedure presenta;
  begin
     clrscr;
     gotoxy(1,1);write('NOMBRE ES    : ',datosciudades.nombre);
     gotoxy(1,2);write('EL PAIS ES   : ',datosciudades.pais);
     gotoxy(1,3);write('LA REGION ES : ',datosciudades.region);
     gotoxy(1,5|);write('Pulse [Enter]');
     readln;
  end;
 
  procedure guarda;
  begin
      assign(f,'TEMPORAL.DAT');
    {$I-} reset(f); {$I+}
    if ioresult <> 0 then
    begin
       rewrite(f);
       seek(f,0);
       write(f,datosciudades);
       close(f);
    end
  else
     begin
         seek(f,filesize(f));
         write(f,datosciudades);
         close(f);
     end;
  end;
 
  procedure menu;
  var
    tec : char;
    sal : boolean;
  begin
    sal := false;
    repeat
      clrscr;
      gotoxy(1,1);write('<<<< MENU GENERAL >>>>');
      gotoxy(1,3);write(' 1 = ENTRADAD');
      gotoxy(1,4);write(' 2 = PRESENTAR');
      gotoxy(1,5);write(' 3 = GUARDAR');
      gotoxy(1,6);write(' 4 = SALIR');
      gotoxy(1,8);write(' **** ELIJA OPCION ****');
      tec := readkey;
    case tec of
  #49 : entradas;
  #50 : presenta;
  #51 : guardar;
  #52 : sal := true;
    end;
   until sal = true;
  end;
  begin
  end.

{Como podéis apreciar los cambios son mínimos para convertirlo en

unidad}
{Repasemos el tema para entenderlo mejor.}
{Cambiamos [program por unit] y insertamos la [interface] esto

determina}
{que es visible y accesible a cualquier programa que la llame}
{Todo lo que se encuentra entre [interface] y [implementacion] lo

podrá}
{manejar el programa llamador las demás variables que están dentro

de}
{los procedimientos no.}
{Después como en el programa van los procedimientos o funciones que}
{están definidos arriba, y final mente termina con [begin y end.]}
{Si quisiéramos por ejemplo al cargar la unidad que limpiara el

registro}
{pondríamos entre begin [fillchar(datosciudades,sizeof(ciudad),' ')]

end.}
{cada vez que arranque la unidad limpiara el registro

[datosciudades]}

{Cadena de caracteres es una cantidad de caracteres ASCII

encerrados}
{entre comillas 'mi mama me ama' esto es la cadena y esto ' ' una

cadena}
{vacía el numero de caracteres dentro de las comillas indican la

longitud}
{de la cadena.}
{El carácter [#] seguido de un numero del [0 al 255] indica a pascal

que}
{es un carácter ASCII este numero tiene que ser un entero y no se

puede}
{poner separado ejemplo: [#123] indicara que es el carácter [{]

ASCII.}

{Los comentarios en un programa se ponen asi.}
function esistearchivo : boolean; {comentario aquí esta parte el}
{compilador no la lee solo sirve}
{como ayuda o información}
{pero siempre entre llave o (* comentario aquí esta parte el *) de}
{esta otra forma eso a elección del programador}

{Algunas de las directivas estándar de Turbo Pascal son}

{[absolute, assembler, export, external, far, forward, index}
{interrupt, near, private, public, resident, virtual] }

{[Absolute] = para declarar una variable absoluta (una variable}
{que reside en una dirección de memoria especifica, o absoluta)}
{ejemplo : var direccion : type absolute Seg:Ofs; esto especifica}
{directamente la dirección (segmento y desplazamiento de la

variable.}
{Ambas constantes deben estar en el rango de $0000 a $FFFF (0 a

65,535).}
{Cuando el Windows se esta ejecutando en modo protegido, la

aplicación}
{puede no tener derechos de acceso a reas de memoria fuera del

programa.}
{El intento de acceder a estas reas de memoria puede hacer fallar}
{al programa.}

{[assembler] = permite procedimientos y funciones completos en

ensamblador}
{incorporado, sin una sentencia begin...end.}
{Ejemplo :
function byteword(p1, p2 : byte) : word;assembler;
asm
mov ah,p1
mov al,p2
end;
{devolverá de estos dos bytes un word sin usar begin end.}

{[Export ] = La directiva export hace exportable a un procedimiento

o}
{función obligando a la rutina a usar el modelo de llamada lejana}
{ y generando código especial de entrada y salida a procedimiento.}
{Si se van a exportar procedimientos y funciones de una DLL, deben}
{ser compilados con la directiva de procedimiento export. Esto}
{significa que una directiva export, si esta presente, debe ser}
{especificada en la primera introducción de un procedimiento o

función}
{no puede ser proporcionada en la declaración de definición o en

una}
{declaración forward. La exportación real del procedimiento o

función}
{no tiene lugar hasta que el procedimiento o función es listado en

una}
{cláusula exports de una librería.}

{[External] = Las declaraciones external permiten enlazar con}
{procedimientos y funciones compilados por separado y escritos en}
{lenguaje ensamblador. El código externo se enlaza con las units o}
{programas en Pascal mediante directivas del compilador $L

nombrefichero.}
{En procedimientos y funciones importados de DLL, la directiva

external}
{toma el lugar de las partes de declaraciones y de sentencias que

estarían}
{presentes en otro caso.}
{Ejemplo : }
{function modovideo : Word; external;
procedure informevideo(Modo : Word); external; $L CURSOR.OBJ
function GlobalAlloc(Flags: Word; Bytes: Longint): THandle; far;

external
'KERNEL' index 15;}
{Estas llamadas a DLL solo se realizaran en modo protegido o

windows}


{mas informacion }

[tipos enteros]
Tipo Rango Tama¤o
Shortint 128..127 8 bits
Integer -32768..32767 16 bits
Longint -2147483648..2147483647 32 bits
Byte 0.255 8 bits
Word 0.65535 16 bits

[tipos reales]

Tipo Rango D¡gitos Bytes
real 2.9e-39..1.7e38 11-12 6
single 1.5e-45..3.4e38 7-8 4
double 5.0e-324..1.7e308 15-16 8
extended 3.4e-4932..1.1e4932 19-20 10
comp -9.2e18..9.2e18 19-20 8

[tipos booleanos]

Boolean = (False, True);
WordBool = (False, True);
LongBool = (False, True);
ByteBool = (False, True);

[funciones matemáticas]

Abs( X ) Toma absoluta el valor de X .
arctan( X ) Toma arcotangente de X .
Cos( X ) Toma del coseno de x .
Exp( X ) Toma exponencial ( en base e ) del argumento .
Frac( X ) Devuelve la fracción de X .
Int( X ) devuelve el entero parte de los X .
Ln( x ) Toma logaritmo base e de X .
PI devuelve el valor de pi .
Ronda( X ) Redondea x ( reales ) de un número entero .
sin( X ) Toma seno del X .
SQR( x ) Toma cuadrada de X .
sqrt( x ) Toma la raíz cuadrada de X .
trunc( x ) Trunca X w / o redondeo .
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 23/04/2012 21:17:12
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
{Este programa tiene muchos de los procedimientos y funciones con los cuales
trabajaremos en adelante.}
 
 {programa ejemplo pascal comentado realizaremos un pequeño editor.}
 {Para evitar fallos de presentación de símbolos expongo el tipo de}
 {configuración en Windows 7 profesional 32 bit.}
 {teclado PS/2 estándar configuración Español (Espada - alfab.}
 {Internacional con el representare los caracteres del programa.}
 program minieditor;
 {$M 65000,0,650000}
 uses
   crt, dos;
  const
     archivo : string = 'NombArch.xxx';
 
  type
     string7 = string[7];
     dattexto = array[0..500] of string[79];
  var
     dia, mes, ayo, diasem : word;
     xo, yo, opcion : integer;
     tecla : char;
     ejecuta, salir : boolean;
     texto : dattexto;
     tt, cont : integer;
 
  function toma_hora : string;
  var
     hor, min, seg, m : string[2];
     i : byte;
     regs : registers;
  begin
     regs.ah := $2c;
     msdos(regs);
     str(regs.cl:2,min);
     str(regs.dh:2,seg);
     for i := 1 to 2 do
     begin
        if min[i] = ' ' then
        min := '0';
        if seg[i] = ' ' then
        seg := '0';
     end;
   case regs.ch of
      0 : i := 12;
 13..23 : i := regs.ch - 12;
 else
     i := regs.ch;
   end;
   str(i:2,hor);
   if hor[1] = ' ' then
   hor[1] := '0';
   toma_hora := 'Hora : ' + hor + ':' + min;
 end;
 
  procedure marcadormenu(x,y : integer; menu : string7);
  begin
     TextBackground(7);
     gotoxy(x,y);write('        ');
     TextColor(0);
     gotoxy(x + 1,y);write(menu);
     TextBackground(0);
     TextColor(15);
  end;
 
  procedure Varramenu(x1, y1, opci : integer);
  var
    men : string7;
  begin
      gotoxy(2,1);write('ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ',
                          'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿');
      gotoxy(2,2);write('³');
      gotoxy(77,2);write('³');
      gotoxy(2,3);write('ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ',
                          'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ');
      gotoxy(78,2);write('Û');
      gotoxy(78,3);write('Û');
      gotoxy(3,4);write('ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß',
                        'ßßßßßßßßßßßßßßßßßßßßßßßßßßßß');
      gotoxy(4,2);write('Cargar    Salvar    Editar    Salir   Fecha : ');
      getdate(ayo,mes,dia,diasem);
      gotoxy(50,2);write(dia,'/',mes,'/',ayo);
      gotoxy(4,2);
   case opci of
  1 : men := 'Cargar';
  2 : men := 'Salvar';
  3 : men := 'Editar';
  4 : men := 'Salir';
   end;
      marcadormenu(x1,y1,men);
  end;
 
  procedure cargaarchivo;
  var
     nomb : string[12];
     f : text;
     pu, cha : char;
     n : integer;
  begin
      window(2,5,79,24);
      gotoxy(2,2);write('Entre Nombre Archivo : ');
      gotoxy(25,2);readln(nomb);
      assign(f,nomb);
      {$I-} reset(f); {$I+}
      if ioresult <> 0 then
      begin
         exit;
      end
   else
      begin
       clrscr;
       writeln('Contenido Del Archivo Nombre : ',nomb);
       writeln('---------------------------------------------');
       n := 0;
       window(2,8,79,24);
       while not Eof(F) do
       begin
         Read(F, Cha);
         Write(Cha);
         if cha = #10 then
         n := n + 1;
         if n > 16 then
         begin
            n := 0;
            textcolor(12);
            gotoxy(1,24);write('Pulse [ ',chr(25),' ]');
            textcolor(15);
            repeat
              pu := readkey;
            until pu = #80;
            clrscr;
         end;
       end;
         writeln;
         textcolor(12);
         gotoxy(2,17);write('Final Archivo Pulsa [Enter]');
         textcolor(15);
         readln;
         close(f);
         window(2,5,79,24);
         clrscr;
      end;
  end;
 
  procedure salvaarchivo(nu : integer;tex : dattexto);
  var
     nomb : string[12];
     f : text;
  begin
      if nu > 0 then
      begin
      window(2,5,79,24);
      gotoxy(2,1);write('Entre nombre y Extension : ');
      gotoxy(29,1);readln(nomb);
      assign(f,nomb);
   {$I-} reset(f); {$I+}
   if ioresult <> 0 then
   begin
       rewrite(f);
       for tt := 0 to cont do
       writeln(f,texto[tt]);
       close(f);
   end
  else
      begin
         writeln('El fichero Existe Pulse [Enter]');
         readln;
      end;
     end;
  end;
 
  procedure editartexto;
  var
    salir : boolean;
  begin
      window(2,5,79,24);
      gotoxy(5,1);write('*** EDITOR TEXTO 500 LINRAS CON READLN ',
                                          '[Espacio] Termina ***');
      window(2,7,79,24);
      salir := false;
      cont := 0;
    repeat
     readln(texto[cont]);
     if texto[cont] <> ' ' then
     cont := cont + 1;
    until texto[cont] = ' ';
    window(2,5,79,24);
    clrscr;
  end;
 
  procedure oculta_cursor;assembler;
  asm
     mov ah,3
     mov bh,0
     int $10
     or ch,$20
     mov ah,1
     int $10
  end;
 
  procedure muestra_cursor;assembler;
  asm
    mov ah,3
    mov bh,0
    int $10
    and ch,not $20
    mov ah,1
    int $10
  end;
 
  procedure menugeneral;
  begin
      TextBackground(0);
      clrscr;
      salir := false;
      opcion := 1;
      yo := 2;
      xo := 4;
      ejecuta := false;
      window(1,1,79,24);
      cont := 0;
     repeat
      varramenu(xo,yo,opcion);
      repeat
      gotoxy(62,2);write(toma_hora);
      oculta_cursor;
      until keypressed;
      tecla := readkey;
      muestra_cursor;
      if tecla = #77 then
      begin
         opcion := opcion + 1;
         if opcion > 4 then
         opcion := 4;
      end;
      if tecla = #75 then
      begin
          opcion := opcion - 1;
         if opcion < 1 then
         opcion := 1;
      end;
    if tecla = #13 then
    begin
        ejecuta := true;
    end;
   case opcion of
  1 : begin
        xo := 4;
        if ejecuta = true then
        begin
          cargaarchivo;
          ejecuta := false;
          clrscr;
          window(1,1,79,24);
        end;
      end;
  2 : begin
        xo := 14;
        if ejecuta = true then
        begin
          salvaarchivo(cont,texto);
          ejecuta := false;
          clrscr;
          window(1,1,79,24);
        end;
      end;
  3 : begin
         xo := 24;
         if ejecuta = true then
         begin
          editartexto;
          ejecuta := false;
          clrscr;
          window(1,1,79,24);
         end;
      end;
  4 : begin
         xo := 34;
         if ejecuta = true then
         begin
            salir := true;
            window(1,1,79,24);
         end;
      end;
    end;
      varramenu(xo,yo,opcion);
      until salir = true;
  end;
 
 
  begin
     menugeneral;
  end.

{Empecemos desde el principio del programa :}
Iniciamos con la cabecera del programa con su nombre.
Le sige la directiva de tama¤o de la asignaci¢n de Memoria
para el programa [$M segmento del stack, tama¤os m¡nimo, tama¤os m ximo del
heap].
Acontinuacion las unidades utilizadas en el programa cl usula uses.
Despues las constantes el nombre para el archivo pero al ser variable
podemos cambiarla cuando guardamos si no guardara con ese.
Lesige las asignaciones type en ella definimos un estring de una longitud
de 7 caracteres y un array de 0 a 500 string de 79 caracteres esto es
por la capacidad de la pantalla que es de 80 caracteres lor linea.
Podemos entrar los 79 o menos nunca mas de esos 79.
Luego las variables para el programa las primeras para la fecha,
las segundas para diferentes cuestiones como por ejemplo el menu,
la tercera para el caracter entrado del teclado en el menu,
la cuarta para establecer cierto o falso en algunas decisiones por
ejemplo para salir del menu,
la quinta es la variable de entrada de texto en el readln,
la sexta para contadores o entradas enteras.
La primera funcion toma la hora del sistema para presentarla en la
barra del menu esta funcion pertenece al dos y como podeis apreciar
trabaja con las interrucciones del dos y sus registros a entender
por encima su funcionamiento. Cargamos en el registro Ah Con la funccion
que en este caso es [2C] obtener la hora del sistema.
Y activamos la interrutcion [21] en este caso la encontramos en la variable
regs con Registers su forma es:
Registers = record
case Integer of
0: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: Word);
1: (AL, AH, BL, BH, CL, CH, DL, DH: Byte);
end;
y esta definida ya en la unidad [dos].
Esta interrupcion nos devuelve en [ch = hora],[cl = minuto], [dh ] segundo],
[dl = centesimas].
Esta interrupcion dependiendo de la funcion entrada realizara diferentes
operaciones a saber:
Intruducion de caracteres, salida de caracteres,terminacion de programa,
acceso a subdirectorios, gestion de memoria ram, acceso a drive res y
dispositivos, hora y fecha, zona de transferencia de disquetes,
registros de directorios, acceso a archivos FCB, acceso a archivos
Handle, llamadas de red, acceso a vectores de interrupcion, acceso a
disquetes y discos duros, acceso al PSP, acceso a las banderas del
dos, acceso a los atributos de archivos, acceso a parametros
especificos del pais, y otras.
Como veis un amplio abanico de posibilidades las cuales veremos
algunas en su momento.
Los procedimientos [str] transforman los valores numericos de los registros
en cadenas para su presentacion.
El [for] verifica que no sea espacio sino [0].
En el [case] aseguramos que sea 1 o 12 no otra cosa.
En el siguiente [str] lo mismo que antes convertimos a cadena.
El [for] verifica que no sea espacio sino [0].
El [procedure marcadormenu] crea el marcador del menu colocandolo en la
posicion [x,y] especificada y presenta la cadena o texto entrado.
El marcador lo creo con el color de fondo o sea [TextBackground] y
la letras con [textcolor] color del texto.
La barra del menu la realizo con los simbolor graficos de los caracteres
especiales como indique al inicio.
El [procedure Varramenu] con [x1,y1] como posicion en la pantalla y [opci]
el numero de opcion entrado.
Como podreis observar los [gotoxy] posicionan el cursor en una posicion dada
para escribir en ella con [write] esto nos permite dejar nuestro menu donde
nos parezca mejor.
El procedimiento [getdate(ayo,mes,dia,diasem);] de la unidad [dos] nos
facilota los datos de a¤o/mes/dia/dia de la semana = domingo ,lunes, martes,
miercoles, jueves, viernes, sábado, en numero [0..6].
Y [case] para tomar la opcion y marcar con [marcadormenu(x1,y1,men)].
El [procedure cargaarchivo] nos carga y muestra el contenido de un archivo
de texto como puede ser un *.pas o *.c, cualquiera que este como texto no
archivos con formato estos tienen otra forma de manejarlos desde pascal.
El tema de las variables ya esta comentado pero la variable [f] que hace
referencia a un fichero de texto y nos permite abrirlo y ver su contenido.
El procedimiento [window] nos permite abrir una ventana de texto se
encuentra en la unidad [crt], con el abro un espacio por debajo de la
barra de menu para que esta no sea borrada.
Las coordenadas 1,1 son para la ventana creada no para la pantalla.
Despues llamamos al archivo con [assign] y comprobamos que existe sino
esta salimos para ello se emplea [{$I-} reset(f) {$I+} y ioresult] que nos
informara si existe si o no, siendo [0] que existe y [otro]valor no.
Si existe leemos asta el final del archivo, presentando sus datos en
pantalla si fuera mayor que la pantalla lo presentaríamos en pantalla por
pantalla asta su fin.
Al final cerramos el archivo [close(f)] y abrimos la ventana a su valor
anterior limpiándola.
El [procedure salvaarchivo] salva el texto entrado en el editor de texto
que como vereis permite guardar unos 40 kb de datos.
Llamamos al archivo con [assign] y comprobamos que existe sino
esta lo creamos con [rewrite] y guardamos los datos en el.
Si existe informamos para que cambie el nombre y salimos.
El [procedure editartexto] nos edita el texto o sea el archivo, pero
como explicare tiene su faceta pobre puesto que solo se puede modificar,
la linea entrante y no un caracter si no todo asta el ejemplo :
[Paco tenia ud coche de lujo] si el error esta en [ud] tendriamos que
borrar todo asta el, puesto que [readln] no permite retroceder caracter
a caracter, por ello este editor es solo para ejemplo de comandos y
procedures/funciones para comprenderlas un poco mas.
Siempre que la entrada sea mayor que [' '] se estara editando las 500
lineas pasando de una a otra con [enter] si despues de [enter] se entra
[espacio y enter] termina la entrada de texto.
Podeis observar que todo se encuentra en ventanas [window].
Los [procedure oculta_cursor] y [procedure muestra_cursor] nos permiten
quitar el cursor de la vista y presentarlo otra vez.
Como comente antes es bueno ir conociendo a nuestro ayudante en muchos
casos que nos ayudara bien.
En [ah] colocamos la funcion [03] lectura de la posicion del cursor
en [bh] el numero de pagina [0], colocamos con un [or] de [ch] y [$20]
el cursor en la linea [35], entramos en [ah] la fucion [1] definicion
de aspecto del cursor y en [ch] tiene la linea de inicio del cursor que
es fuera de pantalla, y como la interrupcion [int $10] que es la
interrupcion de video.
[procedure muestra_cursor] es lo mismo pero una [and ch,not $20] nos pone
el cursor en 15, o sea dentro de pantalla lo presenta.
[procedure menugeneral] este se encarga de controlar el menu general
presentando y activando las opciones elegidas, como vereis esta explicado
todo su proceso como ventanas, gotoxy, write,etc.
Explicare la entrada readkey porsi acaso no lo habeis cazado.
Tenemos dos [repeat] uno para el menu en si y el otro para la pulsacion
de la tecla [keypressed], cuando pulsamos una tecla [keypressed] deja
seguir la operacion mientras que [tecla := readkey] comprueba que tecla
se pulso, los [#77] corresponde a la tecla de [flecha hacia abajo],
[#75] corresponde a la tecla de [flecha hacia arriba] mientras que
[#13] corresponde a [enter], con lo cual tomamos las decisiones que sean
oportunas segun la tecla pulsada.
En la proxima entraremos al manejo de arrays, registros y archivos si
creeis que asfalta informacion comentarlo y tocaremos cosas que e dejado
para segun vallamos entrando, resulta menos tedioso el aprender a sin.
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 02/05/2012 02:12:31
Hola Ramon, disculpa por no responderte a tiempo tuve fallas con el servicio de internet bueno podemos seguir con el curso
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 02/05/2012 22:32:09
Asta ahora todo se entiende puesto que entramos en zona mas complicada con array, registros,
archivos y algo de punteros no quisiera ser demasiado rápido el prosimio envió en esta semana.
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 08/05/2012 12:49:50
{Primero tratemos del array y matriz:
Consideremos el array como un archivador donde colocamos los datos
de amigos, en cada zona tendremos un amigo diferente y sus datos,
ejemplo: [Juan = array[1..5] of integer;] esto nos dejara guardar
5 datos de nuestro amigo Juan pero serán números enteros podían ser,
edad 20, teléfono 234567,nacido 1954, mes 5, día 20, por lógica solo
los números son validos.
Podíamos ponerlo como [nombres = array[1..5] of string;] con lo cual
en este caso seria una serie de caracteres o números pero como carácter
no numérico ejemplo : Manuel Hernández, Juan Serrano, Poco Méndez,
Gabriel Macías, Ambrosio Jiménez.
O cualquier otro dato como: [Shortint, Integer, Longint, Byte, Word,
fichero, objeto, puntero, registro, cadena, char.].
Para manejar un array primero tenemos que posicionarnos en el lugar
que vamos a tratar por ejemplo : que remos tomar el dato que se encuentra
en la posición 3 seria writeln(nombre[3]) resultado = Paco Méndez,
si deseamos entrar un dato seria readln(nombre[2]) cambiaria el dato
actual [Juan Serrano por el nuevo dato insertado.
Como podéis ver su manejo es simple solo con referenciar su posición
tanto para leer como escribir en el.
La matriz es como el array solo que ahora la referencia cambia puesto
que tenemos otro array dentro de el ejemplo : matriz = array[1..5,1..5]
of como el otro lo que deseéis, pero ahora tendréis no 5 sino 25 datos
para manejar esto seria matriz[1,1], matriz[1,2], matriz[1,3], matriz[1,4],
matriz[1,5] y ahora aumentamos a matriz[2,1] y realizamos otros 5 entadas
y pasamos a 3 con 1 asta final asta matriz[5,5] esto seria el final de la
matriz.
Esto no quiere decir que el acceso tenga que ser obligatoria mente secuencial
puede ser aleatorio.
Las matrices pueden ser de mas dimensiones por ejemplo :
matriz[1..5,1..5,1..5], o pueden ser de mas tampoco tienen que ser de
longitud igual pueden ser diferente ejemplo : matriz[1..20,1..4,1..2].
Para la lectura o escritura de estas matrices se sigue el mismo formato
délas otras o bien secuencial mente o aleatoria mente pero el acceso a
la posición 10,3,2 de la matriz daría este aspecto [matriz[10,3,2]
tomaríamos el dato o pondríamos el dato en esa posición de la matriz.
Creo que un ejemplo ayudara mas.
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
program arraymatriz;
  uses
     crt;
   var
      numeros : array[1..10] of integer; (un array de numeros enteros)
      matriz2 : array[1..6,1..10] of integer; (matriz de numeros enteros)
      matriz3 : array[1..3,1..4,0..1] of integer;(matriz de numeros enteros)
      i, s, p : integer; (apuntadores a las posiciones de las matriz y array)
 
   begin
      clrscr;
      for i := 1 to 10 do  (for para cargar el array)
      numeros[i] := 10 * i; (numero a cagar)
      for i := 1 to 6 do    (for para la matriz2 primera 1 a 6)
        for s := 1 to 10 do (for para la matriz2 segunda 1 a 10)
        begin
           matriz2[i,s] := 5 * s + i; (numero a cargar)
        end;
      for i := 1 to 3 do   (for matriz3 primero 1 a 3)
        for s := 1 to 4 do (for matriz3 segundo 1 a 4)
        begin
           for p := 0 to 1 do (for matriz3 tercero 0 a 1)
           matriz3[i,s,p] := 5 * p + s * i; (numero a cargar)
        end;
        writeln('El Array 1 a 10');   (presentamos Contenido Cargado)
        for i := 1 to 10 do
        write('  ',numeros[i]);
        writeln;
        writeln('Pulsa Enter');
        readln;
        writeln('La matriz 1 a 6 de 1 a 10');
        for i := 1 to 6 do
        begin
            for s := 1 to 10 do
            write('  ',matriz2[i,s]);
            writeln;
        end;
        writeln;
        writeln('Pulsa Enter');
        readln;
        writeln('La matriz 1 a 3 de 1 a 4 de 0 a 1');
        for i := 1 to 3 do
        begin
          for s := 1 to 4 do
          begin
             for p := 0 to 1 do
             write('  ',matriz3[i,s,p]);
             writeln;
           end;
           writeln;
           end;
           writeln('Pulsa Enter');
        readln;
   end.

De esto poco mas que decir iremos poco a poco viendo como lo implementamos
en nuestros programas.

[Los registros]
Los trataremos como una armario donde tenemos una seria de ropa y algunas
cosas mas, el registro nos permite colocar varias cosas diferentes en su
interior como puede ser un valor integer, uno string, uno real, uno char,
un puntero, un array o matriz, o otros todos al mismo tiempo y en la
misma variable ejemplo de estructura :

amigos = record
nombre : string;
telefono : word;
direcion : string;
xeso : char;
carne : longint;
end;
esto seria el registro como podéis apreciar se mezclan diferentes tipos
en un salo registro.
su variable seria :

var
amig : amigos;
esta sola variable contendrá todos los datos del registro.
Se podría haber creado un array de registros como :

var
amig : array[1..30] of amigos;
esto nos proporcionaría 30 registros de amigos en vez de uno pero
todo esta limitado por la memoria que pascal nos deja manejar que
no es mucha si queremos guardar muchos registros tendríamos asta
655 kb de memoria también limitada a menos dependiendo de las variables
que hayamos definido en nuestro programa un ejemplo:

1
2
3
4
5
6
7
8
9
10
11
12
program  memoria;
   uses
      crt;
    var
      memori : longint;
 
    begin
       clrscr;
       memori := maxavail;
       writeln('   ',memori / 1024:8:2,' Kb el tama¤o mayor libre del heap');
       readln;
    end.

Si colocáis mas variables veréis como la memoria disminuye poco a poco.
A claro maxavail es una funcion de la unidad [crt].

Siguiendo con los registros vamos a implementar un programa para ver como
los manejamos.}

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
program pequenaajenda;
  uses
    crt;
    type
      regajenda = record  {El registro de la ajenda}
            nombre  : string[40];
            apelli1 : string[40];
            apelli2 : string[40];
            direcci : string[80];
            telefon : word;
            movil   : longint;
            fnacim  : string[10];
          end;
  var
    ajenda : array[1..50] of regajenda; {Un array de registros 50}
    cont   : integer; {Contador del array}
    tecla  : char; {Para la seleccion del menu}
        f  : file of regajenda;  {Para guardar la ajenda}
 
  function entrada(xp, yp : integer;tip : char; td : integer) : string;
  var
    tre : char;
    dat : string[80];
    ps : integer;
  begin
      entrada := ' ';
      gotoxy(xp,yp);
      ps := 1;
    repeat
    tre := readkey;
    if tip in['n','N'] then
    begin
       if tre in[#48..#57] then
       begin
          dat[ps] := tre;
          dat[0] := chr(ps);
          gotoxy((xp - 1) + ps,yp);write(dat[ps]);
          ps := ps + 1;
          if ps > td then
          ps := td;
       end;
    end;
    if tip in['t','T'] then
    begin
        if tre in[#30..#126,#164,#167] then
        begin
        dat[ps] := tre;
        dat[0] := chr(ps);
        gotoxy((xp - 1) + ps,yp);write(dat[ps]);
          ps := ps + 1;
          if ps > td then
          ps := td;
       end;
      end;
    if tre = #8 then
    begin
       ps := ps - 1;
       if ps < 1 then
       ps := 1;
        dat[0] := chr(ps);
        dat[ps] := ' ';
        gotoxy((xp - 1) + ps,yp);write(dat[ps]);
    end;
    until tre = #13;
    if (tre = #13) and (ps > 1) then
    begin
       entrada := copy(dat,1,ps - 1);
    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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 08/05/2012 12:51: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
procedure mascaraentrada(cual : char);
  begin
      if upcase(cual) = 'E' then
      begin
      gotoxy(3,2);write('*** Entrada Datros Ajenda ***');
      end;
      if upcase(cual) = 'M' then
      begin
      gotoxy(3,2);write('*** Ver Datros Ajenda ***');
      end;
      gotoxy(5,5);write('Nombre           : ');
      gotoxy(5,6);write('1§ Apellido      : ');
      gotoxy(5,7);write('2§ Apellido      : ');
      gotoxy(5,8);write('Direccion        : ');
      gotoxy(5,9);write('N§ Telefon       : ');
     gotoxy(5,10);write('N§ Movil         : ');
     gotoxy(5,11);write('Fecha Nacimiento : ');
  end;
 
  procedure entrada_datos(h : integer;ne : char);
  var
     fin : boolean;
     tec : char;
      error, co : integer;
      tt : longint;
      tomado : string[80];
  begin
     fin := false;
     clrscr;
     co := h;
   repeat
     mascaraentrada('e');
     ajenda[co].nombre := entrada(24,5,'t',40);
     ajenda[co].apelli1 := entrada(24,6,'t',40);
     ajenda[co].apelli2 := entrada(24,7,'t',40);
     ajenda[co].direcci := entrada(24,8,'t',80);
     tomado := entrada(24,9,'n',10);
     val(tomado,tt,error);
     if error > 0 then
     begin
        delete(tomado,error,1);
        val(tomado,tt,error);
     end;
     ajenda[co].telefon := tt;
     tomado := entrada(24,10,'n',12);
     val(tomado,tt,error);
     if error > 0 then
     begin
        delete(tomado,error,1);
        val(tomado,tt,error);
     end;
     ajenda[co].movil := tt;
     ajenda[co].fnacim := entrada(24,11,'t',10);
     if ne in['e','E'] then
     begin
     gotoxy(24,13);write('Desea Entrar Mas Datos [S/N]');
     repeat
     tec := readkey;
     until tec in['s','S','n','N'];
     if tec in['s','S'] then
     begin
     co := co + 1;
     if co > 50 then
     fin := true;
     clrscr;
     end;
    end
   else
     fin := true;
   until (tec in['n','N']) or (fin = true);
   cont := co;
  end;
 
  procedure verdatos;
  var
    n : integer;
    tn : char;
    salir : boolean;
  begin
      clrscr;
      n := 1;
      salir := false;
      mascaraentrada('m');
      repeat
      gotoxy(24,5);clreol;
      gotoxy(24,6);clreol;
      gotoxy(24,7);clreol;
      gotoxy(24,8);clreol;
      gotoxy(24,9);clreol;
      gotoxy(24,10);clreol;
      gotoxy(24,11);clreol;
      gotoxy(24,13);clreol;
      gotoxy(24,5);write(ajenda[n].nombre);
      gotoxy(24,6);write(ajenda[n].apelli1);
      gotoxy(24,7);write(ajenda[n].apelli2);
      gotoxy(24,8);write(ajenda[n].direcci);
      gotoxy(24,9);write(ajenda[n].telefon);
      gotoxy(24,10);write(ajenda[n].movil);
      gotoxy(24,11);write(ajenda[n].fnacim);
      gotoxy(24,13);write('Desea Ver Mas Datos [S/N]');
      repeat
      tn := readkey;
      until tn in['n','N','s','S'];
      if tn in['n','N'] then
      salir := true
    else
      n := n + 1;
      if n > cont then
      n := cont;
      until (tn = #27) or (salir = true);
  end;
 
  procedure modificadatos;
  var
     tr : char;
     sal : boolean;
     nn : integer;
  begin
      clrscr;
      nn := 1;
      mascaraentrada('m');
      repeat
      gotoxy(24,5);clreol;
      gotoxy(24,6);clreol;
      gotoxy(24,7);clreol;
      gotoxy(24,8);clreol;
      gotoxy(24,9);clreol;
      gotoxy(24,10);clreol;
      gotoxy(24,11);clreol;
      gotoxy(24,13);clreol;
      gotoxy(24,5);write(ajenda[nn].nombre);
      gotoxy(24,6);write(ajenda[nn].apelli1);
      gotoxy(24,7);write(ajenda[nn].apelli2);
      gotoxy(24,8);write(ajenda[nn].direcci);
      gotoxy(24,9);write(ajenda[nn].telefon);
      gotoxy(24,10);write(ajenda[nn].movil);
      gotoxy(24,11);write(ajenda[nn].fnacim);
      gotoxy(24,14);write('Si Son Los Datos a Modificar Pulse [Enter]');
      gotoxy(24,15);write('Sino Otra Tecla');
      tr := readkey;
      if tr = #13 then
      begin
          clrscr;
          cont := nn;
          entrada_datos(nn,' ');
          tr := #27;
      end;
      nn := nn + 1;
      until tr = #27;
  end;
 
  procedure borraunaajenda;
  var
     nomb, ape1, ape2 : string[40];
     w, nume, nu : integer;
     datos : array[1..50] of regajenda;
     encontre : boolean;
  begin
      clrscr;
      nume := 0;
      encontre := false;
      gotoxy(2,1);write('Borramos Un Elento De La Ajenda');
      gotoxy(2,3);write('Nombre      : ');
      gotoxy(2,4);write('1§ Apellido : ');
      gotoxy(2,5);write('2§ Apellido : ');
      gotoxy(16,3);readln(nomb);
      gotoxy(16,4);readln(ape1);
      gotoxy(16,5);readln(ape2);
      for nu := 1 to cont do
      begin
        if (nomb = ajenda[nu].nombre) and (ape1 = ajenda[nu].apelli1) and
                          (ape2 = ajenda[nu].apelli2) then
         begin
             encontre := true;
             nume := nu;
         end;
      end;
       if encontre = true then
       begin
          w := 1;
          for nu := 1 to cont do
          begin
          if nu <> nume then
          begin
             datos[w] := ajenda[nu];
             w := w + 1;
          end;
         end;
          for nu := 1 to w - 1 do
          ajenda[nu] := datos[nu];
          cont := w - 1;
       end
     else
        begin
          clrscr;
  gotoxy(3,3);write('Dato No Encontrado Intentelo De Nuevo Pulse [Enter]');
         readln;
        end;
    end;
 
  procedure ordenararray;
  var
     temporal : regajenda;
     pri, ult : integer;
  begin
     clrscr;
     for pri := 1 to cont do
       for ult := cont downto pri do
       if ajenda[pri].nombre  > ajenda[ult].nombre then
       begin
           temporal :=  ajenda[pri];
           ajenda[pri]  := ajenda[ult];
           ajenda[ult] := temporal;
       end;
       gotoxy(4,3);write('Array Ordenado Pulsa [Enter]');
       readln;
  end;
 
  procedure salvadatos;
  var
     il : integer;
     as : longint;
  begin
      assign(f,'c:\tp\Agenda.dat');
    {$I-} reset(f); {$I+}
    if ioresult <> 0 then
    begin
         rewrite(f);
         for il := 0 to cont - 1 do
         begin
         seek(f,il);
         write(f,ajenda[1 + il]);
         end;
         close(f);
     end
  else
      begin
        as := filesize(f);
        for il := 0 to cont - 1 do
        begin
           seek(f,as + il);
           write(f,ajenda[1 + il]);
        end;
        close(f);
      end;
      clrscr;
      writeln(' Datos De Agenda Guardados En [Agenda.dat] Pulse [Enter]');
      readln;
  end;
 
  procedure cargadatos;
  var
     ds : integer;
     arch : longint;
  begin
     assign(f,'c:\tp\Agenda.dat');
    {$I-} reset(f); {$I+}
    if ioresult <> 0 then
    begin
        clrscr;
        writeln(' El Archivo [Agenda.dat] No Existe Pulse [Enter]');
        readln;
    end
  else
      begin
        arch := filesize(f) - 1;
        if arch > 49 then
        arch := 49;
        for ds := 0 to arch do
        begin
           seek(f,ds);
           read(f,ajenda[1 + ds]);
        end;
        close(f);
      end;
  end;
 
  procedure menu;
  var
    opci : char;
   begin
      opci := ' ';
      cont := 1;
      repeat;
      clrscr;
      gotoxy(30,2);write('<<<<< MENU GENERAL AGENDA >>>>>');
      gotoxy(30,4);write(' 1 = Entrada o Insertar Datos');
      gotoxy(30,5);write(' 2 = Visualizacion Datros');
      gotoxy(30,6);write(' 3 = Modificacion Datos');
      gotoxy(30,7);write(' 4 = Borrado De Una Agenda');
      gotoxy(30,8);write(' 5 = Ordenar Agenda');
      gotoxy(30,9);write(' 6 = Guardar Agenda');
      gotoxy(30,10);write(' 7 = Cargar Agenda');
      gotoxy(30,11);write(' 8 = Salir De Ajenda');
      gotoxy(36,14);write('Elija Opcion');
      tecla := readkey;
      case tecla of
  #49 : entrada_datos(cont,'e');
  #50 : verdatos;
  #51 : modificadatos;
  #52 : borraunaajenda;
  #53 : ordenararray;
  #54 : salvadatos;
  #55 : cargadatos;
  #56 : opci := 'S';
    end;
    until opci = 'S';
   end;
  begin
      clrscr;
      menu;
  end.
 
  {Espero que esto sirva para avanzar en nuestro curso, en la próxima
   Entraremos en punteros 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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 16/05/2012 20:54:35
{Empecemos con punteros.
Primero que es un puntero, un puntero es como una llave que nos permite
acceder a unas partes de la memoria del ordenador para depositar en
ella algo, dependiendo del tipo que apuntemos por ejemplo:
puntero : ^string;
puntero : ^integer;
puntero : ^real;
puntero : ^char;
puntero : ^word;
puntero : ^longint;
estos son algunas de las cosas que podremos guardar en esa parte de
memoria, pero para ello primero tenemos que asignarla mediante
los comandos new, getmem, lo cual creara un espacio de memoria para
lo que puntero se alla asignado.
Una ved terminado de vemos de liberar la memoria usada para otros programas
o para nosotros mismos, sino la memoria quedara bloqueado asta que vuelvas
a arrancar el ordenador, esto se logra con dispose, freemem, veremos como
funciona esto.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
uses
    crt;
 var
   p : ^real;  'Variable puntero real'
   rel : real; 'variable real simple'
 begin
    clrscr;
    writeln(' Memoria Livre  ',memavail); 'Mostramos la memoria libre'
    new(p);  'Asignsmos espacio a el real en este caso p apunta a la memoria'
    p^ := 100.20; 'Le asignamos el valor 100.20'
    writeln(' Memoria despues  ',memavail); 'Presentamos la memoria libre'
    rel := p^; 'Ponemos el contenido de la memoria en la variable rel'
    dispose(p); 'Liveramos la memoria'
    writeln(rel:8:2); 'presentamos el contenido de rel'
    writeln(' Memoria liverada  ',memavail);  'Mostramos la memoria libre'
    readln;
  end.


Este programa nos muestra el consumo de memoria y su liberación
posterior.
Lógicamente esto es como la primera vez que nos ponemos a trabajar
asta nos parece bonito y todo pero cuando entramos en profundidad
nos damos cuenta que se complica mas ya que se exige mas de nosotros
que cuando aprendemos.
Pero eso lo superaremos poco a poco.
En los punteros lo mejor es que podemos trabajar con toda la memoria
de nuestro ordenador aunque como veréis también tiene sus res tinciones,
como todo en esta vida.
Sigamos a un que esto se presente aquí no tendrá mucho uso de esta
forma puesto que existen otras estructuras mas complejas que si lo
necesitan por ejemplo:

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
type
     puntregdato = ^regdatos;
     regdatos = record
             nombre : string;
             direccion : string;
             provincia : string;
             region : string
             nDNI   : longint;
             telefono : word;
             imeil : string;
             a¤os : integer;
             sig, ant : puntregdato;
            end;
 
    var
      prime, ultimo, anteri, sigien : puntregdato;
 
   Esto si necesita de punteros puesto que es una estructura grande
    que toma mucha memoria, con ello podemos manejar al mismo tiempo
    unos pocos registros.
    Como ejemplo y para empezar a entrar en tema este programa dejara
    una idea mas clara de lo que explico.}
 
    program punterosimple;
    uses
       crt;
    type
       punteropantalla = ^pantallareg;
       pantallareg = record
              pos : array[1..80,1..50] of char;
                 end;
      var
        pant : array[0..3] of punteropantalla;
        tecla : char;
        k, l : byte;
        n : integer;
        m1, m2, m3 : word;
 
 
   function quevideo : word;
   begin
      if mem[$0000:$0449] = 7 then
      quevideo := $B000
   else
      quevideo := $B800;
   end;
 
   procedure llenapantalla(h : char);
   begin
       new(pant[n]);
       for l := 1 to 80 do
         for k := 1 to 50 do
         pant[n]^.pos[l,k] := h;
   end;
 
   begin
       clrscr;
       n := 1;
       m1 := memavail;
       new(pant[3]);
       pant[0] := ptr(quevideo,$0000);
       pant[3]^ := pant[0]^;
       llenapantalla('o');
       pant[0]^ := pant[n]^;
       readkey;
       pant[0]^ := pant[3]^;
       m2 := memavail;
       readkey;
       n := 2;
       llenapantalla('v');
       pant[0]^ := pant[n]^;
       readkey;
       pant[0]^ := pant[3]^;
       dispose(pant[1]);
       dispose(pant[2]);
       dispose(pant[3]);
       m3 := memavail;
       textbackground(0);
       clrscr;
       writeln('memoria inicio : ',m1);
       writeln('memoria medio  : ',m2);
       writeln('memoria final  : ',m3);
       writeln;
       writeln('Pulsa [Enter]');
       readln;
   end.


{Expliquemos el programa como podréis apreciar trabajamos con un
puntero a un array dirigido a pantalla de texto no grafica.
Primera mente creamos un registo y un puntero a el este es [punteropantalla],
después creamos una variable array de cuatro 0..3 punteros al registro,
Las otras variables son contadores i recogida de valores de memoria como
vereis.
Le sige una función que nos proporcionara la dirección base de la tarjeta
de video.
Cuando arrancamos el sistema en la dirección de memoria [mem[$0000:$0449]]
el sistema nos informa de que tarjeta tenemos si es mono o color desde
luego la mono es algo difícil ya pero porsiacaso probamos.
Le sigue un procedimiento para llenar las pantallas con caracteres según
el que queramos.
Después esta el programa en si que primeramente borramos la pantalla
ponemos a uno el contador de punteros y tomamos tamaño de memoria antes
de asignar nada.
Y [new] que Crea una nueva variable din mica y establece una variable tipo
puntero apuntando a ella en nuestro caso pant[3].
En [pant[0]] tomamos el contenido de la pantalla en este momento sin nada,
colocamos el contenido de pant[0] en pante[3] para preservar la pantalla
sin nada, llenamos la pantalla con [o], y creamos una nueva variable
dinámica en este caso pant[1] que en lo que tenemos en [n] en este momento
pasamos a pant[0] el contenido de pant[1] con lo cual lo vemos en pantalla,
ya que pant[0] apunta a la dirección de la tarjeta de video o sea a la
pantalla el traspaso de información es rápido.
Al pulsar una tecla pasamos a pant[0] el contenido de pant[3] lo cual
deja la pantalla sin nada.
Tomamos la cantidad de memoria empleada en este momento.
Ponemos [n] a 2 para la nueva pantalla.
Llenamos la pantalla con [v], y creamos una nueva variable.
Presentamos en pantalla lo nuevo con [pant[0]^ := pant[2]^] lo cual nos
llena la pantalla con [v].
Al pulsar una tecla ponemos [pant[0] = pant[3]] lo cual nos limpia la
pantalla y al mismo tiempo liberamos las variables puntero con
[dispose(pant[x])] y tomamos la memoria libre actual.
Borramos la pantalla asignamos el color de fondo a negro con
[textbackground(0)] y presentamos los datos de la memoria en sus fases.
Como veréis empezamos con punteros de registros y arrays, en la próxima
profundizáremos mas.
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 29/05/2012 18:50:15
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
{Despues de tratar un tipo de puntero empezaremos con conocer
  las diferentes formas de asignacion de memoria y su des asignacion
  tenemos a nuestra disposicion : [new asigna y dispose de asigna]
  [mark asigna y release des asigna] esta en diferencia a  [new y dispose]
  y un tercera es [getmem asigna y freemem des asigna] con relacion a
  estos nos permiten asignar la cantidad de memoria que queremos en
  diferencia a los otros dos.
  A clarado esto pasamos a manejar las listas enlazadas primero las
  simplemente enlazadas y después las doblemente enlazadas que como vereis
  son similares.
  Las listas simplemente enlazadas usan un puntero que apunta al registro o
  dato que le sigue, podiamos considerarlo como los vagones de un tren que
  son enlazados por medio del enganche pero que en un momento dado se
  puede separar o unir otro vagon al conjunto.
  Veamos un peque¤o ejemplo.}
 
  uses
    crt;
  type
     punteroejemp = ^ejemplo;
     ejemplo = record
           datos : string;
           sig : punteroejemp;
         end;
 
   {punteroejemp apunta a registro ejemplo en el se encuentra un
    campo denominado [sig] de finido como punteroejemp.
    nosotros somos los responsables de mantener los punteros en debidas
    condiciones para evitar un cuelgue de nuestro sistema por un descuido
    y entrar en zona inadecuada.
    Debe de tener un control de donde se comienza y donde termina la lista.
    Una lista simple como minimo necesita tres punteros uno para apuntar
    al comienzo otro para el actual y otro para el anterior.}
   var
     tecla : char;
     prime, anter, actu : punteroejemp;
 
   {Para procesar la lista secuencial mente desde el inicio al final
   se debe saber la posicion del primero que enlazo en la lista [anter]
   que apuntara al enlace anterior del actual haciendo que el puntero
   [sig] apunte al siguiente.
   Para conocer si existe algun enlace tenemos que comenzar nuestro
   programa asignando a [prime] el valor [nil].}
 
   procedure otroregistroentra;
   procedure entramosdatos;
   begin
       with actu^ do
       begin
          write('Introduzca Datos : ');
          readln(datos);
       end;
   end;
   {A qui entramos los datos al registro}
 
   begin
   if prime = nil then
   begin
       new(actu);
       entramosdatos;
       prime := actu;
       actu^.sig := nil;
      end
   else
      begin
          anter := actu;
          new(actu);
          entramosdatos;
          anter^.sig := actu;
          actu^.sig := nil;
      end;
    end;
   {La sentencia if compara si es el primero de los enlaces [prime = nil]
    si es cierto se crea el registro y pone en [prime] el valor de [actu]
    y asigna al campo se [actu^.sig] a nil.
    La siguiente entrada ya no es [prime] nil, ya que tomo el valor de [actu]
    por lo cual el proceso va a [else] donde asignamos al puntero [anter]
    el valor de [actu] y creamos una nueva entrada.
    Como podeis apreciar en este momento tenemos activos los tres punteros.
    Donde [actu] apunta a el entrado, [anter] apunta al anterior, y [prime]
    apunta al primero.}
 
    procedure listardatos;
    var
      ver : punteroejemp;
    begin
       ver := prime;
       while ver <> nil do
       begin
          with ver^ do
          writeln(datos);
          ver := ver^.sig;
        end;
        writeln;
        writeln('Pulse [Enter]');
        readln;
     end;
 
   {Aqui mostramos la forma de procesar la lista enlazada para su
   visualizacion en pantalla}
 
   procedure insertaprimero(entrada : string);
   var
      pt : punteroejemp;
    begin
        new(pt);
        pt^.datos := entrada;
        pt^.sig := prime;
        prime := pt;
    end;
    {Aqui mostramos la forma de procesar la lista enlazada para
    Insertar un elemento al principio de la lista}
 
    procedure insertafinal(entrada : string);
    var
      pt : punteroejemp;
    begin
        new(pt);
        pt^.datos := entrada;
        actu^.sig := pt;
        pt^.sig := nil;
        actu := pt;
    end;
    {Aqui mostramos la forma de procesar la lista enlazada para
    Insertar un elemento al Final de la lista}
 
    procedure insertamosporordendebalor(entrada : string);
    var
      rr, pp, pt : punteroejemp;
      nofin, salir : boolean;
    begin
       new(pt);
       pt^.datos := entrada;
       pp := prime;
       rr := prime;
       if pp^.datos > entrada then
       begin
          insertaprimero(entrada);
       end
     else
         begin
         salir := false;
         nofin := false;
     repeat
         rr := pp;
         pp := pp^.sig;
         if pp^.datos > entrada then
         begin
            salir := true;
            nofin := true;
         end;
     until (pp^.sig = nil) or (salir = true);
      if (salir = false) and (nofin = false) then
      begin
         insertafinal(entrada);
      end
    else
       begin
          pt^.sig := pp;
          rr^.sig := pt;
       end;
    end;
  end;
   {Aqui mostramos la forma de procesar la lista enlazada para
    Insertar un elemento por orden de la lista}
 
   procedure insertaregistro;
   var
     dat : string;
     tt : char;
   begin
       clrscr;
       writeln;
       write('Insertamos Entre Datos : ');
       readln(dat);
       writeln;
       writeln('  Pulse  1 = Al Principio   2 = Al Final   3 = Ordenado ',
       '  4 = Nada');
       writeln('  Elija Opcion');
       repeat
       tt := readkey
       until tt in[#49..#52];
    case tt of
  #49 : insertaprimero(dat);
  #50 : insertafinal(dat);
  #51 : insertamosporordendebalor(dat);
  #52 :;
     end;
   end;
   {A qui realizamos la insercion de un elemento en la lista}
 
   begin
       prime := nil;
 
      {Entonces lo primero que realizamos es poner [prime] a nil.}
    repeat
        clrscr;
          repeat
            write('1 = entrar datos  2 = listar datos  3 = Insertar   4  = final');
            tecla := readkey;
          until tecla in[#49..#52];
      if tecla = #49 then
      begin
         clrscr;
         otroregistroentra;
      end;
      if tecla = #50 then
      begin
         clrscr;
         listardatos;
      end;
      if tecla = #51 then
      begin
          clrscr;
          insertaregistro;
      end;
      until tecla = #52;
   end.
  {Aqui ejecutamos el menu y el programa}
 
  {Como esto resulta un poquito mas dificil de entender creo
   que con esto de momento alibiara buestras ganas de aprender
   puesto que luego trataremos los punteros doblemente enlazados
   que aunque son parecidos no son igual.
   Y tanbien trataremos las pilas como listas enlazadas.}
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 21/06/2012 19:30: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
{Espero que vallamos entendiendo a pascal puesto que a partir se esta empezaremos
con gráficos pero no olvidéis que todo lo visto asta esta se manejara también en los gráficos}
 
{Empecemos ablando de las listas doblemente enlazadas su aspecto
 Como las simplemente enlazadas pero con algunos punteros a la lista
 Mas para poder recorrerla de alante a tras y de atrás a lante esta
 Seria su estructura:
 
 punteroreg = ^punterodatos;
 punterodatos = record
                nombre : string;
                sig, ant : punteroreg;
              end;
 var
   prim, anter, ultim, actual : punteroreg;
 
 Esto representa una forma de lista doblemente enlazada como se puede
 Apreciar en vez de un puntero [sig] esta es añadido [ant] para guardar
 Enlace anterior al actual, el puntero [sig] toma el enlace siguiente,
 Se necesitan punteros para seguir la los enlaces tanto del principio
 Como del final.
 Al crear un enlace debemos mantener la posición del primero, la del
 Ultimo, la del actual y la del anterior al actual veamos una estructura.
 
 Iniciamos los punteros prim := nil; y ultim := nil; la entrada de registros
 Quedaría así:
 
 
 if prim = nil then  comprobamos si el primero es nil si loes entonces
 begin
     new(actual); creamos la primera variable
     readln(actual^.nombre); entramos los datos
     actual^.sig := nil; colocamos sus punteros a nil
     actual^.ant := nil;
     prim := actual; como es el primero ponemas prim y ultin como el
     ultim := actual;
   end
 else   pero si no es nil entonces preparamos la insercion
    begin
       anter := ultim; asignamos a ante la posicion de ultim
       new(actual); creamos la siguiente variable
       readln(actual^.nombre); entramos datos
       anter^.sig := actual; enlazamos con actual
       actual^.sig := nil ponemos sig de actual a nil
       actual^.ant := anter; enlazamos ant con anter
       ultim := actual; ponemos ultim como actual
     end;
   end;
   en la primera tendriamos una forma asi:
                  primer registro
                     --------
      ant = nil ----| nombre |----sig = nil
                     --|---|-
                       |   |----- prim = actual
                       |
                       |---------- ultim = actual
 
    en la segunda quedaria asi:
                   segundo registro
                       anter                 actual
                      --------  sig      --------
                     | nombre |---->--- | nombre |---- sig = nil
         nil ant ----|        |----<--- |        |
                      --|-----       ant ---|----
                        |                   |------- ultim = actual
                        |----- anter = ultim
 
 Así continuaría el enlace con el resto.
 Como podéis apreciar es un poco más entretenido que la simple enlazada
 Pero esto no es dificultad para seguir la practica nos ayudara mucho.
 Veamos un ejemplo de prueba.}
 
 {program listasdoble;
 uses
    crt;
    type
       listan = ^listanombres;
       listanombres = record
               nombre : string;
               sig, ant : listan;
             end;
  var
    prim, anter, ultim, actual : listan;
 
  procedure entradatos;
  var
    dat : string;
  begin
      clrscr;
      writeln('*** Entrada De Datos ***');
      writeln;
      write('Nombre : ');
      readln(dat);
      actual^.nombre := copy(dat,1,length(dat));
  end;
 
  procedure insertarregistro;
  begin
      if prim = nil then
      begin
          new(actual);
          entradatos;
          actual^.sig := nil;
          actual^.ant := nil;
          prim := actual;
          ultim := actual;
      end
   else
      begin
          anter := ultim;
          new(actual);
          entradatos;
          anter^.sig := actual;
          actual^.sig := nil;
          actual^.ant := anter;
          ultim := actual;
      end;
  end;
 
  procedure listarregistros;
  var
     tec : char;
   begin
       if prim <> nil then
       begin
          actual := prim;
          while actual <> nil do
          begin
              with actual^ do
              writeln(nombre);
              actual := actual^.sig;
          end;
          writeln;
          writeln('///// Pulse Una Tecla //////');
          readkey;
       end
    else
       begin
           clrscr;
           writeln;
           writeln('     Registros Vacios Entre Datos');
           writeln('     Pulse Una Tecla Para Segir');
           readkey;
       end;
   end;
 
 
 
  procedure menu;
  var
     tecl : char;
     sal : boolean;
  begin
     sal := false;
   repeat
   clrscr;
   writeln('******* Menu Principal *********');
   writeln;
   writeln('  1 = Entrada Nuevo Dato');
   writeln('  2 = Listar Los Datos');
   writeln('  3 = salir');
   writeln;
   writeln('<<<<< Elija Opcion >>>>>');
   repeat
       tecl := readkey;
   until tecl in[#49..#51];
  case tecl of
 #49 : begin clrscr;insertarregistro; end;
 #50 : begin clrscr; listarregistros; end;
 #51 : sal := true;
  end;
   until sal = true;
  end;
 
  begin
      prim := nil;
      ultim := nil;
      menu;
  end.}
 
  {Esto nos permitirá comprobar lo antes comentado de las listas
   Doblemente enlazadas}
 
  {pilas como listas enlazadas}
  {Que son las pilas son un tipo de listas limitada por las condidiones
  siguientes su acceso solo puede realizarse por la cabeza, los elementos
  se a¤aden siempre por la cabezade la lista y se anulan o quitan tambien
  por la cabeza.
  Vamos a implementar una pila como una lista enlazada.
 
  type
    punteropila = ^pilas;
    pilas = record
          nombre : string;
          sig : punteropila;
        end;
   var
     datopila : punteropila;
 
   Esta seria su estructura muy parecida a la lista simplemente enlazada
   pero con un solo puntero en vez de tres.
   Veamos como implementar un ejemplo de pila}
 
   {program manejopilas;
   uses
      crt;
   type
     punteropila = ^pilas;
     pilas = record
          nombre : string;
          sig : punteropila;
        end;
   var
     datopila : punteropila;
 
   function datoentrado : string;
   var
      da : string;
   begin
       clrscr;
       da := ' ';
       writeln(' **** Entrada Datos Pila ****');
       writeln;
       write(' Entre Dato : ');
       readln(da);
       datoentrado := copy(da,1,length(da));
   end;
 
   procedure meterdatos;
   var
     nuevo : punteropila;
   begin
      if datopila = nil then
      begin
          new(datopila);
          datopila^.nombre := datoentrado;
          datopila^.sig := nil;
      end
    else
       begin
           new(nuevo);
           nuevo^.nombre := datoentrado;
           nuevo^.sig := datopila;
           datopila := nuevo;
       end;
     end;
 
   procedure eliminadatosprimero;
   var
     tempo : punteropila;
     dat : string;
   begin
       if datopila <> nil then
       begin
           dat := datopila^.nombre;
           tempo := datopila;
           datopila := datopila^.sig;
           dispose(tempo);
           writeln;
           writeln('El Elemento a Nulado : ',dat);
           writeln;
           writeln('Pulsa Una Tecla');
           readkey;
       end
    else
       begin
          clrscr;
          writeln;
          writeln('La Pila Esta Vacia [Pulse Enter]');
          readln;
       end;
   end;
 
   procedure menu;
   var
     tecl : char;
     sal : boolean;
  begin
     sal := false;
   repeat
   clrscr;
   writeln('******* Menu Principal *********');
   writeln;
   writeln('  1 = Entrada Datos Pila');
   writeln('  2 = Anular 1§ Dato Pila ');
   writeln('  3 = salir');
   writeln;
   writeln('<<<<< Elija Opcion >>>>>');
   repeat
       tecl := readkey;
   until tecl in[#49..#52];
  case tecl of
 #49 : begin clrscr; meterdatos; end;
 #50 : begin clrscr; eliminadatosprimero; end;
 #51 : sal := true;
  end;
   until sal = true;
  end;
 
   begin
       datopila := nil;
       menu;
   end.}
 
 {La Estructura de la pila al entrar los datos quedaría así:
                   |---------------------------------|
             <-----| datos4   dato3   dato2    dato1 |
                   |---------------------------------|
 Queda como si fuera un bote donde metemos unas piezas ajustadas
 Y para poder sacar la primera que hemos metido tenemos que sacar
 Las ultimas entradas con lo cual el bote queda vació
 En la próxima veremos todo esto de los punteros en un programa
 Más completo y empezaremos con gráficos.}
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 24/06/2012 23:55:49
Hola Ramon, tenia tiempo que no entraba en la web del programador, veo que has colocado bueno ejemplos .... tengo que realizarlos
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 26/09/2012 22:06:53
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
{como comente aparte de los punteros que encontraremos en esta serie de programación
 gráfica empezare dejando un pequeño ejemplo de lo que se vera en el resto de la serie.
 En este caso es un programa que permite visualizar archivos de imagen tipo BMP de
 2 colores a 24 bits espero les guste esto es empezar.
 Como podréis apreciar el programa es una mezcla de pascal y ensamblador.
 esto es porque actual mente no se dispone de driveres de vídeo que trabajen con 24 bits y
 32 en pascal por lo cual debemos de preparar nuestros driveres para tal fin.
  Este programa esta echo con pascal 7.0 teniendo problemas para correr con freepascal.
 En cualquiera de sus versiones.
 Por causa del ensamblador del pascal 7.0 y del de freepascal Pudiéndose  acoplar a el de
 otra forma pero eso no entra en esta programación que solo trata pascal estándar pero mejorando
 los medios lo mejor que podamos al sistema actual de gráficos.
Se pasa en varias paginas por su tamaño.}
 
 program a8bmp;
 {$N+}{$G+}
 uses
    crt, dos;
   type
      string3 = string[3];
 
      string8 = string[8];
 
   const
     Camino : string = 'c:\tp\fotos12\'; {Camino donde estan las Imagenes}
 
     exten : string3 = 'bmp'; {Extension del Archivo}
 
  type
      BufferType = Array [0..64000] of Byte; {Buffer virtual}
      BufferPointer = ^BufferType;    {Puntero al buffer virtual}
 
      camposcabecera = record       {Cavecera del BMP}
           idenbmp : array[0..1] of char;
           tamanobmp : longint;
           reserva1  : word;
           reserva2  : word;
           inicioimag : longint;
        end;
 
   campoinformacion = record     {Cavecera de datos del BMP}
           tamanocabe : longint;
           tamanox    : longint;
           tamanoy    : longint;
           planoscolor : word;
           bitspixel   : word;
           compresion  : longint;
           tamaimagen  : longint;
           resolucionx : longint;
           resoluciony : longint;
           numerocolor : longint;
           coloresimpo : longint;
        end;
 
     colorreg = record       {Registro de color del BMP}
           Blue : Byte;
          Green : Byte;
            Red : Byte;
          reser : Integer;
        end;
 
    regcolor = record       {Registro de la Imagen}
          regazul  : byte;
          regverde : byte;
          regrojo  : byte;
          regreser : byte;
        end;
 
    paletabmp = array[0..255] of regcolor;  {El array del Registro imagen}
 
    colorrgb = record    {Registri Paleta color}
          rojo : byte;
          verde : byte;
          azul : byte;
        end;
 
    paletargb = array[0..255] of colorrgb;  {El array de la Paleta}
    paletavesa = array[0..255,0..2] of byte; {El array de la Palete vesa}
 
    pModeList = ^tModeList; {Puntero al array de listado de modos de video}
    tModeList = Array [0..255] of word; {Array de listado de modos de video}
    informevesa = record      {Registro cavecera de la vesa}
                  asignatura : array[1..4] of char;
                  nversion   : word;
                  punterofar : pchar;
                  capacidad  : longint;
                  codigos    : pmodelist;
              end;
 
   datosvesa = record    {Registro de informacion de la vesa}
               modo_flag   : word;
               ventana1    : byte;
               ventana2    : byte;
               granulacion : word;
               tamaventana : word;
               segventana1 : word;
               segventana2 : word;
               areavisible : pointer;
               viteslinea  : word;
               resolucionx : word;
               resoluciony : word;
               anchocaract : byte;
               altocaract  : byte;
               nbitplanes  : byte;
               bitporpixel : byte;
               membloques  : byte;
               mem_modelo  : byte;
               tamamemblok : byte;
         end;
 
   var           {Variables comunes del programa}
     f : file;
     Buffer : ^BufferType;
     dato1  : informevesa;
     dato2  : datosvesa;
     infocabe : camposcabecera;
     infoinfo : campoinformacion;
     bmpcol   : paletabmp;
     imagcol  : paletargb;
     colores, resul1, resul2 : word;
     comp : string[4];
     regs : registers;
     nomarch : array[1..40] of string[12];
     cargamos : string;
     dirinfo : searchrec;
     cag : integer;
     b : array[1..4] of byte;
     fondo : byte;
     temp : Byte;
     BPP : Byte;
     memor : array[0..12000] of byte;
     p, t, z, x, y : integer;
     modo : word;
     currentmode : Word;
     colorespixel, page, currentblock : Byte;
     clear, blanco, color : colorreg;
     getmaxy, screeny, screenx : Integer;
     paletav : paletavesa;
     byt : array[1..1024] of byte;
     tom, tex : string[37];
     sal : boolean;
 
 
   procedure tomachivos(ext : string3);  {Procedimiento para cojer los
                                          archivos BMP para el menu}
    var
       ii : integer;
    begin
      findfirst(camino + '*.' + ext, archive, dirinfo);
      ii := 1;
      while doserror = 0 do
      begin
         nomarch[ii] := dirinfo.name;
         ii := ii + 1;
         if ii > 40 then
         ii := 40;
         findNext(dirinfo);
      end;
        cag := ii - 1;
   end;
 
  procedure menuarchivos;     {Menu para seleccionar la imagen BMP}
  var
     tec : char;
     gg, n, t, yy, xx, cot : integer;
  begin
      textbackground(0);
      clrscr;
      tomachivos(exten);
      clrscr;
      gotoxy(12,1);write('*** Elija Archivo A Visualizar ***');
      cot := 1;
      yy := 3;
      xx := 3;
      repeat
      textcolor(15);
      gotoxy(xx, yy);write(nomarch[cot]);
      xx := xx + 15;
      if xx > 60 then
      begin
         xx := 3;
         yy := yy + 1;
         if yy > 22 then
         yy := 22;
      end;
      cot := cot + 1;
      until cot > cag;
      xx := 3;
      yy := 3;
      cot := 1;
    repeat
      textbackground(2);
      gotoxy(xx - 1,yy);write('              ');
      textcolor(15);
      gotoxy(xx,yy);write(nomarch[cot]);
      textbackground(0);
      tec := readkey;
      gotoxy(xx - 1,yy);write('              ');
      textcolor(15);
      gotoxy(xx,yy);write(nomarch[cot]);
  if tec = #77 then
  begin
      xx := xx + 15;
      cot := cot + 1;
      if (xx > 48) and (cot < cag) then
      begin
         xx := 3;
         yy := yy + 1;
         end;
         if cot > cag then
         begin
            xx := xx - 15;
            cot := cag;
         end;
      end;
  if tec = #75 then
  begin
      xx := xx - 15;
      cot := cot - 1;
      if xx < 3 then
      begin
         xx := 48;
         if yy > 3 then
         yy := yy - 1;
      end;
       if cot < 1 then
       begin
           cot := 1;
           xx := 3;
       end;
  end;
   if tec = #80 then
   begin
       if (cag mod 4) = 0 then
       gg := 2
     else
       gg := 3;
       if (yy < round(cag / 4) + gg) and (cot < cag) then
       begin
       yy := yy + 1;
       t := 4;
       cot := cot + t;
      end;
   end;
   if tec = #72 then
   begin
       if yy > 3 then
       begin
       yy := yy - 1;
       t := 4;
       cot := cot - t;
      end;
   end;
   until tec = #13;
   cargamos := camino + nomarch[cot];
   textbackground(0);
   textcolor(15);
   clrscr;
  end;
 
  procedure cargacabecerayinformeycolor(archi : string);  {Procedimiento
                                                          para cargar las
                                                          caveceras del BMP}
 
  begin
     assign(f,archi);
  {$I-} reset(f,1); {$I+}
  if ioresult <> 0 then
  begin
     writeln('Archivo No Encontrado o Da¤ado pulse [Enter]');
     readln;
     halt(1);
  end;
  if exten = 'BMP' then
  begin
  blockread(f,infocabe,sizeof(camposcabecera),resul1);
  blockread(f,infoinfo,sizeof(campoinformacion),resul2);
  if infoinfo.bitspixel <= 8 then  {Cargamos los colores de la paleta si
                                    devemos cargarlos}
  blockread(f, bmpcol,infocabe.inicioimag - (resul1 + resul2),colores);
  close(f);
  end;
 end;
 
 procedure presentadatosbmp(nom : string); {Presentamos los datos del BMP}
 begin
     cargacabecerayinformeycolor(nom);
     if exten = 'BMP' then
     begin
     clrscr;
     writeln('***** Informacion Archivo *****');
     writeln('-------------------------------');
     writeln;
     writeln('Tipo De Archivo Es            = ',infocabe.idenbmp[0],
                               infocabe.idenbmp[1],'P');
     writeln('tama¤o cabecera y informacion = ',resul1 + resul2,' Bytes');
     writeln('Inicio Imagen En La Posicion  = ',infocabe.inicioimag,' Bytes');
     colorespixel := infoinfo.bitspixel;
     if infoinfo.bitspixel <= 8 then
     begin
     writeln('Tama¤o Paleta de color        = ',infocabe.inicioimag -
                                               (resul1 + resul2),' Bytes');
     writeln('Los Colores De La Paleta Son  = ',
               (infocabe.inicioimag - (resul1 + resul2)) div 4,' colores');
     end
  else
     writeln('Los Colores De La Paleta Son  = ',infoinfo.bitspixel);
     writeln('Los Planos De Color Son       = ',infoinfo.planoscolor);
     writeln('Tama¤o Del Archivo Total      = ',infocabe.tamanobmp,' Bytes');
 
     writeln('Tama¤o De La Imagen           = ',infoinfo.tamaimagen,' Bytes');
     writeln('Longitud  De X                = ',infoinfo.tamanox,' Pixeles');
     writeln('Longitud  De Y                = ',infoinfo.tamanoy,' Pixeles');
     case infoinfo.compresion of
   0 : comp := 'No';
   1 : comp := 'RLE8';
   2 : comp := 'RLE4';
    end;
     writeln('Compresion                    = ',comp);
     writeln('Resoluccion X                 = ',infoinfo. resolucionx);
     writeln('Resoluccion y                 = ',infoinfo. resoluciony);
     writeln('Numero Colores De La Imagen   = ',infoinfo.numerocolor);
     writeln('Numero De Colores Importantes = ',infoinfo.coloresimpo);
     writeln;
     writeln('***** Pulse [Enter] *****');
     readln;
   end;
 end;
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 26/09/2012 22:08:31
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
{Continuación}
 
 function text(dd : string) : string; {Preparamos el Mensaje}
   begin
     text := ' ';
     tex := 'El Archivo Cargado Es = ';
     t := length(dd);
     fillchar(tom,13,' ');
     tom[0] := chr(12);
     p := 12;
     tom[0] := chr(p);
     sal := false;
    repeat
    if dd[t] <> '\' then
    begin
      tom[p] := dd[t];
      p := p - 1;
    end
  else
     begin
        sal := true;
     end;
    t := t - 1;
    until (sal = true) or (t < 1);
    for t := 1 to 12 do
    begin
    if tom[t] = ' ' then
    delete(tom,1,1);
    end;
     tex := tex + tom;
     text := tex;
   end;
 
   procedure putpixel(x, y : integer; colo : word); {Escrivimos un pixel
                                                     en pantalla asta 16
                                                     colores}
   begin
       {Reducimos La imagen para que entre en pantalla si es necesario}
       if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then
       begin
          x := round(x * (500 / infoinfo.tamanox));
          y := round(y * (350 / infoinfo.tamanoy));
       end;
     asm
      mov ah,0Ch
      mov al,byte(colo)
      mov bx,0
      mov cx,x
      mov dx,y
      int 10h
    end;
   end;
 
 procedure  ponpixeltodos(x, y : word; col : byte);{Ponemos todos los pixeles
                                                    sea cual sea su modo de
                                                    video}
 var
    banco : word;
    despla : longint;
    blue, green, red : byte;
  procedure setbtex(x1, y1 : Integer);
   Begin
     temp := (((longint(y1) * screenx * (bpp shr 3) + x1)) shr 16);
     if currentblock <> temp then
     begin
          asm
             mov ax,$4f05
             xor bh,bh
             mov dl,temp
             int $10
          end;
          currentblock := temp;
      end;
   end;
  begin
     blue := 255;
     green := 255;
     red := 255;
     if modo = $101 then {Para modo 256 colores}
     begin
       col := 255;
       despla := longint(y) * 640 + x;
       banco := despla shr 16;
       despla := despla - (banco shl 16);
       if banco <> page then
       begin
        page := banco;
        asm
          mov ax, 4F05h
          mov dx, banco
          int 10h
        end;
     end;
      asm
        mov ax, 0A000h
        mov es, ax
        mov di, word(despla)
        mov al, col
        mov es:[di], al
     end;
   end;
   if modo = $12 then  {Para modo de 2/16 colores}
   begin
     asm
      mov ah,0Ch
      mov al,byte(col)
      mov bx,0
      mov cx,x
      mov dx,y
      int 10h
    end;
   end;
   if modo = $111 then  {Para modo de 24 bit}
   begin
        setbtex(x * 2,y);
        mem[$a000 : ((x + y * screenx) * 2 + 0) - currentblock shl 16] :=
          (blue shr 3) and 31 + ((green shr 3) shl 7) and 224;
        setbtex(x * 2 + 1,y);
        mem[$a000 : ((x + y * screenx) * 2 + 1) - currentblock shl 16] :=
          (((green shr 3) shr 2) and 7) + (((red shr 3) shl 3) and 248);
      end;
   end;
 
   procedure outtextxy(x, y : word; texto : string); {Escrivimos texto en
                                                      Pantalla}
   var
      lx, ly : word;
      bit, posf, font, posi : byte;
      i, t : integer;
  begin
     ly := y;
   for posi := 1 to Length(texto) do
   begin
      lx := x;
      y := ly;
   for posf := 0 to 7 do
   begin
       font := mem[$ffa6:$e + (ord(texto[posi]) shl 3) + posf];
       if ord(texto[posi]) = 164 then   {Representacion de la ¤}
       begin
       if posf = 0 then
       begin
       ponpixeltodos((x - 1) + 1, y - 1, 15);
       ponpixeltodos((x - 1) + 2, y - 2, 15);
       ponpixeltodos((x - 1) + 3, y - 2, 15);
       ponpixeltodos((x - 1) + 4, y - 1, 15);
       ponpixeltodos((x - 1) + 5, y - 1, 15);
       ponpixeltodos((x - 1) + 6, y - 2, 15);
       end;
       font := mem[$ffa6:$e + (110 shl 3) + posf];
       end;
       if ord(texto[posi]) = 165 then  {Representacion de la ¥}
       begin
       if posf = 0 then
       begin
       ponpixeltodos((x - 1) + 1, y - 2, 15);
       ponpixeltodos((x - 1) + 2, y - 3, 15);
       ponpixeltodos((x - 1) + 3, y - 3, 15);
       ponpixeltodos((x - 1) + 4, y - 2, 15);
       ponpixeltodos((x - 1) + 5, y - 2, 15);
       ponpixeltodos((x - 1) + 6, y - 3, 15);
       end;
       font := mem[$ffa6:$e + (78 shl 3) + posf];
       end;
         for bit := 7 downto 0 do
         begin
          if (font and (1 shl bit)) <> 0 then
          ponpixeltodos(x, y, 15);
          x := x + 1;
          end;
          y := y + 1;
          x := lx;
        end;
          x := x + 8;
       end;
     end;
 
 procedure bmp16colores(nom : string);  {Cargamos BMP 16 colores}
 var
   pal : paletargb;
   xx, yy, cargado, longitux, tomados, longituy, colores : word;
   memoria, infor, planos : word;
   dirpixel, colorpixel : byte;
 
 procedure SetAllPalrgb(var pal ; n : integer);
 var
  i : byte;
 begin
  for i := 0 to 15 do
  begin
    asm
     mov bl,i
     mov bh,i
     mov ah,$10
     mov al,$00
     int $10
  end;
 end;
 asm
  mov ah,$10
  mov al,$12
  mov bx,0
  mov cx,n
  les dx,pal
  int $10
  end;
 end;
 
  procedure loadbmp(x, y : integer; name : string);
  var
    j, i : integer;
  begin
   assign(f,name);
   reset(f,1);
   infor := infoinfo.tamanocabe - 4;
   cargado := infor;
   planos := ord(infor <> 8);
   longitux := infoinfo.tamanox;
   longituy := infoinfo.tamanoy;
   colores := 1 shl infoinfo.bitspixel;
   tomados := 8 * (longitux div 8) + 8 * ord(longitux mod 8 <> 0);
   tomados := tomados div 2;
     for i := 0 to colores - 1 do
      begin
         pal[i].rojo := bmpcol[i].regrojo div 4;
         pal[i].verde := bmpcol[i].regverde div 4;
         pal[i].azul := bmpcol[i].regazul div 4;
      end;
         setallpalrgb(pal,colores);
         memoria := tomados * (12000 div tomados);
         cargado := memoria;
         xx := 0;
         yy := 0;
         seek(f,infocabe.inicioimag);
         while cargado = memoria  do
          begin
           blockread(f,memor,memoria,cargado);
             for j := 1 to cargado div tomados do
              for i := 0 to longitux - 1 do
               begin
                xx := x + i;
                yy := y + longituy - j;
                dirpixel := memor[(j - 1) * tomados + 1 + i div 2];
                colorpixel := (dirpixel shr 4) * ((i + 1) mod 2) +
                 (dirpixel and 15) * ((i + 2) mod 2) ;
                putpixel(xx,yy,colorpixel);
              end;
               y := y - cargado div tomados;
           end;
    close(f);
  end;
  begin
      Loadbmp(3,1,cargamos);
  end;
 
 
 procedure  bmp1colores(nom : string);  {Cargamos BMP de 2 colores}
 var
    k, j, i : integer;
 begin
      assign(f,nom);
      reset(f,1);
      seek(f,infocabe.inicioimag);
       for j := infoinfo.tamanoy - 1 downto 0 do
       begin
         i := 0;
         repeat
          blockread(f,b,4);
          k := 1;
           repeat
            if b[k] and $80 > 0 then
            putpixel(i,j,15)
        else
            putpixel(i,j,0);
            inc(i);
            b[k] := b[k] shl 1;
            if I mod 8 = 0 then
            inc(k);
          until k > 4;
        until i > infoinfo.tamanox - 1;
     end;
     close(f);
 end;
   {Estos procedimientos para la palketa de colores son 6}
   procedure establecer_un_registro_paleta(num, color : byte);
   begin
     asm
      mov bl,num       {Numero del registro}
      mov bh,color     {Numero de color}
      mov ah,10h       {Funcion}
      mov al,00h       {Subfuncion}
      int 10h          {Interruccion}
    end;
   end;
 
 procedure lee_registro_paleta(num : byte; var valor : byte);
 var
    colo : byte;
 begin
   asm
     mov bl,num      {Numero del registro}
     mov ah,10h      {Funcion}
     mov al,07h      {Subfuncion}
     int 10h         {Interruccion}
     mov colo,bh;   {Numero de color}
    end;
    valor := colo;
 end;
 
 procedure establece_registro_individual_paleta(num : integer; rojo,
                                                 verde, azul : byte);
 begin
  asm
    mov ah,10h      {Funcion}
    mov al,10h      {Subfuncion}
    mov bx,num      {Numero del registros}
    mov dh,rojo     {Tomamos valor del rojo}
    mov ch,verde    {Tomamos valor del verde}
    mov cl,azul     {Tomamos valor del azul}
    int 10h         {Interruccion}
  end;
 end;
 
 procedure lee_registro_individual_paleta(num : integer; var rojo,
                                             verde, azul : byte);
 var
    r, v, a : byte;
 begin
   asm
    mov ah,10h      {Funcion}
    mov al,15h      {Subfuncion}
    mov bx,num      {Numero del registros}
    int 10h         {Interruccion}
    mov r,dh        {Tomamos los valores de rojo}
    mov v,ch        {Tomamos los valores de verde}
    mov a,cl        {Tomamos los valores de azul}
   end;
     rojo := r;
     verde := v;
     azul := a;
 end;
 
  Procedure establecepaletacolores(nm : byte);
  var
    k, nu : byte;
    rojo, verde, azul : byte;
  begin
   for k := 0 to nm do
   begin
   lee_registro_paleta(k,nu);
   establecer_un_registro_paleta(k,k);
   lee_registro_individual_paleta(nu, rojo, verde, azul);
   establece_registro_individual_paleta(k, rojo, verde, azul);
   end;
 end;
 
   procedure ponpaletargb(var pal; num : integer);
   begin
     asm
      mov ah,10h {Funcion}
      mov al,12h {Subfuncion}
      mov bx,0h  {Numero del primer registro}
      mov cx,num {Numero del registros}
      les dx,pal {Direccion de la paleta o buffer}
      int 10h    {Interruccion}
    end;
  end;
 
 
  procedure iniciograf(modo : word); {Iniciamos Graficos Vesa}
  begin
 
   asm
      mov ax,4f02h {Inicio grafico vesa}
      mov bx,modo  {Modo video}
      int 10h      {Interruccion video}
     end;
     bpp := 16; {}
     screenx := 640; {Tama¤o pantalla x}
     screeny := 480; {Tama¤o Pantalla y}
  end;
 
  procedure closegraficos;  {Terminamos graficos Vesa}
  begin
  asm
   mov ah,00h
   mov al,03h
   int 10h
   end;
   bpp := 0;
   screenx := 80;
   screeny := 24;
  end;
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 26/09/2012 22:13:26
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
{El total del Programa}
 
 procedure color24bits(xpos, ypos : integer); {Cargamos imagen 24 bit}
   procedure setblock(x1, y1 : Integer);
   Begin
     temp := (((longint(y1) * screenx * (bpp shr 3) + x1)) shr 16);
     if currentblock <> temp then
     begin
          asm
             mov ax,$4f05
             xor bh,bh
             mov dl,temp
             int $10
          end;
          currentblock := temp;
      end;
   end;
  procedure putpixel1(x1,y1 : Integer; color, clearcolor : colorreg);
  var
    z : byte;
   begin
   if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then
     begin
         x1 := round(x1 * (500 / infoinfo.tamanox));
         y1 := round(y1 * (350 / infoinfo.tamanoy));
     end;
   with color do
   begin
        setblock(x1 * 2,y1);
        mem[$a000 : ((x1 + y1 * screenx) * 2 + 0) - currentblock shl 16] :=
          (blue shr 3) and 31 + ((green shr 3) shl 7) and 224;
        setblock(x1 * 2 + 1,y1);
        mem[$a000 : ((x1 + y1 * screenx) * 2 + 1) - currentblock shl 16] :=
          (((green shr 3) shr 2) and 7) + (((red shr 3) shl 3) and 248);
   end;
  end;
 
  function presentabmp(xx, yy : Integer; nomb : String; docolors : boolean;
                                      clear : colorreg) : boolean;
    begin
     assign(f, nomb);
     reset(f,1);
     with infoinfo do
     if bitsPixel = 24 then
     begin
        blockread(f, memor, infocabe.inicioimag);
        z := (infoinfo.tamanox * bitspixel) shr 3;
          while z mod(4) <> 0 do Inc(z);
          color.reser := -1;
          bitspixel := (bitspixel shr 3);
        for y := infoinfo.tamanoy - 1 downto 0 do
        begin
          blockread(f, memor, z);
          for x := 0 to infoinfo.tamanox - 1 do
          begin
             color.blue  := ord(memor[x * bitspixel + 0]);
             color.green := ord(memor[x * bitspixel + 1]);
             color.red   := ord(memor[x * bitspixel + 2]);
             putpixel1(xx + x, yy + y, color, clear);
          end;
        end;
     end;
     close(f);
  end;
  begin
     modo := $111;
     iniciograf(modo);
     currentmode := modo;
     presentabmp(1,1,cargamos,true, blanco);
     if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then
     getmaxy := (round(infoinfo.tamanoy * (350 / infoinfo.tamanoy))) + 10
   else
     getmaxy := infoinfo.tamanoy + 10;
     outtextxy(40, getmaxy, text(cargamos));
     repeat
     until keypressed;
     closegraficos;
  end;
 
  procedure presentaimagen8(colr : array of regcolor); {presentamos Imagen
                                                        de 256 colores}
   var
     xx, yy, cont : integer;
     linea : longint;
   procedure putpixel256(x, y : word; c : byte);
   VAR
      banco : word;
      despla : longint;
   BEGIN
    if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then
    begin
          x := round(x * (500 / infoinfo.tamanox));
          y := round(y * (350 / infoinfo.tamanoy));
    end;
    despla := longint(y) * 640 + x;
    banco := despla shr 16;
    despla := despla - (banco shl 16);
    if banco <> page then
    begin
    page := banco;
    asm
      mov ax, 4F05h
      mov dx, banco
      int 10h
    end;
  end;
  asm
    mov ax, 0A000h
    mov es, ax
    mov di, word(despla)
    mov al, c
    mov es:[di], al
   end;
 end;
   begin
      assign(f,cargamos);
      reset(f,1);
         for cont := 0 to 255 do
         begin
            paletav[cont,0] := colr[cont].regrojo shr 2;
            paletav[cont,1] := colr[cont].regverde shr 2;
            paletav[cont,2] := colr[cont].regazul shr 2;
         end;
       modo := $101;
       iniciograf(modo);
       establecepaletacolores(255);
       ponpaletargb(paletav,255);
       seek(f,infocabe.inicioimag);
 linea := 4 * (infoinfo.tamanox div 4) + 4 * ord(infoinfo.tamanox mod 4 <> 0);
      for yy :=  infoinfo.tamanoy - 1 downto 0 do
      begin
        blockread(f,byt,linea);
        for xx := 0 to linea  do
        begin
           putpixel256(xx,yy,byt[xx]);
        end;
      end;
      close(f);
      if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then
     getmaxy := (round(infoinfo.tamanoy * (350 / infoinfo.tamanoy))) + 10
   else
     getmaxy := infoinfo.tamanoy + 10;
     outtextxy(40, getmaxy, text(cargamos));
      readkey;
      closegraficos;
   end;
 
  procedure cargaimagenesBmp; {Elije imagen a cargar segun elegida}
  begin
       presentadatosbmp(cargamos);
       if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then
       begin
          getmaxy := round(infoinfo.tamanoy * 0.50);
       end
     else
        getmaxy := infoinfo.tamanoy + 25;
 
       if (infoinfo.bitspixel = 1) or (infoinfo.bitspixel = 4) then
       begin
       asm
         mov ax,0012h
         int 10h
       end;
         modo := $12;
         if infoinfo.bitspixel = 4 then
         bmp16colores(cargamos);
         if infoinfo.bitspixel = 1 then
         bmp1colores(cargamos);
         if (infoinfo.tamanox > 639) or (infoinfo.tamanoy > 479) then
     getmaxy := (round(infoinfo.tamanoy * (350 / infoinfo.tamanoy))) + 10
   else
         getmaxy := infoinfo.tamanoy + 10;
         outtextxy(40, getmaxy, text(cargamos));
         readkey;
       asm
         mov ax,0003h
         int 10h
       end;
      end;
      if infoinfo.bitspixel = 8 then
      begin
          presentaimagen8(bmpcol);
      end;
      if infoinfo.bitspixel = 24 then
      begin
          color24bits(0,0);
      end;
  end;
 
  procedure elijevisualizar;  {El menu jeneral}
  var
     salir : boolean;
     opci : char;
  begin
    salir := false;
    fondo := 0;
    repeat
      clrscr;
      writeln('***** Menu De Visualizacion Imagenes *****');
      writeln;
      writeln(' B = Imagenes BMP');
      writeln(' S = Salir');
      writeln;
      writeln('<<< Elija Opcion >>>');
     repeat
      opci := upcase(readkey);
     until opci in['B','J','S'];
    case opci of
  'B' : begin clrscr; exten := 'BMP'; menuarchivos; cargaimagenesBmp; end;
  'S' : salir := true;
  end;
    until salir = true;
  end;
 
  function estalavesa : boolean;
  begin
      asm
         mov ax,4f00h
         mov bx,seg dato1.asignatura[1]
         mov es,bx
         mov di,offset dato1.asignatura
         int 10h
      end;
      if (dato1.asignatura[1] = 'V') and (dato1.asignatura[2] = 'E') and
         (dato1.asignatura[3] = 'S') and (dato1.asignatura[4] = 'A') then
       estalavesa := true
     else
       estalavesa := false;
       closegraficos;
  end;
 
  begin
     if estalavesa then {Miramos si existe sistema compatible vesa}
     elijevisualizar {inicio del Programa}
   else
     begin
         clrscr;
         writeln('Sistema Vesa No Disponible en Este Equipo Pulse [Enter]');
         readln;
     end;
  end.
 
{Al principio del programa encontrareis una linea como esta.
const
Camino : string = 'c:\tp\fotos12\'; {Camino donde estan las Imagenes}
------------------
Tendréis que cambiarla según vuestras direcciones donde tengáis metidas las imágenes
a visualizar.
También apreciareis que las  imágenes son reducidas para verse en pantalla }
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 09/10/2012 01:10:38
Hola Ramon, como estas la verdad he tenido bastante tiempo sin entrar a este pos y ver tus ejemplos ya es por causa de fuerzas mayores pero me interesa este curso, veo que has colocado bastantes ejemplos.

Fijate ahora urgentemente necesito hacer un programa en pascal para detectar impresoras bien sea impresoras locales o impresoras en red sean por el puerto paralelo , usb o serial y a su vez detectar cualquier estado que la impresora tenga al momento de enviar a imprimir.

Los estados serian:

1.- Si esta apagada o encendida
2.- Si esta imprimiendo
3.- Si tiene el papel atascado
4.- Si le falta papel
5.- O cualquier otro estado que se pueda saber mediante este programa.
6.- Y al saber el estado de la impresora enviar el resultado a un archivo TXT

Ya que necesito trabajar con impresoras fiscales y si tienes algun ejemplo para este tipo de impresora seria bunisimo.....

De antemano Mil gracias en la ayuda que me puedas prestar
Mis correos para que tambien me envies la informacion son: jose-8602@hotmail.com y clipfox12@gmail.com
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 10/10/2012 17:28:09
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
{Primero aclarar algo estamos programando con el dos puesto que pascal 7 solo trabaja con el
 o sea no en modo real sino modo protegido por lo cual tenemos de momento que desechar la
 idea de impresoras conectadas a puestos usb [ando en su conexión al dos].
Este programa te permite el control de impresoras conectadas a los puertos lpt 1,2,3.
espero te sirva de ayuda ten en cuenta que cada impresora maneja diferentes comando
 de impresión dependiendo tipo t marca.
 
   program impresion;
 uses
    crt, dos;
  const
    puerto : array[0..4] of word = (
    0,1,2,3,4);
 
   var
     estado, estadoimp : array[1..6] of string[40];
     n : integer;
 
   procedure estadoimpres(b : byte);
   begin
      if b and 1 = 1 then
      estadoimp[1] := 'Error de Tiempo de Espera';
      if b and 8 = 1 then
      estadoimp[2] := 'Error de Trasmision de Datos';
      if b and 16 = 1 then
      estadoimp[3] := 'Impresora ON-Line'
    else
      estadoimp[3] := 'Impresora OF-Line';
      if b and 32 = 0 then
      estadoimp[4] := 'Impresora sin Papel'
    else
      estadoimp[4] := 'Impresora con Papel';
      if b and 64 = 1 then
      estadoimp[5] := 'Confirmacion de Recepcion'
    else
      estadoimp[5] := 'Impresora no en Linea';
      if b and 128 = 0 then
      estadoimp[6] := 'Impresora Ocupada'
    else
      estadoimp[6] := 'Impresora Libre';
      for n := 1 to 6 do
      estado[n] := copy(estadoimp[n],1,length(estadoimp[n]));
   end;
 
   procedure enviacaracter(n : byte; purt : word);
   var
     esta : byte;
   begin
       asm
          mov ah,00h
          mov al,n
          mov dx,purt
          int 17h
          mov esta,ah
       end;
        estadoimpres(esta);
     end;
 
   procedure iniciapuertoparalelo(purt : word);
   var
      esta : byte;
   begin
       asm
          mov ah,01h
          mov dx,purt
          int 17h
          mov esta,ah
       end;
        estadoimpres(esta);
     end;
 
   procedure impresorapresente(purt : word);
   var
      esta : byte;
   begin
       asm
          mov ah,02h
          mov dx,purt
          int 17h
          mov esta,ah
       end;
       estadoimpres(esta);
     end;
 
  begin
     impresorapresente(puerto[0]);
     clrscr;
     for n := 1 to 6 do
     begin
     if estado[n] > ' ' then
     writeln('   Impresora Estado : ',estado[n]);
     end;
     readln;
  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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 28/11/2012 22:52:05
Espero aya is cogido con esto practica puesto que en breve pasare un programa de presentación de
otro tipo de imagen como lo es el jpg con ello pasaremos a la programación de dibujo de otro tipo
para poder ir manejando pequeños objetos en pantalla gráficas asi como su desplazamiento por
ella ,
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 10/12/2012 19:01:10
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
590
591
592
593
594
{Bien a qui  tenemos el programa para las imágenes jpg como podréis apreciar tiene procedimientos
 y funciones en asm con lineas en 32 bits, también apreciareis que la presentación es directa a      pantalla eso es porque el dos no nos deja mas que 64 K de memoria y una imagen de 640X480
 necesita bastante mas o sea  307,2 K por lo cual se tiene que trabajar en este caso directo a memoria de vídeo.
 En  la pro sima veremos como trabajar con toda nuestra ram usando xms, y algunas otras cosas
 como música y espites.
 
{Esta en 2 partes}
{ Parte 1}
 
  {Solo jpg estandar}
{Esta linea cambiar a la direccion que tengais los jpg Camino : string = 'c:\tp\fotos12\'}
 
 
program verjpg;
{$N+}{$G+}
uses
  crt, dos;
 
   type
     arrayint = array[0..63] of integer;
     matrizInt = array[0..7,0..7] of integer;
     ahuff = record
             v : word;
          hc,l : byte;
          end;
     colorgb = array[0..3] of byte;
     rgbc = array[0..2] of integer;
 
     vesamodeInfor = record
      modo_flag : word;
      ventana1, ventana2 : byte;
      granulacion, tamaventana : word;
      segventana1, segventana2 : word;
      areavisible : pointer;
      viteslinea : word;
      resolucionx : word;
      resoluciony : word;
      anchocaract, altocaract : byte;
      nbitplanes, bitporpixel, membloques, mem_modelo : byte;
      tamamemblok : byte;
      reser1 : array[1..11] of byte;
      videobuffer : pointer;
      reser2 : array[1..22] of byte;
      Reser3 : array[1..188] of byte;
   end;
 
   vesacabeceraInfor = record
      asignatura : array[1..4] of char;
      nversion : array[1..2] of byte;
      nombre1, compativ : longint;
      punterofar : pointer;
      capacidad : word;
      reva1 : word;
      vendor, producto, revision : pointer;
      reserva2 : array[0..221] of byte;
      reserva3 : array[0..255] of byte;
   end;
   string3 = string[3];
 
     const
          recorridoenzigzag : array[0..7,0..7] of byte = (
          (0, 1, 5, 6,14,15,27,28),
	  (2, 4, 7,13,16,26,29,42),
	  (3, 8,12,17,25,30,41,43),
	  (9,11,18,24,31,40,44,53),
	  (10,19,23,32,39,45,52,54),
	  (20,22,33,38,46,51,55,60),
	  (21,34,37,47,50,56,59,61),
	  (35,36,48,49,57,58,62,63));
 
     Camino : string = 'c:\tp\fotos12\';
     exten : string3 = 'jpg';
 
     var
    Comet, comet1 : string;
    longy, longx, longxx, longyy : integer;
    tablasingle : array[0..7,0..7] of single;
    tablalongt : array[0..7,0..7] of longint;
    estado, estado1 : integer;
    errores, errores1 : string;
    precision : byte;
    planos : byte;
    identificacion : array [1..4] of record
                      c, h, v, t : byte
                      end;
    marca : byte;
    tablashuff : record
                l : array [1..16] of byte;
                v : array [1..16,0..255] of byte;
                c : array [0..1,0..3,0..255] of ahuff;
             end;
    referenciahuff : array [0..1,0..3,0..19] of record
                  eleje, vege : byte;
                 end;
    quantiza : array [0..3] of matrizInt;
    mastablasdta : record
            Component,TD,TA:array [1..4] of byte;
            Ss, Se, Ah, Al : byte;
              end;
    tablaaritmeti : array [0..1,0..3] of byte;
    qqty : word;
    Curbit, Curbyte : byte;
    marcadores : array [192..254] of boolean;
    vectores : arrayint;
    coeficientesdc : array [1.. 3] of integer;
    x2, y2, x1, y1 : integer;
    datosdeljpg : array[0..999] of byte;
    filenomb, apuntad : longint;
    avanz : word;
    f : file;
    ycbtable : array[1..4,1..2,1..2] of matrizInt;
    colorjpg : colorgb;
    nombrearchi : string;
    modeinfo : vesamodeInfor;
    bancovid : word;
    informacion : vesacabeceraInfor;
    dirinfo : searchrec;
    cargamos : string;
    nomarch : array[1..40] of string[12];
    cag : integer;
    currentblock, temp : byte;
 
 
 
    procedure tomachivos(ext : string3);
    var
       ii : integer;
    begin
      FindFirst(camino + '*.' + ext, Archive, DirInfo);
      ii := 1;
      while DosError = 0 do
      begin
         nomarch[ii] := DirInfo.Name;
         ii := ii + 1;
         if ii > 40 then
         ii := 40;
         FindNext(DirInfo);
      end;
        cag := ii;
        nomarch[cag] := 'Salir';
   end;
 
  procedure menuarchivos;
  var
     tec : char;
     gg, n, t, yy, xx, cot : integer;
  begin
      TextBackground(0);
      clrscr;
      exten := 'JPG';
      tomachivos(exten);
      clrscr;
      gotoxy(12,1);write('*** Elija Archivo A Visualizar ***');
      cot := 1;
      yy := 3;
      xx := 3;
      repeat
      textcolor(15);
      gotoxy(xx, yy);write(nomarch[cot]);
      xx := xx + 15;
      if xx > 60 then
      begin
         xx := 3;
         yy := yy + 1;
         if yy > 22 then
         yy := 22;
      end;
      cot := cot + 1;
      until cot > cag;
      xx := 3;
      yy := 3;
      cot := 1;
    repeat
      TextBackground(2);
      gotoxy(xx - 1,yy);write('              ');
      textcolor(15);
      gotoxy(xx,yy);write(nomarch[cot]);
      TextBackground(0);
      tec := readkey;
      gotoxy(xx - 1,yy);write('              ');
      textcolor(15);
      gotoxy(xx,yy);write(nomarch[cot]);
  if tec = #77 then
  begin
      xx := xx + 15;
      cot := cot + 1;
      if (xx > 48) and (cot < cag) then
      begin
         xx := 3;
         yy := yy + 1;
         end;
         if cot > cag then
         begin
            xx := xx - 15;
            cot := cag;
         end;
      end;
  if tec = #75 then
  begin
      xx := xx - 15;
      cot := cot - 1;
      if xx < 3 then
      begin
         xx := 48;
         if yy > 3 then
         yy := yy - 1;
      end;
       if cot < 1 then
       begin
           cot := 1;
           xx := 3;
       end;
  end;
   if tec = #80 then
   begin
       if (cag mod 4) = 0 then
       gg := 2
     else
       gg := 3;
       if (yy < round(cag / 4) + gg) and (cot < cag) then
       begin
       yy := yy + 1;
       t := 4;
       cot := cot + t;
      end;
   end;
   if tec = #72 then
   begin
       if yy > 3 then
       begin
       yy := yy - 1;
       t := 4;
       cot := cot - t;
      end;
   end;
   until tec = #13;
   if nomarch[cot] = 'Salir' then
   cargamos := nomarch[cot]
  else
   cargamos := camino + nomarch[cot];
   TextBackground(0);
   Textcolor(15);
   clrscr;
  end;
 
  procedure informacionvesaesiste;
  begin
   asm
      mov ax,4f00h
      mov bx,seg informacion.asignatura[1]
      mov es,bx
      mov di,offset informacion.asignatura
      int 10h
   end;
end;
 
   procedure activamodo(m:word);
   var
    ok : boolean;
    pseg, pofs : word;
    a : word;
    pal : colorgb;
    ees, ddi : word;
 begin
   informacionvesaesiste;
   ok := true;
   asm
      mov ax,4f02h
      mov bx,m
      int 10h
      cmp ax,4fh
      je @exit
         mov ah,00h
         mov al,3
         int 10H
         mov ok,false
      @exit:
   end;
   if ok = false then
   begin
      writeln('Error de Video');
      halt;
   end;
   fillchar(mem[$a000:0],100,0);
   pseg := seg(modeinfo);
   pofs := ofs(modeinfo);
   asm
      push es
      mov ax,4f01h
      mov cx,m
      mov es,pseg
      mov di,pofs
      int 10h
      mov pseg,es
      mov pofs,di
      pop es
   end;
  end;
 
  procedure closegraph;assembler;
  asm
   mov ah,00h
   mov al,03h
   int 10h
  end;
 
   procedure asignabanco(b : word);assembler;
  asm
   xor bx,bx
   mov dx,b
   call modeinfo.areavisible
  end;
 
  function partaltabyte(b8 : byte):byte;assembler;
  asm
     mov al,b8
     shr al,4
 end;
 
 function partbajabyte(b8:byte):byte;assembler;
 asm
   mov al,b8
   and al,1111b
 end;
 
  procedure putpixel(x, y : longint;var color);
  begin
    if (longxx > 639) or (longy > 479) then
    begin
       x := round(x * (610 / longxx));
       y := round(y * (430 / longy));
    end;
  asm
   db 66h;mov bx,word ptr[x]
   cmp bx,modeinfo.resolucionx
   jae @exit
   db 66h;mov ax,word ptr[y]
   cmp ax,modeinfo.resoluciony
   jae @exit
   db 66h;shl bx,1
   db 66h;xor dx,dx
   mov dx,modeinfo.viteslinea
   db 66h; mul dx;
   db 66h;add ax,bx
   mov di,ax
   db 66h;shr ax,16
   cmp ax,bancovid
   je @memmunka
      mov bancovid,ax
      mov dx,ax
      mov bx,00h
      call modeinfo.areavisible
@memmunka:
   les si,color
   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;
 end;
 
 
  procedure cargatablas1;
  var
     a, b : byte;
   begin
   for a := 0 to 7 do
      for b := 0 to 7 do
         tablasingle[b,a] := Cos(a * (2 * b + 1) * 0.19635);
  end;
 
  procedure cargatablas2;
  var
    a,b : byte;
    r : real;
  begin
   for a := 0 to 7 do
      for b := 0 to 7 do
      begin
         r := Cos(a * (2 * b + 1) * 0.19635);
         tablalongt[b,a] := round(r * 1024);
      end;
   end;
 
   procedure asignycbcrargb(y, cb, cr : integer; var r,g,b : byte);
   var
     roj, ver, azu : integer;
  begin
     roj := round(y + 1.40200 * (cr - 128));
     ver := round(y - 0.34414 * (cb - 128) - 0.71414 * (cr - 128));
     azu := round(y + 1.77200 * (cb-128));
  if roj < 0 then
    r:=0
  else
   if roj > 255 then
    r := 255
  else
    r := roj;
  if ver < 0 then
    g := 0
  else
  if ver > 255 then
    g := 255
  else
    g := ver;
  if azu < 0 then
    b := 0
  else
   if azu > 255 then
    b := 255
  else
    b := azu;
 end;
 
  procedure cargadpartesdearchivo;
  var
     res : word;
  begin
   filemode := 0;
   reset(f,1);
   seek(f,filenomb * 1000);
   blockread(f,datosdeljpg,1000,res);
   inc(filenomb);
   Close(f);
   avanz := 0;
  end;
 
  function leeunbyte : byte;assembler;
  asm
   mov si,offset datosdeljpg[0]
   add si,avanz
   mov al,ds:[si]
   mov Curbyte,al
   inc avanz
   mov Curbit,0
   cmp avanz,999
   jna @Exit
      push ax
      call cargadpartesdearchivo
      pop ax
   @Exit:
 end;
 
  function leerword : word;assembler;
  asm
   call leeunbyte
   mov ah,al
   call leeunbyte
  end;
 
   function leerbit : byte;assembler;
   asm
       cmp Curbit,0
       jne @j1
       call leeunbyte
       cmp Curbyte,0ffh
       jne @j1
  @jrepeat:
       call leeunbyte
       cmp Curbyte,0ffh
       je @jrepeat
       cmp Curbyte,0d0h
       jnae @j3
       cmp Curbyte,0d7h
       jnbe @j3
       mov word ptr coeficientesdc[1],0
       mov word ptr coeficientesdc[2],0
       mov word ptr coeficientesdc[3],0
  @j3:
       cmp Curbyte,0
       je @j4
       call leeunbyte
       jmp @j5
  @j4:
       mov Curbyte,0ffh
  @j5:
  @j1:
      mov al,Curbyte
      mov cl,7
      sub cl,Curbit
      shr al,cl
      and al,1
      inc Curbit
      and Curbit,0111b
  @exit:
  end;
 
 
   procedure siguienteBit(var v);assembler;
   asm
     call leerbit
     les di,v
     db 66h;mov bx,[es:di]
     db 66h;shl bx,1
     or bl,al
     db 66h;mov [es:di],bx
  end;
 
   function leerbits(nn : byte):word;
   var
      i : byte;
      l : longint;
   begin
      l := 0;
      For i := 1 to nn do
      siguienteBit(l);
      leerbits := l
   end;
 
   function bitesinteger(nn : byte; value : word):integer;
   var
      a : integer;
   begin
      if (value and (1 shl (nn - 1)) > 0) then
      bitesinteger :=  value
   else
      bitesinteger := -(value xor (1 shl nn - 1))
   end;
 
   function codigosdehuffman(t, c : byte) : word;
   var
     i, l : byte;
     v : longint;
   begin
      l := 0;
      v := 0;
      Repeat
         inc(l);
         siguienteBit(v);
         For i := referenciahuff[t,c,l].eleje to $ff do
         if (tablashuff.c[t,c,i].l = l) and
                    (tablashuff.c[t,c,i].v = v) then
         begin
           codigosdehuffman := tablashuff.c[t,c,i].hc;
           exit
         end;
      until l = 16;
       codigosdehuffman := v;
   end;
 
  procedure huffmanreferenciatabla;
  var
     q, w, i, nr, mred : byte;
     esta : boolean;
    tempo : ahuff;
  begin
   for q := 0 to 1 do
      for w := 0 to 3 do
      begin
         for i := 0 to 255 do
            tablashuff.c[q,w,i].hc := i;
         repeat
            esta := true;
            for i := 0 to 254 do
               if tablashuff.c[q,w,i].l > tablashuff.c[q,w,i + 1].l then
               begin
                  tempo := tablashuff.c[q,w,i];
                  tablashuff.c[q,w,i] := tablashuff.c[q,w,i + 1];
                  tablashuff.c[q,w,i + 1] := tempo;
                  esta := false;
               end;
         until esta;
         i := 0;
         nr := tablashuff.c[q,w,i].l;
         mred := 0;
         repeat
            repeat
               inc(i);
            until (tablashuff.c[q,w,i].l <> nr) or (i = 255);
            referenciahuff[q,w,nr].eleje := mred;
            if tablashuff.c[q,w,i].l = nr then
            referenciahuff[q,w,nr].vege := i
         else
            referenciahuff[q,w,nr].vege := i - 1;
            mred := i;
            nr := tablashuff.c[q,w,i].l;
         until i = 255;
      end;
   end;
 
   Procedure pasoazigzag(src : arrayint;var dst : matrizInt);
   var
     xx, yy : integer;
   begin
     for yy :=0 to 7 do
      for xx := 0 to 7 do
         dst[xx,yy] := src[recorridoenzigzag[xx,yy]];
   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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 10/12/2012 19:18:30
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
{Parte 2}
 
 Procedure tomadatosjpe(nomb : string);
   var
      aa : arrayint;
       b : byte;
    m, vv, hh : byte;
    v, w : word;
         z : integer;
   begin
      estado1 := 0;
       Curbit := 0;
      Filemode := 0;
   Assign(f,nomb);
   {$I-} Reset(f,1); {$I+}
   if IOResult <> 0 then
   begin
      estado1 := 2;
      errores1 := 'Archivo No Encontrado';
   end;
   if estado1 <> 0 then
   exit;
   close(f);
   Fillchar(tablashuff,SizeOf(tablashuff),0);
   For m := 192 to 254 do
    marcadores[m] := False;
   marca := 0;
   qqty := 0;
   filenomb := 0;
   cargadpartesdearchivo;
   Repeat
      v := leerword;
      if hi(v) <> 255 then
      begin
         errores1 := 'Formato De Fichero No Valido';
         estado1 := 2;
      end;
      if estado1 <> 0 then
      exit;
      b := lo(v);
      marcadores[b] := True;
      z := avanz;
      if (b <> 216) and (b <> 217) then
      begin
         v := leerword;
         Case b of
            192,193,194,195,197,198,199,201,202,203,205,206,
            207: begin          { Main Image Parameters }
                    precision := leeunbyte;
                    longy := leerword;
                    longxx := leerword;
                    planos := leeunbyte;
                    if (precision <> 8) or (planos <> 3) then
                    begin
                       errores1 := 'Formato De Color No Compatible';
                       estado1 := 2;
                    end;
                    if estado1 <> 0 then
                    exit;
                    For hh := 1 to planos do
                    begin
                       identificacion[hh].c := leeunbyte;
                       vv := leeunbyte;
                       identificacion[hh].h := partaltabyte(vv);
                       identificacion[hh].v := partbajabyte(vv);
                       identificacion[hh].t := leeunbyte;
                    end;
                    marca := b;
                 end;
            196 : begin
                    apuntad := 0;
                    repeat
                    hh := leeunbyte;
                    For vv := 1 to 16 do
                    tablashuff.l[vv] := leeunbyte;
                    inc(apuntad,17);
                    For vv := 1 to 16 do
                       For m := 1 to tablashuff.l[vv] do
                       begin
                          tablashuff.v[vv,m] := leeunbyte;
                          inc(apuntad);
                       end;
                    w := 0;
                  For vv := 1 to 16 do
                  begin
                   For m := 1 to tablashuff.L[vv] do
                   begin
                   tablashuff.C[partaltabyte(hh),partbajabyte(hh),tablashuff.V[vv,m]].l := vv;
                   tablashuff.C[partaltabyte(hh),partbajabyte(hh),tablashuff.V[vv,m]].v := w;
                   inc(w)
                   end;
                      w := w shl 1;
                   end;
                    Until apuntad >= v - 2
                 end;
            204 : begin
                    apuntad := 0;
                    Repeat
                       hh := leeunbyte;
           tablaaritmeti[partaltabyte(hh),partbajabyte(hh)] := leeunbyte;
                       inc(apuntad,2);
                    Until apuntad >= v - 2
                 end;
            218 : begin
                    m := leeunbyte;
                    For hh := 1 to m do
                    begin
                       mastablasdta.Component[hh] := leeunbyte;
                       vv := leeunbyte;
                       mastablasdta.TD[hh] := partaltabyte(vv);
                       mastablasdta.TA[hh] := partbajabyte(vv)
                    end;
                    mastablasdta.Ss := leeunbyte;
                    mastablasdta.Se := leeunbyte;
                    vv := leeunbyte;
                    mastablasdta.Ah := partaltabyte(vv);
                    mastablasdta.Al := partbajabyte(vv)
                 end;
            219 : begin
                    apuntad := 0;
                    repeat
                    hh := leeunbyte;
                    if partaltabyte(hh) = 0 then
                       For vv := 0 to 63 do
                          aa[vv] := leeunbyte
                        else
                         For vv := 0 to 63 do
                          aa[vv] := leerword;
                    pasoazigzag(aa,quantiza[Lo(hh)]);
                    if partaltabyte(hh)=0 then
                    inc(apuntad,65)
                  else
                    inc(apuntad,129)
                    Until apuntad >= v - 2
                 end;
            221 : qqty := leerword;
         End;
         avanz := z + v;
         if IOResult <> 0 then
         begin
            errores1 := 'Error De Entrada / Salida';
            estado1 := 2;
         end;
      end
  Until (b = 217) or (b = 218) or (estado1 <> 0);
   huffmanreferenciatabla;
  end;
 
  Procedure codigohuffman(cond : byte);
  var
    xx, yy, z : integer;
begin
     z := codigosdehuffman(0,mastablasdta.TD[cond]);
     vectores[0] := coeficientesdc[cond] +
                bitesinteger(partbajabyte(z), leerbits(partbajabyte(z)));
     coeficientesdc[cond] := vectores[0];
     xx := 1;
   Repeat
      z := codigosdehuffman(1,mastablasdta.TA[cond]);
      if z = 0 then
         Repeat
            vectores[xx] := 0;
            inc(xx);
         Until xx >= 64
       else
         begin
            yy := xx + partaltabyte(z);
            While xx < yy do
            begin
               vectores[xx] := 0;
               inc(xx)
            end;
  vectores[xx] := bitesinteger(partbajabyte(z),leerbits(partbajabyte(z)));
  inc(xx)
         end
      Until xx >= 64;
    end;
 
  Procedure icddescuantlongit(var src, tab, dst : matrizInt);
  var
     xx, yy : integer;
    sum, idct, sum2 : longint;
    v, w : word;
    z : integer;
  begin
    asm
       push ds
       push es
       les di,src
       lds si,tab
       mov cx,64
  @deqloop:
       lodsw
       mov bx,es:[di]
       mul bx
       stosw
       loop @deqloop
       pop es
       pop ds
   end;
   For yy := 0 to 7 do
      For xx := 0 to 7 do
      begin
         sum := 0;
         For v := 1 to 3 do
         begin
            idct := 0;
            For w := 1 to 7 do
               idct := idct + src[v,w] * tablalongt[xx,w];
               sum := sum + idct * tablalongt[yy,v];
            end;
         sum2 := 0;
         For v := 4 to 7 do
         begin
            idct := 0;
            For w := 1 to 7 do
               idct := idct + src[v,w] * tablalongt[xx,w];
               sum2 := sum2 + idct * tablalongt[yy,v];
            end;
            idct := sum;
            inc(sum, sum2);
         if (xx = 0) and (yy = 0) and ((sum < 0) and (idct > 0) and
         (sum2 > 0)) or ((sum > 0) and (idct < 0)and (sum2 < 0)) then
         dst[xx,yy] := 255
      else
         begin
            idct := 0;
            For v := 1 to 7 do
               idct := idct + (src[v,0] * tablalongt[yy,v] +
                               src[0,v] * tablalongt[xx,v]);
            idct := (idct * 1024) div 181;
            inc(sum, idct * 128);
            inc(sum, src[0,0] * 524288);
            sum := round(sum / 4194304);
            z := sum + 128;
            if z < 0 then
            z := 0;
            if z > 255 then
            z := 255;
            dst[xx,yy] := z;
         end;
      end;
   end;
 
    Procedure icddescuantsingle(var src, tab, dst : matrizInt);
    var
      xx, yy : integer;
    sum, idct : single;
    v, w : word;
       z :integer;
   begin
     asm
       push ds
       push es
       les di,src
       lds si,tab
       mov cx,64
   @deqloop:
       lodsw
       mov bx,es:[di]
       mul bx
       stosw
       loop @deqloop
       pop es
       pop ds
   end;
   For yy := 0 to 7 do
      For xx := 0 to 7 do
      begin
         sum := 0;
         For v := 1 to 7 do
         begin
            idct := 0;
            For w := 1 to 7 do
               idct := idct + src[v,w] * tablasingle[xx,w];
               sum := sum + idct * tablasingle[yy,v];
         end;
         idct := 0;
         For v := 1 to 7 do
            idct := idct + (src[v,0] * tablasingle[yy,v] +
                                   src[0,v] * tablasingle[xx,v]);
         sum := sum + idct / 1.4142;
         sum := sum + src[0,0] / 2;
         z := Round(sum / 4) + 128;
         if z < 0 then
         z := 0;
         if z > 255 then
         z := 255;
         dst[xx,yy] := z;
      end;
   end;
 
 procedure cargaimagen(xxx, yyy : integer; nomb : string);
   var
        aa : matrizInt;
      i, j : integer;
    pixx, pixy : integer;
         b : byte;
      x, y : longint;
    xx, yy : integer;
    vv, hh : integer;
    m1, m2 : integer;
  begin
   Curbit := 0;
   tomadatosjpe(nomb);
   nombrearchi := nomb;
   comet := comet1;
   x1 := xxx;
   y1 := yyy;
   x2 := x1 + longxx;
   y2 := y1 + longy;
   longy := longy;
   longx := longxx;
   estado := estado1;
   errores := errores1;
   Case marca of
  192 : begin
      if not (marcadores[196] and marcadores[219]) then
      begin
         errores := 'Error Tabla Marcadores No Presente';
         estado := 2;
      end;
      if estado <> 0 then
      exit;
      FillChar(coeficientesdc,SizeOf(coeficientesdc),0);
      Y := 0;
      Repeat
         X := 0;
         Repeat
            For b := 1 to planos do
               For vv := 1 to identificacion[b].v do
                  For hh := 1 to identificacion[b].h do
                  Begin
                     codigohuffman(b);
                     pasoazigzag(vectores,aa);
      icddescuantlongit(aa,quantiza[identificacion[b].t],ycbtable[b,hh,vv]);
                  End;
            if planos > 1 then
            begin
               m1 := x + x1;
               m2 := y + y1;
       if (identificacion[1].v = 2) and (identificacion[1].h = 2) then
       begin
          if (x + 16 > longxx) or (y + 16 > longy) then
            for j := 0 to 7 do
              for i := 0 to 7 do
              begin
                asignycbcrargb(ycbtable[1, 1, 1, i, j],
                    ycbtable[2, 1, 1, i div 2, j div 2],
                      ycbtable[3, 1, 1, i div 2, j div 2],
                       colorjpg[2], colorjpg[1], colorjpg[0]);
                if (X + i + 1 <= longxx) and (Y + j + 1 <= longy) then
                  putpixel(m1 + i,m2 + j,colorjpg);
                   asignycbcrargb(ycbtable[1, 2, 1, i, j],
                     ycbtable[2, 1, 1, i div 2 + 4, j div 2],
                       ycbtable[3, 1, 1, i div 2 + 4, j div 2],
                        colorjpg[2], colorjpg[1], colorjpg[0]);
                if (X + i + 9 <= longxx) and (Y + j + 1 <= longy) then
                putpixel(m1 + i + 8,m2 + j, colorjpg);
                asignycbcrargb(ycbtable[1, 1, 2, i, j],
                  ycbtable[2, 1, 1, i div 2, j div 2 + 4],
                    ycbtable[3, 1, 1, i div 2, j div 2 + 4],
                     colorjpg[2], colorjpg[1], colorjpg[0]);
                if (X + i + 1 <= longxx) and (Y + j + 9 <= longy) then
                 putpixel(m1 + i,m2 + j + 8, colorjpg);
                 asignycbcrargb(ycbtable[1, 2, 2, i, j],
                   ycbtable[2, 1, 1, i div 2 + 4, j div 2 + 4],
                     ycbtable[3, 1, 1, i div 2 + 4, j div 2 + 4],
                       colorjpg[2], colorjpg[1], colorjpg[0]);
                if (X + i + 9 <= longxx) and (Y + j + 9 <= longy) then
                 putpixel(m1 + i + 8,m2 + j + 8, colorjpg);
                     end
                     else
                  for j := 0 to 7 do
                     for i := 0 to 7 do
                     begin
                        asignycbcrargb(ycbtable[1, 1, 1, i, j],
                         ycbtable[2, 1, 1, i div 2, j div 2],
                          ycbtable[3,1,1,i div 2,j div 2],
                          colorjpg[2], colorjpg[1], colorjpg[0]);
                        putpixel(m1 + i, m2 + j, colorjpg);
                        asignycbcrargb(ycbtable[1, 2, 1, i, j],
                         ycbtable[2, 1, 1, i div 2 + 4, j div 2],
                          ycbtable[3,1,1,i div 2+4,j div 2],
                          colorjpg[2], colorjpg[1], colorjpg[0]);
                        putpixel(m1 + i + 8, m2 + j, colorjpg);
                        asignycbcrargb(ycbtable[1,1,2,i,j],
                         ycbtable[2, 1, 1, i div 2, j div 2 + 4],
                          ycbtable[3, 1, 1, i div 2, j div 2 + 4],
                           colorjpg[2], colorjpg[1], colorjpg[0]);
                        putpixel(m1 + i, m2 + j + 8, colorjpg);
                        asignycbcrargb(ycbtable[1, 2, 2, i, j],
                         ycbtable[2, 1, 1, i div 2 + 4, j div 2 + 4],
                          ycbtable[3, 1, 1, i div 2 + 4, j div 2 + 4],
                           colorjpg[2], colorjpg[1], colorjpg[0]);
                        putpixel(m1 + i + 8, m2 + j + 8, colorjpg);
                     end;
                 end;
         if (identificacion[1].v = 1) and (identificacion[1].h = 1) then
          if (x + 8 > longxx) or (y + 8 > longy) then
           for j := 0 to 7 do
            for i := 0 to 7 do
             begin
               asignycbcrargb(ycbtable[1, 1, 1, i, j],
                ycbtable[2, 1, 1, i, j],
                 ycbtable[3, 1, 1, i, j],
                  colorjpg[2], colorjpg[1], colorjpg[0]);
             if (x + i + 1 <= longxx) and (y + j + 1 <= longy) then
              putpixel(m1 + i, m2 + j, colorjpg);
              end
           else
              for j := 0 to 7 do
                for i := 0 to 7 do
                 begin
                   asignycbcrargb(ycbtable[1, 1, 1, i, j],
                    ycbtable[2, 1, 1, i, j],
                     ycbtable[3, 1, 1, i, j],
                     colorjpg[2], colorjpg[1], colorjpg[0]);
                    putpixel(m1 + i, m2 + j, colorjpg);
                 end;
             end;
            if KeyPressed then
               begin
                  errores := 'Proceso Peticion De Terminar';
                  estado := 2;
                  X := longx;
                  Y := longy;
               end;
            Inc(X,identificacion[1].h * 8)
         Until (X >= longx) or (estado <> 0);
         if qqty > 0 then
         Curbit := 0;
         Inc(Y,identificacion[1].v * 8)
      Until (Y >= longy)  or (estado <> 0);
     end;
 
  end;
  if estado = 0 then
  estado := 1;
 end;
 
begin
   menuarchivos;
   if cargamos = 'Salir' then
   begin
      exit;
   end
  else
   begin
   cargatablas1;
   cargatablas2;
   nombrearchi := cargamos;
   activamodo($111);
   asignabanco($111);
   cargaimagen(10,50,nombrearchi);
   readln;
   closegraph;
  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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 25/01/2013 22:24:35
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
{Como comente en la parte anterior ahora toca un poquito de manejo de puertos para aprender
 a trabajar con nuestra querida sound blaster  y poder sacarle un poco de música en esta ocasión
 entraremos con archivos de música wave de 8 bits este programa nos permitirá oír unos pocos
  sonidos o voces mientras realizamos otras labores en el programa.
 Al mismo tiempo nos presentara el tipo de tarjeta y la configuración que tiene a si como la estructura del archivo wav.}
 
 program musicawav;
 uses
    crt, dos;
 type
    regmusica = record
             frecu : longint;
             tama  : longint;
             misi  : pointer;
           end;
 
     cavewave = record
          riff : array[0..3] of char;
          tama : longint;
          wave : array[0..7] of char;
          for1 : longint;
          for2 : integer;
          mono : integer;
          frec : longint;
          bseg : longint;
          bcat : integer;
          bmut : integer;
          dato : array[0..3] of char;
          bmst : longint;
      end;
      string4 = string[4];
 
   var
     tomado, pbase : word;
     mimusi : regmusica;
     cwave  : cavewave;
     f : file;
     mayor, menor : byte;
     nombre : string;
     blaster, memtoma : boolean;
     memcarga : word;
     nombmusi : string[20];
 
 
  function bytehex(n : byte) : string;
  Const
    nchars : Array[0..15] of char = '0123456789ABCDEF';
  begin
    bytehex[0] := #2;
    bytehex[1] := nchars[n shr  4];
    bytehex[2] := nchars[n and 15];
  end;
 
  function wordhexa(n : word) : string;
  begin
    wordhexa := bytehex(hi(n)) + bytehex(lo(n));
  end;
 
  function longinthex(n : longint) : string;
  begin
    longinthex := wordhexa(n shr 16) + wordhexa(n);
  end;
 
  procedure puertobase;
  var
     datos : string;
     bas : string[4];
     tb : word;
     erro : integer;
  begin
     datos := getenv('blaster');
     if datos[1] in ['a','A'] then
     bas := copy(datos,2,5);
     for erro := 1 to length(bas) do
     if bas[erro] = ' ' then
     delete(bas,erro,1);
     val('$' + bas,tb,erro);
     if erro = 0 then
     begin
      pbase := tb;
      blaster := true;
      writeln('Configuracion Sound Blaster = ',datos);
     end;
  end;
 
  procedure versionsb;
  begin
      port[pbase + $c] := $e1;
      mayor := port[pbase + $a];
      menor := port[pbase + $a];
      port[pbase + $c] := $D0;
  end;
 
  procedure escribe_dsp(d : byte);
  begin
    while Port[pbase + $c] And $80 <> 0 do;
    port[pbase + $c] := d;
  end;
 
  function lee_dsp : byte;
  begin
     while Port[pbase + $c] and $80 = 0 do;
     lee_dsp := Port[pbase + $a];
  end;
 
  procedure escribe_dac(d : byte);
  begin
     escribe_dsp($10);
     escribe_dsp(d);
  end;
 
  function lee_dac : byte;
  begin
     escribe_dsp($20);
     lee_dac := lee_dsp;
  end;
 
  function altavoz_encendido : byte;
  begin
     escribe_dsp($d1);
  end;
 
  function altavoz_apagado: byte;
  begin
     escribe_dsp($d3);
  end;
 
  procedure activa_dma;
  begin
     escribe_dsp($d4);
  end;
 
  procedure para_dma;
  begin
     escribe_dsp($d0);
  end;
 
  procedure escribe_en_mixer(ind, v : byte);
  begin
      port[pbase + 4] := ind;
      port[pbase + 5] := v;
  end;
 
  function lee_en_mixer(ind : byte) : byte;
  begin
      port[pbase + 4] := ind;
      lee_en_mixer := port[pbase + 5];
  end;
 
  procedure activa_misica(soud : Pointer; long : word; frec : longint);
  var
     tiempo : longint;
     pagina, despla : word;
   begin
      altavoz_encendido;
      long := long - 1;
      despla := seg(soud^) shl 4 + ofs(soud^);
      pagina := (seg(soud^) + ofs(soud^) shr 4) shr 12;
      port[$0a] := 5;
      port[$0c] := 0;
      port[$0b] := $49;
      port[$02] := lo(despla);
      port[$02] := hi(despla);
      port[$83] := pagina;
      port[$03] := lo(long);
      port[$03] := hi(long);
      port[$0a] := 1;
 
 
      if (cwave.bmut = 8) and (cwave.mono = 1) and (cwave.bcat = 1) then {8 bit}
      begin
      tiempo := (65536 - (256000000 div (1 * frec))) shr 8;
      escribe_dsp($40);
      escribe_dsp(tiempo);
      escribe_dsp($14);
      escribe_dsp(lo(long));
      escribe_dsp(hi(long));
      end;
    end;
 
    procedure presenta_archivos_wav;
    var
       x, y : integer;
       DirInfo: SearchRec;
    begin
       x := 2;
       y := 6;
       FindFirst('c:\*.wav', Archive, DirInfo);
       while DosError = 0 do
       begin
          gotoxy(x,y);write(DirInfo.Name);
          FindNext(DirInfo);
          y := y + 1;
          if y > 23 then
          begin
             x := x + 15;
             y := 6;
          end;
        end;
     end;
 
 
    procedure tomawave(nom : string);
    begin
       memtoma := false;
       assign(f,nom);
    {$I-} reset(f,1); {$I+}
    if ioresult <> 0 then
    begin
        clrscr;
        writeln('  Error El Archivo No Se Encontro Pulse [Enter]');
        readln;
        exit;
    end
  else
      begin
         seek(f,0);
         blockread(f,cwave,sizeof(cavewave),tomado);
         if cwave.bmst < 32563 then
         begin
            getmem(mimusi.misi,cwave.bmst);
            blockread(f,mimusi.misi^,cwave.bmst);
            memtoma := true;
            mimusi.tama := cwave.bmst;
            mimusi.frecu := cwave.frec;
            memcarga := cwave.bmst;
         end
       else
           begin
            getmem(mimusi.misi,32563);
            blockread(f,mimusi.misi^,32563);
            memtoma := true;
            mimusi.tama := 32563;
            mimusi.frecu := cwave.frec;
            memcarga := 32563;
           end;
         close(f);
      end;
    end;
 
   procedure presenta_cabecera_wave;
   begin
      clrscr;
      writeln('****** Cabecera De Archivo Wave *******');
      writeln;
      writeln('  Identificador Archivo   : ',cwave.riff[0], cwave.riff[1],
                                           cwave.riff[2], cwave.riff[3]);
      writeln('  Tama¤o Del Archivo      : ',cwave.tama);
      writeln('  Marcador Wave           : ',cwave.wave[0], cwave.wave[1],
             cwave.wave[2], cwave.wave[3], cwave.wave[4], cwave.wave[5],
             cwave.wave[6], cwave.wave[7]);
      writeln('  Tama¤o Cabecera         : ',cwave.for1);
      writeln('  Etiqueta Formato        : ',cwave.for2);
      if cwave.mono = 1 then
      writeln('  Tipo Reproducion        : Mono')
    else
      writeln('  Tipo Reproducion        : Estereo');
      writeln('  Frecuencia Muestreo     : ',cwave.frec);
      writeln('  N§ Medio De Bytes/Sg    : ',cwave.bseg);
      writeln('  Alineamiento De Blaques : ',cwave.bcat);
      writeln('  N§ Bytes Por Muestra    : ',cwave.bmut);
      writeln('  Marcador Inicio Datos   : ',cwave.dato[0], cwave.dato[1],
                                             cwave.dato[2], cwave.dato[3]);
      writeln('  N§ Bytes Muestra        : ',cwave.bmst);
      writeln;
      writeln('>>>>> Pulse Una Tecla <<<<<');
      repeat until keypressed;
   end;
 
 
 
  begin
    clrscr;
     blaster := false;
     puertobase;
     if blaster = true then
     begin
     writeln('*** Sound Blaster En Puerto Base : $',wordhexa(pbase),' ***');
     versionsb;
     writeln('*** Sound Blaster Version = ',mayor,'.',menor);
     presenta_archivos_wav;
     gotoxy(2,25);write('Elija Solo Nombre : ');
     gotoxy(22,25);readln(nombmusi);
     nombre := 'c:\' + nombmusi + '.wav';
     tomawave(nombre);
     activa_misica(mimusi.misi, mimusi.tama, mimusi.frecu);
     port[pbase + $c] := $D0;
     presenta_cabecera_wave;
       if memtoma = true then
       freemem(mimusi.misi,memcarga);
     end;
    end.
 
  {Encaso de tener los archivos wave en otra dirección tendréis que cambiar estos dos fragmentos
     FindFirst('c:\*.wav', Archive, DirInfo); como veréis la dirección es [c:\*.wav] la tendríais que
     cambiar por la vuestra  y en este otro  [nombre := 'c:\' + nombmusi + '.wav';]}
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 17/03/2012 19:37:55
Una pregunta que te hago que opinas del Free Pascal , el TMT Pascal, El Dev-Pascal o el Gani cual es mejor.

Tu crees que el Free Pascal esta mas actualizado que Turbo pascal 7.0 vi en internet una pagina de Free Pascal que esta actualizada hasta el 2011.

Y que del Proyecto Lazarus que opinas de el.
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 17/03/2012 21:36:54
Te comento uno Free Pascal esta basado en turbo pascal por lo tanto me parece tan bueno uno como otro, TMT Pascal es también un retrato de turbo pascal y Dev-Pascal esta basado en free pascal cualquiera de ellos esta bien.
Referente a lo moderno es lógico que lo sean sino de nada u viera servido sacarlos ahora o no,
estando ya turbo pascal 7, estos otros se componen de mas librerías acopladas a los sistemas
actuales.
Se debe de reconocer que pascal 7 asido abandonado y no se crearon mas unidades de apoyo
para el sistema pero para aprender a programar se deben de realizar algunas cosas que parecen pesadas pero después nos demuestran que no lo son tanto.
Un ejemplo de ello es la creación de librerías o unidades para nuestro uso como ratón, teclado, vídeo
y otras que nos permiten trabajar o sea programar mas cómoda mente, pero eso lo iras viendo
con el tiempo.
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 27/03/2012 18:24:06
Tienes toda la razon, en esa parte de aprender a crear librerias para trabajar mejor con el lenguaje. Me gustaria aprender bien a crearlas ya que uno mismo puede ampliar el lenguaje con librerias para lo que haga falta.

Una cosa mas que opinas del Lazarus y del CodeThypon como programacion Visual Free Pascal son buenos....a tu criterio... para desarrollar aplicaciones tan poderosas como Visual Basic - Visual Fox Pro - Delphi - el mismo Turbo Pascal de la Borlan.

Otra cosa es cierto que el Lazarus es una copia del Delphi o esta hecho desde 0 (cero).
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

Compilador de pascal 7.7

Publicado por Jose Torres (1 intervención) el 21/02/2012 18:39:21
Porqué no piensas en algo moderno, como FreePascal + Lazarus? Puedes descargar el IDE CodeTyphon de www.pilotlogic.com, es muy potente, no te va a defraudar.
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

Compilador de pascal 7.7

Publicado por Gabriel clipfox12@gmail.com (17 intervenciones) el 03/03/2012 20:22:40
Hola Jose Torres gracias por la sugerencia fijate si he estado viendo este lenguaje el FREE PASCAL Y EL LAZARUS y de verdad me gusta ya que en la pagina web describen las cualidades del lenguaje y esta actualizado hasta el año pasado.

Pero quiero hacerte una pregunta con relacion al Lazarus y al Free Pascal se puede hacer una aplicacion comercial completa y potente como se haria con Delphi, el Visual Basic, el visual Fox Pro o el mismo xHarbour ?

Gracias....
Jose
correo: jose-8602@hotmail.com
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

Compilador de pascal 7.7

Publicado por Jose Torres jtorres@logosoftcr.com (1 intervención) el 05/03/2012 13:09:34
Sí, se puede hacer una aplicación completa. En mi empresa lo adoptamos el año pasado y ya tenemos varios utilitarios y una aplicación comercial desarrollados en esta herramienta.
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

Compilador de pascal 7.7

Publicado por carlos (1 intervención) el 23/12/2013 15:52:43
disculpe. necesito por favor el programa turbo pascal 7.0 o otra version del turbo pascal pero la necesito completa con los comandos correctos.
GRACIAS
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 24/12/2013 13:07:22
busques en google por turbo pascal 7.0 lo tienes libre por lo tanto es fácil encontrarlo normal mente esta entero
pueden faltar los ejemplos por lo demás suele estar todo.
Los comando como esposen siempre los tendrás puesto que son internos del lenguaje siempre y cuando
tengas los archivos turbo.tpl puesto que dentro de el se encuentran todas las librerías necesarias para poder
trabajar con el 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

Compilador de pascal 7.7

Publicado por Diego Restrepo Ocampo (3 intervenciones) el 17/03/2014 23:56:44
Sería bueno que el análisis de que hace de algunos programas que son muy buenos por cierto, fuera con un programa que muestre los que está comentando por ejemplo donde habla de como se desarrolla el programa con todos los pasos explicados. En el ejemplo de los arrays se debía implementar el programa ya con los clientes de un hotel, sus habitaciones, los empleados de una empresa,etc. Porque hay veces que se encuentran muchos programas pero no su aplicación para un caso concreto. Y en estos casos cuando no se domina bien esto se queda volando...
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

Compilador de pascal 7.7

Publicado por ramon (2072 intervenciones) el 01/04/2014 11:12:44
A ver informo que los arrays no son para aplicaciones del tipo que comentas puesto que la cantidad de datos que podría llegar a manejar desbordaría la memoria que el programa podría manejar me explico pascal solo permite un máximo
de 64 k lo cual nos obliga a manejar otros datos como registros o punteros pero si quieres un pequeño ejemplo lo
pondré en breve
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