gmp.bac

REM --------------------------------------------------------------------------------------
REM 
REM Inspired by Project Euler - http://projecteuler.net - I needed a library to perform
REM calculations with Really Large numbers.
REM 
REM This INCLUDE file implements a subset of the GMP library at http://gmplib.org
REM 
REM Integer functions implemented:
REM  ADD$, SUBSTRACT$, MULTIPLE$, DIVIDE$, MODULO$, SQUARE$, POWER$,
REM   FACTORIAL$, FIBONACCI$, ISPRIME, NEXTPRIME$
REM 
REM Float functions implemented:
REM  FADD$, FSUBSTRACT$, FMULTIPLE$, FDIVIDE$, FSQUARE$, FPOWER$, PRECISION$
REM 
REM Other functions:
REM  COMPARE, FCOMPARE, PRECISION
REM 
REM (c) Peter van Eerten, September 2009 - GPL.
REM Credits to the newLisp GMP module.
REM 
REM Version 0.1: -initial release
REM Version 0.2: -added MODULO$, ISPRIME$
REM Version 0.3: -floating numbers return correct format now
REM              -incoming arguments in float functions always converted to float
REM              -added PRECISION to define precision of float calculations
REM Version 0.4: -fixed limitation in precision definition
REM Version 0.5: -better library naming
REM Version 0.6: -added heuristic library search
REM Version 0.7: -added nth-root
REM Version 0.8: -added COMPARE and FCOMPARE
REM Version 0.9: -adjustments for including separate functions, added INIT
REM Version 0.10: -ISPRIME should return integer, second argument should be integer
REM Version 0.11: -simplified heuristic library search
REM Version 0.12: -add GCD$ (Greatest Common Divisor)
REM Version 0.13: -code improvements
REM Version 0.14: -improved import logic
REM Version 1.0: - renamed SUBSTRACT to SUBTRACT, modernized code to latest BaCon syntax
REM Version 2.0: - redesigned to link with libGMP directly
REM --------------------------------------------------------------------------------------

' Do not choke on GMP functions
OPTION PARSE FALSE

' Link with gmp
PRAGMA INCLUDE <gmp.h>
PRAGMA LDFLAGS -lgmp

REM Determine how many digits are significant in case of floats
CONST gmp_signify = 64

REM Use these variables for calculation
DECLARE gmp_op1, gmp_op2, gmp_res TYPE mpz_t
DECLARE gmp_fp1, gmp_fp2, gmp_fes TYPE mpf_t

REM Initialize these integer variables for GMP
__gmpz_init(gmp_op1)
__gmpz_init(gmp_op2)
__gmpz_init(gmp_res)
__gmpf_init2(gmp_fp1, gmp_signify)
__gmpf_init2(gmp_fp2, gmp_signify)
__gmpf_init2(gmp_fes, gmp_signify)

REM -------------------------- IMPLEMENTATION ------------------------------------

FUNCTION ADD$(STRING op1$, STRING op2$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_set_str(gmp_op1, op1$, 10)
    __gmpz_set_str(gmp_op2, op2$, 10)

    __gmpz_add(gmp_res, gmp_op1, gmp_op2)

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION SUBTRACT$(STRING op1$, STRING op2$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_set_str(gmp_op1, op1$, 10)
    __gmpz_set_str(gmp_op2, op2$, 10)

    __gmpz_sub(gmp_res, gmp_op1, gmp_op2)

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION MULTIPLY$(STRING op1$, STRING op2$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_set_str(gmp_op1, op1$, 10)
    __gmpz_set_str(gmp_op2, op2$, 10)

    __gmpz_mul(gmp_res, gmp_op1, gmp_op2)

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION DIVIDE$(STRING op1$, STRING op2$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_set_str(gmp_op1, op1$, 10)
    __gmpz_set_str(gmp_op2, op2$, 10)

    IF ISFALSE(__gmpz_cmp_si(gmp_op2, 0)) THEN
        PRINT "ERROR: division by zero in GMP module!"
        END
    END IF
    __gmpz_cdiv_q(gmp_res, gmp_op1, gmp_op2)

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION MODULO$(STRING op1$, STRING op2$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_set_str(gmp_op1, op1$, 10)
    __gmpz_set_str(gmp_op2, op2$, 10)

    IF ISFALSE(__gmpz_cmp_si(gmp_op2, 0)) THEN
        PRINT "ERROR: division by zero in GMP module!"
        END
    END IF
    __gmpz_mod(gmp_res, gmp_op1, gmp_op2)

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION POWER$(STRING op1$, STRING op2$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_set_str(gmp_op1, op1$, 10)

    __gmpz_pow_ui(gmp_res, gmp_op1, VAL(op2$))

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION SQUARE$(STRING op1$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_set_str(gmp_op1, op1$, 10)

    __gmpz_sqrt(gmp_res, gmp_op1)

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION ROOT$(STRING op1$, STRING op2$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_set_str(gmp_op1, op1$, 10)

    __gmpz_root(gmp_res, gmp_op1, VAL(op2$))

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION COMPARE(STRING op1$, STRING op2$)

    LOCAL result

    __gmpz_set_str(gmp_op1, op1$, 10)
    __gmpz_set_str(gmp_op2, op2$, 10)

    result = __gmpz_cmp(gmp_op1, gmp_op2)

    RETURN result

END FUNCTION

FUNCTION GCD$(STRING op1$, STRING op2$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_set_str(gmp_op1, op1$, 10)
    __gmpz_set_str(gmp_op2, op2$, 10)

    __gmpz_gcd(gmp_res, gmp_op1, gmp_op2)

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION

SUB PRECISION(NUMBER n)

    __gmpf_set_prec(gmp_fp1, n)
    __gmpf_set_prec(gmp_fp2, n)
    __gmpf_set_prec(gmp_fes, n)

END SUB

FUNCTION FADD$(STRING fp1$, STRING fp2$)

    LOCAL pointer TYPE char*
    LOCAL result$, var$
    LOCAL exp

    IF ISFALSE(INSTR(fp1$, ".")) THEN fp1$ = fp1$ & ".0"

    IF ISFALSE(INSTR(fp2$, ".")) THEN fp2$ = fp2$ & ".0"

    __gmpf_set_str(gmp_fp1, fp1$, 10)
    __gmpf_set_str(gmp_fp2, fp2$, 10)

    __gmpf_add(gmp_fes, gmp_fp1, gmp_fp2)

    pointer = __gmpf_get_str(NULL, &exp, 10, 0, gmp_fes)
    var$ = pointer

    IF ISFALSE(exp) THEN
        result$ = "0." & var$
    ELIF exp < 0 THEN
        result$ = "0." & FILL$(ABS(exp), 48) & var$
    ELSE
        IF LEN(var$) > exp THEN
            result$ = LEFT$(var$, exp) & "." & MID$(var$, exp+1)
        ELIF LEN(var$) = exp THEN
            result$ = var$ & ".0"
        ELSE
            result$ = var$ & FILL$(exp-LEN(var$), 48) & ".0"
        ENDIF
    ENDIF

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION FSUBTRACT$(STRING fp1$, STRING fp2$)

    LOCAL pointer TYPE char*
    LOCAL result$, var$
    LOCAL exp

    IF ISFALSE(INSTR(fp1$, ".")) THEN fp1$ = fp1$ & ".0"

    IF ISFALSE(INSTR(fp2$, ".")) THEN fp2$ = fp2$ & ".0"

    __gmpf_set_str(gmp_fp1, fp1$, 10)
    __gmpf_set_str(gmp_fp2, fp2$, 10)

    __gmpf_sub(gmp_fes, gmp_fp1, gmp_fp2)

    pointer = __gmpf_get_str(0, &exp, 10, 0, gmp_fes)
    var$ = pointer

    IF ISFALSE(exp) THEN
        result$ = "0." & var$
    ELIF exp < 0 THEN
        result$ = "0." & FILL$(ABS(exp), 48) & var$
    ELSE
        IF LEN(var$) > exp THEN
            result$ = LEFT$(var$, exp) & "." & MID$(var$, exp+1)
        ELIF LEN(var$) = exp THEN
            result$ = var$ & ".0"
        ELSE
            result$ = var$ & FILL$(exp-LEN(var$), 48) & ".0"
        ENDIF
    ENDIF

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION FMULTIPLY$(STRING fp1$, STRING fp2$)

    LOCAL pointer TYPE char*
    LOCAL result$, var$
    LOCAL exp

    IF ISFALSE(INSTR(fp1$, ".")) THEN fp1$ = fp1$ & ".0"

    IF ISFALSE(INSTR(fp2$, ".")) THEN fp2$ = fp2$ & ".0"

    __gmpf_set_str(gmp_fp1, fp1$, 10)
    __gmpf_set_str(gmp_fp2, fp2$, 10)

    __gmpf_mul(gmp_fes, gmp_fp1, gmp_fp2)

    pointer = __gmpf_get_str(0, &exp, 10, 0, gmp_fes)
    var$ = pointer

    IF ISFALSE(exp) THEN
        result$ = "0." & var$
    ELIF exp < 0 THEN
        result$ = "0." & FILL$(ABS(exp), 48) & var$
    ELSE
        IF LEN(var$) > exp THEN
            result$ = LEFT$(var$, exp) & "." & MID$(var$, exp+1)
        ELIF LEN(var$) = exp THEN
            result$ = var$ & ".0"
        ELSE
            result$ = var$ & FILL$(exp-LEN(var$), 48) & ".0"
        ENDIF
    ENDIF

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION FDIVIDE$(STRING fp1$, STRING fp2$)

    LOCAL pointer TYPE char*
    LOCAL result$, var$
    LOCAL exp

    IF ISFALSE(INSTR(fp1$, ".")) THEN fp1$ = fp1$ & ".0"

    IF ISFALSE(INSTR(fp2$, ".")) THEN fp2$ = fp2$ & ".0"

    __gmpf_set_str(gmp_fp1, fp1$, 10)
    __gmpf_set_str(gmp_fp2, fp2$, 10)

    IF ISFALSE(__gmpf_cmp_si(gmp_fp2, 0)) THEN
        PRINT "ERROR: division by zero in GMP module!"
        END
    END IF

    __gmpf_div(gmp_fes, gmp_fp1, gmp_fp2)

    pointer = __gmpf_get_str(0, &exp, 10, 0, gmp_fes)
    var$ = pointer

    IF ISFALSE(exp) THEN
        result$ = "0." & var$
    ELIF exp < 0 THEN
        result$ = "0." & FILL$(ABS(exp), 48) & var$
    ELSE
        IF LEN(var$) > exp THEN
            result$ = LEFT$(var$, exp) & "." & MID$(var$, exp+1)
        ELIF LEN(var$) = exp THEN
            result$ = var$ & ".0"
        ELSE
            result$ = var$ & FILL$(exp-LEN(var$), 48) & ".0"
        ENDIF
    ENDIF

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION FPOWER$(STRING fp1$, STRING fp2$)

    LOCAL pointer TYPE char*
    LOCAL result$, var$
    LOCAL exp

    IF ISFALSE(INSTR(fp1$, ".")) THEN fp1$ = fp1$ & ".0"

    __gmpf_set_str(gmp_fp1, fp1$, 10)

    __gmpf_pow_ui(gmp_fes, gmp_fp1, VAL(fp2$))

    pointer = __gmpf_get_str(0, &exp, 10, 0, gmp_fes)
    var$ = pointer

    IF ISFALSE(exp) THEN
        result$ = "0." & var$
    ELIF exp < 0 THEN
        result$ = "0." & FILL$(ABS(exp), 48) & var$
    ELSE
        IF LEN(var$) > exp THEN
            result$ = LEFT$(var$, exp) & "." & MID$(var$, exp+1)
        ELIF LEN(var$) = exp THEN
            result$ = var$ & ".0"
        ELSE
            result$ = var$ & FILL$(exp-LEN(var$), 48) & ".0"
        ENDIF
    ENDIF

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION FSQUARE$(STRING fp1$)

    LOCAL pointer TYPE char*
    LOCAL result$, var$
    LOCAL exp

    IF ISFALSE(INSTR(fp1$, ".")) THEN
        fp1$ = fp1$ & ".0"
    ENDIF

    __gmpf_set_str(gmp_fp1, fp1$, 10)

    __gmpf_sqrt(gmp_fes, gmp_fp1)

    pointer = __gmpf_get_str(0, &exp, 10, 0, gmp_fes)
    var$ = pointer

    IF ISFALSE(exp) THEN
        result$ = "0." & var$
    ELIF exp < 0 THEN
        result$ = "0." & FILL$(ABS(exp), 48) & var$
    ELSE
        IF LEN(var$) > exp THEN
            result$ = LEFT$(var$, exp) & "." & MID$(var$, exp+1)
        ELIF LEN(var$) = exp THEN
            result$ = var$ & ".0"
        ELSE
            result$ = var$ & FILL$(exp-LEN(var$), 48) & ".0"
        ENDIF
    ENDIF

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION FCOMPARE(STRING fp1$, STRING fp2$)

    LOCAL result

    IF ISFALSE(INSTR(fp1$, ".")) THEN fp1$ = fp1$ & ".0"

    IF ISFALSE(INSTR(fp2$, ".")) THEN fp2$ = fp2$ & ".0"

    __gmpf_set_str(gmp_fp1, fp1$, 10)
    __gmpf_set_str(gmp_fp2, fp2$, 10)

    result = __gmpf_cmp(gmp_fp1, gmp_fp2)

    RETURN result

END FUNCTION

FUNCTION FIBONACCI$(STRING op1$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_fib_ui(gmp_res, VAL(op1$))

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION FACTORIAL$(STRING op1$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_fac_ui(gmp_res, VAL(op1$))

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION

FUNCTION ISPRIME(STRING op1$, NUMBER op2)

    LOCAL result

    __gmpz_set_str(gmp_op1, op1$, 10)

    result = __gmpz_probab_prime_p(gmp_op1, op2)

    RETURN result

END FUNCTION

FUNCTION NEXTPRIME$(STRING op1$)

    LOCAL pointer TYPE char*
    LOCAL result$

    __gmpz_set_str(gmp_op1, op1$, 10)

    __gmpz_nextprime(gmp_res, gmp_op1)

    pointer = __gmpz_get_str(NULL, 10, gmp_res)
    result$ = pointer

    FREE pointer

    RETURN result$

END FUNCTION