Bigmath - operations sur des tres grands nombres

Télécharger le projet
Commenter

Description

ajoute ce module dans ton projet et tu pourra utiliser les fonctions suivantes sur des nombres contenant jusqu'a 2 milliard de chiffres (stockés en string bien sur) :
- CompNumber(Number1, Number2) pour comparer 2 nombres
- SumNumber(Number1, Number2) pour additionner 2 nombres
- RoundNumber(Number, NumDigitsAfterDecimal) pour arrondir un nombre

les calculs sont en precision infinie. j'ai fait de nombreux test comparatifs pour atteindre la plus grande vitesse d'execution mais je n'ai jamais reussi a egaler la rapidite d'us_30 qui a poste un code similaire (http://www.codes-sources.com/code.aspx?ID=31544).
le code s'adapte aux options regionales et linguistiques en ce qui concerne le separateur decimal.
chaque fonction peut verifier que le nombre saisi est correct (en option dans les parametres parceque la verification d'un nombre peut etre tres longue : de l'ordre de la seconde des que le nombre depasse 200000 chiffres).

Source / Exemple : 


'************************************************************************'
'************************************************************************'
'**                                                                    **'
'**                    MATHEMATICS WITH BIG NUMBERS                    **'
'**                                                                    **'
'************************************************************************'
'************************************************************************'

'----------------------------   PROPERTIES   ----------------------------'
'Author = Santiago Diez
'Date = 06 OCTOBER 2005  00:13
'Version = 3.5
'---------------------------   DESCRIPTION   ----------------------------'
'This module performs mathematic operations on very big numbers up to two
'billion digits stored as strings.
'-----------------   PUBLIC PROCEDURES AND FUNCTIONS   ------------------'
'String = CheckNumber(Number As String)
'   Returns Number in its best writting pattern or empty ("") if Number is
'   not understandable.
'-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- '
'String = CreateNumber(NumberOfDigits As Long, [WithDecimal As Boolean =
'                                     True], [WithSign As Boolean = True])
'   Returns a random number with NumberOfDigits digits (including whole
'   and decimal part). CreateNumber is signed if WithSign is True, it is
'   decimal if WithDecimal is True.
'-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- '
'Long = CompNumber(Number1 As String, Number2 As String, [Check As Boolean
'                                                                = False])
'   Returns -1 if Number1 < Number2,
'            0 if Number1 = Number2 and
'            1 if Number1 > Number2.
'   Check numbers if Check is True.
'-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- '
'String = OppNumber(Number As String, [Check As Boolean = False])
'   Returns the opposite of Number. Check number if Check is True.
'-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- '
'String = AbsNumber(Number As String, [Check As Boolean = False])
'   Returns the absolute value of Number. Check number if Check is True.
'-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- '
'String = SumNumber(Number1 As String, Number2 As String, [Check As
'                                                        Boolean = False])
'   Returns Number1 + Number2. Check numbers if Check is True.
'-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- '
'String = RoundNumber(Number As String, [NumDigitsAfterDecimal As Long =
'                                          0], [Check As Boolean = False])
'   Returns Number rounded to NumDigitsAfterDecimal digits after decimal.
'   Ignore if NumDigitsAfterDecimal < 0.
'---------------------------   ABOUT SPEED   ----------------------------'
'It is faster to use ByRef parameters than to use ByVal parameters.
'   That is why every public function MyFunction using ByVal parameters (
'   to ensure no parameters will be modified) has its equivalent private
'   function MyFunctionA using ByRef parameters.
'It is faster to split Number in String rather than in an Array.
'To delete a symbol in a string :
'   > String = Left$(String, Pos - 1) & Mid$(String, Pos + 1)
'   is faster than
'   > String = Replace(String, Symbol)
'-------------------------------   BUGS   -------------------------------'
'No bug reported.
'-----------------------------   SOURCES   ------------------------------'
'http://vbfrance.com/code.aspx?ID=31544     (by us_30)
'http://www.delphifr.com/code.aspx?ID=33431 (by RedDevlopper)
'-------------------------   CALLED LIBRARIES   -------------------------'
'kernel32.dll       'msvbvm60.dll
'VB6.OLB            'VB6FR.DLL
'-----------------------------   OPTIONS   ------------------------------'
Option Base 1
Option Compare Text
Option Explicit
'------------------------   PRIVATE VARIABLES   -------------------------'
Private DecSymbol As String

'+----------------------------------------------------------------------+'
'+                             DECLARATIONS                             +'
'+----------------------------------------------------------------------+'
Private Declare Function GetLocaleInfoA Lib "kernel32" (ByVal Locale As _
                            Long, ByVal LCType As Long, ByVal lpLCData _
                            As String, ByVal cchData As Long) As Long
Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long

'+----------------------------------------------------------------------+'
'+                           CHECK FUNCTIONS                            +'
'+----------------------------------------------------------------------+'
Private Function GetLocalInfo(ByRef Id As Long) As String
    On Error Resume Next
    Dim sBuffer As String
    Dim nBufferLen As Long
    nBufferLen = 255
    sBuffer = String$(nBufferLen, vbNullChar)
    nBufferLen = _
        GetLocaleInfoA(GetSystemDefaultLCID, Id, sBuffer, nBufferLen)
    If (nBufferLen > 0) _
        Then GetLocalInfo = Left$(sBuffer, nBufferLen - 1)
End Function
Private Function GetDecSymbol() As String
    If (DecSymbol = "") _
        Then If (GetLocalInfo(&HE) = GetLocalInfo(&H16)) _
            Then DecSymbol = GetLocalInfo(&HE)
    GetDecSymbol = DecSymbol
End Function
Public Function CheckNumber(ByVal Number As String) As String
    Call CheckNumberA(Number)
    CheckNumber = Number
End Function
Private Sub CheckNumberA(Number As String)
    'Declare.
    Dim CheckNumber As String
    Dim IsNegN As Boolean
    Dim I As Byte
    'Delete all space characters.
    If InStr(Number, " ") > 0 Then Number = Replace(Number, " ", "")
    'Only one minus (-) alowed at the begining.
    IsNegN = IsNeg(Number)
    CheckNumber = Mid$(Number, 1 - IsNegN)
    'Only one point (.) or (,) alowed anywhere.
    CheckNumber = Replace(CheckNumber, GetDecSymbol, "", 1, 1)
    'There must be at least one digit.
    If CheckNumber = "" Then Exit Sub
    'There must be only digits left.
    For I = 0 To 9
        CheckNumber = Replace(CheckNumber, CStr(I), "")
    Next
    'If there is any symbol left, Number is not valid.
    If CheckNumber <> "" Then
        Number = ""
    'Else returns Number with point at the right position.
    ElseIf InStr(Number, GetDecSymbol) = 1 - IsNegN Then
        Number = IIf(IsNegN, "-0", "0") & Mid$(Number, 1 - IsNegN)
    ElseIf InStr(Number, GetDecSymbol) = Len(Number) Then
        Number = Left$(Number, Len(Number) - 1)
    End If
End Sub

'+----------------------------------------------------------------------+'
'+                           STRING FUNCTION                            +'
'+----------------------------------------------------------------------+'
Public Function CreateNumber(ByVal NumberOfDigits As Long, Optional _
                        ByVal WithDecimal As Boolean = True, Optional _
                        ByVal WithSign As Boolean = True) As String
    'Declare.
    Const SubLen As Long = 7
    Dim I As Long
    Dim IsNegN As Boolean
    Dim PointPos As Long
    'Initialize.
    Randomize
    'Make CreateNumber randomly positive or negative.
    If WithSign Then IsNegN = (Int(2 * Rnd) = 0)
    'Add decimal symbol at random position.
    If WithDecimal And NumberOfDigits > 1 _
    Then PointPos = Int((NumberOfDigits - 1) * Rnd + 2) _
    Else WithDecimal = False
    'Initialize CreateNumber.
    NumberOfDigits = NumberOfDigits - IsNegN - WithDecimal
    CreateNumber = String$(NumberOfDigits, "0")
    'Fill CreateNumber with random numbers.
    'Tip : Mid$("hello", 4, 5) = "hello" ---> "helhe"
    For I = 1 To NumberOfDigits Step SubLen
        Mid$(CreateNumber, I, SubLen) = _
            Format(Int(10 ^ SubLen * Rnd), String$(SubLen, "0"))
    Next
    'CreateNumber can't start with "0" exept if PointPos = 2.
    If PointPos <> 2 _
    Then Mid$(CreateNumber, IIf(IsNegN, 2, 1), 1) = Int(9 * Rnd + 1)
    'CreateNumber with decimal can't end with "0".
    If WithDecimal _
    Then Mid$(CreateNumber, NumberOfDigits, 1) = Int(9 * Rnd + 1)
    'Write symbols.
    If IsNegN _
    Then Mid$(CreateNumber, 1, 1) = "-"
    If WithDecimal _
    Then Mid$(CreateNumber, PointPos - IsNegN, 1) = GetDecSymbol
End Function
Private Sub AlignNumber(ByRef Number1 As String, ByRef Number2 As String _
                                    , Optional ByRef ModLen As Long = 1)
    'Declare.
    Dim IsNeg1 As Boolean, IsNeg2 As Boolean
    Dim PPos1 As Long, PPos2 As Long
    Dim WL1 As Long, WL2 As Long
    Dim DL1 As Long, DL2 As Long
    Dim WLen As Long, DLen As Long
    'Check sign.
    If IsNeg(Number1) Then IsNeg1 = True
    If IsNeg(Number2) Then IsNeg2 = True
    'Calculate whole and decimal part length.
    PPos1 = InStr(Number1, GetDecSymbol)
    PPos2 = InStr(Number2, GetDecSymbol)
    If PPos1 = 0 _
    Then DL1 = 0: WL1 = Len(Number1) + IsNeg1 _
    Else DL1 = Len(Number1) - PPos1: WL1 = PPos1 - 1 + IsNeg1
    If PPos2 = 0 _
    Then DL2 = 0: WL2 = Len(Number2) + IsNeg2 _
    Else DL2 = Len(Number2) - PPos2: WL2 = PPos2 - 1 + IsNeg2
    WLen = IIf(WL1 > WL2, WL1, WL2)
    DLen = IIf(DL1 > DL2, DL1, DL2)
    If (WLen + DLen) Mod ModLen > 0 _
    Then WLen = WLen + ModLen - (WLen + DLen) Mod ModLen
    'Align numbers.
    If WL1 < WLen Or DL1 < DLen Or (PPos1 > 0 And DLen = 0) _
    Then Number1 = IIf(IsNeg1, "-", "") _
                 & IIf(WL1 < WLen, String$(Abs(WLen - WL1), "0"), "") _
                 & Mid$(Number1, 1 - IsNeg1, WL1) _
                 & IIf(DLen > 0, GetDecSymbol & _
                   Mid$(Number1, WL1 - IsNeg1 + 2, DL1) & _
                   IIf(DL1 < DLen, String$(Abs(DLen - DL1), "0"), ""), "")
    If WL2 < WLen Or DL2 < DLen Or (PPos2 > 0 And DLen = 0) _
    Then Number2 = IIf(IsNeg2, "-", "") _
                 & IIf(WL2 < WLen, String$(Abs(WLen - WL2), "0"), "") _
                 & Mid$(Number2, 1 - IsNeg2, WL2) _
                 & IIf(DLen > 0, GetDecSymbol & _
                   Mid$(Number2, WL2 - IsNeg2 + 2, DL2) & _
                   IIf(DL2 < DLen, String$(Abs(DLen - DL2), "0"), ""), "")
End Sub
Private Sub TrimNumber(ByRef Number As String)
    'Declare.
    Dim NLead As Long
    Dim NEnd As Long
    Dim IsNegN As Boolean
    'Delete leading zeros.
    IsNegN = IsNeg(Number)
    NLead = 1 - IsNegN
    Do While Mid$(Number, NLead, 1) = "0"
        NLead = NLead + 1
    Loop
    'Delete end zeros in decimal part.
    If InStr(Number, GetDecSymbol) > 0 Then
        NEnd = Len(Number)
        Do While Mid$(Number, NEnd, 1) = "0"
            NEnd = NEnd - 1
        Loop
    Else
        NEnd = Len(Number)
    End If
    'Rewrite number.
    If NLead > 1 - IsNegN Or NEnd < Len(Number) _
    Then Number = IIf(IsNegN, "-", "") _
                & IIf(Mid$(Number, NLead, 1) = GetDecSymbol, "0", "") _
                & IIf(Mid$(Number, NLead, 1) = "", "0", "") _
                & Mid$(Number, NLead, NEnd - NLead + _
                      IIf(Mid$(Number, NEnd, 1) = GetDecSymbol, 0, 1))
End Sub

'+----------------------------------------------------------------------+'
'+                              COMPARISON                              +'
'+----------------------------------------------------------------------+'
Private Function IsNeg(ByRef Number As String) As Boolean
    IsNeg = (Left$(Number, 1) = "-")
End Function
Public Function CompNumber(ByVal Number1 As String, ByVal Number2 As _
                String, Optional ByVal Check As Boolean = False) As Long
    'Check numbers if asked to.
    If Check Then Call CheckNumberA(Number1): _
                  Call CheckNumberA(Number2): _
                  If Number1 = "" Or Number2 = "" Then Exit Function
    'Compare numbers.
    CompNumber = CompNumberA(Number1, Number2)
End Function
Private Function CompNumberA(ByVal Number1 As String, ByVal Number2 As _
                                                        String) As Long
    'Case Number1 and Number2 are negative.
    If IsNeg(Number1) And IsNeg(Number2) Then
        Call OppNumberA(Number1)
        Call OppNumberA(Number2)
        CompNumberA = CompNumberA(Number2, Number1)
    Else
        'Align numbers.
        Call AlignNumber(Number1, Number2)
        'Compare numbers.
        CompNumberA = StrComp(Number1, Number2, vbBinaryCompare)
    End If
End Function

'+----------------------------------------------------------------------+'
'+                        ADDITION / SUBTRACTION                        +'
'+----------------------------------------------------------------------+'
Public Function OppNumber(ByVal Number As String, Optional ByVal Check _
                                            As Boolean = False) As String
    If Check Then Call CheckNumberA(Number): _
                  If Number = "" Then Exit Function
    Call OppNumberA(Number)
    OppNumber = Number
End Function
Private Sub OppNumberA(ByRef Number As String)
    If IsNeg(Number) _
    Then Number = Mid$(Number, 2) _
    Else Number = ("-" & Number)
End Sub
Public Function AbsNumber(ByVal Number As String, Optional ByVal Check _
                                            As Boolean = False) As String
    If Check Then Call CheckNumberA(Number): _
                  If Number = "" Then Exit Function
    If IsNeg(Number) _
    Then AbsNumber = Mid$(Number, 2) _
    Else AbsNumber = Number
End Function
Public Function SumNumber(ByVal Number1 As String, ByVal Number2 As _
                String, Optional ByVal Check As Boolean = False) As String
    'Declare.
    Dim IsNeg1 As Boolean, IsNeg2 As Boolean
    Dim NLen1 As Long, PPos1 As Long
    Dim DecLen As Long
    Dim SumType As Long, SumNeg As Boolean
    Dim I As Long
    'All following variables must be the same data type (Bigger = Faster)
    'SubLen gives the max significant digits stored in the data type ;
    'Don't forget after addition, numbers can be one digit longer.
    Dim SubNum1 As Double, SubNum2 As Double
    Dim SubSum As Double, SubCarry As Double
    Const SubLen As Long = 14
    'Check numbers if asked to.
    If Check Then Call CheckNumberA(Number1): _
                  Call CheckNumberA(Number2): _
                  If Number1 = "" Or Number2 = "" Then Exit Function
    'Align numbers.
    Call AlignNumber(Number1, Number2, SubLen)
    'Select addition type.
    IsNeg1 = IsNeg(Number1): IsNeg2 = IsNeg(Number2)
    SumType = -IsNeg2 - 2 * IsNeg1
    'Calculate the result decimal part length.
    PPos1 = InStr(Number1, GetDecSymbol) + IsNeg1
    NLen1 = Len(Number1) + IsNeg1
    If PPos1 > 0 Then DecLen = NLen1 - PPos1
    'Delete minus and decimal symbol.
    If IsNeg1 Or PPos1 > 0 Then Number1 = _
        Mid$(Number1, 1 - IsNeg1, IIf(PPos1 > 0, PPos1 - 1, NLen1)) _
      & Mid$(Number1, PPos1 - IsNeg1 + 1, DecLen)
    If IsNeg2 Or PPos1 > 0 Then Number2 = _
        Mid$(Number2, 1 - IsNeg2, IIf(PPos1 > 0, PPos1 - 1, NLen1)) _
      & Mid$(Number2, PPos1 - IsNeg2 + 1, DecLen)
    NLen1 = NLen1 + CLng(PPos1 > 0)
    'Modify addition type if result is negative.
    Select Case SumType
        Case 1: If StrComp(Number1, Number2) = -1 _
                Then SumType = 2: SumNeg = True
        Case 2: If StrComp(Number1, Number2) = 1 _
                Then SumType = 1: SumNeg = True
        Case 3: SumType = 0: SumNeg = True
    End Select
    'Initialize Result (1 digit longer than numbers)
    SumNumber = String$(NLen1 + 1, "0")
    'Calculate sum.
    For I = NLen1 - SubLen + 1 To 1 Step -SubLen
        SubNum1 = CDec(Mid$(Number1, I, SubLen))
        SubNum2 = CDec(Mid$(Number2, I, SubLen))
        Select Case SumType
            Case 0  ' A+B
                SubSum = SubNum1 + SubNum2 + SubCarry
                SubCarry = IIf(SubSum < 10 ^ SubLen, 0, 1)
            Case 1  ' A-B
                SubSum = SubNum1 - SubNum2 + SubCarry
                SubCarry = IIf(SubSum < 0, -1, 0)
                If SubSum < 0 Then SubSum = SubSum + 10 ^ SubLen
            Case 2  '-A+B
                SubSum = -SubNum1 + SubNum2 + SubCarry
                SubCarry = IIf(SubSum < 0, -1, 0)
                If SubSum < 0 Then SubSum = SubSum + 10 ^ SubLen
        End Select
        'Insert SubSum in Result (shift -1).
        Mid$(SumNumber, I, SubLen + 1) = _
           Format(SubSum, String$(SubLen + 1, "0"))
    Next
    'Rewrite minus and decimal symbol.
    If SumNeg Or DecLen > 0 _
    Then SumNumber = IIf(SumNeg, "-", "") _
                   & Left$(SumNumber, NLen1 + 1 - DecLen) _
                   & IIf(DecLen > 0, GetDecSymbol, "") _
                   & Right$(SumNumber, DecLen)
    'Trim number.
    Call TrimNumber(SumNumber)
End Function
Public Function RoundNumber(ByVal Number As String, Optional ByVal _
                            NumDigitsAfterDecimal As Long = 0, Optional _
                            ByVal Check As Boolean = False) As String
    'Declare.
    Dim NLen As Long
    Dim DecLen As Long
    Dim NDAD As Long: NDAD = NumDigitsAfterDecimal
    'Get number lengths
    NLen = Len(Number)
    DecLen = InStr(Number, GetDecSymbol)
    If DecLen > 0 Then DecLen = NLen - DecLen
    'Check numbers if asked to.
    If Check Then Call CheckNumberA(Number): _
                  If Number = "" Then Exit Function
    'If it is not necessary to round.
    If NDAD < 0 Or NDAD >= DecLen Then
        RoundNumber = Number
    Else
       'Else round the number.
       Select Case Mid$(Number, NLen - DecLen + NDAD + 1, 1)
            Case "0", "1", "2", "3", "4"
                If NDAD = 0 _
                Then RoundNumber = Left$(Number, NLen - DecLen - 1) _
                Else RoundNumber = Left$(Number, NLen - DecLen + NDAD)
            Case "5", "6", "7", "8", "9"
                If NDAD = 0 _
                Then RoundNumber = SumNumber(Left$(Number, NLen - DecLen _
                    - 1), IIf(IsNeg(Number), "-", "") & "1", False) _
                Else RoundNumber = SumNumber(Left$(Number, NLen - DecLen _
                    + NDAD), IIf(IsNeg(Number), "-", "") & "0" & _
                    GetDecSymbol & String$(NDAD - 1, "0") & "1", False)
       End Select
    End If
    'Trim number.
    Call TrimNumber(RoundNumber)
End Function

'+----------------------------------------------------------------------+'
'+                     ACCESS TO PRIVATE FUNCTIONS                      +'
'+----------------------------------------------------------------------+'
Public Sub BigMath_GetPrivate(ByRef Name As String, Optional ByRef _
                        Number1 As String = "0", Optional ByRef Number2 _
                        As String = "0", Optional ByRef Param1 As _
                        Variant = 1, Optional ByRef Result As Variant _
                        = "0", Optional ByRef Check As Boolean = False)
    Select Case Name
        Case "AlignNumber"
            Call AlignNumber(Number1, Number2, CLng(Param1))
        Case "CompNumberA"
            Result = CompNumberA(Number1, Number2)
        Case "OppNumberA"
            Call OppNumberA(Number1)
        Case "TrimNumber"
            Call TrimNumber(Number1)
    End Select
End Sub

Conclusion :


je poste mes codes pour partager des connaissances et des idees.
j'attends des constatations de bugs ou des propositions d'amelioration.

si vous trouvez ce code inutile ou "deja vu", pas la peine de le consulter et de le commenter.
si vous eprouvez neanmoins un besoin irrepressible de montrer votre capacite a critiquer, merci de le faire en m'envoyant un message afin de ne pas noyer ce code au milieu des polemiques.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_santiago69)