( Copyright PPC Paris 1986 ) ( opÅrations sur la pile en virgule flottante ) ( seront notÅes (n1 -F- n2), n1 en X devient n2 ) DECIMAL VOCABULARY VOC-DL VOC-DL DEFINITIONS ( On crÅe un nouveau vocabulaire VOC-DL ) VARIABLE PILENIV 0 PILENIV ! ( position du ) ( registre X de la pile de poly. dans STACK ) VARIABLE DEGRE 5 DEGRE ! ( DEGRE contient ) ( l'ordre auquel doivent Átre fait les ) ( calculs ) 10 CONSTANT DEGREMAX ( degrÅ maximal des poly. ) CREATE STACK DEGREMAX 1+ 64 * NALLOT ( espace ) ( mÅmoire rÅservÅe Č la pile des poly. ) 42 CONSTANT LENMAX ( longueur maximale des ) ( chaŅnes caractÅrisant les poly. ) LENMAX 4 STRING-ARRAY STACK$ ( espace mÅmoire ) ( contenant les chaŅnes des poly. ) : BOUCLE ( --- n1 ) ( valeur revenant souvent ) ( pour les boucles ) DEGRE @ 1+ ; : #NIVEAU ( n1 --- n2 ) ( retourne l'adresse ) ( du registre caractÅrisÅ par n1 ; 0 pour X etc ) PILENIV @ + 4 /MOD DROP BOUCLE 16 * * STACK + ; : X ( --- n1 ) ( renvoit l'adresse du reg. X ) 0 #NIVEAU ; : Y ( --- n1 ) ( idem pour Y ) 1 #NIVEAU ; : Z ( --- n1 ) ( idem pour Z ) 2 #NIVEAU ; : T ( --- n1 ) ( idem pour T ) 3 #NIVEAU ; : COEFF@ ( add n1 --- ) ( -F- n2 ) ( add est ) ( l'adresse de X-Y-Z ou T, n1 est le ) (numÅro du coeff., n2 est le coeff. dÅsirÅ ) 16 * + STO ; : COEFF! ( add n1 --- ) ( n2 -F- ) ( stocke n2 dans le registre d'adresse ) ( add au niÅme emplaĩement ) 16 * + STO ; : SMOVELEN ( str add --- ) ( voir article ) OVER OVER 2- ! SMOVE ; : .DL ( affiche la chaŅne du poly. qui est en X ) CR PILENIV @ 1+ STACK$ TYPE ; : REDIM ( n1 ---) ( change l'ordre des DL ) DUP DEGREMAX > IF U. ." superieur a " DEGREMAX U. EXIT ELSE DEGRE ! .DL THEN ; : #NIVEAU$ ( n1 --- str ) ( idem #NIVEAU mais ) ( pour les chaines ) PILENIV @ + 4 /MOD DROP 1+ STACK$ ; : X$ ( ---str ) ( retourne la chaŅne du DL en ) ( X ) 0 #NIVEAU$ ; : Y$ ( --- str ) ( idem pour Y ) 1 #NIVEAU$ ; : Z$ ( --- str ) ( idem pour Z ) 2 #NIVEAU$ ; : T$ ( --- str ) ( idem pour T ) 3 #NIVEAU$ ; : BAS ( dÅcrÅmente PILENIV ) PILENIV @ ?DUP IF 1- ELSE 3 THEN PILENIV ! ; : HAUT ( incrÅmente la valeur de PILENIV ) PILENIV @ 1+ 4 /MOD DROP PILENIV ! ; : RUP ( fait tourner la pile vers le haut ) BAS .DL ; : RDN ( fait tourner la pile vers le bas ) HAUT .DL ; : CLX ( no comment ) BOUCLE 0 DO T I COEFF@ X I COEFF! LOOP PILENIV @ 3 + 4 /MOD DROP 1+ STACK$ PILENIV @ 1+ STACK$ DROP SMOVELEN RDN ; : CLST ( remet pile et chaines Ā zero ) STACK BOUCLE 64 * 0 NFILL 0 X$ DROP 2- C! 0 Y$ DROP 2- C! 0 Z$ DROP 2- C! 0 T$ DROP 2- C! ; : ENTER ( duplique le poly. en X ) X T BOUCLE 8 * CMOVE X$ T$ DROP SMOVELEN RUP ; : IFACT ( n1 --- ) ( -F- n2 ) ( n2 est ) ( FACT(n1) ) DUP DUP 1 <> * IF DUP ITOF 1 D0 I ITOF F* ELSE DROP 1. THEN ; : . ( affiche les coeff. du poly en X ) BOUCLE 0 DO CR X I COEFF@ ." a(" I . ." )=" F. KEY DROP LOOP .DL ; : X<>Y ( Åchange le contenu de X avec celui de ) ( Y ) BOUCLE 0 DO X I COEFF@ Y I COEFF@ X I COEFF! X<>Y Y I COEFF! LOOP X$ SWAP OVER PAD SMOVE Y$ X$ DROP SMOVELEN PAD SWAP Y$ DROP SMOVELEN .DL ; VARIABLE DEPOT ( sauvegarde momentanÅe d'un nbr ) VARIABLE VARIDEF ( contient le CFA de la def. ) ( d'une fonction ; COS, SIN ... ) : ?DEF ( voir article ) BAS BOUCLE 0 DO I VARIDEF @ EXECUTE X I COEFF! LOOP PILENIV @ 1+ STACK$ DROP SMOVELEN . DL ; : IMPAIR? ( n1 --- b ) ( renvoit 1 si n1 impair ) ( 0 sinon ) 1 AND ; : PAIR? ( n1 --- b ) ( renvoit -1 si n1 pair, ) ( 0 sinon ) IMPAIR? 1- ; : EXPDEF IFACT 1/X ; : EXP " EXP" ['] EXPDEF VARIDEF ! ?DEF ; : SINDEF DUP IMPAIR? IF -1. DUP 1- 2/ ITOF Y^X IFACT F/ ELSE DROP 0. THEN ; : SIN " SIN" ['] SINDEF VARIDEF ! ?DEF ; : LOGDEF DUP IF DUP 1+ -1. ITOF Y^X ITOF F/ ELSE DROP 0. THEN ; : LOG " LOG" ['] LOGDEF VARIDEF ! ?DEF ; : SHDEF DUP IMPAIR? IF IFACT 1/X ELSE DROP 0. THEN ; : SH " SH" ['] SHDEF VARIDEF ! ?DEF ; : COSDEF DUP PAIR? IF -1. DUP 2/ ITOF Y^X IFACT F/ ELSE DROP 0. THEN ; : COS " COS" ['] COSDEF VARIDEF ! ?DEF ; : CHDEF DUP PAIR? IF IFACT 1/X ELSE DROP 0. THEN ; : CH " CH" ['] CHDEF VARIDEF ! ?DEF ; : ATANDEF DUP IMPAIR? IF -1. DUP 1- 2/ ITOF Y^X ITOF F/ ELSE DROP 0. THEN ; : ATAN " ATAN" ['] ATANDEF VARIDEF ! ?DEF ; : ATHDEF DUP IMPAIR? IF ITOF 1/X ELSE DROP 0. THEN ; : ATH " ATH" ['] ATHDEF VARIDEF ! ?DEF ; : ASINDEF DUP IMPAIR? IF DUP 1- DUP DUP IFACT 2. ITOF Y^X F/ 2/ IFACT X^2 F/ ITOF F/ ELSE DROP 0. THEN ; : ASIN " ASIN" ['] ASINDEF VARIDEF ! ?DEF ; : ASHDEF DUP IMPAIR? IF -1. DUP 1- 2/ ITOF Y^X DUP 1- DUP DUP IFACT 2. ITOF Y^X F/ 2/ IFACT X^2 F/ ITOF F/ ELSE DROP 0 THEN ; : ASH " ASH" ['] ASHDEF VARIDEF ! ?DEF ; : POLY ( permet de rentrer un poly. quelconque ) BAS X BOUCLE 16 * 0 NFILL X$ DROP DUP CR ." Nom du poly : " EXPECT96 2- SPAN @ SWAP C! DEPTH DEPOT ! BOUCLE 0 DO ." a(" I U. ." )=" QUERY #TIB @ IF INTERPRET DEPTH DEPOT @ - IF ITOF THEN X I COEFF! ELSE LEAVE THEN LOOP .DL ; CREATE SCRATCH1 DEGREMAX 1+ 16 * NALLOT CREATE SCRATCH2 DEGREMAX 1+ 16 * NALLOT CREATE SCRATCH3 DEGREMAX 1+ 16 * NALLOT : / ( divise le poly. en Y par celui en X ) SCRATCH1 BOUCLE 16 * 0 NFILL -1 BEGIN 1+ DUP X SWAP COEFF@ X=0? 1+ UNTIL BOUCLE DEPOT @ DO Y I COEFF@ X DEPOT @ COEFF@ F/ SCRATCH1 I DEPOT @ - COEFF! 0 DEGRE @ I - DO Y J I + COEFF@ X DEPOT @ I + COEFF@ Y J COEFF@ F* X DEPOT @ COEFF@ F/ F- Y J I + COEFF! -1 +LOOP LOOP BOUCLE 0 DO SCRATCH1 I COEFF@ Y I COEFF! LOOP " (" Y$ S>& " )/(" S<& X$ S<& " )" S<& 2DROP CLX ; : COMP ( compose le poly. en Y par celui en X ) Y 0 COEFF@ X=0? 1+ IF CR ." Y(0)#0" EXIT THEN SCRATCH2 BOUCLE 16 * 0 NFILL BOUCLE 0 DO Y I COEFF@ SCRATCH1 I COEFF! LOOP X 0 COEFF@ SCRATCH2 0 COEFF! BOUCLE 0 DO X 1 COEFF@ Y I COEFF@ F* SCRATCH2 I COEFF@ F+ SCRATCH2 I COEFF! LOOP BOUCLE 2 DO BOUCLE 0 DO 0. I 1+ 0 DO Y I COEFF@ SCRATCH1 J I - COEFF@ F* F+ LOOP SCRATCH3 I COEFF! LOOP BOUCLE 0 DO SCRATCH3 I COEFF@ Y I COEFF! LOOP BOUCLE 0 DO Y I COEFF@ X J COEFF@ F* SCRATCH2 I COEFF@ F+ SCRATCH2 I COEFF! LOOP LOOP BOUCLE 0 DO SCRATCH2 I COEFF@ Y I COEFF! LOOP X$ " [" S<& Y$ S>& " ]" S<& 2DROP CLX ; : CHS ( change le signe du poly. en X ) X 15 + BOUCLE 0 DO DUP 9 TOGGLE 16 + LOOP DROP " -(" X$ S>& " )" S<& 2DROP .DL ; : * ( multiplie le poly. en X par celui en Y ) BOUCLE 0 DO 0. I 1+ 0 DO X I COEFF@ Y J I - COEFF@ F* F+ LOOP SCRATCH1 I COEFF! LOOP BOUCLE 0 DO SCRATCH1 I COEFF@ Y I COEFF! LOOP " (" X$ S>& " )*(" S<& Y$ S>& " )" S<& 2DROP CLX ; : + ( additionne le poly. en X avec celui en Y ) BOUCLE 0 DO X I COEFF@ Y I COEFF@ F+ Y I COEFF! LOOP Y$ " +" S<& X$ S<& 2DROP CLX ; : - ( soustrait le poly. en X Ā celui en Y ) BOUCLE 0 DO Y I COEFF@ X I COEFF@ F- Y I COEFF! LOOP Y$ " -(" S<& X$ S<& " )" S<& 2DROP CLX ; : FRC ( n1 --- ) ( donne la fraction du ) ( coeff. d'ordre n1 du poly. en X ) ( utilise FRC qui doit se trouver dans le ) ( vocabulaire FORTH, voir article ) DUP DEGRE @ > IF U. ." c'est trop grand." EXIT THEN X SWAP COEFF@ FRC PAD EXPECT96 .DL ; ( opÅrations sur la pile en virgule flottante ) ( seront notÅes (n1 -F- n2), n1 en X devient n2 ) DECIMAL VOCABULARY VOC-DL VOC-DL DEFINITIONS ( On crÅe un nouveau vocabulaire VOC-DL ) VARIABLE PILENIV 0 PILENIV ! ( position du ) ( registre X de la pile de poly. dans STACK ) VARIABLE DEGRE 5 DEGRE ! ( DEGRE contient ) ( l'ordre auquel doivent Átre fait les ) ( calculs ) 10 CONSTANT DEGREMAX ( degrÅ maximal des poly. ) CREATE STACK DEGREMAX 1+ 64 * NALLOT ( espace ) ( mÅmoire rÅservÅe Č la pile des poly. ) 42 CONSTANT LENMAX ( longueur maximale des ) ( chaŅnes caractÅrisant les poly. ) LENMAX 4 STRING-ARRAY STACK$ ( espace mÅmoire ) ( contenant les chaŅnes des poly. ) : BOUCLE ( --- n1 ) ( valeur revenant souvent ) ( pour les boucles ) DEGRE @ 1+ ; : #NIVEAU ( n1 --- n2 ) ( retourne l'adresse ) ( du registre caractÅrisÅ par n1 ; 0 pour X etc ) PILENIV @ + 4 /MOD DROP BOUCLE 16 * * STACK + ; : X ( --- n1 ) ( renvoit l'adresse du reg. X ) 0 #NIVEAU ; : Y ( --- n1 ) ( idem pour Y ) 1 #NIVEAU ; : Z ( --- n1 ) ( idem pour Z ) 2 #NIVEAU ; : T ( --- n1 ) ( idem pour T ) 3 #NIVEAU ; : COEFF@ ( add n1 --- ) ( -F- n2 ) ( add est ) ( l'adresse de X-Y-Z ou T, n1 est le ) ( numÅro du coeff. , n2 est le coeff. dÅsirÅ ) : COEFF! ( add n1 --- ) ( n2 -F- ) ( stocke n2 dans le registre d'adresse ) ( add au niÅme emplaĩement ) 16 * + STO ; : SMOVELEN ( str add --- ) ( voir article ) OVER OVER 2- ! SMOVE ; : .DL ( affiche la chaŅne du poly. qui est en X ) CR PILENIV @ 1+ STACK$ TYPE ; : REDIM ( n1 ---) ( change l'ordre des DL ) DUP DEGREMAX > IF U. ." superieur a " DEGREMAX U. EXIT ELSE DEGRE ! .DL THEN ; : #NIVEAU$ ( n1 --- str ) ( idem #NIVEAU mais ) ( pour les chaines ) PILENIV @ + 4 /MOD DROP 1+ STACK$ ; : X$ ( ---str ) ( retourne la chaŅne du DL en ) ( X ) 0 #NIVEAU$ ; : Y$ ( --- str ) ( idem pour Y ) 1 #NIVEAU$ ; : Z$ ( --- str ) ( idem pour Z ) 2 #NIVEAU$ ; : T$ ( --- str ) ( idem pour T ) 3 #NIVEAU$ ; : BAS ( dÅcrÅmente PILENIV ) PILENIV @ ?DUP IF 1- ELSE 3 THEN PILENIV ! ; : HAUT ( incrÅmente la valeur de PILENIV ) PILENIV @ 1+ 4 /MOD DROP PILENIV ! ; : RUP ( fait tourner la pile vers le haut ) BAS .DL ; : RDN ( fait tourner la pile vers le bas ) HAUT .DL ; : CLX ( no comment ) BOUCLE 0 DO T I COEFF@ X I COEFF! LOOP PILENIV @ 3 + 4 /MOD DROP 1+ STACK$ PILENIV @ 1+ STACK$ DROP SMOVELEN RDN ; : CLST ( remet pile et chaines Ā zero ) STACK BOUCLE 64 * 0 NFILL 0 X$ DROP 2- C! 0 Y$ DROP 2- C! 0 Z$ DROP 2- C! 0 T$ DROP 2- C! ; : ENTER ( duplique le poly. en X ) X T BOUCLE 8 * CMOVE X$ T$ DROP SMOVELEN RUP ; : IFACT ( n1 --- ) ( -F- n2 ) ( n2 est ) ( FACT(n1) ) DUP DUP 1 <> * IF DUP ITOF 1 D0 I ITOF F* ELSE DROP 1. THEN ; : . ( affiche les coeff. du poly en X ) BOUCLE 0 DO CR X I COEFF@ ." a(" I . ." )=" F. KEY DROP LOOP .DL ; : X<>Y ( Åchange le contenu de X avec celui de ) ( Y ) BOUCLE 0 DO X I COEFF@ Y I COEFF@ X I COEFF! X<>Y Y I COEFF! LOOP X$ SWAP OVER PAD SMOVE Y$ X$ DROP SMOVELEN PAD SWAP Y$ DROP SMOVELEN .DL ; VARIABLE DEPOT ( sauvegarde momentanÅe d'un nbr ) VARIABLE VARIDEF ( contient le CFA de la def. ) ( d'une fonction ; COS, SIN ... ) : ?DEF ( voir article ) BAS BOUCLE 0 DO I VARIDEF @ EXECUTE X I COEFF! LOOP PILENIV @ 1+ STACK$ DROP SMOVELEN . DL ; : IMPAIR? ( n1 --- b ) ( renvoit 1 si n1 impair ) ( 0 sinon ) 1 AND ; : PAIR? ( n1 --- b ) ( renvoit -1 si n1 pair, ) ( 0 sinon ) IMPAIR? 1- ; : EXPDEF IFACT 1/X ; : EXP " EXP" ['] EXPDEF VARIDEF ! ?DEF ; : SINDEF DUP IMPAIR? IF -1. DUP 1- 2/ ITOF Y^X IFACT F/ ELSE DROP 0. THEN ; : SIN " SIN" ['] SINDEF VARIDEF ! ?DEF ; : LOGDEF DUP IF DUP 1+ -1. ITOF Y^X ITOF F/ ELSE DROP 0. THEN ; : LOG " LOG" ['] LOGDEF VARIDEF ! ?DEF ; : SHDEF DUP IMPAIR? IF IFACT 1/X ELSE DROP 0. THEN ; : SH " SH" ['] SHDEF VARIDEF ! ?DEF ; : COSDEF DUP PAIR? IF -1. DUP 2/ ITOF Y^X IFACT F/ ELSE DROP 0. THEN ; : COS " COS" ['] COSDEF VARIDEF ! ?DEF ; : CHDEF DUP PAIR? IF IFACT 1/X ELSE DROP 0. THEN ; : CH " CH" ['] CHDEF VARIDEF ! ?DEF ; : ATANDEF DUP IMPAIR? IF -1. DUP 1- 2/ ITOF Y^X ITOF F/ ELSE DROP 0. THEN ; : ATAN " ATAN" ['] ATANDEF VARIDEF ! ?DEF ; : ATHDEF DUP IMPAIR? IF ITOF 1/X ELSE DROP 0. THEN ; : ATH " ATH" ['] ATHDEF VARIDEF ! ?DEF ; : ASINDEF DUP IMPAIR? IF DUP 1- DUP DUP IFACT 2. ITOF Y^X F/ 2/ IFACT X^2 F/ ITOF F/ ELSE DROP 0. THEN ; : ASIN " ASIN" ['] ASINDEF VARIDEF ! ?DEF ; : ASHDEF DUP IMPAIR? IF -1. DUP 1- 2/ ITOF Y^X DUP 1- DUP DUP IFACT 2. ITOF Y^X F/ 2/ IFACT X^2 F/ ITOF F/ ELSE DROP 0 THEN ; : ASH " ASH" ['] ASHDEF VARIDEF ! ?DEF ; : POLY ( permet de rentrer un poly. quelconque ) BAS X BOUCLE 16 * 0 NFILL X$ DROP DUP CR ." Nom du poly : " EXPECT96 2- SPAN @ SWAP C! DEPTH DEPOT ! BOUCLE 0 DO ." a(" I U. ." )=" QUERY #TIB @ IF INTERPRET DEPTH DEPOT @ - IF ITOF THEN X I COEFF! ELSE LEAVE THEN LOOP .DL ; CREATE SCRATCH1 DEGREMAX 1+ 16 * NALLOT CREATE SCRATCH2 DEGREMAX 1+ 16 * NALLOT CREATE SCRATCH3 DEGREMAX 1+ 16 * NALLOT : / ( divise le poly. en Y par celui en X ) SCRATCH1 BOUCLE 16 * 0 NFILL -1 BEGIN 1+ DUP X SWAP COEFF@ X=0? 1+ UNTIL BOUCLE DEPOT @ DO Y I COEFF@ X DEPOT @ COEFF@ F/ SCRATCH1 I DEPOT @ - COEFF! 0 DEGRE @ I - DO Y J I + COEFF@ X DEPOT @ I + COEFF@ Y J COEFF@ F* X DEPOT @ COEFF@ F/ F- Y J I + COEFF! -1 +LOOP LOOP BOUCLE 0 DO SCRATCH1 I COEFF@ Y I COEFF! LOOP " (" Y$ S>& " )/(" S<& X$ S<& " )" S<& 2DROP CLX ; : COMP ( compose le poly. en Y par celui en X ) Y 0 COEFF@ X=0? 1+ IF CR ." Y(0)#0" EXIT THEN SCRATCH2 BOUCLE 16 * 0 NFILL BOUCLE 0 DO Y I COEFF@ SCRATCH1 I COEFF! LOOP X 0 COEFF@ SCRATCH2 0 COEFF! BOUCLE 0 DO X 1 COEFF@ Y I COEFF@ F* SCRATCH2 I COEFF@ F+ SCRATCH2 I COEFF! LOOP BOUCLE 2 DO BOUCLE 0 DO 0. I 1+ 0 DO Y I COEFF@ SCRATCH1 J I - COEFF@ F* F+ LOOP SCRATCH3 I COEFF! LOOP BOUCLE 0 DO SCRATCH3 I COEFF@ Y I COEFF! LOOP BOUCLE 0 DO Y I COEFF@ X J COEFF@ F* SCRATCH2 I COEFF@ F+ SCRATCH2 I COEFF! LOOP LOOP BOUCLE 0 DO SCRATCH2 I COEFF@ Y I COEFF! LOOP X$ " [" S<& Y$ S>& " ]" S<& 2DROP CLX ; : CHS ( change le signe du poly. en X ) X 15 + BOUCLE 0 DO DUP 9 TOGGLE 16 + LOOP DROP " -(" X$ S>& " )" S<& 2DROP .DL ; : * ( multiplie le poly. en X par celui en Y ) BOUCLE 0 DO 0. I 1+ 0 DO X I COEFF@ Y J I - COEFF@ F* F+ LOOP SCRATCH1 I COEFF! LOOP BOUCLE 0 DO SCRATCH1 I COEFF@ Y I COEFF! LOOP " (" X$ S>& " )*(" S<& Y$ S>& " )" S<& 2DROP CLX ; : + ( additionne le poly. en X avec celui en Y ) BOUCLE 0 DO X I COEFF@ Y I COEFF@ F+ Y I COEFF! LOOP Y$ " +" S<& X$ S<& 2DROP CLX ; : - ( soustrait le poly. en X Ā celui en Y ) BOUCLE 0 DO Y I COEFF@ X I COEFF@ F- Y I COEFF! LOOP Y$ " -(" S<& X$ S<& " )" S<& 2DROP CLX ; : FRC ( n1 --- ) ( donne la fraction du ) ( coeff. d'ordre n1 du poly. en X ) ( utilise FRC qui doit se trouver dans le ) ( vocabulaire FORTH, voir article ) DUP DEGRE @ > IF U. ." c'est trop grand." EXIT THEN X SWAP COEFF@ FRC PAD EXPECT96 .DL ;