08-19-2022, 06:25 PM
Code: (Select All)
Screen _NewImage(1280, 720, 32)
a$ = "-10000000000000000000123.256"
b$ = " 60000000000000000000000.111"
Test a$, b$
a$ = " 100000000000000000000000000"
b$ = "-000000000000000000000000001.1"
Test a$, b$
a$ = "24123538548354853499345235498325489235982355952936529659265982635982398569.56466456"
b$ = "3.1"
Test a$, b$
Sub Test (a$, b$)
Print "==========================================================================="
Print a$
Print b$
Print "STEVE+:"; StringAdd(a$, b$)
Print "BTEN +:"; BTen$(a$, "+", b$)
Print "STEVE-:"; StringSubtract(a$, b$)
Print "BTEN -:"; BTen$(a$, "-", b$)
Print "==========================================================================="
Sleep
End Sub
Function StringAdd$ (tempa$, tempb$)
a$ = tempa$: b$ = tempb$ 'don't alter our original numbers
Dim As _Unsigned _Integer64 a, b, c, carryover 'to hold our values
'first fix the numbers to notmalize their lengths
FixNumbers a$, b$
'find the signs and strip them off
If Left$(a$, 1) = "-" Then sa$ = "-": a$ = Mid$(a$, 2) Else sa$ = " "
If Left$(b$, 1) = "-" Then sb$ = "-": b$ = Mid$(b$, 2) Else sb$ = " "
'find the decimal position
dp = InStr(a$, ".")
If dp > 0 Then 'remove the decimal place from our numbers. We can put it back later, in its proper position
righta$ = Mid$(a$, dp + 1)
rightb$ = Mid$(b$, dp + 1)
a$ = Left$(a$, dp - 1) + righta$
b$ = Left$(b$, dp - 1) + rightb$
End If
'our strings are now nothing but numbers with no signs and no decimals to deal with. Let's start adding!
'are we adding or really subtracting?
If sa$ <> sb$ Then 'we're subtracting the two values if the signs aren't the same.
Select Case a$
Case Is < b$: s$ = sb$: Swap a$, b$ 'our sign is going to be determiined by b$
Case Is = b$ 'if the two values are the same and are subtracting, our result is zero!
StringAdd$ = "0" 'How easy was that?
Exit Function
Case Else: s$ = sa$ 'our sign is determined by a$
End Select
Do
lb = Len(b$)
a = Val(Right$(a$, 18)): a$ = Left$(a$, Len(a$) - 18)
b = Val(Right$(b$, 18)): b$ = Left$(b$, Len(b$) - 18)
If borrow Then b = b + 1~&& 'in case we had to borrow a digit for the last subtraction
If a < b Then
If lb < 18 Then a = a + 10 ^ lb Else a = a + 10 ^ 18
borrow = -1
Else
borrow = 0
End If
c = a - b
temp$ = _Trim$(Str$(c))
answer$ = String$(18 - Len(temp$), "0") + temp$ + answer$
Loop Until Len(a$) = 0
'remove leading 0's
Do Until Left$(answer$, 1) <> "0"
answer$ = Mid$(answer$, 2)
Loop
'remember to add in the decimal place before finished
dp = Len(righta$)
If dp > 0 Then
answer$ = Left$(answer$, Len(answer$) - dp) + "." + Right$(answer$, dp)
End If
StringAdd$ = s$ + answer$
Exit Function
End If
Do
a1$ = Right$(a$, 18)
b1$ = Right$(b$, 18)
a = Val(Right$(a$, 18)): a$ = Left$(a$, Len(a$) - 18)
b = Val(Right$(b$, 18)): b$ = Left$(b$, Len(b$) - 18)
c = a + b + carryover
temp$ = _Trim$(Str$(c))
If Len(temp$) > 18 Then 'see if we have an answer that is more than 18 digits
temp$ = Right$(temp$, 18) 'keep 18 digits
carryover = 1 'store one for carry over
Else
carryover = 0 'no carryover
End If
answer$ = String$(18 - Len(temp$), "0") + temp$ + answer$
Loop Until Len(a$) = 0
If carryover Then answer$ = "1" + answer$
'remember to add in the decimal place before finished
dp = Len(righta$)
If dp > 0 Then
answer$ = Left$(answer$, Len(answer$) - dp) + "." + Right$(answer$, dp)
End If
'remove leading 0's
Do Until Left$(answer$, 1) <> "0"
answer$ = Mid$(answer$, 2)
Loop
StringAdd$ = sa$ + answer$
End Function
Function StringSubtract$ (tempa$, tempb$)
a$ = tempa$: b$ = tempb$
FixNumbers a$, b$
If Left$(b$, 1) = "-" Then b$ = Mid$(b$, 2) Else b$ = "-" + b$
StringSubtract$ = StringAdd$(a$, b$)
End Function
Sub FixNumbers (a$, b$)
'first remove scientific notation and spaces from both
a$ = _Trim$(N2S$(a$)): b$ = _Trim$(N2S$(b$))
'then find the decimal position for both and normalize the expressions
d1 = InStr(a$, "."): d2 = InStr(b$, ".")
If d1 <> 0 Then 'break down the left and right side of the decimal point for ease of processing (this is a$)
lefta$ = Left$(a$, d1 - 1)
righta$ = Mid$(a$, d1)
Else
lefta$ = a$
End If
If d2 <> 0 Then 'break down the left and right side of the decimal point for ease of processing (this is b$)
leftb$ = Left$(b$, d2 - 1)
rightb$ = Mid$(b$, d2)
Else
leftb$ = b$
End If
'normalize the right side of our expressions
l1 = Len(righta$): l2 = Len(rightb$)
If l1 < l2 Then
addzero = l2 - l1
If l1 = 0 Then righta$ = ".": addzero = addzero - 1
righta$ = righta$ + String$(addzero, "0")
ElseIf l1 > l2 Then
addzero = l1 - l2
'If l2 = 0 Then rightb$ = ".": addzero = addzero - 1
rightb$ = rightb$ + String$(addzero, "0")
End If
'strip off any plus/minus signs from the two numbers.
If Left$(lefta$, 1) = "-" Then signa$ = "-": lefta$ = Mid$(lefta$, 2)
If Left$(leftb$, 1) = "-" Then signb$ = "-": leftb$ = Mid$(leftb$, 2)
If Left$(lefta$, 1) = "+" Then signa$ = "": lefta$ = Mid$(lefta$, 2)
If Left$(leftb$, 1) = "+" Then signb$ = "": leftb$ = Mid$(leftb$, 2)
'normalize the left side of our expressions
l1 = Len(lefta$): l2 = Len(leftb$)
If l1 < l2 Then
addzero = l2 - l1
lefta$ = String$(addzero, "0") + lefta$
ElseIf l1 > l2 Then
addzero = l1 - l2
leftb$ = String$(addzero, "0") + leftb$
End If
'and then put it all together
a$ = signa$ + lefta$ + righta$
b$ = signb$ + leftb$ + rightb$
End Sub
Function N2S$ (exp$) 'scientific Notation to String
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 = 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$ = "0." + l$
Case Else
For i = 1 To r&&
l$ = l$ + "0"
Next
End Select
N2S$ = sign$ + l$
End Function
Function DWD$ (exp$) 'Deal With Duplicates
'To deal with duplicate operators in our code.
'Such as -- becomes a +
'++ becomes a +
'+- becomes a -
'-+ becomes a -
t$ = exp$
Do
bad = 0
Do
l = InStr(t$, "++")
If l Then t$ = Left$(t$, l - 1) + "+" + Mid$(t$, l + 2): bad = -1
Loop Until l = 0
Do
l = InStr(t$, "+-")
If l Then t$ = Left$(t$, l - 1) + "-" + Mid$(t$, l + 2): bad = -1
Loop Until l = 0
Do
l = InStr(t$, "-+")
If l Then t$ = Left$(t$, l - 1) + "-" + Mid$(t$, l + 2): bad = -1
Loop Until l = 0
Do
l = InStr(t$, "--")
If l Then t$ = Left$(t$, l - 1) + "+" + Mid$(t$, l + 2): bad = -1
Loop Until l = 0
Loop Until Not bad
DWD$ = t$
End Function
Function BTen$ (InTop As String, Op As String, InBot As String)
Rem $DYNAMIC
InTop = LTrim$(RTrim$(InTop))
InBot = LTrim$(RTrim$(InBot))
l = InStr(InTop, "-")
If l = 0 Then l = InStr(InTop, "+")
If l = 0 Then InTop = "+" + InTop
l = InStr(InBot, "-")
If l = 0 Then l = InStr(InBot, "+")
If l = 0 Then InBot = "+" + InBot
l = InStr(InTop, ".")
If l = 0 Then InTop = InTop + "."
l = InStr(InBot, ".")
If l = 0 Then InBot = InBot + "."
If Op$ = "-" Then
Op$ = "+"
If Mid$(InBot, 1, 1) = "-" Then Mid$(InBot, 1, 1) = "+" Else Mid$(InBot, 1, 1) = "-"
End If
TDP& = Check&(10, InTop$)
BDP& = Check&(10, InBot$)
If TDP& < 0 Or BDP& < 0 Then Exit Function
TSign% = Check&(11, InTop$)
BSign% = Check&(11, InBot$)
' Calculate Array Size
If Op$ = Chr$(43) Or Op$ = Chr$(45) Then
' "+" (Add) OR "-" (Subtract)
Temp& = 9
ElseIf Op$ = Chr$(42) Or Op$ = Chr$(50) Then
' "*" (Multiply) OR "2" (SQRT Multiply)
Temp& = 7
Else
Exit Function
End If
' LSA (Left Side of Array)
LSA& = TDP& - 2
TLS& = LSA& \ Temp&
If LSA& Mod Temp& > 0 Then
TLS& = TLS& + 1
Do While (TLPad& + LSA&) Mod Temp& > 0
TLPad& = TLPad& + 1
Loop
End If
LSA& = BDP& - 2
BLS& = LSA& \ Temp&
If LSA& Mod Temp& > 0 Then
BLS& = BLS& + 1
Do While (BLPad& + LSA&) Mod Temp& > 0
BLPad& = BLPad& + 1
Loop
End If
If TLS& >= BLS& Then LSA& = TLS& Else LSA& = BLS&
' RSA (Right Side of Array)
RSA& = Len(InTop$) - TDP&
TRS& = RSA& \ Temp&
If RSA& Mod Temp& > 0 Then
TRS& = TRS& + 1
Do While (TRPad& + RSA&) Mod Temp& > 0
TRPad& = TRPad& + 1
Loop
End If
RSA& = Len(InBot$) - BDP&
BRS& = RSA& \ Temp&
If RSA& Mod Temp& > 0 Then
BRS& = BRS& + 1
Do While (BRPad& + RSA&) Mod Temp& > 0
BRPad& = BRPad& + 1
Loop
End If
If TRS& >= BRS& Then RSA& = TRS& Else RSA& = BRS&
If Op$ = Chr$(43) Or Op$ = Chr$(45) Then
' "+" (Add) OR "-" (Subtract)
Dim Result(1 To (LSA& + RSA&)) As Long
If (Op$ = Chr$(43) And TSign% = BSign%) Or (Op$ = Chr$(45) And TSign% <> BSign%) Then
' Add Absolute Values and Return Top Sign
' Left Side
For I& = 1 To LSA&
' Top
If I& <= (LSA& - TLS&) Then
''' Result(I&) = Result(I&) + 0
ElseIf I& = (1 + LSA& - TLS&) Then
Result(I&) = Val(Mid$(InTop$, 2, (9 - TLPad&)))
TDP& = 11 - TLPad&
Else
Result(I&) = Val(Mid$(InTop$, TDP&, 9))
TDP& = TDP& + 9
End If
' Bottom
If I& <= (LSA& - BLS&) Then
''' Result(I&) = Result(I&) + 0
ElseIf I& = (1 + LSA& - BLS&) Then
Result(I&) = Result(I&) + Val(Mid$(InBot$, 2, (9 - BLPad&)))
BDP& = 11 - BLPad&
Else
Result(I&) = Result(I&) + Val(Mid$(InBot$, BDP&, 9))
BDP& = BDP& + 9
End If
Next I&
' Right Side
TDP& = TDP& + 1: BDP& = BDP& + 1
For I& = (LSA& + 1) To (LSA& + RSA&)
' Top
If I& > (LSA& + TRS&) Then
''' Result(I&) = Result(I&) + 0
ElseIf I& = (LSA& + TRS&) Then
Result(I&) = (10 ^ TRPad&) * Val(Right$(InTop$, (9 - TRPad&)))
Else
Result(I&) = Val(Mid$(InTop$, TDP&, 9))
TDP& = TDP& + 9
End If
' Bottom
If I& > (LSA& + BRS&) Then
''' Result(I&) = Result(I&) + 0
ElseIf I& = (LSA& + BRS&) Then
Result(I&) = Result(I&) + (10 ^ BRPad&) * Val(Right$(InBot$, (9 - BRPad&)))
Else
Result(I&) = Result(I&) + Val(Mid$(InBot$, BDP&, 9))
BDP& = BDP& + 9
End If
Next I&
' Carry
For I& = (LSA& + RSA&) To 2 Step -1
If Result(I&) >= 1000000000 Then
Result(I& - 1) = Result(I& - 1) + 1
Result(I&) = Result(I&) - 1000000000
End If
Next I&
' Return Sign
If TSign% = 1 Then RetStr$ = Chr$(43) Else RetStr$ = Chr$(45)
Else
' Compare Absolute Values
If TDP& > BDP& Then
Compare& = 1
ElseIf TDP& < BDP& Then
Compare& = -1
Else
If Len(InTop$) > Len(InBot$) Then Compare& = Len(InBot$) Else Compare& = Len(InTop$)
For I& = 2 To Compare&
If Val(Mid$(InTop$, I&, 1)) > Val(Mid$(InBot$, I&, 1)) Then
Compare& = 1
Exit For
ElseIf Val(Mid$(InTop$, I&, 1)) < Val(Mid$(InBot$, I&, 1)) Then
Compare& = -1
Exit For
End If
Next I&
If Compare& > 1 Then
If Len(InTop$) > Len(InBot$) Then
Compare& = 1
ElseIf Len(InTop$) < Len(InBot$) Then
Compare& = -1
Else
Compare& = 0
End If
End If
End If
' Conditional Subtraction
If Compare& = 1 Then
' Subtract Bottom from Top and Return Top Sign
' Top
Result(1) = Val(Mid$(InTop$, 2, (9 - TLPad&)))
TDP& = 11 - TLPad&
For I& = 2 To LSA&
Result(I&) = Val(Mid$(InTop$, TDP&, 9))
TDP& = TDP& + 9
Next I&
TDP& = TDP& + 1
For I& = (LSA& + 1) To (LSA& + TRS& - 1)
Result(I&) = Val(Mid$(InTop$, TDP&, 9))
TDP& = TDP& + 9
Next I&
Result(LSA& + TRS&) = 10& ^ TRPad& * Val(Right$(InTop$, (9 - TRPad&)))
' Bottom
BDP& = (Len(InBot$) - 17) + BRPad&
For I& = (LSA& + BRS&) To (1 + LSA& - BLS&) Step -1
If I& = LSA& Then BDP& = BDP& - 1
If I& = (LSA& + BRS&) Then
Temp& = (10& ^ BRPad&) * Val(Right$(InBot$, (9 - BRPad&)))
ElseIf I& = (1 + LSA& - BLS&) Then
Temp& = Val(Mid$(InBot$, 2, (9 - BLPad&)))
Else
Temp& = Val(Mid$(InBot$, BDP&, 9))
BDP& = BDP& - 9
End If
If Result(I&) < Temp& Then
' Borrow
For J& = (I& - 1) To 1 Step -1
If Result(J&) = 0 Then
Result(J&) = 999999999
Else
Result(J&) = Result(J&) - 1
Exit For
End If
Next J&
Result(I&) = Result(I&) + 1000000000
End If
Result(I&) = Result(I&) - Temp&
Next I&
' Return Sign
If TSign% = 1 Then RetStr$ = Chr$(43) Else RetStr$ = Chr$(45)
ElseIf Compare& = -1 Then
' Subtract Top from Bottom and Return Bottom Sign
' Bottom
Result(1) = Val(Mid$(InBot$, 2, (9 - BLPad&)))
BDP& = 11 - BLPad&
For I& = 2 To LSA&
Result(I&) = Val(Mid$(InBot$, BDP&, 9))
BDP& = BDP& + 9
Next I&
BDP& = BDP& + 1
For I& = (LSA& + 1) To (LSA& + BRS& - 1)
Result(I&) = Val(Mid$(InBot$, BDP&, 9))
BDP& = BDP& + 9
Next I&
Result(LSA& + BRS&) = 10& ^ BRPad& * Val(Right$(InBot$, (9 - BRPad&)))
' Top
TDP& = (Len(InTop$) - 17) + TRPad&
For I& = (LSA& + TRS&) To (1 + LSA& - TLS&) Step -1
If I& = LSA& Then TDP& = TDP& - 1
If I& = (LSA& + TRS&) Then
Temp& = (10& ^ TRPad&) * Val(Right$(InTop$, (9 - TRPad&)))
ElseIf I& = (1 + LSA& - TLS&) Then
Temp& = Val(Mid$(InTop$, 2, (9 - TLPad&)))
Else
Temp& = Val(Mid$(InTop$, TDP&, 9))
TDP& = TDP& - 9
End If
If Result(I&) < Temp& Then
' Borrow
For J& = (I& - 1) To 1 Step -1
If Result(J&) = 0 Then
Result(J&) = 999999999
Else
Result(J&) = Result(J&) - 1
Exit For
End If
Next J&
Result(I&) = Result(I&) + 1000000000
End If
Result(I&) = Result(I&) - Temp&
Next I&
' Build Return Sign
If BSign% = 1 Then RetStr$ = Chr$(43) Else RetStr$ = Chr$(45)
Else
' Result will always be 0
LSA& = 1: RSA& = 1
RetStr$ = Chr$(43)
End If
End If
' Generate Return String
RetStr$ = RetStr$ + LTrim$(Str$(Result(1)))
For I& = 2 To LSA&
RetStr$ = RetStr$ + Right$(String$(8, 48) + LTrim$(Str$(Result(I&))), 9)
Next I&
RetStr$ = RetStr$ + Chr$(46)
For I& = (LSA& + 1) To (LSA& + RSA&)
RetStr$ = RetStr$ + Right$(String$(8, 48) + LTrim$(Str$(Result(I&))), 9)
Next I&
Erase Result
ElseIf Op$ = Chr$(42) Then
' * (Multiply)
Dim TArray(1 To (LSA& + RSA&)) As Long
Dim BArray(1 To (LSA& + RSA&)) As Long
Dim ResDBL(0 To (LSA& + RSA&)) As Double
' Push String Data Into Array
For I& = 1 To LSA&
If I& <= (LSA& - TLS&) Then
''' TArray(I&) = TArray(I&) + 0
ElseIf I& = (1 + LSA& - TLS&) Then
TArray(I&) = Val(Mid$(InTop$, 2, (7 - TLPad&)))
TDP& = 9 - TLPad&
Else
TArray(I&) = Val(Mid$(InTop$, TDP&, 7))
TDP& = TDP& + 7
End If
If I& <= (LSA& - BLS&) Then
''' BArray(I&) = BArray(I&) + 0
ElseIf I& = (1 + LSA& - BLS&) Then
BArray(I&) = Val(Mid$(InBot$, 2, (7 - BLPad&)))
BDP& = 9 - BLPad&
Else
BArray(I&) = Val(Mid$(InBot$, BDP&, 7))
BDP& = BDP& + 7
End If
Next I&
TDP& = TDP& + 1: BDP& = BDP& + 1
For I& = (LSA& + 1) To (LSA& + RSA&)
If I& > (LSA& + TRS&) Then
''' TArray(I&) = TArray(I&) + 0
ElseIf I& = (LSA& + TRS&) Then
TArray(I&) = 10 ^ TRPad& * Val(Right$(InTop$, (7 - TRPad&)))
Else
TArray(I&) = Val(Mid$(InTop$, TDP&, 7))
TDP& = TDP& + 7
End If
If I& > (LSA& + BRS&) Then
''' BArray(I&) = BArray(I&) + 0
ElseIf I& = (LSA& + BRS&) Then
BArray(I&) = 10 ^ BRPad& * Val(Right$(InBot$, (7 - BRPad&)))
Else
BArray(I&) = Val(Mid$(InBot$, BDP&, 7))
BDP& = BDP& + 7
End If
Next I&
' Multiply from Arrays to Array
For I& = (LSA& + TRS&) To (1 + LSA& - TLS&) Step -1
For J& = (LSA& + BRS&) To (1 + LSA& - BLS&) Step -1
Temp# = 1# * TArray(I&) * BArray(J&)
If (I& + J&) Mod 2 = 0 Then
TL& = Int(Temp# / 10000000)
TR& = Temp# - 10000000# * TL&
ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL&
ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + 10000000# * TR&
Else
ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + Temp#
End If
If ResDBL((I& + J&) \ 2) >= 100000000000000# Then
Temp# = ResDBL((I& + J&) \ 2)
TL& = Int(Temp# / 100000000000000#)
ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL&
ResDBL((I& + J&) \ 2) = Temp# - 100000000000000# * TL&
End If
Next J&
Next I&
Erase TArray, BArray
' Generate Return String
If (TSign% * BSign%) = 1 Then RetStr$ = Chr$(43) Else RetStr$ = Chr$(45)
RetStr$ = RetStr$ + LTrim$(Str$(ResDBL(0)))
For I& = 1 To (LSA&)
RetStr$ = RetStr$ + Right$(String$(13, 48) + LTrim$(Str$(ResDBL(I&))), 14)
Next I&
RetStr$ = Left$(RetStr$, Len(RetStr$) - 7) + Chr$(46) + Right$(RetStr$, 7)
For I& = (LSA& + 1) To (LSA& + RSA&)
RetStr$ = RetStr$ + Right$(String$(13, 48) + LTrim$(Str$(ResDBL(I&))), 14)
Next I&
Erase ResDBL
ElseIf Op$ = Chr$(50) Then
' 2 (SQRT Multiply)
Dim IArray(1 To (LSA& + RSA&)) As Long
Dim ResDBL(0 To (LSA& + RSA&)) As Double
' Push String Data Into Array
For I& = 1 To LSA&
If I& <= (LSA& - TLS&) Then
''' IArray(I&) = IArray(I&) + 0
ElseIf I& = (1 + LSA& - TLS&) Then
IArray(I&) = Val(Mid$(InTop$, 2, (7 - TLPad&)))
TDP& = 9 - TLPad&
Else
IArray(I&) = Val(Mid$(InTop$, TDP&, 7))
TDP& = TDP& + 7
End If
Next I&
TDP& = TDP& + 1
For I& = (LSA& + 1) To (LSA& + RSA&)
If I& > (LSA& + TRS&) Then
''' IArray(I&) = IArray(I&) + 0
ElseIf I& = (LSA& + TRS&) Then
IArray(I&) = 10 ^ TRPad& * Val(Right$(InTop$, (7 - TRPad&)))
Else
IArray(I&) = Val(Mid$(InTop$, TDP&, 7))
TDP& = TDP& + 7
End If
Next I&
' SQRT Multiply from Array to Array
For I& = (LSA& + TRS&) To 1 Step -1
For J& = I& To 1 Step -1
Temp# = 1# * IArray(I&) * IArray(J&)
If I& <> J& Then Temp# = Temp# * 2
If (I& + J&) Mod 2 = 0 Then
TL& = Int(Temp# / 10000000)
TR& = Temp# - 10000000# * TL&
ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL&
ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + 10000000# * TR&
Else
ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + Temp#
End If
If ResDBL((I& + J&) \ 2) >= 100000000000000# Then
Temp# = ResDBL((I& + J&) \ 2)
TL& = Int(Temp# / 100000000000000#)
ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL&
ResDBL((I& + J&) \ 2) = Temp# - 100000000000000# * TL&
End If
Next J&
Next I&
Erase IArray
' Generate Return String
If (TSign% * BSign%) = 1 Then RetStr$ = Chr$(43) Else RetStr$ = Chr$(45)
RetStr$ = RetStr$ + LTrim$(Str$(ResDBL(0)))
For I& = 1 To (LSA&)
RetStr$ = RetStr$ + Right$(String$(13, 48) + LTrim$(Str$(ResDBL(I&))), 14)
Next I&
RetStr$ = Left$(RetStr$, Len(RetStr$) - 7) + Chr$(46) + Right$(RetStr$, 7)
' Don't usually want the full right side for this, just enough to check the
' actual result against the expected result, which is probably an integer.
' Uncomment the three lines below when trying to find an oddball square root.
'FOR I& = (LSA& + 1) TO (LSA& + RSA&)
' RetStr$ = RetStr$ + RIGHT$(STRING$(13, 48) + LTRIM$(STR$(ResDBL(I&))), 14)
'NEXT I&
Erase ResDBL
End If
' Trim Leading and Trailing Zeroes
Do While Mid$(RetStr$, 2, 1) = Chr$(48) And Mid$(RetStr$, 3, 1) <> Chr$(46)
RetStr$ = Left$(RetStr$, 1) + Right$(RetStr$, Len(RetStr$) - 2)
Loop
Do While Right$(RetStr$, 1) = Chr$(48) And Right$(RetStr$, 2) <> Chr$(46) + Chr$(48)
RetStr$ = Left$(RetStr$, Len(RetStr$) - 1)
Loop
If Mid$(RetStr$, 1, 1) = "+" Then Mid$(RetStr$, 1, 1) = " "
Do
r$ = Right$(RetStr$, 1)
If r$ = "0" Then RetStr$ = Left$(RetStr$, Len(RetStr$) - 1)
Loop Until r$ <> "0"
r$ = Right$(RetStr$, 1)
If r$ = "." Then RetStr$ = Left$(RetStr$, Len(RetStr$) - 1)
BTen$ = RetStr$
End Function
Rem $STATIC
' ---------------------------------------------------------------------------
' FUNCTION Check& (Op&, InString$) Multi-Purpose String Tester
' ---------------------------------------------------------------------------
'
' * Op& = Type of string to expect and/or operation to perform
'
' { 00A } = (10) Test Base-10-Format String ( *!* ALTERS InString$ *!* )
' { 00B } = (11) Read Sign ("+", "-", or CHR$(241))
'
' Unlisted values are not used and will return [ Check& = 0 - Op& ].
' Different Op& values produce various return values.
' Refer to the in-code comments for details.
'
' ---------------------------------------------------------------------------
' FUNCTION Check& (Op&, InString$) Multi-Purpose String Tester
' ---------------------------------------------------------------------------
Function Check& (Op As Long, InString As String)
Rem $DYNAMIC
RetVal& = Len(InString$)
Select Case Op&
Case 10
' {00A} Test String for Base-10-Format ( *!* ALTERS InString$ *!* )
' Returns:
' {& > 0} = DP offset; {& < 0} = FAILED at negative offset
'
' After testing passes, the string is trimmed
' of nonessential leading and trailing zeroes.
If RetVal& = 0 Then
RetVal& = -1
Else
Select Case Asc(Left$(InString$, 1))
Case 43, 45 ' "+", "-"
For I& = 2 To RetVal&
Select Case Asc(Mid$(InString$, I&, 1))
Case 46 ' "."
If DPC% > 0 Then
RetVal& = 0 - I&
Exit For
Else
DPC% = DPC% + 1
RetVal& = I&
End If
Case 48 To 57
' keep going
Case Else
RetVal& = 0 - I&
Exit For
End Select
Next I&
Case Else
RetVal& = -1
End Select
If DPC% = 0 And RetVal& > 0 Then
RetVal& = 0 - RetVal&
ElseIf RetVal& = 2 Then
InString$ = Left$(InString$, 1) + Chr$(48) + Right$(InString$, Len(InString$) - 1)
RetVal& = RetVal& + 1
End If
If RetVal& = Len(InString$) Then InString$ = InString$ + Chr$(48)
Do While Asc(Right$(InString$, 1)) = 48 And RetVal& < (Len(InString$) - 1)
InString$ = Left$(InString$, Len(InString$) - 1)
Loop
Do While Asc(Mid$(InString$, 2, 1)) = 48 And RetVal& > 3
InString$ = Left$(InString$, 1) + Right$(InString$, Len(InString$) - 2)
RetVal& = RetVal& - 1
Loop
End If
Case 11
' {00B} Read Sign ("+", "-", or CHR$(241))
' Returns:
' Explicit: +1 = Positive; -1 = Negative; 0 = Unsigned;
' Implied: +64 = Positive; -64 = NULL String
If RetVal& = 0 Then RetVal& = -64
For I& = 1 To RetVal&
Select Case Asc(Mid$(InString$, I&, 1))
Case 32
RetVal& = 64
' keep going
Case 43
RetVal& = 1
Exit For
Case 45
RetVal& = -1
Exit For
Case 241
RetVal& = 0
Exit For
Case Else
RetVal& = 64
Exit For
End Select
Next I&
Case Else
RetVal& = 0 - Op&
End Select
Check& = RetVal&
End FunctionCode to plug in and use for string math. So far, I've only coded these for addition or subtraction, though the older BTEN$ also handles multiplication and SQRT. I figured I'd toss these up here as it seems nearly every programmer ends up writing a sting math routine at some point in their coding career, and these should be easy enough to plug into any other program and use as a comparison test to make certain that results match.
Of course, if results don't match, and the issue is somehow with my code here, feel free to mention it to me and I'll try and dig into the problem and sort it out. There's a lot of little tweaks which can toss string math off, so I wouldn't swear everything here is 100% bug-free, but it's got 2 different routines to compare against, if you need it. AFAIK, things work without issues, but I wouldn't swear to anything. After all, @Pete found a glitch earlier where my integer64 variables were trying to do floating point math, and I *never* would've expected that ! (Especially just to add 1 for carryover!!)
I reserve the right to always hide glitches somewhere in the code for... umm.... for... for learning experience! Yeah! There might be some in there for the learning experience!
