home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / quad.seq < prev    next >
Encoding:
Text File  |  1989-07-04  |  1.8 KB  |  72 lines
  1. \ Quadratic Equation solver.
  2. \ Requires VP-Planner Floating Point package VPSFP101.ZIP
  3.  
  4.    FLOATING
  5.    FVARIABLE A
  6.    FVARIABLE B
  7.    FVARIABLE C
  8.  
  9. 0. FVALUE ROOT1
  10. 0. FVALUE ROOT2
  11. 0. FVALUE REAL_PART
  12. 0. FVALUE IMAG_PART
  13. 0. FVALUE B^2-4AC
  14.  
  15. : GET_DATA ( -- )
  16.        CLS  20 2 AT ." Quadratic Equation Solver "
  17.        0. A F! 0. B F! 0. C F!
  18.        0 4 AT ." Input value of A : " A 20 4 10 XYWF#ED
  19.        0 6 AT ." Input value of B : " B 20 6 10 XYWF#ED
  20.        0 8 AT ." Input value of C : " C 20 8 10 XYWF#ED  ;
  21.  
  22. \ Compute B^2 - 4AC save as fvalue  B^2-4AC and
  23. \ leave true flag if it is negative
  24. : NEGATIVE_DISCRIMINANT? ( -- flag )
  25.        B F@ FDUP F*  4.0 A F@ C F@ F* F* F-
  26.        FDUP F!> B^2-4AC F0< ;
  27.  
  28. : REAL1  ( -- )
  29.       B F@ FNEGATE  B^2-4AC FSQRT F-
  30.       2. A F@ F* F/  F!> ROOT1         ;
  31.  
  32. : REAL2  ( -- )
  33.       B F@ FNEGATE  B^2-4AC FSQRT F+
  34.       2. A F@ F* F/  F!> ROOT2         ;
  35.  
  36. : REAL_ROOTS ( -- )
  37.       REAL1  REAL2
  38.       20 10 AT ." Real Roots "
  39.       10 12 AT ." Root 1 : "
  40.       ROOT1 ..
  41.       10 14 AT ." Root 2 : "
  42.       ROOT2 ..  ;
  43.  
  44. : COMPLEX ( -- )
  45.       B F@ FNEGATE
  46.       2. A F@ F* F/  F!> REAL_PART
  47.       B^2-4AC FNEGATE FSQRT
  48.       2. A F@ F* F/  F!> IMAG_PART ;
  49.  
  50. : COMPLEX_ROOTS
  51.       COMPLEX
  52.       20 10 AT ." Complex Roots "
  53.       10 12 AT ." Root 1 : "
  54.       REAL_PART .. ."  +  " IMAG_PART .. ."  j"
  55.       10 14 AT ." Root 2 : "
  56.       REAL_PART .. ."  -  " IMAG_PART .. ."  j"  ;
  57.  
  58. HEX
  59. : QUAD ( -- )
  60.        BEGIN   GET_DATA
  61.                NEGATIVE_DISCRIMINANT?
  62.                IF    COMPLEX_ROOTS
  63.                ELSE  REAL_ROOTS
  64.                THEN
  65.        10 16 AT
  66.        ." Would you like to solve another quadratic? Y/N "
  67.        KEY  0DF AND ASCII Y <>
  68.        UNTIL                     ;
  69.  
  70.  DECIMAL
  71.  
  72.