( Fonctions mathematiques pour calculs en virgule flottante.
  Version 1.20 du 2 Fevrier 2002.
  Ecrit par jpb.forth .
)

TELECHARGEMENT

( Ce fichier contient le code des fonctions suivantes :
  FSQRT pour extraire la racine carree d'un nombre flottant,
  FEXP est la fonction exponentielle,
  FLN est la fonction logarithme neperien,
  FPI est le nombre flottant PI (constante),
  FTAN, FSIN et FCOS constituent les fonctions trigonometriques,
  FATAN, FASIN et FACOS sont les fonctions trigonometriques inverses.
)

DECIMAL

: FSQRT ( flottant --> flottant' )
 DUP 0>
 IF
  DUP 2139095040 AND 1073741824- DUP >R - R> 2/ DUP 4194304 AND
  IF
   >R [ 1 UFLOAT 2 UFLOAT F/ LITERAL ] F* R> 4194304+
  THEN
  >R DUP [ 25 UFLOAT 1000 UFLOAT F/ LITERAL ] F- 0<
  IF
   DUP [ 85 UFLOAT 10 UFLOAT F/ LITERAL ] F*
   [ 2 UFLOAT 10 UFLOAT F/ LITERAL ] F+
  ELSE
   DUP [ 875 UFLOAT 1000 UFLOAT F/ LITERAL ] F*
   [ 1 UFLOAT 100 UFLOAT F/ LITERAL ] F+
  THEN
  OVER [ 3288 UFLOAT 1000000 UFLOAT F/ LITERAL ] F- 0<
  IF
   8
  ELSE
   34
  THEN
  0 DO
   OVER OVER F/ F+ [ 1 UFLOAT 2 UFLOAT F/ LITERAL ] F*
  LOOP
  >R DROP R> R> +
 ELSE
  DUP 0<
  IF
   ." Racine carree d'un flottant negatif !" CR BELL
  THEN
 THEN
;

: FEXP0 ( flottant --> flottant' )
 [ 3 UFLOAT LITERAL ] 20 PUISSANCE F/ 20 0 DO
  DUP DUP F* [ 4 UFLOAT LITERAL ] F* [ 3 UFLOAT LITERAL ] F+ F*
 LOOP
 DUP DUP F* [ 1 UFLOAT LITERAL ] F+ FSQRT F+
;

: FLN0 ( flottant compris etre 1 et e --> flottant' )
 [ 1 UFLOAT LITERAL 0 UFLOAT LITERAL 1 UFLOAT FEXP0 LITERAL 1 UFLOAT LITERAL ]
 ( x,a,la,b,lb )
 BEGIN
  4 PICK 3 PICK F* FSQRT 4 PICK 3 PICK F+ [ 2 UFLOAT LITERAL ] F/
  ( x,a,la,b,lb,g,lg )
  7 PICK 3 PICK F- 0<
  IF
   >R >R DROP DROP R> R>
  ELSE
   >R >R >R >R DROP DROP R> R> R> R> 4 ROLL 4 ROLL
  THEN
  4 PICK 3 PICK F- FABS [ 5 UFLOAT 10000000 UFLOAT F/ LITERAL ] F- 0> NOT
 UNTIL
 >R DROP R> F+ [ 2 UFLOAT LITERAL ] F/ >R DROP DROP R>
;

: FEXP ( flottant --> flottant' )
 DUP 0<
 IF
  >R [ 1 UFLOAT LITERAL ] R> FNEGATE FEXP F/
 ELSE
  [ 177 UFLOAT LITERAL ] OVER F- 0<
  IF
   ." Exponentielle d'un flottant trop grand !" CR BELL
  ELSE
   [ 2 UFLOAT FLN0 LITERAL ] F/MOD >R
   [ 1 UFLOAT 1 UFLOAT 16 UFLOAT F/ F+ FLN0 LITERAL ] F/MOD >R
   [ 1 UFLOAT 1 UFLOAT 16 UFLOAT F/ F+ LITERAL ]
   R> PUISSANCE >R
   [ 1 UFLOAT 1 UFLOAT 256 UFLOAT F/ F+ FLN0 LITERAL ] F/MOD >R
   [ 1 UFLOAT 1 UFLOAT 256 UFLOAT F/ F+ LITERAL ]
   R> PUISSANCE R> F* >R
   [ 1 UFLOAT 1 UFLOAT 4096 UFLOAT F/ F+ FLN0 LITERAL ] F/MOD >R
   [ 1 UFLOAT 1 UFLOAT 4096 UFLOAT F/ F+ LITERAL ]
   R> PUISSANCE R> F* >R
   [ 1 UFLOAT 1 UFLOAT 65536 UFLOAT F/ F+ FLN0 LITERAL ] F/MOD >R
   [ 1 UFLOAT 1 UFLOAT 65536 UFLOAT F/ F+ LITERAL ]
   R> PUISSANCE R> F* >R
   DUP
   [ 1 UFLOAT 2 UFLOAT F/ LITERAL ] F*
   [ 1 UFLOAT LITERAL ] F+ F*
   [ 1 UFLOAT LITERAL ] F+
   R> F* R> 23 LSH +
  THEN
 THEN
;

: FLN ( flottant --> flottant' )
 DUP 0>
 IF
  DUP [ 1 UFLOAT LITERAL ] F- ?DUP
  IF
   0<
   IF
    >R [ 1 UFLOAT LITERAL ] R> F/ FLN FNEGATE
   ELSE
    DUP SWAB 65535 AND DUP 16640 > ( Test si superieur a 4 )
    IF
     16256- 32256 AND DUP -7 LSH NEGATE >R SWAB -
    ELSE
     DROP 0 >R
    THEN
    >R [ 2 UFLOAT FLN0 16777216+ LITERAL ] R>
    BEGIN
     DUP [ 1 UFLOAT 1 UFLOAT 16 UFLOAT F/ F+ LITERAL ] F*
     DUP [ 16 UFLOAT LITERAL ] U<
     IF
      >R DROP
      [ 1 UFLOAT 1 UFLOAT 16 UFLOAT F/ F+ FLN0 LITERAL ] F-
      R> 0
     ELSE
      DROP -1
     THEN
    UNTIL
    BEGIN
     DUP [ 1 UFLOAT 1 UFLOAT 256 UFLOAT F/ F+ LITERAL ] F*
     DUP [ 16 UFLOAT LITERAL ] U<
     IF
      >R DROP
      [ 1 UFLOAT 1 UFLOAT 256 UFLOAT F/ F+ FLN0 LITERAL ] F-
      R> 0
     ELSE
      DROP -1
     THEN
    UNTIL
    BEGIN
     DUP [ 1 UFLOAT 1 UFLOAT 4096 UFLOAT F/ F+ LITERAL ] F*
     DUP [ 16 UFLOAT LITERAL ] U<
     IF
      >R DROP
      [ 1 UFLOAT 1 UFLOAT 4096 UFLOAT F/ F+ FLN0 LITERAL ] F-
      R> 0
     ELSE
      DROP -1
     THEN
    UNTIL
    BEGIN
     DUP [ 1 UFLOAT 1 UFLOAT 65536 UFLOAT F/ F+ LITERAL ] F*
     DUP [ 16 UFLOAT LITERAL ] U<
     IF
      >R DROP
      [ 1 UFLOAT 1 UFLOAT 65536 UFLOAT F/ F+ FLN0 LITERAL ] F-
      R> 0
     ELSE
      DROP -1
     THEN
    UNTIL
    33554432- DUP
    [ -1 UFLOAT 2 UFLOAT F/ LITERAL ] F*
    [ 2 UFLOAT LITERAL ] F+ F*
    [ -3 UFLOAT 2 UFLOAT F/ LITERAL ] F+
    F+
    R> UFLOAT [ 2 UFLOAT FLN0 LITERAL ] F* F-
   THEN
  ELSE
   DROP 0
  THEN
 ELSE
  ." Logarithme d'un flottant negatif ou nul !" CR BELL
 THEN
;

: FPI ( - --> PI en flottant )
 [ 1 UFLOAT LITERAL ]
 [ 1 UFLOAT 2 UFLOAT F/ FSQRT LITERAL ]
 0 16 0 DO
  >R OVER OVER F* FSQRT
  >R F+ [ 2 UFLOAT LITERAL ] F/
  R> OVER DUP F* OVER DUP F* F-
  R> SWAP I 1+ 127+ 23 LSH F* F+
 LOOP
 [ -2 UFLOAT LITERAL ] F* [ 1 UFLOAT LITERAL ] F+
 >R DROP DUP F* [ 4 UFLOAT LITERAL ] F* R> F/
;

FPI FORGET FPI CONSTANT FPI

: FATAN0 ( flottant --> flottant' )
 DUP >R DUP F* R> DUP 0
 BEGIN
  OVER >R >R >R OVER F* R> OVER R@ 2* 3+ UFLOAT F/ R@ 1 AND
  IF
   F+
  ELSE
   F-
  THEN
  R> 1+ OVER R> F- 0=
 UNTIL
 DROP >R DROP DROP R>
;

: AJUSTEXY ( arc, y, x, ki, fatan[ki] --> arc', y', x' )
 >R 4 PICK R> F/MOD ?DUP
 IF
  ( arc, y, x, ki, arc', ai )
  >R 5 ROLL DROP 4 ROLL 4 ROLL R>
  ( ki, arc', y, x, ai )
  0 DO
   ( ki, arc', y, x )
   DUP 5 PICK 4 PICK F* F- >R 4 PICK F* F+ R>
  LOOP
  4 ROLL DROP
 ELSE
  ( arc, y, x, ki, arc )
  DROP DROP
 THEN
;

: FTANU ( flottant --> flottant' )
 [ 2 UFLOAT LITERAL ] F/ 0 [ 1 UFLOAT LITERAL ]
 ( angle moitie, y, x )
 [ 1 UFLOAT LITERAL FPI 4 UFLOAT F/ LITERAL ] AJUSTEXY
 [ 1 UFLOAT 16 UFLOAT F/ DUP LITERAL FATAN0 LITERAL ] AJUSTEXY
 [ 1 UFLOAT 16 UFLOAT 2 PUISSANCE F/ DUP LITERAL FATAN0 LITERAL ] AJUSTEXY
 [ 1 UFLOAT 16 UFLOAT 3 PUISSANCE F/ DUP LITERAL FATAN0 LITERAL ] AJUSTEXY
 [ 1 UFLOAT 16 UFLOAT 4 PUISSANCE F/ DUP LITERAL FATAN0 LITERAL ] AJUSTEXY
 [ 1 UFLOAT 16 UFLOAT 5 PUISSANCE F/ DUP LITERAL FATAN0 LITERAL ] AJUSTEXY
 F/ >R DROP R>
;

: FTAN ( flottant --> flottant' )
 [ FPI LITERAL ] F/MOD DROP DUP
 IF
  DUP 0<
  IF
   FNEGATE FTAN FNEGATE
  ELSE
   DUP [ FPI 2 UFLOAT F/ LITERAL ] F- ?DUP
   IF
    0> DUP >R
    IF
     [ FPI LITERAL ] F- FNEGATE
    THEN
    FTANU DUP DUP FNEGATE F* [ 1 UFLOAT LITERAL ] F+ F/
    [ 2 UFLOAT LITERAL ] F* R>
    IF
     FNEGATE
    THEN
   ELSE
    ." Tangente de PI/2 ou -PI/2 !" CR BELL
   THEN
  THEN
 THEN
;

: FSIN ( flottant --> flottant' )
 [ FPI LITERAL ] F/MOD 1 AND
 IF
  FNEGATE
 THEN
 DUP 0<
 IF
  FNEGATE FSIN FNEGATE
 ELSE
  [ FPI 2 UFLOAT F/ LITERAL ] F/MOD 1 AND
  IF
   >R [ FPI 2 UFLOAT F/ LITERAL ] R> F-
  THEN
  FTANU DUP DUP F* [ 1 UFLOAT LITERAL ] F+ F/ [ 2 UFLOAT LITERAL ] F*
 THEN
;

: FCOS ( flottant --> flottant' )
 [ FPI 2 UFLOAT F/ LITERAL ] F- FNEGATE FSIN
;

: FATAN ( flottant --> flottant' )
 DUP 0<
 IF
  FNEGATE FATAN FNEGATE
 ELSE
  [ 1 UFLOAT LITERAL ] OVER F- 0<
  IF
   >R [ FPI 2 UFLOAT F/ LITERAL 1 UFLOAT LITERAL ] R> F/ FATAN F-
  ELSE
   [ FPI 12 UFLOAT F/ FTAN LITERAL ] OVER F- 0< DUP >R
   IF
    DUP >R [ 3 UFLOAT FSQRT LITERAL ] F* [ 1 UFLOAT LITERAL ] F-
    R> [ 3 UFLOAT FSQRT LITERAL ] F+ F/
   THEN
   DUP DUP F* DUP DUP F*
   OVER [ 10 UFLOAT LITERAL ] F* F+
   [ 9 UFLOAT LITERAL ] F* [ 105 UFLOAT LITERAL ] F+
   >R [ 55 UFLOAT LITERAL ] F*
   [ 105 UFLOAT LITERAL ] F+ F* R> F/ R>
   IF
    [ FPI 6 UFLOAT F/ LITERAL ] F+
   THEN
  THEN
 THEN
;

: FASIN ( flottant --> flottant' )
 DUP 0<
 IF
  FNEGATE FASIN FNEGATE
 ELSE
  [ 1 UFLOAT LITERAL ] DUP 3 PICK F- ?DUP
  IF
   0<
   IF
    DROP ." Arcsinus d'un flottant exterieur a [-1,+1] !" CR BELL
   ELSE
    OVER DUP F* F- FSQRT F/ FATAN
   THEN
  ELSE
   DROP DROP [ FPI 2 UFLOAT F/ LITERAL ]
  THEN
 THEN
;

: FACOS ( flottant --> flottant' )
 >R [ FPI 2 UFLOAT F/ LITERAL ] R> FASIN F-
;

( FIN
)