+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: Treebeard's String-Math (/showthread.php?tid=691)
Treebeard's String-Math - Jack - 07-27-2022
just for fun I adapted Treebeard's String-Math arithmetic routines +, -, * and / to QB64 https://web.archive.org/web/20200220020034/http://www.rain.org/~mkummel/tbvault.html
Updated to include Sqr, Log, Exp and trig functions
Code: (Select All)
$Console:Only
_Dest _Console
'BIGNUM.BAS v0.n
'Sep-Dec 1996 by Marc Kummel aka Treebeard.
'Contact mkummel@rain.org, http://www.rain.org/~mkummel/
'
' ** site no longer available, use the link below
' https://web.archive.org/web/20200220020034/http://www.rain.org/~mkummel/tbvault.html
' Conditions:
'-------------
'This program and source code are yours to use and modify as you will, but
'they are offered as freeware with no warranty whatsoever. Give me credit,
'but do not distribute any changes under my name, or attribute such changes
'to me in any way. You're on your own!
Const neg$ = "-"
Const negative = -1
Const positive = 1
Const asc0 = 48
Const dp$ = "."
Const zero$ = "0"
Const one$ = "1"
Const two$ = "2"
Const three$ = "3"
Const four$ = "4"
Const five$ = "5"
Const False = 0
Const True = -1
Const basechr = "@"
Const basesep$ = ","
Const maxlongdig = 8
Const emem = 32
Const memget = 0
Const memput = 1
Const defaultdigits = 30
Const maxmem = 35
Const maxstack = 10
Const minconst = 30
Const maxconst = 35
Const pimem = 30
Const pi2mem = 31
Const phimem = 33
Const ln10mem = 34
Const ln2mem = 35
Const memclr = 2
'useful shared stuff, initialize these in bInit()
Dim Shared errormsg$, abortmsg$, Error$, bmem$(maxmem), out$
Dim Shared zmem$(maxstack), cname$(maxconst)
Dim Shared bncpath$, prmcntfile$
Dim Shared digits%, zstack%
'Prime count table data
Dim maxprmcnt%
Dim prmcnt&
'======================================
Dim n As String
Dim m As String
Dim c As String
digits% = 35
bInit
n = "7." + String$(digits% - 1, "7")
m = "9." + String$(digits% - 1, "9")
c = ""
bAdd (n), (m), c
Print "n + m = "; c
bSub (n), (m), c
Print "n - m = "; c
bMul (n), (m), c
Print "n * m = "; c
bDiv (n), (m), c
Print "n / m = "; c
bSqr "2", c
Print "Sqr(2) = "; c
bLn "2", c
Print "Ln(2) = "; c
bLog "2", "10", c
Print "Log10(2) = "; c
bSin "1", c
Print "Sin(1) = "; c
bCos "1", c
Print "Cos(1) = "; c
bTan "1", c
Print "Tan(1) = "; c
'======================================
' BNCxx.BAS
' BNC math module
' 1997 by Marc Kummel aka Treebeard.
' Contact mkummel@rain.org, http://www.rain.org/~mkummel/
's = |s|
'
Sub bAbs (s$)
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2)
End Sub
'out = s1 + s2
'
Sub bAdd (s1$, s2$, out$)
Dim last1%, dp1%, sign1%, last2%, dp2%, sign2%
Dim last%, d1%, d2%, dpt%, carry%
Dim i%, n%
'strip the numbers
bStripDp s1$, last1%, dp1%, sign1%
bStripDp s2$, last2%, dp2%, sign2%
'treat different signs as subtraction and exit
If sign1% = negative And sign2% = positive Then
bSub s2$, s1$, out$
bNeg s1$
Exit Sub
ElseIf sign1% = positive And sign2% = negative Then
bSub s1$, s2$, out$
bNeg s2$
Exit Sub
End If
'align the decimal points and digit pointers
last% = bMaxInt%(last1% - dp1%, last2% - dp2%)
d1% = last% + dp1%
d2% = last% + dp2%
dpt% = bMaxInt%(dp1%, dp2%)
last% = dpt% + last%
out$ = Space$(last%)
carry% = 0
'do the addition right to left
For i% = last% To 1 Step -1
If i% <> dpt% Then
n% = carry%
If d1% > 0 Then n% = n% + Val(Mid$(s1$, d1%, 1))
If d2% > 0 Then n% = n% + Val(Mid$(s2$, d2%, 1))
carry% = n% \ 10
Mid$(out$, i%, 1) = Chr$(asc0 + (n% Mod 10))
Else
Mid$(out$, i%, 1) = dp$
End If
d1% = d1% - 1
d2% = d2% - 1
Next i%
If carry% Then out$ = one$ + out$
'clean up
If sign1% = negative Then s1$ = neg$ + s1$: s2$ = neg$ + s2$: out$ = neg$ + out$
bClean s1$
bClean s2$
bClean out$
End Sub
'out = arccos(s)
'
Sub bArcCos (s$, out$)
Dim t$, t2$
' pi
' Arccos(x) = -- - Arcsin(x)
' 2
bPi t$
t2$ = t$
bDiv t2$, two$, t$
bArcSin s$, out$
If out$ <> Error$ Then bSub t$, (out$), out$
End Sub
'out = arccosh(s)
'
Sub bArcCosh (s$, out$)
'acosh(x) = Log(x + Sqr(x * x - 1))
out$ = zero$
End Sub
'out =arccot(s)
'
Sub bArcCot (s$, out$)
'acot(x) = Atn(x) + pi / 2
out$ = zero$
End Sub
'out =arccoth(s)
'
Sub bArcCoth (s$, out$)
'acoth(x) = Log((x + 1) / (x - 1)) / 2
out$ = zero$
End Sub
'out = arccsc(s)
'
Sub bArcCsc (s$, out$)
'acsc(x) = Atn(x / Sqr(x * x - 1)) + (Sgn(x) - 1) * pi / 2
out$ = zero$
End Sub
'out = arccsch(s)
'
Sub bArcCsch (s$, out$)
'acsch(x) = Log((Sgn(x) * Sqr(x * x + 1) + 1) / x)
out$ = zero$
End Sub
'out = arcsec(s)
'
Sub bArcSec (s$, out$)
'asec(x) = Atn(x / Sqr(x * x - 1)) + Sgn(Sgn(x) - 1) * pi / 2
out$ = zero$
End Sub
'out = arcsech(s)
'
Sub bArcSech (s$, out$)
'asech(x) = Log(Sqr((-x * x + 1) + 1) / x)
out$ = zero$
End Sub
'out = arcsin(s)
'
Sub bArcSin (s$, out$)
Dim t$, t2$
' x
' Arcsin(x) = Arctan --------
' û(1-x^2)
t2$ = s$
bMul t2$, s$, t$
bTrimDig t$
t2$ = t$
bSub one$, t2$, t$
If bIsNeg%(t$) Then
out$ = Error$
ElseIf bIsZero%(t$) Then
bPi out$
t2$ = out$
bDiv t2$, two$, out$
Else
t2$ = t$
bSqr t2$, t$
t2$ = t$
bDiv s$, t2$, t$
bTrimDig t$
bArcTan t$, out$
End If
End Sub
'out = arcsinh(s)
'
Sub bArcSinh (s$, out$)
'asinh(x) = Log(x + Sqr(x * x + 1))
out$ = zero$
End Sub
'out = arctan(s)
'
Sub bArcTan (s$, out$)
Dim t$, tfac$, fac$, d$, z$
Dim olddigits%, flag%
olddigits% = digits%
digits% = digits% + 5
t$ = s$: bAbs t$
If bIsMore%(t$, one$) Then GoSub aTan2 Else GoSub aTan1
digits% = olddigits%
bTrimDig out$
Exit Sub
'both routines are slow when |x|=1!
'for -1 < x < 1
' x^3 x^5 x^7
'arctan(x) = x - --- + --- - --- + ...
' 3 5 7
aTan1:
t$ = s$
z$ = t$
bMul z$, t$, tfac$
bTrimDig tfac$
out$ = t$
fac$ = three$
flag% = False
Do
z$ = t$
bMul z$, tfac$, t$
bTrimDig t$
bDiv t$, fac$, d$
bTrimDig d$
If bIsZero%(d$) Then Exit Do
If flag% Then
z$ = out$
bAdd z$, d$, out$
Else
z$ = out$
bSub z$, d$, out$
End If
flag% = Not flag%
bInc fac$, 2
Loop
Return
'x < -1 or x > 1
' ã 1 1 1 1
'arctan(x) = (+/-) - - - + ---- - ---- + ---- - ...
' 2 x 3x^3 5x^5 7x^7
aTan2:
t$ = s$
z$ = t$
bMul z$, t$, tfac$
bTrimDig tfac$
out$ = t$
bInv out$
bNeg out$
fac$ = three$
flag% = True
Do
z$ = t$
bMul z$, tfac$, t$
bTrimDig t$
bMul t$, fac$, d$
bTrimDig d$
bInv d$
bTrimDig d$
If bIsZero%(d$) Then Exit Do
If flag% Then
z$ = out$
bAdd z$, d$, out$
Else
z$ = out$
bSub z$, d$, out$
End If
flag% = Not flag%
bInc fac$, 2
Loop
digits% = olddigits%
bPi t$
z$ = t$
bDiv z$, two$, t$
If bIsNeg%(s$) Then bNeg t$
z$ = out$
bAdd z$, t$, out$
Return
End Sub
'out = arctanh(s)
'
Sub bArcTanh (s$, out$)
'atanh(x) = Log((1 + x) / (1 - x)) / 2
out$ = zero$
End Sub
'Convert s$ FROM base base1% TO base base2%, including decimals to digits% places.
's$ is modified in place. No errors for illegal digits, eg 161 base 2 is
'treated as (1*2^2)+(6*2^1)+(1*2^0) even though the "6" is wrong. Bases
'to 16 are formed with 1..F, but larger bases are formed with digit groups
'separated by commas, eg 6,6,@100=(6*100^1+6*100^0)=606. Bases ok to 32K!
'Appends "@n" to end of string if base2%<>10, which GetArg() will recognize.
'Slow because of divisions, but the decimals are fun.
'
Sub bBase (s$, base1%, base2%)
Dim b1$, b2$, whole$, dec$, n$, r$, t$, tn$, dig$, z$
Dim negflag%, digmask%, groupflag%, dpt%
Dim i%, j%, last%, nn%
If base1% < 2 Or base2% < 2 Then s$ = Error$: Exit Sub
If base1% = base2% Then Exit Sub
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2): negflag% = True
b1$ = LTrim$(Str$(base1%))
b2$ = LTrim$(Str$(base2%))
digmask% = Len(LTrim$(Str$(base2% - 1)))
'convert FROM base base1%
dpt% = InStr(s$, dp$)
If dpt% = 0 Then dpt% = Len(s$) + 1
'if base 10, then we're done
If base1% = 10 Then
whole$ = Left$(s$, dpt% - 1)
dec$ = Mid$(s$, dpt%)
Else
'else figure whole part
n$ = Left$(s$, dpt% - 1)
GoSub bbConvertString
whole$ = n$
'figure decimal part
n$ = Mid$(s$, dpt% + 1)
If Len(n$) Then
GoSub bbConvertString
bPowerInt b1$, LTrim$(Str$(last%)), t$
bDiv n$, t$, dec$
End If
End If
'convert TO base base2%
'if base 10, then we're done
If base2% = 10 Then
bAdd whole$, dec$, s$
Else
s$ = ""
'figure whole part
Do
z$ = whole$
bDivIntMod z$, b2$, whole$, n$
nn% = Val(n$)
GoSub bbGetDigit
s$ = dig$ + s$
Loop Until whole$ = zero$
'figure decimal part
If Len(dec$) Then
s$ = s$ + dp$
r$ = one$
Do
z$ = r$
bMul z$, b2$, r$
bMul dec$, r$, n$
bInt n$
nn% = Val(n$)
GoSub bbGetDigit
s$ = s$ + dig$
z$ = n$
bDiv z$, r$, n$
z$ = n$
bSub dec$, z$, n$
dec$ = n$
Loop Until dec$ = zero$ Or Len(s$) > digits%
End If
End If
If Len(s$) = 0 Then s$ = zero$
If s$ <> zero$ Then
If base2% <> 10 Then s$ = s$ + " " + basechr$ + b2$
If negflag% Then s$ = neg$ + s$
End If
Exit Sub
'receive whole number n$ in base base1% and return it in base 10
bbConvertString:
tn$ = zero$
last% = Len(n$)
groupflag% = (base1% > 16) Or (InStr(n$, basesep$) > 0)
i% = 1
Do
If i% > last% Then Exit Do
If groupflag% Then
'digits in groups, eg 6,6,b100 = 6*10^1 + 6*10^0
j% = InStr(i%, n$, basesep$)
If j% = 0 Then j% = last%
nn% = Val(Mid$(n$, i%, j%))
i% = j% + 1
Else
'digits 1 by 1, eg 123 or ABC
nn% = Asc(Mid$(n$, i%, 1))
i% = i% + 1
Select Case nn%
Case 48 To 57: nn% = nn% - 48
Case 65 To 90: nn% = nn% - 55
Case Else: nn% = 0
End Select
End If
'skip illegal digits?
'IF nn% >= base1% THEN nn% = 0
t$ = tn$
bMul t$, b1$, tn$
bInc tn$, nn%
Loop
n$ = tn$
Return
'return base base2% digit or group for nn%
bbGetDigit:
If base2% > 16 Then
dig$ = LTrim$(Str$(nn%))
dig$ = String$(digmask% - Len(dig$), zero$) + dig$ + basesep$
ElseIf nn% < 10 Then
dig$ = Chr$(nn% + asc0)
Else
dig$ = Chr$(nn% + 55)
End If
Return
End Sub
'check if s$ is in some other number base and convert it to base 10.
'
Sub bBase10 (s$)
Dim numbase%
bBaseCheck s$, numbase%
If numbase% Then bBase s$, numbase%, 10
End Sub
'return number and base from a string, or 0 if no base (=base 10).
'eg 100b2 returns s$="100" and numbase%=2
'
Sub bBaseCheck (s$, numbase%)
Dim i%, n%
If bIsBase%(s$) Then
'deal with 6bb16 (=6B hex)
For i% = Len(s$) To 1 Step -1
If UCase$(Mid$(s$, i%, 1)) = basechr$ Then n% = i%: Exit For
Next i%
numbase% = Val(Mid$(s$, n% + 1))
s$ = Left$(s$, n% - 1)
Else
numbase% = False
End If
End Sub
'Strip a number to "standard form" with no leading or trailing 0s and no
'final "." All routines should return all arguments in this form.
'
Sub bClean (s$)
Dim sign%
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2): sign% = True
bStripZero s$
If InStr(s$, dp$) Then bStripTail s$
If sign% And s$ <> zero$ Then s$ = neg$ + s$
End Sub
'clean up a number for display so .6 -> 0.6
'
Sub bCleanShow (s$)
bClean s$
If Left$(s$, 2) = "-." Then
s$ = "-0." + Mid$(s$, 3)
ElseIf Left$(s$, 1) = dp$ Then
s$ = zero$ + s$
End If
End Sub
'Compare two numbers using fast string compares. This can screw up since it
'uses string length, eg it reports "8"<"8." so watch out. The practice in
'these routines is no leading or trailing 0s and no final "." See bClean().
'
'Return 1 if s1 > s2
' 0 if s1 = s2
' -1 if s1 < s2
'
Function bComp% (s1$, s2$)
Dim s1flag%, s2flag%, sign1%, sign2%
Dim dp1%, dp2%, arg%
'kludge to fix 0<.1
If Left$(s1$, 1) = dp$ Then s1$ = zero$ + s1$: s1flag% = True
If Left$(s2$, 1) = dp$ Then s2$ = zero$ + s2$: s2flag% = True
sign1% = (Left$(s1$, 1) = neg$)
sign2% = (Left$(s2$, 1) = neg$)
dp1% = InStr(s1$, dp$): If dp1% = 0 Then dp1% = Len(s1$) + 1
dp2% = InStr(s2$, dp$): If dp2% = 0 Then dp2% = Len(s2$) + 1
If sign1% <> sign2% Then
If sign1% Then arg% = -1 Else arg% = 1
ElseIf s1$ = s2$ Then
arg% = 0
ElseIf (dp1% < dp2%) Or ((dp1% = dp2%) And (s1$ < s2$)) Then
arg% = -1
Else
arg% = 1
End If
If sign1% And sign2% Then arg% = -arg%
If s1flag% Then s1$ = Mid$(s1$, 2)
If s2flag% Then s2$ = Mid$(s2$, 2)
bComp% = arg%
End Function
'out = cos(x)
'
Sub bCos (s$, out$)
Dim t$, tfac$, fac$, z$
Dim nfac&
Dim olddigits%, flag%
' x^2 x^4 x^6
'cos(x) = 1 - --- + --- - --- + ...
' 2! 4! 6!
t$ = s$
bNormRad t$
olddigits% = digits%
digits% = digits% + 5
z$ = t$
bMul t$, z$, tfac$
bTrimDig tfac$
t$ = one$
nfac& = 2
fac$ = two$
out$ = t$
flag% = False
Do
z$ = t$
bMul z$, tfac$, t$
bTrimDig t$
z$ = t$
bDiv z$, fac$, t$
bTrimDig t$
If bIsZero%(t$) Then Exit Do
If flag% Then
z$ = out$
bAdd z$, t$, out$
Else
z$ = out$
bSub z$, t$, out$
End If
flag% = Not flag%
fac$ = LTrim$(Str$((nfac& + 1&) * (nfac& + 2&)))
nfac& = nfac& + 2&
Loop
digits% = olddigits%
bTrimDig out$
End Sub
'out = cosh(x)
'
Sub bCosh (s$, out$)
'cosh(x) = (Exp(x) + Exp(-x)) / 2
out$ = zero$
End Sub
'out = cot(s)
'
Sub bCot (s$, out$)
Dim t$, tc$, ts$
'cot=cos/sin
t$ = s$
bNormRad t$
bSin t$, ts$
If bIsZero%(ts$) Then
out$ = Error$
Else
bCos t$, tc$
bDiv tc$, ts$, out$
End If
End Sub
'out = coth(s)
'
Sub bCoth (s$, out$)
'coth(x) = (Exp(x) + Exp(-x)) / (Exp(x) - Exp(-x))
out$ = zero$
End Sub
'out = csc(s)
'
Sub bCsc (s$, out$)
'csc(s)=1/sin(s)
bSin s$, out$
If bIsZero%(out$) Then
out$ = Error$
Else
bInv out$
End If
End Sub
'out = csch(s)
'
Sub bCsch (s$, out$)
'csch(x) = 2 / (Exp(x) - Exp(-x))
out$ = zero$
End Sub
'return decimal part of number (or 0)
'
Sub bDec (s$)
Dim n%
n% = InStr(s$, dp$)
If n% Then s$ = Mid$(s$, n%) Else s$ = zero$
End Sub
'degrees to radians, rad=deg*pi/180
'
Sub bDegToRad (s$)
Dim t$, z$
bPi t$
z$ = t$
bDiv z$, "180", t$
z$ = s$
bMod z$, "360", s$
z$ = s$
bMul t$, z$, s$
End Sub
'out = s1 / s2
'
Sub bDiv (s1$, s2$, out$)
Dim t$
Dim slog1%, sign1%, slog2%, sign2%
Dim outlog%, outsign%, olddigits%
'strip divisor
t$ = s2$
bLogGet t$, slog2%, sign2%, True
'divide by zero?
If t$ = zero$ Then
out$ = Error$
'do powers of 10 with shifts
ElseIf t$ = one$ Then
out$ = s1$
sign1% = bSign%(out$)
If sign1% = negative Then bAbs out$
bShift out$, -slog2%
If sign1% <> sign2% Then bNeg out$
'the hard way
Else
'strip all
s2$ = t$: t$ = ""
bLogGet s1$, slog1%, sign1%, True
'figure decimal point and sign of answer
outlog% = slog1% + bLogDp%(s2$, slog2%)
If sign1% <> sign2% Then outsign% = negative Else outsign% = positive
'bump digits past leading zeros and always show whole quotient
olddigits% = digits%
digits% = digits% + Len(s2$)
If digits% < outlog% + 1 Then digits% = outlog% + 1
'do it, ignore remainder
If Len(s2$) <= maxlongdig Then bDivLong s1$, s2$, out$, t$ Else bDivChar s1$, s2$, out$, t$
'clean up
bLogPut out$, outlog%, outsign%
bLogPut s1$, slog1%, sign1%
bLogPut s2$, slog2%, sign2%
digits% = olddigits%
End If
End Sub
'out = s1 / s2 using character algorithm, digit by digit, slow but honest.
's1$ and s2$ must be stripped first, no decimals.
'
Sub bDivChar (s1$, s2$, quotient$, remainder$)
Dim last1%, last2%, ldvd%, lrem%, dig%, borrow%
Dim i%, j%, n%
Dim dvd$
last1% = Len(s1$) 'length of the dividend
last2% = Len(s2$) 'length of the divisor
quotient$ = ""
remainder$ = ""
For i% = 1 To digits%
'get next digit of dividend or zero$ if past end
If i% <= last1% Then
dvd$ = remainder$ + Mid$(s1$, i%, 1)
Else
dvd$ = remainder$ + zero$
End If
'if dividend < divisor then digit%=0 else have to calculate it.
'do fast compare using string operations. see bComp%()
bStripZero dvd$
ldvd% = Len(dvd$)
If (ldvd% < last2%) Or ((ldvd% = last2%) And (dvd$ < s2$)) Then
'divisor is bigger, so digit is 0, easy!
dig% = 0
remainder$ = dvd$
Else
'dividend is bigger, but no more than 9 times bigger.
'subtract divisor until we get remainder less than divisor.
'time hog, average is 5 tries through j% loop. There's a better way.
For dig% = 1 To 9
remainder$ = ""
borrow% = 0
For j% = 0 To ldvd% - 1
n% = last2% - j%
If n% < 1 Then n% = 0 Else n% = Val(Mid$(s2$, n%, 1))
n% = Val(Mid$(dvd$, ldvd% - j%, 1)) - n% - borrow%
If n% >= 0 Then borrow% = 0 Else borrow% = 1: n% = n% + 10
remainder$ = Chr$(asc0 + n%) + remainder$
Next j%
'if remainder < divisor then exit
bStripZero remainder$
lrem% = Len(remainder$)
If (lrem% < last2%) Or ((lrem% = last2%) And (remainder$ < s2$)) Then Exit For
dvd$ = remainder$
ldvd% = Len(dvd$)
Next dig%
End If
quotient$ = quotient$ + Chr$(asc0 + dig%)
Next i%
End Sub
'out = integer part of s1 / s2
'
Sub bDivInt (s1$, s2$, out$)
Dim t$
bDivIntMod s1$, s2$, out$, t$
End Sub
's1 / s2 = integer and remainder (s1 = s2 * q + r)
'bDivInt() and bDivMod() call this.
'
Sub bDivIntMod (s1$, s2$, quotient$, remainder$)
Dim slog1%, sign1%, slog2%, sign2%
Dim olddigits%, outlog%, outsign%
olddigits% = digits%
'strip the numbers, set flag false to NOT trim zeros, slower but needed
bLogGet s2$, slog2%, sign2%, False
If s2$ = zero$ Then quotient$ = Error$: remainder$ = Error$: Exit Sub
bLogGet s1$, slog1%, sign1%, False
'figure decimal point and sign of answer
outlog% = slog1% + bLogDp%(s2$, slog2%)
If sign1% <> sign2% Then outsign% = negative Else outsign% = positive
'a trick: figure the decimal and only find that many digits
digits% = outlog% + 1
'send the work out
If Len(s2$) <= maxlongdig Then bDivLong s1$, s2$, quotient$, remainder$ Else bDivChar s1$, s2$, quotient$, remainder$
'clean up
bLogPut s1$, slog1%, sign1%
bLogPut s2$, slog2%, sign2%
bClean quotient$
bClean remainder$
If sign1% <> sign2% Then bNeg quotient$
digits% = olddigits%
End Sub
'out = s1 / s2 using fast long-integer algorithm. s2$ must be <= 8 digits.
's1$ and s2$ must be stripped first, no decimals.
'
Sub bDivLong (s1$, s2$, quotient$, remainder$)
Dim rmdr&, dividend&, divisor&
Dim dig%, i%
quotient$ = ""
rmdr& = 0
divisor& = Val(s2$)
For i% = 1 To digits%
dividend& = rmdr& * 10& + Val(Mid$(s1$, i%, 1))
dig% = dividend& \ divisor&
quotient$ = quotient$ + Chr$(asc0 + dig%)
rmdr& = dividend& - dig% * divisor&
Next i%
If Len(quotient$) = 0 Then quotient$ = zero$
remainder$ = LTrim$(Str$(rmdr&))
End Sub
'Return an ellipsis... repeat just the decimal or whole string if no decimal.
'Stop at digits% length. Handy for big test numbers.
'
Sub bDot (s$, out$)
Dim t$
Dim n%
n% = InStr(s$, dp$)
If n% Then t$ = Mid$(s$, n% + 1) Else t$ = s$
out$ = s$
Do
out$ = out$ + t$
Loop Until Len(out$) >= digits%
out$ = Left$(out$, digits%)
End Sub
'out = e^s
'
Sub bExp (s$, out$)
Dim t$, fac$, z$
Dim olddigits%, eflag%
olddigits% = digits%
'if e^1, see if we already have it.
If bIsEqual%(s$, one$) Then
bMemory t$, emem, memget
If digits% <= Len(t$) - 1 Then out$ = t$: bTrimDig out$: Exit Sub
eflag% = True
End If
digits% = digits% + 5
'e^x = 1 + x + x^2/2! + x^3/3! + ...
out$ = one$
t$ = one$
fac$ = one$
Do
z$ = t$
bMul z$, s$, t$
bTrimDig t$
z$ = t$
bDiv z$, fac$, t$
bTrimDig t$
If bIsZero%(t$) Then Exit Do
z$ = out$
bAdd z$, t$, out$
bInc fac$, 1
Loop
digits% = olddigits%
bTrimDig out$
If eflag% Then bMemory out$, emem, memput
End Sub
'out = s!
'
Sub bFactorial (s$, out$)
Dim t$, mul$, z$
Dim num&, product&
Dim last%, i%
bInt s$
bAbs s$
If bIsZero%(s$) Then out$ = one$: Exit Sub '0!=1 really!
If Len(s$) <= maxlongdig Then GoSub bfLong Else GoSub bfChar
Exit Sub
bfChar:
'start the easy way to 99999999! then finish. This could take weeks!
t$ = s$
s$ = String$(maxlongdig, "9")
GoSub bfLong
bSwapString s$, t$
If out$ = abortmsg$ Then Return
Do Until t$ = s$
bInc t$, 1
z$ = out$
bMul z$, t$, out$
Loop
Return
bfLong:
'this is the long-integer multiply slightly customized
out$ = one$
For num& = 2& To CLng(Val(s$))
mul$ = out$
last% = Len(mul$)
out$ = Space$(last%)
product& = 0
For i% = last% To 1 Step -1
product& = product& + Val(Mid$(mul$, i%, 1)) * num&
Mid$(out$, i%, 1) = Chr$(asc0 + CInt(product& Mod 10&))
product& = product& \ 10&
Next i%
If product& Then out$ = LTrim$(Str$(product&)) + out$
Next num&
Return
End Sub
'out = GCD(s1,s2)
'figure Greatest Common Divisor using Euclid's Algorithm
'Byte, Jan 86, p. 397
'
Sub bGCD (s1$, s2$, out$)
Dim div$, dvd$, t$
'work with copies
div$ = s1$
dvd$ = s2$
If bIsMore%(div$, dvd$) Then bSwapString div$, dvd$
Do Until bIsZero%(div$)
bMod dvd$, div$, t$
dvd$ = div$
div$ = t$
Loop
out$ = dvd$
End Sub
's += num%
'Fast increment s$ by num% for internal use, but not quite primetime.
's$ must be positive (but decimals are ok). It's ok to use negative num%
'for decrements but if result goes negative it returns "0" with no warning.
'num% must be an integer +-32k.
'
Sub bInc (s$, num%)
Dim dig%, n%, borrow%
If num% = 0 Then Exit Sub
dig% = InStr(s$, dp$)
If dig% Then dig% = dig% - 1 Else dig% = Len(s$)
n% = num%
If n% > 0 Then 'increment (n>0)
Do While n%
If dig% < 1 Then
s$ = LTrim$(Str$(n%)) + s$
n% = 0
Else
n% = n% + Val(Mid$(s$, dig%, 1))
Mid$(s$, dig%, 1) = Chr$(asc0 + (n% Mod 10))
n% = n% \ 10
dig% = dig% - 1
End If
Loop
Else 'decrement (n<0)
n% = -n%
Do While n%
If dig% < 1 Then s$ = zero$: Exit Do
borrow% = 0
n% = Val(Mid$(s$, dig%, 1)) - n%
Do While n% < 0
n% = n% + 10: borrow% = borrow% + 1
Loop
Mid$(s$, dig%, 1) = Chr$(asc0 + n%)
n% = borrow%
dig% = dig% - 1
Loop
End If
bStripZero s$
End Sub
'Initialize b_routines, set globals, etc
'
Sub bInit ()
Dim i%
'a few defaults
'digits% = defaultdigits
errormsg$ = "error"
abortmsg$ = "abort"
'clear memory
zstack% = 0
For i% = 0 To maxmem
bmem$(i%) = zero$
Next i%
For i% = 1 To maxstack
zmem$(i%) = zero$
Next i%
'useful constants
cname$(pimem) = "pi": bmem$(pimem) = "3.14159265358979323846264338327"
cname$(pi2mem) = "2pi": bmem$(pi2mem) = "6.28318530717958647692528676654"
cname$(emem) = "e": bmem$(emem) = "2.71828182845904523536028747135"
cname$(phimem) = "phi": bmem$(phimem) = "1.61803398874989484820458683436"
cname$(ln10mem) = "ln(10)": bmem$(ln10mem) = "2.30258509299404568401799145468"
cname$(ln2mem) = "ln(2)": bmem$(ln2mem) = ".693147180559945309417232121458"
bncpath$ = "" 'path for files (or current dir if null)
prmcntfile$ = "BNPRMCNT.DAT" 'prime count table
' LoadPrimeTable
End Sub
's = int(s)
'truncate towards 0 like Basic FIX: bInt(-3.3) returns -3.
'
Sub bInt (s$)
Dim n%
n% = InStr(s$, dp$)
If n% Then
If n% = 1 Then s$ = zero$ Else s$ = Left$(s$, n% - 1)
If s$ = neg$ Or Left$(s$, 2) = "-." Then s$ = zero$
End If
End Sub
'return s1\s2 if s2 is divisor of s1, else return 0.
'
Sub bIntDiv (s1$, s2$, out$)
Dim t$
bDivIntMod s1$, s2$, out$, t$
If t$ <> zero$ Then out$ = zero$
End Sub
's = 1/s
'
Sub bInv (s$)
Dim z$
z$ = s$
bDiv one$, z$, s$
End Sub
'return false or the position of the "B" if s$ is in another number base,
'eg 123b5 and abcb16 return 4.
'
Function bIsBase% (s$)
bIsBase% = InStr(UCase$(s$), basechr$)
End Function
'return true if s1 divides s2
'
Function bIsDiv% (s1$, s2$)
Dim t$
bMod s2$, s1$, t$
bIsDiv% = (t$ = zero$)
End Function
'return true if s1 = s2
'
Function bIsEqual% (s1$, s2$)
bIsEqual% = (s1$ = s2$)
End Function
'return true if s$ is even, no decimals!
'
Function bIsEven% (s$)
bIsEven% = (Val(Right$(s$, 1)) Mod 2 = 0)
End Function
'return true if s in an integer (no decimal point).
'
Function bIsInteger% (s$)
bIsInteger% = (InStr(s$, dp$) = 0)
End Function
'return true if s1 < s2
'
Function bIsLess% (s1$, s2$)
bIsLess% = (bComp%(s1$, s2$) = -1)
End Function
'return true if s1 > s2
'
Function bIsMore% (s1$, s2$)
bIsMore% = (bComp%(s1$, s2$) = 1)
End Function
'return true if s is negative
'
Function bIsNeg% (s$)
bIsNeg% = (Left$(s$, 1) = neg$)
End Function
Function bIsNotZero% (s$)
Dim flag%, i%
flag% = False
For i% = 1 To Len(s$)
If InStr("0-. ", Mid$(s$, i%, 1)) = False Then flag% = True: Exit For
Next i%
bIsNotZero% = flag%
End Function
'return true if odd
'
Function bIsOdd% (s$)
bIsOdd% = (Val(Right$(s$, 1)) Mod 2 <> 0)
End Function
'return true if s is prime
'
Function bIsPrime% (s$)
bIsPrime% = (bPrmDiv$(s$, False) = s$)
End Function
's is pseudoprime to base b if (b,s)=1 and b^(s-1)=1 (mod s). Integers only!
'
Function bIsPseudoPrime% (s$, bas$)
Dim t$, smin$
Dim flag%
flag% = False
If bIsRelPrime%(s$, bas$) Then
smin$ = s$: bInc smin$, -1
bModPower bas$, smin$, s$, t$
flag% = (t$ = one$)
End If
bIsPseudoPrime% = flag%
End Function
'return true if s1 and s2 are relatively prime, ie share no factor
'
Function bIsRelPrime% (s1$, s2$)
Dim gcd$
bGCD s1$, s2$, gcd$
bIsRelPrime% = bIsEqual%(gcd$, one$)
End Function
'Return true if s$ is zero$ or null, s$ needn't be clean.
'
Function bIsZero% (s$)
Dim flag%, i%
flag% = True
For i% = 1 To Len(s$)
If InStr("0-. ", Mid$(s$, i%, 1)) = False Then flag% = False: Exit For
Next i%
bIsZero% = flag%
End Function
'out = LCM(s1,s2)
'figure Least Common Multiple using Euclid's Algorithm for GCD.
'LCM (a,b) = (a*b) / GCD(a,b)
'Byte, Jan 86, p. 397
'
Sub bLcm (s1$, s2$, out$)
Dim product$, gcd$
bMul s1$, s2$, product$
bGCD s1$, s2$, gcd$
bDivInt product$, gcd$, out$
End Sub
'out = ln(s), natural logarithm
'
Sub bLn (s$, out$)
Dim t$, d$, tfac$, fac$, z$, w$
Dim ln10flag%, ln2flag%, olddigits%, flag%
If Not bIsMore%(s$, zero$) Then out$ = Error$: Exit Sub
If bIsEqual%(s$, "10") Then
bMemory t$, ln10mem, memget
If digits% <= Len(t$) - 1 Then out$ = t$: bTrimDig out$: Exit Sub
ln10flag% = True
ElseIf bIsEqual%(s$, "2") Then
bMemory t$, ln2mem, memget
If digits% <= Len(t$) - 1 Then out$ = t$: bTrimDig out$: Exit Sub
ln2flag% = True
End If
olddigits% = digits%
digits% = digits% + 5
If bIsLess%(s$, "1.6") Then GoSub LnSeries2 Else GoSub LnSeries1
digits% = olddigits%
bTrimDig out$
If ln10flag% Then
bMemory out$, ln10mem, memput
ElseIf ln2flag% Then
bMemory out$, ln2mem, memput
End If
Exit Sub
' x-1 1 x-1 1 x-1
'ln(x) = 2 * [ --- + - (---)^3 + - (---)^5 + ... ] {x > 0}
' x+1 3 x+1 5 x+1
'faster for x > 1.6
LnSeries1:
t$ = s$: bInc t$, -1
d$ = s$: bInc d$, 1
bDiv t$, d$, out$
t$ = out$
z$ = t$
w$ = t$
bMul z$, w$, tfac$
bTrimDig tfac$
fac$ = three$
Do
z$ = t$
bMul z$, tfac$, t$
bTrimDig t$
bDiv t$, fac$, d$
bTrimDig d$
If bIsZero%(d$) Then Exit Do
z$ = out$
bAdd z$, d$, out$
bInc fac$, 2
Loop
z$ = out$
bMul z$, two$, out$
Return
' 1 1
'ln(x) = (x-1) - - (x-1)^2 + - (x-1)^3 - ... {2 >= x > 0}
' 2 3
'faster for x < 1.6
LnSeries2:
bSub s$, one$, t$
tfac$ = t$
out$ = t$
fac$ = two$
flag% = False
Do
z$ = t$
bMul z$, tfac$, t$
bTrimDig t$
bDiv t$, fac$, d$
bTrimDig d$
If bIsZero%(d$) Then Exit Do
If flag% Then
z$ = out$
bAdd z$, d$, out$
Else
z$ = out$
bSub z$, d$, out$
End If
flag% = Not flag%
bInc fac$, 1
Loop
Return
End Sub
'out = log(s1) base s2, or ln(s1) if s2=0
'
Sub bLog (s1$, s2$, out$)
Dim t$, z$
'log(s) base(n) = ln(s) / ln(n)
If bIsEqual%(s2$, "-1") Then
bExp s1$, out$
ElseIf bIsNeg%(s2$) Then
out$ = Error$
Else
bLn s1$, out$
If Not bIsZero%(s2$) Then
bLn s2$, t$
z$ = out$
bDiv z$, t$, out$
End If
End If
End Sub
'Take whole number and log from bLogGet() and return number of decimal
'places in the expanded number; OR take string and number of decimal points
'desired and return the log. It works both ways.
'
Function bLogDp% (s$, logdp%)
bLogDp% = Len(s$) - 1 - logdp%
End Function
'Strip s$ to whole number and base 10 integer logarithm and sign. Decimal
'point is implied after the first digit, and slog% counts places left or
'right. bLogPut() reverses the process, and bLogDp() gives info on the
'decimals. Tricky, but it works and simplifies dividing and multipling.
'
Sub bLogGet (s$, slog%, sign%, zeroflag%)
Dim dpt%, n%
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2): sign% = negative Else sign% = positive
bStripZero s$
dpt% = InStr(s$, dp$)
Select Case dpt%
Case 0
slog% = Len(s$) - 1
Case 1
n% = dpt% + 1
Do While Mid$(s$, n%, 1) = zero$
n% = n% + 1
Loop
s$ = Mid$(s$, n%)
slog% = dpt% - n%
Case Else
s$ = Left$(s$, dpt% - 1) + Mid$(s$, dpt% + 1)
slog% = dpt% - 2
End Select
'remove trailing 0's if zeroflag%
If zeroflag% Then bStripTail s$
End Sub
'Restore a number from the integer and log figured in bLogGet(). s$ is taken
'as a number with the decimal after first digit, and decimal is moved slog%
'places left or right, adding 0s as required. Called by bDiv() and bMul().
'
Sub bLogPut (s$, slog%, sign%)
Dim last%
last% = Len(s$)
If Len(s$) = 0 Or s$ = zero$ Then
s$ = zero$
ElseIf slog% < 0 Then
s$ = dp$ + String$(-slog% - 1, zero$) + s$
ElseIf slog% > last% - 1 Then
s$ = s$ + String$(slog% - last% + 1, zero$) + dp$
Else
s$ = Left$(s$, slog% + 1) + dp$ + Mid$(s$, slog% + 2)
End If
bClean s$
If sign% = negative Then s$ = neg$ + s$
End Sub
'return the largest of two integers
'
Function bMaxInt% (n1%, n2%)
If n1% >= n2% Then bMaxInt% = n1% Else bMaxInt% = n2%
End Function
'Put or Get a number string in a cell. Only 64k in PDS, much less in QB,
'beep for overflow.
'
Sub bMemory (s$, memcell%, memop%)
Dim i%
'in range?
If memcell% < 0 Or memcell% > maxmem Then Exit Sub
Select Case memop%
Case memget: s$ = bmem$(memcell%)
Case memput
'check for enough memory?
bmem$(memcell%) = s$
Case memclr: For i% = 0 To 9: bmem$(i%) = "": Next i%
End Select
End Sub
'Perform Miller test for a number and base, return true if s may be prime.
' Schneier, Applied Cryptography, p.260
' Robbins, Beginning Number Theory, p.262
'
Function bMillerTest% (s$, bas$)
Dim t$, z$, rmd$, w$, y$
Dim j%, flag%
Static lasts$, smin$, m$, k%
If bIsEven%(s$) Then bMillerTest% = False: Exit Function
'figure {k,m} so s = 2^k * m + 1. Save results for next call.
If s$ <> lasts$ Then
smin$ = s$
bInc smin$, -1
m$ = smin$
k% = 0
Do
t$ = m$
bDivIntMod t$, two$, m$, rmd$
If rmd$ = zero$ Then k% = k% + 1 Else m$ = t$: Exit Do
Loop
End If
bModPower bas$, m$, s$, z$
If z$ = one$ Or z$ = smin$ Then
flag% = True
Else
flag% = False
For j% = 1 To k% - 1
w$ = z$
y$ = z$
bMul w$, y$, z$
w$ = z$
bMod w$, s$, z$
If z$ = smin$ Then flag% = True: Exit For
Next j%
End If
bMillerTest% = flag%
End Function
'out = s1 mod s2
'remainder after division, works for non-integers, but doesn't mean much.
'
Sub bMod (s1$, s2$, out$)
Dim t$
bDivIntMod s1$, s2$, t$, out$
End Sub
'out = s1^-1 (mod s2)
'Find inverse mod a number with Extended Euclid Algorithm.
'Given a and n, find x such that a*x = 1 (mod n).
'Answer exists only if a and n are relatively prime, else return 0.
'
Sub bModInv (s1$, s2$, out$)
Dim g0$, g1$, g2$, v0$, v1$, v2$, y$, t$, z$
If Not bIsRelPrime%(s1$, s2$) Then out$ = zero$: Exit Sub
g0$ = s2$: g1$ = s1$
v0$ = zero$: v1$ = one$
Do Until bIsZero%(g1$)
bDivInt g0$, g1$, y$
bMul y$, g1$, t$
bSub g0$, t$, g2$
bMul y$, v1$, t$
bSub v0$, t$, v2$
g0$ = g1$: g1$ = g2$
v0$ = v1$: v1$ = v2$
Loop
out$ = v0$
If bIsNeg%(out$) Then
z$ = out$
bAdd z$, s2$, out$
End If
End Sub
'out = (s1 ^ s2) mod s3
'
Sub bModPower (s1$, s2$, s3$, out$)
'Use variation of "Russian Peasant Method" to figure m=(c^d) mod n.
'Byte, Jan 83, p.206.
'test value: (71611947 ^ 63196467) mod 94815109 = 776582
'm=1
'do
' if d is odd then m=(m*c) mod n
' c=(c*c) mod n
' d=int(d/2)
'loop while d>0
'm is the answer
Dim c$, d$, z$, w$
Static n$ 'remember modulus for next call
'positive numbers only, modulus must be >1! Find mod inverse if s2=-1.
out$ = errormsg$
If Len(s3$) Then n$ = s3$
If bIsNeg%(s1$) Or bIsNeg%(n$) Then Exit Sub
If bIsNeg%(s2$) Then
If bIsEqual%(s2$, "-1") Then bModInv s1$, n$, out$
Exit Sub
End If
c$ = s1$
d$ = s2$
out$ = one$
Do
If bIsOdd%(d$) Then
z$ = out$
bMul z$, c$, out$
z$ = out$
bMod z$, n$, out$
End If
z$ = c$
w$ = c$
bMul z$, w$, c$
z$ = c$
bMod z$, n$, c$
z$ = d$
bDivInt z$, two$, d$
Loop Until bIsZero%(d$)
End Sub
'out = s1 * s2
'
Sub bMul (s1$, s2$, out$)
Dim t$
Dim slog1%, sign1%, slog2%, sign2%, outdp%, outsign%, outlog%, swapflag%
'strip multiplier
t$ = s2$
bLogGet t$, slog2%, sign2%, True
'times 0
If t$ = zero$ Then
out$ = zero$
'do powers of 10 with shifts
ElseIf t$ = one$ Then
out$ = s1$
sign1% = bSign%(out$)
If sign1% = negative Then bAbs out$
bShift out$, slog2%
If sign1% <> sign2% Then bNeg out$
'the hard way
Else
'strip all
s2$ = t$: t$ = ""
bLogGet s1$, slog1%, sign1%, True
'figure decimal point and sign of answer
outdp% = bLogDp%(s1$, slog1%) + bLogDp%(s2$, slog2%)
If sign1% <> sign2% Then outsign% = negative Else outsign% = positive
'always multiply by the shorter number
If Len(s2$) > Len(s1$) Then bSwapString s1$, s2$: swapflag% = True
'do it
If Len(s2$) <= maxlongdig Then bMulLong s1$, s2$, out$ Else bMulChar s1$, s2$, out$
'clean up
outlog% = bLogDp%(out$, outdp%)
bLogPut out$, outlog%, outsign%
If swapflag% Then bSwapString s1$, s2$
bLogPut s1$, slog1%, sign1%
bLogPut s2$, slog2%, sign2%
End If
End Sub
'out = s1 * s2 using character algorithm, slow but honest. Whole numbers
'only. Inner loop is optimized and hard to understand, but it works.
'
Sub bMulChar (s1$, s2$, out$)
Dim last1%, last2%, last%
Dim i%, j%, k%, sj%, ej%
Dim product&
last1% = Len(s1$)
last2% = Len(s2$)
last% = last1% + last2%
out$ = Space$(last%)
product& = 0
For i% = 0 To last% - 1
k% = last1% - i%
sj% = 1 - k%: If sj% < 0 Then sj% = 0
ej% = last1% - k%: If ej% > last2% - 1 Then ej% = last2% - 1
For j% = sj% To ej%
product& = product& + Val(Mid$(s1$, k% + j%, 1)) * Val(Mid$(s2$, last2% - j%, 1))
Next j%
Mid$(out$, last% - i%, 1) = Chr$(asc0 + CInt(product& Mod 10&))
product& = product& \ 10&
Next i%
If product& Then out$ = LTrim$(Str$(product&)) + out$
End Sub
'out = s1 * s2 using fast long-integer algorithm. s2$ must be <= 8 digits.
's1$ and s2$ must be stripped first, whole numbers only.
'
Sub bMulLong (s1$, s2$, out$)
Dim last1%, i%
Dim s2val&, product&
last1% = Len(s1$)
s2val& = Val(s2$)
out$ = Space$(last1%)
For i% = last1% To 1 Step -1
product& = product& + Val(Mid$(s1$, i%, 1)) * s2val&
Mid$(out$, i%, 1) = Chr$(asc0 + CInt(product& Mod 10&))
product& = product& \ 10&
Next i%
If product& Then out$ = LTrim$(Str$(product&)) + out$
End Sub
'out = nCr, s1 things taken s2 at a time, order doesn't matter
'
Sub bnCr (s1$, s2$, out$)
' n! nPr
'nCr = -------- = ---
' r!(n-r)! r!
'nCr = nCn-r, so pick the smaller
Dim r$, t$, z$
bSub s1$, s2$, r$
If bIsMore%(r$, s2$) Then r$ = s2$
bnPr s1$, r$, t$
If t$ = errormsg$ Then Exit Sub
z$ = r$
bFactorial z$, r$
bDivInt t$, r$, out$
End Sub
's = -s
'
Sub bNeg (s$)
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2) Else s$ = neg$ + s$
End Sub
'Normalize s1 to range of +-{s2}
'
Sub bNorm (s1$, s2$)
Dim t$
Dim dpt%
t$ = s1$
bAbs t$
If Not bIsLess%(t$, s2$) Then
bDiv s1$, s2$, t$
dpt% = InStr(t$, dp$)
If dpt% = 0 Then
s1$ = zero$
Else
bMul s2$, Mid$(t$, dpt%), s1$
bTrimDig s1$
If bIsNeg%(t$) Then bNeg s1$
End If
End If
End Sub
'Normalize an angle in radians to +-2pi
'
Sub bNormRad (s$)
Dim pi2$
bPi2 pi2$
bNorm s$, pi2$
End Sub
'out = nPr, s1 things taken s2 at a time, order matters
'
Sub bnPr (s1$, s2$, out$)
' n!
'nPr = ------ = (n)*(n-1)*...*(n-r+1)
' (n-r)!
Dim t$, z$
bAbs s1$
bAbs s2$
If bIsMore%(s2$, s1$) Then out$ = errormsg$: Exit Sub
If bIsZero%(s2$) Then out$ = one$: Exit Sub
bSub s1$, s2$, out$
bInc out$, 1
t$ = out$
Do Until t$ = s1$
bInc t$, 1
z$ = out$
bMul t$, z$, out$
Loop
End Sub
'out = phi (Golden Ratio)
'
Sub bPhi (out$)
Dim t$
Dim olddigits%
olddigits% = digits%
'see if it's already in memory
bMemory t$, phimem, memget
If digits% <= Len(t$) - 1 Then
out$ = t$
bTrimDig out$
Exit Sub
End If
'else calculate it. Need to write this.
out$ = t$
End Sub
'pi with Machin's formula: pi= 16 arctan(1/5) - 4 arctan(1/239)
'
Sub bPi (out$)
Dim d$, k$, t$, tfac$, atan$, atan5$, atan239$, z$
Dim olddigits%, flag%
olddigits% = digits%
'see if it's already in memory
bMemory t$, pimem, memget
If digits% <= Len(t$) - 1 Then out$ = t$: bTrimDig out$: Exit Sub
'figure a bit more and truncate to get last place right
digits% = digits% + 5
t$ = five$: GoSub bpArctan: atan5$ = atan$
t$ = "239": GoSub bpArctan: atan239$ = atan$
bMul four$, atan5$, t$
bSub t$, atan239$, out$
digits% = olddigits%
bTrimDig out$
bMemory out$, pimem, memput
Exit Sub
'Machin's series 1 1 1
' 4*arctan(1/n) = { - - ----- + ----- - ... }
' n 3*n^3 5*n^5
bpArctan:
z$ = t$
bMul z$, t$, tfac$
z$ = t$
bMul z$, four$, t$
atan$ = zero$
k$ = one$
flag% = True
Do
z$ = t$
bDiv z$, tfac$, t$
bDiv t$, k$, d$
bTrimDig d$
If bIsZero%(d$) Then Exit Do
If flag% Then
z$ = atan$
bAdd z$, d$, atan$
Else
z$ = atan$
bSub z$, d$, atan$
End If
flag% = Not flag%
bInc k$, 2
Loop
Return
End Sub
'return s=2*pi, from memory if possible
'
Sub bPi2 (s$)
Dim z$
bMemory s$, pi2mem, memget
If digits% <= Len(s$) - 1 Then
bTrimDig s$
Else
bPi s$
z$ = s$
bMul z$, two$, s$
bMemory s$, pi2mem, memput
End If
End Sub
'out = s1 ^ s2, for real s2
'
Sub bPower (s1$, s2$, out$)
Dim z$
Dim invflag%
If bIsInteger%(s2$) Then
bPowerInt s1$, s2$, out$
Else
If bIsNeg%(s2$) Then bNeg s2$: invflag% = True
bLn s1$, out$
z$ = out$
bMul z$, s2$, out$
z$ = out$
bExp z$, out$
If invflag% Then bNeg s2$: bInv out$
End If
End Sub
'out = s1 ^ s2, for integer s2 only! (It truncates s2)
'Uses variation of "Russian Peasant Method".
'
Sub bPowerInt (s1$, s2$, out$)
Dim c$, d$, z$, w$
Dim invflag%
bInt s2$
If bIsZero%(s2$) Then out$ = one$: Exit Sub
If bIsNeg%(s2$) Then bNeg s2$: invflag% = True
c$ = s1$
d$ = s2$
out$ = one$
Do
If bIsOdd%(d$) Then
z$ = out$
bMul z$, c$, out$
End If
z$ = c$
w$ = c$
bMul z$, w$, c$
z$ = d$
bDivInt z$, two$, d$
Loop Until bIsZero%(d$)
If invflag% Then
bNeg s2$
z$ = out$
bDiv one$, z$, out$
End If
End Sub
'If pflag% then count primes to s and return count else return s_th prime.
'If dspcol% then show progress on current line starting with that column.
'Will go forever if pflag% and s not prime.
'
Function bPrmCount$ (s$, dspcol%, pflag%)
Dim cnt$, num$
Dim n&
Dim i%, dinc%
'deal with exceptions up front
Select Case s$
Case "0": cnt$ = zero$: num$ = zero$
Case "1": cnt$ = zero$: num$ = two$
Case "2": cnt$ = one$: num$ = three$
Case "3": cnt$ = two$: num$ = five$
Case Else
'if no prime table then start from scratch else cue into table
If maxprmcnt% = 0 Then
i% = 0
'pflag% true: s$ is prime, count to it and return count
ElseIf pflag% Then
If bIsMore%(s$, LTrim$(Str$(prmcnt&(maxprmcnt%)))) Then
i% = maxprmcnt%
Else
n& = Val(s$)
For i% = 1 To maxprmcnt%
If prmcnt&(i%) > n& Then Exit For
Next i%
i% = i% - 1
End If
'pflag% false: s$ is the count, return that prime
Else
If bIsMore%(s$, LTrim$(Str$(maxprmcnt% * 1000&))) Then
i% = maxprmcnt%
Else
i% = Val(s$) \ 1000
End If
End If
'get start values
If i% = 0 Then
num$ = five$: cnt$ = three$
Else
num$ = LTrim$(Str$(prmcnt&(i%)))
cnt$ = LTrim$(Str$(i% * 1000&))
End If
If Val(num$) Mod 6 = 1 Then dinc% = 4 Else dinc% = 2
'finally to work
Do
If bIsPrime%(num$) Then
'IF dspcol% AND (RIGHT$(cnt$, 2) = "00") THEN PRINT "."; : IF POS(0) = 75 THEN LOCATE , dspcol%: PRINT TAB(80); : LOCATE , dspcol%
If pflag% Then
If num$ = s$ Then Exit Do
Else
If cnt$ = s$ Then Exit Do
End If
bInc cnt$, 1
End If
bInc num$, dinc%
dinc% = 6 - dinc%
Loop
End Select
If pflag% Then bPrmCount$ = cnt$ Else bPrmCount$ = num$
End Function
'Return smallest prime divisor or s$ if prime, no size limit, but slows
'down when s$>8 digits. This is strictly brute force and slow. Press <esc>
'to abort and it returns 0. If dspflag% then print (most) factors in
'lblTryNum of Factor frame, an inelegant kludge used by Factor(). A speed
'hit, but fun to watch.
'
Function bPrmDiv$ (s$, dspflag%)
Dim num$, sfac$, maxfac$, t$
Dim lfac&, lnum&, lmaxfac&, ldfac&
Dim i%, cnt%, flag%, dfac%
num$ = s$
bInt num$
bAbs num$
If Len(num$) <= maxlongdig Then GoSub bpdLong Else GoSub bpdChar
Exit Function
bpdChar:
'try some classic divisibility tests for small factors.
'Cf Gardner, Unexpected Hanging, p.160.
'by 2?
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = two$
' frmBncFactor.lblTryNum.Refresh
'End If
If Val(Right$(num$, 1)) Mod 2 = 0 Then bPrmDiv$ = two$: Return
'by 3?
'IF dspflag% THEN LOCATE , dspflag%: PRINT three$;
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = three$
' frmBncFactor.lblTryNum.Refresh
'End If
lfac& = 0
For i% = 1 To Len(num$)
lfac& = lfac& + Asc(Mid$(num$, i%, 1)) - asc0
Next i%
If lfac& Mod 3 = 0 Then bPrmDiv$ = three$: Return
'by 5?
'IF dspcol% THEN LOCATE , dspcol%: PRINT five$;
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = five$
' frmBncFactor.lblTryNum.Refresh
'End If
If Val(Right$(num$, 1)) Mod 5 = 0 Then bPrmDiv$ = five$: Return
'by 7, 11, or 13?
'IF dspcol% THEN LOCATE , dspcol%: PRINT "7+";
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = "7+"
' frmBncFactor.lblTryNum.Refresh
'End If
lfac& = 0
i% = Len(num$) + 1
cnt% = 3
flag% = True
Do
i% = i% - 3: If i% < 1 Then cnt% = i% + 2: i% = 1
If flag% Then
lfac& = lfac& + Val(Mid$(num$, i%, cnt%))
Else
lfac& = lfac& - Val(Mid$(num$, i%, cnt%))
End If
flag% = Not flag%
Loop While i% > 1
If lfac& Mod 7 = 0 Then bPrmDiv$ = "7": Return
If lfac& Mod 11 = 0 Then bPrmDiv$ = "11": Return
If lfac& Mod 13 = 0 Then bPrmDiv$ = "13": Return
'main loop, increment factor by 2 or 4.
sfac$ = "17"
dfac% = 2
bSqrInt num$, maxfac$
Do
'IF dspcol% THEN LOCATE , dspcol%: PRINT sfac$;
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = sfac$
' frmBncFactor.lblTryNum.Refresh
'End If
bMod num$, sfac$, t$
If bIsZero%(t$) Then Exit Do
bInc sfac$, dfac%
dfac% = 6 - dfac%
If bIsMore%(sfac$, maxfac$) Then sfac$ = num$: Exit Do
'If INKEY$ = esc$ Then sfac$ = zero$: Exit Do
Loop
bPrmDiv$ = sfac$
Return
bpdLong:
lnum& = Val(num$)
If lnum& <= 1 Then
lfac& = 1&
ElseIf lnum& Mod 2& = 0& Then
lfac& = 2&
ElseIf lnum& Mod 3& = 0& Then
lfac& = 3&
Else
lmaxfac& = Int(Sqr(lnum&))
lfac& = 5&
ldfac& = 2&
Do
'IF dspcol% THEN LOCATE , dspcol%: PRINT lfac&;
' If dspflag% Then
' frmBncFactor.lblTryNum.Caption = LTrim$(Str$(lfac&))
' frmBncFactor.lblTryNum.Refresh
'End If
If lnum& Mod lfac& = 0& Then Exit Do
lfac& = lfac& + ldfac&
ldfac& = 6& - ldfac&
If lfac& > lmaxfac& Then lfac& = lnum&: Exit Do
Loop
End If
bPrmDiv$ = LTrim$(Str$(lfac&))
Return
End Function
'Do Rabin-Miller Prime test times% times. If true, then probability that
's is composite is < .25^times%. Of course s$ is an odd integer.
'If dspcol% then show progress on current line starting with that column.
'
Function bPrmTest% (s$, times%, dspflag%)
Dim n$
Dim i%, flag%
If bIsEven%(s$) Then bPrmTest% = False: Exit Function
flag% = True
For i% = 2 To times% + 1
'If dspflag% Then Print ".";
n$ = LTrim$(Str$(i%))
If bIsRelPrime%(s$, n$) Then
flag% = bMillerTest%(s$, n$)
Else
flag% = False
End If
If Not flag% Then Exit For
Next i%
bPrmTest% = flag%
End Function
'radians to degrees, deg=rad*180/pi
'
Sub bRadToDeg (s$)
Dim t$, z$
bNormRad s$
bPi t$
z$ = t$
bDiv "180", z$, t$
z$ = s$
bMul t$, z$, s$
bTrimDig s$
End Sub
'Return a random number. Expects an argument of form m.n:
' m.n returns m digits+decimal+n digits
' m returns m digits
' m. m digits with random decimal point
'<null> use last mask
'
Sub bRand (s$, out$)
Static randmask$
Dim t$
Dim n%
t$ = s$
If Len(t$) = 0 Then
If Len(randmask$) = 0 Then randmask$ = "5"
t$ = randmask$
End If
randmask$ = t$
n% = InStr(t$, dp$)
If n% = 0 Then
'R3 -> abc
out$ = bRnd$(Val(t$))
ElseIf n% = 1 Then
'R.3 -> .abc
out$ = dp$ + bRnd$(Val(Mid$(t$, 2)))
ElseIf n% = Len(t$) Then
'R3. -> abc with random dp
out$ = bRnd$(Val(t$) + 1)
Mid$(out$, Int(1 + Rnd * Len(out$)), 1) = dp$
Else
'R3.2 -> abc.ef
out$ = bRnd$(Val(Mid$(t$, 1, n% - 1))) + dp$ + bRnd$(Val(Mid$(t$, n% + 1)))
End If
End Sub
'Return a random number string of places% digits.
'
Function bRnd$ (places%)
Dim t$
Dim i%
If places% = 0 Then
bRnd$ = zero$
Else
t$ = Space$(places%)
Mid$(t$, 1, 1) = Chr$(asc0 + Int(Rnd * 9) + 1)
For i% = 2 To places%
Mid$(t$, i%, 1) = Chr$(asc0 + Int(Rnd * 10))
Next i%
bRnd$ = t$
End If
End Function
'Return a random number < max$, to digits places.
'
Sub bRndNum (max$, out$)
bMul LTrim$(Str$(Rnd)), max$, out$
End Sub
'out = s2 root of s1, (or s1 ^ 1/s2)
'
Sub bRoot (s1$, s2$, out$)
Dim t$, x$, root$, mroot$, r$, newx$, z$
Dim negflag%, invflag%
'easy 0 values
If bIsZero%(s2$) Then out$ = one$: Exit Sub
If bIsZero%(s1$) Then out$ = zero$: Exit Sub
'use logs for non-integer roots
If Not bIsInteger%(s2$) Then
t$ = s2$: bInv t$
bPower s1$, t$, out$
Exit Sub
End If
x$ = s1$
root$ = s2$
If bIsNeg%(x$) Then If bIsEven%(root$) Then out$ = errormsg$: Exit Sub Else bNeg x$: negflag% = True
If bIsNeg%(root$) Then bNeg root$: invflag% = True
If root$ = two$ Then bSqr x$, out$ Else GoSub brRoot
If invflag% Then bInv out$
If negflag% Then bNeg out$
Exit Sub
'Newton-Raphson method for any integer root
brRoot:
mroot$ = root$
bInc mroot$, -1
Do
'newx = [x*(n-1) + s/x^(n-1)] / (n-1)
bMul x$, mroot$, r$
bPowerInt x$, mroot$, t$
bTrimDig t$
z$ = t$
bDiv s1$, z$, t$
bTrimDig t$
z$ = t$
bAdd r$, z$, t$
z$ = t$
bDiv z$, root$, newx$
'a bug, these are never equal
'bTrimDig x$
'bTrimDig newx$
'IF x$ = newx$ THEN EXIT DO
If Left$(x$, digits% - 1) = Left$(newx$, digits% - 1) Then Exit Do
x$ = newx$
bTrimDig x$
Loop
out$ = newx$
Return
End Sub
'Take a string in "scientific notation" and expand it.
'Recognize both 66.6e2 AND 66.6d2 as 6660 to accommadate QB.
' ^ ^
'
Sub bSci (s$)
Dim n%, xp%, sign%
s$ = UCase$(LTrim$(s$))
n% = InStr(s$, "E")
If n% = 0 Then n% = InStr(s$, "D") 'because double# use "D" not "E"
If n% Then
xp% = Val(Mid$(s$, n% + 1))
s$ = Left$(s$, n% - 1)
bLogGet s$, n%, sign%, True
bLogPut s$, n% + xp%, sign%
End If
End Sub
'out = sec(x)
'
Sub bSec (s$, out$)
'sec(x)=1/cos(x)
bCos s$, out$
If bIsZero%(out$) Then
out$ = Error$
Else
bInv out$
End If
End Sub
'out = sech(s)
'
Sub bSech (s$, out$)
'sech(x) = 2 / (Exp(x) + Exp(-x))
out$ = zero$
End Sub
'Set digits% to dig% (or return value if 0).
'
Sub bSetDigits (dig%)
If dig% = False Then dig% = digits% Else digits% = dig%
End Sub
'shift decimal n% digits (minus=left), i.e multiply/divide by 10.
'
Sub bShift (s$, n%)
Dim slog%, sign%
bLogGet s$, slog%, sign%, False
bLogPut s$, slog% + n%, sign%
End Sub
'return sign of number (-1 or +1)
'
Function bSign% (s$)
If bIsNeg%(s$) Then bSign% = negative Else bSign% = positive
End Function
'out = sin(x)
'
Sub bSin (s$, out$)
Dim t$, tfac$, fac$, z$
Dim nfac&
Dim olddigits%, flag%
' x^3 x^5 x^7
'sin(x) = x - --- + --- - --- + ...
' 3! 5! 7!
t$ = s$
bNormRad t$
olddigits% = digits%
digits% = digits% + 5
z$ = t$
bMul t$, z$, tfac$
bTrimDig tfac$
nfac& = 3
fac$ = "6"
out$ = t$
flag% = False
Do
z$ = t$
bMul z$, tfac$, t$
bTrimDig t$
z$ = t$
bDiv z$, fac$, t$
bTrimDig t$
If bIsZero%(t$) Then Exit Do
If flag% Then
z$ = out$
bAdd z$, t$, out$
Else
z$ = out$
bSub z$, t$, out$
End If
flag% = Not flag%
fac$ = LTrim$(Str$((nfac& + 1&) * (nfac& + 2&)))
nfac& = nfac& + 2&
Loop
digits% = olddigits%
bTrimDig out$
End Sub
'out = sinh(x) hyperbolic sine
'
Sub bSinh (s$, out$)
'sinh(x) = (Exp(x) - Exp(-x)) / 2
out$ = zero$
End Sub
'out = SQR(s) using the old hand method
'I learned this in high school, but I still don't understand it. It's fast.
Sub bSqr (s$, out$)
Dim dvd$, div$, dig$, newdiv$, t$, z$
Dim slog%, ssign%, slen%, spt%, olddigits%, n%, m%
If bIsNeg%(s$) Then out$ = errormsg$: Exit Sub
'strip to whole number + group digits by 2 left or right of decimal
bLogGet s$, slog%, ssign%, True
slen% = Len(s$)
If slog% Mod 2 Then spt% = 2 Else spt% = 1
'Force at least enough digits to show integer of root
olddigits% = digits%
n% = 1 + slog% \ 2
If digits% < n% Then digits% = n%
'figure first digit and setup loop
n% = Val(Left$(s$ + "0", spt%))
m% = Int(Sqr(n%))
out$ = LTrim$(Str$(m%))
dvd$ = LTrim$(Str$(n% - m% * m%))
spt% = spt% + 1
Do
'all done?
If (spt% > slen% And bIsZero%(dvd$)) Or Len(out$) >= digits% Then Exit Do
'append next 2 digits (or 0s) to dividend
dvd$ = dvd$ + Left$(Mid$(s$, spt%, 2) + "00", 2)
spt% = spt% + 2
'divisor=twice the root * 10
z$ = out$
bAdd out$, z$, div$
bShift div$, 1
'estimate divisor, and adjust if too big. Unit is next digit of root.
bDivInt dvd$, div$, dig$
Do
bAdd div$, dig$, newdiv$
bMul newdiv$, dig$, t$
If Not bIsMore%(t$, dvd$) Then Exit Do
bInc dig$, -1
Loop
out$ = out$ + dig$
'form new divisor
z$ = dvd$
bSub z$, t$, dvd$
Loop
'clean up
bLogPut s$, slog%, ssign%
If slog% < 0 Then slog% = slog% - 1
bLogPut out$, slog% \ 2, ssign%
digits% = olddigits%
End Sub
'out = INT(SQR(s)), largest integer n such that n^2 <= s
'
Sub bSqrInt (s$, out$)
Dim t$
Dim olddigits%
If bIsNeg%(s$) Then out$ = errormsg$: Exit Sub
t$ = s$
bInt t$
'a trick: let bSqr() figure the decimal and only find that many digits
olddigits% = digits%
digits% = 0
bSqr t$, out$
digits% = olddigits%
End Sub
'Return a number string. str(4.31) returns 4 "31"s, i.e. 31313131.
'Handy for big test numbers.
'
Sub bStr (s$, out$)
Dim t$
Dim n%, i%
n% = InStr(s$, ".")
If n% Then t$ = Mid$(s$, n% + 1) Else t$ = Right$(s$, 1)
out$ = ""
For i% = 1 To Val(s$)
out$ = t$ + out$
Next i%
If Len(out$) = 0 Then out$ = zero$
End Sub
'Trim leading spaces, add decimal points, eliminate signs.
'Returns last%=length of string, dpt%=decimal place, sign%=-1 or 1.
'Called only by bAdd() and bSub() which needs a final decimal point.
'
Sub bStripDp (s$, last%, dpt%, sign%)
If Left$(s$, 1) = neg$ Then s$ = Mid$(s$, 2): sign% = negative Else sign% = positive
bStripZero s$
If InStr(s$, dp$) = 0 Then s$ = s$ + dp$
If s$ = dp$ Then s$ = "0."
dpt% = InStr(s$, dp$)
last% = Len(s$)
End Sub
'Strip trailing 0s to "." (but leave something)
'
Sub bStripTail (s$)
Dim n%
n% = Len(s$)
Do While Mid$(s$, n%, 1) = zero$
n% = n% - 1
If n% <= 1 Then Exit Do
Loop
If n% Then If Mid$(s$, n%, 1) = dp$ Then n% = n% - 1
s$ = Left$(s$, n%)
If Len(s$) = 0 Then s$ = zero$
End Sub
'Strip leading 0s and final "." (but leave something)
'
Sub bStripZero (s$)
Dim n%
n% = 1
Do While Mid$(s$, n%, 1) = zero$
n% = n% + 1
Loop
If n% > 1 Then s$ = Mid$(s$, n%)
If Right$(s$, 1) = dp$ Then s$ = Left$(s$, Len(s$) - 1)
If Len(s$) = 0 Then s$ = zero$
End Sub
'out = s1 - s2
'
Sub bSub (s1$, s2$, out$)
Dim last1%, dp1%, sign1%
Dim last2%, dp2%, sign2%
Dim last%, d1%, d2%, dpt%, borrow%, swapflag%
Dim i%, n%
'strip the numbers
bStripDp s1$, last1%, dp1%, sign1%
bStripDp s2$, last2%, dp2%, sign2%
'treat different signs as addition
If sign1% = negative And sign2% = positive Then
bNeg s1$
bNeg s2$
bAdd s1$, s2$, out$
bNeg s2$
Exit Sub
ElseIf sign1% = positive And sign2% = negative Then
bAdd s1$, s2$, out$
bNeg s2$
Exit Sub
End If
'align the decimal points and digit pointers
last% = bMaxInt%(last1% - dp1%, last2% - dp2%)
d1% = last% + dp1%
d2% = last% + dp2%
dpt% = bMaxInt%(dp1%, dp2%)
last% = dpt% + last%
out$ = Space$(last%)
borrow% = 0
'always subtract smaller from bigger to avoid complements
If bIsMore%(s2$, s1$) Then
bSwapString s1$, s2$
bSwapInt d2%, d1%
swapflag% = True
End If
'do the subtraction right to left
For i% = last% To 1 Step -1
If i% <> dpt% Then
If d1% > 0 Then n% = Val(Mid$(s1$, d1%, 1)) Else n% = 0
If d2% > 0 Then n% = n% - Val(Mid$(s2$, d2%, 1))
n% = n% - borrow%
If n% >= 0 Then borrow% = 0 Else borrow% = 1: n% = n% + 10
Mid$(out$, i%, 1) = Chr$(asc0 + n%)
Else
Mid$(out$, i%, 1) = dp$
End If
d1% = d1% - 1
d2% = d2% - 1
Next i%
'clean up
If sign1% = negative Then s1$ = neg$ + s1$: s2$ = neg$ + s2$
If swapflag% Then
bSwapString s1$, s2$
sign1% = -sign1%
End If
If sign1% = negative Then out$ = neg$ + out$
bClean s1$
bClean s2$
bClean out$
End Sub
Sub bSwapInt (s1%, s2%)
Dim t%
t% = s1%
s1% = s2%
s2% = t%
End Sub
Sub bSwapString (s1$, s2$)
Dim t$
t$ = s1$
s1$ = s2$
s2$ = t$
End Sub
'out = tan(s)
'
Sub bTan (s$, out$)
Dim t$, tc$, ts$
'tan=sin/cos
t$ = s$
bNormRad t$
bCos t$, tc$
If bIsZero%(tc$) Then
out$ = Error$
Else
bSin t$, ts$
bDiv ts$, tc$, out$
End If
End Sub
Sub bTanh (s$, out$)
'tanh(x) = (Exp(x) - Exp(-x)) / (Exp(x) + Exp(-x))
out$ = zero$
End Sub
'Truncate s$ to digits% places
'
Sub bTrimDig (s$)
s$ = Left$(s$, digits% + 1)
End Sub
'Try to load table of prime counts, 66th item is the 66000th prime.
'Should be in current dircetory, but check path if not.
'
'Sub LoadPrimeTable ()
' Dim file$, path$, in$
' Dim i%, n%, m%, flag%, filenum%
' file$ = prmcntfile$
' filenum% = FreeFile
' maxprmcnt% = False
'' if table not in current dir, then check path
' If Len(Dir$(file$)) = 0 Then
' path$ = Environ$("PATH")
' flag% = True
' n% = 1
' Do While n% < Len(path$)
' m% = InStr(n%, path$, ";")
' If m% = 0 Then m% = Len(path$) + 1
' file$ = Mid$(path$, n%, m% - n%)
' If Right$(file$, 1) <> "\" Then file$ = file$ + "\"
' file$ = file$ + prmcntfile$
' If Len(Dir$(file$)) Then
' bncpath$ = Mid$(path$, n%, m% - n%) + "\"
' flag% = False
' Exit Do
' End If
' n% = m% + 1
' Loop
' If flag% Then Exit Sub
' End If
'' found it, check for signature and load data
' Open file$ For Input As #filenum%
' Line Input #filenum%, in$
' If UCase$(Left$(in$, 7)) = "'BIGNUM" Then
' Do
' Line Input #filenum%, in$
' Loop While Left$(in$, 1) = "'"
' maxprmcnt% = Val(in$)
' ReDim prmcnt&(1 To maxprmcnt%)
' For i% = 1 To maxprmcnt%
' Input #filenum%, prmcnt&(i%)
' Next i%
' End If
' Close #filenum%
'End Sub
'PUT or GET a number from the stack, or beep
'
Sub WorkStack (s$, memop%)
Dim i%
Select Case memop%
Case memget
If zstack% Then
s$ = zmem$(zstack%)
zstack% = zstack% - 1
Else
s$ = zero$ 'stack underflow
End If
Case memput
If (zstack% < maxstack) Then
zstack% = zstack% + 1
zmem$(zstack%) = s$
Else
'stack overflow
End If
Case memclr
zstack% = False
For i% = 1 To maxstack: zmem$(i%) = zero$: Next i%
End Select
End SubRE: Treebeard's String-Math - Pete - 07-28-2022
That demo leaves a lot to be desired.
Pete
RE: Treebeard's String-Math - Jack - 07-28-2022
what would you like to see in the demo?
RE: Treebeard's String-Math - Pete - 07-28-2022
As is, it just appears as such an odd way to express using strings to perform basic math functions. I looked at the 24 digit sets, all from one continuous string, and all using the division sub routines to increase the size of the quotient, which is passed back as outs and passed back again as r. Add together each set and it gives the next 24-digit set. As such, I cannot see a practical way to have it demonstrate the four various math routines with the subroutines in the code; so I guess what I would like to see it do is handle user input to demonstrate this is a number multiplied by another number with another number subtracted from it, divided by ant=other number, and added to another number, etc. Also, how it handles negatives and decimals.
Pete
RE: Treebeard's String-Math - Jack - 07-28-2022
OK Pete
Code: (Select All)
$NoPrefix
$Console:Only
Dest Console
'BIGNUM.BAS v0.n
'Sep-Dec 1996 by Marc Kummel aka Treebeard.
'Contact mkummel@rain.org, http://www.rain.org/~mkummel/
'
' ** site no longer available, use the link below
' https://web.archive.org/web/20200220020034/http://www.rain.org/~mkummel/tbvault.html
' Conditions:
'-------------
'This program and source code are yours to use and modify as you will, but
'they are offered as freeware with no warranty whatsoever. Give me credit,
'but do not distribute any changes under my name, or attribute such changes
'to me in any way. You're on your own!
Const zero = "0", one = "1"
Const dp = ".", neg = "-", asc0 = 48
Const negative = -1, positive = 1 'returned by bComp()
Const maxlongdig = 8 'max digits in long var&
Const true = -1
'useful shared stuff
Dim Shared As Long digits
Dim Shared As String errors
Const null = ""
digits = 24 'digits for division etc
's = |s|
'
'========================================================================
Dim As String n, m, r
Dim As Long i, j
t = Timer
Input "enter n ", n
If n = "" Then
n = "3.1415926535897932384626433832795"
Print "n = "; n
End If
Input "enter m ", m
If m = "" Then
m = "-2.7182818284590452353602874713527"
Print "m = "; m
End If
Print
bAdd n, m, r
Print "n + m = "; r
bSub n, m, r
Print "n - m = "; r
bMul n, m, r
Print "n * m = "; r
bDiv n, m, r
Print "n / m = "; r
'========================================================================
Sub bAbs (s As String)
If Left$(s, 1) = neg Then s = Mid$(s, 2)
End Sub
'return true if s is negative
'
Function bIsNeg& (s As String)
bIsNeg = (Left$(s, 1) = neg)
End Function
'return sign of number (-1 or +1)
'
Function bSign& (s As String)
If bIsNeg(s) Then bSign = negative Else bSign = positive
End Function
'return the largest of two integers
'
Function bMaxInt& (n1 As Long, n2 As Long)
If n1 >= n2 Then bMaxInt = n1 Else bMaxInt = n2
End Function
'Compare two numbers using fast string compares. This can screw up since it
'uses string length, eg it reports "8"<"8." so watch out. The practice in
'these routines is no leading or trailing 0s and no final "." See bClean().
'
'Return 1 if s1 > s2
' 0 if s1 = s2
' -1 if s1 < s2
'
Function bComp& (s1 As String, s2 As String)
'dim as string dp
Dim As Long sign1, sign2, dp1, dp2, arg, s1flag, s2flag
'kludge to fix 0<.1
If Left$(s1, 1) = dp Then s1 = zero + s1: s1flag = true
If Left$(s2, 1) = dp Then s2 = zero + s2: s2flag = true
sign1 = (Left$(s1, 1) = neg)
sign2 = (Left$(s2, 1) = neg)
dp1 = InStr(s1, dp): If dp1 = 0 Then dp1 = Len(s1) + 1
dp2 = InStr(s2, dp): If dp2 = 0 Then dp2 = Len(s2) + 1
If sign1 <> sign2 Then
If sign1 Then arg = -1 Else arg = 1
ElseIf s1 = s2 Then
arg = 0
ElseIf (dp1 < dp2) Or ((dp1 = dp2) And (s1 < s2)) Then
arg = -1
Else
arg = 1
End If
If sign1 And sign2 Then arg = -arg
If s1flag Then s1 = Mid$(s1, 2)
If s2flag Then s2 = Mid$(s2, 2)
bComp = arg
End Function
'return true if s1 > s2
'
Function bIsMore& (s1 As String, s2 As String)
bIsMore = (bComp(s1, s2) = 1)
End Function
'Strip leading 0s and final "." (but leave something)
'
Sub bStripZero (s As String)
Dim As Long n
n = 1
Do While Mid$(s, n, 1) = zero
n = n + 1
Loop
If n > 1 Then s = Mid$(s, n)
If Right$(s, 1) = dp Then s = Left$(s, Len(s) - 1)
If Len(s) = 0 Then s = zero
End Sub
'Strip trailing 0s to "." (but leave something)
'
Sub bStripTail (s As String)
Dim As Long n
n = Len(s)
Do While Mid$(s, n, 1) = zero
n = n - 1
If n <= 1 Then Exit Do
Loop
If n Then If Mid$(s, n, 1) = dp Then n = n - 1
s = Left$(s, n)
If Len(s) = 0 Then s = zero
End Sub
'Strip s$ to whole number and base 10 integer logarithm and sign. Decimal
'point is implied after the first digit, and slog% counts places left or
'right. bLogPut() reverses the process, and bLogDp() gives info on the
'decimals. Tricky, but it works and simplifies dividing and multipling.
'eg s$ -> s$ , slog%
' 660 -> 66 , 2 (6.6 * 10^ 2) (or 660,2 if zeroflag%=false)
' 6.6 -> 66 , 0 (6.6 * 10^ 0)
' .066 -> 66 , -2 (6.6 * 10^-2)
'bDiv(), bMul(), and bSqr() use this to trim unnecessary zeros and to locate
'decimal point. These set zeroflag% to trim trailing zeros, but bDivIntMod()
'must set it false in order to figure remainder of division. A kludge.
'
Sub bLogGet (s As String, slog As Long, sign As Long, zeroflag As Long)
Dim As Long n, dpt
If Left$(s, 1) = neg Then s = Mid$(s, 2): sign = negative Else sign = positive
bStripZero s
dpt = InStr(s, dp)
Select Case dpt
Case 0
slog = Len(s) - 1
Case 1
n = dpt + 1
Do While Mid$(s, n, 1) = zero
n = n + 1
Loop
s = Mid$(s, n)
slog = dpt - n
Case Else
s = Left$(s, dpt - 1) + Mid$(s, dpt + 1)
slog = dpt - 2
End Select
'remove trailing 0's if zeroflag
If zeroflag Then bStripTail s
End Sub
'Strip a number to "standard form" with no leading or trailing 0s and no
'final "." All routines should return all arguments in this form.
'
Sub bClean (s As String)
Dim As Long sign
If Left$(s, 1) = neg Then s = Mid$(s, 2): sign = true
bStripZero s
If InStr(s, dp) Then bStripTail s
If sign And s <> zero Then s = neg + s
End Sub
'Restore a number from the integer and log figured in bLogGet(). s$ is taken
'as a number with the decimal after first digit, and decimal is moved slog%
'places left or right, adding 0s as required. Called by bDiv() and bMul().
'
Sub bLogPut (s As String, slog As Long, sign As Long)
Dim As Long last
last = Len(s)
If Len(s) = 0 Or s = zero Then
s = zero
ElseIf slog < 0 Then
s = dp + String$(-slog - 1, zero) + s
ElseIf slog > last - 1 Then
s = s + String$(slog - last + 1, zero) + dp
Else
s = Left$(s, slog + 1) + dp + Mid$(s, slog + 2)
End If
bClean s
If sign = negative Then s = neg + s
End Sub
'shift decimal n% digits (minus=left), i.e multiply/divide by 10.
'
Sub bShift (s As String, n As Long)
Dim As Long slog, sign
bLogGet s, slog, sign, 0 'false
bLogPut s, slog + n, sign
End Sub
's = -s
'
Sub bNeg (s As String)
If Left$(s, 1) = neg Then s = Mid$(s, 2) Else s = neg + s
End Sub
'Take whole number and log from bLogGet() and return number of decimal
'places in the expanded number; OR take string and number of decimal points
'desired and return the log. It works both ways.
'
Function bLogDp& (s As String, logdp As Long)
bLogDp = Len(s) - 1 - logdp
End Function
'out = s1 / s2 using fast long-integer algorithm. s2$ must be <= 8 digits.
's1$ and s2$ must be stripped first, no decimals.
'
Sub bDivLong (s1 As String, s2 As String, quotient As String, remain As String)
Dim As Long dividend, remainder, divisor, dig, i
quotient = null
remainder = 0
divisor = Val(s2)
For i = 1 To digits
dividend = remainder * 10 + Val(Mid$(s1, i, 1))
dig = dividend \ divisor
quotient = quotient + Chr$(asc0 + dig)
remainder = dividend - dig * divisor
Next i
If Len(quotient) = 0 Then quotient = zero
remain = LTrim$(Str$(remainder))
End Sub
'out = s1 / s2 using character algorithm, digit by digit, slow but honest.
's1$ and s2$ must be stripped first, no decimals.
'
Sub bDivChar (s1 As String, s2 As String, quotient As String, remainder As String)
Dim As Long last1, last2, ldvd, dig, borrow, i, j, n, lrem
Dim As String dvd
last1 = Len(s1) 'length of the dividend
last2 = Len(s2) 'length of the divisor
quotient = null
remainder = null
For i = 1 To digits
'get next digit of dividend or zero$ if past end
If i <= last1 Then
dvd = remainder + Mid$(s1, i, 1)
Else
dvd = remainder + zero
End If
'if dividend < divisor then digit%=0 else have to calculate it.
'do fast compare using string operations. see bComp%()
bStripZero dvd
ldvd = Len(dvd)
If (ldvd < last2) Or ((ldvd = last2) And (dvd < s2)) Then
'divisor is bigger, so digit is 0, easy!
dig = 0
remainder = dvd
Else
'dividend is bigger, but no more than 9 times bigger.
'subtract divisor until we get remainder less than divisor.
'time hog, average is 5 tries through j% loop. There's a better way.
For dig = 1 To 9
remainder = null
borrow = 0
For j = 0 To ldvd - 1
n = last2 - j
If n < 1 Then n = 0 Else n = Val(Mid$(s2, n, 1))
n = Val(Mid$(dvd, ldvd - j, 1)) - n - borrow
If n >= 0 Then borrow = 0 Else borrow = 1: n = n + 10
remainder = Chr$(asc0 + n) + remainder
Next j
'if remainder < divisor then exit
bStripZero remainder
lrem = Len(remainder)
If (lrem < last2) Or ((lrem = last2) And (remainder < s2)) Then Exit For
dvd = remainder
ldvd = Len(dvd)
Next dig
End If
quotient = quotient + Chr$(asc0 + dig)
Next i
End Sub
'out = s1 / s2
'
Sub bDiv (s1 As String, s2 As String, outs As String)
Dim As String t
Dim As Long slog1, slog2, sign1, sign2, outlog, outsign, olddigits
'strip divisor
t = s2
bLogGet t, slog2, sign2, -1 'true
'divide by zero?
If t = zero Then
outs = errors
'do powers of 10 with shifts
ElseIf t = one Then
outs = s1
sign1 = bSign(outs)
If sign1 = negative Then bAbs outs
bShift outs, -slog2
If sign1 <> sign2 Then bNeg outs
'the hard way
Else
'strip all
s2 = t: t = null
bLogGet s1, slog1, sign1, -1 'true
'figure decimal point and sign of answer
outlog = slog1 + bLogDp(s2, slog2)
If sign1 <> sign2 Then outsign = negative Else outsign = positive
'bump digits past leading zeros and always show whole quotient
olddigits = digits
digits = digits + Len(s2)
If digits < outlog + 1 Then digits = outlog + 1
'do it, ignore remainder
If Len(s2) <= maxlongdig Then bDivLong s1, s2, outs, t Else bDivChar s1, s2, outs, t
'clean up
bLogPut outs, outlog, outsign
bLogPut s1, slog1, sign1
bLogPut s2, slog2, sign2
digits = olddigits
End If
End Sub
'Trim leading spaces, add decimal points, eliminate signs.
'Returns last%=length of string, dpt%=decimal place, sign%=-1 or 1.
'Called only by bAdd() and bSub() which needs a final decimal point.
'
Sub bStripDp (s As String, last As Long, dpt As Long, sign As Long)
If Left$(s, 1) = neg Then s = Mid$(s, 2): sign = negative Else sign = positive
bStripZero s
If InStr(s, dp) = 0 Then s = s + dp
If s = dp Then s = "0."
dpt = InStr(s, dp)
last = Len(s)
End Sub
declare SUB bAdd (s1 as string, s2 as string, outs as string)
'out = s1 - s2
'
Sub bSub (s1 As String, s2 As String, outs As String)
Dim As Long last, last1, last2, sign1, sign2, dpt, dp1, dp2
Dim As Long d1, d2, borrow, swapflag, i, n
'strip the numbers
bStripDp s1, last1, dp1, sign1
bStripDp s2, last2, dp2, sign2
'treat different signs as addition
If sign1 = negative And sign2 = positive Then
bNeg s1
bNeg s2
bAdd s1, s2, outs
bNeg s2
Exit Sub
ElseIf sign1 = positive And sign2 = negative Then
bAdd s1, s2, outs
bNeg s2
Exit Sub
End If
'align the decimal points and digit pointers
last = bMaxInt(last1 - dp1, last2 - dp2)
d1 = last + dp1
d2 = last + dp2
dpt = bMaxInt(dp1, dp2)
last = dpt + last
outs = Space$(last)
borrow = 0
'always subtract smaller from bigger to avoid complements
If bIsMore(s2, s1) Then Swap s2, s1: Swap d2, d1: swapflag = true
'do the subtraction right to left
For i = last To 1 Step -1
If i <> dpt Then
If d1 > 0 Then n = Val(Mid$(s1, d1, 1)) Else n = 0
If d2 > 0 Then n = n - Val(Mid$(s2, d2, 1))
n = n - borrow
If n >= 0 Then borrow = 0 Else borrow = 1: n = n + 10
Mid$(outs, i, 1) = Chr$(asc0 + n)
Else
Mid$(outs, i, 1) = dp
End If
d1 = d1 - 1
d2 = d2 - 1
Next i
'clean up
If sign1 = negative Then s1 = neg + s1: s2 = neg + s2
If swapflag Then Swap s2, s1: sign1 = -sign1
If sign1 = negative Then outs = neg + outs
bClean s1
bClean s2
bClean outs
End Sub
'out = s1 + s2
'
Sub bAdd (s1 As String, s2 As String, outs As String)
Dim As Long last1, last2, sign1, sign2, dp1, dp2
Dim As Long last, i, d1, d2, dpt, carry, n
'strip the numbers
bStripDp s1, last1, dp1, sign1
bStripDp s2, last2, dp2, sign2
'treat different signs as subtraction and exit
If sign1 = negative And sign2 = positive Then
bSub s2, s1, outs
bNeg s1
Exit Sub
ElseIf sign1 = positive And sign2 = negative Then
bSub s1, s2, outs
bNeg s2
Exit Sub
End If
'align the decimal points and digit pointers
last = bMaxInt(last1 - dp1, last2 - dp2)
d1 = last + dp1
d2 = last + dp2
dpt = bMaxInt(dp1, dp2)
last = dpt + last
outs = Space$(last)
carry = 0
'do the addition right to left
For i = last To 1 Step -1
If i <> dpt Then
n = carry
If d1 > 0 Then n = n + Val(Mid$(s1, d1, 1))
If d2 > 0 Then n = n + Val(Mid$(s2, d2, 1))
carry = n \ 10
Mid$(outs, i, 1) = Chr$(asc0 + (n Mod 10))
Else
Mid$(outs, i, 1) = dp
End If
d1 = d1 - 1
d2 = d2 - 1
Next i
If carry Then outs = one + outs
'clean up
If sign1 = negative Then s1 = neg + s1: s2 = neg + s2: outs = neg + outs
bClean s1
bClean s2
bClean outs
End Sub
'out = s1 * s2 using character algorithm, slow but honest. Whole numbers
'only. Inner loop is optimized and hard to understand, but it works.
'
Sub bMulChar (s1 As String, s2 As String, outs As String)
Dim As Long last, last1, last2, i, j, k, sj, ej, product
last1 = Len(s1)
last2 = Len(s2)
last = last1 + last2
outs = Space$(last)
product = 0
For i = 0 To last - 1
k = last1 - i
sj = 1 - k: If sj < 0 Then sj = 0
ej = last1 - k: If ej > last2 - 1 Then ej = last2 - 1
For j = sj To ej
product = product + Val(Mid$(s1, k + j, 1)) * Val(Mid$(s2, last2 - j, 1))
Next j
Mid$(outs, last - i, 1) = Chr$(asc0 + CInt(product Mod 10))
product = product \ 10
Next i
If product Then outs = LTrim$(Str$(product)) + outs
End Sub
'out = s1 * s2 using fast long-integer algorithm. s2$ must be <= 8 digits.
's1$ and s2$ must be stripped first, whole numbers only.
'
Sub bMulLong (s1 As String, s2 As String, outs As String)
Dim As Long last1, s2L, i, product
last1 = Len(s1)
s2L = Val(s2)
outs = Space$(last1)
For i = last1 To 1 Step -1
product = product + Val(Mid$(s1, i, 1)) * s2L
Mid$(outs, i, 1) = Chr$(asc0 + CInt(product Mod 10))
product = product \ 10
Next i
If product Then outs = LTrim$(Str$(product)) + outs
End Sub
'out = s1 * s2
'
Sub bMul (s1 As String, s2 As String, outs As String)
Dim As Long slog1, slog2, sign1, sign2, outdp, outsign
Dim As Long outlog, swapflag
Dim As String t
'strip multiplier
t = s2
bLogGet t, slog2, sign2, true
'times 0
If t = zero Then
outs = zero
'do powers of 10 with shifts
ElseIf t = one Then
outs = s1
sign1 = bSign(outs)
If sign1 = negative Then bAbs outs
bShift outs, slog2
If sign1 <> sign2 Then bNeg outs
'the hard way
Else
'strip all
s2 = t: t = null
bLogGet s1, slog1, sign1, true
'figure decimal point and sign of answer
outdp = bLogDp(s1, slog1) + bLogDp(s2, slog2)
If sign1 <> sign2 Then outsign = negative Else outsign = positive
'always multiply by the shorter number
If Len(s2) > Len(s1) Then Swap s1, s2: swapflag = true
'do it
If Len(s2) <= maxlongdig Then bMulLong s1, s2, outs Else bMulChar s1, s2, outs
'clean up
outlog = bLogDp(outs, outdp)
bLogPut outs, outlog, outsign
If swapflag Then Swap s1, s2
bLogPut s1, slog1, sign1
bLogPut s2, slog2, sign2
End If
End SubCode: (Select All)
enter n
n = 3.1415926535897932384626433832795
enter m
m = -2.7182818284590452353602874713527
n + m = .4233108251307480031023559119268
n - m = 5.8598744820488384738229308546322
n * m = -8.53973422267356706546355086954668447174445893592492906242717965
n / m = -1.155727349790921717910093RE: Treebeard's String-Math - James D Jarvis - 07-28-2022
I'm working on big number support for up to 2,147,483,645 digits with strings (need space for the negative sign and the decimal point), always happy to see how other people tackle the general idea for math with strings.
RE: Treebeard's String-Math - Pete - 07-28-2022
(07-28-2022, 03:09 PM)James D Jarvis Wrote: I'm working on big number support for up to 2,147,483,645 digits with strings (need space for the negative sign and the decimal point), always happy to see how other people tackle the general idea for math with strings.
I put this together a few years back for +-?* strimg math routines.
What I didn't include was a way to carry repeating decimals (repetends). So 1 / 3 * 3 will result in .9... instead of 1, just as .3... * 3 would result in .9...
So I would consider it unfinished for use in a calculator.
Code: (Select All)
PRINT
INPUT "Limit Display: "; limit&&
LINE INPUT "Use Rounding? Y/N: "; ans$
IF UCASE$(ans$) = "Y" THEN
round_total% = -1
LINE INPUT "Show if Rounded? Y/N: "; ans$
IF UCASE$(ans$) = "Y" THEN show_rounding% = -1 ELSE show_rounding% = 0
ELSE
round_total% = 0
END IF
LINE INPUT "Display in Scientific Notation? Y/N: "; ans$
IF UCASE$(ans$) = "Y" THEN
snconvert% = -1
ELSE
snconvert% = 0
LINE INPUT "Display in Dollars and Cents? Y/N: "; ans$
IF UCASE$(ans$) = "Y" THEN currency_display% = -1 ELSE currency_display% = 0
LINE INPUT "Display Results with Commas? Y/N: "; ans$
END IF
IF UCASE$(ans$) = "Y" THEN comma_display% = -1 ELSE comma_display% = 0
DO
DO
LINE INPUT "Number: "; stringmathb$
IF UCASE$(stringmathb$) = "C" THEN RUN
origb$ = stringmathb$
CALL stringmath(stringmatha$, operator$, stringmathb$, runningtotal$, snconvert%, round_total%, show_rounding%, comma_display%, currency_display%, limit&&)
IF stringmathb$ <> "invalid number" AND stringmathb$ <> "overflow" THEN
EXIT DO
ELSE
PRINT stringmathb$
END IF
LOOP
IF operator$ <> "" THEN
DO UNTIL INSTR(origa$, ",") = 0
origa$ = MID$(origa$, 1, INSTR(origa$, ",") - 1) + MID$(origa$, INSTR(origa$, ",") + 1)
LOOP
DO UNTIL INSTR(origb$, ",") = 0
origb$ = MID$(origb$, 1, INSTR(origb$, ",") - 1) + MID$(origb$, INSTR(origb$, ",") + 1)
LOOP
IF INSTR(origb$, "$") THEN origb$ = MID$(origb$, 1, INSTR(origb$, "$") - 1) + MID$(origb$, INSTR(origb$, "$") + 1)
SELECT CASE orig_operator$
CASE "+"
runningtotal# = VAL(origa$) + VAL(origb$)
CASE "-"
runningtotal# = VAL(origa$) - VAL(origb$)
CASE "*"
runningtotal# = VAL(origa$) * VAL(origb$)
CASE "/"
runningtotal# = VAL(origa$) / VAL(origb$)
CASE "C", "c"
RUN
END SELECT
origa$ = LTRIM$(STR$(runningtotal#))
COLOR 8, 0: PRINT "Numeric Total: "; origa$: COLOR 7, 0
PRINT "String Total: "; runningtotal$
ELSE
origa$ = runningtotal$: IF INSTR(origa$, "$") THEN origa$ = MID$(origa$, 1, INSTR(origa$, "$") - 1) + MID$(origa$, INSTR(origa$, "$") + 1)
END IF
COLOR 2, 0: PRINT "Operator: +-/*: ";: COLOR 7, 0
DO
operator$ = INKEY$
IF LEN(operator$) THEN
IF operator$ = CHR$(27) THEN SYSTEM
IF INSTR("-+/*=8cC", operator$) THEN EXIT DO
END IF
LOOP
IF UCASE$(operator$) = "C" THEN RUN
IF operator$ = "=" THEN operator$ = "+"
IF operator$ = "8" THEN operator$ = "*"
orig_operator$ = operator$
PRINT operator$
LOOP
SUB stringmath (stringmatha$, operator$, stringmathb$, runningtotal$, snconvert%, round_total%, show_rounding%, comma_display%, currency_display%, limit&&)
stringmathround$ = ""
IF limit&& > 2147483640 THEN limit&& = 2147483640
IF limit&& = 0 THEN limit&& = 70 ' Default.
IF RIGHT$(UCASE$(runningtotal$), 1) = "R" THEN runningtotal$ = MID$(runningtotal$, 1, LEN(runningtotal$) - 1) 'Strip off rounding designation.
' Check running total. If S.N. convert to numeric for operations.
IF INSTR(runningtotal$, ",") <> 0 OR INSTR(runningtotal$, "e") <> 0 THEN
holdstringmathb$ = stringmathb$
stringmathb$ = runningtotal$
IF INSTR(runningtotal$, ",") <> 0 THEN GOSUB comma_removal ELSE GOSUB scientific_to_numeric
runningtotal$ = stringmathb$: stringmathb$ = holdstringmathb$: holdstringmathb$ = ""
END IF
' Check input number. If S.N. convert to numeric for operations.
IF INSTR(UCASE$(stringmathb$), "D") <> 0 OR INSTR(UCASE$(stringmathb$), "E") <> 0 THEN
GOSUB validate_string_number
IF stringmathb$ = "invalid number" THEN EXIT SUB
GOSUB scientific_to_numeric
END IF
IF runningtotal$ = "" THEN
GOSUB validate_string_number
IF stringmathb$ = "invalid number" THEN EXIT SUB
IF LEFT$(stringmathb$, 1) = "-" THEN
stringmathb$ = MID$(stringmathb$, 2)
n2sign$ = "-"
ELSE
n2sign$ = ""
END IF
GOSUB limit_round_convert
IF stringmathb$ = "overflow" THEN
n2sign$ = "": PRINT "Validated: "; stringmathb$: EXIT SUB
END IF
runningtotal$ = n2sign$ + stringmathb$: n2sign$ = ""
IF stringmathround$ <> "" THEN runningtotal$ = runningtotal$ + stringmathround$
PRINT "Validated: "; runningtotal$
IF INSTR(LCASE$(stringmathb$), "e") <> 0 THEN BEEP: GOSUB scientific_to_numeric
ELSE
GOSUB validate_string_number
PRINT "Validated: "; stringmathb$
IF stringmathb$ = "invalid number" THEN EXIT SUB
IF INSTR(UCASE$(stringmathb$), "e") <> 0 THEN GOSUB scientific_to_numeric
END IF
IF runningtotal$ <> "" THEN stringmatha$ = runningtotal$
SELECT CASE operator$
CASE "+", "-"
string_add_subtract:
IF INSTR(stringmatha$, ".") <> 0 THEN ' Evaluate sum for decimal fraction.
sumplace& = LEN(stringmatha$) - INSTR(stringmatha$, ".")
stringmatha$ = MID$(stringmatha$, 1, INSTR(stringmatha$, ".") - 1) + MID$(stringmatha$, INSTR(stringmatha$, ".") + 1) ' Strip out decimal
END IF
IF INSTR(stringmathb$, ".") <> 0 THEN ' Evaluate number for decimal fraction.
numplace& = LEN(stringmathb$) - INSTR(stringmathb$, ".")
stringmathb$ = MID$(stringmathb$, 1, INSTR(stringmathb$, ".") - 1) + MID$(stringmathb$, INSTR(stringmathb$, ".") + 1) ' Strip out decimal
END IF
IF sumplace& > numplace& THEN addsubplace& = sumplace& ELSE addsubplace& = numplace&
IF sumplace& > addsubplace& THEN
stringmatha$ = stringmatha$ + STRING$(sumplace& - addsubplace&, "0")
ELSEIF addsubplace& > sumplace& THEN
stringmatha$ = stringmatha$ + STRING$(addsubplace& - sumplace&, "0")
END IF
IF numplace& > addsubplace& THEN
stringmathb$ = stringmathb$ + STRING$(numplace& - addsubplace&, "0")
ELSEIF addsubplace& > numplace& THEN
stringmathb$ = stringmathb$ + STRING$(addsubplace& - numplace&, "0")
END IF ' END Decimal evaluations.
IF LEFT$(stringmatha$, 1) = "-" THEN sign_input$ = "-" ELSE sign_input$ = "+"
IF LEFT$(stringmathb$, 1) = "-" THEN sign_total$ = "-" ELSE sign_total$ = "+"
addsubsign% = 0
SELECT CASE sign_input$ + operator$ + sign_total$
CASE "+++", "+--"
operator$ = "+"
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
CASE "++-", "+-+"
operator$ = "-"
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
IF VAL(stringmathb$) > VAL(stringmatha$) THEN SWAP stringmatha$, stringmathb$: addsubsign% = -1
CASE "---", "-++"
operator$ = "-"
IF LEFT$(stringmatha$, 1) = "-" THEN stringmatha$ = MID$(stringmatha$, 2)
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
IF VAL(stringmathb$) > VAL(stringmatha$) THEN SWAP stringmatha$, stringmathb$ ELSE addsubsign% = -1
CASE "--+", "-+-"
operator$ = "+"
IF LEFT$(stringmatha$, 1) = "-" THEN stringmatha$ = MID$(stringmatha$, 2)
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
addsubsign% = -1
END SELECT
IF LEN(stringmatha$) > LEN(stringmathb$) THEN
stringmathb$ = STRING$(LEN(stringmatha$) - LEN(stringmathb$), "0") + stringmathb$
ELSEIF LEN(stringmatha$) < LEN(stringmathb$) THEN
stringmatha$ = STRING$(LEN(stringmathb$) - LEN(stringmatha$), "0") + stringmatha$
END IF
addsubx1$ = ""
SELECT CASE operator$
CASE "+", "="
FOR addsubii& = LEN(stringmatha$) TO 1 STEP -1
addsubx1% = VAL(MID$(stringmatha$, addsubii&, 1)) + VAL(MID$(stringmathb$, addsubii&, 1)) + addsubcarry%
IF addsubx1% > 9 THEN addsubx1% = addsubx1% - 10: addsubcarry% = 1 ELSE addsubcarry% = 0
addsubx1$ = LTRIM$(STR$(addsubx1%)) + addsubx1$
NEXT
IF addsubcarry% THEN addsubx1$ = "1" + addsubx1$: addsubcarry% = 0
GOSUB replace_decimal
CASE "-"
FOR addsubii& = LEN(stringmatha$) TO 1 STEP -1
addsubx1% = VAL(MID$(stringmatha$, addsubii&, 1)) - VAL(MID$(stringmathb$, addsubii&, 1)) + addsubcarry%
IF addsubx1% < 0 THEN addsubx1% = addsubx1% + 10: addsubcarry% = -1 ELSE addsubcarry% = 0
addsubx1$ = LTRIM$(STR$(addsubx1%)) + addsubx1$
NEXT
IF addsubx1$ <> "" AND addsubx1$ <> STRING$(LEN(addsubx1$), "0") THEN GOSUB replace_decimal
DO UNTIL LEFT$(addsubx1$, 1) <> "0" ' Remove leading zeros.
addsubx1$ = MID$(addsubx1$, 2)
LOOP
IF addsubx1$ = "" THEN
addsubx1$ = "0": addsubsign% = 0
ELSE
IF addsubcarry% THEN addsubx1$ = "-" + addsubx1$: addsubcarry% = 0
END IF
END SELECT
IF addsubsign% THEN
IF LEFT$(addsubx1$, 1) = "-" THEN addsubx1$ = MID$(addsubx1$, 2) ELSE addsubx1$ = "-" + addsubx1$
END IF
stringmatha$ = addsubx1$: addsubx1$ = ""
IF operationdivision% THEN RETURN
stringmathb$ = stringmatha$: stringmatha$ = ""
IF LEFT$(stringmathb$, 1) = "-" THEN
stringmathb$ = MID$(stringmathb$, 2)
n2sign$ = "-"
ELSE
n2sign$ = ""
END IF
GOSUB limit_round_convert
IF stringmathb$ = "overflow" THEN n2sign$ = "": EXIT SUB
GOSUB sm_converter
runningtotal$ = n2sign$ + stringmathb$: n2sign$ = ""
CASE "*"
string_multiply:
fac1$ = stringmatha$: fac2$ = stringmathb$ ' Make numbers whole numbers and remove any - sign.
IF LEFT$(fac1$, 1) = "-" THEN fac1$ = MID$(fac1$, 2): m_sign% = -1
IF LEFT$(fac2$, 1) = "-" THEN fac2$ = MID$(fac2$, 2): IF m_sign% THEN m_sign% = 0 ELSE m_sign% = -1
IF INSTR(fac1$, ".") <> 0 THEN m_decimal_places& = LEN(fac1$) - INSTR(fac1$, "."): fac1$ = MID$(fac1$, 1, INSTR(fac1$, ".") - 1) + MID$(fac1$, INSTR(fac1$, ".") + 1)
IF INSTR(fac2$, ".") <> 0 THEN m_decimal_places& = m_decimal_places& + LEN(fac2$) - INSTR(fac2$, "."): fac2$ = MID$(fac2$, 1, INSTR(fac2$, ".") - 1) + MID$(fac2$, INSTR(fac2$, ".") + 1)
FOR m_i& = LEN(fac2$) TO 1 STEP -1 ' Multiply each charter top and bottom.
m_k& = m_l&
m_x2$ = MID$(fac2$, m_i&, 1)
FOR m_j& = LEN(fac1$) TO 1 STEP -1
m_x1$ = MID$(fac1$, m_j&, 1)
IF m_product$ <> "" THEN
m_add$ = LTRIM$(STR$(VAL(m_x1$) * VAL(m_x2$))) + STRING$(m_k&, "0")
m_t& = 0: m_xproduct$ = "": m_carry% = 0
DO ' Add multiplied characters together.
m_x3$ = MID$(m_add$, LEN(m_add$) - m_t&, 1)
m_x4$ = MID$(m_product$, LEN(m_product$) - m_t&, 1)
IF m_x3$ = "" AND m_x4$ = "" THEN
IF m_carry% THEN m_xproduct$ = "1" + m_xproduct$
EXIT DO
END IF
m_g% = VAL(m_x3$) + VAL(m_x4$) + m_carry%
IF m_g% >= 10 THEN m_g% = m_g% - 10: m_carry% = 1 ELSE m_carry% = 0
m_xproduct$ = LTRIM$(STR$(m_g%)) + m_xproduct$
m_t& = m_t& + 1
LOOP
m_product$ = m_xproduct$: m_xproduct$ = ""
ELSE
m_product$ = LTRIM$(STR$(VAL(m_x1$) * VAL(m_x2$))) + STRING$(m_k&, "0") ' First loop makes variable here.
END IF
m_k& = m_k& + 1 ' Adds trailing zeros multiplication
NEXT
m_l& = m_l& + 1 ' Used to reset value for m_k& adding one trailing zer for each loop.
NEXT
fac1$ = "": fac2$ = "": m_l& = 0: m_k& = 0: m_t& = 0
IF m_decimal_places& > LEN(m_product$) THEN m_product$ = STRING$(m_decimal_places& - LEN(m_product$), "0") + m_product$ ' Add any leading zeros to a decimal. Ex: .02 * .01 is factored as 002. It needs one leading zero before adding the decimal point, .0002.
IF m_decimal_places& AND m_product$ <> "0" THEN ' Replace any decimal point.
m_product$ = MID$(m_product$, 1, LEN(m_product$) - m_decimal_places&) + "." + MID$(m_product$, LEN(m_product$) - m_decimal_places& + 1)
END IF
DO UNTIL LEFT$(m_product$, 1) <> "0" ' Remove leading zeros.
m_product$ = MID$(m_product$, 2)
LOOP
IF m_decimal_places& THEN
DO UNTIL RIGHT$(m_product$, 1) <> "0" ' Remove trailing zeros in a decimal sum.
m_product$ = MID$(m_product$, 1, LEN(m_product$) - 1)
LOOP
END IF
IF m_product$ = "" THEN m_product$ = "0": m_sign% = 0
IF RIGHT$(m_product$, 1) = "." THEN m_product$ = MID$(m_product$, 1, LEN(m_product$) - 1) ' Remove decimal from the end of an integer total.
IF operationdivision% THEN m_sign% = 0: RETURN
stringmathb$ = m_product$: m_product$ = "": GOSUB limit_round_convert
IF stringmathb$ = "overflow" THEN EXIT SUB
GOSUB sm_converter
runningtotal$ = stringmathb$: stringmathb$ = ""
IF m_sign% THEN runningtotal$ = "-" + runningtotal$: m_sign% = 0
CASE "/"
operationdivision% = -1
divbuffer& = LEN(stringmathb$) - LEN(stringmatha$)
IF divbuffer& < 0 THEN divbuffer& = 0
d2dividend$ = stringmatha$
d1divisor$ = stringmathb$
IF LEFT$(d1divisor$, 1) = "0" AND LEN(d1divisor$) = 1 THEN PRINT "Division by zero not allowed.": END
IF LEFT$(d1divisor$, 1) = "-" THEN divsign% = -1: d1divisor$ = MID$(d1divisor$, 2)
IF LEFT$(d2dividend$, 1) = "-" THEN
IF divsign% THEN
divsign% = 0
ELSE
divsign% = -1
END IF
d2dividend$ = MID$(d2dividend$, 2)
END IF
IF INSTR(d1divisor$, ".") <> 0 THEN
DO UNTIL RIGHT$(d1divisor$, 1) <> "0"
d1divisor$ = MID$(d1divisor$, 1, LEN(d1divisor$) - 1) ' Strip off trailing zeros
LOOP
divplace& = LEN(d1divisor$) - INSTR(d1divisor$, ".")
d1divisor$ = MID$(d1divisor$, 1, INSTR(d1divisor$, ".") - 1) + MID$(d1divisor$, INSTR(d1divisor$, ".") + 1) ' Strip off decimal point.
DO UNTIL LEFT$(d1divisor$, 1) <> "0"
d1divisor$ = MID$(d1divisor$, 2) ' Strip off leading zeros for divisors smaller than .1
LOOP
END IF
IF INSTR(d2dividend$, ".") <> 0 THEN
d2dividend$ = d2dividend$ + STRING$(divplace& - LEN(d2dividend$) - INSTR(d2dividend$, "."), "0") ' Add any zeros based on the length of dividend at decimal - length of divisor at decimal. If less than zero, nothing added.
divplace2& = INSTR(d2dividend$, ".")
DO UNTIL RIGHT$(d2dividend$, 1) <> "0"
d2dividend$ = MID$(d2dividend$, 1, LEN(d2dividend$) - 1) ' Strip off trailing zeros
LOOP
d2dividend$ = MID$(d2dividend$, 1, INSTR(d2dividend$, ".") - 1) + MID$(d2dividend$, INSTR(d2dividend$, ".") + 1) ' Strip off decimal point.
ELSE
d2dividend$ = d2dividend$ + STRING$(divplace&, "0") ' Add any zeros based on the length of dividend at decimal - length of divisor at decimal. If less than zero, nothing added.
divplace& = 0
END IF
DO
DO
divremainder& = divremainder& + 1: divremainder$ = divremainder$ + MID$(d2dividend$, divremainder&, 1)
IF MID$(d2dividend$, divremainder&, 1) = "" THEN
IF divremainder$ = STRING$(LEN(divremainder$), "0") AND LEN(quotient$) > LEN(d2dividend$) THEN divflag% = -1: EXIT DO
divcarry& = divcarry& + 1
IF divcarry& = 1 THEN divplace3& = divremainder& - 1
IF divcarry& > limit&& + 1 + divbuffer& THEN
divflag% = -2: EXIT DO
END IF
divremainder$ = divremainder$ + "0" ' No more digits to bring down.
END IF
IF LEN(divremainder$) > LEN(d1divisor$) OR LEN(divremainder$) = LEN(d1divisor$) AND divremainder$ >= d1divisor$ THEN EXIT DO
quotient$ = quotient$ + "0"
LOOP
IF divflag% THEN divflag% = 0: EXIT DO
FOR div_i% = 9 TO 1 STEP -1
stringmatha$ = LTRIM$(STR$(div_i%)): stringmathb$ = d1divisor$
m_product$ = "": GOSUB string_multiply
tempcutd$ = divremainder$ ' divremainder$ can be 00 or other leading zero values.
DO
IF LEN(tempcutd$) = 1 THEN EXIT DO
IF LEFT$(tempcutd$, 1) = "0" THEN
tempcutd$ = MID$(tempcutd$, 2)
ELSE
EXIT DO
END IF
LOOP
IF LEN(tempcutd$) > LEN(m_product$) OR LEN(tempcutd$) = LEN(m_product$) AND m_product$ <= tempcutd$ THEN EXIT FOR
NEXT
quotient$ = quotient$ + LTRIM$(STR$(div_i%))
stringmatha$ = LTRIM$(STR$(div_i%)): stringmathb$ = d1divisor$
m_product$ = "": GOSUB string_multiply
operator$ = "-"
stringmatha$ = divremainder$
stringmathb$ = m_product$
GOSUB string_add_subtract
divremainder$ = stringmatha$
operator$ = "/"
LOOP
IF divplace& = 0 AND divplace2& = 0 THEN divplace& = divplace3&
IF divplace2& THEN divplace& = divplace& + divplace2& - 1
IF quotient$ = "" THEN divplace& = 0 ' dividend is zero.
IF divplace& OR divplace2& THEN
quotient$ = MID$(quotient$, 1, divplace&) + "." + MID$(quotient$, divplace& + 1)
DO UNTIL RIGHT$(quotient$, 1) <> "0"
quotient$ = MID$(quotient$, 1, LEN(quotient$) - 1) ' Strip off trailing zeros
LOOP
IF RIGHT$(quotient$, 1) = "." THEN quotient$ = MID$(quotient$, 1, LEN(quotient$) - 1) ' Strip off abandoned decimal.
END IF
DO UNTIL LEFT$(quotient$, 1) <> "0"
quotient$ = MID$(quotient$, 2) ' Strip off leading zeros
LOOP
IF quotient$ = "" THEN quotient$ = "0": divsign% = 0
operationdivision% = 0
stringmathb$ = quotient$: quotient$ = "": GOSUB limit_round_convert
IF stringmathb$ = "overflow" THEN divsign% = 0: EXIT SUB
GOSUB sm_converter
runningtotal$ = stringmathb$: stringmathb$ = ""
IF divsign% THEN runningtotal$ = "-" + runningtotal$
END SELECT
IF stringmathround$ <> "" THEN runningtotal$ = runningtotal$ + stringmathround$
EXIT SUB
validate_string_number:
vsn_negcnt& = 0: vsn_poscnt& = 0: vsn_depresent& = 0: decimalcnt& = 0: vsn_numberpresent& = 0: vsn_zerospresent& = 0
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2): sm_sign$ = "-" ELSE sm_sign$ = ""
IF LEFT$(stringmathb$, 1) = "+" THEN IF sm_sign$ <> "-" THEN stringmathb$ = MID$(stringmathb$, 2) ELSE stringmathb$ = "invalid number": RETURN
IF INSTR(UCASE$(stringmathb$), "D") OR INSTR(UCASE$(stringmathb$), "E") THEN ' Evaluate for Scientific Notation.
FOR sm_i& = 1 TO LEN(stringmathb$)
validatenum$ = MID$(UCASE$(stringmathb$), sm_i&, 1)
SELECT CASE validatenum$
CASE "+"
IF vsn_depresent& THEN vsn_poscnt& = vsn_poscnt& + 1 ELSE stringmathb$ = "invalid number": RETURN
CASE "-"
IF vsn_depresent& THEN vsn_negcnt& = vsn_negcnt& + 1 ELSE stringmathb$ = "invalid number": RETURN
CASE "0" TO "9"
vsn_numberpresent& = -1
CASE "D", "E"
vsn_depresent& = vsn_depresent& + 1
IF decimalcnt& = 0 AND sm_i& <> 2 OR vsn_depresent& > 1 OR vsn_numberpresent& = 0 OR vsn_negcnt& > 1 OR vsn_poscnt& > 1 OR vsn_negcnt& = 1 AND vsn_poscnt& >= 1 THEN vsn_numberpresent& = 0: EXIT FOR
vsn_numberpresent& = 0
MID$(stringmathb$, sm_i&, 1) = "e" ' Standardize
CASE "."
decimalcnt& = decimalcnt& + 1
IF sm_i& <> 2 THEN vsn_numberpresent& = 0: EXIT FOR
CASE ELSE
vsn_numberpresent& = 0: EXIT FOR
END SELECT
NEXT
IF decimalcnt& = 0 THEN stringmathb$ = MID$(stringmathb$, 1, 1) + "." + MID$(stringmathb$, 2) ' Standardize "."
IF vsn_numberpresent& = 0 OR vsn_negcnt& = 1 AND vsn_poscnt& = 1 OR decimalcnt& > 1 OR INSTR(stringmathb$, ".") <> 2 THEN stringmathb$ = "invalid number": RETURN
vsn_depresent& = INSTR(stringmathb$, "e")
sm_x$ = MID$(stringmathb$, vsn_depresent& + 1, 1) ' Standardize exponent "+" these two lines.
IF sm_x$ <> "+" AND sm_x$ <> "-" THEN stringmathb$ = MID$(stringmathb$, 1, vsn_depresent&) + "+" + MID$(stringmathb$, vsn_depresent& + 1)
IF MID$(stringmathb$, vsn_depresent& + 2, 1) = "0" THEN
IF MID$(stringmathb$, vsn_depresent& + 3, 1) <> "" THEN stringmathb$ = "invalid number": RETURN ' No leading zeros allowed in exponent notation.
END IF
jjed& = INSTR(stringmathb$, "e") ' Get position of notation.
valexpside$ = MID$(stringmathb$, jjed&) ' These two lines break up into number and notation
stringmathb$ = MID$(stringmathb$, 1, jjed& - 1) ' stringmathb$ is +- single digit whole number, decimal point and decimal number. valexpside$ is notation, sign and exponent.
DO UNTIL RIGHT$(stringmathb$, 1) <> "0" ' Remove any trailing zeros for number. Example 1.0d3 or 1.0000d3, etc.
stringmathb$ = MID$(stringmathb$, 1, LEN(stringmathb$) - 1)
LOOP
IF VAL(MID$(stringmathb$, 1, INSTR(stringmathb$, ".") - 1)) = 0 THEN
IF RIGHT$(stringmathb$, 1) = "." THEN
stringmathb$ = "0.e+0" ' Handles all types of zero entries.
ELSE
stringmathb$ = "invalid number": RETURN
END IF
RETURN
END IF
stringmathb$ = sm_sign$ + stringmathb$ + valexpside$
RETURN
ELSE
FOR sm_i& = 1 TO LEN(stringmathb$)
validatenum$ = MID$(stringmathb$, sm_i&, 1)
SELECT CASE validatenum$
CASE "."
decimalcnt& = decimalcnt& + 1
CASE "0"
vsn_zerospresent& = -1
CASE "1" TO "9"
vsn_numberpresent& = -1
CASE "$"
CASE ELSE
stringmathb$ = "invalid number": RETURN
END SELECT
NEXT
IF decimalcnt& > 1 OR vsn_negcnt& > 1 OR vsn_poscnt& > 1 OR vsn_negcnt& >= 1 AND vsn_poscnt& >= 1 THEN
stringmathb$ = "invalid number": RETURN
END IF
IF INSTR(stringmathb$, "$") THEN GOSUB currency_validate
IF INSTR(stringmathb$, ",") THEN
GOSUB comma_validation
IF stringmathb$ = "invalid number" THEN RETURN
GOSUB comma_removal
END IF
IF RIGHT$(stringmathb$, 1) = "." THEN stringmathb$ = MID$(stringmathb$, 1, LEN(stringmathb$) - 1)
DO UNTIL LEFT$(stringmathb$, 1) <> "0" ' Strip off any leading zeros.
stringmathb$ = MID$(stringmathb$, 2)
LOOP
stringmathb$ = sm_sign$ + stringmathb$
IF INSTR(stringmathb$, ".") THEN
DO UNTIL RIGHT$(stringmathb$, 1) <> "0" ' Strip off any trailing zeros in a decimal.
stringmathb$ = MID$(stringmathb$, 1, LEN(stringmathb$) - 1)
LOOP
END IF
IF RIGHT$(stringmathb$, 1) = "." THEN stringmathb$ = MID$(stringmathb$, 1, LEN(stringmathb$) - 1)
IF vsn_numberpresent& = 0 THEN
IF vsn_zerospresent& THEN
stringmathb$ = "0"
ELSE
stringmathb$ = "invalid number"
END IF
END IF
END IF
RETURN
' Convert to commas, currency, S.N., etc.
sm_converter:
IF comma_display% THEN GOSUB comma_placement
IF currency_display% THEN GOSUB currency_convert
IF snconvert% THEN GOSUB numeric_to_scientific
RETURN
' Add in commas.
comma_placement:
GOSUB comma_prep
sm_i& = 0: sm_j& = 0: sm_seed& = 0
sm_seed& = LEN(temp_stringmathb1$) MOD 3: IF sm_seed& = 0 THEN sm_seed& = 3
sm_m1& = LEN(temp_stringmathb1$)
sm_m2& = (LEN(temp_stringmathb1$) - 1) \ 3
sm_replace$ = SPACE$(sm_m1& + sm_m2&)
DO WHILE sm_i& < sm_m1&
MID$(sm_replace$, sm_j& + 1, sm_seed& + 1) = MID$(temp_stringmathb1$, sm_i& + 1, sm_seed&) + ","
sm_i& = sm_i& + sm_seed&: sm_j& = sm_j& + sm_seed& + 1: sm_seed& = 3
LOOP
sm_replace$ = RTRIM$(sm_replace$)
IF RIGHT$(sm_replace$, 1) = "," THEN
stringmathb$ = MID$(sm_replace$, 1, LEN(sm_replace$) - 1)
ELSE
stringmathb$ = sm_replace$
END IF
sm_replace$ = "": temp_stringmathb1$ = ""
RETURN
' Validate comma entry.
comma_validation:
GOSUB comma_prep
IF INSTR(temp_stringmathb2$, ",") <> 0 OR temp_stringmathb1$ = STRING$(LEN(temp_stringmathb1$), ",") THEN
stringmathb$ = "invalid number" ' Decimal part has comma or entry is all commas.
ELSE
FOR sm_i& = LEN(temp_stringmathb1$) TO 1 STEP -1
sm_j% = sm_j% + 1
IF sm_j% = 4 THEN
IF MID$(temp_stringmathb1$, sm_i&, 1) <> "," THEN stringmathb$ = "invalid number": EXIT FOR
sm_j% = 0
END IF
NEXT
IF stringmathb$ <> "invalid number" THEN
stringmathb$ = sm_sign$ + temp_stringmathb1$ + temp_stringmathb2$
END IF
END IF
temp_stringmathb1$ = "": temp_stringmathb2$ = "": sm_i& = 0: sm_j% = 0: sm_sign$ = "": sm_dollar$ = ""
RETURN
comma_removal:
sm_i& = 0: sm_j& = 0: sm_seed& = 0
sm_replace$ = SPACE$(LEN(stringmathb$))
DO
sm_i& = INSTR(sm_seed& + 1, stringmathb$, ",")
IF sm_i& = 0 THEN EXIT DO
MID$(sm_replace$, sm_j& + 1, sm_i& - sm_seed& + 1) = MID$(stringmathb$, sm_seed& + 1, sm_i& - sm_seed& - 1)
sm_j& = sm_j& + sm_i& - sm_seed& - 1
sm_seed& = sm_i&
LOOP
stringmathb$ = RTRIM$(sm_replace$) + MID$(stringmathb$, sm_seed& + 1): sm_replace$ = ""
RETURN
comma_prep:
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2): sm_sign$ = "-"
temp_stringmathb1$ = stringmathb$: stringmathb$ = ""
IF INSTR(temp_stringmathb1$, ".") THEN
temp_stringmathb2$ = MID$(temp_stringmathb1$, INSTR(temp_stringmathb1$, ".")) ' Decimal part
temp_stringmathb1$ = MID$(temp_stringmathb1$, 1, INSTR(temp_stringmathb1$, ".") - 1) ' Non-decimal part
END IF
IF LEFT$(temp_stringmathb1$, 1) = "$" THEN temp_stringmathb1$ = MID$(temp_stringmathb1$, 2): sm_dollar$ = "$"
RETURN
currency_validate:
IF LEFT$(stringmathb$, 2) = "$-" OR LEFT$(stringmathb$, 2) = "$+" THEN stringmathb$ = "invalid number": RETURN
IF LEFT$(stringmathb$, 1) = "$" THEN stringmathb$ = MID$(stringmathb$, 2)
IF INSTR(stringmathb$, "$") THEN stringmathb$ = "invalid number": RETURN
sm_dollar$ = "$"
RETURN
currency_convert:
IF INSTR(UCASE$(stringmathb$), "D") <> 0 OR INSTR(UCASE$(stringmathb$), "E") <> 0 THEN GOSUB scientific_to_numeric
IF INSTR(stringmathb$, ",") = 0 THEN GOSUB comma_placement
IF INSTR(stringmathb$, ".") = 0 THEN stringmathb$ = stringmathb$ + ".00"
IF RIGHT$(stringmathb$, 1) = "." THEN stringmathb$ = stringmathb$ + "00"
IF MID$(stringmathb$, LEN(stringmathb$) - 2, 1) <> "." THEN stringmathb$ = stringmathb$ + "0"
IF MID$(stringmathb$, LEN(stringmathb$) - 2, 1) <> "." THEN stringmathb$ = "invalid number": RETURN
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
stringmathb$ = sm_sign$ + "$" + stringmathb$
RETURN
numeric_to_scientific:
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2): n2sign$ = "-"
IF INSTR(stringmathb$, ".") = 0 THEN exponentvalue&& = LEN(stringmathb$) - 1 ELSE exponentvalue&& = INSTR(stringmathb$, ".") - 2 ' Exponent is one less than number of digits for whole number an two less than the placement of the decimal point for a fraction.
stringmathb$ = MID$(stringmathb$, 1, INSTR(stringmathb$, ".") - 1) + MID$(stringmathb$, INSTR(stringmathb$, ".") + 1)
IF LEFT$(stringmathb$, 1) = "0" AND LEN(stringmathb$) > 1 OR exponentvalue&& = -1 THEN
DO UNTIL LEFT$(stringmathb$, 1) <> "0" ' Remove leading zeros to consider rounding.
stringmathb$ = MID$(stringmathb$, 2)
exponentvalue&& = exponentvalue&& - 1
LOOP
esign$ = "-"
ELSE
esign$ = "+"
END IF
DO UNTIL RIGHT$(stringmathb$, 1) <> "0" ' Remove trailing zeros.
stringmathb$ = MID$(stringmathb$, 1, LEN(stringmathb$) - 1)
LOOP
IF stringmathb$ = "" THEN stringmathb$ = "0": esign$ = "+": exponentvalue&& = 0
stringmathb$ = LEFT$(stringmathb$, 1) + "." + MID$(stringmathb$, 2)
IF stringmathb$ = "0." THEN n2sign$ = "": esign$ = "+"
stringmathb$ = stringmathb$ + "e" + esign$ + LTRIM$(STR$(ABS(exponentvalue&&))) ' S.N formed here.
IF stringmathb$ <> "overflow" THEN
stringmathb$ = n2sign$ + stringmathb$
END IF
n2sign$ = "": esign$ = "": exponentvalue&& = 0
RETURN
scientific_to_numeric:
IF INSTR(UCASE$(stringmathb$), "D") THEN MID$(stringmathb$, INSTR(UCASE$(stringmathb$), "D"), 1) = "e"
IF MID$(stringmathb$, INSTR(stringmathb$, "e") + 2) = "0" THEN ' The numeric value is the number without the zero exponent.
stringmathb$ = MID$(stringmathb$, 1, INSTR(stringmathb$, "e") - 1)
IF RIGHT$(stringmathb$, 1) = "." THEN stringmathb$ = MID$(stringmathb$, 1, LEN(stringmathb$) - 1)
RETURN
ELSE
IF LEFT$(stringmathb$, 1) = "-" THEN stn_sign$ = "-": stringmathb$ = MID$(stringmathb$, 2)
stringmathb$ = MID$(stringmathb$, 1, INSTR(stringmathb$, ".") - 1) + MID$(stringmathb$, INSTR(stringmathb$, ".") + 1) ' Remove decimal point.
stn_i& = INSTR(stringmathb$, "e") - 1 ' Length of the numric part.
IF MID$(stringmathb$, INSTR(stringmathb$, "e") + 1, 1) = "-" THEN
stringmathb$ = "." + STRING$(VAL(MID$(stringmathb$, stn_i& + 3)) - 1, "0") + MID$(stringmathb$, 1, stn_i&) ' Decimal point followed by exponent value in zeros added in front of numeric part.
ELSE
IF stn_i& - 1 > VAL(MID$(stringmathb$, stn_i& + 3)) THEN stn_point$ = "." ' - 1 for decimal place. Ex 2.034d+2 is 2034 here where 3 places to the right . could be moved before . disappears. > so no trailing decimal results.
stringmathb$ = MID$(MID$(stringmathb$, 1, stn_i&), 1, VAL(MID$(stringmathb$, stn_i& + 3)) + 1) + stn_point$ + MID$(MID$(stringmathb$, 1, stn_i&), VAL(MID$(stringmathb$, stn_i& + 3)) + 2, stn_i& - VAL(MID$(stringmathb$, stn_i& + 3)) - 1) + STRING$(VAL(MID$(stringmathb$, stn_i& + 2)) - (stn_i& - 1), "0")
END IF
END IF
IF stringmathb$ = "0" THEN stn_sign$ = ""
stringmathb$ = stn_sign$ + stringmathb$
stn_sign$ = "": stn_point$ = ""
RETURN
limit_round_convert:
' Try SN if whole number is too large (as it may be trailing zeros) or decimal is beyond limit.
IF LEFT$(stringmathb$, 2) = ".0" AND LEN(stringmathb$) > limit&& + 1 OR INSTR(stringmathb$, ".") > limit&& + 1 OR INSTR(stringmathb$, ".") = 0 AND LEN(stringmathb$) > limit&& THEN
IF limit&& > 1 THEN
GOSUB numeric_to_scientific ' Retry as S.N.
IF LEN(stringmathb$) > limit&& + 3 THEN ' Needs rounding.
snotation$ = MID$(stringmathb$, INSTR(UCASE$(stringmathb$), "E"))
exponentvalue&& = VAL(MID$(snotation$, 2)) ' Get positive or negative sign.
snexponent$ = MID$(stringmathb$, INSTR(UCASE$(stringmathb$), "E") + 2)
stringmathb$ = MID$(stringmathb$, 1, INSTR(UCASE$(stringmathb$), "E") - 1)
'''IF LEN(stringmathb$) + LEN(snexponent$) > limit&& + 1 AND exponentvalue&& >= limit&& THEN BEEP
IF exponentvalue&& >= limit&& THEN
stringmathb$ = MID$(stringmathb$, 1, exponentvalue&& + 3)
ELSE
stringmathb$ = MID$(stringmathb$, 1, limit&& - LEN(snexponent$) + 2)
END IF
GOSUB string_rounding_method
IF LEFT$(stringmathb$, 3) = "10." THEN
stringmathb$ = "1." + MID$(stringmathb$, 4)
' Add one to the exponent.
FOR round_i& = LEN(snexponent$) TO 1 STEP -1
round_x$ = CHR$(ASC(MID$(snexponent$, round_i&, 1)) + 1)
IF round_x$ <> CHR$(47) THEN ' Decimal point + 1. Ignore.
IF round_x$ = CHR$(58) THEN
MID$(snexponent$, round_i&, 1) = "0": carry$ = "1"
ELSE
MID$(snexponent$, round_i&, 1) = round_x$: carry$ = "": EXIT FOR
END IF
END IF
NEXT
snexponent$ = carry$ + snexponent$: carry$ = ""
END IF
stringmathb$ = stringmathb$ + MID$(snotation$, 1, 2) + snexponent$
IF LEN(snexponent$) + LEN(MID$(stringmathb$, 1, INSTR(UCASE$(stringmathb$), "E") - 1)) > limit&& + 1 THEN
stringmathb$ = "overflow"
END IF
exponentvalue&& = 0
END IF
ELSE
IF INSTR(stringmathb$, ".") > 0 AND INSTR(stringmathb$, ".") <= limit&& THEN
stringmathb$ = MID$(stringmathb$, 1, limit&& + 2)
IF round_total% = -1 AND RIGHT$(stringmathb$, 1) > "4" THEN
GOSUB string_rounding_method
ELSE
stringmathb$ = MID$(stringmathb$, 1, limit&& + 1)
IF show_rounding% THEN stringmathround$ = "r"
END IF
ELSE
stringmathb$ = "overflow"
END IF
END IF
RETURN
END IF
IF LEN(stringmathb$) > limit&& AND INSTR(stringmathb$, ".") = 0 OR LEN(stringmathb$) > limit&& + 1 AND INSTR(stringmathb$, ".") <> 0 THEN
IF INSTR(stringmathb$, ".") = 0 THEN
stringmathb$ = MID$(stringmathb$, 1, limit&& + 1)
ELSE
stringmathb$ = MID$(stringmathb$, 1, limit&& + 2)
END IF
GOSUB string_rounding_method
IF LEN(stringmathb$) > limit&& + lrc_decimalpoint& THEN ' Ex: limit&& = 4 9999.9 1.e+4
GOSUB numeric_to_scientific
ELSE
IF LEN(stringmathb$) > limit&& + lrc_decimalpoint& THEN stringmathb$ = "overflow"
END IF
END IF
RETURN
replace_decimal:
IF addsubplace& THEN
addsubx1$ = STRING$(addsubplace& - LEN(addsubx1$), "0") + addsubx1$
addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - addsubplace&) + "." + MID$(addsubx1$, LEN(addsubx1$) - addsubplace& + 1)
DO UNTIL RIGHT$(addsubx1$, 1) <> "0" ' Remove trailing zeros in a decimal sum.
addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - 1)
addsubplace& = addsubplace& - 1
LOOP
IF RIGHT$(addsubx1$, 1) = "." THEN addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - 1) ' Number is now an integer.
END IF
RETURN
string_rounding_method:
IF INSTR(stringmathb$, ".") THEN lrc_decimalpoint& = 1 ELSE lrc_decimalpoint& = 0
IF MID$(stringmathb$, LEN(stringmathb$), 1) > "4" THEN
FOR round_i& = LEN(stringmathb$) - 1 TO 1 STEP -1
round_x$ = CHR$(ASC(MID$(stringmathb$, round_i&, 1)) + 1)
IF round_x$ <> CHR$(47) THEN ' Decimal point + 1. Ignore.
IF round_x$ = CHR$(58) THEN
MID$(stringmathb$, round_i&, 1) = "0": carry$ = "1"
ELSE
MID$(stringmathb$, round_i&, 1) = round_x$: carry$ = "": EXIT FOR
END IF
END IF
NEXT
stringmathb$ = carry$ + MID$(stringmathb$, 1, LEN(stringmathb$) - 1): carry$ = ""
IF show_rounding% THEN stringmathround$ = "R"
ELSE
stringmathb$ = MID$(stringmathb$, 1, LEN(stringmathb$) - 1)
IF show_rounding% THEN stringmathround$ = "r"
END IF
IF lrc_decimalpoint& THEN
DO UNTIL RIGHT$(stringmathb$, 1) <> "0"
stringmathb$ = MID$(stringmathb$, 1, LEN(stringmathb$) - 1)
LOOP
IF stringmathb$ = "" OR stringmathb$ = "." THEN stringmathb$ = "0": lrc_decimalpoint& = 0
IF RIGHT$(stringmathb$, 1) = "." AND exponentvalue&& = 0 THEN
stringmathb$ = MID$(stringmathb$, 1, LEN(stringmathb$) - 1): lrc_decimalpoint& = 0
END IF
END IF
RETURN
END SUBLimit Display - Input how many digits you want displayed to the screen.
Use Rounding Y/N - Sef explanitory.
Display in Scientitic Notation Y/N - Sef explanitory.
Display in Dollars and Cents Y/N - Sef explanitory.
Display Results with Commas Y/N- Sef explanitory.
Number - Input the first number. It will give a validation message after input.
Operator +-/* - Input the symbol to add, subtract, divide, or multiply.
Number - Input the nextnumber to complete the operation. It ouputs both the numeric and string answer.
Pete
RE: Treebeard's String-Math - Pete - 07-28-2022
@Jack
Very cool!
That's meaningful. It shows the design was made to simply call the appropriate sub-routine. Honestly, that first demo didn't address practical usage, but this one does.
Thanks!
Pete
RE: Treebeard's String-Math - James D Jarvis - 07-28-2022
(07-28-2022, 04:02 PM)Pete Wrote: I put this together a few years back for +-?* strimg math routines.
What I didn't include was a way to carry repeating decimals (repetends). So 1 / 3 * 3 will result in .9... instead of 1, just as .3... * 3 would result in .9...
So I would consider it unfinished for use in a calculator.
still interesting, thanks for sharing. I'm using right shifting and left shifting to handle division and multiplication as much as possible, just using base 10 instead of binary. My code still is buggy and not clean enough to share yet.
RE: Treebeard's String-Math - Kernelpanic - 07-29-2022
@Jack - Your first version reminds me of the Fibonacci sequence:
Code: (Select All)
'Fibonaccizahl - 29. Juli 2022
'https://de.wikipedia.org/wiki/Fibonacci-Folge
'https://en.wikipedia.org/wiki/Fibonacci_number
Option _Explicit
Dim x, y As Long
Dim i, n As Integer
x = 1: y = 1: i = 1
Cls
Locate 3, 3
Print "Berechnet iterativ die Fibonaccizahl."
Locate 5, 3
Input "Geben Sie eine Zahl ein: ", n
Locate 7, 3
If n > 33 Then
Print "Nur Eingaben bis 33!"
GoTo Ende
End If
If n = 0 Then
Print Using "Die Fibonaccizahl von # ist: #"; n, 1
GoTo Ende
ElseIf n = 1 Then
Print Using "Die Fibonaccizahl von # ist: #"; n, 1
GoTo Ende
ElseIf n = 2 Then
Print Using "Die Fibonaccizahl von # ist: 1 1 #"; n, n
GoTo Ende
End If
If n > 2 Then
Print "0 1 1 ";
While i < n
x = x + y: y = x - y: i = i + 1
Print " "; x;
Wend
End If
Print: Print
Locate , 3
Print Using "Die Fibonaccizahl von ## ist: ###,#####"; n, x
Ende:
End