( Logiciel de demonstration 3D filaire.
  Version 2.00 du 17 Avril 2011.
  Ecrit par jpb.forth .
)

DECIMAL

START 2@ CONSTANT DEBUT_DEMO3D

( Variables de definition des projections :
  -----------------------------------------
)

0 VARIABLE FEN
FEN_STRING" S_FEN
DEMONSTRATION 3D"
3D DEMONSTRATION"
FEN_STRING" S_A_PROPOS

   Demonstration 3D FORTH

 Version 2.00 du 17/04/2011

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

Que le FORTH soit avec vous!
"

  FORTH 3D demonstration

Version 2.00 in 04/17/2011

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

May the FORTH be with you!
"

-500 VARIABLE DISTANCE 1000 VARIABLE PROFONDEUR
( DISTANCE doit etre inferieur ou egal a PROFONDEUR. )

0 VARIABLE DELTA_X 0 VARIABLE DELTA_Y 0 VARIABLE DELTA_Z
0 VARIABLE ANGLE_X 0 VARIABLE ANGLE_Y
0 VARIABLE SIN_X 32767 VARIABLE COS_X
0 VARIABLE SIN_Y 32767 VARIABLE COS_Y
( L'angle sur X varie de -180 a +180 degres,
  l'angle sur Y varie de -90 a +90 degres.   )

( Exemples de fichiers 3D en fils de fer :
  ----------------------------------------
    Le premier mot comporte le nombre de points, des que ce nombre est nul la
  figure est terminee.
  n x1 y1 z1 x2 y2 z2 ... xn-1 yn-1 zn-1 xn yn zn
  m x1 y1 z1 ... xm ym zm
  0
)

HERE
5 , 100 , 100 , 100 , -100 , 100 , 100 , -100 , -100 , 100 ,
    100 , -100 , 100 , 100 , 100 , 100 ,
5 , 100 , 100 , -100 , -100 , 100 , -100 , -100 , -100 , -100 ,
    100 , -100 , -100 , 100 , 100 , -100 ,
2 , 100 , 100 , 100 , 100 , 100 , -100 ,
2 , -100 , 100 , 100 , -100 , 100 , -100 ,
2 , -100 , -100 , 100 , -100 , -100 , -100 ,
2 , 100 , -100 , 100 , 100 , -100 , -100 ,
3 , 50 , 0 , 0 , 0 , 0 , 0 , 0 , 50 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 50 ,
2 , 150 , 70 , 70 , 150 , -70 , -70 , 2 , 150 , -70 , 70 , 150 , 70 , -70 , ( X )
2 , -70 , 150 , -70 , 0 , 150 , 0 , 2 , 70 , 150 , -70 , -70 , 150 , 70 , ( Y )
4 , -70 , 70 , 150 , 70 , 70 , 150 , -70 , -70 , 150 , 70 , -70 , 150 , ( Z )
0 ,
CONSTANT CUBE_3D

HERE
6 , 300 , -100 , 0 , 100 , -100 , 25 , -200 , -100 , 175 ,
    -200 , -100 , -175 , 100 , -100 , -25 , 300 , -100 , 0 ,
3 , -200 , -100 , 25 , -100 , -100 , 50 , -150 , -100 , 150 ,
3 , -200 , -100 , -25 , -100 , -100 , -50 , -150 , -100 , -150 ,
5 , -100 , -50 , 0 , -250 , 75 , 0 , -300 , 50 , 0 ,
    -250 , -50 , 0 , -100 , -50 , 0 ,
3 , -200 , -50 , 0 , -250 , 50 , 0 , -300 , 50 , 0 ,
4 , -200 , -100 , 25 , -200 , -50 , 25 , -200 , -50 , -25 , -200 , -100 , -25 ,
8 , 0 , -100 , 75 , 0 , -50 , 75 , 0 , -50 , 25 , -100 , -50 , 25 ,
    -100 , -50 , -25 , 0 , -50 , -25 , 0 , -50 , -75 , 0 , -100 , -75 ,
2 , 0 , -50 , 75 , -200 , -50 , 25 ,
2 , 0 , -50 , -75 , -200 , -50 , -25 ,
6 , -100 , -50 , 25 , 100 , 0 , 25 , 200 , -50 , 25 ,
    200 , -50 , -25 , 100 , 0 , -25 , -100 , -50 , -25 ,
5 , 100 , -100 , 25 , 200 , -50 , 25 , 300 , -100 , 0 ,
    200 , -50 , -25 , 100 , -100 , -25 ,
4 , 200 , -50 , 25 , 50 , -12 , 25 , 50 , -12 , -25 , 200 , -50 , -25 ,
0 ,
CONSTANT AVION_3D

: 16384_*/ ( n,m --> n*m/16384 )
 * 8192 OVER 0<
 IF
  NEGATE
 THEN
 + -14 ASH
;

: 32768_*/ ( n,m --> n*m/32768 )
 * 16384 OVER 0<
 IF
  NEGATE
 THEN
 + -15 ASH
;

: TRANSLATE_3D ( mul,div,dx,dy,dz,adr --> - )
 BEGIN
  DUP @
 WHILE
  DUP @ DUP , >R 2+ R> 0 DO
   DUP @ 7 PICK 7 PICK */ 5 PICK + , 2+
   DUP @ 7 PICK 7 PICK */ 4 PICK + , 2+
   DUP @ 7 PICK 7 PICK */ 3 PICK + , 2+
  LOOP
 REPEAT
 DROP DROP DROP DROP DROP DROP
;

: GENERE_AVIONS_3D
 1 2 200 100 50 AVION_3D TRANSLATE_3D
 1 2 0 0 -100 AVION_3D TRANSLATE_3D
 1 2 0 0 300 AVION_3D TRANSLATE_3D
 1 2 -200 -100 -300 AVION_3D TRANSLATE_3D
 0 ,
;

HERE GENERE_AVIONS_3D CONSTANT AVIONS_3D

: GENERE_SPHERE_3D
 8 0 DO
  33 , 8 -8 DO
   I 4096 * DUP SIN SWAP COS 2 0 DO
    I J + 1 AND K + 4096 * DUP SIN SWAP COS
    OVER 4 PICK 32768_*/ 70 16384_*/ ,
    DUP 70 16384_*/ ,
    OVER 5 PICK 32768_*/ 70 16384_*/ ,
    DROP DROP
   LOOP
   DROP DROP
  LOOP
  3 0 DO
   HERE 33 1- 6 * - @ ,
  LOOP
 LOOP
 0 ,
;

HERE GENERE_SPHERE_3D CONSTANT SPHERE_3D

: GENERE_TUBE_3D
 8 -8 DO
  10 ,
  I 4096 * DUP SIN SWAP COS I 1+ 4096 * DUP SIN SWAP COS
  3 PICK 50 16384_*/ , 100 , 4 PICK 50 16384_*/ ,
  DUP 50 16384_*/ , 100 , OVER 50 16384_*/ ,
  DUP 50 16384_*/ , 50 , OVER 50 16384_*/ ,
  3 PICK 50 16384_*/ , 50 , 4 PICK 50 16384_*/ ,
  3 PICK 50 16384_*/ , 0 , 4 PICK 50 16384_*/ ,
  DUP 50 16384_*/ , 0 , OVER 50 16384_*/ ,
  DUP 50 16384_*/ , -50 , OVER 50 16384_*/ ,
  3 PICK 50 16384_*/ , -50 , 4 PICK 50 16384_*/ ,
  3 PICK 50 16384_*/ , -100 , 4 PICK 50 16384_*/ ,
  DUP 50 16384_*/ , -100 , OVER 50 16384_*/ ,
  DROP DROP DROP DROP
 LOOP
 0 ,
;

HERE GENERE_TUBE_3D CONSTANT TUBE_3D

: GENERE_FUSEE_3D
 4 -4 DO
  21 I 1 AND 0=
  IF
   2+
  THEN
  , I 8192 * DUP SIN SWAP COS I 1+ 8192 * DUP SIN SWAP COS
  0 , 300 , 0 ,
  3 PICK 12 16384_*/ , 275 , 4 PICK 12 16384_*/ ,
  DUP 12 16384_*/ , 275 , OVER 12 16384_*/ ,
  DUP 25 16384_*/ , 225 , OVER 25 16384_*/ ,
  3 PICK 25 16384_*/ , 225 , 4 PICK 25 16384_*/ ,
  3 PICK 25 16384_*/ , 150 , 4 PICK 25 16384_*/ ,
  DUP 25 16384_*/ , 150 , OVER 25 16384_*/ ,
  DUP 12 16384_*/ , 100 , OVER 12 16384_*/ ,
  3 PICK 12 16384_*/ , 100 , 4 PICK 12 16384_*/ ,
  3 PICK 12 16384_*/ , -50 , 4 PICK 12 16384_*/ ,
  DUP 12 16384_*/ , -50 , OVER 12 16384_*/ ,
  DUP 25 16384_*/ , -100 , OVER 25 16384_*/ ,
  3 PICK 25 16384_*/ , -100 , 4 PICK 25 16384_*/ ,
  3 PICK 25 16384_*/ , -150 , 4 PICK 25 16384_*/ ,
  DUP 25 16384_*/ , -150 , OVER 25 16384_*/ ,
  I 1 AND 0=
  IF
   DUP 50 16384_*/ , -250 , OVER 50 16384_*/ ,
   DUP 50 16384_*/ , -300 , OVER 50 16384_*/ ,
  THEN
  DUP 25 16384_*/ , -250 , OVER 25 16384_*/ ,
  3 PICK 25 16384_*/ , -250 , 4 PICK 25 16384_*/ ,
  3 PICK 12 16384_*/ , -250 , 4 PICK 12 16384_*/ ,
  DUP 12 16384_*/ , -250 , OVER 12 16384_*/ ,
  DUP 25 16384_*/ , -300 , OVER 25 16384_*/ ,
  3 PICK 25 16384_*/ , -300 , 4 PICK 25 16384_*/ ,
  DROP DROP DROP DROP
 LOOP
 0 ,
;

HERE GENERE_FUSEE_3D CONSTANT FUSEE_3D

: GENERE_FUSEES_3D
 1 2 0 50 0 FUSEE_3D TRANSLATE_3D
 1 2 0 -50 -150 FUSEE_3D TRANSLATE_3D
 1 2 0 -50 150 FUSEE_3D TRANSLATE_3D
 0 ,
;

HERE GENERE_FUSEES_3D CONSTANT FUSEES_3D

: GENERE_RADAR_3D
 8 -8 DO
  12 , 0 , 100 , 0 ,
  I 4096 * DUP SIN SWAP COS I 1+ 4096 * DUP SIN SWAP COS
  3 PICK 25 16384_*/ , 0 , 4 PICK 25 16384_*/ ,
  DUP 25 16384_*/ , 0 , OVER 25 16384_*/ ,
  DUP 75 16384_*/ , 25 , OVER 75 16384_*/ ,
  3 PICK 75 16384_*/ , 25 , 4 PICK 75 16384_*/ ,
  3 PICK 100 16384_*/ , 50 , 4 PICK 100 16384_*/ ,
  DUP 100 16384_*/ , 50 , OVER 100 16384_*/ ,
  DUP 100 16384_*/ , 25 , OVER 100 16384_*/ ,
  3 PICK 100 16384_*/ , 25 , 4 PICK 100 16384_*/ ,
  3 PICK 50 16384_*/ , -25 , 4 PICK 50 16384_*/ ,
  DUP 50 16384_*/ , -25 , OVER 50 16384_*/ ,
  DROP DROP DROP DROP
  0 , -50 , 0 ,
 LOOP
 0 ,
;

HERE GENERE_RADAR_3D CONSTANT RADAR_3D

: GENERE_AXES_3D
 24 -24 DO
  3 , I 16384 12 */ DUP SIN SWAP COS
  I 1 AND
  IF
   91
  ELSE
   I 2 AND
   IF
    87
   ELSE
    75
   THEN
  THEN
  >R DUP R@ 16384_*/ , 0 , OVER R> 16384_*/ ,
  100 16384_*/ , 0 , 100 16384_*/ ,
  I 1+ 16384 12 */ DUP SIN SWAP COS
  100 16384_*/ , 0 , 100 16384_*/ ,
 LOOP
 -200 HERE 6- ! 12 -12 DO
  3 , I 16384 12 */ DUP SIN SWAP COS
  I 1 AND
  IF
   91
  ELSE
   I 2 AND
   IF
    87
   ELSE
    75
   THEN
  THEN
  >R DUP R@ 16384_*/ , OVER R> 16384_*/ , 0 ,
  100 16384_*/ , 100 16384_*/ , 0 ,
  I 1+ 16384 12 */ DUP SIN SWAP COS
  100 16384_*/ , 100 16384_*/ , 0 ,
 LOOP
 4 HERE 20- ! 0 , 150 , 0 ,
 3 , 100 , 0 , 0 , 0 , 0 , 0 , 0 , 100 , 0 ,
 2 , 0 , 0 , 0 , 0 , 0 , 100 ,
 0 ,
;

HERE GENERE_AXES_3D CONSTANT AXES_3D

: GENERE_ROUE_3D
 8 -8 DO
  12 ,
  I 4096 * DUP SIN SWAP COS I 1+ 4096 * DUP SIN SWAP COS
  3 PICK 75 16384_*/ , 25 , 4 PICK 75 16384_*/ ,
  DUP 75 16384_*/ , 25 , OVER 75 16384_*/ ,
  DUP 100 16384_*/ , 50 , OVER 100 16384_*/ ,
  3 PICK 100 16384_*/ , 50 , 4 PICK 100 16384_*/ ,
  3 PICK 125 16384_*/ , 35 , 4 PICK 125 16384_*/ ,
  DUP 125 16384_*/ , 35 , OVER 125 16384_*/ ,
  DUP 125 16384_*/ , -35 , OVER 125 16384_*/ ,
  3 PICK 125 16384_*/ , -35 , 4 PICK 125 16384_*/ ,
  3 PICK 100 16384_*/ , -50 , 4 PICK 100 16384_*/ ,
  DUP 100 16384_*/ , -50 , OVER 100 16384_*/ ,
  DUP 75 16384_*/ , -25 , OVER 75 16384_*/ ,
  3 PICK 75 16384_*/ , -25 , 4 PICK 75 16384_*/ ,
  DROP DROP DROP DROP
 LOOP
 0 ,
;

HERE GENERE_ROUE_3D CONSTANT ROUE_3D

( Projection d'un point 3D en 2D :
  --------------------------------
    1 - on applique la translation decrite par DELTA_X, DELTA_Y et DELTA_Z
    2 - on applique les rotations decrites par SIN_X, COS_X , SIN_Y et COS_Y
    3 - on applique le rapport avec DISTANCE et PROFONDEUR
  x,y,z PROJECTION_3D_A_2D x',y'
)

DECIMAL

: PROJECTION_3D_A_2D
 ( X' <-- X + DELTA_X, Y' <-- Y + DELTA_Y, Z' <-- Z + DELTA_Z )
 >R >R DELTA_X @ + R> DELTA_Y @ + R> DELTA_Z @ +
 ( X'' <-- X'.COS_Y + Z'.SIN_Y
   Y'' <-- Y'.COS_X + [ Z'.COS_Y - X'.SIN_Y ].SIN_X
   Z'' <-- [ Z'.COS_Y - X'.SIN_Y ].COS_X - Y'.SIN_X )
 3 PICK COS_Y @ 32768_*/ OVER SIN_Y @ 32768_*/ +
 OVER COS_Y @ 32768_*/ 5 PICK SIN_Y @ 32768_*/ - >R
 3 PICK COS_X @ 32768_*/ R@ SIN_X @ 32768_*/ +
 R> COS_X @ 32768_*/ 5 PICK SIN_X @ 32768_*/ -
 ( X2d <-- X''.[ Z'' + PROFONDEUR - DISTANCE ]/PROFONDEUR
   Y2d <-- Y''.[ Z'' + PROFONDEUR - DISTANCE ]/PROFONDEUR )
 PROFONDEUR @ + DISTANCE @ - >R
 SWAP R@ PROFONDEUR @ */
 SWAP R> PROFONDEUR @ */
 >R >R DROP DROP DROP R> R>
;

( Effacement total de la fenetre :
  --------------------------------
)

DECIMAL

: TAILLE_FIGURE_3D_A_2D ( adr --> taille en octets )
 0
 BEGIN
  OVER @ ?DUP
 WHILE
  DUP >R 2* 1+ 2* + SWAP R> 3 * 1+ 2* + SWAP
 REPEAT
 2+ >R DROP R>
;

( Calcul de projection 3d a 2d sur une figure complete :
  ------------------------------------------------------
    adr1,adr2 FIGURE_3D_A_2D -
  adr1 est l'adresse de la figure decrite en 3D
  adr2 est l'adresse ou sera stocke le resultat de la projection
)

DECIMAL

: FIGURE_3D_A_2D
 >R >R ECRAN 4+ @ 1+ R> R>
 BEGIN
  OVER @
 WHILE
  OVER @ DUP >R OVER ! >R 2+ R> 2+ R> 0 DO
   >R DUP @ 3 PICK DUP >R 640 */ OVER 2+ @ R@ 640 */
   3 PICK 4+ @ R> 640 */ PROJECTION_3D_A_2D 2 / NEGATE
   R@ 2+ ! 2 / R@ ! 6+ R> 4+
  LOOP
 REPEAT
 0 SWAP ! DROP DROP
;

 0 VARIABLE PRECED
 0 VARIABLE INDICE_ICONE
 0 VARIABLE INDEX_FIGURE
 0 VARIABLE POINTEUR_FIGURE
 0 VARIABLE NOUVELLE_FIGURE
 0 VARIABLE ANCIENNE_FIGURE
 0 VARIABLE CALCUL_FIGURE
 0 VARIABLE %_FIGURE

 80000 CONSTANT TAILLE_FIGURE

( Structure des donnees pointees par INDEX_FIGURE:
  [INDEX_FIGURE] --> nbr de points na (2) --> ... --> 0 fin de la liste
                     x1a,y1a (2,2)
                     x2a,y2a (2,2)
                     ...
                     xna,yna (2,2)
                     nbr de points nb (2)
                     x1b,y1b (2,2)
                     x2b,y2b (2,2)
                     ...
                     xnb,ynb (2,2)
                     ...
                     0 fin de la premiere figure (2)
)

FEN_STRING" S_MENU
CUBE
TUBE
SPHERE
ROUE
AXES
RADAR
AVION
AVIONS
FUSEE
FUSEES
FERMER...ESC F
MENU.....ESC N"
CUBIC
TUBE
SPHERE
COIL
AXES
RADAR
PLANE
PLANES
ROCKET
ROCKETS
CLOSE...ESC F
MENU....ESC N"
FEN_STRING" S_CALCUL

Calcul nouvelle sequence...
"

Compute new stream...
"
FEN_STRING" S_PB_MEMOIRE
Memoire INSUFFISANTE
   pour creer une
 nouvelle sequence!"
NOT ENOUGH memory
   to create a
   new stream!"

BIN HERE

0000000000000000 , ( 0 )
0000000000000000 ,
0000000001110000 ,
0000001110010000 ,
0000110000010000 ,
0000100000010000 ,
0000100000010000 ,
0111111111111110 ,
0000111111110000 ,
0000100000010000 ,
0000100000010000 ,
0000110000010000 ,
0000001110010000 ,
0000000001110000 ,
0000000000000000 ,
0000000000000000 ,

0000000000000000 , ( 1 )
0000000000000000 ,
0000000000000000 ,
0011111111111100 ,
0010000000000100 ,
0010000000000100 ,
0010000000000100 ,
0010011111100100 ,
0111111111111110 ,
0010000000000100 ,
0010000000000100 ,
0010000000000100 ,
0011111111111100 ,
0000000000000000 ,
0000000000000000 ,
0000000000000000 ,

0000000000000000 , ( 2 )
0000000000000000 ,
0000111000000000 ,
0000100111000000 ,
0000100000110000 ,
0000100000010000 ,
0000111111110000 ,
0000100000010000 ,
0001100000011000 ,
0011111111111100 ,
0000100000010000 ,
0000100000110000 ,
0000100111000000 ,
0000111000000000 ,
0000000000000000 ,
0000000000000000 ,

0000000000000000 , ( 3 )
0000000000000000 ,
0000001000000000 ,
0000001100000000 ,
0000111111110000 ,
0000101001010000 ,
0001001001001000 ,
0001001001001000 ,
0001001001001000 ,
0010001001000100 ,
0010001001000100 ,
0011111111111100 ,
0000001100000000 ,
0000001000000000 ,
0000000000000000 ,
0000000000000000 ,

0000000000000000 , ( 4 )
0000000100000000 ,
0000000100000000 ,
0011111111111100 ,
0010000100000100 ,
0010000110000100 ,
0010000110000100 ,
0010000110000100 ,
0010000110000100 ,
0010000110000100 ,
0010000110000100 ,
0010000100000100 ,
0011111111111100 ,
0000000100000000 ,
0000000100000000 ,
0000000000000000 ,

0000000000000000 , ( 5 )
0000000010000000 ,
0000000010000000 ,
0000000010000000 ,
0011111111111100 ,
0010000110000100 ,
0010000110000100 ,
0001000110001000 ,
0001000110001000 ,
0001000110001000 ,
0000100110010000 ,
0000111111110000 ,
0000000010000000 ,
0000000010000000 ,
0000000010000000 ,
0000000000000000 ,

0000000000000000 , ( 6 )
0000000000000000 ,
0000000001000000 ,
0000000011000000 ,
0000000101000000 ,
0000001001000000 ,
0011111111111100 ,
0001001001001000 ,
0000101001010000 ,
0000011111100000 ,
0000001001000000 ,
0000000101000000 ,
0000000011000000 ,
0000000001000000 ,
0000000000000000 ,
0000000000000000 ,

CONSTANT SYMBOLES_ICONE

DECIMAL

FEN: CALCUL_FIGURE_FEN
 0 DUP ANGLE_X ! ANGLE_Y !
 65536 TAILLE_FIGURE 2- CALCUL_FIGURE 2@ TAILLE_FIGURE_3D_A_2D /MOD >R DROP
 R@ / R> POINTEUR_FIGURE 2@ OVER 0 DO
  I 100 4 PICK */ %_FIGURE !
  ANGLE_X DUP >R @ DUP SIN 32767 MIN SIN_X !
  DUP COS 32767 MIN COS_X ! 4 PICK + R> !
  ANGLE_Y DUP >R @ DUP SIN 32767 MIN SIN_Y !
  DUP COS 32767 MIN COS_Y ! 4 PICK - R> !
  CALCUL_FIGURE 2@ OVER FIGURE_3D_A_2D
  BEGIN
   DUP @ ?DUP
   IF
    4* + 2+ 0
   ELSE
    2+ -1
   THEN
  UNTIL
 LOOP
 >R DUP XOR R> ! DUP XOR CALCUL_FIGURE 2!
;

( Trace d'un ensemble de segments :
  ---------------------------------
    adresse,couleur,fen TRACE_FIGURE -

  adresse --> nombre de points n1 du segment 1
              x1
              y1
              x2
              y2
              ...
              xn1
              yn1
              nombre de points n2 du segment 2
              x1
              y1
              ...
              xn2
              yn2
              0
)

: TRACE_FIGURE ( adresse,couleur,fen --> - )
 DUP >R FEN_TAILLE_? >R 2/ R> 2/ ROT 4 ROLL R>
 ( dx,dy,couleur,adresse,fen )
 BEGIN
  OVER @
 WHILE
  OVER >R >R 2+ R> R> @ 1- 0 DO
   OVER >R 3 PICK R@ @ 7 PICK + R@ 2+ @ 7 PICK +
   R@ 4+ @ 9 PICK + R> 6+ @ 9 PICK + 6 PICK FEN_TRACE_LIGNE >R 4+ R>
  LOOP
  >R 4+ R>
 REPEAT
 DROP DROP DROP DROP DROP
;

FEN: SP_AF_DEMO3D
 DUP >R FEN_TAILLE_? OVER 64 > OVER 64 > OR
 IF
  NOUVELLE_FIGURE 2@ ?DUP
  IF
   ANCIENNE_FIGURE 2@ OVER OVER -
   IF
    0 R@ TRACE_FIGURE
   ELSE
    DUP XOR 2 DUP 6 PICK 3- 6 PICK 3- R@ FEN_TRACE_REC
   THEN
   255 R@ TRACE_FIGURE
  THEN
 THEN
 DROP DROP R> DROP
;

FEN: CHRONO_FEN
 POINTEUR_FIGURE 2@ CALCUL_FIGURE 2@ 0= AND
 IF
  INDEX_FIGURE DUP >R 2@ MEMOIRE_LIBERE DROP
  0 POINTEUR_FIGURE DUP 2@ DUP R> 2!
  DUP ANCIENNE_FIGURE 2! NOUVELLE_FIGURE 2! 2!
 ELSE
  NOUVELLE_FIGURE DUP >R 2@ DUP ANCIENNE_FIGURE 2!
  BEGIN
   DUP @ ?DUP
   IF
    4* + 2+ 0
   ELSE
    2+ -1
   THEN
  UNTIL
  DUP @ 0=
  IF
   DROP INDEX_FIGURE 2@
  THEN
  R> 2!
 THEN
 >R INDICE_ICONE DUP >R @ 1+ 7 MOD R> !
 199 SP_AF_DEMO3D CHRONO_FEN R> FEN_CHRONO
;

FEN: AFFICHE_FEN
 >R 0 DUP DUP R@ FEN_TAILLE_? >R 1- R> 1- R> FEN_TRACE_REC
;

FEN: A_PROPOS_FEN
 >R S_A_PROPOS R> FEN_DIALOGUE_MESSAGE
;

FEN: ICONE_FEN
 DUP >R FEN_TAILLE_? >R 20- 2/ R> 20- 2/
 0 3 PICK 3 PICK OVER 19+ OVER 19+ R@ FEN_TRACE_REC
 >R >R 16 DUP 255 R> 2+ R> 2+ SYMBOLES_ICONE INDICE_ICONE @ 5 LSH +
 R> FEN_TRACE_MOTIF DROP DROP DROP DROP DROP
;

FEN: FERME_FEN
 >R ICONE_FEN R> FEN_ICONE
;

FEN: MENU_FEN
 BEGIN
  13 S_MENU 0 4 PICK FEN_DIALOGUE_CHOIX CASE
   1 OF
    -1 CUBE_3D
   ENDOF
   2 OF
    -1 TUBE_3D
   ENDOF
   3 OF
    -1 SPHERE_3D
   ENDOF
   4 OF
    -1 ROUE_3D
   ENDOF
   5 OF
    -1 AXES_3D
   ENDOF
   6 OF
    -1 RADAR_3D
   ENDOF
   7 OF
    -1 AVION_3D
   ENDOF
   8 OF
    -1 AVIONS_3D
   ENDOF
   9 OF
    -1 FUSEE_3D
   ENDOF
   10 OF
    -1 FUSEES_3D
   ENDOF
   11 OF
    DUP FERME_FEN EXECUTE -1 0
   ENDOF
   12 OF
    0 DUP
   ENDOF
   -1 0
  ENDCASE
  ?DUP
  IF
   TAILLE_FIGURE MEMOIRE_ALLOUE ?DUP
   IF
    POINTEUR_FIGURE 2! CALCUL_FIGURE 2!
    %_FIGURE 0 OVER ! CALCUL_FIGURE_FEN S_CALCUL 4 PICK FEN_DIALOGUE_PROGRESSE
   ELSE
    DROP S_PB_MEMOIRE 3 PICK FEN_DIALOGUE_MESSAGE
   THEN
  THEN
 UNTIL
 DROP
;

FEN: CLAVIER_FEN
 SWAP PRECED @ 27 =
 IF
  31 AND 0
 ELSE
  DUP 27 =
  IF
   0 SWAP
  ELSE
   0
  THEN
 THEN
 PRECED !

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

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

 IF
  BELL
 THEN
 DROP
;

: DEMO3D
 FEN @ ?DUP
 IF
  FEN_SELECTIONNE
 ELSE
  FEN_CREE ?DUP
  IF
   DUP >R FEN !
   S_FEN R@ FEN_NOM
   ECRAN DUP >R 4+ @ 1+ 2/ R> 6+ @ 1+ 2/
   OVER 2/ OVER 2/ R@ FEN_POSITION R@ FEN_TAILLE
   FERME_FEN R@ FEN_FERME
   A_PROPOS_FEN R@ FEN_A_PROPOS
   MENU_FEN R@ FEN_MENU
   220 140 20000 12000 R@ FEN_DIMENSIONS
   AFFICHE_FEN R@ FEN_AFFICHE
   ICONE_FEN R@ FEN_ICONE
   CLAVIER_FEN R@ FEN_CLAVIER
   1 SP_AF_DEMO3D CHRONO_FEN R@ FEN_CHRONO
   R@ FEN_ACTIVE
   CUBE_3D TAILLE_FIGURE MEMOIRE_ALLOUE ?DUP
   IF
    POINTEUR_FIGURE 2! CALCUL_FIGURE 2!
    %_FIGURE 0 OVER ! CALCUL_FIGURE_FEN S_CALCUL R> FEN_DIALOGUE_PROGRESSE
   ELSE
    DROP R> DROP
   THEN
  ELSE
   ." IMPOSSIBLE de creer l'application DEMONSTRATION 3D!" ABORT
  THEN
 THEN
;

' DEMO3D 4- DUP DEBUT_DEMO3D 4- - SWAP 2! DICO_INIT

DEMO3D

( FIN
)