metro
Descripción del contenido de la página
Programa escrito en Forth con FPC para crear unos efectos gráficos relacionados con el Metro de Madrid.
El origen de este programa
En 1997 me pidieron colaboración de una productora de cine para crear unos efectos gráficos para ilustrar un anuncio que iban a rodar sobre el Metro de Madrid.
Busqué entre los sistemas Forth que usaba y decidí usar FPC, probablemente el mejor Forth que haya sido escrito para el sistema operativo MS- DOS. Por descontado, FPC tenía unas extensiones gráficas que permitían hacer lo que yo necesitaba.
El programa quedó sin terminar porque los planes respecto al anuncio cambiaron y ya no hizo falta mi colaboración.
De hecho no recuerdo en qué estado quedó ni qué mostraba en pantalla, aunque echando un vistazo al código podría adivinarse fácilmente (no voy a montar un sistema DOS bajo mi sistema Debian sólo para instalar FPC después de trece años y averiguarlo...)
Ya que el programa al final no fue vendido, puedo publicarlo como curiosidad, aunque esté inconcluso.
Código fuente
\ metro
\ Copyright (C) 1997 Marcos Cruz (http://programandala.net)
\ Licencia/Permesilo/License: http://programandala.net/license
\ Programa escrito en Forth FPC. El código está en castellano.
\ Programo verkita en FPC-Fortho. La kodo kastililingvas.
\ Program written in FPC Forth. The code is in Spanish.
needs grtype.seq
anew metro!
only forth also graphics also
\ depuraci'on
\ ***********
variable vv1
variable vv2
: vv1! dup vv1 ! ;
: vv2! dup vv2 ! ;
: pausa
key drop
\ begin key? until
\ begin key? 0= until
;
\ constantes
\ **********
$00 CONSTANT negro \ black
$01 CONSTANT azul \ blue
$02 CONSTANT verde \ green
\ $03 CONSTANT CYAN \ cyan
$04 CONSTANT rojo \ red
\ $05 CONSTANT MAGENTA \ magenta
$06 CONSTANT marr'on \ brown
$07 CONSTANT gris_claro \ light gray
$08 CONSTANT gris_oscuro \ dark gray All following, blink in Background.
$09 CONSTANT azul_claro \ light blue
$0A CONSTANT verde_claro \ light green
$0B CONSTANT cyan_claro \ light cyan
$0C CONSTANT rojo_claro \ light red
$0D CONSTANT magenta_claro \ light magenta
$0E CONSTANT amarillo \ yellow
$0F CONSTANT blanco \ white
8 constant anchura_car \ anchura de los caracteres
10 constant altura_t'itulo
9 constant v'ias \ pares de v'ias en una pantalla como m'aximo
5 constant franjas_en_v'ia \ franjas para situar elementos
4 constant separaci'on_elemento \ espacio horizontal entre elementos
\ los siguientes valores se calculan al cambiar a modo gr'afico:
0 value altura_'util \ altura 'util en pantalla para las v'ias
0 value altura_v'ias \ altura del espacio de cada v'ia
0 value altura_franja \ altura de cada franja dentro de una v'ia
0 value altura_elemento \ altura m'axima de un elemento en una franja
: x_de_v'ia ( v'ia -- x )
1- altura_v'ias * altura_t'itulo +
;
: x_de_franja ( v'ia franja -- x )
1- altura_franja * 1+
swap x_de_v'ia +
;
: marco
blanco color !
0 hres @ 1- 2dup
0 hline
vres @ 1- hline
0 vres @ 1- 2dup
0 vline
hres @ 1- vline
;
/*
: t'itulo ( color dir_texto long_texto -- )
rot color !
dup anchura_car *
hres @
swap -
2 /
0 Gr_AT
GrType
;
*/
: t'itulo_l'inea ( l'inea_de_metro -- )
blanco color !
dup 9 > 1+ 6 + \ longitud del t'itulo en letras
anchura_car * \ longitud en pixeles
hres @ swap - 2 / \ coordenada x para centrar el t'itulo
1 Gr_AT " LINEA " GrType Gr_.
;
\ *********
\ elementos
\ *********
\ general
\ -------
/*
siguiente_elemento
x y = v'ertice superior derecho del 'ultimo elemento dibujado
actualiza la coordenada x y sit'ua el cursor gr'afico
para el siguiente elemento que se dibuje a su derecha
*/
: siguiente_elemento ( x y -- )
swap separaci'on_elemento + swap
moveto
;
\ tri'angulos
\ -----------
/*
(tri'angulo_derecha)
x y = coordenadas del v'ertice superior izquierdo
del recuadro ocupado por el elemento
dibuja un tri'angulo que apunta hacia la derecha
*/
: (tri'angulo_derecha) ( x y -- )
\ calcular v'ertice superior derecho
2dup altura_elemento 2 / rot + swap ( x y x' y )
2swap \ guardar las nuevas coordenadas para siguiente_elemento
2dup ( x y x y )
dup altura_elemento + ( x y x y ny )
rot ( x y y ny x )
2dup swap 2>r
vline ( x y )
altura_elemento 2 / dup ( x y inc inc )
3 pick + ( x y inc nx )
swap 2 pick + ( x y nx ny )
2dup 2>r
line ( )
2r> 2r> line
siguiente_elemento
;
/*
tri'angulo_derecha_=color
dibuja un tri'angulo que apunta hacia la derecha
en la posici'on actual y en el color actual
*/
: tri'angulo_derecha_=color ( -- )
x2 @ y2 @ (tri'angulo_derecha)
;
/*
tri'angulo_derecha
color = color
dibuja un tri'angulo que apunta hacia la derecha
en la posici'on actual y en el color especificado
conserva el valor de la variable color
*/
: tri'angulo_derecha ( color -- )
color @ swap color !
tri'angulo_derecha_=color
color !
;
/*
(tri'angulo_izquierda)
x y = coordenadas del v'ertice superior izquierdo
del recuadro ocupado por el elemento
dibuja un tri'angulo que apunta hacia la izquierda
*/
: (tri'angulo_izquierda) ( x y -- )
\ calcular v'ertice superior derecho
altura_elemento 2 / rot + swap ( x' y )
2dup \ guardar las coordenadas para siguiente_elemento
2dup ( x y x y )
dup altura_elemento + ( x y x y ny )
rot ( x y y ny x )
2dup swap 2>r
vline ( x y )
altura_elemento 2 / dup ( x y inc inc )
3 pick swap - ( x y inc nx )
swap 2 pick + ( x y nx ny )
2dup 2>r
line ( )
2r> 2r> line
siguiente_elemento
;
/*
tri'angulo_izquierda_=color
dibuja un tri'angulo que apunta hacia la izquierda
en la posici'on actual y en el color actual
*/
: tri'angulo_izquierda_=color ( -- )
x2 @ y2 @ (tri'angulo_izquierda)
;
/*
tri'angulo_izquierda
color = color
dibuja un tri'angulo que apunta hacia la izquierda
en la posici'on actual y en el color especificado
conserva el valor de la variable color
*/
: tri'angulo_izquierda ( color -- )
color @ swap color !
tri'angulo_izquierda_=color
color !
;
/*
(tri'angulo_abajo)
x y = coordenadas del v'ertice superior izquierdo
del recuadro ocupado por el elemento
dibuja un tri'angulo que apunta hacia abajo
*/
: (tri'angulo_abajo) ( x y -- )
\ calcular v'ertice derecho a partir del izquierdo y dibujar l'inea
2dup ( x y x y )
over altura_elemento + ( x y x y x' )
2dup swap 2>r \ guardar v'ertice derecho
\ para siguiente_elemento
2dup swap 2>r \ guardar v'ertice derecho
\ para la 'ultima l'inea
-rot ( x y x' x y )
hline ( x y )
\ calcular v'ertice inferior a partir del izquierdo y dibujar l'inea
2dup ( x y x y )
altura_elemento 2 / dup ( x y x y inc inc )
rot + ( x y x inc ny )
rot rot + swap ( x y nx ny )
2dup 2>r \ guardar v'ertice inferior
\ para la 'ultima l'inea
line
\ dibujar l'inea desde v'ertice inferior a v'ertice derecho
2r> 2r> line
2r> siguiente_elemento
;
/*
tri'angulo_abajo_=color
dibuja un tri'angulo que apunta hacia abajo
en la posici'on actual y en el color actual
*/
: tri'angulo_abajo_=color ( -- )
x2 @ y2 @ (tri'angulo_abajo)
;
/*
tri'angulo_abajo
color = color
dibuja un tri'angulo que apunta hacia abajo
en la posici'on actual y en el color especificado
conserva el valor de la variable color
*/
: tri'angulo_abajo ( color -- )
color @ swap color !
tri'angulo_abajo_=color
color !
;
/*
(tri'angulo_arriba)
x y = coordenadas del v'ertice superior izquierdo
del recuadro ocupado por el elemento
dibuja un tri'angulo que apunta hacia arriba
*/
: (tri'angulo_arriba) ( x y -- )
\ calcular v'ertice superior derecho del recuadro
2dup altura_elemento 2 / rot + swap ( x y x' y )
2swap \ guardar las nuevas coordenadas para siguiente_elemento
\ calcular v'ertice derecho a partir del izquierdo y dibujar l'inea
2dup ( x y x y )
over altura_elemento + ( x y x y x' )
2dup swap 2>r \ guardar v'ertice derecho
-rot ( x y x' x y )
hline ( x y )
\ calcular v'ertice superior a partir del izquierdo y dibujar l'inea
2dup ( x y x y )
altura_elemento 2 / dup ( x y x y inc inc )
rot swap - ( x y x inc ny )
rot rot + swap ( x y nx ny )
2dup 2>r \ guardar v'ertice inferior
line
\ dibujar l'inea desde v'ertice inferior a v'ertice derecho
2r> 2r> line
siguiente_elemento
;
/*
tri'angulo_arriba_=color
dibuja un tri'angulo que apunta hacia arriba
en la posici'on actual y en el color actual
*/
: tri'angulo_arriba_=color ( -- )
x2 @ y2 @ (tri'angulo_arriba)
;
/*
tri'angulo_arriba
color = color
dibuja un tri'angulo que apunta hacia arriba
en la posici'on actual y en el color especificado
conserva el valor de la variable color
*/
: tri'angulo_arriba ( color -- )
color @ swap color !
tri'angulo_arriba_=color
color !
;
\ etiquetas
\ ---------
/*
(etiqueta)
x y = coordenadas del v'ertice superior izquierdo del elemento
color_t = color del texto
color_f = color del fondo
dir = direcci'on del texto
long = longitud del texto
dibuja una etiqueta con los colores y texto especificados
en la posici'on indicada
conserva el color actual
*/
: (etiqueta) ( x y color_t color_f dir long -- )
color @ >r \ guardar color actual
rot color ! ( x y color_t dir long )
3 pick 5 pick 1- swap ( x y color_t dir long x y )
2 pick ( x y color_t dir long x y long )
1- anchura_car * 1+ 9 ( x y color_t dir long x y ancho alto )
3 pick 2 pick + 3 pick 2>r \ guardar v'ertice derecho
\ para siguiente_elemento
solid-rect ( x y color_t dir long )
rot color ! ( x y dir long )
2swap Gr_AT GrType
2r> siguiente_elemento
r> color ! \ recuperar color actual
;
/*
etiqueta
color_t = color del texto
color_f = color del fondo
dir = direcci'on del texto
long = longitud del texto
dibuja una etiqueta con los colores y texto especificados
en la posici'on actual del cursor gr'afico
*/
: etiqueta ( color_t color_f dir long -- x y color_t color_f dir long )
2>r 2>r
x2 @ y2 @
2r> 2r>
(etiqueta)
;
\ varios
\ ******
' D_Point_On IS Point_On \ makes GrType draw text on screen,
\ ' X_Point_On IS Point_On \ XOR text on screen (Default)
\ pruebas
\ *******
: cursor
blanco color !
100 100 moveto
150 150 nline
200 150 nline
;
: barras
red color !
637 20 do
i 100 2 80 solid-rect
20 +loop
;
\ principal
\ *********
: modo_gr'afico
vga640
vres @ altura_t'itulo 2+ -
!> altura_'util
altura_'util v'ias /
!> altura_v'ias \ altura 'util para cada v'ia
altura_v'ias 2- franjas_en_v'ia /
!> altura_franja \ altura 'util para cada franja de v'ia
altura_franja 2-
!> altura_elemento
;
: metro
modo_gr'afico
marco
\ blanco " LINEA 1" t'itulo
1 t'itulo_l'inea
\ verde color ! 20 30 tri'angulo_derecha
0 20 moveto
amarillo tri'angulo_izquierda
verde tri'angulo_izquierda
rojo tri'angulo_izquierda
\ 60 50 tri'angulo_abajo
\ cyan 70 70 tri'angulo_arriba
150 300 moveto
amarillo tri'angulo_derecha
rojo tri'angulo_arriba
verde tri'angulo_abajo
negro cyan " BILBAO" etiqueta
verde gris_claro " LISTA" etiqueta
amarillo tri'angulo_abajo
verde tri'angulo_derecha
rojo cyan " QUEVEDO" etiqueta
blanco tri'angulo_arriba
negro blanco " IGLESIA" etiqueta
verde tri'angulo_izquierda
pausa
text
x2 ? cr y2 ?
;
metro
Descargas
La extensión SEQ era la usada por FPC para los ficheros de código fuente en formato de texto normal (para distinguirlos del formato de texto en bloques propio de Forth).