A (very hard) easy math qwestion

[kedaman]

Yep, this is just something for you who have nothing to do for the moment.

Multiply these values:

29345872602374560293475092374059716888384666023740523098028
20398602938570189304576187468987610438502734592487572345860

But you'll get no bonus points if you don't show your method.

[Arbiter]

OK, I've multiplied them.

I don't want any points so I'm going to show you neither my method, nor my answer.

:D

[Iain17]

5886148021017041140702685048723535923611387590845662110441587235041736501033684329157951756090654878 83425026699964085

How i did it ?

I programmed a long multiplication with strings.

[Mad Compie]

Yeah right, lain17. But I think there's an error in your calculation!
The correct result should be:

5986148031017041140702685048723535933611397590845662210441587235041736501033684329157951756090654878 83425026699964080

and not

5886148021017041140702685048723535923611387590845662110441587235041736501033684329157951756090654878 83425026699964085

That was a nice thread Kedaman! You really are a guru.

My solution (add to a form):

Option Explicit
' Huge multiplications
' (c)2000 by Marc Compernolle "Mad Compie"
'
'
' V1
' V2
' x-------
' = Result
'
'This form needs a listbox (lstMultiply),
' two textboxes (txtV1, txtV2) with MultiLine=True and Scrollbars=1
' two buttons (cmdEnd, cmdMultiply)
'
' Form width x height = 6975 x 5160 twips
' List width x height = 409 x 173 pixels
' Text width x height = 409 x 33 pixels
'
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long

Const LB_SETHORIZONTALEXTENT = &H194

Const GWL_STYLE = (-16)
Const ES_NUMBER = &H2000&

Dim Result As String 'end result
Dim SumTerms() As String 'number of sum terms

Private Sub cmdEnd_Click()
Unload Me
End Sub

Private Sub cmdMultiply_Click()
Dim V1 As String
Dim V2 As String
Dim V1_Length As Integer
Dim V2_Length As Integer
Dim SumLength As Integer
Dim i As Integer
Dim j As Integer
Dim Adder As Integer
Dim POS As Integer
Dim a As Integer
Dim b As Integer
Dim c As Integer

' V1
' V2
'x------
' Result

If Not IsNumeric(txtV1.Text) Then Beep: Exit Sub
If Not IsNumeric(txtV2.Text) Then Beep: Exit Sub

V1 = Trim$(txtV1.Text)
V2 = Trim$(txtV2.Text)

lstMultiply.Clear

V1_Length = Len(V1)
V2_Length = Len(V2)
SumLength = V1_Length + V2_Length
ReDim SumTerms(1 To V2_Length) As String

For i = 1 To V2_Length
SumTerms(i) = String$(SumLength, "0")
Next i
Result = String$(SumLength, "0")

POS = 0

For i = V2_Length To 1 Step -1
a = Val(Mid$(V2, i, 1))
Adder = 0
For j = V1_Length To 1 Step -1
b = Val(Mid$(V1, j, 1))
c = Adder + a * b
If (j > 1) Then
Mid$(SumTerms(i), SumLength - (V1_Length - j) - POS, 1) = "" & (c Mod 10)
Adder = c \ 10
Else
Mid$(SumTerms(i), SumLength - (V1_Length - j) - POS, 1) = "" & (c Mod 10)
Mid$(SumTerms(i), SumLength - (V1_Length - j) - POS - 1, 1) = "" & (c \ 10)
End If
Next j
POS = POS + 1
Next i
lstMultiply.AddItem ""
lstMultiply.AddItem "The terms are:"
For i = V2_Length To 1 Step -1
lstMultiply.AddItem SumTerms(i)
Next i
lstMultiply.AddItem ""
lstMultiply.AddItem "The product is:"
Adder = 0
For i = SumLength To 1 Step -1
a = Adder
For j = V2_Length To 1 Step -1
a = a + Val(Mid$(SumTerms(j), i, 1))
Next j
Mid$(Result, i, 1) = "" & a Mod 10
Adder = a \ 10
Next i
lstMultiply.AddItem Result
End Sub

Private Sub Form_Load()
Dim CurrStyle As Long

Me.ScaleMode = vbPixels

'Set the textboxes numerical...
CurrStyle = GetWindowLong(txtV1.hwnd, GWL_STYLE) Or ES_NUMBER
SetWindowLong txtV1.hwnd, GWL_STYLE, CurrStyle
CurrStyle = GetWindowLong(txtV2.hwnd, GWL_STYLE) Or ES_NUMBER
SetWindowLong txtV2.hwnd, GWL_STYLE, CurrStyle
txtV1.Text = "29345872602374560293475092374059716888384666023740523098028"
txtV2.Text = "20398602938570189304576187468987610438502734592487572345860"
'SendMessage lstMultiply.hwnd, LB_FINDSTRING, -1, ByVal CStr(Text1.Text)
'Set the horizontal scrollbar on the listbox to 1024pels...
SendMessage lstMultiply.hwnd, LB_SETHORIZONTALEXTENT, 1024, 0&
End Sub

Private Sub Form_Unload(Cancel As Integer)
Erase SumTerms
End
End Sub

Private Sub txtV1_KeyPress(KeyAscii As Integer)
If (KeyAscii = 13) Then KeyAscii = 0 'Suppress the CRLF
End Sub

Private Sub txtV2_KeyPress(KeyAscii As Integer)
If (KeyAscii = 13) Then KeyAscii = 0 'Suppress the CRLF
End Sub

[Iain17]

Opps, i messed up the remainder in one place.

*bangs his head against the wall and goes off to die*

[KWell]

5986147103101610411310702685048723535933611397590845662110104415872350417365010336843291579517560906 5487883425026699964080

Here is my code
Function Multiplication(Nbr1 As String, Nbr2 As String) As String
Dim N1() As Byte
Dim Idx1 As Integer
Dim IdxMax1 As Integer
Dim N2() As Byte
Dim Idx2 As Integer
Dim IdxMax2 As Integer
Dim NRes() As Byte
Dim IdxRes As Integer
Dim Idx As Integer
Dim IdxResMax As Integer
Dim Result As String
Dim NResTemp() As Byte
Dim Report As Byte
Dim i As Integer

' Init of the arrays
IdxMax1 = Len(Nbr1)
IdxMax2 = Len(Nbr2)
ReDim N1(IdxMax1)
ReDim N2(IdxMax2)
IdxResMax = IdxMax1 + IdxMax2
ReDim NRes(IdxResMax)

For i = 0 To IdxMax1 - 1
N1(i + 1) = Mid(Nbr1, IdxMax1 - i, 1)
Next

For i = 0 To IdxMax2 - 1
N2(i + 1) = Mid(Nbr2, IdxMax2 - i, 1)
Next

' Multiplication
For Idx1 = 1 To IdxMax1
For Idx2 = 1 To IdxMax2
NRes(Idx1 + Idx2 - 1) = NRes(Idx1 + Idx2 - 1) + N1(Idx1) * N2(Idx2)
If NRes(Idx1 + Idx2 - 1) >= 10 Then
NRes(Idx1 + Idx2) = NRes(Idx1 + Idx2) + Int(NRes(Idx1 + Idx2 - 1) / 10)
NRes(Idx1 + Idx2 - 1) = NRes(Idx1 + Idx2 - 1) Mod 10
End If
Next Idx2
Next Idx1

' Put the result in a string
For i = IdxResMax To 1 Step -1
Result = Result & Trim(Str(NRes(i)))
Next
' Delete all zero before the number
While Left(Result, 1) = "0"
Result = Mid(Result, 2)
Wend
Multiplication = Result
End Function

Sub TestMultiplication()
Dim Nbr1 As String
Dim Nbr2 As String
Dim Result As String
Nbr1 = "29345872602374560293475092374059716888384666023740523098028"
Nbr2 = "20398602938570189304576187468987610438502734592487572345860"
Result = Multiplication(Nbr1, Nbr2)
Debug.Print Nbr1
Debug.Print Nbr2 & " x"
Debug.Print String(Len(Nbr2), "-")
Debug.Print Result
End Sub

[Edited by kwell on 09-26-2000 at 08:58 AM]

[Mad Compie]

Hmm, I think you're a little bit wrong here, KWell. I think the placement of the 10ths are miscalculated.
Long live my solution!
What about yours, Keda?

[Iain17]

Yeah, very good Mad Compie, just to let you know that your soloution wont even work on VERY big numbers. Try it and see.

[Mad Compie]

Hm, wouldn't it?
I don't know.
Maybe because VB6 only allows a integer sized max string length?
This means that the result string should have a max length 32767 digits?
Or is it not that what you are trying to say, Lain17 ?

[kedaman]

Oh nice work guys! I have looked trough your algoritms and we have a winner!
The winner is...






ok, first the correct answer is

5986148031017041140702685048723535933611397590845662210441587235041736501033684329157951756090654878 83425026699964080

and my own algoritm, if anyone doubts me...

Sub main()
Debug.Print MultString("29345872602374560293475092374059716888384666023740523098028", "20398602938570189304576187468987610438502734592487572345860")
'598614803101704114070268504872353593361139759084566221044158723504173650103368432915795175609065487 883425026699964080
End Sub

Function MultString$(stra$, strb$)
Dim a() As Byte, b() As Byte, res() As Byte, temp&, x&, y&, z&
a = StrConv(stra, vbFromUnicode)
b = StrConv(strb, vbFromUnicode)
ReDim res(Len(stra) + Len(strb) - 2)
For x = 0 To UBound(a)
For y = 0 To UBound(b)
Position = UBound(a) - x + UBound(b) - y
z = Position
temp = CLng(a(x) - 48) * (b(y) - 48)
Do While temp
If z > UBound(res) Then ReDim Preserve res(z)
temp = temp + res(z)
res(z) = temp Mod 10
temp = Int(temp / 10)
z = z + 1
Loop
Next y
Next x
For x = 0 To UBound(res)
res(x) = res(x) + 48
Next x
MultString = ReverseString(StrConv(res, vbUnicode))
End Function
Function ReverseString(Str As String) As String
For x = Len(Str) To 1 Step -1
ReverseString = ReverseString & Mid(Str, x, 1)
Next x
End Function


Now the winner is (correct me if i'm wrong)
The winner is, Mad Compie, and you get one bonus points for solving it brilliantly
Iain and Kwell get's second,
Iain get one bonus point for having a very close answer (and you could get more if you posted your function too)
Kwell get's one bonus point for a nice try and organized code, nice work guys ;)
Mad Compie 3p
Iain 1p
Kwell 1p
Arbiter could get a point if you show us your answer+code

[kedaman]

Also i forgot, the max length of a string is 2147483648, 2^31 or 2 Gb.

[Arbiter]

Well,

It's funny you should say that Kedaman, but I got the same answer you did and my code looked absolutely identical.

Remarkable really.

Okay, Okay I didn't even try. Come up with some more challenges though and I promise I'll try next time.

[kedaman]

Now this one is harder.

The squareroot of
8923650187589071592837401740527047801837856239745170

[Iain17]

Well, my code is comparitivley crap as i just threw it together to answer the question as quickly as possible, and look what happened, i forgot to carry the remaninder.


Function bigMultiply(strNum1 As String, strNum2 As String) As String
Dim strAnswer() As String
Dim strTemp As String
Dim iNum1 As Integer, iNum2 As Integer
Dim iTempAnswer As Integer, iRem As Integer
Dim iAnswer As Integer
Dim i As Long, j As Long

ReDim strAnswer(1 To Len(strNum2)) As String

For i = Len(strNum2) To 1 Step -1
iNum1 = Mid$(strNum2, i, 1)
For j = Len(strNum1) To 1 Step -1
iNum2 = Mid$(strNum1, j, 1)

iTempAnswer = iNum1 * iNum2 + iRem
iAnswer = (iTempAnswer) Mod 10
iRem = iTempAnswer \ 10

strAnswer(i) = strAnswer(i) & iAnswer
Next j
If iRem > 0 Then
strAnswer(i) = strAnswer(i) & iRem
iRem = 0
End If
strAnswer(i) = String(Len(strNum2) - i, "0") & strAnswer(i)
Next i


For i = UBound(strAnswer) To LBound(strAnswer) Step -1
For j = 1 To Len(strAnswer(i))
iNum1 = Val(Mid$(bigMultiply, j, 1))
iNum2 = Val(Mid$(strAnswer(i), j, 1))

iTempAnswer = iNum1 + iNum2 + iRem
iAnswer = iTempAnswer Mod 10
iRem = iTempAnswer \ 10

strTemp = strTemp & iAnswer
Next j
If iRem > 0 Then
strTemp = strTemp & iRem
iRem = 0
End If
bigMultiply = strTemp
strTemp = ""
Next i

bigMultiply = StrReverse(bigMultiply)

End Function

[kedaman]

Ok, Iain get's another point, well not 2 because Mad compie got 2 for the "first correct answer"

Now How about The a bit more harder problem, you don't need to have the decimals below 10^0

Three points to the first correct answer, Two for correct answer, and some bonuspoints if you have something extra

[KWell]

The squareroot of 8923650187589071592837401740527047801837856239745170
is
94465073903475413482026203.3461236635024168025764851517941468748656
with 40 decimals

Here is my code
Option Explicit

Function Multiplication(Nbr1 As String, Nbr2 As String) As String
Dim N1() As Byte
Dim Idx1 As Integer
Dim IdxMax1 As Integer
Dim N2() As Byte
Dim Idx2 As Integer
Dim IdxMax2 As Integer
Dim NRes() As Byte
Dim IdxRes As Integer
Dim Idx As Integer
Dim IdxResMax As Integer
Dim Result As String
Dim NResTemp() As Byte
Dim Report As Byte
Dim i As Integer

' Init of the arrays
IdxMax1 = Len(Nbr1)
IdxMax2 = Len(Nbr2)
ReDim N1(IdxMax1)
ReDim N2(IdxMax2)
IdxResMax = IdxMax1 + IdxMax2
ReDim NRes(IdxResMax)

For i = 0 To IdxMax1 - 1
N1(i + 1) = Mid(Nbr1, IdxMax1 - i, 1)
Next

For i = 0 To IdxMax2 - 1
N2(i + 1) = Mid(Nbr2, IdxMax2 - i, 1)
Next

' Multiplication
For Idx1 = 1 To IdxMax1
For Idx2 = 1 To IdxMax2
NRes(Idx1 + Idx2 - 1) = NRes(Idx1 + Idx2 - 1) + N1(Idx1) * N2(Idx2)
If NRes(Idx1 + Idx2 - 1) >= 10 Then
NRes(Idx1 + Idx2) = NRes(Idx1 + Idx2) + Int(NRes(Idx1 + Idx2 - 1) / 10)
NRes(Idx1 + Idx2 - 1) = NRes(Idx1 + Idx2 - 1) Mod 10
End If
Next Idx2
Next Idx1

' Put the result in a string
For i = IdxResMax To 1 Step -1
Result = Result & Trim(Str(NRes(i)))
Next
' Delete all zero before the number
While Left(Result, 1) = "0"
Result = Mid(Result, 2)
Wend
Multiplication = Result
End Function

Sub TestMultiplication()
Dim Nbr1 As String
Dim Nbr2 As String
Dim Result As String
Nbr1 = "29345872602374560293475092374059716888384666023740523098028"
Nbr2 = "20398602938570189304576187468987610438502734592487572345860"
Result = Multiplication(Nbr1, Nbr2)
Debug.Print Nbr1
Debug.Print Nbr2 & " x"
Debug.Print String(Len(Nbr2), "-")
Debug.Print Result
End Sub

Function Addition(Nbr1 As String, Nbr2 As String) As String
Dim Idx1 As Integer
Dim IdxMax1 As Integer
Dim Idx2 As Integer
Dim IdxMax2 As Integer
Dim IdxRes As Integer
Dim IdxMaxRes As Integer
Dim Nb1() As Byte
Dim Nb2() As Byte
Dim NbRes() As Byte
Dim i As Integer
Dim Report As Integer
Dim Result As String
IdxMax1 = Len(Nbr1)
IdxMax2 = Len(Nbr2)
IdxMaxRes = IIf(IdxMax1 > IdxMax2, IdxMax1 + 1, IdxMax2 + 1)
ReDim Nb1(IdxMaxRes - 1)
ReDim Nb2(IdxMaxRes - 1)
ReDim NbRes(IdxMaxRes)

For i = 0 To IdxMax1 - 1
Nb1(i + 1) = Mid(Nbr1, IdxMax1 - i, 1)
Next
Report = 0
For i = 0 To IdxMax2 - 1
Nb2(i + 1) = Mid(Nbr2, IdxMax2 - i, 1)
Next


For i = 1 To IdxMaxRes - 1
NbRes(i) = Nb1(i) + Nb2(i) + Report
If NbRes(i) >= 10 Then
Report = 1
NbRes(i) = NbRes(i) Mod 10
End If
Next i
If Report <> 0 Then
NbRes(IdxMaxRes) = NbRes(IdxMaxRes) + Report
End If

' Put the result in a string
For i = IdxMaxRes To 1 Step -1
Result = Result & Trim(Str(NbRes(i)))
Next
' Delete all zero before the number
While Left(Result, 1) = "0"
Result = Mid(Result, 2)
Wend
Addition = Result
End Function

Function SquareRoot(Byval Number As String, Byval Decimale As Integer) As String
Dim CurNumber As String
Dim LastNumber As String
Dim Increment As String
Dim Square As String
Number = Number & String(2 * Decimale, "0")
LastNumber = "0"
CurNumber = "0"
Increment = "1" & String((Len(Number) / 2) - 1, "0")
CurNumber = Increment
Square = Multiplication(CurNumber, CurNumber)
While (Not Square = Number) And Increment <> ""
While Not Greater(Square, Number)
LastNumber = CurNumber
CurNumber = Addition(CurNumber, Increment)
Square = Multiplication(CurNumber, CurNumber)
Wend
'Debug.Print CurNumber, LastNumber
'Debug.Print " " & Square, Number
'Debug.Print

If Square <> Number Then
Increment = Mid(Increment, 1, Len(Increment) - 1)
CurNumber = LastNumber 'Addition(LastNumber, Increment)
Square = Multiplication(CurNumber, CurNumber)
End If
Wend

'PrintNumber CurNumber, Decimale
'PrintNumber Square, 2 * Decimale
'PrintNumber Number, 2 * Decimale
SquareRoot = GetNumber(CurNumber, Decimale)
End Function

Function PrintNumber(Number As String, Decimale As Integer) As String
Debug.Print Left(Number, Len(Number) - Decimale) & "." & Right(Number, Decimale)
End Function

Function GetNumber(Number As String, Decimale As Integer) As String
GetNumber = Left(Number, Len(Number) - Decimale) & "." & Right(Number, Decimale)
End Function

Function Greater(Nb1 As String, Nb2 As String) As Boolean
' Delete all zero before the number
While Left(Nb1, 1) = "0"
Nb1 = Mid(Nb1, 2)
Wend
While Left(Nb2, 1) = "0"
Nb1 = Mid(Nb2, 2)
Wend
If Len(Nb1) > Len(Nb2) Then
Greater = True
ElseIf Len(Nb2) > Len(Nb1) Then
Greater = False
Else
Greater = Nb1 >= Nb2
End If
End Function

Sub TestSquareroot()
Dim Number As String
Dim SqRoot As String
Dim Decimale As Integer
Number = "8923650187589071592837401740527047801837856239745170"

Decimale = 40
SqRoot = SquareRoot(Number, Decimale)
Debug.Print "The Square root of "
Debug.Print Number
Debug.Print "is"
Debug.Print SqRoot
Debug.Print "with a precision of " & Decimale & " decimal(s)"
End Sub

[Arbiter]

Well, I did the easy bit. I got the answer with an incredibly small piece of code, but I'm far too stupid to get it to display all the decimal places.


Option Compare Database
Option Explicit

Dim blnStop As Boolean

Private Sub Command3_Click()
Dim storage

On Error Resume Next

temp.Caption = 2

Do While blnStop = False
DoEvents
temp2.Caption = ""
storage = ((Val(Value.Caption) / Val(temp.Caption)) + Val(temp.Caption)) / 2
current.Caption = storage * storage
temp.Caption = storage
Loop

End Sub

Private Sub Command5_Click()
blnStop = true
end sub



How would I go about getting it to display all the decimal place.

PS - I'm using VBA in Access as I'm at work, which is also why I don't have time to race people to the answer, sorry...

[kedaman]

Option Compare Database?!?!?

gives me an expected "text or binary", so i guess Database is something new in VB6 or???
What does it do and how is it related to your solution?

Anyway, hehe, not going to reveal the real asnwer until i've got some more replies ;)

[Mad Compie]

Thanks for the bonus, Keda!

I was some time away and just read the new test. Hm, do I smell some recursive routines here?

Please wait for my answer (but not too long...)

[Yonatan]

Originally posted by kedaman
Option Compare Database?!?!?

gives me an expected "text or binary", so i guess Database is something new in VB6 or???
What does it do and how is it related to your solution?

It is not related. :rolleyes:
Arbiter is using Microsoft Access VBA and it automatically adds Option Compare Database (an Access-VBA-only compare option) to all the code modules.

[Arbiter]

Yeah, I'm using VBA in Access as I don't have VB at work, only at home. I'm a Business Analyst not a developer, so I have no need for VB as part of my job.

It makes things a little awkward but hey, I shouldn't really be doing this in work time anyway!

You can just remove Option Compare Database.

[kedaman]

Seems that it was a pretty hard one, since not many got any solutions, but yes, we have a winner and you probably know who it is ;)

But first, as usual, the correct answer is (without extra decimals)

94465073903475413482026203

And if anyone want's my code...

Function SqrString(str As String)
Dim res() As Byte, x&
res = StrConv(String(Int(Log(str) / Log(100) + 1), "0"), vbFromUnicode)
For x = 0 To UBound(res)
Do Until Right(String(Len(str), "0") & MultString(StrConv(res, vbUnicode), StrConv(res, vbUnicode)), Len(str) + 1) > "0" & str
res(x) = res(x) + 1
Loop
res(x) = res(x) - 1
Next x
SqrString = StrConv(res, vbUnicode)
End Function


So, there is a winner, and he is...


He is KWell!!!!! 3 points! 3 points for the first correct answer and 1 bonus point for the 40 or more if needed decimals!!!
Arbiter get's 1 point for a very nice try :) Well that's better than 0 points for all the others that didn't try. Although i'm not sure what your code does but it surely get's the squareroot but you don't have the needed decimals.

[KWell]

Kwell 5
Mad Compie 3p
Arbiter 2p
Iain 2p

Wow, i'm the first with 5p!!

Kedaman, what's the new chalenge ?

[Mad Compie]

Sadly I did not have too much time to compete with you guys.
Maybe some other time.
By the way, Keda, why are you using vbUnicode and StrConv. I'm not quite familiar with it.
I tought that Windows does not support Unicode chars?

[kedaman]

ACtually Strings are unicode by default in vb :) So you can use use strconv to convert a unicode string to a byte array for instance. It's much more faster way to calculate with a byte array than converting a part of a string all the time.
Anyone want's more math problems? or was that last one too hard? hehe

[Mad Compie]

hm,

How about a calculation of PI with 1000 decimals?

There's a cool way of remembering Pi:

'May I have a large container of coffee? Thank you.
' 3 1 4 1 5 9 2 6 5 3
'
'The numbers under the words are the number of letters
'in each word. Put all the numbers together and you
'get exactly Pi:
'Pi = 3.141592653.... :)

[Yonatan]

Here are a few calculation methods.
None give you many decimals, but you'll get over it. :rolleyes:
Here they are, from best to worst:

#1: Arctangent!

Dim Pi As Double

Pi = Atn(1) * 4
' Which is equivalent to...
Pi = Atn(0.2) - 4 * Atn(1 / 239)

#2: Algorithm-named-after-someone-with-a-long-name!

Dim Pi As Double
Dim I As Long

' Define how accurate the calculation will be, and how long it will take:
Const Precision = 1000000 ' 1 million is average precision.

For I = 1 To Precision Step 2
Pi = Pi + (-I Mod 4 + 2) * (4 / I) ' I think this would be faster in C++. :rolleyes:
Next

#3: Another unknown method! Comes close, but not accurate.

Dim Pi As Double

Pi = ((0.5 + Sqr(0.125) + Sqr(Sqr(0.5))) ^ 2) / (1 - 4 * ((Sqr(0.125) - 0.5) ^ 2))

#4: A simple constant expression which comes quite close. This is a very very old method. (Babylonians?)

Const Pi As Double = (4 / 3) ^ 4

#5: Estimate the value of Pi! That's right, estimate! Different result every time!

Dim Pi As Double
Dim N As Long, I As Long

' Define how accurate the estimation will be, and how long it will take:
Const Precision = 100000 ' 100 thousand is about average for this one!

Call Randomize ' This line does not look good on Pi-calculation code, does it?

For I = 1 To Precision
If Rnd ^ 2 + Rnd ^ 2 <= 1 Then N = N + 1
Next

Pi = 4 * N / Precision

Enjoy! :rolleyes:

[oetje]

I know the value of pi in 50 decimals: 3.14159265358979323846264338327950288419716939937510

[KWell]

Here is my code (based on a C code)
Declare Function GetTickCount Lib "kernel32.dll" () As Long

Dim Result() As Long ' Temp Result
Dim Result1() As Long ' Final Result and Arctg(1/5)
Dim Result2() As Long ' Arctg(1/239)
Dim Lim As Long ' Nbr of decimals
Dim K As Long ' Count of null cell
Dim MAX As Long ' Max dim of array
Dim BASE As Long ' Base of the number
Dim GBASE As Long ' Nbr group for the output
Dim I5 As Long ' Nbr iteration for the compute of the arctg 1/5
Dim I239 As Long ' Nbr iteration for the compute of the arctg 1/239
Public Msg As String '
Dim TStart As Long
Dim TEnd As Long


Sub LaunchComputation()
Debug.Print CalculPi(1000)
Debug.Print Msg
End Sub

Function CalculPi(NbDeci As Long) As String
' PI = 16*ArcTG(1/5) - 4*ArcTg(1/239)
Lim = NbDeci
' Max decimale for Arctg(1/5) and arctg(1/239)
' Base 1000000 = 1502 and 5104
' Base 100000 = 15012 and 51070
' Base 10000 = ...
If Lim <= 1500 Then
BASE = 1000000
NB = 6
GBASE = 10
ElseIf Lim <= 15000 Then
BASE = 100000
NB = 5
GBASE = 12
ElseIf Lim <= 150000 Then
BASE = 10000
NB = 4
GBASE = 15
ElseIf Lim <= 1500000 Then
BASE = 1000
NB = 3
GBASE = 20
Else
MsgBox "This code is for compute not more than 1500000 decimals. You can but it take long time."
Exit Function
End If

TStart = GetTickCount

K = 0
MAX = 3 + Lim / NB
ReDim Result(4 * MAX)
ReDim Result1(4 * MAX)
I5 = ArcTg(Result, 5, Result1)
K = 0
Mult Result1, 16
ReDim Result(4 * MAX)
ReDim Result2(4 * MAX)
I239 = ArcTg(Result, 239, Result2)
K = 0
Mult Result2, 4

K = 0
Sous Result1, Result2

TEnd = GetTickCount

Msg = "Decimal print: " & NB * (MAX - 2) & " - Nbr of Iteration: " & I5 & ", " & I239 & " (" & I5 + I239 & ")"
Msg = Msg & vbCrLf
Msg = Msg & "in " & (TEnd - TStart) / 1000 & "seconds"

CalculPi = " Pi = " & BaseToDec(Result1)
End Function

Function BaseToDec(Table() As Long) As String ' Convert number in base BASE to base 10
Dim i As Integer
Dim Tmp As Long
Dim BS10 As Long
Dim StrPi As String
BS10 = BASE / 10 ' max number of digit in the base number
StrPi = StrPi & Table(0) & " "
i = 1
While i < MAX - 1
Tmp = Table(i)
Tmp = IIf(Tmp = 0, 1, Tmp)
While Tmp < BS10
StrPi = StrPi & "0"
Tmp = 10 * Tmp
Wend

StrPi = StrPi & Trim(Table(i))
If i Mod GBASE Then
StrPi = StrPi & " "
Else
StrPi = StrPi & vbCrLf & " "
End If
i = i + 1
Wend
BaseToDec = StrPi
End Function

Sub Add(a() As Long, b() As Long) ' Add 2 arrays
Dim i As Integer
Dim r As Long
r = 0
i = MAX - 1
While i >= K
r = a(i) + r + b(i)
If r >= BASE Then
a(i) = r - BASE
r = 1
Else
a(i) = r
r = 0
End If
i = i - 1
Wend
While r <> 0
r = a(i) + r
If r >= BASE Then
a(i) = r - BASE
r = 1
Else
a(i) = r
r = 0
End If
i = i - 1
Wend
End Sub

Sub Sous(a() As Long, b() As Long) ' Sub 2 arrays (singn of the result +)
Dim i As Integer
Dim r As Long
r = 0
i = MAX - 1
While i >= K
r = a(i) - r - b(i)
If (r < 0) Then
a(i) = r + BASE
r = 1
Else
a(i) = r
r = 0
End If
i = i - 1
Wend
While r <> 0
r = a(i) - r
If (r < 0) Then
a(i) = r + BASE
r = 1
Else
a(i) = r
r = 0
End If
i = i - 1
Wend
End Sub

Sub Mult(a() As Long, n As Long) ' Mult an array by a number
Dim i As Integer
Dim s As Long
s = 0
i = MAX - 1
While i >= K
a(i) = a(i) * n + s
s = Int(a(i) / BASE)
a(i) = a(i) Mod BASE
i = i - 1
Wend
If i <> -1 Then
a(i) = a(i) * n + s
While ((s = a(i)) >= BASE)
a(i - 1) = a(i - 1) + s / BASE
a(i) = s Mod BASE
i = i - 1
K = K - 1
Wend
End If
If K > 0 Then
K = K - 1
End If
While (a(K) = 0) And K <= MAX
K = K + 1 ' /* GESTION DES CASES NULLES */
Wend
End Sub

Sub Div(t() As Long, n As Long) ' Divide a array by a number
Dim i As Integer
Dim a As Long
a = t(K)
i = K
While i < MAX
t(i) = Int(a / n)
a = BASE * (a Mod n) + t(i + 1)
i = i + 1
Wend
While (t(K) = 0) And K <= MAX
K = K + 1 ' Count the number of first null cell for find when we stop
Wend
End Sub

Function ArcTg(a() As Long, p As Long, Result() As Long) As Long ' arctg(1/p) where 1/p is in radian
'ArtTg(1/X) = U0(X) + U1(X) + U2(X) + ... + Ui(X) + ...
' Where Ui(X)= -1^i/((2i+1)*X^(2i+1))
' and X = ° radian
'
' -> U0(X)=1/X
' Un+1(X)=-1*(2n+1)/((2n+3)*X*X) * Un(X)
'
Dim i As Long
K = 0
i = 0
a(i) = 1 '6
Div a, p 'U0(X)
Add Result, a
While K < MAX
' Calcul of Ui+1(X)
' a = Ui(X)
' a / (2i+3)
Div a, (2 * i + 3)
' a / X^2
Div a, p
Div a, p
' a * (2i+1)
Mult a, (2 * i + 1)
' a * -1^i
If i Mod 2 Then
Add Result, a
Else
Sous Result, a
End If
i = i + 1
Wend
ArcTg = i
End Function

[Michael]

Too many people with wayyyyyyyyyyyy too much spare time on their hands.

My advice: Get out more.

[kedaman]

Oh my god! :D
I had made up 4 qwestion for you this weekend and now it seems like 3 of them have been completely answered!!!

Well actually the first one was of calculating Tangens of a value but while i was thinking about of how to solve it, i found you need to divide two values, calculate pi and Integrate a circle function, so i added them to the list for others who would like to solve a bit easier qwestions first.

Now i got your answers even before i asked the qwestions :D :D

but hey, i had a fourth qwestion, maybe you could find out the anwer?
20940562793640971452396459^2.258

Kwell, great work! You converted that from C and maybe you have a lot more math related stuff in C? I'm especially interested in the trigonometrical functions. Do you have them?

[Mad Compie]

Well guys, here's my solution. You can calculate PI at a given number of decimals:


'This form "frmPI" needs:
' 1 CommandButton "cmdCalculate"
' 1 Label: "lblPI"
' 2 TextBoxes: "txtNumbers" and "txtOutput"
'
Dim CalculatingPi As Boolean ' toggle true/false whether calc'ing pi

'
' Infinite Sums Formulas:
'
' Pi = 1/1 - 1/3 + 1/5 - 1/7 + 1/9 - 1/11 . . . = 4 / Pi
'
' Pi = 1/1^2 + 1/2^2 + 1/3^2 +1/4^2 + 1/5^2 . . . = (Pi^2) / 6
'
'
' ArcTangent Formulas:
'
' Pi = 4 * Atn(1)
'
' Euler's Formula:
' Pi = 20 * Atn(1/7) + 8 * Atn(3/79)
'
' Gauss's Formula:
' Pi = 48 * Atn(1/18) + 32 * Atn(1/57) - 20 * Atn(1/239)
'
' Machin's Formula:
' Pi = 16 * Atn(1/5) - 4 * Atn(1/239)
'
'
' Power Series Expansion for ArcTangent:
' Atn(X) = X - X^3 /3 + X^5 /5 - X^7 /7 + X^9 /9 . . .
'
'
'
' Ramanujan's Formulas:
'
' 1 1103 27493 1 1*3 53883 1*3 1*3*5*7
' ----------- = ---- + ----- - --- + ----- --- ------- + . . .
' 2*pi*Sqr(2) 99^2 99^6 2 4^2 99^10 2*4 4^2+8^2
'
'
' Elliptic Integral Formula:
'
' 1/pi = [ sqrt(8) / 9801 ] * sum { (4n)! * (1103+26390n) /
' [(n!)^4 * 396^(4n) ] } (n=0,1,2,... )


Sub cmdCalculate_Click()
If Not (CalculatingPi) Then CalculatePi Else Unload Me
End Sub

Sub CalculatePi()
Dim TimeSpent As Double
Dim PiValue As String

If Not IsNumeric(txtNumbers.Text) Then Beep: txtNumbers.Text = 0: Exit Sub

TimeSpent = Timer

txtOutput = "Initializing": DoEvents
CalculatingPi = True
cmdCalculate.Caption = "Stop!"

Dim X As Integer
Dim CarryPosition As Integer
' to be used in subtraction routine below

Dim NumberOfLoops As Integer
Dim LengthOfNumbers As Integer
' variables to be passed to FindArcTangent sub

LengthOfNumbers = txtNumbers + 3
' add 3 extra places because last couple may not be accurate
NumberOfLoops = Int(2 / 3 * LengthOfNumbers)
' each iteration should produce about 1 1/2 accurate places


' all numbers needed to be super accurate in this program
' are represented by arrays consisting of single character
' length strings. the 1 position contains the digit in the
' number to the far left, and the >1 positions in the array
' represent the numbers going to the right in the # from there

ReDim ArcTangent5(1 To LengthOfNumbers) As String * 1
ReDim ArcTangent239(1 To LengthOfNumbers) As String * 1
' arrays to be calculated by FindArcTangent sub
ReDim MultipliedArcTangent5(1 To LengthOfNumbers + 1) As String * 1
' arrays to be calculated by MultiplyArray sub
ReDim MultipliedArcTangent239(1 To LengthOfNumbers + 1) As String * 1

' Machin's Formula:
' Pi = 16 * Atn(1/5) - 4 * Atn(1/239)
txtOutput = "Calculating ArcTangent of 1/5": DoEvents
FindArcTangent 5, NumberOfLoops, LengthOfNumbers, ArcTangent5()
txtOutput = "Calculating the ArcTangent of 1/239": DoEvents
FindArcTangent 239, NumberOfLoops, LengthOfNumbers, ArcTangent239()
txtOutput = "Multiplying ArcTan of 1/5 by 16": DoEvents
MultiplyArray ArcTangent5(), 16, MultipliedArcTangent5()
txtOutput = "Multiplying ArcTan of 1/239 by 4": DoEvents
MultiplyArray ArcTangent239(), 4, MultipliedArcTangent239()
txtOutput = "Subtracting the Multiplied Arctangents": DoEvents
For X = LengthOfNumbers To 1 Step -1
' subtract MultipliedArcTangent239 array
' from MultipliedArcTangent5 array
If MultipliedArcTangent5(X) < MultipliedArcTangent239(X) Then
' do we need to carry?
CarryPosition = X - 1 ' start with 1st number to the left
Do Until MultipliedArcTangent5(CarryPosition) <> "0"
' find a non-zero number to borrow from
MultipliedArcTangent5(CarryPosition) = "9" 'fill the other #'s
CarryPosition = CarryPosition - 1 ' with 9's
' go to the next number to the left
Loop ' loop until finding a non-zero number
' at end of loop, CarryPosition will be # to borrow from
MultipliedArcTangent5(CarryPosition) = CStr(CInt(MultipliedArcTangent5(CarryPosition)) - 1)
' decrease number carried from by one
MultipliedArcTangent5(X) = CStr((CInt(MultipliedArcTangent5(X)) + 10) - CInt(MultipliedArcTangent239(X)))
'add an extra ten (borrowed) to MultipliedArcTangent5 and subtract MultipliedArcTangent239
Else ' just simple subtraction if there isn't carrying
MultipliedArcTangent5(X) = CStr(CInt(MultipliedArcTangent5(X)) - CInt(MultipliedArcTangent239(X)))
End If
DoEvents
Next X ' loop to subtract entire MultipliedArcTangent239 array

' with the MultipliedArcTangent239 array subtracted from the
' MultipliedArcTangent5 array, the MultipliedArcTangent5 array
' should now be equal to pi

lblPI.Caption = "Pi = 3. + . . .": DoEvents
txtOutput = "" ' clear text box
For X = 1 To LengthOfNumbers - 3 ' don't print the extra 3 numbers
' dump the value of pi into the text box
' the array does not include the "3."
' the 3 was bumped out of the array in the multiplication routine
PiValue = PiValue & MultipliedArcTangent5(X)
If X Mod 5 = 0 Then
' insert a space every 50 places for word wrapping
PiValue = PiValue & " "
End If
Next X

txtOutput.Text = PiValue
MsgBox "Pi calculated to " & LengthOfNumbers - 3 & " decimal places." & Chr$(13) & "Completed " & NumberOfLoops & " iterations." & Chr$(13) & "Spent " & Format$((Timer - TimeSpent) / 60, "#0.0000") & " minutes calculating.", 64, "Calculations Complete"
CalculatingPi = False
cmdCalculate.Caption = "Calculate!"
End Sub

' Received Received Received Calculated and Passed
Sub FindArcTangent(ArcTanToFind As Integer, NumberOfLoops As Integer, LengthOfNumbers As Integer, ArcTangent() As String * 1)
' ArcTanToFind reciprocal of number to find arctangent of
' NumberOfLoops set number of iterations
' LengthOfNumbers set length of numbers
'
' Machin's Formula
' Pi = 16 * Atn(1/5) - 4 * Atn(1/239)
'
' Atn(X) = X - X^3 /3 + X^5 /5 - X^7 /7 + X^9 /9 . . .
Dim StartPos As Integer ' position to start division loops
Dim Sum As Long ' keeps track of total and carrying in adding loops
Dim X As Integer ' multiusage as counter in For...Next and Do loops
Dim Divisor As Long ' keeps track of what the Answer is to be divided by
Dim Remainder As Long ' remainder in the dividing loops
Dim CarryPosition As Long ' keeps track of position when carrying
Dim DividedInto As Integer ' counts how many times # has divided into

ReDim Answer(1 To LengthOfNumbers) As String * 1
' answer after being raised to a certain power, built on each loop
ReDim Divided(1 To LengthOfNumbers) As String * 1
' the Answer after being divided by the divisor

StartPos = 1
For X = 1 To LengthOfNumbers
ArcTangent(X) = "0" ' change arrays from having
Divided(X) = "0" ' nulls to having 0's
Answer(X) = "0"
Next X

Select Case ArcTanToFind
Case 5: ArcTangent(1) = "2" ' final answer is .2 (1/5) so far
Case 239
X = 1
FillInNumbers:
If X <= LengthOfNumbers Then ArcTangent(X) = "0": X = X + 1
If X <= LengthOfNumbers Then ArcTangent(X) = "0": X = X + 1
If X <= LengthOfNumbers Then ArcTangent(X) = "4": X = X + 1
If X <= LengthOfNumbers Then ArcTangent(X) = "1": X = X + 1
If X <= LengthOfNumbers Then ArcTangent(X) = "8": X = X + 1
If X <= LengthOfNumbers Then ArcTangent(X) = "4": X = X + 1
If X <= LengthOfNumbers Then ArcTangent(X) = "1": X = X + 1
' final answer is .0041841 repeating (1/239) so far
If X <= LengthOfNumbers Then GoTo FillInNumbers
' fill in entire array with the repeating fraction
End Select

For X = 1 To LengthOfNumbers ' answer will be the same as
Answer(X) = ArcTangent(X) ' the final arctangent at this point
Next X

Divisor = 3 ' start with the divisor being 3

Do Until (Divisor - 1) / 2 = NumberOfLoops + 1 ' stops after formula
' has been computed NumberOfLoops times
For X = Int(StartPos) To LengthOfNumbers
' loop to divide Answer array by #^2
Remainder = Remainder * 10 ' multiply by ten and add new number
Remainder = Remainder + CInt(Answer(X)) ' like bringing down
' the next number in long division
Do Until Remainder < (ArcTanToFind ^ 2) ' loop until # is smaller
Remainder = Remainder - (ArcTanToFind ^ 2) 'subtract and count
DividedInto = DividedInto + 1 ' times it has gone into the #
Loop
Answer(X) = CStr(DividedInto) ' the answer of the long division
Divided(X) = Answer(X) ' make a copy in the divided array
DividedInto = 0 ' clear for next loop
DoEvents
Next X ' loop for whole array
DoneDividing = 0 ' reset this for next iteration
Remainder = 0 ' clear variables for the next loop
DividedInto = 0
For X = Int(StartPos) To LengthOfNumbers
'loop to divide Divided array by Divisor
Remainder = Remainder * 10 ' same long division loop
Remainder = Remainder + CInt(Divided(X)) ' bring down number
Do Until (Remainder < Divisor) ' divide into remainder
Remainder = Remainder - Divisor
DividedInto = DividedInto + 1 ' count number of times
Loop
Divided(X) = CStr(DividedInto) ' put answer back into array
DividedInto = 0 ' clear variable for next loop
DoEvents
Next X ' do this for entire Divided array
Remainder = 0 ' clear variables for the next loop
DividedInto = 0
If (Divisor Mod 4) = 1 Then ' all answers to be added will be true
For X = LengthOfNumbers To 1 Step -1
' add Divided array to ArcTangent array
Sum = Sum + CInt(Divided(X)) + CInt(ArcTangent(X))
' add the two numbers together
ArcTangent(X) = CStr(Sum Mod 10)
' the answer will just be the ones' place
Sum = Int(Sum / 10) ' divide the remainder by ten for
' the increasing place value and drop the ones' place
DoEvents
Next X ' loop for entire arrays
Sum = 0 ' clear variable
Else ' all answers to be subtracted will be false
For X = LengthOfNumbers To 1 Step -1
' subtract Divided array from ArcTan array
If (ArcTangent(X) < Divided(X)) Then ' do we need to carry?
CarryPosition = X - 1 ' start with 1st number to the left
Do Until ArcTangent(CarryPosition) <> "0"
' find a non-zero number to borrow from
ArcTangent(CarryPosition) = "9" 'fill the other #'s
CarryPosition = CarryPosition - 1 ' with 9's
' go to the next number to the left
Loop ' loop until finding a non-zero number
' at end of loop, CarryPosition will be # to borrow from
ArcTangent(CarryPosition) = CStr(CInt(ArcTangent(CarryPosition)) - 1)
' decrease number carried from by one
ArcTangent(X) = CStr((CInt(ArcTangent(X)) + 10) - CInt(Divided(X)))
'add an extra ten (borrowed) to ArcTan and subtract Divided
Else ' just simple subtraction if there isn't carrying
ArcTangent(X) = CStr(CInt(ArcTangent(X)) - CInt(Divided(X)))
End If
DoEvents
Next X ' loop to subtract entire Divided array
CarryPosition = 0 ' clear variable
End If
Divisor = Divisor + 2 ' each loop, power and divisor increase by 2
txtOutput.Text = "Calculating ArcTangent of 1/" & ArcTanToFind & ", Done with iteration " & (Divisor - 1) / 2
DoEvents
StartPos = StartPos + 1.25
Loop ' loop NumberOfLoops times
' each time ArcTangent gets more accurate
End Sub

' Received Received Calculated and Passed
Sub MultiplyArray(ArrayToMultiply() As String * 1, NumberToMultiplyBy As Integer, Answer() As String * 1)
Dim Position As Integer ' current position in array
Dim SmallAnswer As Integer ' keeps track of "sub-answers" in the multiplication process
Dim NumberToCarry As Integer ' keeps track of carrying

For Position = txtNumbers + 3 To 1 Step -1
SmallAnswer = (CInt(ArrayToMultiply(Position)) * NumberToMultiplyBy) + NumberToCarry
' multiply the 2 numbers together and add the remainder
Answer(Position) = Right$(CStr(SmallAnswer), 1)
' add ones place of SmallAnswer to the whole answer
If SmallAnswer < 10 Then ' if greater than ten we will need
NumberToCarry = 0 ' to carry
Else
NumberToCarry = CInt(Left$(CStr(SmallAnswer), CInt(Len(CStr(SmallAnswer))) - 1))
End If
' carry the Answer without the ones place
' (everything is shifted to the right so it get divided by 10)
DoEvents
Next Position ' go on to the next position (moving to the left)
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub