( Aide a la mise au point des economiseurs d'ecran.
  Version 0.10 du 18 Juillet 2010.
  Ecrit par jpb.forth .
)

DECIMAL

START 2@ CONSTANT DEBUT_ECONOMISEUR

 0 VARIABLE F_TEST
 0 VARIABLE PRE_TEST
 0 VARIABLE LIEU_TEST
 0 VARIABLE APPEL_TEST 0 APPEL_TEST 2!
 0 VARIABLE PRGM_TEST 0 PRGM_TEST 2!
 0 VARIABLE PARAM_TEST 0 PARAM_TEST 2!
 0 VARIABLE INIT_TEST 0 INIT_TEST 2!
 0 VARIABLE FICHIER_TEST 0 FICHIER_TEST 2!
 0 VARIABLE MEM_TEST 0 MEM_TEST 2!
 0 VARIABLE ERREUR_TEST
 0 VARIABLE %_TEST

HERE 4 ALLOT CONSTANT LIM_TEST

FEN_STRING" S_DESCRIPTIF

TEST ECONOMISEUR d'ECRAN FORTH

  Version 0.10 du 18/07/2010

   http://jpb.forth.free.fr/
   jpb_forth@yahoogroups.com

  Que le FORTH soit avec TOI!
"

 FORTH  SCREEN SAVER TEST

Version 0.10 in 07/18/2010

 http://jpb.forth.free.fr/
 jpb_forth@yahoogroups.com

May the FORTH be with you!
"
FEN_STRING" S_TITRE
TEST ECONOMISEUR d'ECRAN"
SCREEN SAVER TEST"
FEN_STRING" S_FICHIER_0
Aucun fichier."
Not any file."
FEN_STRING" S_ITERATION
Appel no: 0000000000"
Call no: 0000000000"
FEN_STRING" S_LANCE
LANCEMENT"
LAUCHING"
FEN_STRING" S_IMAGE
IMAGE GIF"
GIF PICTURE"
FEN_STRING" S_MENU
    FICHIER
FERMER....ESC F
MENU......ESC N"
     FILE
CLOSE....ESC F
MENU.....ESC N"
FEN_STRING" S_MENU_P
    FICHIER
  PARAMETRE(S)
FERMER....ESC F
MENU......ESC N"
     FILE
 PARAMETER(S)
CLOSE....ESC F
MENU.....ESC N"
" : XYZT ;" STRING S_DEB_TEST
" FORGET XYZT" STRING S_FIN_TEST
FEN_STRING" S_NON_VERIF

IMPOSSIBLE car une compilation est en cours!
"

IMPOSSIBLE because a compilation is running!
"
FEN_STRING" S_VERIFICATION

Verification du fichier...
"

File cheking...
"
FEN_STRING" S_ERREUR_0
Aucune erreur."
Not any error."
FEN_STRING" S_ERREUR_1
Fichier INEXISTANT!"
UNEXISTING file!"
FEN_STRING" S_ERREUR_2
PAS ASSEZ de memoire"
NOT ENOUGHT memory!"
FEN_STRING" S_ERREUR_3
Pile des donnees MODIFIEE!"
MODIFIED data stack!"
FEN_STRING" S_ERREUR_4
Compilation INCOMPLETE!"
NOT FULL compilation!"
FEN_STRING" S_ERREUR_5
ERREUR de compilation!"
Compilation ERROR!"
FEN_STRING" S_ERREUR_6
Ecriture de la somme INCORRECTE!"
BAD sum writing!"
" ( SOM_VEILLE 0000000000 )" STRING S_SOM
FEN_STRING" S_PROBLEME_FICHIER

   PROBLEME d'ACCES
au SYSTEME de FICHIER!
"

  FILE SYSTEM
ACCESS PROBLEM!
"
" ./ECONOMISEUR.GIF" STRING S_GIF_VEILLE

HERE 258 2/ ALLOT CONSTANT GIF_TAMPON

0 VARIABLE FICHIER_GIF 0 FICHIER_GIF 2!
0 VARIABLE GIF_NB_COULEURS
0 VARIABLE GIF_NB_BITS
0 VARIABLE GIF_IND_BITS
0 VARIABLE GIF_TABLE 0 GIF_TABLE 2!
0 VARIABLE GIF_CODE
0 VARIABLE GIF_LARGEUR
0 VARIABLE GIF_HAUTEUR
0 VARIABLE GIF_CHAINE
0 VARIABLE GIF_TMP_FICHIER
0 VARIABLE GIF_FIC

: GIF_CONCATENE ( code --> - )
 GIF_IND_BITS DUP >R @ DUP >R DUP -3 LSH GIF_TAMPON + >R 7 AND
 DUP >R LSH 1 R> LSH 1- R@ C@ AND OVER OR R@ C! -8 LSH DUP R@ 1+ C!
 -8 LSH R> 2+ C! GIF_NB_BITS @ R> + DUP R> ! 2039 >
 IF
  GIF_TMP_FICHIER 2@ GIF_FIC -1 OVER ! 1 3 PICK FWRITE DROP
  GIF_TAMPON DUP >R 255 3 PICK FWRITE DROP
  DROP R> DUP >R 255+ R> 3 CMOVE 2040 GIF_IND_BITS -!
 THEN
;

: GIF_CHERCHE ( chaine --> chaine, index_table )
 DUP -14 LSH OVER 255 AND 14 GIF_NB_COULEURS @ - LSH XOR DUP 2/ + DUP
 IF
  DUP [ 5449 6 * LITERAL ] -
 ELSE
  -6
 THEN
 ( chaine, index, decalage )
 GIF_TABLE 2@ >R
 BEGIN
  OVER R@ + @ 0<
  IF
   -1
  ELSE
   OVER R@ + 2+ 2@ 4 PICK =
   IF
    -1
   ELSE
    DUP >R + DUP 0<
    IF
     [ 5449 6 * LITERAL ] +
    THEN
    R> 0
   THEN
  THEN
 UNTIL
 DROP R> +
;

: GIF_COMPRIME ( caractere --> - )
 GIF_CHAINE DUP >R 2@ 16 LSH + GIF_CODE @
 IF
  GIF_CHERCHE DUP @ DUP 0<
  IF
   ( chaine, index_table, -1 )
   DROP >R DUP SWAB GIF_CONCATENE DUP R@ 2+ 2!
   GIF_CODE DUP @ DUP R> ! 1+ DUP 1 GIF_NB_BITS @ LSH >
   IF
    DUP 4096 >
    IF
     DROP 1 GIF_NB_COULEURS @ DUP 1 = - LSH GIF_CONCATENE 0
    ELSE
     1 GIF_NB_BITS +!
    THEN
   THEN
   SWAP !
  ELSE
   >R DROP DROP R>
  THEN
 ELSE
  GIF_TABLE 2@ DUP [ 5449 6 * LITERAL ] + SWAP DO
   -1 I !
  6 +LOOP
  1 GIF_NB_COULEURS @ DUP 1 = - DUP 1+ GIF_NB_BITS ! LSH 2+ GIF_CODE !
  DUP SWAB GIF_CONCATENE GIF_CHERCHE >R DUP R@ 2+ 2!
  GIF_CODE DUP @ DUP R> ! 1+ SWAP !
 THEN
 R> 2!
;

: SPF_RETRACE ( x0,y0,x1,y1 --> - )
 FENETRE DUP >R 2@ 0 R@ 2! >R
 >R >R >R LIMITES DUP >R @ MAX R> R> SWAP DUP >R 2+ @ MAX
 R> R> SWAP DUP >R 4+ @ MIN R> 6+ @ R> MIN
 4 PICK 3 PICK > 4 PICK 3 PICK > OR
 IF
  DROP DROP DROP DROP
 ELSE
  0 F_RETRACE
 THEN
 R> R> 2!
;

FEN: ICONE_TEST
 >R FEN_TEINTES_? DROP DROP DROP DROP >R DROP R>
 R@ FEN_TAILLE_? >R 22- 2/ R> 22- 2/
 3 PICK 3 PICK 3 PICK OVER 21+ OVER 2+ R@ FEN_TRACE_REC
 3 PICK 3 PICK 3 PICK 3+ OVER OVER 15+ R@ FEN_TRACE_REC
 R> 8 0 DO
  7 I - 2* 1+ DUP 12 AND 4* DUP 4* + +
  DUP 5 PICK I + 1+ 5 PICK 3+ OVER OVER 15+ 7 PICK FEN_TRACE_REC
  4 PICK 20+ I - 4 PICK 3+ OVER OVER 15+ 6 PICK FEN_TRACE_REC
 LOOP
 >R OVER R@ FEN_POSITION_? >R + 9+ OVER R> + 3+ OVER 3+ OVER 15+ SPF_RETRACE
 3 PICK 3 PICK 21+ 3 PICK 3+ OVER OVER 15+ R@ FEN_TRACE_REC
 19+ OVER 21+ OVER 2+ R> FEN_TRACE_REC
;

FEN: FERME_TEST
 >R ICONE_TEST R> FEN_ICONE
;

FEN: A_PROPOS_TEST
 >R S_DESCRIPTIF R> FEN_DIALOGUE_MESSAGE
;

: SP_AFF_FICHIER ( fen --> - )
 DUP >R FEN_TAILLE_? FEN_TEINTES_? DROP >R DROP DROP >R DROP R> R>
 OVER 2 DUP 7 PICK 3- OVER 11+ R@ FEN_TRACE_REC
 DUP CARACTERES_GRAPHIQUES FICHIER_TEST 2@ ?DUP
 IF
  0
  BEGIN
   OVER OVER + C@ 3-
  WHILE
   OVER OVER + C@ >R 1+ R> 47 =
   IF
    + 0
   THEN
  REPEAT
 ELSE
  S_FICHIER_0 COUNT
 THEN
 >R 7 PICK R@ 7 * - 2/ 3
 ROT R> R@ FEN_TRACE_CHAINE DROP DROP DROP DROP DROP
 DROP DROP DROP DROP R> DROP
;

: SP_AFF_FOND ( fen --> - )
 LIM_TEST DUP >R @ R@ 2+ @ R@ 4+ @ R> 6+ @ SPF_RETRACE DROP
;

: AFFICHE_ITERATION ( fen --> - )
 DUP >R FEN_TAILLE_? FEN_TEINTES_? DROP >R DROP DROP >R DROP R> R>
 DUP CARACTERES_GRAPHIQUES S_ITERATION COUNT >R 7 PICK R@ 7 * - 2/
 R@ 10- 7 * + 7 PICK 39- ROT R> 10- + 10 APPEL_TEST 2@ 11 1 DO
  10 U/MOD SWAP 48+ 4 PICK 4 PICK + I - C!
 LOOP
 DROP 8 PICK 5 PICK 5 PICK OVER 69+ OVER 9+ R@ FEN_TRACE_REC
 R@ FEN_TRACE_CHAINE DROP DROP DROP DROP DROP
 DROP DROP DROP DROP R> DROP
;

: SP_AFF_ITERATION ( fen --> - )
 DUP >R FEN_TAILLE_? FEN_TEINTES_? DROP >R DROP DROP >R DROP R> R>
 OVER 2 5 PICK 40- 7 PICK 3- OVER 11+ R@ FEN_TRACE_REC
 DUP CARACTERES_GRAPHIQUES S_ITERATION COUNT >R 7 PICK R@ 7 * - 2/ 7 PICK 39-
 ROT R> 10- R@ FEN_TRACE_CHAINE DROP DROP DROP DROP DROP R@ AFFICHE_ITERATION
 DROP DROP DROP DROP R> DROP
;

: SP_TRACE_CADRE ( x0,y0,x1,y1 --> - )
 LIMITES -1 6 PICK 6 PICK 6 PICK OVER TRACE_REC
 -1 6 PICK 6 PICK OVER 6 PICK TRACE_REC
 -1 4 PICK 6 PICK OVER 6 PICK TRACE_REC
 DROP >R >R >R >R LIMITES -1 R> R> DROP  R> R> SWAP OVER TRACE_REC DROP
;

: SP_AFF_ERREUR ( fen --> - )
 DUP >R FEN_TAILLE_? ERREUR_TEST @ PRGM_TEST 2@ 0= OR
 IF
  193 255
 ELSE
  49 0
 THEN
 OVER 2 5 PICK 28- 7 PICK 3- OVER 11+ R@ FEN_TRACE_REC
 DUP CARACTERES_GRAPHIQUES ERREUR_TEST @ CASE
  1 OF
   S_ERREUR_1
  ENDOF
  2 OF
   S_ERREUR_2
  ENDOF
  3 OF
   S_ERREUR_3
  ENDOF
  4 OF
   S_ERREUR_4
  ENDOF
  5 OF
   S_ERREUR_5
  ENDOF
  6 OF
   S_ERREUR_6
  ENDOF
  PRGM_TEST 2@
  IF
   S_ERREUR_0
  ELSE
   S_FICHIER_0
  THEN
 ENDCASE
 COUNT >R 7 PICK R@ 7 * - 2/ 7 PICK 27-
 ROT R> R@ FEN_TRACE_CHAINE DROP DROP DROP DROP DROP
 DROP DROP DROP DROP R> DROP
;

: TEINTE_RVB ( c --> r,v,b )
 DUP 3 AND DUP 4 LSH + >R
 DUP 192 AND DUP -4 LSH + R@ + SWAP
 DUP 48 AND 4* DUP -4 LSH + R@ + SWAP
 12 AND DUP 4 LSH + R> +
;

: SP_AFF_LANCEMENT ( fen --> - )
 >R FEN_TEINTES_? R@ FEN_TAILLE_? 3 PICK DUP 0<
 IF
  DUP XOR
 ELSE
  0= LIEU_TEST @ 2 = R@ FEN_DEVANT_? AND
  IF
   >R 6 PICK 6
  ELSE
   >R 8 PICK 8
  THEN
  PICK >R TEINTE_RVB R> TEINTE_RVB 2 9 PICK 16 R> DEGRADE_|
 THEN
 ?DUP
 IF
  DUP 0 4 PICK 16- R@ FEN_ECRIT_REC MEMOIRE_LIBERE DROP
 ELSE
  LIEU_TEST @ 2 = R@ FEN_DEVANT_? AND
  IF
   6 PICK 6
  ELSE
   8 PICK 8
  THEN
  PICK 0 4 PICK 16- 6 PICK 1- OVER 11+ R@ FEN_TRACE_REC
  0 3 PICK 4- 5 PICK 1- OVER 3+ R@ FEN_TRACE_REC
 THEN
 4 PICK CARACTERES_GRAPHIQUES LIEU_TEST @ 2 = R@ FEN_DEVANT_? AND
 IF
  S_IMAGE
 ELSE
  S_LANCE
 THEN
 COUNT >R 5 PICK R@ 7 * - 2/ 5 PICK 13-
 ROT R> R@ FEN_TRACE_CHAINE DROP >R 1+ R> LIEU_TEST @ 2 = R@ FEN_DEVANT_? AND
 IF
  S_IMAGE
 ELSE
  S_LANCE
 THEN
 COUNT R@ FEN_TRACE_CHAINE
 DROP DROP DROP DROP DROP
 DROP DROP DROP DROP DROP DROP DROP DROP R> DROP
;

FEN: AFFICHE_TEST
 DUP >R FEN_TAILLE_? FEN_TEINTES_? DROP DROP DROP DROP >R DROP R>
 DUP 0 DUP 6 PICK 1- 1 R@ FEN_TRACE_REC
 DUP 0 2 1 6 PICK 17- R@ FEN_TRACE_REC
 DUP 4 PICK 2- 2 OVER 1+ 6 PICK 17- R@ FEN_TRACE_REC
 R> DUP SP_AFF_FICHIER 16 0 DO
  15 I - DUP 12 AND 4* DUP 4* + +
  DUP I 3 * 2+ 14 OVER 2+ 8 PICK 41- 7 PICK FEN_TRACE_REC
  5 PICK I 1+ 3 * - 2- 14 OVER 2+ 7 PICK 41- 6 PICK FEN_TRACE_REC
 LOOP
 >R DROP R@ FEN_POSITION_? 14+ DUP LIM_TEST DUP >R 2+ ! ROT 55- + R@ 6+ !
 50+ DUP R@ ! 101- + R> 4+ !
 R@ SP_AFF_FOND R@ SP_AFF_ITERATION R@ SP_AFF_ERREUR R> SP_AFF_LANCEMENT
;

HERE ]
 FICHIER_TEST 2@ -1 FOPEN DUP 0>
 IF
  DUP 1+ MEMOIRE_ALLOUE ?DUP
  IF
   DUP 3 PICK 0 DO
    DUP 1 6 PICK FREAD DROP DUP C@ 10-
    IF
     1+
    ELSE
     OVER OVER - OVER 1- C@ 13 = AND NOT
     IF
      13 OVER C! 1+
     THEN
    THEN
   LOOP
   25 %_TEST ! 3 SWAP C! S_DEB_TEST 1+ LOAD 1024 ALLOT
   HERE -9 8 -7 6 -5 4 -3 2 -1 DEPTH >R 11 PICK LOAD DEPTH R> -
   DUP >R 9+ 0 DO
    DROP
   LOOP
   50 %_TEST ! R>
   IF
    DROP 3 ERREUR_TEST !
   ELSE
    ERROR @
    IF
     DROP 5 ERREUR_TEST !
    ELSE
     STATE @ 0=
     IF
      HERE SWAP - MEMOIRE_ALLOUE ?DUP
      IF
       DUP >HERE OVER LOAD MEM_TEST 2@ ?DUP
       IF
        MEMOIRE_LIBERE DROP
       THEN
       DUP 2@ PRGM_TEST 2! LIM_TEST OVER 4+ 2! DUP 8+ 2@ PARAM_TEST 2!
       DUP 12+ 2@ INIT_TEST 2! MEM_TEST 2! 0 ERREUR_TEST !
      ELSE
       2 ERREUR_TEST !
      THEN
     ELSE
      DROP 4 ERREUR_TEST !
     THEN
    THEN
   THEN
   0 ERROR ! 0 STATE ! S_FIN_TEST 1+ LOAD MEMOIRE_LIBERE DROP DROP
  ELSE
   DROP 2 ERREUR_TEST !
  THEN
 ELSE
  DROP 1 ERREUR_TEST !
 THEN
 FCLOSE DROP
 75 %_TEST ! ERREUR_TEST @ 0=
 IF
  FICHIER_TEST 2@ -1 FOPEN DUP 0>
  IF
   DUP MEMOIRE_ALLOUE ?DUP
   IF
    DUP 3 PICK 5 PICK FREAD 3 PICK -
    IF
     1 ERREUR_TEST !
    ELSE
     >R >R FCLOSE DROP FICHIER_TEST 2@ 0 FOPEN R> R> ROT 0<
     IF
      1 ERREUR_TEST !
     ELSE
      0 DUP 4 PICK 4 PICK + 4 PICK DO
       3 PICK 3 PICK + 13 S_SOM 1+ OVER STRCMP
       IF
        3 PICK 3 PICK + C@ 255 AND + >R 1+ R>
       ELSE
        LEAVE
       THEN
      LOOP
      100 %_TEST ! 3 PICK 3 PICK 7 PICK FWRITE 0<
      IF
       DROP DROP 6 ERREUR_TEST !
      ELSE
       SWAP 4 PICK - 0=
       IF
        [ 13 8 LSH 10+ LITERAL ] 3 PICK ! OVER 2 6 PICK FWRITE DROP
       THEN
       S_SOM COUNT + 3- 10 0 DO
        >R 10 U/MOD SWAP 48+ R@ C! R> 1-
       LOOP
       DROP DROP S_SOM COUNT 5 PICK FWRITE 0<
       IF
        6 ERREUR_TEST !
       THEN
      THEN
     THEN
    THEN
    MEMOIRE_LIBERE DROP DROP
   ELSE
    DROP 2 ERREUR_TEST !
   THEN
  ELSE
   DROP 1 ERREUR_TEST
  THEN
  FCLOSE DROP
 THEN
 EXIT
[ CONSTANT SP_COMPILE

FEN: MENU_TEST
 BEGIN
  PARAM_TEST 2@
  IF
   5 S_MENU_P
  ELSE
   4 S_MENU
  THEN
  0 4 PICK FEN_DIALOGUE_CHOIX DUP 1 > PARAM_TEST 2@ 0= AND - CASE
   1 OF
    PAD 2@ STATE @ OR
    IF
     S_NON_VERIF OVER FEN_DIALOGUE_MESSAGE
    ELSE
     FICHIER_TEST 2@ DUP -1 0 5 PICK FEN_DIALOGUE_FICHIER DUP 1+ 0=
     IF
      DROP DROP
     ELSE
      >R ?DUP
      IF
       MEMOIRE_LIBERE DROP
      THEN
      R> FICHIER_TEST 2! DUP SP_AFF_FICHIER
      %_TEST 0 OVER ! SP_COMPILE S_VERIFICATION 4 PICK FEN_DIALOGUE_PROGRESSE
     THEN
     DUP SP_AFF_ERREUR
    THEN
    -1
   ENDOF
   2 OF
    PARAM_TEST 2@ -9 8 -7 6 -5 4 -3 2 -1 DEPTH >R 11 PICK 11 PICK EXECUTE
    DEPTH R> - DUP
    IF
     3
    ELSE
     0
    THEN
    ERREUR_TEST ! 10+ 0 DO
     DROP
    LOOP
    DUP SP_AFF_ERREUR -1
   ENDOF
   3 OF
    DUP FERME_TEST EXECUTE -1
   ENDOF
   4 OF
    0
   ENDOF
   -1
  ENDCASE
 UNTIL
 DROP
;

FEN: CLAVIER_TEST
 SWAP PRE_TEST @ 27 =
 IF
  31 AND 0
 ELSE
  DUP 27 =
  IF
   0 SWAP
  ELSE
   0
  THEN
 THEN
 PRE_TEST !

 DUP 6 = ( fermeture )
 IF
  DROP DUP FERME_TEST EXECUTE 0
 THEN

 DUP 14 = ( menu )
 IF
  DROP DUP MENU_TEST EXECUTE 0
 THEN

 IF
  BELL
 THEN
 DROP
;

FEN: SOURIS_TEST
 >R OVER OVER OR
 IF
  LIEU_TEST @ ?DUP
  IF
   1-
   IF
    LIM_TEST DUP >R @ R@ 2+ @ R@ 4+ @ R> 6+ @ 40000 MEMOIRE_ALLOUE ?DUP
    IF
     S_GIF_VEILLE COUNT CHEMIN_CONCATENE ?DUP
     IF
      DUP >R 0 FOPEN 0<
      IF
       R> MEMOIRE_LIBERE DROP
       S_PROBLEME_FICHIER R@ FEN_DIALOGUE_MESSAGE FCLOSE DROP
      ELSE
       ( x0,y0,x1,y1,adr_gif,adr_fic )
       DUP GIF_TMP_FICHIER 2! OVER GIF_TABLE 2! 8 GIF_NB_COULEURS !
       4 PICK 1+ 7 PICK - GIF_LARGEUR !
       3 PICK 1+ 6 PICK - GIF_HAUTEUR !
       ( GIF89a )
       GIF_FIC DUP >R [ 71 8 LSH 73+ 8 LSH 70+ 8 LSH 56+ LITERAL ] R@ 2!
       4 3 PICK FWRITE DROP R@ [ 57 8 LSH 97+ LITERAL ] R@ ! 2 3 PICK FWRITE DROP
       ( largeur et hauteur ecran 16 bits PC )
       R@ GIF_LARGEUR DUP >R 1+ C@ 8 LSH R> C@ 255 AND + 8 LSH
       GIF_HAUTEUR DUP >R 1+ C@ 255 AND + 8 LSH R> C@ 255 AND + R@ 2!
       4 3 PICK FWRITE DROP
       ( descriptif 1+3+1+3 bits 0xF7
         couleur du fond 8 bits
         dx/dy 8 bits 0x31 )
       R@ 15 4 LSH GIF_NB_COULEURS @ 1- + 16 LSH 49+ 8 LSH R@ 2!
       3 3 PICK FWRITE DROP
       ( palette r-v-b )
       R@ 1 GIF_NB_COULEURS @ LSH 0 DO
        I -4 LSH 12 AND I 3 AND + DUP 4 LSH + 8 LSH
        I 4/ 12 AND I 3 AND + DUP 4 LSH + + 8 LSH
        I 15 AND DUP 4 LSH + + 8 LSH OVER 2!
        DUP 3 4 PICK FWRITE DROP
       LOOP
       ( commentaire )
       [ 33 8 LSH 254+ LITERAL ] R@ ! 2 3 PICK FWRITE DROP
       S_DESCRIPTIF COUNT 1+ >R 1- R> 3 PICK FWRITE DROP
       ( debut image avec caractere "," 0x2C )
       R@ 44 R@ ! 2 3 PICK FWRITE DROP
       ( decalage x et y 16 bits PC )
       R@ 0 R@ 2! 4 3 PICK FWRITE DROP
       ( largeur et hauteur image 16 bits PC )
       R@ GIF_LARGEUR DUP >R 1+ C@ 8 LSH R> C@ 255 AND + 8 LSH
       GIF_HAUTEUR DUP >R 1+ C@ 255 AND + 8 LSH R> C@ 255 AND + R@ 2!
       4 3 PICK FWRITE DROP
       ( descriptif 1+1+1+2+3 bits 0x00 et largeur code )
       R@ GIF_NB_COULEURS @ DUP 1 = - R@ ! 2 3 PICK FWRITE 0< NOT
       IF
        ( x0,y0,x1,y1,adr_gif,adr_fic )
        ( paquets LZW )
        GIF_LARGEUR @ 16 LSH 1+ 3 PICK 38000+ 2!
        1 GIF_NB_COULEURS @ DUP 1+ GIF_NB_BITS ! 0 DUP GIF_IND_BITS !
        GIF_CODE ! LSH GIF_CONCATENE GIF_HAUTEUR @ 0 DO
         LIMITES 3 PICK 38000+ 8 PICK 8 PICK I + LIT_REC DROP
         6 PICK 6 PICK 6 PICK OVER I + SP_TRACE_CADRE
         GIF_LARGEUR @ 0 DO
          OVER 38004+ I + C@ 255 AND I J OR
          IF
           GIF_COMPRIME
          ELSE
           GIF_CHAINE 2!
          THEN
         LOOP
         6 PICK 6 PICK 6 PICK OVER I + SP_TRACE_CADRE
        LOOP
        GIF_CHAINE 2@ GIF_CONCATENE 1 GIF_NB_COULEURS @ LSH 1+ GIF_CONCATENE
        GIF_IND_BITS @ ?DUP
        IF
         7+ -3 LSH DUP R@ C! R@ 1 4 PICK FWRITE DROP
         GIF_TAMPON SWAP 3 PICK FWRITE DROP
        THEN
        ( fin de l'image )
        ( paquet vide 8 bits a 0 et caractere ";" 0x3B )
        R@ 59 R@ ! 2 3 PICK FWRITE DROP
       THEN
       R> DROP FCLOSE
       IF
        R> MEMOIRE_LIBERE DROP
        S_PROBLEME_FICHIER R@ FEN_DIALOGUE_MESSAGE
       ELSE
        R> DUP -1 FOPEN DUP 0>
        IF
         FICHIER_GIF 2@ 0 DUP R@ FEN_DIALOGUE_FICHIER DUP 1+
         IF
          ?DUP
          IF
           DUP FICHIER_GIF DUP 2@ ?DUP
           IF
            MEMOIRE_LIBERE DROP
           THEN
           2! 0 FOPEN 0<
           IF
            S_PROBLEME_FICHIER R@ FEN_DIALOGUE_MESSAGE FCLOSE DROP
           ELSE
            ( desc_fic_1,lng_fic_1,desc_fic_2 )
            OVER
            BEGIN
             GIF_TAMPON OVER 256 MIN 6 PICK FREAD DROP
             GIF_TAMPON OVER 256 MIN 4 PICK FWRITE DROP
             256- 0 MAX DUP 0=
            UNTIL
            DROP FCLOSE
            IF
             S_PROBLEME_FICHIER R@ FEN_DIALOGUE_MESSAGE FCLOSE DROP
            THEN
           THEN
          ELSE
           S_PROBLEME_FICHIER R@ FEN_DIALOGUE_MESSAGE
          THEN
         ELSE
          DROP
         THEN
        ELSE
         S_PROBLEME_FICHIER R@ FEN_DIALOGUE_MESSAGE
        THEN
        DROP FCLOSE DROP DUP 0 FOPEN DROP FCLOSE DROP MEMOIRE_LIBERE DROP
       THEN
      THEN
     ELSE
      S_PROBLEME_FICHIER R@ FEN_DIALOGUE_MESSAGE
     THEN
     MEMOIRE_LIBERE DROP
    ELSE
     S_ERREUR_2 R@ FEN_DIALOGUE_MESSAGE
    THEN
    DROP DROP DROP DROP
   ELSE
    R@ MENU_TEST EXECUTE
   THEN
  THEN
 ELSE
  4 PICK 0< 5 PICK R@ FEN_TAILLE_? >R 1- > OR
  4 PICK R@ 16- < OR 4 PICK R> 1- > OR
  IF
   R@ FEN_POSITION_? >R 5 PICK + R> 5 PICK +
   DUP LIM_TEST DUP >R 2+ @ < SWAP R@ 6+ @ > OR
   SWAP DUP R@ @ < SWAP R> 4+ @ > OR OR
   IF
    0 DUP
   ELSE
    576 1
   THEN
  ELSE
   576 2
  THEN
  LIEU_TEST DUP >R @ OVER R> ! -
  IF
   R@ SP_AFF_LANCEMENT R@ SP_AFF_FOND LIEU_TEST @ 2 =
   IF
    0 APPEL_TEST 2!
   THEN
  THEN
  GRAPHIQUES_16 + R@ FEN_MOTIF_SOURIS
 THEN
 R> DROP DROP DROP DROP DROP
;

FEN: SORT_TEST
 LIEU_TEST @
 IF
  0 LIEU_TEST ! DUP SP_AFF_LANCEMENT DUP SP_AFF_FOND
 THEN
 DROP
;

FEN: AFF_CHRONO
 APPEL_TEST 2@
 IF
  PRGM_TEST 2@
 ELSE
  INIT_TEST 2@
 THEN
 ?DUP
 IF
  -9 8 -7 6 -5 4 -3 2 -1 DEPTH >R 10 PICK EXECUTE DEPTH R> - DUP
  IF
   3 ERREUR_TEST !
  THEN
  10+ 0 DO
   DROP
  LOOP
  ERREUR_TEST @
  IF
   DUP SP_AFF_ERREUR
  THEN
 THEN
 APPEL_TEST 2@ NPA ABS 20 MOD U/MOD DROP 0= ERREUR_TEST @ OR
 IF
  DUP AFFICHE_ITERATION
 THEN
 PRGM_TEST 2@
 IF
  1 APPEL_TEST +2!
 THEN
 DROP
;

FEN: AFF_RIEN
 DROP
;

FEN: CHRONO_TEST
 >R LIEU_TEST @ 2 = ERREUR_TEST @ 0= AND
 IF
  25 AFF_CHRONO
 ELSE
  250 AFF_RIEN
 THEN
 CHRONO_TEST R> FEN_CHRONO
;

: ECONOMISEUR
 F_TEST @ ?DUP
 IF
  FEN_SELECTIONNE
 ELSE
  FEN_CREE ?DUP
  IF
   DUP >R F_TEST !
   ECRAN 4+ DUP >R @ 1+ 2/ 300 MAX R> 2+ @ 1+ 2/ 225 MAX
   OVER 2/ OVER 2/ R@ FEN_POSITION R@ FEN_TAILLE
   300 225 20000 15000 R@ FEN_DIMENSIONS
   S_TITRE R@ FEN_NOM
   FERME_TEST R@ FEN_FERME
   MENU_TEST R@ FEN_MENU
   A_PROPOS_TEST R@ FEN_A_PROPOS
   AFFICHE_TEST R@ FEN_AFFICHE
   SOURIS_TEST R@ FEN_SOURIS
   CLAVIER_TEST R@ FEN_CLAVIER
   SORT_TEST R@ FEN_SORT
   R@ FERME_TEST EXECUTE
   1 AFF_CHRONO CHRONO_TEST R@ FEN_CHRONO
   R> FEN_ACTIVE
  ELSE
   ." IMPOSSIBLE de creer l'application TEST ECONOMISEUR d'ECRAN FORTH!" ABORT
  THEN
 THEN
;

' ECONOMISEUR 4- DUP DEBUT_ECONOMISEUR 4- - SWAP 2! DICO_INIT

ECONOMISEUR

( FIN
)