home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / FOXPRO / ANNUIT / ANNUITY.PRG
Text File  |  1992-12-11  |  5KB  |  177 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program.....: annuity.prg
  3. *-- Programmer..: Bowen Moursund, CI$ 76566,1405
  4. *-- Date........: 12-11-1992
  5. *-- Notes.......: Comment and/or criticism invited.
  6. *-- Written for.: FORCE Compiler Version 2.1E
  7. *-- Rev. History: None
  8. *-------------------------------------------------------------------------------
  9.  
  10. #include io.hdr
  11. #include math.hdr
  12. #include keys.hdr
  13. #include colors.hdr
  14. #include data.hdr
  15. #include system.hdr
  16. #include string.hdr
  17.  
  18. VARDEF
  19.     uint        nRow
  20.     dbl         nPV,nRate,nPeriods,nPayment
  21. ENDDEF
  22.  
  23. FUNCTION dbl payment prototype
  24. parameters const dbl nPV, const dbl nRate, const dbl nPeriods
  25.  
  26. FUNCTION dbl pv prototype
  27. parameters const dbl nPayment, const dbl nRate, const dbl nPeriods
  28.  
  29. FUNCTION dbl periods prototype
  30. parameters const dbl nPV, const dbl nRate, const dbl nPayment
  31.  
  32. FUNCTION dbl rate prototype
  33. parameters const dbl nPV, const dbl nPeriods, const dbl nPayment
  34.  
  35. FUNCTION logical checksign prototype
  36. parameters const dbl nNumber
  37.  
  38. PROCEDURE force_main
  39. nRow = row() - 1    && save row
  40. do save_screen      && and screen to retore on exit
  41. set scoreboard off
  42.  
  43. __color_enhcd = &white_black
  44. __color_std   = &green_white
  45. fill(7,17,19,61,&DOUBLE_BOX," ",&green_white,&green_white,12)
  46. @ 7,30 ?? " Annuity Calculator "
  47. @ 9,27 ?? "%Rate per period "
  48. @11,33 ?? "Periods "
  49. @13,26 ?? "Present Value "
  50. @15,29 ?? "Payment "
  51.  
  52. do while .t.
  53.  
  54.     @9,46 get nRate picture "99.99999" valid checksign(nRate)
  55.     @11,43 get nPeriods picture "999999" valid checksign(nPeriods)
  56.     @13,42 get nPV picture "9999999999.99" valid checksign(nPV)
  57.     @15,39 get nPayment picture "999999999.99" valid checksign(nPayment)
  58.     @17,20 ?? "Ctrl-End: Compute blank field  Esc: Exit"
  59.     read
  60.  
  61.     if lastkey() <> &K_ESC .and. lastkey() <> &K_C_END
  62.         loop
  63.     endif
  64.     
  65.     if lastkey() = &K_C_END
  66.         do case
  67.         case nPayment=0 .and. nPV>0 .and. nPeriods>0 .and. nRate>0
  68.             * compute payment
  69.             nPayment = payment(nPV,nRate/100,nPeriods)
  70.  
  71.         case nPV=0 .and. nPayment>0 .and. nPeriods>0 .and. nRate>0
  72.             * compute principal/present value
  73.             nPV = pv(nPayment,nRate/100,nPeriods)
  74.  
  75.         case nPeriods=0 .and. nPV>0 .and. nPayment>0 .and. nRate>0
  76.             * compute number of periods
  77.             if nPV*nRate/100/nPayment >= 1
  78.                 @17,20 clear to 17,59
  79.                 @17,22 ?? chr(7)+"Interest not covered. Press a key "
  80.                 get_key()
  81.             else
  82.                 nPeriods =  periods(nPV,nRate/100,nPayment)
  83.             endif
  84.  
  85.         case nRate=0 .and. nPV>0 .and. nPayment>0 .and. nPeriods>0
  86.             * compute interest rate per period
  87.             @17,20 clear to 17,59
  88.             if nPayment * nPeriods < nPV
  89.                 @17,25 ?? chr(7)+"No negative rates. Press a key "
  90.                 get_key()
  91.             else
  92.                 @17,28 ?? "Please wait - Processing "
  93.                 nRate = rate(nPV,nPeriods,nPayment) * 100
  94.             endif
  95.  
  96.         case nPayment=0 .and. nPV=0 .and. nPeriods=0 .and. nRate=0
  97.             * data entry error
  98.             @17,20 clear to 17,59
  99.             @17,22 ?? chr(7)+"1 field must be blank. Press a key "
  100.             get_key()
  101.  
  102.         otherwise
  103.             * data entry error
  104.             @17,20 clear to 17,59
  105.             @17,20 ?? chr(7)+"Only 1 field may be blank. Press a key "
  106.             get_key()
  107.         endcase
  108.     else
  109.         exit
  110.     endif
  111.  
  112. enddo
  113.  
  114. do restore_area     && restore screen
  115. @nrow,0             && and row
  116. ENDPRO
  117.  
  118. FUNCTION dbl payment
  119. parameters const dbl nPV, const dbl nRate, const dbl nPeriods
  120. RETURN nPV/((1-(1+(nRate))**(-nPeriods))/(nRate))
  121. ENDPRO
  122.  
  123. FUNCTION dbl pv
  124. parameters const dbl nPayment, const dbl nRate, const dbl nPeriods
  125. RETURN nPayment*((1-(1+(nRate))**(-nPeriods))/(nRate))
  126. ENDPRO
  127.  
  128. FUNCTION dbl periods
  129. parameters const dbl nPV, const dbl nRate, const dbl nPayment
  130. RETURN (-ln(1-(nPV*nRate/nPayment)))/(ln(1+(nRate)))
  131. ENDPRO
  132.  
  133. FUNCTION dbl rate
  134. parameters const dbl nPV, const dbl nPeriods, const dbl nPayment
  135. VARDEF
  136.     dbl nTrialPayment, nTrialRate, nFloor, nCeiling
  137. ENDDEF
  138. store 0.02 to nTrialRate, nCeiling   && gotta start somewhere
  139. store 0 to nFloor, nTrialPayment
  140. do while .t.
  141.     nTrialPayment = payment(nPV,nTrialRate,nPeriods)
  142.     if abs(nTrialPayment - nPayment) >= 0.005
  143.         if nTrialPayment > nPayment
  144.             nCeiling = nTrialRate
  145.         else
  146.             nFloor = nTrialRate
  147.             if nFloor >= nCeiling
  148.                 nCeiling = nFloor * 2
  149.             endif
  150.         endif
  151.         nTrialRate = (nCeiling + nFloor) / 2
  152.     else   && close enough!
  153.         exit
  154.     endif
  155. enddo
  156. RETURN nTrialRate
  157. ENDPRO
  158.  
  159. FUNCTION logical checksign
  160. parameters const dbl nNumber
  161. VARDEF
  162.     logical lRetVal
  163. ENDDEF
  164. if nNumber < 0
  165.     lRetVal = .f.
  166.     @17,20 clear to 17,59
  167.     @17,23 ?? chr(7)+"No negative values. Press a key "
  168.     get_key()
  169.     @17,20 ?? "Ctrl-End: Compute blank field  Esc: Exit"
  170. else
  171.     lRetVal = .t.
  172. endif
  173. RETURN lRetVal
  174. ENDPRO
  175.  
  176. *-- EoF: annuity.prg
  177.