03-31-2025, 10:43 PM
Oh I have a String Math set too with extended Addition, Subtraction, Multiplication and Division that you set how far to go with decimals. Also has SqrRoot and my version of Bin2Dec$ and Dec2Bin$
This code is loaded with tests including for timing extended factorials and how many fibanocci terms are in the inverse of STx Number.
This code is loaded with tests including for timing extended factorials and how many fibanocci terms are in the inverse of STx Number.
Code: (Select All)
Option _Explicit
_Title "String Math Fix Mr$ add co 2023-10-15" ' b+ 2023-10-15
' starting from "String Math Powers 2022-09-22" ' b+ try to do powers with string math
' directly from "String Math 2021-06-14" ' b+ from SM2 (2021 June)
' a bunch of experiments to fix and improve speeds.
' June 2021 fix some old String Math procedures, better nInverse with new LT frunction,
' remove experimental procedures.
' Now with decent sqrRoot it works independent of Mr$() = Math Regulator that handles signs
' and decimals and calls to add$(), subtr$, mult$, divide$ (100 significant digits)
' add$(), subtr$, mult$ are exact!
' If you need higher precsion divide, I recommend use nInverse on denominator (integer)
' then add sign and decimal and mult$() that number with numerator to get divsion answer
' in higher precision than 100.
' (See how Mr$() handles division and just call nInverse$ with what precision you need.)
' The final function showDP$() is for displaying these number to a set amount of Decimal Places.
' The main code is sampler of tests performed with these functions.
' 2022-09-22 a little fix to MR$ for Function change versions QB64 v2.0+
' Attempt to do Powers with SQRs of 2 Multipliers
' needs to be able to convert a number into a binary String
' might also need a Table setup for nested SQR's of 2
' needs a decent BigSQR$ string function for SQR
' 2022-09-25 this is one frustration after another LT does not work for strings??? but < does?
' try some more with BigSQR concentrate on Integer part first, just get that right
' 2022-09-26 Bin2Dec$ Function seems OK
' 2022-09-30 current status using new nLn$ for natural logs in string math calculation
' and eToTheX$ for raising e to some x power, power$ then is x^y = e^(y*ln(x)) in String math functions.
' Started using ShowDP$ to eliminate excess digits so calculations don't hang up all day long...
' 2023-10-15 Maybe a week ago I was working on updating FVal$ with oh functions and oh with new
' FVal$ functions and I was testing some routines, oh I was adding extended math routines from
' code here and testing with FVal$ functions when I discovered a horrible bug with extended Add
' from Mr$. It was a shock! I've been using extended Math from here for couple years on and off
' and now I find that Mr$ drops the decimal when adding!? I think it's just when the carry over
' extends all the way left to needing to add a digit. I was able to fix add through Mr$ when I
' isolated it from Subtract and other functions but I need Mr$ to handle all 4 math ops because
' I don't want to write new code for each one (I don't think... hmm? Just one of the many debates
' I've had with myself since reopening this old code back up again.)
'
' And maybe I should keep code notes in a separate file once they reach the length this one has!
' 2023-10-22 I ran some old tests from SM2
' 2023-10-23 today I found old code to test the 4 main math ops from Mr$ calls
' This is code that should have caught that addition problem from years ago. I must have changed
' code since to screw it up the way I found it this year. Anyway I want to take anoth shot of
' tons of random testing!
$Console:Only
Width 125
Randomize Timer
'Dim r$, ruler$ not sure we need ruler$
'ruler$ = "123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" + Chr$(10)
'ruler$ = ruler$ + " 1 2 3 4 5 6 7 8 9 10 11 12"
'Print ruler$
'2023-10-15 here is the new problem code! Where are the decimals?
Print mr$("-.0000000002", "+", "-.9999999998") ' 1 and 10 0's shit! fixed! = 1
Print mr$("-.2", "+", "-.8") ' 10 shit! what happened? was this always here? fixed = 1
' ===================================== old tests from SM2 2021
' jack error reported 2021-06-04 confirmed! fixed
'Print "0.00000000000000000000000000000000000000000000200000000000000054307978001764"; " Plus"
'Print "-.000000000000000000000000000000000000000000002"; " is = "
'Print ".00000000000000000000000000000000000000000000000000000000000054307978001764"
'Print mr$(".00000000000000000000000000000000000000000000200000000000000054307978001764", "+", "-.000000000000000000000000000000000000000000002")
'Print
'Print ".00000000000000000000000000000000000000000000200000000000000054307978001764"; " Minus"
'Print ".000000000000000000000000000000000000000000002"; " is = "
'Print ".00000000000000000000000000000000000000000000000000000000000054307978001764"
'Print mr$(".00000000000000000000000000000000000000000000200000000000000054307978001764", "-", ".000000000000000000000000000000000000000000002")
' 2023-10-22 OK
' debug tests
'Print mr$("-5", "+", "-2100"), " OK if -2105"
'Print mr$("." + String$(20, "0") + "1", "+", "1" + String$(40, "0") + "1") ' first real test of add
'Print ruler$
'Print
'Print "-.00071 plus"
'Print " .00036000000000000000000000000000000000009 is = "
'Print "-.00034999999999999999999999999999999999991"
'Print mr$("-.00071", "+", ".00036" + String$(35, "0") + "9")
' 2023-10-22 OK
'testing a different subtract sub
'Print mr$("10", "-", "5"), " 5 OK"
'Print mr$("-10", "+", "5"), " -5 OK"
'Print mr$("-10", "-", "-5"), " -5 OK"
'Print mr$("-10", "-", "5"), " -15 OK added"
'Print mr$("10", "-", "-5"), " 15 OK added"
'Print mr$("-.010", "-", "-5"), "4.99 OK"
'Print mr$("-.010", "-", "5"), "-5.01 OK just added"
'Print mr$(".010", "-", "5"), " -4.99 OK"
' 2023-10-22 OK
' jack error reported 2021-06-04 confirmed! variation below
'r$ = mr$(".00000000200000000000000054307978001764", "-", ".0000000020000000000000001") '16 0 wrong 8 wrong
'Print " mr$ rtnd:"; r$
'Print " .00000000200000000000000054307978001764"
'Print " - .0000000020000000000000001"
'Print " compare:.00000000000000000000000044307978001764" ' 2021-06-05 finally!
' 2023-10-22 OK
'r$ = mr$(".00000000000000000100000000000000000011", "-", ".000000000000000001000000000000000001") ' bad too
'Print " .00000000000000000100000000000000000011"
'Print " - .000000000000000001000000000000000001"
'Print " -.00000000000000000000000000000000000089"
'Print " mr$ rtnd:"; r$
' 2023-10-22 OK
'r$ = mr$(".00000000000000000100000000000000000111", "-", ".000000000000000002000000000000000001")
'Print " .000000000000000002000000000000000001"
'Print " - .00000000000000000100000000000000000111"
'Print " compare: -.00000000000000000099999999999999999989"
'Print " mr$ rtnd: "; r$
' 2023-10-22 OK
'r$ = mr$(".00000000000000000000000000999", "-", "1")
'Print " .00000000000000000000000000999"
'Print " - 1"
'Print " compare: -.99999999999999999999999999001"
'Print " mr$ rtnd: "; r$
' 2023-10-22 OK
'r$ = mr$("1", "+", "-1000000000000000000000000000000000000000")
'Print " 1"
'Print " - 1000000000000000000000000000000000000000"
'Print " compare: -999999999999999999999999999999999999999"
'Print " mr$ rtnd: "; r$
' 2023-10-22 OK
' check jack problems with FB translation 2021-06-03 errors must be in FB trans from QB64
'Print Mid$(mr$(" .1", "/", "3"), 1, 100) ' too long?
'Print Mid$(mr$("1.1", "/", "9"), 1, 100)
'Print Mid$(mr$("1.38", "/", "1.2"), 1, 100)
' 2023-10-22 OK
' another error reported by jack 2021-06-06 fixed (same problem as subtr$)
'Print mr$("1.000000000000000000000001000000000000000000000001", "*", ".000000000000000000000000000000000000000000000001")
'' .000000000000000000000000000000000000000000000001"
'Print ".000000000000000000000000000000000000000000000001"
'Print " 1000000000000000000000001000000000000000000000001"
'Print ruler$
'Print "checking inverse of 50 = .02 "; nInverse$("50", 20) 'OK .020000... length 20
' 2023-10-22 hmm nInverse of 50 is not 20 decimals?? OK?
'Print
'Print "zzz... see inverse of STx number now takes close to 30 secs with fixed subtr$() sub,"
'Print "Use to come up in a sneeze! It also looks different way more space on end but still"
'Print "can find 115 Fibonacci terms in it."
'Print " The only difference is I am not trimming leading 0's in subst$() function!"
'Sleep
'Cls
'Dim inverseSTx$, start, done
'start = Timer(.001)
'inverseSTx$ = nInverse$("999999999999999999999998999999999999999999999999", 2785) ' now 2 secs with new subtr from 19 secs
''inverseSTx$ = nInverse2$("999999999999999999999998999999999999999999999999", 817) ' 13 sec damn added 7 secs! now 19.xx
'' 816 in 4.22 secs only 64 terms 817 sigDigits matching in 12.93 secs gets all 115 Fibonacci Terms
'done = Timer(.001) - start
'Print Mid$(inverseSTx$, 1, 3000)
'Print
'Print "Inverse time:"; done; " zzz... press any to search for Fibonacci Terms"
'Sleep
'Dim As Long startSearch, termN, find
'Dim f1$, f2$, searchFor$
'f1$ = "1"
'f2$ = "1"
'startSearch = 1
'termN = 2
'Do
' searchFor$ = mr$(f1$, "+", f2$)
' find = InStr(startSearch, inverseSTx$, searchFor$)
' If find Then
' termN = termN + 1
' Print "Term Number"; termN; " = "; searchFor$; " found at"; find
' f1$ = f2$
' f2$ = searchFor$
' startSearch = find + Len(searchFor$)
' Else
' Print searchFor$; " not found."
' Exit Do
' End If
'Loop
' 2023-10-22 OK < 2 secs 115 terms found good!
'Print
'Print " Test factorial speed"
'Dim fact$, i As _Unsigned _Integer64, refFact$, cont$, start, done
'_KeyClear
'Input "Press y for yes, let's do 10000 factorial test, takes 2.9 minutes "; fact$
'If fact$ = "y" Then
' start = Timer(.001)
' fact$ = "1"
' For i = 2 To 10000
' fact$ = TrimLead0$(mult$(fact$, _Trim$(Str$(i))))
' If i Mod 100 = 0 Then Print i; "factorial length ="; Len(fact$)
' Next
' done = Timer(.001) - start
' Print i, Len(fact$), done
' ' save it
' Open "calc 10000!.txt" For Output As #1
' Print #1, fact$
' Close #1
' Beep
' Print Len(fact$), done, " zzz... press any to compare to reference 10000!."
' Sleep
' _KeyClear
' Open "10000!.txt" For Input As #1
' Input #1, refFact$
' Close #1
' Print "Comparing fact$ to reference fact$:"
' For i = 1 To Len(fact$)
' If Mid$(fact$, i, 1) <> Mid$(refFact$, i, 1) Then
' Print i, Mid$(fact$, i, 1), Mid$(refFact$, i, 1)
' Beep
' Input "Continue? y for yes "; cont$
' If cont$ <> "y" Then Exit For
' End If
' Next
' _KeyClear
' Print "zzz... press any to start sqr estimating"
' Sleep
' _KeyClear
'End If
' OK 2023-10-22
'Dim n$
'Do
' 'remember everything is strings
' Input "Enter a number to find it's square root, just enter to quit "; n$
' If n$ = "" Then End
' Print bigSQR$(n$), (Val(n$)) ^ .5
' Print
'Loop
' OK 2023-10-22
' ================================= end of old tests from SM2 2021
' newer stuff only a year or so ago
'Dim As Double i ' testing Dec2Bin$
'Dim p2$, x$, sum$
'p2$ = "1"
'For i = 1 To 50
' p2$ = mr$(p2$, "/", "2")
' x$ = mr$(x$, "+", "1")
' sum$ = mr$(x$, "+", p2$)
' Print sum$, Dec2Bin$(sum$, 100)
' 'Sleep
'Next
' OK 2023-10-22
'Print: Print " Square Roots:"
'Dim b$, intger$, i
'For i = 1 To 50
' b$ = Str$(i + 1 / (2 ^ i))
' Print b$, bigSQR$(b$)
'Next
'intger$ = "10000000000000000000000000000000000000000000000000000000000000000"
'Print: Print "Bonus SQR of "; intger$; " Len = "; Len(intger$); " is:"
'b$ = bigSQR$(intger$)
'Print b$, " Len Integer Part ="; Len(Mid$(b$, 1, InStr(b$, ".") - 1))
'intger$ = "100000000000000000000000000000000000000000000000000000000000000000"
'Print: Print "Bonus SQR of "; intger$; " Len = "; Len(intger$); " is:"
'b$ = bigSQR$(intger$)
'Print b$, " Len Integer Part ="; Len(Mid$(b$, 1, InStr(b$, ".") - 1))
'Print: Print " Square Roots:"
' OK 2023-10-22
' OK now test the new Power$ routine
'Print showDP$(power$("8", mr$("1", "/", "1025")), 30)
' 2023-10-22 Not ready for prime time yet!!!
'Dim i As Long
'For i = 1 To 60
' Print i, Dec2Bin$(N2S$(Str$(i / 60)), 60)
'Next
' 2023-10-22 OK
'Dim test$, ans$
'Print "Testing converting back from binary to decimal"
'Do
' Input "Enter a decimal to convert to binary and back - sgn or decimal "; test$
' ans$ = Dec2Bin$(test$, 100)
' Print "Binary is: "; ans$
' Print "Check conversion back: "; Bin2Dec$(ans$)
'Loop Until test$ = ""
' 2023-10-22 OK
' 2023-10-23 take anothe shot with this code
'random testing for correct signs, decimal places and values
Dim ad As Double, bd As Double, check As Double
Dim ea As Double, eb As Double
Dim i As Integer, flag As Integer, count As Long
Dim op$, a$, b$, mrStr$, qbCalc$
Do
'pick two numbers
' pick operation
op$ = Mid$("+-*/", Int(Rnd * 4) + 1, 1)
' pick exponents
ea = 10 * Rnd * (2 * Int(Rnd * 2) - 1)
eb = 10 * Rnd * (2 * Int(Rnd * 2) - 1)
ad = (2 * Int(Rnd * 2) - 1) * Rnd * 10 ^ ea
a$ = N2S$(Str$(ad))
bd = (2 * Int(Rnd * 2) - 1) * Rnd * 10 ^ eb
b$ = N2S$(Str$(bd))
Select Case op$
Case "+": check = ad + bd
Case "-": check = ad - bd
Case "*": check = ad * bd
Case "/": check = ad / bd
End Select
qbCalc$ = N2S$(Str$(check))
Print
Print a$; " "; op$; " "; b$; " ="
mrStr$ = mr$(a$, op$, b$)
Print Mid$(mrStr$, 1, 100); " by way of Mr$"
Print qbCalc$; " by way of QB64 math"
Print "diff ="; Val(mrStr$) - check
'compare first 13 digits of each
flag = 0
For i = 1 To 13
If Len(qbCalc$) >= i And Len(mrStr$) >= i Then
If Mid$(qbCalc$, i, 1) <> Mid$(mrStr$, i, 1) Then
Beep
flag = flag + 1
End If
End If
Next
Print flag; " differences in first 13 digits."
If flag Then
Print "Press key for next test or press escape to quit..."
Sleep ' comment out to see if any delay in execution of print
count = 0
Else
count = count + 1
Print count; " calculations that agreed."
End If
Loop Until _KeyDown(27)
' 2023-10-15 Mr$() moved to top for rework
' catchy? mr$ for math regulator cop$ = " + - * / " 1 of 4 basic arithmetics
' Fixed so that add and subtract have signs calc'd in Mr and correct call to add or subtract made
' with bigger minus smaller in subtr$() call
Function mr$ (a$, cop$, b$)
Dim op$, ca$, cb$, aSgn$, bSgn$, postOp$, sgn$, rtn$
Dim As Long adp, bdp, dp, lpop, aLTb
op$ = _Trim$(cop$) 'save fixing each time
ca$ = _Trim$(a$): cb$ = _Trim$(b$) 'make copies in case we change
'strip signs and decimals
If Left$(ca$, 1) = "-" Then
aSgn$ = "-": ca$ = Mid$(ca$, 2)
Else
aSgn$ = ""
End If
dp = InStr(ca$, ".")
If dp > 0 Then
adp = Len(ca$) - dp
ca$ = Mid$(ca$, 1, dp - 1) + Mid$(ca$, dp + 1)
Else
adp = 0
End If
If Left$(cb$, 1) = "-" Then
bSgn$ = "-": cb$ = Mid$(cb$, 2)
Else
bSgn$ = ""
End If
dp = InStr(cb$, ".")
If dp > 0 Then
bdp = Len(cb$) - dp
cb$ = Mid$(cb$, 1, dp - 1) + Mid$(cb$, dp + 1)
Else
bdp = 0
End If
If op$ = "+" Or op$ = "-" Or op$ = "/" Then 'add or subtr even up strings on right of decimal
'even up the right sides of decimals if any
If adp > bdp Then dp = adp Else dp = bdp
If adp < dp Then ca$ = ca$ + String$(dp - adp, "0")
If bdp < dp Then cb$ = cb$ + String$(dp - bdp, "0")
ElseIf op$ = "*" Then
dp = adp + bdp
End If
If op$ = "*" Or op$ = "/" Then
If aSgn$ = bSgn$ Then sgn$ = "" Else sgn$ = "-"
End If
'now according to signs and op$ call add$ or subtr$
If op$ = "-" Then ' make it adding according to signs because that is done for + next!
If bSgn$ = "-" Then bSgn$ = "" Else bSgn$ = "-" ' flip bSgn$ with op$
op$ = "+" ' turn this over to + op already done! below
End If
If op$ = "+" Then
If aSgn$ = bSgn$ Then 'really add
postOp$ = add$(ca$, cb$)
sgn$ = aSgn$
ElseIf aSgn$ <> bSgn$ Then 'have a case of subtraction
'but which is first and which is 2nd and should final sign be pos or neg
If TrimLead0$(ca$) = TrimLead0(cb$) Then 'remove case a = b
mr$ = "0": Exit Function
Else
aLTb = LTE(ca$, cb$)
If aSgn$ = "-" Then
If aLTb Then ' b - a = pos
postOp$ = subtr$(cb$, ca$)
sgn$ = ""
Else ' a > b so a - sgn wins - (a - b)
postOp$ = subtr$(ca$, cb$)
sgn$ = "-"
End If
Else ' b has the - sgn
If aLTb Then ' result is -
postOp$ = subtr$(cb$, ca$)
sgn$ = "-"
Else ' result is pos
postOp$ = subtr$(ca$, cb$)
sgn$ = ""
End If
End If
End If
End If
ElseIf op$ = "*" Then
postOp$ = mult$(ca$, cb$)
ElseIf op$ = "/" Then
postOp$ = divide$(ca$, cb$)
End If ' which op
' 2023-10-15 something in here is fouling up when addition needs to co and new digit
' I wish I wrote down what reasons were for some of this code.
' this order is correct
' 1st return decimal
' 2nd trim 0's off left and right?
' 3rd finally put back the negative sign
If op$ <> "/" Then 'put dp back
lpop = Len(postOp$) ' put decimal back if there is non zero stuff following it
If Len(Mid$(postOp$, lpop - dp + 1)) Then ' fix 1 extra dot appearing in 10000! ?!
' debug 10-15
'Print "postOp$, lpop, dp :"; postOp$, lpop, dp
'Print "TrimLead0$(Mid$(postOp$, lpop - dp + 1))"; TrimLead0$(Mid$(postOp$, lpop - dp + 1)) 'debug"
' 10-15 what is this line checking??? It seems to interfere with decimal
'If TrimLead0$(Mid$(postOp$, lpop - dp + 1)) <> "0" Then ' .0 or .00 or .000 ??
postOp$ = Mid$(postOp$, 1, lpop - dp) + "." + Mid$(postOp$, lpop - dp + 1)
'Else
'End If
End If
End If
rtn$ = trim0$(postOp$) 'trim lead 0's then tack on sign
If rtn$ <> "0" Then mr$ = sgn$ + rtn$ Else mr$ = rtn$
End Function
Function power$ (x$, exponent$) ' not ready for prime time yet!
' this power is getting bogged down by tons of digits not making significant change to final value
Dim step1$
step1$ = mr$(exponent$, "*", nLn$(x$))
step1$ = showDP$(step1$, 100) ' cut x$ down to 100 places
Print step1$
power$ = eToTheX$(step1$)
End Function
Function nLn$ (x$)
Dim term1$, term2$, term$, xbase$, coef$, sum$, newsum$
Dim As Long k, count, kPower
newsum$ = "0"
term1$ = mr$(x$, "-", "1")
term2$ = mr$(x$, "+", "1")
term$ = mr$(term1$, "/", term2$)
xbase$ = "1"
Do
sum$ = newsum$
'Print newsum$
'coef$ = 2 / (2 * k + 1)
coef$ = mr$("2", "/", _Trim$(Str$(2 * k + 1)))
kPower = 2 * k + 1
While count < kPower
xbase$ = showDP$(mr$(xbase$, "*", term$), 100)
count = count + 1
Wend
newsum$ = showDP$(mr$(coef$, "*", xbase$), 100)
newsum$ = mr$(sum$, "+", newsum$)
k = k + 1
Loop Until (sum$ = newsum$) Or (kPower > 2500)
nLn$ = newsum$
End Function
Function eToTheX$ (x$)
Dim sum$, t1$, t2$
Dim As Long n, i
sum$ = "1": n = 100
For i = n - 1 To 1 Step -1
'sum$ = "1" + x$ * sum / i
t1$ = mr$(sum$, "/", _Trim$(Str$(i)))
t2$ = mr$(x$, "*", t1$)
sum$ = mr$("1", "+", t2$)
sum$ = showDP$(sum$, 100) ' trim down all the digits building up
'Print showDP$(sum$, 20)
Next
eToTheX$ = sum$
End Function
' x to the power of pow
Function BinPower$ (xx$, pow$) ' so far this sucks, decimal is lost and digits only good for about 10 places 10% of dp in SQR(2)'s
Dim build$, ip$, fp$, x$, bs$, runningXSQR$
Dim As Long dot, i
x$ = _Trim$(xx$)
dot = InStr(pow$, ".")
If dot Then
ip$ = Mid$(pow$, 1, dot - 1)
fp$ = Mid$(pow$, dot) ' keep dot
Else
ip$ = pow$
fp$ = ""
End If
'integer part or power
build$ = "1"
If ip$ <> "" Then
While LTE("0", ip$)
build$ = mr$(build$, "*", x$)
ip$ = mr$(ip$, "-", "1")
Wend
End If
If fp$ = "" Or fp$ = "." Then BinPower$ = build$: Exit Function
build$ = build$ + "."
'now for the fraction part convert decimal to Binary
bs$ = Dec2Bin$(fp$, 100)
'at moment we haven't taken any sqr of x
runningXSQR$ = mr$(x$, "*", x$)
'run through all the 0's and 1's in the bianry expansion of the fraction part of the power float
For i = 1 To Len(bs$)
'this is the matching sqr of the sqr of the sqr... of x
runningXSQR$ = bigSQR$(runningXSQR$)
'for every 1 in the expansion, multiple our build with the running sqr of ... sqr of x
If Mid$(bs$, i, 1) = "1" Then build$ = mr$(build$, "*", runningXSQR$)
Next
'our build should be a estimate or x to power of pow
BinPower$ = build$
End Function
Function Bin2Dec$ (bn$) ' bn$ is binary string number with possible neg sign and decimal
Dim b$, sgn$, ip$, fp$, p2$, build$
Dim As Long dot, i
b$ = _Trim$(bn$)
If Left$(b$, 1) = "-" Then sgn$ = "-": b$ = Mid$(b$, 2) Else sgn$ = ""
dot = InStr(b$, ".")
If dot Then
ip$ = Mid$(b$, 1, dot - 1)
fp$ = Mid$(b$, dot + 1)
Else
ip$ = b$
fp$ = ""
End If
p2$ = "1"
For i = Len(ip$) To 1 Step -1
If Mid$(ip$, i, 1) = "1" Then build$ = mr$(build$, "+", p2$)
p2$ = mr$(p2$, "*", "2")
Next
If fp$ <> "" Then
build$ = build$ + "."
p2$ = "1"
For i = 1 To Len(fp$)
p2$ = mr$(p2$, "/", "2")
If Mid$(fp$, i, 1) = "1" Then build$ = mr$(build$, "+", p2$)
Next
End If
Bin2Dec$ = sgn$ + build$
End Function
Function bigSQR$ (number$)
Dim ip$, fp$, n$, calc$, remainder$, new$, test$
Dim As Long dot, dp, i, pulldown, cal, digit, maxDec
maxDec = 100
' divide number into integer part, ip$ and fraction part, fp$
' figure decimal places to left of decimal then even up front and back
dot = InStr(number$, ".")
If dot Then
ip$ = _Trim$(Mid$(number$, 1, dot - 1))
fp$ = Left$(_Trim$(Mid$(number$, dot + 1)) + String$(2 * maxDec, "0"), 2 * maxDec)
Else
ip$ = _Trim$(number$)
If Len(ip$) Mod 2 = 1 Then ip$ = "0" + ip$
fp$ = String$(2 * maxDec, "0")
End If
dp = Int((Len(ip$) + 1) / 2)
If Len(ip$) Mod 2 = 1 Then ip$ = "0" + ip$
n$ = ip$ + fp$
For i = 1 To Len(n$) Step 2
pulldown = Val(Mid$(n$, i, 2))
If i = 1 Then
cal = Int(Sqr(pulldown))
remainder$ = _Trim$(Str$(pulldown - cal * cal))
calc$ = _Trim$(Str$(cal))
Else
new$ = mr$("100", "*", remainder$)
new$ = mr$(new$, "+", _Trim$(Str$(pulldown)))
For digit = 9 To 0 Step -1
'test$ = (20 * Val(calc$) + digit) * digit
test$ = mr$("20", "*", calc$)
test$ = mr$(test$, "+", _Trim$(Str$(digit)))
test$ = mr$(test$, "*", _Trim$(Str$(digit)))
If LTE(test$, new$) Then Exit For
Next
calc$ = calc$ + _Trim$(Str$(digit))
remainder$ = mr$(new$, "-", test$)
End If
Next
If dp Then
calc$ = Mid$(calc$, 1, dp) + "." + Mid$(calc$, dp + 1)
Else
calc$ = "." + calc$
End If
bigSQR$ = calc$
End Function
' New stuff
Function Dec2Bin$ (Dec$, numDigits As Long)
Dim sgn$, d$, ip$, fp$, b$, tp$
Dim As Long dot, c
If _Trim$(Left$(Dec$, 1)) = "-" Then
sgn$ = "-": d$ = Mid$(_Trim$(Dec$), 2)
Else
sgn$ = "": d$ = _Trim$(Dec$)
End If
dot = InStr(d$, ".")
If dot Then
ip$ = Mid$(d$, 1, dot - 1): fp$ = Mid$(d$, dot)
Else ' all integer
ip$ = d$: fp$ = "."
End If
tp$ = "2"
If LTE(tp$, ip$) Then
While LTE(tp$, ip$)
tp$ = mr$(tp$, "*", "2")
Wend
End If
While LT("1", tp$)
tp$ = mr$(tp$, "/", "2")
If LTE(tp$, "1") Then b$ = b$ + ip$: Exit While
If LT(ip$, tp$) Then
b$ = b$ + "0"
Else
b$ = b$ + "1"
ip$ = mr$(ip$, "-", tp$)
End If
Wend
b$ = b$ + "." ' cross over point to fractions
tp$ = "1"
'Print "start fp$ "; fp$
While c <= numDigits 'And LT("0", fp$)
tp$ = mr$(tp$, "/", "2")
'If LT(fp$, tp$) Then ' for some reason LT is not working but < is
If fp$ < tp$ Then ' for some reason LT is not working but < is
b$ = b$ + "0"
Else
b$ = b$ + "1"
fp$ = mr$(fp$, "-", tp$)
If LTE(fp$, "0") Then Exit While
End If
c = c + 1
Wend
Dec2Bin$ = sgn$ + b$ ' b$ = build of 0,1 and .
End Function
Function add$ (a$, b$) 'add 2 positive integers assume a and b are just numbers no - signs
'set a and b numbers to same length and multiple of 18 so can take 18 digits at a time
Dim As Long la, lb, m, g
Dim sa As _Unsigned _Integer64, sb As _Unsigned _Integer64, co As _Unsigned _Integer64
Dim fa$, fb$, t$, new$, result$
la = Len(a$): lb = Len(b$)
If la > lb Then m = Int(la / 18) + 1 Else m = Int(lb / 18) + 1
fa$ = Right$(String$(m * 18, "0") + a$, m * 18)
fb$ = Right$(String$(m * 18, "0") + b$, m * 18)
'now taking 18 digits at a time Thanks Steve McNeill
For g = 1 To m
sa = Val(Mid$(fa$, (m - g) * 18 + 1, 18))
sb = Val(Mid$(fb$, (m - g) * 18 + 1, 18))
t$ = Right$(String$(36, "0") + _Trim$(Str$(sa + sb + co)), 36)
co = Val(Mid$(t$, 1, 18))
new$ = Mid$(t$, 19)
result$ = new$ + result$
Next
If co Then result$ = Str$(co) + result$
add$ = result$
End Function
' This is used in nInverse$ not by Mr$ because there it saves time!
Function subtr1$ (a$, b$)
Dim As Long la, lb, lResult, i, ca, cb, w
Dim result$, fa$, fb$
la = Len(a$): lb = Len(b$)
If la > lb Then lResult = la Else lResult = lb
result$ = Space$(lResult)
fa$ = result$: fb$ = result$
Mid$(fa$, lResult - la + 1) = a$
Mid$(fb$, lResult - lb + 1) = b$
For i = lResult To 1 Step -1
ca = Val(Mid$(fa$, i, 1))
cb = Val(Mid$(fb$, i, 1))
If cb > ca Then ' borrow 10
Mid$(result$, i, 1) = Right$(Str$(10 + ca - cb), 1)
w = i - 1
While w > 0 And Mid$(fa$, w, 1) = "0"
Mid$(fa$, w, 1) = "9"
w = w - 1
Wend
Mid$(fa$, w, 1) = Right$(Str$(Val(Mid$(fa$, w, 1)) - 1), 1)
Else
Mid$(result$, i, 1) = Right$(Str$(ca - cb), 1)
End If
Next
subtr1$ = result$
End Function
' 2021-06-08 fix up with new mr call that decides the sign and puts the greater number first
Function subtr$ (sum$, minus$) ' assume both numbers are positive all digits
Dim As Long m, g, p
Dim VB As _Unsigned _Integer64, vs As _Unsigned _Integer64, tenE18 As _Unsigned _Integer64
Dim ts$, tm$, sign$, LG$, sm$, t$, result$
ts$ = _Trim$(sum$): tm$ = _Trim$(minus$) ' fixed subtr$ 2021-06-05
If trim0(ts$) = trim0$(tm$) Then subtr$ = "0": Exit Function 'proceed knowing not equal
tenE18 = 1000000000000000000 'yes!!! no dang E's
sign$ = ""
m = Int(Len(ts$) / 18) + 1
LG$ = Right$(String$(m * 18, "0") + ts$, m * 18)
sm$ = Right$(String$(m * 18, "0") + tm$, m * 18)
'now taking 18 digits at a time From Steve I learned we can do more than 1 digit at a time
For g = 1 To m
VB = Val(Mid$(LG$, m * 18 - g * 18 + 1, 18))
vs = Val(Mid$(sm$, m * 18 - g * 18 + 1, 18))
If vs > VB Then
t$ = Right$(String$(18, "0") + _Trim$(Str$(tenE18 - vs + VB)), 18)
p = (m - g) * 18
While p > 0 And Mid$(LG$, p, 1) = "0"
Mid$(LG$, p, 1) = "9"
p = p - 1
Wend
If p > 0 Then Mid$(LG$, p, 1) = _Trim$(Str$(Val(Mid$(LG$, p, 1)) - 1))
Else
t$ = Right$(String$(18, "0") + _Trim$(Str$(VB - vs)), 18)
End If
result$ = t$ + result$
Next
subtr$ = result$
End Function
Function TrimLead0$ (s$) 'for treating strings as number (pos integers)
Dim copys$
Dim As Long i, find
copys$ = _Trim$(s$) 'might as well remove spaces too
i = 1: find = 0
While i < Len(copys$) And Mid$(copys$, i, 1) = "0"
i = i + 1: find = 1
Wend
If find = 1 Then copys$ = Mid$(copys$, i)
If copys$ = "" Then TrimLead0$ = "0" Else TrimLead0$ = copys$
End Function
Function divide$ (n$, d$) ' goal here is 100 digits precision not 100 digits past decimal
Dim di$, ndi$
Dim As Long nD
If n$ = "0" Then divide$ = "0": Exit Function
If d$ = "0" Then divide$ = "div 0": Exit Function
If d$ = "1" Then divide$ = n$: Exit Function
' aha! found a bug when d$ gets really huge 100 is no where near enough!!!!
' 2021-06-03 fix by adding 100 to len(d$), plus have to go a little past 100 like 200
di$ = Mid$(nInverse$(d$, Len(d$) + 200), 2) 'chop off decimal point after
nD = Len(di$)
ndi$ = mult$(n$, di$)
ndi$ = Mid$(ndi$, 1, Len(ndi$) - nD) + "." + Right$(String$(nD, "0") + Right$(ndi$, nD), nD)
divide$ = ndi$
End Function
' This uses Subtr1$ is Positive Integer only!
' DP = Decimal places = says when to quit if don't find perfect divisor before
Function nInverse$ (n$, DP As Long) 'assume decimal at very start of the string of digits returned
Dim m$(1 To 9), si$, r$, outstr$, d$
Dim i As Long
For i = 1 To 9
si$ = _Trim$(Str$(i))
m$(i) = mult$(si$, n$)
Next
outstr$ = ""
If n$ = "0" Then nInverse$ = "Div 0": Exit Function
If n$ = "1" Then nInverse$ = "1": Exit Function
outstr$ = "." 'everything else n > 1 is decimal 8/17
r$ = "10"
Do
While LT(r$, n$) ' 2021-06-08 this should be strictly Less Than
outstr$ = outstr$ + "0" ' add 0 to the output string
If Len(outstr$) = DP + 1 Then nInverse$ = outstr$: Exit Function 'DP length?
r$ = r$ + "0"
Wend
For i = 9 To 1 Step -1
If LTE(m$(i), r$) Then d$ = _Trim$(Str$(i)): Exit For
Next
outstr$ = outstr$ + d$
If Len(outstr$) = DP + 1 Then nInverse$ = outstr$: Exit Function
r$ = subtr1$(r$, mult$(d$, n$)) 'r = r -d*n ' 2021-06-08 subtr1 works faster
If TrimLead0$(r$) = "0" Then nInverse$ = outstr$: Exit Function ' add trimlead0$ 6/08
r$ = r$ + "0" 'add another place
Loop
End Function
Function mult$ (a$, b$) 'assume both positive integers prechecked as all digits strings
Dim As Long la, lb, m, g, dp
Dim As _Unsigned _Integer64 v18, sd, co
Dim f18$, f1$, t$, build$, accum$
If a$ = "0" Then mult$ = "0": Exit Function
If b$ = "0" Then mult$ = "0": Exit Function
If a$ = "1" Then mult$ = b$: Exit Function
If b$ = "1" Then mult$ = a$: Exit Function
'find the longer number and make it a mult of 18 to take 18 digits at a time from it
la = Len(a$): lb = Len(b$)
If la > lb Then
m = Int(la / 18) + 1
f18$ = Right$(String$(m * 18, "0") + a$, m * 18)
f1$ = b$
Else
m = Int(lb / 18) + 1
f18$ = Right$(String$(m * 18, "0") + b$, m * 18)
f1$ = a$
End If
For dp = Len(f1$) To 1 Step -1 'dp = digit position of the f1$
build$ = "" 'line builder
co = 0
'now taking 18 digits at a time Thanks Steve McNeill
For g = 1 To m
v18 = Val(Mid$(f18$, (m - g) * 18 + 1, 18))
sd = Val(Mid$(f1$, dp, 1))
t$ = Right$(String$(19, "0") + _Trim$(Str$(v18 * sd + co)), 19)
co = Val(Mid$(t$, 1, 1))
build$ = Mid$(t$, 2) + build$
Next g
If co Then build$ = _Trim$(Str$(co)) + build$
If dp = Len(f1$) Then
accum$ = build$
Else
accum$ = add$(accum$, build$ + String$(Len(f1$) - dp, "0"))
End If
Next dp
mult$ = accum$
End Function
'this function needs TrimLead0$(s$) ' dang I can't remember if a$ and b$ can have decimals or not
Function LTE (a$, b$) ' a$ Less Than or Equal b$ comparison of 2 strings
Dim ca$, cb$
Dim As Long la, lb, i
ca$ = TrimLead0$(a$): cb$ = TrimLead0(b$)
la = Len(ca$): lb = Len(cb$)
If ca$ = cb$ Then
LTE = -1
ElseIf la < lb Then ' a is smaller
LTE = -1
ElseIf la > lb Then ' a is bigger
LTE = 0
ElseIf la = lb Then ' equal lengths
For i = 1 To Len(ca$)
If Val(Mid$(ca$, i, 1)) > Val(Mid$(cb$, i, 1)) Then
LTE = 0: Exit Function
ElseIf Val(Mid$(ca$, i, 1)) < Val(Mid$(cb$, i, 1)) Then
LTE = -1: Exit Function
End If
Next
End If
End Function
'need this for ninverse faster than subtr$ for sign
Function LT (a$, b$) ' a$ Less Than or Equal b$ comparison of 2 strings
Dim ca$, cb$
Dim As Long la, lb, i
ca$ = TrimLead0$(a$): cb$ = TrimLead0(b$)
la = Len(ca$): lb = Len(cb$)
If la < lb Then ' a is smaller
LT = -1
ElseIf la > lb Then ' a is bigger
LT = 0
ElseIf la = lb Then ' equal lengths
For i = 1 To Len(ca$)
If Val(Mid$(ca$, i, 1)) > Val(Mid$(cb$, i, 1)) Then
LT = 0: Exit Function
ElseIf Val(Mid$(ca$, i, 1)) < Val(Mid$(cb$, i, 1)) Then
LT = -1: Exit Function
End If
Next
End If
End Function
Function TrimTail0$ (s$)
Dim copys$
Dim As Long dp, i, find
copys$ = _Trim$(s$) 'might as well remove spaces too
TrimTail0$ = copys$
dp = InStr(copys$, ".")
If dp > 0 Then
i = Len(copys$): find = 0
While i > dp And Mid$(copys$, i, 1) = "0"
i = i - 1: find = 1
Wend
If find = 1 Then
If i = dp Then
TrimTail0$ = Mid$(copys$, 1, dp - 1)
Else
TrimTail0$ = Mid$(copys$, 1, i)
End If
End If
End If
End Function
Function trim0$ (s$)
Dim cs$, si$
cs$ = s$
si$ = Left$(cs$, 1)
If si$ = "-" Then cs$ = Mid$(cs$, 2)
cs$ = TrimLead0$(cs$)
cs$ = TrimTail0$(cs$)
If Right$(cs$, 1) = "." Then cs$ = Mid$(cs$, 1, Len(cs$) - 1)
If si$ = "-" Then trim0$ = si$ + cs$ Else trim0$ = cs$
End Function
' for displaying truncated numbers say to 60 digits
Function showDP$ (num$, nDP As Long)
Dim cNum$
Dim As Long dp, d, i
cNum$ = num$ 'since num$ could get changed
showDP$ = num$
dp = InStr(num$, ".")
If dp > 0 Then
If Len(Mid$(cNum$, dp + 1)) > nDP Then
d = Val(Mid$(cNum$, dp + nDP + 1, 1))
If d > 4 Then
cNum$ = "0" + cNum$ ' tack on another 0 just in case 9's all the way to left
dp = dp + 1
i = dp + nDP
While Mid$(cNum$, i, 1) = "9" Or Mid$(cNum$, i, 1) = "."
If Mid$(cNum$, i, 1) = "9" Then
Mid$(cNum$, i, 1) = "0"
End If
i = i - 1
Wend
Mid$(cNum$, i, 1) = _Trim$(Str$(Val(Mid$(cNum$, i, 1)) + 1)) 'last non 9 digit
cNum$ = Mid$(cNum$, 1, dp + nDP) 'chop it
showDP$ = trim0$(cNum$)
Else
showDP$ = Mid$(cNum$, 1, dp + nDP)
End If
End If
End If
End Function
Function N2S$ (EXP$) 'remove scientific Notation to String (~40 LOC)
'SMcNeill Jan 7, 2020 ref: https://www.qb64.org/forum/index.php?topic=1555.msg112989#msg112989
'Last Function in code marked Best Answer (removed debug comments and blank lines added these 2 lines.)
ReDim t$, sign$, l$, r$, r&&
ReDim dp As Long, dm As Long, ep As Long, em As Long, check1 As Long, l As Long, i As Long
t$ = LTrim$(RTrim$(EXP$))
If Left$(t$, 1) = "-" Or Left$(t$, 1) = "N" Then sign$ = "-": t$ = Mid$(t$, 2)
dp = InStr(t$, "D+"): dm = InStr(t$, "D-")
ep = InStr(t$, "E+"): em = InStr(t$, "E-")
check1 = Sgn(dp) + Sgn(dm) + Sgn(ep) + Sgn(em)
If check1 < 1 Or check1 > 1 Then N2S = _Trim$(EXP$): Exit Function 'If no scientic notation is found, or if we find more than 1 type, it's not SN!
Select Case l 'l now tells us where the SN starts at.
Case Is < dp: l = dp
Case Is < dm: l = dm
Case Is < ep: l = ep
Case Is < em: l = em
End Select
l$ = Left$(t$, l - 1) 'The left of the SN
r$ = Mid$(t$, l + 1): r&& = Val(r$) 'The right of the SN, turned into a workable long
If InStr(l$, ".") Then 'Location of the decimal, if any
If r&& > 0 Then
r&& = r&& - Len(l$) + 2
Else
r&& = r&& + 1
End If
l$ = Left$(l$, 1) + Mid$(l$, 3)
End If
Select Case r&&
Case 0 'what the heck? We solved it already?
'l$ = l$
Case Is < 0
For i = 1 To -r&&
l$ = "0" + l$
Next
l$ = "." + l$
Case Else
For i = 1 To r&&
l$ = l$ + "0"
Next
l$ = l$
End Select
N2S$ = sign$ + l$
End Function
b = b + ...
