home *** CD-ROM | disk | FTP | other *** search
/ Archive Magazine 1996 / ARCHIVE_96.iso / discs / mag_discs / volume_2 / issue_06 / pi_stuff / PISTANDAL < prev   
Text File  |  1988-12-29  |  3KB  |  110 lines
  1.   EMPTY
  2. : NEWSTART SP! LP! RP! 0 MODE PAGE CR
  3.   ." RiscFORTH.  Stand alone program." CR CR
  4.   ." PI calculator will calculate 1000 decimal places in about 33 seconds." CR
  5. CR ." The speed depends on which mode you are in. MODE 0 appears to be the fastest." CR CR
  6.   'QUIT @EXECUTE ;
  7.   ' NEWSTART ST-ADDR !   
  8.   100000 CONSTANT base 5 CONSTANT dp
  9.   0 CONSTANT fa
  10.   0 CONSTANT A 0 CONSTANT B 
  11.   0 CONSTANT X 0 CONSTANT Y
  12.   VARIABLE places 
  13.   VARIABLE pointer     0 pointer !
  14.   VARIABLE plusminus   0 plusminus !
  15.  
  16. ( Define 4 arrays )
  17. : A% 4 * A + ;        : B% 4 * B + ;
  18. : X% 4 * X + ;        : Y% 4 * Y + ;
  19.  
  20. ( Dimension space for 4 arrays ) 
  21. : DIM HERE TO A places @ 4 * ALLOT
  22.       HERE TO B places @ 4 * ALLOT
  23.       HERE TO X places @ 4 * ALLOT
  24.       HERE TO Y places @ 4 * ALLOT ;
  25.    
  26. ( Print ALL 5 digits from cell)
  27. : .CELL <# # # # # # #> TYPE SPACE ;
  28.  
  29. ( .PI prints final value)
  30. : .PI CR 0 Y% @ . ." ." places @ 1- 1 
  31.   DO I DUP Y% @ .CELL 13 MOD 0= 
  32.   IF 2 SPACES THEN LOOP CR ; 
  33.  
  34. ( INITialise A%[] & B%[] arrays )
  35. : INIT places @ 0 DO 
  36.   0  I A% !  0  I B% ! LOOP 1 0 B% ! 
  37.   0 pointer !   0 plusminus ! ; 
  38.  
  39. ( TAKE one cell from another ) 
  40. : TAKE + 2DUP < IF SWAP base + 
  41.    -: 1 ELSE - 0   THEN SWAP ;  
  42.  
  43. ( DIVide B%[] by number into B%[]. ) 
  44. : DIVB pointer @ DUP >R B% @  
  45.   OVER UM/MOD DUP R@ B% ! 0= 
  46.   IF 1 pointer +! THEN base * 
  47.   places @ R> 1+ 2DUP > IF DO I B% @ 
  48.   + OVER UM/MOD I B% ! base * LOOP 
  49.   ELSE 2DROP THEN 2DROP ;
  50.  
  51. ( DIVide B%[] by number into A%[] )
  52. : DIVA  0  places @  pointer @ 
  53.   1- DO I B% @ + OVER UM/MOD I A% ! 
  54.   base * LOOP 2DROP ;
  55.  
  56. ( Copy B%[] to A%[] ) 
  57. : B->A places @ 0 
  58.   DO I B% @ I A% ! LOOP ;
  59.  
  60. ( Add A%[] to X%[] ) 
  61. : ADDAX 0 0 places @ 1- DO I A% @ 
  62.   I X% @ + + base UM/MOD 
  63.   SWAP I X% ! -1 +LOOP DROP ;
  64.  
  65. ( Add X%[] to Y%[]. ) 
  66. : ADDXY 0 0 places @ 1- DO I X% @
  67.   I Y% @ + + base UM/MOD 
  68.   SWAP I Y% ! -1 +LOOP DROP ; 
  69.  
  70. ( Take A%[] from X%[]. ) 
  71. : TAKEAX 0 0 places @ 1-
  72.   DO I X% @ I A% @ ROT TAKE 
  73.   I X% ! -1 +LOOP DROP ; 
  74.  
  75. ( Times X%[] by number. ) 
  76. : TIMES 0 0 places @ 1- DO I X% @
  77.   2 PICK UM* + base UM/MOD 
  78.   SWAP I X% ! -1 +LOOP 2DROP ; 
  79.  
  80. ( Accumulate ARCTAN series in X%[] )
  81. : ACCUM 1 plusminus @ - DUP 
  82.   plusminus ! IF   ADDAX
  83.               ELSE TAKEAX THEN ;
  84.  
  85. ( Calculate Arctan )
  86. : ARCTAN DUP DUP INIT DIVB B->A
  87.   ACCUM 147 < IF DUP * 2 TO fa 
  88.   ELSE 1 TO fa THEN
  89.   1 BEGIN OVER DIVB fa + DUP 2 MOD 
  90.      IF DUP DIVA ACCUM 
  91.      THEN pointer @ places @ 1- > 
  92.   UNTIL 2DROP ;
  93.  
  94. ( Add all arctan series into Y%[]) 
  95. : PI 0 !TIME EMPTY 1- dp / 3 + 
  96.   places ! DIM places @ 0 
  97.        DO 0 I X% ! 0 I Y% ! LOOP 
  98.   8   ARCTAN 24 TIMES  ADDXY 
  99.   places @ 0 DO 0 I X% ! LOOP 
  100.   57  ARCTAN  8 TIMES  ADDXY 
  101.   places @ 0 DO 0 I X% ! LOOP 
  102.   239 ARCTAN  4 TIMES  ADDXY 
  103.   .PI CR ." Time:= " @TIME 
  104.   .TIME ." seconds" ;
  105.  
  106. : NEWQUIT BEGIN RP! CR ." Number of decimal places ?"
  107.   QUERY 32 WORD NUMBER CR PI CR AGAIN ;
  108. PROTECT
  109. HERE H.
  110.