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.

Etiquetas:

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).