Code: (Select All)
Option _Explicit
_Title "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 function, 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
$Console:Only
Dim dinpt, oput As String * 40
Dim dbase As String * 800
Dim dinput As String * 80
Dim dnum As String * 80
Dim whprt As String * 800
Dim fprt As String * 800
Dim gttl As String * 800
Dim qmlt As String * 80
Dim mlt As String * 80
Dim zee As String * 800
Dim sen As Long
Dim sign As Long
Dim ctr As Long
Dim flg As Long
Dim flg2 As Long
Dim lsplt As Long
Dim rsplt As Long
Dim pres As Long
Randomize Timer
Rem $Dynamic
dinput = "000000000000"
Print "enter number to convert from incl.base use 4 digits for each digit include 0 in each of the 4 places thaat contains no value so 0 is 0000 and 1 is 0001 "
Print "first enter a base of at least 2 (0002) enter - for a negative number . for decimal point"
Input ": "; dinput
Print " in a similiar manner enter the base to convert too "
Input ": "; oput
sen = Len(dinput)
dbase = Left$(dinput, 4)
sen = sen - 4
dnum = Right$(dinput, sen)
sign = 1
sen = Len(dnum)
If Left$(dnum, 1) = "-" Then
sign = -1
sen = sen - 1
dnum = Right$(dnum, sen)
End If
ctr = 1
flg = 0
flg2 = 0
While flg = 0 And ctr <= sen
If Mid$(dnum, ctr, 1) = "." Then
lsplt = ctr - 1
rsplt = sen - ctr
flg = 1
If ctr = 1 Then flg2 = 1
End If
ctr = ctr + 1
Wend
If flg = 1 And flg2 = 0 Then
whprt = Left$(dnum, lsplt)
fprt = Right$(dnum, rsplt)
End If
If flg = 1 And flg2 = 1 Then
whprt = "0000"
fprt = Right$(dnum, rsplt)
lsplt = 4
End If
gttl = "0"
qmlt = "1"
mlt = dbase
If flg = 0 Then whprt = dnum
While lsplt > 0
zee = Right$(whprt, 4)
gttl = mr(gttl, "+", mr(zee, "*", qmlt))
qmlt = mr(qmlt, "*", mlt)
lsplt = lsplt - 4
whprt = Left$(whprt, lsplt)
Wend
pres = Int((Log(Val(dbase)) * Int(rsplt / 4)) / Log(Val(oput)))
qmlt = "1"
Rem wqs&& = 1 to pres&&
qmlt = mr(qmlt, "/", dbase)
While rsplt >= 4
zee = Left$(fprt, 4)
gttl = mr(gttl, "+", mr(zee, "*", qmlt))
qmlt = mr(qmlt, "/", dbase)
rsplt = rsplt - 4
fprt = Right$(fprt, rsplt)
Wend
Print "base ten value: "; gttl
' 2022-09-25 Use BigSQR$ it's way faster, no estimating!
' == String Math 2021-06-14 Procedure start here (aprox 412 LOC for copy/paste into your app) ==
Function sqrRoot$ (nmbr$)
Dim n$, guess$, lastGuess$, other$, sum$, imaginary$, loopcnt
If Left$(nmbr$, 1) = "-" Then 'handle neg numbers
imaginary$ = "*i": n$ = Mid$(nmbr$, 2)
Else
imaginary$ = "": n$ = nmbr$
End If
guess$ = mr$(n$, "/", "2")
other$ = n$
Do
loopcnt = loopcnt + 1
If (Mid$(guess$, 1, 105) = Mid$(lastGuess$, 1, 105)) Then
' go past 100 matching digits for 100 digit precision
sqrRoot$ = Mid$(other$, 1, 101) + imaginary$
' try other factor for guess$ sometimes it nails answer without all digits
Exit Function
Else
lastGuess$ = guess$
sum$ = mr$(guess$, "+", other$)
guess$ = mr$(sum$, "/", "2")
other$ = mr$(n$, "/", guess$)
End If
Loop
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
' 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$
Rem Dim aLTb As String * 800
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
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! ?!
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)
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 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
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$ (dnum, 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 Functionthere it is the LT function seems to be gone / missing!!!