fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2001-07-23 18:40 MEST Martin Vogel <vogel@inttec.de>

Browse Source
This commit is contained in:
Martin Vogel
2001-07-23 16:38:00 +00:00
parent 1d690a55d6
commit 97d5d8386b
24 changed files with 3403 additions and 94 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
harbour/ChangeLog
View File

@@ -1,3 +1,37 @@
2001-07-23 18:40 MEST Martin Vogel <vogel@inttec.de>
+ contrib/libct/finan.c
+ contrib/libct/math.c
+ contrib/libct/num1.c
+ contrib/libct/trig.c
+ contrib/libct/tests/finan.prg
+ contrib/libct/tests/math.prg
+ contrib/libct/tests/num1.prg
+ contrib/libct/tests/trig.prg
+ mathematical functions provided by Alejandro de Garate <alex_degarate@hotmail.com>
+ Documentation (and some minor changes) added by me
* contrib/libct/ascpos.c
* contrib/libct/atadjust.c
* contrib/libct/atnum.c
* contrib/libct/charlist.c
* contrib/libct/charswap.c
* contrib/libct/ct.c
* contrib/libct/ct.h
* contrib/libct/cterror.ch
* contrib/libct/ctmath.h
* contrib/libct/token1.c
* some minor changes to remove warnings reported by Maurilio Longo
* changed USHORT to ULONG in variable parameter functions
* fixed $SEEALSO$ bug in documentation
* contrib/libct/ctflist.txt
* contrib/libct/Makefile
* contrib/libct/makefile.bc
* contrib/libct/makefile.vc
* contrib/libct/tests/Makefile
* changes according to new files and function stati
2001-07-23 04:20 UTC-0800 Ron Pinkas <ron@profit-master.com>
* contrib/dot/pp.prg
! Various refinments in matching and outputing due to new observations about Clipper.

4
harbour/contrib/libct/Makefile
View File

@@ -29,7 +29,11 @@ C_SOURCES = \
ctcolton.c \
ctcrypt.c \
ctposupp.c \
finan.c \
math.c \
num1.c \
token1.c \
trig.c \
wordrepl.c \
PRG_SOURCES= \

6
harbour/contrib/libct/ascpos.c
View File

@@ -87,7 +87,7 @@ static void do_ascpos (int iSwitch)
{
if (iSwitch == DO_ASCPOS_VALPOS)
{
if (isdigit (pcString[sPos-1]))
if (isdigit ((size_t)pcString[sPos-1]))
hb_retnl (pcString[sPos-1]-48);
else
hb_retnl (0);
@@ -162,7 +162,7 @@ static void do_ascpos (int iSwitch)
* $PLATFORMS$
* All
* $FILES$
* Source is asciisum.c, library is ct3.
* Source is asciisum.c, library is libct.
* $SEEALSO$
* VALPOS()
* $END$
@@ -213,7 +213,7 @@ HB_FUNC (ASCPOS)
* $PLATFORMS$
* All
* $FILES$
* Source is asciisum.c, library is ct3.
* Source is asciisum.c, library is libct.
* $SEEALSO$
* ASCPOS()
* $END$

4
harbour/contrib/libct/atadjust.c
View File

@@ -94,7 +94,7 @@
* $FILES$
* Source is atadjust.c, library is ct3.
* $SEEALSO$
* SETATLIKE() CSETATMUPA()
* SETATLIKE(),CSETATMUPA()
* $END$
*/
@@ -116,7 +116,7 @@ HB_FUNC (ATADJUST)
char cAtLike = ct_getatlikechar();
size_t sIgnore, sMatchStrLen;
ULONG ulCounter;
char *pc;
char *pc = NULL;
char cFillChar;
char *pcRetStr, *pcCheckFill;

6
harbour/contrib/libct/atnum.c
View File

@@ -81,7 +81,7 @@ static void do_atnum (int iSwitch)
char cAtLike = ct_getatlikechar();
size_t sIgnore, sMatchStrLen;
ULONG ulCounter;
char *pc;
char *pc = NULL;
/* eventually ignore some characters */
if (ISNUM (4))
@@ -406,9 +406,9 @@ static void do_atnum (int iSwitch)
* $PLATFORMS$
* All
* $FILES$
* Source is atnum.c, library is ct3.
* Source is atnum.c, library is libct.
* $SEEALSO$
* ATNUM() BEFORATNUM() CSETATMUPA() SETATLIKE()
* ATNUM(),BEFORATNUM(),CSETATMUPA(),SETATLIKE()
* $END$
*/

20
harbour/contrib/libct/charlist.c
View File

@@ -103,10 +103,10 @@ static void do_list (int iSwitch)
for (sCnt = 0; sCnt < sStrLen; sCnt++)
{
if (asCharCnt[pcString[sCnt]] == 0)
if (asCharCnt[(size_t)(pcString[sCnt])] == 0)
{
pcRet[sRetStrLen++] = pcString[sCnt];
asCharCnt[pcString[sCnt]] = 1;
asCharCnt[(size_t)(pcString[sCnt])] = 1;
}
}
@@ -224,9 +224,9 @@ static void do_list (int iSwitch)
* $PLATFORMS$
* All
* $FILES$
* Source is charlist.c, library is ct3.
* Source is charlist.c, library is libct.
* $SEEALSO$
* CHARNOLIST() CHARSLIST() CHARHIST()
* CHARNOLIST(),CHARSLIST(),CHARHIST()
* $END$
*/
@@ -272,9 +272,9 @@ HB_FUNC (CHARLIST)
* $PLATFORMS$
* All
* $FILES$
* Source is charlist.c, library is ct3.
* Source is charlist.c, library is libct.
* $SEEALSO$
* CHARNOLIST() CHARLIST() CHARHIST()
* CHARNOLIST(),CHARLIST(),CHARHIST()
* $END$
*/
@@ -319,9 +319,9 @@ HB_FUNC (CHARSLIST)
* $PLATFORMS$
* All
* $FILES$
* Source is charlist.c, library is ct3.
* Source is charlist.c, library is libct.
* $SEEALSO$
* CHARLIST() CHARSLIST() CHARHIST()
* CHARLIST(),CHARSLIST(),CHARHIST()
* $END$
*/
@@ -367,9 +367,9 @@ HB_FUNC (CHARNOLIST)
* $PLATFORMS$
* All
* $FILES$
* Source is charlist.c, library is ct3.
* Source is charlist.c, library is libct.
* $SEEALSO$
* CHARLIST() CHARNOLIST() CHARSLIST()
* CHARLIST(),CHARNOLIST(),CHARSLIST()
* $END$
*/

10
harbour/contrib/libct/charswap.c
View File

@@ -81,7 +81,7 @@ static void do_charswap (int iSwitch)
char *pcRet;
size_t sRetIndex = 0;
int iShift, iMod;
char *pcSub, *pc;
char *pcSub;
if (iSwitch == DO_CHARSWAP_WORDSWAP)
{
@@ -241,9 +241,9 @@ static void do_charswap (int iSwitch)
* $PLATFORMS$
* All
* $FILES$
* Source is charswap.c, library is ct3.
* Source is charswap.c, library is libct.
* $SEEALSO$
* WORDSWAP() CSETREF()
* WORDSWAP(),CSETREF()
* $END$
*/
@@ -294,9 +294,9 @@ HB_FUNC (CHARSWAP)
* $PLATFORMS$
* All
* $FILES$
* Source is charswap.c, library is ct3.
* Source is charswap.c, library is libct.
* $SEEALSO$
* CHARSWAP() CSETREF()
* CHARSWAP(),CSETREF()
* $END$
*/

20
harbour/contrib/libct/ct.c
View File

@@ -61,17 +61,17 @@
- function adapted from errorapi.c */
USHORT ct_error (USHORT uiSeverity, ULONG ulGenCode, ULONG ulSubCode,
char * szDescription, char * szOperation, USHORT uiOsCode,
USHORT uiFlags, USHORT uiArgCount, ...)
USHORT uiFlags, ULONG uiArgCount, ...)
{
USHORT uiAction;
PHB_ITEM pError;
PHB_ITEM pArray, pArg;
PHB_ITEM pArray;
va_list va;
USHORT uiArgPos;
ULONG uiArgPos;
BOOL bRelease = TRUE;
HB_TRACE(HB_TR_DEBUG, ("ct_error (%hu, %lu, %lu, %s, %s, %hu, %hu, %hu",
HB_TRACE(HB_TR_DEBUG, ("ct_error (%hu, %lu, %lu, %s, %s, %hu, %hu, %lu",
uiSeverity, ulGenCode, ulSubCode, szDescription,
szOperation, uiOsCode, uiFlags, uiArgCount));
@@ -118,16 +118,16 @@ USHORT ct_error (USHORT uiSeverity, ULONG ulGenCode, ULONG ulSubCode,
- function adapted from errorapi.c */
PHB_ITEM ct_error_subst (USHORT uiSeverity, ULONG ulGenCode, ULONG ulSubCode,
char * szDescription, char * szOperation, USHORT uiOsCode,
USHORT uiFlags, USHORT uiArgCount, ...)
USHORT uiFlags, ULONG uiArgCount, ...)
{
PHB_ITEM pRetVal;
PHB_ITEM pError;
PHB_ITEM pArray;
va_list va;
USHORT uiArgPos;
ULONG uiArgPos;
HB_TRACE(HB_TR_DEBUG, ("ct_error_subst (%hu, %lu, %lu, %s, %s, %hu, %hu, %hu",
HB_TRACE(HB_TR_DEBUG, ("ct_error_subst (%hu, %lu, %lu, %s, %s, %hu, %hu, %lu",
uiSeverity, ulGenCode, ulSubCode, szDescription,
szOperation, uiOsCode, uiFlags, uiArgCount));
@@ -214,7 +214,7 @@ int ct_getargerrormode (void)
* $PLATFORMS$
* All
* $FILES$
* Source is ct.c, library is ct3.
* Source is ct.c, library is libct.
* $SEEALSO$
* $END$
*/
@@ -288,7 +288,7 @@ static int s_initialized = 0; /* TODO: make this thread safe */
* $PLATFORMS$
* All
* $FILES$
* Source is ct.c, library is ct3.
* Source is ct.c, library is libct.
* $SEEALSO$
* $END$
*/
@@ -344,7 +344,7 @@ HB_FUNC (CTINIT)
* $PLATFORMS$
* All
* $FILES$
* Source is ct.c, library is ct3.
* Source is ct.c, library is libct.
* $SEEALSO$
* $END$
*/

4
harbour/contrib/libct/ct.h
View File

@@ -73,11 +73,11 @@
/* CT subsystem error throwing functions */
extern USHORT ct_error (USHORT uiSeverity, ULONG ulGenCode, ULONG ulSubCode,
char * szDescription, char * szOperation, USHORT uiOsCode,
USHORT uiFlags, USHORT uiArgCount, ...);
USHORT uiFlags, ULONG uiArgCount, ...);
extern PHB_ITEM ct_error_subst (USHORT uiSeverity, ULONG ulGenCode, ULONG ulSubCode,
char * szDescription, char * szOperation, USHORT uiOsCode,
USHORT uiFlags, USHORT uiArgCount, ...);
USHORT uiFlags, ULONG uiArgCount, ...);
/* set argument error behaviour */
extern void ct_setargerrormode (int iMode);

38
harbour/contrib/libct/cterror.ch
View File

@@ -666,25 +666,25 @@
#define CT_ERROR_COS 7463
#define CT_ERROR_COT 7473
#define CT_ERROR_DTOR 7483
#define CT_ERROR_EXPA 7493
#define CT_ERROR_FACT 7502
#define CT_ERROR_FLOOR 7512
#define CT_ERROR_FV 7523
#define CT_ERROR_GETPREC 7532
#define CT_ERROR_LOG10 7543
#define CT_ERROR_LOGA 7553
#define CT_ERROR_PAYMENT 7563
#define CT_ERROR_PERIODS 7572
#define CT_ERROR_PI 7583
#define CT_ERROR_PV 7593
#define CT_ERROR_RATE 7603
#define CT_ERROR_ROOT 7613
#define CT_ERROR_RTOD 7623
#define CT_ERROR_SETMATHERR 7632
#define CT_ERROR_SETPREC 7642
#define CT_ERROR_SIGN 7652
#define CT_ERROR_SIN 7663
#define CT_ERROR_TAN 7673
#define CT_ERROR_FACT 7492
#define CT_ERROR_FLOOR 7502
#define CT_ERROR_FV 7513
#define CT_ERROR_GETPREC 7522
#define CT_ERROR_LOG10 7533
#define CT_ERROR_PAYMENT 7543
#define CT_ERROR_PERIODS 7552
#define CT_ERROR_PI 7563
#define CT_ERROR_PV 7573
#define CT_ERROR_RATE 7583
#define CT_ERROR_RTOD 7593
#define CT_ERROR_SETMATHERR 7602
#define CT_ERROR_SETPREC 7612
#define CT_ERROR_SIGN 7622
#define CT_ERROR_SIN 7633
#define CT_ERROR_TAN 7643
#define CT_ERROR_SINH 7653
#define CT_ERROR_COSH 7663
#define CT_ERROR_TANH 7773
/* peek and poke functions */
#define CT_ERROR_INBYTE 7810 /* TODO: change last digit */

58
harbour/contrib/libct/ctflist.txt
View File

@@ -269,15 +269,15 @@ WORDTOCHAR ;N;
;===============================
;
BITTOC ;N;
CELSIUS ;N;
CELSIUS ;R;
CLEARBIT ;N;
CTOBIT ;N;
CTOF ;N;
CTON ;N;
EXPONENT ;N;
FAHRENHEIT ;N;
FAHRENHEIT ;R;
FTOC ;N;
INFINITY ;N;
INFINITY ;R;
INTNEG ;N;
INTPOS ;N;
ISBIT ;N;
@@ -590,33 +590,33 @@ XTOC ;N;
;3.4 math functions
;==================
;
ACOS ;N;
ASIN ;N;
ATAN ;N;
ATN2 ;N;
CEILING ;N;
COS ;N;
COT ;N;
DTOR ;N;
EXPA ;N; !NEW!
FACT ;N;
FLOOR ;N;
FV ;N;
GETPREC ;N;
LOGA ;N; !NEW!
LOG10 ;N;
PAYMENT ;N;
PERIODS ;N;
PI ;N;
PV ;N;
RATE ;N;
ROOT ;N; !NEW!
RTOD ;N;
ACOS ;R;
ASIN ;R;
ATAN ;R;
ATN2 ;R;
CEILING ;R;
COS ;R;
COSH ;R; !NEW!
COT ;R;
DTOR ;R;
FACT ;R;
FLOOR ;R;
FV ;R;
GETPREC ;R;
LOG10 ;R;
PAYMENT ;R;
PERIODS ;R;
PI ;R;
PV ;R;
RATE ;R;
RTOD ;R;
SETMATHERR ;R; !NEW!
SETPREC ;N;
SIGN ;N;
SIN ;N;
TAN ;N;
SETPREC ;R;
SIGN ;R;
SIN ;R;
SINH ;R; !NEW!
TAN ;R;
TANH ;R; !NEW!
;
;
;3.5 peek and poke functions

4
harbour/contrib/libct/ctmath.h
View File

@@ -91,6 +91,10 @@ extern int ct_matherr (HB_MATH_EXCEPTION * pexc);
extern void ct_setprecision (int iPrecision);
extern int ct_getprecision();
#define CT_PI 3.14159265358979323846
#define CT_PI_2 1.57079632679489661923
#define CT_PI_RAD 0.0174532925199432957692 /* 3.14159265358979323846 / 180.0 */
#endif /* CTMATH_H */

627
harbour/contrib/libct/finan.c Normal file
View File

@@ -0,0 +1,627 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* CT3 Financial functions
* - PV
* - FV
* - PAYMENT
* - PERIODS
* - RATE
*
* NOTE: All these functions were builded using Borland C++ 5.5 (free version)
*
* Copyright 2001 Alejandro de Garate <alex_degarate@hotmail.com>
*
* Documentation and changes concerning error handling Copyright 2001
* IntTec GmbH, Freiburg, Germany, Author: Martin Vogel <vogel@inttec.de>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "ct.h"
/* $DOC$
* $FUNCNAME$
* FV()
* $CATEGORY$
* CT3 math functions
* $ONELINER$
* Future value of a capital
* $SYNTAX$
* FV (nDeposit, nInterest, nPeriods) --> nFutureValue
* $ARGUMENTS$
* <nDeposit> amount of money invested per period
* <nInterest> rate of interest per period, 1 == 100%
* <nPeriods> period count
* $RETURNS$
* <nFutureValue> Total value of the capital after <nPeriods> of
* paying <nDeposit> and <nInterest> interest being
* paid every period and added to the capital (resulting
* in compound interest)
* $DESCRIPTION$
* FV() calculates the value of a capital after <nPeriods> periods.
* Starting with a value of 0, every period, <nDeposit>
* (Dollars, Euros, Yens, ...) and an interest of <nInterest> for the
* current capital are added for the capital (<nInterest>=Percent/100).
* Thus, one gets the non-linear effects of compound interests:
* value in period 0 = 0
* value in period 1 = ((value in period 0)*(1+<nInterest>/100)) + <nDeposit>
* value in period 2 = ((value in period 1)*(1+<nInterest>/100)) + <nDeposit>
* etc....
* value in period <nPeriod> = ((value in period <nPeriod>-1)*(1+<nInterest>/100))< + <nDeposit>
* = <nDeposit> * sum from i=0 to <nPeriod>-1 over (1+<nInterest>/100)^i
* = <nDeposit> * ((1+<nInterest>/100)^n-1) / (<nInterest>/100)
* $EXAMPLES$
* // Payment of 1000 per year for 10 years at a interest rate
* // of 5 per cent per year
*
* ? fv (1000, 0.05, 10) --> 12577.893
* $TESTS$
* fv (1000, 0.00, 10) == 10000.0
* fv (1000, 0.05, 10) == 12577.893
* $STATUS$
* Ready
* $COMPLIANCE$
* FV() is compatible with CT3's FV().
* $PLATFORMS$
* All
* $FILES$
* Source is finan.c, library is libct.
* $SEEALSO$
* PV(),PAYMENT(),PERIODS(),RATE()
* $END$
*/
HB_FUNC( FV )
{
if( ISNUM(1) && ISNUM(2) && ISNUM(3) )
{
double dPayment = hb_parnd(1);
double dRate = hb_parnd(2);
double dTime = hb_parnd(3);
double dResult;
ct_matherrbegin();
if (dRate == 0.0)
{
/* NOTE: CT3 crashes with dRate == 0.0 */
dResult = dPayment*dTime;
}
else
{
dResult = dPayment*(pow (1.0+dRate, dTime)-1.0)/dRate;
}
ct_matherrend();
hb_retnd (dResult);
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_FV,
NULL, "FV", 0, EF_CANSUBSTITUTE, 3,
hb_paramError (1), hb_paramError (2),
hb_paramError (3));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (0.0);
}
}
return;
}
/* $DOC$
* $FUNCNAME$
* PV()
* $CATEGORY$
* CT3 math functions
* $ONELINER$
* Present value of a loan
* $SYNTAX$
* PV (nPayment, nInterest, nPeriods) --> nPresentValue
* $ARGUMENTS$
* <nPayment> amount of money paid back per period
* <nInterest> rate of interest per period, 1 == 100%
* <nPeriods> period count
* $RETURNS$
* <nPresentValue> Present value of a loan when one is paying back
* <nDeposit> per period at a rate of interest of
* <nInterest> per period
* $DESCRIPTION$
* PV() calculates the present value of a loan that is paid back
* in <nPeriods> payments of <nPayment> (Dollars, Euros, Yens,...)
* while the rate of interest is <nInterest> per period:
* debt in period 0 = <nPresentValue>
* debt in period 1 = ((debt in period 0)-<nPayment>)*(1+<nInterest>/100)
* debt in period 2 = ((debt in period 1)-<nPayment>)*(1+<nInterest>/100)
* etc...
* debt in period <nPeriod> = ((debt in period <nPeriod>-1)-<nPayment>)*(1+<nInterest>/100)
* -> has to be 0, so
* <nPresentValue> = <nPayment>*(1-(1+<nInterest>/100)^(-n))/(<nInterest>/100)
* $EXAMPLES$
* // You can afford to pay back 100 Dollars per month for 5 years
* // at a interest rate of 0.5% per month (6% per year), so instead
* // of 6000 Dollars (the amount you will pay back) the bank will pay
* // you
*
* ? pv (100, 0.005, 60) --> 5172.56
* $TESTS$
* pv (100, 0.0, 60) == 6000.0
* pv (100, 0.005, 60) == 5172.56
* $STATUS$
* Ready
* $COMPLIANCE$
* PV() is compatible with CT3's PV().
* $PLATFORMS$
* All
* $FILES$
* Source is finan.c, library is libct.
* $SEEALSO$
* FV(),PAYMENT(),PERIODS(),RATE()
* $END$
*/
HB_FUNC( PV )
{
if( ISNUM(1) && ISNUM(2) && ISNUM(3) )
{
double dPayment = hb_parnd(1);
double dRate = hb_parnd(2);
double dTime = hb_parnd(3);
double dResult;
ct_matherrbegin();
if (dRate == 0.0)
{
/* NOTE: CT3 crashes with dRate == 0.0 */
dResult = dPayment*dTime;
}
else
{
dResult = dPayment*(1.0-pow (1.0+dRate, -dTime))/dRate;
}
ct_matherrend();
hb_retnd (dResult);
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_PV,
NULL, "PV", 0, EF_CANSUBSTITUTE, 3,
hb_paramError (1), hb_paramError (2),
hb_paramError (3));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (0.0);
}
}
return;
}
/* $DOC$
* $FUNCNAME$
* PAYMENT()
* $CATEGORY$
* CT3 math functions
* $ONELINER$
* Payments for a loan
* $SYNTAX$
* PAYMENT (nLoan, nInterest, nPeriods) --> nPayment
* $ARGUMENTS$
* <nLoan> amount of money you get from the bank
* <nInterest> rate of interest per period, 1 == 100%
* <nPeriods> period count
* $RETURNS$
* <nPayment> Periodical payment one has to make to pay the
* loan <nLoan> back
* $DESCRIPTION$
* PAYMENT() calculates the payment one has to make periodically
* to pay back a loan <nLoan> within <nPeriods> periods and for a
* rate of interest <nInterest> per period.
* debt in period 0 = <nLoan>
* debt in period 1 = ((debt in period 0)-<nPayment>)*(1+<nInterest>/100)
* debt in period 2 = ((debt in period 1)-<nPayment>)*(1+<nInterest>/100)
* etc...
* debt in period <nPeriod> = ((debt in period <nPeriod>-1)-<nPayment>)*(1+<nInterest>/100)
* -> has to be 0, so
* <nPayment> = <nLoan>*(<nInterest>/100)/(1-(1+<nInterest>/100)^(-n))
* $EXAMPLES$
* // You get a loan of 5172.56 at a interest rate of 0.5% per
* // month (6% per year).
* // For 5 years, you have to pay back every month
*
* ? payment (5172.56, 0.005, 60) --> 100.00
* $TESTS$
* payment (5172.56, 0.0, 60) == 86.21
* payment (5172.56, 0.005, 60) == 100.00
* $STATUS$
* Ready
* $COMPLIANCE$
* PAYMENT() is compatible with CT3's PAYMENT().
* $PLATFORMS$
* All
* $FILES$
* Source is finan.c, library is libct.
* $SEEALSO$
* PV(),FV(),PERIODS(),RATE()
* $END$
*/
HB_FUNC( PAYMENT )
{
if( ISNUM(1) && ISNUM(2) && ISNUM(3) )
{
double dCapital = hb_parnd(1);
double dRate = hb_parnd(2);
double dTime = hb_parnd(3);
double dResult;
if (dRate == 0.0)
{
/* NOTE: CT3 crashes with dRate == 0.0 */
if (dTime == 0.0)
{
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
ct_error ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_PAYMENT,
NULL, "PAYMENT", 0, EF_CANDEFAULT, 3,
hb_paramError (1), hb_paramError (2),
hb_paramError (3));
};
hb_retnd (0.0);
return;
}
ct_matherrbegin();
dResult = dCapital/dTime;
ct_matherrend();
}
else
{
ct_matherrbegin();
dResult = dCapital*dRate/(1.0-pow (1.0+dRate, -dTime));
ct_matherrend();
}
hb_retnd (dResult);
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_PAYMENT,
NULL, "PAYMENT", 0, EF_CANSUBSTITUTE, 3,
hb_paramError (1), hb_paramError (2),
hb_paramError (3));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (0.0);
}
}
return;
}
/* $DOC$
* $FUNCNAME$
* PERIODS()
* $CATEGORY$
* CT3 math functions
* $ONELINER$
* Number of periods for a loan
* $SYNTAX$
* PERIODS (nLoan, nPayment, nInterest) --> nPeriods
* $ARGUMENTS$
* <nLoan> amount of money you get from the bank
* <nPayment> amount of money you pay back per period
* <nInterest> rate of interest per period, 1 == 100%
* $RETURNS$
* <nPeriods> number of periods you need to pay the loan back
* $DESCRIPTION$
* PERIODS() calculates the number of periods one needs to pay back
* a loan of <nLoan> with periodical payments of <nPayment> and for a
* rate of interest <nInterest> per period.
* debt in period 0 = <nLoan>
* debt in period 1 = ((debt in period 0)-<nPayment>)*(1+<nInterest>/100)
* debt in period 2 = ((debt in period 1)-<nPayment>)*(1+<nInterest>/100)
* etc...
* debt in period <nPeriod> = ((debt in period <nPeriod>-1)-<nPayment>)*(1+<nInterest>/100)
* -> has to be 0, so
* <nPeriods> = -log(1-<nLoan>*(<nInterest>/100)/<nPayment>)/log(1+<nInterest>/100))
*
* Note, however that in the case of nPayment <= <nLoan>*(<nInterest>/100),
* one would need infinite time to pay the loan back. The functions does
* then return -1.
* $EXAMPLES$
* // You get a loan of 5172.56 at a interest rate of 0.5% per
* // month (6% per year).
* // You can afford to pay 100 back every month, so you need
*
* ? periods (5172.56, 100, 0.005) --> 60.0
*
* // months to cancel the loan.
* $TESTS$
* periods (5172.56, 100, 0.005) == 60.0
* periods (5172.56, 100, 0.0) == 51.7256
* $STATUS$
* Ready
* $COMPLIANCE$
* PERIODS() is compatible with CT3's PERIODS().
* $PLATFORMS$
* All
* $FILES$
* Source is finan.c, library is libct.
* $SEEALSO$
* PV(),FV(),PAYMENT(),RATE()
* $END$
*/
HB_FUNC( PERIODS )
{
if( ISNUM(1) && ISNUM(2) && ISNUM(3) )
{
double dCapital = hb_parnd(1);
double dPayment = hb_parnd(2);
double dRate = hb_parnd(3);
double dResult;
if (dPayment <= dCapital*dRate)
{
/* in this case infinite time is needed to cancel the loan */
hb_retnd (-1.0);
return;
}
if (dRate == 0.0)
{
/* NOTE: CT3 crashes with dRate == 0.0 */
if (dPayment == 0.0)
{
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
ct_error ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_PERIODS,
NULL, "PERIODS", 0, EF_CANDEFAULT, 3,
hb_paramError (1), hb_paramError (2),
hb_paramError (3));
};
hb_retnd (0.0);
return;
}
ct_matherrbegin();
dResult = dCapital/dPayment;
ct_matherrend();
}
else
{
ct_matherrbegin();
dResult = -log(1.0-(dCapital*dRate/dPayment))/log(1+dRate);
ct_matherrend();
}
hb_retnd( dResult );
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_PERIODS,
NULL, "PERIODS", 0, EF_CANSUBSTITUTE, 3,
hb_paramError (1), hb_paramError (2),
hb_paramError (3));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (0.0);
}
}
return;
}
/* $DOC$
* $FUNCNAME$
* RATE()
* $CATEGORY$
* CT3 math functions
* $ONELINER$
* Estimate rate of interest for a loan
* $SYNTAX$
* RATE (nLoan, nPayment, nPeriods) --> nRate
* $ARGUMENTS$
* <nLoan> amount of money you get from the bank
* <nPayment> amount of money you pay back per period
* <nPeriods> number of periods you pay the loan back
* $RETURNS$
* <nInterest> estimated rate of interest per period, 1 == 100%
* $DESCRIPTION$
* RATE() calculates the rate of interest per period for the given
* loan, payment per periods and number of periods. This is done with
* the same equation used in the PAYMENT() or PERIODS() function:
*
* <nPayment> = <nLoan>*(<nInterest>/100)/(1-(1+<nInterest>/100)^(-<nPeriods>))
*
* However, this equation can not be solved for <nInterest> in a "closed"
* manner, i.e. <nInterest> = ..., so that the result can only be estimated.
* $EXAMPLES$
* // You get a loan of 5172.56, pay 100 back every month for
* // 5 years (60 months). The effective interest rate per
* // period (=month) is
*
* ? rate (5172.56, 100, 60) --> 0.005
*
* $TESTS$
* rate (5172.56, 100, 60.0) == 0.005
* rate (6000.0, 100, 60.0) == 0.0
* $STATUS$
* Ready
* $COMPLIANCE$
* RATE() is compatible with CT3's RATE().
* $PLATFORMS$
* All
* $FILES$
* Source is finan.c, library is libct.
* $SEEALSO$
* PV(),FV(),PAYMENT(),PERIODS()
* $END$
*/
HB_FUNC( RATE )
{
if( ISNUM(1) && ISNUM(2) && ISNUM(3) )
{
double dCapital = hb_parnd(1);
double dPayment = hb_parnd(2);
double dTime = hb_parnd(3);
double dAux; /* estimated payment to compare for */
double dEpsilon = 0.00001; /* mimimal to consider 2 numbers as equal*/
double dScale = 1.0; /* fractional step */
double r; /* temptative rate */
double j = 1.0; /* index */
double dExp;
while( j < 1020.0 ) /* maximum anual rate */
{
r = j * 0.000833333; /* j * ( 0.01 / 12.0) mensual's rate */
/* replace PAYMENT() function overhead */
dExp = pow( (1.0 + r), dTime );
dAux = dCapital * ( (dExp * r) / (dExp - 1.0) );
if( dAux > dPayment )
{
j = j - dScale;
dScale = dScale * 0.10;
if( (dAux - dPayment) < dEpsilon)
break;
}
else
j = j + dScale;
} /* endwhile */
hb_retnd( j * 0.000833333 ); /* return as mensual's rate */
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_RATE,
NULL, "RATE", 0, EF_CANSUBSTITUTE, 3,
hb_paramError (1), hb_paramError (2),
hb_paramError (3));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (0.0);
}
}
return;
}

20
harbour/contrib/libct/makefile.bc
View File

@@ -114,7 +114,11 @@ TOOLS_LIB_OBJS = \
$(OBJ_DIR)\ctcolton.obj \
$(OBJ_DIR)\ctcrypt.obj \
$(OBJ_DIR)\ctposupp.obj \
$(OBJ_DIR)\finan.obj \
$(OBJ_DIR)\math.obj \
$(OBJ_DIR)\num1.obj \
$(OBJ_DIR)\token1.obj \
$(OBJ_DIR)\trig.obj \
$(OBJ_DIR)\wordrepl.obj \
\
$(OBJ_DIR)\ctmisc.obj \
@@ -232,10 +236,26 @@ $(OBJ_DIR)\ctposupp.obj : $(TOOLS_DIR)\ctposupp.c
$(CC) $(CLIBFLAGS) -o$@ $**
tlib $(TOOLS_LIB) $(ARFLAGS) -+$@,,
$(OBJ_DIR)\finan.obj : $(TOOLS_DIR)\finan.c
$(CC) $(CLIBFLAGS) -o$@ $**
tlib $(TOOLS_LIB) $(ARFLAGS) -+$@,,
$(OBJ_DIR)\math.obj : $(TOOLS_DIR)\math.c
$(CC) $(CLIBFLAGS) -o$@ $**
tlib $(TOOLS_LIB) $(ARFLAGS) -+$@,,
$(OBJ_DIR)\num1.obj : $(TOOLS_DIR)\num1.c
$(CC) $(CLIBFLAGS) -o$@ $**
tlib $(TOOLS_LIB) $(ARFLAGS) -+$@,,
$(OBJ_DIR)\token1.obj : $(TOOLS_DIR)\token1.c
$(CC) $(CLIBFLAGS) -o$@ $**
tlib $(TOOLS_LIB) $(ARFLAGS) -+$@,,
$(OBJ_DIR)\trig.obj : $(TOOLS_DIR)\trig.c
$(CC) $(CLIBFLAGS) -o$@ $**
tlib $(TOOLS_LIB) $(ARFLAGS) -+$@,,
$(OBJ_DIR)\wordrepl.obj : $(TOOLS_DIR)\wordrepl.c
$(CC) $(CLIBFLAGS) -o$@ $**
tlib $(TOOLS_LIB) $(ARFLAGS) -+$@,,

8
harbour/contrib/libct/makefile.vc
View File

@@ -134,7 +134,11 @@ TOOLS_LIB_OBJS = \
$(OBJ_DIR)\ctcolton.obj \
$(OBJ_DIR)\ctcrypt.obj \
$(OBJ_DIR)\ctposupp.obj \
$(OBJ_DIR)\finan.obj \
$(OBJ_DIR)\math.obj \
$(OBJ_DIR)\num1.obj \
$(OBJ_DIR)\token1.obj \
$(OBJ_DIR)\trig.obj \
$(OBJ_DIR)\wordrepl.obj \
\
$(OBJ_DIR)\ctmisc.obj \
@@ -172,7 +176,11 @@ CLEAN:
-@if exist $(OBJ_DIR)\ctcolton.* del $(OBJ_DIR)\ctcolton.*
-@if exist $(OBJ_DIR)\ctcrypt.* del $(OBJ_DIR)\ctcrypt.*
-@if exist $(OBJ_DIR)\ctposupp.* del $(OBJ_DIR)\ctposupp.*
-@if exist $(OBJ_DIR)\finan.* del $(OBJ_DIR)\finan.*
-@if exist $(OBJ_DIR)\math.* del $(OBJ_DIR)\math.*
-@if exist $(OBJ_DIR)\num1.* del $(OBJ_DIR)\num1.*
-@if exist $(OBJ_DIR)\token1.* del $(OBJ_DIR)\token1.*
-@if exist $(OBJ_DIR)\trig.* del $(OBJ_DIR)\trig.*
-@if exist $(OBJ_DIR)\wordrepl.* del $(OBJ_DIR)\wordrepl.*
-@if exist $(OBJ_DIR)\ctmisc.* del $(OBJ_DIR)\ctmisc.*
-@if exist $(TOOLS_LIB) del $(TOOLS_LIB)

483
harbour/contrib/libct/math.c Normal file
View File

@@ -0,0 +1,483 @@
/*
* Harbour Project source code:
*
* CT3 mathematical functions
* - FLOOR
* - CEILING
* - SIGN
* - LOG10
* - FACT
*
* NOTE: All these functions were builded using Borland C++ 5.5 (free version)
*
* Copyright 2001 Alejandro de Garate <alex_degarate@hotmail.com>
*
* Documentation and changes concerning error handling Copyright 2001
* IntTec GmbH, Freiburg, Germany, Author: Martin Vogel <vogel@inttec.de>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "ct.h"
/* $DOC$
* $FUNCNAME$
* FLOOR()
* $CATEGORY$
* CT3 math functions
* $ONELINER$
* Rounds down a number to the next integer
* $SYNTAX$
* FLOOR (nNumber) -> nDownRoundedNumber
* $ARGUMENTS$
* <nNumber> number to round down
* $RETURNS$
* <nDownRoundedNumber> the rounded number
* $DESCRIPTION$
* The function FLOOR() determines the biggest integer that is smaller
* than <nNumber>.
* $EXAMPLES$
* ? floor (1.1) --> 1.0
* ? floor (-1.1) --> -2.0
* $TESTS$
* floor (1.1) == 1.0
* floor (-1.1) == -2.0
* $STATUS$
* Ready
* $COMPLIANCE$
* FLOOR() is compatible with CT3's FLOOR().
* $PLATFORMS$
* All
* $FILES$
* Source is math.c, library is libct.
* $SEEALSO$
* CEILING
* $END$
*/
HB_FUNC( FLOOR )
{
if( ISNUM(1) )
{
double dInput = hb_parnd(1);
double dResult;
ct_matherrbegin();
dResult = floor (dInput);
ct_matherrend();
hb_retnd( dResult );
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_FLOOR,
NULL, "FLOOR", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (0.0);
}
}
return;
}
/* $DOC$
* $FUNCNAME$
* CEILING()
* $CATEGORY$
* CT3 math functions
* $ONELINER$
* Rounds up a number to the next integer
* $SYNTAX$
* CEILING (nNumber) -> nUpRoundedNumber
* $ARGUMENTS$
* <nNumber> number to round up
* $RETURNS$
* <nUpRoundedNumber> the rounded number
* $DESCRIPTION$
* The function CEILING() determines the smallest integer that is bigger
* than <nNumber>.
* $EXAMPLES$
* ? ceiling (1.1) --> 2.0
* ? ceiling (-1.1) --> -1.0
* $TESTS$
* ceiling (1.1) == 2.0
* ceiling (-1.1) == -1.0
* $STATUS$
* Ready
* $COMPLIANCE$
* CEILING() is compatible with CT3's CEILING().
* $PLATFORMS$
* All
* $FILES$
* Source is math.c, library is libct.
* $SEEALSO$
* FLOOR
* $END$
*/
HB_FUNC( CEILING )
{
if( ISNUM(1) )
{
double dInput = hb_parnd(1);
double dResult;
ct_matherrbegin();
dResult = ceil (dInput);
ct_matherrend();
hb_retnd( dResult );
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_CEILING,
NULL, "CEILING", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (0.0);
}
}
return;
}
/* $DOC$
* $FUNCNAME$
* SIGN()
* $CATEGORY$
* CT3 math functions
* $ONELINER$
* Sign of a number
* $SYNTAX$
* SIGN (nNumber) -> nSign
* $ARGUMENTS$
* <nNumber> a number
* $RETURNS$
* <nSign> sign of <nNumber>
* $DESCRIPTION$
* The function SIGN() determines the sign of <nNumber>.
* If <nNumber> is > 0, then SIGN(<nNumber>) returns 1
* If <nNumber> is < 0, then SIGN(<nNumber>) returns -1
* If <nNumber> is == 0, then SIGN(<nNumber>) returns 0
* $EXAMPLES$
* ? sign (1.1) --> 1
* ? sign (-1.1) --> -1
* ? sign (0.0) --> 0
* $TESTS$
* sign (1.1) == 1
* sign (-1.1) == -1
* sign (0.0) == 0
* $STATUS$
* Ready
* $COMPLIANCE$
* SIGN() is compatible with CT3's SIGN().
* $PLATFORMS$
* All
* $FILES$
* Source is math.c, library is libct.
* $SEEALSO$
* $END$
*/
HB_FUNC( SIGN )
{
if( ISNUM(1) )
{
double dInput = hb_parnd(1);
int iResult ;
if( dInput == 0.00 )
iResult = 0;
else
{
if( dInput > 0.00 )
iResult = 1;
else
iResult = -1;
}
hb_retni( iResult );
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_SIGN,
NULL, "SIGN", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retni (0);
}
}
return;
}
/* $DOC$
* $FUNCNAME$
* LOG10()
* $CATEGORY$
* CT3 math functions
* $ONELINER$
* Decadic logarithm of a number
* $SYNTAX$
* LOG10 (nNumber) -> nLogarithm
* $ARGUMENTS$
* <nNumber> number to logarithm
* $RETURNS$
* <nLogarithm> decadic logarithm of <nNumber>
* $DESCRIPTION$
* The function LOG10() calculates the decadic logarithm of <nNumber>,
* i.e. 10^<nLogarithm> == <nNumber>.
* $EXAMPLES$
* ? log10 (10.0) --> 1.0
* ? log10 (sqrt(10.0)) --> 0.5
* $TESTS$
* log10 (10.0) == 1.0
* log10 (sqrt(10.0)) == 0.5
* $STATUS$
* Ready
* $COMPLIANCE$
* LOG10() is compatible with CT3's LOG10().
* $PLATFORMS$
* All
* $FILES$
* Source is math.c, library is libct.
* $SEEALSO$
* $END$
*/
HB_FUNC( LOG10 )
{
if( ISNUM(1) )
{
double dInput = hb_parnd(1);
double dResult;
if (dInput <= 0.0)
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_LOG10,
NULL, "LOG10", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (0.0);
}
}
else
{
ct_matherrbegin();
dResult = log10 (dInput);
ct_matherrend();
hb_retnd( dResult );
}
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_LOG10,
NULL, "LOG10", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retni (0);
}
}
return;
}
/* $DOC$
* $FUNCNAME$
* FACT()
* $CATEGORY$
* CT3 math functions
* $ONELINER$
* Calculates faculty
* $SYNTAX$
* FACT (nNumber) -> nFaculty
* $ARGUMENTS$
* <nNumber> number between 0 and 21
* $RETURNS$
* <nFaculty> the faculty of <nNumber>
* $DESCRIPTION$
* The function FACT() calculates the faculty to the integer given in
* <nNumber>. The faculty is defined as n! = 1*2*...*n and is often
* used in statistics. Note, that faculties above 21 are too big
* so that the function must return a -1.
* $EXAMPLES$
* ? fact (0) --> 1
* ? fact (1) --> 1
* ? fact (4) --> 24
* $TESTS$
* fact (0) == 1
* fact (1) == 1
* fact (4) == 24
* $STATUS$
* Ready
* $COMPLIANCE$
* FACT() is compatible with CT3's FACT().
* $PLATFORMS$
* All
* $FILES$
* Source is math.c, library is libct.
* $SEEALSO$
* $END$
*/
HB_FUNC( FACT )
{
if( ISNUM(1) )
{
int iInput = hb_parni(1);
int i;
double dResult = 1.0;
if ((iInput >= 0) && (iInput < 22))
{
for (i = 1; i <= iInput; i++)
{
dResult *= (double)i;
}
hb_retnd( dResult );
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_FACT,
NULL, "FACT", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (-1.0);
}
}
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_FACT,
NULL, "FACT", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (0.0);
}
}
return;
}

266
harbour/contrib/libct/num1.c Normal file
View File

@@ -0,0 +1,266 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
*
* CT3 Numeric functions - PART 1
* - CELSIUS
* - FAHRENHEIT
* - INFINITY
*
* NOTE: All these functions were builded using Borland C++ 5.5 (free version)
*
* Copyright 2001 Alejandro de Garate <alex_degarate@hotmail.com>
*
* Documentation and changes concerning error handling Copyright 2001
* IntTec GmbH, Freiburg, Germany, Author: Martin Vogel <vogel@inttec.de>
*
* www - http://www.harbour-project.org
*
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "ct.h"
/* $DOC$
* $FUNCNAME$
* CELSIUS()
* $CATEGORY$
* CT3 numeric functions
* $ONELINER$
* Temperature conversion Fahrenheit to Celsius
* $SYNTAX$
* CELSIUS (nDegreeFahrenheit) --> nDegreeCelsius
* $ARGUMENTS$
* <nDegreeFahrenheit> temperature in degree Fahrenheit
* $RETURNS$
* <nDegreeCelsius> temperate in degree Celsius
* $DESCRIPTION$
* CELSIUS() converts temperature values measured in the Fahrenheit scale
* to the Celsius scale.
* $EXAMPLES$
* // melting point of water in standard conditions
* ? celsius (32.0) --> 0.0
* // boiling point of water in standard conditions
* ? celsius (212.0) --> 100.0
* $TESTS$
* celsius (32.0) == 0.0
* celsius (212.0) == 100.0
* $STATUS$
* Ready
* $COMPLIANCE$
* CELSIUS() is compatible with CT3's CELSIUS().
* $PLATFORMS$
* All
* $FILES$
* Source is num1.c, library is libct.
* $SEEALSO$
* FAHRENHEIT()
* $END$
*/
HB_FUNC( CELSIUS )
{
if( ISNUM(1) )
{
double dInput = hb_parnd(1);
double dResult;
ct_matherrbegin();
dResult = (5.0 / 9.0) * ( dInput - 32.0 );
ct_matherrend();
hb_retnd( dResult );
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_CELSIUS,
NULL, "CELSIUS", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (0.0);
}
}
return;
}
/* $DOC$
* $FUNCNAME$
* FAHRENHEIT()
* $CATEGORY$
* CT3 numeric functions
* $ONELINER$
* Temperature conversion Celsius to Fahrenheit
* $SYNTAX$
* FAHRENHEIT (nDegreeCelsius) --> nDegreeFahrenheit
* $ARGUMENTS$
* <nDegreeCelsius> temperate in degree Celsius
* $RETURNS$
* <nDegreeFahrenheit> temperature in degree Fahrenheit
* $DESCRIPTION$
* FAHRENHEIT() converts temperature values measured in the Celsius scale
* to the Fahrenheit scale.
* $EXAMPLES$
* // melting point of water in standard conditions
* ? fahrenheit (0.0) --> 32.0
* // boiling point of water in standard conditions
* ? fahrenheit (100.0) --> 212.0
* $TESTS$
* fahrenheit (0.0) == 32.0
* celsius (100.0) == 212.0
* $STATUS$
* Ready
* $COMPLIANCE$
* FAHRENHEIT() is compatible with CT3's FAHRENHEIT().
* $PLATFORMS$
* All
* $FILES$
* Source is num1.c, library is libct.
* $SEEALSO$
* CELSIUS()
* $END$
*/
HB_FUNC( FAHRENHEIT )
{
if( ISNUM(1) )
{
double dInput = hb_parnd(1);
double dResult;
ct_matherrbegin();
dResult = (( 9.0 / 5.0) * dInput ) + 32.0 ;
ct_matherrend();
hb_retnd( dResult );
}
else
{
PHB_ITEM pSubst = NULL;
int iArgErrorMode = ct_getargerrormode();
if (iArgErrorMode != CT_ARGERR_IGNORE)
{
pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_FAHRENHEIT,
NULL, "FAHRENHEIT", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1));
}
if (pSubst != NULL)
{
hb_itemReturn (pSubst);
hb_itemRelease (pSubst);
}
else
{
hb_retnd (0.0);
}
}
return;
}
/* $DOC$
* $FUNCNAME$
* INFINITY()
* $CATEGORY$
* CT3 numeric functions
* $ONELINER$
* Returns the largest floating point number available in the system
* $SYNTAX$
* INFINITY ([<lPlatformIndependant>]) --> nLargestNumber
* $ARGUMENTS$
* [<lPlatformIndependant>] .T., if the function should return
* the maximum floating point value
* available (DBL_MAX)
* .F., function should try to return
* the same value as the original CT3 lib did
* Default: .F.
* $RETURNS$
* <nLargestNumber> the largest floating point number available in the system
* $DESCRIPTION$
* INFINITY() returns the largest floating point number available
* in the system. For platform independance, this is set to DBL_MAX.
* $EXAMPLES$
* $TESTS$
* $STATUS$
* Ready
* $COMPLIANCE$
* INFINITY() must not necessarily return the same number as CT3's INFINITY().
* $PLATFORMS$
* All
* $FILES$
* Source is num1.c, library is libct.
* $SEEALSO$
* $END$
*/
HB_FUNC( INFINITY )
{
if (ISLOG (1) && hb_parl(1))
{
hb_retnd (DBL_MAX);
}
else
{
hb_retnd (93786976294838206460.00);
}
return;
}

4
harbour/contrib/libct/tests/Makefile
View File

@@ -66,12 +66,16 @@ PRG_SOURCES=\
csetatmu.prg \
csetarge.prg \
csetref.prg \
finan.prg \
math.prg \
num1.prg \
numtoken.prg \
setatlik.prg \
token.prg \
tokenlow.prg \
tokensep.prg \
tokenupp.prg \
trig.prg \
valpos.prg \
wordone.org \
wordonly.prg \

111
harbour/contrib/libct/tests/finan.prg Normal file
View File

@@ -0,0 +1,111 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* CT3 Financial functions
* - PV
* - FV
* - PAYMENT
* - PERIODS
* - RATE
*
* NOTE: All these functions were builded using Borland C++ 5.5 (free version)
*
* Copyright 2001 Alejandro de Garate <alex_degarate@hotmail.com>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
PROCEDURE MAIN
CTINIT()
SET DECIMAL TO 3
CLS
?? "Testing Financial functions...."
?
? "Calculate how loan summs if you make deposits for $175.00 for 24 months,"
? "if the annual rate of the Bank for this mortage is 9.5% fixed"
? "PV( 175, 0.095/12, 24 ) = 3811.433 // CT3"
? SPACE(19), PV( 175, 0.095/12, 24 ), " <-- CT for Harbour"
?
?
? "Calculate the amount in your account after 3 years, if you make deposits"
? "for $150.00 per month, and the annual rate of the Bank for this is 6%"
? "Capital = FV( 150, 0.06/12, 36 ) = 5900.416 // CT3"
? SPACE(28), FV( 150, 0.06/12, 36 ), " <-- CT for Harbour"
?
?
? "Calculate the monthly payment for a loan of $2000.00 at an annual rate"
? "of 10%, within 24 month "
? "PAYMENT( 2000.00, 0.10/12, 24 ) = 92.290 // CT3"
? SPACE(26),PAYMENT( 2000.00, 0.10/12, 24 ), " <-- CT for Harbour"
?
? " PRESS ANY KEY"
INKEY (0)
? "Continue Testing Financial functions...."
?
? "Calculate how many month do you need to cancel a loan of $4000.00 at"
? "an annual rate of 9.5% with payments of $200.00 max"
? "PERIODS( 4000.00, 200.00, 0.095/12 ) = 21.859 // CT3"
? SPACE(31), PERIODS( 4000.00, 200.00, 0.095/12 ), " <-- CT for Harbour"
?
?
? "Calculate which is the effective anual rate of your Bank, for a loan"
? "of $2500.00 if you pay $86.67 per month for 3 years"
? "RATE( 2500.00, 86.67, 36 ) * 12 = 0.1501 // CT3"
? SPACE(24), RATE( 2500.00, 86.67, 36 ) * 12.0, " <-- CT for Harbour"
?
? " PRESS ANY KEY"
INKEY(0)
CTEXIT()
RETURN

178
harbour/contrib/libct/tests/math.prg Normal file
View File

@@ -0,0 +1,178 @@
/*
* Harbour Project source code:
*
* Test CT3 math functions
* - FLOOR
* - CEILING
* - LOG10
* - SIGN
* - FACT
*
* Copyright 2001 Alejandro de Garate <alex_degarate@hotmail.com>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
PROCEDURE MAIN
CTINIT()
SET DECIMAL TO 2
CLS
? "Test of mathematical functions"
?
? "FLOOR( 1.9) = 1 // CT3"
? SPACE(4), FLOOR( 1.9)," <-- CT for Harbour"
?
? "FLOOR( 1.1) = 1 // CT3"
? SPACE(4), FLOOR( 1.1)," <-- CT for Harbour"
?
? "FLOOR( 0.9) = 0 // CT3"
? SPACE(4), FLOOR( 0.9)," <-- CT for Harbour"
?
? "FLOOR( -0.1) = -1 // CT3"
? SPACE(6), FLOOR( -0.1)," <-- CT for Harbour"
?
? "FLOOR( -0.9) = -1 // CT3"
? SPACE(6), FLOOR( -0.9)," <-- CT for Harbour"
?
? "FLOOR( -1.1) = -2 // CT3"
? SPACE(6), FLOOR( -1.1)," <-- CT for Harbour"
?
WAIT4()
? "CEILING( 1.9) = 2 // CT3"
? SPACE(6), CEILING( 1.9)," <-- CT for Harbour"
?
? "CEILING( 1.1) = 2 // CT3"
? SPACE(6), CEILING( 1.1)," <-- CT for Harbour"
?
? "CEILING( 0.9) = 1 // CT3"
? SPACE(6), CEILING( 0.9)," <-- CT for Harbour"
?
? "CEILING( -0.1) = 0 // CT3"
? SPACE(7), CEILING( -0.1)," <-- CT for Harbour"
?
? "CEILING( -0.9) = 0 // CT3"
? SPACE(7), CEILING( -0.9)," <-- CT for Harbour"
?
? "CEILING( -1.1) = -1 // CT3"
? SPACE(8), CEILING( -1.1)," <-- CT for Harbour"
?
WAIT4()
? "LOG10( 0.01 ) = -2.00 // CT3"
? SPACE(7), LOG10( 0.01 )," <-- CT for Harbour"
?
? "LOG10( 2 ) = 0.30 // CT3"
? SPACE(3), LOG10( 2 )," <-- CT for Harbour"
?
? "LOG10( 100 ) = 2.00 // CT3"
? SPACE(5), LOG10( 100 )," <-- CT for Harbour"
?
?
? "SIGN( 48335 ) = 1 // CT3"
? SPACE(6), SIGN( 48335 )," <-- CT for Harbour"
?
? "SIGN( -258 ) = -1 // CT3"
? SPACE(6), SIGN( -258 )," <-- CT for Harbour"
?
WAIT4()
SET DECIMALS TO 0
? "FACT( 1 ) = 1 // CT3"
? SPACE(2), FACT( 1 ), " <-- CT for Harbour"
?
? "FACT( 5 ) = 120 // CT3"
? SPACE(4), FACT( 5), " <-- CT for Harbour"
?
? "FACT( 21 ) = 51090942171709440000 // CT3"
? SPACE(12), FACT( 21), " <-- CT for Harbour"
?
? "FACT( 25 ) = -1 // CT3"
? SPACE(4), FACT( 25), " <-- CT for Harbour"
?
? "FACT( 0 ) = 1 // CT3"
? SPACE(2), FACT( 0), " <-- CT for Harbour"
?
CTEXIT()
RETURN
PROCEDURE WAIT4
? " PRESS ANY KEY"
INKEY(0)
CLS
RETURN

106
harbour/contrib/libct/tests/num1.prg Normal file
View File

@@ -0,0 +1,106 @@
/*
* Harbour Project source code:
*
* Test CT3 Numeric functions - PART 1
*
* - CELSIUS
* - FAHRENHEIT
* - INFINITY
*
* Copyright 2001 Alejandro de Garate <alex_degarate@hotmail.com>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
PROCEDURE MAIN
CTINIT()
SET DECIMAL TO 14
CLS
?? "Test of Numeric functions - part 1"
? "CELSIUS( 33.8 ) = 1 // CT3"
? SPACE(10), CELSIUS( 33.8 ), " <-- CT for Harbour "
?
? "CELSIUS( 338.0 ) = 170 // CT3"
? SPACE(11), CELSIUS( 338.0 ), " <-- CT for Harbour "
?
? "CELSIUS( 3380.0) = 1860 // CT3"
? SPACE(12), CELSIUS( 3380.0), " <-- CT for Harbour "
?
? "CELSIUS( -33.8) = -36.5555.. // CT3"
? SPACE(10), CELSIUS( -33.8), " <-- CT for Harbour "
?
? "FAHRENHEIT( 12.5 ) = 54.5 // CT3"
? SPACE(12), FAHRENHEIT( 12.5 ), " <-- CT for Harbour "
?
? "FAHRENHEIT( 125 ) = 257 // CT3"
? SPACE(12), FAHRENHEIT( 125 ), " <-- CT for Harbour "
?
? "FAHRENHEIT( 1250 ) = 2282 // CT3"
? SPACE(14), FAHRENHEIT( 1250 ), " <-- CT for Harbour "
?
? "FAHRENHEIT( -155 ) = -247 // CT3"
? SPACE(14), FAHRENHEIT( -155 ), " <-- CT for Harbour "
?
? " PRESS ANY KEY"
INKEY(0)
? "INFINITY() // CT3"
? SPACE(8), STR( INFINITY(), 30, 15), " <-- CT for Harbour"
?
CTEXIT()
RETURN

267
harbour/contrib/libct/tests/trig.prg Normal file
View File

@@ -0,0 +1,267 @@
/*
* Harbour Project source code:
*
* Test CT3 TRIGONOMETRIC functions - PART 1
*
* - PI
* - SIN
* - COS
* - TAN
* - COT
* - ASIN
* - ACOS
* - ATAN
* - ATN2
* - SINH
* - COSH
* - TANH
*
* Copyright 2001 Alejandro de garate <alex_degarate@hotmail.com>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
PROCEDURE MAIN
local X, Y
CTINIT()
SET DECIMAL TO 14
CLS
? "Begin test of Trigonometric functions... "
?
? "PI = " + STR( PI(), 18, 15 )
? "STR( SIN( PI() /4 ), 18, 15 ) = 0.707106781186548 // CT3"
? SPACE(32) + STR( SIN( PI() /4 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( SIN( PI() /2 ), 18, 15 ) = 1.000000000000000 // CT3"
? SPACE(32) + STR( SIN( PI() /2 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( SIN( PI() *99.5 ), 18, 15 ) = -1.000000000000000 // CT3"
? SPACE(35) + STR( SIN( PI() * 99.5 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( SIN( PI() /9 ), 18, 15 ) = 0.342020143325669 // CT3"
? SPACE(32) + STR( SIN( PI() / 9 ), 18, 15 ) + " <-- CT for Harbour"
WAIT4()
? "STR( COS( 0 ), 18, 15 ) = 1.000000000000000 // CT3"
? SPACE(26) + STR( COS( 0 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( COS( PI() /4 ), 18, 15 ) = 0.707106781186548 // CT3"
? SPACE(32) + STR( COS( PI() /4 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( COS( PI() /2 ), 18, 15 ) = 0.000000000000000 // CT3"
? SPACE(32) + STR( COS( PI() /2 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( COS( PI() *99.5 ), 18, 15 ) = 0.000000000000000 // CT3"
? SPACE(34) + STR( COS( PI() *99.5), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( COS( PI() /9 ), 18, 15 ) = 0.939692620785908 // CT3"
? SPACE(32) + STR( COS( PI() / 9 ), 18, 15 ) + " <-- CT for Harbour"
?
WAIT4()
? "STR( TAN( 0 ), 18, 15 ) = 1.000000000000000 // CT3 wrong ! "
? SPACE(26) + STR( TAN( 0 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( TAN( PI() /4 ), 18, 15 ) = 1.000000000000000 // CT3"
? SPACE(32) + STR( TAN( PI() /4 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( TAN( PI() /9 ), 18, 15 ) = 0.363970234266202 // CT3"
? SPACE(32) + STR( TAN( PI() / 9 ), 18, 15 ) + " <-- CT for Harbour"
?
?
?
? "STR( ASIN( 0.5 ), 18, 15 ) = 0.523598775598299 // CT3"
? SPACE(29) + STR( ASIN( 0.5 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( ACOS( 0.7 ), 18, 15 ) = 0.795398830184144 // CT3"
? SPACE(29) + STR( ACOS( 0.7 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( ATAN( PI() /4 ), 18, 15 ) = 0.665773750028354 // CT3"
? SPACE(33) + STR( ATAN( PI() /4 ), 18, 15 ) + " <-- CT for Harbour"
?
WAIT4()
? "STR( COT( PI() /4 ), 18, 15 ) = 1.000000000000000 // CT3"
? SPACE(32) + STR( COT( PI() /4 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( COT( PI() /2 ), 18, 15 ) = 0.000000000000000 // CT3"
? SPACE(32) + STR( COT( PI() /2 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( COT( PI() /9 ), 18, 15 ) = 2.747477419454622 // CT3"
? SPACE(32) + STR( COT( PI() / 9 ), 18, 15 ) + " <-- CT for Harbour"
?
WAIT4()
?? "Testing Hiperbolic Sine..."
?
? "STR( SINH( PI() /2 ), 18, 15 ) = 2.301298902307295 // CT3"
? SPACE(33) + STR( SINH( PI() /2 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( SINH( PI() /4 ), 18, 15 ) = 0.868670961486010 // CT3"
? SPACE(33) + STR( SINH( PI() /4 ), 18, 15 ) + " <-- CT for Harbour"
?
? "Testing Hiperbolic Cosine..."
?
? "STR( COSH( PI() /2 ), 18, 15 ) = 2.509178478658057 // CT3"
? SPACE(33) + STR( COSH( PI() /2 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( COSH( PI() /4 ), 18, 15 ) = 1.324609089252006 // CT3"
? SPACE(33) + STR( COSH( PI() /4 ), 18, 15 ) + " <-- CT for Harbour"
?
? "Testing Hiperbolic Tangent..."
?
? "STR( TANH( PI() /2 ), 18, 15 ) = 0.917152335667274 // CT3"
? SPACE(33) + STR( TANH( PI() /2 ), 18, 15 ) + " <-- CT for Harbour"
?
? "STR( TANH( PI() /4 ), 18, 15 ) = 0.655794202632672 // CT3"
? SPACE(33) + STR( TANH( PI() /4 ), 18, 15 ) + " <-- CT for Harbour"
?
WAIT4()
? "Testing Degree TO Radian..."
?
? "STR( DTOR( 360), 18, 15 ) = 6.283185307179588 // CT3"
? SPACE(27) + STR( DTOR( 360), 18, 15 ), " <-- CT for Harbour "
?
? "STR( DTOR( 180), 18, 15 ) = 3.141592653589794 // CT3"
? SPACE(27) + STR( DTOR( 180), 18, 15 ), " <-- CT for Harbour "
?
? "STR( DTOR( 180.5), 18, 15 ) = 3.150319299849766 // CT3"
? SPACE(29) + STR( DTOR( 180.5), 18, 15 ), " <-- CT for Harbour "
?
? "STR( DTOR( 720), 18, 15 ) = 12.566370614359180 // CT3"
? SPACE(28) + STR( DTOR( 720), 18, 15 ), " <-- CT for Harbour "
?
? "STR( DTOR( -180), 18, 15 ) = -3.141592653589794 // CT3"
? SPACE(29) + STR( DTOR( -180), 18, 15 ), " <-- CT for Harbour "
WAIT4()
? "Testing Radian TO Degree..."
?
? "RTOD( PI() ) = 180 // CT3 "
? SPACE(7), RTOD( PI() ), " <-- CT for Harbour "
? "RTOD( 2 * PI()) = 360 // CT3 "
? SPACE(10), RTOD( 2 * PI() ), " <-- CT for Harbour "
? "RTOD( 4 * PI()) = 720 // CT3 "
? SPACE(10), RTOD( 4 * PI() ), " <-- CT for Harbour "
? "RTOD( -PI() ) = -180 // CT3"
? SPACE(9), RTOD( -PI() ), " <-- CT for Harbour "
?
WAIT4()
/* NOTE: ATN2( x, y) have the parameters inverted, when
comparing with the standard C languaje ATAN2( y, x)
*/
? "Testing ATN2( x, y )... where:"
x = SIN( DTOR( 30 ) )
y = COS( DTOR( 30 ) )
? "x = SIN( DTOR( 30 ) ) =", x
? "y = COS( DTOR( 30 ) ) =", y
?
? "STR( ATN2( x, y ), 18, 15 ) = 0.523598775598299 // CT3"
? SPACE(31) + STR( ATN2( x, y), 18, 15 ) + " <-- CT for Harbour"
?
? "RTOD( ATN2( x, y)) ="+ STR( RTOD( ATN2( x,y)), 18,4) +" <-- CT for Harbour"
?
WAIT4()
CTEXIT()
RETURN
PROCEDURE WAIT4
? " PRESS ANY KEY"
INKEY(0)
CLS
RETURN

25
harbour/contrib/libct/token1.c
View File

@@ -83,7 +83,7 @@ static int siPostSeparator = -1; /* TODO: make this threadsafe */
static void do_token1 (int iSwitch)
{
int iParamCheck;
int iParamCheck = 0;
int iNoRef = ct_getref();
switch (iSwitch)
@@ -110,10 +110,13 @@ static void do_token1 (int iSwitch)
size_t sStrLen = (size_t)hb_parclen (1);
char *pcSeparatorStr;
size_t sSeparatorStrLen;
ULONG ulTokenCounter, ulSkip;
ULONG ulTokenCounter = 0;
ULONG ulSkip;
char *pcSubStr, *pcRet;
size_t sSubStrLen, sRetStrLen;
char *pcSubStr;
char *pcRet = NULL;
size_t sSubStrLen;
size_t sRetStrLen = 0;
ULONG ulToken = 0;
ULONG ulSkipCnt;
@@ -283,7 +286,7 @@ static void do_token1 (int iSwitch)
/* should we find the last token, but string ends with tokenizer, i.e.
pc points to a the last character at the moment ?
-> break here ! */
if (ulTokenCounter == HB_MKULONG (255,255,255,255) &&
if ((ulTokenCounter == HB_MKULONG (255,255,255,255)) &&
(pc+1==pcString+sStrLen))
{
break;
@@ -533,7 +536,7 @@ static void do_token1 (int iSwitch)
* $PLATFORMS$
* All
* $FILES$
* Source is token1.c, library is ct3.
* Source is token1.c, library is libct.
* $SEEALSO$
* TOKEN(),NUMTOKEN(),TOKENLOWER(),TOKENUPPER(),TOKENSEP()
* $END$
@@ -610,7 +613,7 @@ HB_FUNC (ATTOKEN)
* $PLATFORMS$
* All
* $FILES$
* Source is token1.c, library is ct3.
* Source is token1.c, library is libct.
* $SEEALSO$
* NUMTOKEN(),ATTOKEN(),TOKENLOWER(),TOKENUPPER(),TOKENSEP()
* $END$
@@ -649,7 +652,7 @@ HB_FUNC (TOKEN)
* $PLATFORMS$
* All
* $FILES$
* Source is token1.c, library is ct3.
* Source is token1.c, library is libct.
* $SEEALSO$
* TOKEN(),ATTOKEN(),TOKENLOWER(),TOKENUPPER(),TOKENSEP()
* $END$
@@ -718,7 +721,7 @@ HB_FUNC (NUMTOKEN)
* $PLATFORMS$
* All
* $FILES$
* Source is token1.c, library is ct3.
* Source is token1.c, library is libct.
* $SEEALSO$
* TOKEN(),NUMTOKEN(),ATTOKEN(),TOKENUPPER(),TOKENSEP(),CSETREF()
* $END$
@@ -788,7 +791,7 @@ HB_FUNC (TOKENLOWER)
* $PLATFORMS$
* All
* $FILES$
* Source is token1.c, library is ct3.
* Source is token1.c, library is libct.
* $SEEALSO$
* TOKEN(),NUMTOKEN(),ATTOKEN(),TOKENLOWER(),TOKENSEP(),CSETREF()
* $END$
@@ -837,7 +840,7 @@ HB_FUNC (TOKENUPPER)
* $PLATFORMS$
* All
* $FILES$
* Source is token1.c, library is ct3.
* Source is token1.c, library is libct.
* $SEEALSO$
* TOKEN(),NUMTOKEN(),ATTOKEN(),TOKENLOWER(),TOKENUPPER()
* $END$

1194
harbour/contrib/libct/trig.c Normal file
View File

File diff suppressed because it is too large Load Diff