home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
FOXPRO
/
ANNUIT
/
ANNUITY.PRG
Wrap
Text File
|
1992-12-11
|
5KB
|
177 lines
*-------------------------------------------------------------------------------
*-- Program.....: annuity.prg
*-- Programmer..: Bowen Moursund, CI$ 76566,1405
*-- Date........: 12-11-1992
*-- Notes.......: Comment and/or criticism invited.
*-- Written for.: FORCE Compiler Version 2.1E
*-- Rev. History: None
*-------------------------------------------------------------------------------
#include io.hdr
#include math.hdr
#include keys.hdr
#include colors.hdr
#include data.hdr
#include system.hdr
#include string.hdr
VARDEF
uint nRow
dbl nPV,nRate,nPeriods,nPayment
ENDDEF
FUNCTION dbl payment prototype
parameters const dbl nPV, const dbl nRate, const dbl nPeriods
FUNCTION dbl pv prototype
parameters const dbl nPayment, const dbl nRate, const dbl nPeriods
FUNCTION dbl periods prototype
parameters const dbl nPV, const dbl nRate, const dbl nPayment
FUNCTION dbl rate prototype
parameters const dbl nPV, const dbl nPeriods, const dbl nPayment
FUNCTION logical checksign prototype
parameters const dbl nNumber
PROCEDURE force_main
nRow = row() - 1 && save row
do save_screen && and screen to retore on exit
set scoreboard off
__color_enhcd = &white_black
__color_std = &green_white
fill(7,17,19,61,&DOUBLE_BOX," ",&green_white,&green_white,12)
@ 7,30 ?? " Annuity Calculator "
@ 9,27 ?? "%Rate per period "
@11,33 ?? "Periods "
@13,26 ?? "Present Value "
@15,29 ?? "Payment "
do while .t.
@9,46 get nRate picture "99.99999" valid checksign(nRate)
@11,43 get nPeriods picture "999999" valid checksign(nPeriods)
@13,42 get nPV picture "9999999999.99" valid checksign(nPV)
@15,39 get nPayment picture "999999999.99" valid checksign(nPayment)
@17,20 ?? "Ctrl-End: Compute blank field Esc: Exit"
read
if lastkey() <> &K_ESC .and. lastkey() <> &K_C_END
loop
endif
if lastkey() = &K_C_END
do case
case nPayment=0 .and. nPV>0 .and. nPeriods>0 .and. nRate>0
* compute payment
nPayment = payment(nPV,nRate/100,nPeriods)
case nPV=0 .and. nPayment>0 .and. nPeriods>0 .and. nRate>0
* compute principal/present value
nPV = pv(nPayment,nRate/100,nPeriods)
case nPeriods=0 .and. nPV>0 .and. nPayment>0 .and. nRate>0
* compute number of periods
if nPV*nRate/100/nPayment >= 1
@17,20 clear to 17,59
@17,22 ?? chr(7)+"Interest not covered. Press a key "
get_key()
else
nPeriods = periods(nPV,nRate/100,nPayment)
endif
case nRate=0 .and. nPV>0 .and. nPayment>0 .and. nPeriods>0
* compute interest rate per period
@17,20 clear to 17,59
if nPayment * nPeriods < nPV
@17,25 ?? chr(7)+"No negative rates. Press a key "
get_key()
else
@17,28 ?? "Please wait - Processing "
nRate = rate(nPV,nPeriods,nPayment) * 100
endif
case nPayment=0 .and. nPV=0 .and. nPeriods=0 .and. nRate=0
* data entry error
@17,20 clear to 17,59
@17,22 ?? chr(7)+"1 field must be blank. Press a key "
get_key()
otherwise
* data entry error
@17,20 clear to 17,59
@17,20 ?? chr(7)+"Only 1 field may be blank. Press a key "
get_key()
endcase
else
exit
endif
enddo
do restore_area && restore screen
@nrow,0 && and row
ENDPRO
FUNCTION dbl payment
parameters const dbl nPV, const dbl nRate, const dbl nPeriods
RETURN nPV/((1-(1+(nRate))**(-nPeriods))/(nRate))
ENDPRO
FUNCTION dbl pv
parameters const dbl nPayment, const dbl nRate, const dbl nPeriods
RETURN nPayment*((1-(1+(nRate))**(-nPeriods))/(nRate))
ENDPRO
FUNCTION dbl periods
parameters const dbl nPV, const dbl nRate, const dbl nPayment
RETURN (-ln(1-(nPV*nRate/nPayment)))/(ln(1+(nRate)))
ENDPRO
FUNCTION dbl rate
parameters const dbl nPV, const dbl nPeriods, const dbl nPayment
VARDEF
dbl nTrialPayment, nTrialRate, nFloor, nCeiling
ENDDEF
store 0.02 to nTrialRate, nCeiling && gotta start somewhere
store 0 to nFloor, nTrialPayment
do while .t.
nTrialPayment = payment(nPV,nTrialRate,nPeriods)
if abs(nTrialPayment - nPayment) >= 0.005
if nTrialPayment > nPayment
nCeiling = nTrialRate
else
nFloor = nTrialRate
if nFloor >= nCeiling
nCeiling = nFloor * 2
endif
endif
nTrialRate = (nCeiling + nFloor) / 2
else && close enough!
exit
endif
enddo
RETURN nTrialRate
ENDPRO
FUNCTION logical checksign
parameters const dbl nNumber
VARDEF
logical lRetVal
ENDDEF
if nNumber < 0
lRetVal = .f.
@17,20 clear to 17,59
@17,23 ?? chr(7)+"No negative values. Press a key "
get_key()
@17,20 ?? "Ctrl-End: Compute blank field Esc: Exit"
else
lRetVal = .t.
endif
RETURN lRetVal
ENDPRO
*-- EoF: annuity.prg