home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / CLIPPER / NFSRC.ZIP / ROUND.PRG < prev    next >
Encoding:
Text File  |  1991-08-16  |  7.1 KB  |  190 lines
  1. /*
  2.  * File......: Round.Prg
  3.  * Author....: David Husnian
  4.  * Date......: $Date:   15 Aug 1991 23:05:30  $
  5.  * Revision..: $Revision:   1.2  $
  6.  * Log file..: $Logfile:   E:/nanfor/src/round.prv  $
  7.  * 
  8.  * This is an original work by David Husnian and is placed in the
  9.  * public domain.
  10.  *
  11.  * Modification history:
  12.  * ---------------------
  13.  *
  14.  * $Log:   E:/nanfor/src/round.prv  $
  15.  * 
  16.  *    Rev 1.2   15 Aug 1991 23:05:30   GLENN
  17.  * Forest Belt proofread/edited/cleaned up doc
  18.  * 
  19.  *    Rev 1.1   14 Jun 1991 19:52:48   GLENN
  20.  * Minor edit to file header
  21.  * 
  22.  *    Rev 1.0   01 Apr 1991 01:02:08   GLENN
  23.  * Nanforum Toolkit
  24.  *
  25.  */
  26.  
  27.  
  28. /*  $DOC$
  29.  *  $FUNCNAME$
  30.  *     FT_ROUND()
  31.  *  $CATEGORY$
  32.  *     Math
  33.  *  $ONELINER$
  34.  *     Rounds a number to a specific place
  35.  *  $SYNTAX$
  36.  *     FT_ROUND( <nNumber> [, <nRoundToAmount>           ;
  37.  *               [, <cRoundType>  [, <cRoundDirection>   ;
  38.  *               [, <nAcceptableError> ] ] ] ] )            -> nNumber
  39.  *  $ARGUMENTS$
  40.  *     <nNumber> is the number to round
  41.  *
  42.  *     <nRoundToAmount> is the fraction to round to or the number of places,
  43.  *     default is 2.
  44.  *
  45.  *     <cRoundType> is the type of rounding desired
  46.  *
  47.  *        "D" for Decimal       (3 for thousandth, 1/1000)  (default)
  48.  *        "F" for Fraction      (3 for thirds, 1/3)
  49.  *        "W" for Whole numbers (3 for thousand, 1000)
  50.  *
  51.  *     <cRoundDirection> is the direction to round the number toward
  52.  *
  53.  *        "U" to round Up      1.31 ->  1.4
  54.  *                            -1.31 -> -1.4
  55.  *        "D" to round Down    1.36 ->  1.3
  56.  *                            -1.36 -> -1.3
  57.  *        "N" to round Normal  1.5  ->  2        
  58.  *                            -1.5  -> -2
  59.  *                             1.49 ->  1
  60.  *                            -1.49 -> -1
  61.  *
  62.  *     <nAcceptableError> is the amount that is considered acceptable
  63.  *     to be within, i.e., if you're within this amount of the number
  64.  *     you don't need to round
  65.  *  $RETURNS$
  66.  *     The number, rounded as specified.
  67.  *  $DESCRIPTION$
  68.  *     This function will allow you to round a number.  The following can
  69.  *     be specified:
  70.  *       a. Direction (up, down or normal - normal is 4/5 convention)
  71.  *       b. Type (whole, decimal, fraction)
  72.  *       c. Amount (100's, 5 decimals, 16th, etc.)
  73.  *  $EXAMPLES$
  74.  *     // round normal to 2 decimal places
  75.  *     nDollars := FT_ROUND(nDollars)
  76.  *
  77.  *     // round normal to 6 decimal places
  78.  *     nIntRate := FT_ROUND(nIntRate, 6)
  79.  *
  80.  *     // round to nearest thousands
  81.  *     nPrice   := FT_ROUND(nPrice, 3, NEAREST_WHOLE_NUMBER)
  82.  *
  83.  *     // round Up to nearest third
  84.  *     nAmount  := FT_ROUND(nAmount, 3, NEAREST_FRACTION, ROUND_UP)
  85.  *
  86.  *     // round down to 3 decimals Within .005
  87.  *     nAvg     := FT_ROUND(nAvg, 3, , ROUND_DOWN, .005)
  88.  *  $END$
  89.  */
  90.  
  91.  
  92. #define IS_NEGATIVE(x)       ((x) < 0)
  93.  
  94. #define NEAREST_DECIMAL      "D"
  95. #define NEAREST_FRACTION     "F"
  96. #define NEAREST_WHOLE_NUMBER "W"
  97. #define ROUND_DOWN           "D"
  98. #define ROUND_NORMAL         "N"
  99. #define ROUND_UP             "U"
  100.  
  101. #command    DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
  102.             => ;
  103.             <Param1> := IF(<Param1> == NIL,<Def1>,<Param1>) ;
  104.          [; <ParamN> := IF(<ParamN> == NIL,<DefN>,<ParamN>)]
  105.  
  106. #command    DEFAULT <Param1> TO <Def1> IF NOT <Type1> ;
  107.                  [, <ParamN> TO <DefN> IF NOT <TypeN> ] ;
  108.             => ;
  109.             <Param1> := IF(VALTYPE(<Param1>) == <Type1>,<Param1>,<Def1>) ;
  110.          [; <ParamN> := IF(VALTYPE(<ParamN>) == <TypeN>,<ParamN>,<DefN>)]
  111.  
  112.  
  113.  
  114. FUNCTION FT_ROUND(nNumber, nRoundToAmount, cRoundType, cRoundDirection, ;
  115.                   nAcceptableError)
  116.  
  117.    LOCAL nResult := ABS(nNumber)        // The Result of the Rounding
  118.  
  119.    DEFAULT nRoundToAmount   TO 2, ;
  120.            cRoundType       TO NEAREST_DECIMAL, ;
  121.            cRoundDirection  TO ROUND_NORMAL, ;
  122.            nAcceptableError TO 1 / (nRoundToAmount ** 2)
  123.  
  124.                                         // Are We Rounding to the Nearest Whole
  125.                                         // Number or to Zero Decimal Places??
  126.    IF (LEFT(cRoundType,1) != NEAREST_WHOLE_NUMBER .AND. ;
  127.        (nRoundToAmount := INT(nRoundToAmount)) != 0)
  128.  
  129.                                         // No, Are We Rounding to the Nearest
  130.                                         // Decimal Place??
  131.       IF (LEFT(cRoundType,1) == NEAREST_DECIMAL)
  132.  
  133.                                         // Yes, Convert to Nearest Fraction
  134.          nRoundToAmount := 10 ** nRoundToAmount
  135.  
  136.       ENDIF                             // LEFT(cRoundType,1) == NEAREST_DECIMAL
  137.  
  138.                                         // Are We Already Within the Acceptable
  139.                                         // Error Factor??
  140.       IF (ABS(INT(nResult * nRoundToAmount) - (nResult * nRoundToAmount)) > ;
  141.           nAcceptableError)
  142.                                         // No, Are We Rounding Down??
  143.          nResult -= IIF(LEFT(cRoundDirection,1) == ROUND_DOWN, ;
  144.                                       ; // Yes, Make Downward Adjustment
  145.                         1 / nRoundToAmount / 2, ;
  146.                                       ; // Are We Rounding Up??
  147.                         IIF(LEFT(cRoundDirection,1) == ROUND_UP , ;
  148.                                       ; // Yes, Make Upward Adjustment
  149.                             -1 / (nRoundToAmount) / 2, ;
  150.                                       ; // No, Rounding Normal, No Adjustment
  151.                             0))
  152.                                         //Do the Actual Rounding
  153.          nResult := INT((nRoundToAmount * nResult) + .5 + nAcceptableError) / ;
  154.                     nRoundToAmount
  155.  
  156.       ENDIF                             // ABS(INT(nResult * nRoundToAmount) -
  157.                                         //     (mResult * nRoundAmount)) >
  158.                                         // nAcceptableError
  159.  
  160.    ELSE                                 // Yes, Round to Nearest Whole Number
  161.                                         // or to Zero Places
  162.  
  163.       nRoundToAmount := MAX(nRoundToAmount, 1)
  164.  
  165.       DO CASE                           // Do "Whole" Rounding
  166.  
  167.          CASE LEFT(cRoundDirection,1) == ROUND_UP
  168.  
  169.             nResult := (INT(nResult / nRoundToAmount) * nRoundToAmount) + ;
  170.                        nRoundToAmount
  171.  
  172.          CASE LEFT(cRoundDirection,1) = ROUND_DOWN
  173.  
  174.             nResult := INT(nResult / nRoundToAmount) * nRoundToAmount
  175.  
  176.          OTHERWISE                      // Round Normally
  177.  
  178.             nResult := INT((nResult + nRoundToAmount / 2) / nRoundToAmount) * ;
  179.                        nRoundToAmount
  180.  
  181.       ENDCASE
  182.  
  183.    ENDIF                                // LEFT(cRoundType,1)!=NEAREST_WHOLE or
  184.                                         // nRoundToAmount == 0
  185.    IF IS_NEGATIVE(nNumber)              // Was the Number Negative??
  186.       nResult := -nResult               // Yes, Make the Result Negative Also
  187.    ENDIF                                // IS_NEGATIVE(nNumber)
  188.  
  189.    RETURN (nResult)                     // FT_Round
  190.