home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / tutor / l5p200 < prev    next >
Text File  |  1990-07-15  |  2KB  |  83 lines
  1.        ╔════════════════════════════════════════════════════╗
  2.        ║ Lesson 5 Part 200  F-PC 3.5 Tutorial by Jack Brown ║
  3.        ╚════════════════════════════════════════════════════╝
  4.  
  5.  
  6. This a sample application using some of the floating point input
  7. and output operators.  It by no means exercises all of the options.
  8.  
  9. \ Quadratic Equation solver.
  10. \ Requires VP-Planner Floating Point package VPSFP101.ZIP
  11. \ and JB#EDIT.SEQ from the preceding 4 messages or download
  12. \ JB#EDIT.ZIP from BCFB
  13.  
  14.    FLOATING
  15.    FVARIABLE A
  16.    FVARIABLE B
  17.    FVARIABLE C
  18.  
  19. 0. FVALUE ROOT1
  20. 0. FVALUE ROOT2
  21. 0. FVALUE REAL_PART
  22. 0. FVALUE IMAG_PART
  23. 0. FVALUE B^2-4AC
  24.  
  25. : GET_DATA ( -- )
  26.        CLS  20 2 AT ." Quadratic Equation Solver "
  27.        0. A F! 0. B F! 0. C F!
  28.        0 4 AT ." Input value of A : " A 20 4 10 XYWF#ED
  29.        0 6 AT ." Input value of B : " B 20 6 10 XYWF#ED
  30.        0 8 AT ." Input value of C : " C 20 8 10 XYWF#ED  ;
  31.  
  32. \ Compute B^2 - 4AC save as fvalue  B^2-4AC and
  33. \ leave true flag if it is negative
  34. : NEGATIVE_DISCRIMINANT? ( -- flag )
  35.        B F@ FDUP F*  4.0 A F@ C F@ F* F* F-
  36.        FDUP F!> B^2-4AC F0< ;
  37.  
  38. : REAL1  ( -- )
  39.       B F@ FNEGATE  B^2-4AC FSQRT F-
  40.       2. A F@ F* F/  F!> ROOT1         ;
  41.  
  42. : REAL2  ( -- )
  43.       B F@ FNEGATE  B^2-4AC FSQRT F+
  44.       2. A F@ F* F/  F!> ROOT2         ;
  45.  
  46. : REAL_ROOTS ( -- )
  47.       REAL1  REAL2
  48.       20 10 AT ." Real Roots "
  49.       10 12 AT ." Root 1 : "
  50.       ROOT1 ..
  51.       10 14 AT ." Root 2 : "
  52.       ROOT2 ..  ;
  53.  
  54. : COMPLEX ( -- )
  55.       B F@ FNEGATE
  56.       2. A F@ F* F/  F!> REAL_PART
  57.       B^2-4AC FNEGATE FSQRT
  58.       2. A F@ F* F/  F!> IMAG_PART ;
  59.  
  60. : COMPLEX_ROOTS
  61.       COMPLEX
  62.       20 10 AT ." Complex Roots "
  63.       10 12 AT ." Root 1 : "
  64.       REAL_PART .. ."  +  " IMAG_PART .. ."  j"
  65.       10 14 AT ." Root 2 : "
  66.       REAL_PART .. ."  -  " IMAG_PART .. ."  j"  ;
  67.  
  68. HEX
  69. : QUAD ( -- )
  70.        BEGIN   GET_DATA
  71.                NEGATIVE_DISCRIMINANT?
  72.                IF    COMPLEX_ROOTS
  73.                ELSE  REAL_ROOTS
  74.                THEN
  75.        10 16 AT
  76.        ." Would you like to solve another quadratic? Y/N "
  77.        KEY  0DF AND ASCII Y <>
  78.        UNTIL                     ;
  79.  
  80.  DECIMAL
  81.  
  82.  
  83.