Calculs sur de grands nombres (plusieurs milliers de chiffres)

Soyez le premier à donner votre avis sur cette source.

Vue 6 224 fois - Téléchargée 474 fois

Description

Calculs sur de grands nombres (plusieurs milliers de chiffres) et gestion des décimales.
addition, soustraction, multiplication, division, exponentiation, racine carrée, comparaisons et quelques autres fonctions.
écrit pour mes besoins personnels, non optimisé, mais ça marche.

opérations de base, modulo, racine nième (Newton), exponentiation, factorielle, changement de bases, comparaisons, racines eq 2ème degré, test de primalité (Miller-Bach)

Source / Exemple :


Option Explicit

'--------------------------------------------------------------------------------------------------------
'
'           Fonctions de calcul sur les grands nombres              V2.14
'
'           Philippe Laugerat,  Apex Informatique,  2010
'
'--------------------------------------------------------------------------------------------------------
'
'   GAdd    (x,y)       Addition                = x + y
'   GSub    (x,y)       Soustraction            = x - y
'   GMult   (x,y)       Multiplication          = x * y
'   GDiv    (x,y,r)     Division euclidienne    = x / y     r = reste   (x = y * z + r)
'                           r optionnel                     GDiv et r renvoyés vide si y = 0
'
'   GMod    (x,y)       Reste de x/y            = x mod y
'   GModP   (a, n, m)   a^n modulo m
'
'   GRac    (x,r,d)     Racine carrée           = x ^ 1/2
'                           r optionnel reste               r = x - GRac^2
'                           d optionnel nb de décimales
'   GRacn    (x,n,r,d)  Racine nième            = x ^ 1/n   Méthode de Newton
'                           n entier 0 <= n <= 1000
'                           r optionnel reste               r = x - GRac^n
'                           d optionnel nb de décimales
'                                                           GRacn et r renvoyés vide si n=pair et x < 0
'
'   GRacn1   (x,n,r,d)  Racine nième            = x ^ 1/n
'                                                           idem précédente
'                                                           algo en valeurs exactes mais trop lent
'                                                           *** 4mn pour racine 100ème de x = 1000 chiffres
'                                                           au lieu de 4 secondes pour Newton
'
'   GExp    (x,n)       Exponantiation          = x ^ n     n<=100
'   GExpFic (x,p)       recherche dans fichiers les valeurs précalculée de 1^1 jusqu'à 1000^1000
'
'   GFact   (x)         Factorielle de x        = x!
'
'   GConvBase   (x,b1,b2)   convertit x écrit en base b vers la base b2
'                           x et résultat   string,     b1 et b2 integer
'
'   GConvB  (x)         Convertit x (alpha décimal) en binaire alpha
'   GConvF  (x,p)       Convertit x en alpha flottant renvoie p chiffres et 10^nnn (e.dddddd 10^ppp)
'                           p numérique optionnel (16) par défaut
'   GConvD  (x)         Convertit x en numérique double précision
'                           renvoie 0 si exposant > 323 ou < -323
'   GConvA  (x)         Convertit x numérique en alpha
'
'   GAbs    (x)         valeur absolue          = abs(x)
'
'   GSup    (x,y)       Supérieur               = Vrai si x > y (strictement)   sinon = Faux
'   GInf    (x,y)       Inférieur               = Vrai si x < y (strictement)   sinon = Faux
'   GSupEq  (x,y)       Supérieur ou égal       = Vrai si x >= y                sinon = Faux
'   GInfEq  (x,y)       Inférieur ou égal       = Vrai si x <= y                sinon = Faux
'   GEq     (x,y)       Egal                    = Vrai si x = y                 sinon = Faux
'   GComp   (x,y)       Comparaison             = 0 si x = y, 1 si x > y, -1 si x < y
'
'   GInt    (x)         Partie entière          = fix(x)
'   GDec    (x)         partie décimale
'
'   GSol2   (a,b,c,x1,x2,Optional Nbdecimales=0)
'                       racines de l'équation du 2ème degré
'                           si nbdecimales = 0, x1 et x2 doivent être des entiers
'                               sinon la fonction renvoie false et x1="" et x2=""
'                           si nbdecimales > 0 et delta < 0 GSol2=false et x1="" et x2=""
'                           dans les autres cas GSol2 = true et x1 et x2 sont renvoyées
'
'   GPremier(n, Optional precision = 0)     test de primalité       Miller-Bach (1985)
'
'--------------------------------------------------------------------------------------------------------

'--------------------------------------------------------------------------------------------------------
'   GMult   (x,y)       Multiplication          = x * y
'                       x et y  string
'                       GMult   string
'                       multiplication classique comme à la main avec chiffres goupés par 14
'                       utilisation de variables de type decimale   dim v as variant puis v = cdec(xxxx)
'--------------------------------------------------------------------------------------------------------
Public Function GMult(x As String, y As String) As String

    Dim res(10000) As Variant
    Dim r As Variant, rx As Variant, ry As Variant, rz As Variant
    Dim ra As String, rb As String
    Dim wx As String, wy As String
    Dim n As String
    Dim xent As String, xdec As String, yent As String, ydec As String
    Dim sg As Integer, p As Integer, pmax As Integer
    Dim lgx As Integer, lgy As Integer, re As Integer, gr As Integer
    Dim ix As Integer, dx As Integer, iy As Integer, dy As Integer
    Dim ret As Variant
    
    gr = 13
    
    wx = GNormalise(x)
    wy = GNormalise(y)
    
    Call GDecimale(wx, xent, xdec)
    Call GDecimale(wy, yent, ydec)
    
    wx = xent + xdec
    wy = yent + ydec
    
    wx = GNormalise(wx)
    wy = GNormalise(wy)
    
    On Error GoTo GMult01
    
    rx = CDec(wx)
    ry = CDec(wy)
    rz = CDec(rx * ry)
    wx = Trim(Str(rz))
    wx = GDecimale2(wx, Len(xdec) + Len(ydec))
    GMult = GNormalise(wx)
    On Error GoTo 0
    Exit Function
    
GMult01:
    On Error GoTo 0
    
    If wx = "0" Or wy = "0" Then GMult = "0": Exit Function
    
    sg = 1
    If Left(wx, 1) = "-" Then sg = -sg: wx = Mid(wx, 2)
    If Left(wy, 1) = "-" Then sg = -sg: wy = Mid(wy, 2)
    
    If wx = "1" Then
        If sg = 1 Then GMult = wy Else GMult = "-" + wy
        Exit Function
    End If
    
    If wy = "1" Then
        If sg = 1 Then GMult = wx Else GMult = "-" + wx
        Exit Function
    End If
    
    
    lgx = Len(wx)
    lgy = Len(wy)
    
    re = lgx - Int(lgx / gr) * gr:    If re > 0 Then wx = String(gr - re, "0") + wx: lgx = Len(wx)
    re = lgy - Int(lgy / gr) * gr:    If re > 0 Then wy = String(gr - re, "0") + wy: lgy = Len(wy)
    
    ix = 0
    For dx = lgx To gr Step -gr
    
        ix = ix + 1
        rx = CDec(Mid(wx, dx - gr + 1, gr))
        iy = 0
        For dy = lgy To gr Step -gr
            iy = iy + 1
            p = ix + iy - 2
            ry = CDec(Mid(wy, dy - gr + 1, gr))
            rz = CDec(rx * ry)
            res(p) = CDec(res(p) + rz)
        Next dy
    Next dx
    
    pmax = lgx / gr + lgy / gr
    n = ""
    
    For p = 0 To pmax
        ra = Trim(Str(res(p)))
        rb = Right(ra, gr)
        If Len(ra) - gr > 0 Then ret = CDec(Left(ra, Len(ra) - gr)) Else ret = CDec(0)
        res(p + 1) = res(p + 1) + ret
        n = Right(String(gr, "0") + ra, gr) + n
    Next p
            
    If sg = -1 And n <> "0" Then n = "-" + n
    
    n = GDecimale2(n, Len(xdec) + Len(ydec))
    GMult = GNormalise(n)
    
End Function

'--------------------------------------------------------------------------------------------------------
'   GFact   (x)         Factorielle de x        = x!
'                           calcul numérique pour x <= 27, utilise GMult pour la suite
'--------------------------------------------------------------------------------------------------------
Public Function GFact(x As String) As String

    Dim res As Variant, n As Integer
    Dim wx As String, na As String
    Dim i As Integer
    Dim max As Integer
    Dim resa As String
    
    max = 27
    
    wx = GNormalise(x)
    If wx = "0" Then GFact = "1": Exit Function
    If Left(wx, 1) = "-" Then GFact = "": Exit Function
    
    If Len(wx) <= 2 Then
        n = Val(wx)
        If n <= max Then
            res = CDec(1)
            For i = 2 To n
                res = res * CDec(i)
            Next i
            GFact = GNormalise(Str(res))
            Exit Function
        End If
    End If
    
    res = CDec(1)
    For n = 2 To max
        res = res * CDec(n)
    Next n
    
    resa = Trim(Str(res))
    na = Trim(Str(max + 1))
    
    Do
        resa = GMult(resa, na)
        If na = wx Then Exit Do
        na = GAdd(na, "1")
    Loop

    GFact = resa

End Function

'--------------------------------------------------------------------------------------------------------
'   GAbs   (x)         Valeur absolue de x        = abs(x)
'--------------------------------------------------------------------------------------------------------
Public Function GAbs(x As String) As String

    Dim wx As String

    wx = GNormalise(x)
    If Left(wx, 1) = "-" Then wx = Mid(wx, 2)
    GAbs = wx
    
End Function

'--------------------------------------------------------------------------------------------------------
'   GExp   (x,n)       Exponentiation             = x^n
'--------------------------------------------------------------------------------------------------------
Public Function GExp(x As String, exposant As Integer) As String

    Dim n As Variant, n0 As Variant
    Dim z As Variant, zx As Variant
    Dim res As String
    
    res = GExpFic(n, p)
    If res <> "" Then GExp = res: Exit Function
    
    Dim wx As String
    
    If Len(exposant) > 7 Then GExp = "": Exit Function
    n = CDec(exposant)
    n0 = CDec(n)
    
    wx = GNormalise(x)
    Call GDecimale(wx, xent, xdec)
    wx = xent + xdec
    wx = GNormalise(wx)

    On Error GoTo GExp01
    
    zx = CDec(wx)
    z = CDec(1)
    For i = 1 To n: z = z * zx: Next i
    wx = Trim(Str(z))
    wx = GDecimale2(wx, Len(xdec) * n)
    GExp = GNormalise(wx)
    On Error GoTo 0
    Exit Function
    
GExp01:
    On Error GoTo 0

    If n = 1 Then GExp = GNormalise(x): Exit Function
    If n < 2 Or Int(n) <> n Then GExp = "": Exit Function

    Dim tp(100) As Integer                  ' stocke 1 pour puissance de 2
    Dim txp(100) As String                  ' table des puissances 1 2 4 de x
    
    p = 0                               ' decomposition en puissance de 2
    Do
        p = p + 1
        If n Mod 2 = 1 Then tp(p) = 1: n = n - 1
        n = n / 2
    Loop Until n = 0
    
    txp(1) = x
    For i = 2 To p
        txp(i) = GMult(txp(i - 1), txp(i - 1))
    Next i
    
    res = "1"
    For i = 1 To p
        If tp(i) = 1 Then res = GMult(res, txp(i))
    Next i
    
    res = GDecimale2(res, Len(xdec) * n0)
    GExp = GNormalise(res)
    
End Function

'--------------------------------------------------------------------------------------------------------
'   GExpFic   (x,p)         Exponentiation             = x^p
'                           recherche dans des fichiers les valeurs précalculées de 1^1 jusqu'à 1000^1000
'                           répertoire  : C:\Users\Philippe\Diophante\
'                           fichiers    : Puissances de 1E1 à 1000E100.txt"
'                                       : Puissances de 1E101 à 1000E200.txt"
'                                       : Puissances de 1E201 à 1000E300.txt"
'                                       : ...
'                                       : Puissances de 1E901 à 1000E1000.txt"
'--------------------------------------------------------------------------------------------------------
Function GExpFic(x As String, p As Integer)

    If GSup(x, "1000") Then GExpFic = "": Exit Function
    If p > 1000 Then GExpFic = "": Exit Function
    
    Dim n As Integer
    n = Val(x)
    
    Dim lgrec As Variant
    lgrec = Array(303, 603, 903, 1203, 1503, 1803, 2103, 2403, 2703, 3003)
    
    Dim res As String
    Dim nofic As Integer, canal As Integer, rec As Long
    Dim fic As String, rep As String, pf1 As String, pf2 As String
    
    If n = 0 Or n = 1 Then GExpFic = Trim(Str(n)): Exit Function
    If p = 0 Then GExpFic = "1": Exit Function
    If p = 1 Then GExpFic = Trim(Str(n)): Exit Function
    If n > 1000 Then GExpFic = "": Exit Function
    
    
    nofic = Fix((p - 1) / 100)
    pf1 = Trim(Str(nofic * 100 + 1))
    pf2 = Trim(Str(nofic * 100 + 100))
    
    rep = "C:\Users\Philippe\Diophante\"
    fic = "Puissances de 1E" + pf1 + " à 1000E" + pf2 + ".txt"
    If Dir(rep + fic) = "" Then GExpFic = "": Exit Function
    
    canal = FreeFile(1)
    Open rep + fic For Random As canal Len = lgrec(nofic)
    
    rec = (n - 1) * 100 + ((p - 1) Mod 100) + 1
    Get canal, rec, res
    
    Close canal
    
    GExpFic = res

End Function

'--------------------------------------------------------------------------------------------------------
'   GAdd    (x,y)       Addition          = x + y
'                       x et y  string
'                       GAdd   string
'                       addition classique comme à la main avec chiffres goupés par 28
'                       si les signes sont differents, on utilise GSub
'                       utilisation de variables de type decimale   dim v as variant puis v = cdec(xxxx)
'--------------------------------------------------------------------------------------------------------
Public Function GAdd(x, y) As String

    Dim gr As Integer
    gr = 28
    
    Dim z As Variant, zx As Variant, zy As Variant
    Dim ret As Variant
    Dim wx As String, wy As String, n As String, za As String
    Dim xd As Integer, yd As Integer
    Dim sgx As Integer, sgy As Integer
    Dim lg As Integer, lgx As Integer, lgy As Integer
    
    wx = GNormalise(x)
    wy = GNormalise(y)
    
    Call GDecimale(wx, xent, xdec)
    Call GDecimale(wy, yent, ydec)
    
    xd = Len(xdec)
    yd = Len(ydec)
    If xd < yd Then
        xdec = xdec + String(yd - xd, "0")
    Else
        ydec = ydec + String(xd - yd, "0")
    End If
        
    wx = xent + xdec
    wy = yent + ydec
    
    wx = GNormalise(wx)
    wy = GNormalise(wy)
    
    
    On Error GoTo GAdd01
    
    zx = CDec(wx)
    zy = CDec(wy)
    z = CDec(zx + zy)
    wx = Trim(Str(z))
    wx = GDecimale2(wx, Len(xdec))
    GAdd = GNormalise(wx)
    On Error GoTo 0
    Exit Function
    
GAdd01:
    On Error GoTo 0
    
    
    If Left(wx, 1) = "-" Then sgx = -1: wx = Mid(wx, 2) Else sgx = 1
    If Left(wy, 1) = "-" Then sgy = -1: wy = Mid(wy, 2) Else sgy = 1
    
    If sgx = sgy Then
    
        lgx = Len(wx)
        lgy = Len(wy)
        If lgx > lgy Then lg = lgx Else lg = lgy
        lg = (Int(lg / gr) + 1) * gr
        wx = String(lg - lgx, "0") + wx
        wy = String(lg - lgy, "0") + wy
        
        n = ""
        ret = CDec(0)
        For i = lg To 1 Step -gr
            zx = CDec(Mid(wx, i - gr + 1, gr))
            zy = CDec(Mid(wy, i - gr + 1, gr))
            z = CDec(zx + zy + ret)
            za = Trim(Str(z))
            If Len(za) > gr Then
                ret = CDec(Left(za, 1))
                za = Mid(za, 2)
            Else
                ret = CDec(0)
            End If
            n = Right(String(gr, "0") + za, gr) + n
        Next i
        
        If sgx = -1 Then n = "-" + n
        
    Else
    
        If GSup(wx, wy) Then
            n = GSub(wx, wy)
            If sgx = -1 Then n = "-" + n
        Else
            n = GSub(wy, wx)
            If sgy = -1 Then n = "-" + n
        End If
        
    End If
    
    n = GDecimale2(n, Len(xdec))
    GAdd = GNormalise(n)
    
End Function

'--------------------------------------------------------------------------------------------------------
'   GSub    (x,y)       Soustraction          = x - y
'                       x et y  string
'                       GSub   string
'                       soustraction classique comme à la main avec chiffres goupés par 28
'                       si les signes sont differents, on utilise GAdd
'                       utilisation de variables de type decimale   dim v as variant puis v = cdec(xxxx)
'--------------------------------------------------------------------------------------------------------
Public Function GSub(x, y) As String
    
    Dim z As Variant, z1 As Variant, z2 As Variant
    Dim ret As Variant
   
    Dim wx As String, wy As String
    Dim w1 As String, w2 As String
    Dim xent As String, xdec As String, yent As String, ydec As String
    Dim n As String
    
    Dim xd As Integer, yd As Integer
    Dim sgx As Integer, sgy As Integer
    Dim cas As Integer
    Dim lg As Integer, lg1 As Integer, lg2 As Integer
    Dim gr As Integer
    
    gr = 28
    
    wx = GNormalise(x)
    wy = GNormalise(y)

    Call GDecimale(wx, xent, xdec)
    Call GDecimale(wy, yent, ydec)
    
    xd = Len(xdec)
    yd = Len(ydec)
    If xd < yd Then
        xdec = xdec + String(yd - xd, "0")
    Else
        ydec = ydec + String(xd - yd, "0")
    End If
        
    wx = xent + xdec
    wy = yent + ydec
    
    wx = GNormalise(wx)
    wy = GNormalise(wy)
    
    On Error GoTo GSub01
    
    z1 = CDec(wx)
    z2 = CDec(wy)
    z = CDec(z1 - z2)
    wx = Trim(Str(z))
    wx = GDecimale2(wx, Len(xdec))
    GSub = GNormalise(wx)
    On Error GoTo 0
    Exit Function
    
GSub01:
    On Error GoTo 0
    
   
    If Left(wx, 1) = "-" Then sgx = -1: wx = Mid(wx, 2) Else sgx = 1
    If Left(wy, 1) = "-" Then sgy = -1: wy = Mid(wy, 2) Else sgy = 1

    If sgx <> sgy Then              ' signes <> = addition
    
        n = GAdd(wx, wy)
        cas = 0
        If sgx = -1 Then n = "-" + n
        
    Else                            ' mm signes = soustaction
    
        If GSup(wx, wy) Then
            w1 = wx
            w2 = wy
            cas = 1
        Else
            w1 = wy
            w2 = wx
            cas = 2
        End If
            
        lg1 = Len(w1)
        lg2 = Len(w2)
        If lg1 > lg2 Then lg = lg1 Else lg = lg2
        lg = (Int(lg / gr) + 1) * gr
        w1 = String(lg - lg1, "0") + w1
        w2 = String(lg - lg2, "0") + w2
        
        n = ""
        ret = CDec(0)
        For i = lg To 1 Step -gr
            z1 = CDec(Mid(w1, i - gr + 1, gr))
            z2 = CDec(Mid(w2, i - gr + 1, gr))
            z = z1 - z2 - ret
            ret = CDec(0)
            If z < 0 Then
                z = CDec((10 ^ gr) + z)
                ret = CDec(1)
            End If
            n = Right(String(gr, "0") + Trim(Str(z)), gr) + n
        Next i
        
        If cas = 1 And sgx = -1 Then n = "-" + n
        If cas = 2 And sgx = 1 Then n = "-" + n
        
    End If
    
    n = GDecimale2(n, Len(xdec))
    GSub = GNormalise(n)
    
End Function

'--------------------------------------------------------------------------------------------------------
'   GMod    (x,y)       reste de la division de x par y          = x mod y
'                       x et y  string
'                       GMod   string
'--------------------------------------------------------------------------------------------------------
Public Function GMod(x, y)

    Call GDiv(x, y, reste)
    GMod = reste

End Function

'--------------------------------------------------------------------------------------------------------
'   GDiv    (x,y)       Division          = x / y
'                       x et y  string
'                       GDiv    string
'                       division classique comme à la main
'--------------------------------------------------------------------------------------------------------
Public Function GDiv(x, y, Optional reste, Optional Nbdecimales = 0) As String

    Dim ox As Variant, oy As Variant, oz As Variant, oo As Variant
    Dim wx As String, wy As String, wp As String, n As String
    Dim xd As Integer, yd As Integer, sgx As Integer, sgy As Integer
    Dim ix As Integer, imax As Integer
    Dim lgx As Integer, lgy As Integer
    Dim wm1 As String, wm2 As String
    Dim dd As Integer, d As Integer
    
    wx = GNormalise(x)
    wy = GNormalise(y)
    
    Call GDecimale(wx, xent, xdec)
    Call GDecimale(wy, yent, ydec)
    
    xd = Len(xdec)
    yd = Len(ydec)
    If xd < yd Then
        xdec = xdec + String(yd - xd, "0")
    Else
        ydec = ydec + String(xd - yd, "0")
    End If
    
    xdec = xdec + String(Nbdecimales, "0")
    
    wx = xent + xdec
    wy = yent + ydec
    
    wx = GNormalise(wx)
    wy = GNormalise(wy)
    
    On Error GoTo GDiv01
    ox = CDec(wx)
    oy = CDec(wy)
    oz = CDec(Int(ox / oy))
    oo = CDec(Abs(ox) - Abs(oy * oz))
    wx = Trim(Str(oz))
    wx = GDecimale2(wx, Nbdecimales)
    GDiv = GNormalise(wx)
    wx = Trim(Str(oo))
    wx = GDecimale2(wx, Nbdecimales)
    reste = GNormalise(wx)
    On Error GoTo 0
    Exit Function
    
GDiv01:
    On Error GoTo 0

    If Left(wx, 1) = "-" Then sgx = -1: wx = Mid(wx, 2) Else sgx = 1
    If Left(wy, 1) = "-" Then sgy = -1: wy = Mid(wy, 2) Else sgy = 1
    
    If wx = "0" Then
        GDiv = ""
        reste = ""
        Exit Function
    End If
    
    If GSup(wy, wx) Then
        GDiv = "0"
        reste = x
        Exit Function
    End If
    
    If GSupEq(wy, wx) Then
        If sgx = sgy Then GDiv = "1" Else GDiv = "-1"
        reste = "0"
        Exit Function
    End If
    
    lgy = Len(wy)
    wp = Left(wx, lgy)
    If GInf(wp, wy) Then wp = Left(wx, lgy + 1)
    
    n = ""
    ix = Len(wp)
    imax = Len(wx)
    
    Do
        wm1 = "0"
        dd = 0
        For d = 1 To 9
            wm2 = GMult(Str(d), wy)
            If GSup(wm2, wp) Then Exit For
            dd = d
            wm1 = wm2
        Next d
    
        n = n + Trim(Str(dd))
        wp = GSub(wp, wm1)
        ix = ix + 1
        If ix > imax Then Exit Do
        wp = wp + Mid(wx, ix, 1)
    Loop
    
    If sgx <> sgy Then n = "-" + n
    wp = GDecimale2(wp, Nbdecimales)
    reste = GNormalise(wp)
    n = GDecimale2(n, Nbdecimales)
    GDiv = GNormalise(n)
    

End Function

'--------------------------------------------------------------------------------------------------------
'   GRac    (x)         Racine carrée de x
'                       x       string
'                       GRac   string
'                       extraction classique comme à la main
'--------------------------------------------------------------------------------------------------------
Public Function GRac(x, Optional reste, Optional Nbdecimales = 0) As String
    
    
    Dim ox As Variant, oy As Variant, oo As Variant
    Dim wx As String
    Dim xd As Integer
    Dim tr1 As Integer, tr2 As Integer
    Dim res As String, rp As String, qt As String
    Dim ja  As String, m As String
    Dim i As Integer, nb2 As Integer
    
    wx = GNormalise(x)
    
    Call GDecimale(wx, xent, xdec)
    xd = Len(xdec)
    If xd Mod 2 = 1 Then xdec = xdec + "0"
    
    wx = xent + xdec
    wx = wx + String(2 * Nbdecimales, "0")
    
    wx = GNormalise(wx)
    
    On Error GoTo GRac01
    ox = CDec(wx)
    oy = CDec(Fix(Sqr(ox)))
    oo = CDec(ox - oy * oy)
    wx = Trim(Str(oy))
    wx = GDecimale2(wx, Nbdecimales + Len(xdec) / 2)
    GRac = GNormalise(wx)
    wx = Trim(Str(oo))
    wx = GDecimale2(wx, 2 * Nbdecimales + Len(xdec) / 2)
    reste = GNormalise(wx)
    On Error GoTo 0
    Exit Function
    
GRac01:
    On Error GoTo 0

    If Left(wx, 1) = "-" Then GRac = "": reste = "": Exit Function
    If Len(wx) Mod 2 = 1 Then wx = "0" + wx
    
    tr1 = Val(Left(wx, 2))
    tr2 = Int(Sqr(tr1))
    res = Trim(Str(tr2))
    rp = Trim(Str(tr1 - tr2 * tr2))
    nb2 = Len(wx) / 2
    
    For i = 2 To nb2
        rp = rp + Mid(wx, i * 2 - 1, 2)
        qt = GMult(res, "2")
        For j = 9 To 0 Step -1
            ja = Trim(Str(j))
            m = GMult(qt + ja, ja)
            If GInfEq(m, rp) Then Exit For
        Next j
        res = res + ja
        rp = GSub(rp, m)
    Next i
        
    wx = GDecimale2(res, Nbdecimales + Len(xdec) / 2)
    GRac = GNormalise(wx)
    wx = GDecimale2(rp, 2 * Nbdecimales + Len(xdec) / 2)
    reste = GNormalise(wx)
    

End Function

'--------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------
Public Function GRacn1(x As String, n As Integer, Optional reste, Optional Nbdecimales = 0)

    Dim r(1000) As String
    Dim r1(1000) As String
    Erase r, r1
    
    nn = n
    
    If nn = 0 Then
        GRacn = "1"
        reste = "0"
        Exit Function
    End If
    If nn = 1 Then
        GRacn = x
        reste = "0"
        Exit Function
    End If
    If nn < 2 Or nn > UBound(r) Or nn <> Fix(nn) Then
        GRacn = ""
        reste = ""
        Exit Function
    End If
        
    
    wx = GNormalise(x)
    If Left(wx, 1) = "-" Then
        neg = True
        If nn Mod 2 = 0 Then GRacn = "": reste = "": Exit Function
        wx = Mid(wx, 2)
    Else
        neg = False
    End If
    Call GDecimale(x, we, wd)
                                                    ' nb chiffres partie entière = k.n
    w = Len(we) Mod nn
    If w > 0 Then we = String(nn - w, "0") + we
    lge = Len(we)
                                                    ' nb chiffres partie décimale
    If Nbdecimales > 0 Then
        If Nbdecimales - Len(wd) > 0 Then wd = wd + String(Nbdecimales - Len(wd), "0")
    End If
    If Len(wd) > 0 Then wd = wd + String((nn - 1) * Len(wd), "0")
    lgd = Len(wd)
                                                    ' nombre entier
    wx = we + wd
    lg = lge + lgd
    
    tr = 1
    trd = lg / nn
    r(0) = "1"
    r(n) = Left(wx, nn)
    chgtr = False
    
    Do Until r(nn) = "0" And tr = trd
    
        If chgtr = False Then
            For k = 1 To nn: r1(k) = r(k): Next k
        Else
            For k = 1 To nn: r(k) = r1(k): Next k
            r(1) = GSub(r(1), "1")
            For k = 1 To nn - 1: r(k) = r(k) + String(k, "0"): Next k
            tr = tr + 1
            If tr > trd Then Exit Do
            r(nn) = r(nn) + Mid(wx, 1 + (tr - 1) * nn, nn)
            r(1) = GAdd(r(1), "10")
            chgtr = False
        End If
    
        For i = 0 To nn - 1
            For j = 1 To nn - i
                If j = nn Then
                    If GSupEq(r(j), r(j - 1)) Then
                        r(j) = GSub(r(j), r(j - 1))
                        reste = r(j)
                        rr1 = r(1)
                    Else
                        chgtr = True
                        Exit For
                    End If
                Else
                    r(j) = GAdd(r(j), r(j - 1))
                End If
            Next j
            If chgtr Then Exit For
        Next i
        
        If GInf(r(nn), r(nn - 1)) Then chgtr = True
        
    Loop
    
GRacnf:
    
    w = GAdd(rr1, Str(nn - 1))
    w = GDiv(w, Str(nn))
    
    wx = GDecimale2(w, lgd / nn)
    wx = GNormalise(wx)
    If neg Then wx = "-" + wx
    GRacn = wx
    wx = GDecimale2(reste, lgd)
    wx = GNormalise(wx)
    If neg Then wx = "-" + wx
    reste = wx
    
End Function

'--------------------------------------------------------------------------------------------------------
Public Function GRacn(x As String, n As Integer, Optional reste As String, Optional Nbdecimales As Integer = 0)

    Dim wx As String
    Dim un As String, un1 As String
    Dim nn As Integer
    
    nn = n
    nbd = Nbdecimales + 10
    
    If nn = 0 Then GRacn = "1": reste = "0": Exit Function
    If nn = 1 Then GRacn = x: reste = "0": Exit Function
    If nn < 2 Or nn > 1000 Or nn <> Fix(nn) Then GRacn = "": reste = "": Exit Function
        
    wx = GNormalise(x)
    If Left(wx, 1) = "-" Then
        neg = True
        If nn Mod 2 = 0 Then GRacn = "": reste = "": Exit Function
        wx = Mid(wx, 2)
    Else
        neg = False
    End If
    Call GDecimale(x, we, wd)
    wd = wd + String(10, "0")
                                                    ' nb chiffres partie entière = k.n
    w = Len(we) Mod nn
    If w > 0 Then we = String(nn - w, "0") + we
    lge = Len(we)
                                                    ' nb chiffres partie décimale
    If nbd > 0 Then
        If nbd - Len(wd) > 0 Then wd = wd + String(nbd - Len(wd), "0")
    End If
    If Len(wd) > 0 Then wd = wd + String((nn - 1) * Len(wd), "0")
    lgd = Len(wd)
                                                    ' nombre entier
    wx = we + wd
    lg = lge + lgd
    
    
    wu = GNormalise(wx)
    pp = Len(wu) - 1
    u = Val(Left(wu, 1) + "." + Mid(wu, 2, 10))
    slog = (Log(u) / Log(10) + pp) / n             ' log décimal  log10(x)=log(x)/log(10)
    sexp = Int(slog)
    sdec = Exp((slog - sexp) * Log(10))
    For i = 1 To 8
        If sexp > 1 Then sdec = sdec * 10: sexp = sexp - 1
    Next i
    
    un = "0"
    un1 = Trim(Str(Fix(sdec))) + String(sexp, "0")
    
    Do Until GSub(un, un1) = "0"
    
        yyy = GSub(un, un1)
        DoEvents
    
        un = un1
        w1 = GExp(un, Str(nn - 1))
        w2 = GDiv(wx, w1)
        w3 = GMult(un, Str(nn - 1))
        w4 = GAdd(w2, w3)
        un1 = GDiv(w4, Str(n))
    Loop
    

    
    wx = GDecimale2(un1, lgd / nn)
    wx = GDecimale3(wx, Nbdecimales)
    wx = GNormalise(wx)
    If neg Then wx = "-" + wx
    GRacn = wx
    
    wx = GExp(wx, nn)
    wx = GSub(x, wx)
    If neg Then wx = "-" + wx
    reste = wx
    
End Function

'--------------------------------------------------------------------------------------------------------
Public Function GSol2(a, b, c, x1, x2, Optional Nbdecimales = 0)

    Delta = GMult(b, b)
    w = GMult(a, c)
    w = GMult(w, "4")
    Delta = GSub(Delta, w)
    If GInf(Delta, "0") Then
        GSol2 = False
        x1 = ""
        x2 = ""
        Exit Function
    End If
    
    rac_delta = GRac(Delta, reste, Nbdecimales)
    If Nbdecimales = 0 And reste <> "0" Then
        GSol2 = False
        x1 = ""
        x2 = ""
        Exit Function
    End If
    
    a2 = GAdd(a, a)
    b2 = GMult(b, "-1")
    
    x1 = GAdd(b2, rac_delta)
    x1 = GDiv(x1, a2, reste, Nbdecimales)
    If Nbdecimales = 0 And reste <> "0" Then x1 = ""
    
    x2 = GSub(b2, rac_delta)
    x2 = GDiv(x2, a2, reste, Nbdecimales)
    If Nbdecimales = 0 And reste <> "0" Then x2 = ""
    
    If x1 = "" And x2 = "" Then GSol2 = False: Exit Function
    
    GSol2 = True
    
End Function

'--------------------------------------------------------------------------------------------------------
Public Function GConvF(x, Optional p = 16)

    wx = GNormalise(x)
    If wx = "0" Then GConvF = "0": Exit Function
    If Left(wx, 1) = "-" Then sg = -1: wx = Mid(wx, 2) Else sg = 1
    Call GDecimale(wx, xe, xd)
    wx = xe + xd
    
    expo = Len(xe) - 1
    While Left(wx, 1) = "0"
        wx = Mid(wx, 2)
        expo = expo - 1
    Wend
    
    If p < 1 Then p = 16
    If Len(wx) > p Then                     ' arrondi
        w = Left(wx, p + 1)
        w = GAdd(w, 5)
    Else
        w = wx
    End If
    w = Left(Left(w, 1) + "." + Mid(w, 2, p - 1) + String(p, "0"), p + 1)
    w = w + " 10^" + Trim(Str(expo))
    If sg = -1 Then w = "-" + w
    GConvF = w
    
End Function

'--------------------------------------------------------------------------------------------------------
Public Function GConvD(x) As Double

    wx = GNormalise(x)
    If wx = "0" Then GConvD = 0: Exit Function
    If Left(wx, 1) = "-" Then sg = -1: wx = Mid(wx, 2) Else sg = 1
    Call GDecimale(wx, xe, xd)
    wx = xe + xd
    
    expo = Len(xe) - 1
    While Left(wx, 1) = "0"
        wx = Mid(wx, 2)
        expo = expo - 1
    Wend
    
    If Abs(expo) > 323 Then GConvD = 0: Exit Function
    
    If Mid(wx, 2, 18) = "" Then
        wx = Left(wx, 1)
    Else
        wx = Left(wx, 1) + "." + Mid(wx, 2, 18)
    End If
    wx = wx + "E" + Trim(Str(expo))
    If sg = -1 Then w = "-" + w
    GConvD = CDbl(Val(wx))
    
End Function

'--------------------------------------------------------------------------------------------------------
Public Function GConvA(x) As String

    If x = 0 Then GConvA = "0": Exit Function
    x1 = x
    If x1 > 0 Then
        sg = 1
    Else
        x1 = Abs(x1)
        sg = -1
    End If
    wx = Trim(Str(x1))
    
    p = InStr(wx, "E")
    If p > 0 Then
        expo = Mid(wx, p + 1)
        wx = Left(wx, p - 1)
        Call GDecimale(wx, xe, xd)
        d = Len(xd)
        If d > 0 Then
            wx = xe + xd
            expo = expo - d
        End If
        If expo > 0 Then wx = wx + String(expo, "0")
        If expo < 0 Then
            expo = Abs(expo)
            d = Len(wx)
            If expo >= d Then
                wx = "0." + String(expo - d, "0") + wx
            Else
                wx = Left(wx, d - expo) + "." + Mid(wx, d - expo + 1)
            End If
        End If
    End If
    
    If sg = -1 Then wx = "-" + Trim(wx)
    GConvA = GNormalise(wx)
        
End Function

'-----------------------------------------------------------------------------
Function GConvB(n) As String

    Dim wn As Variant
    Dim v1 As Variant, v2 As Variant
    Dim wna As String
    
    v1 = CDec(1)
    v2 = CDec(2)
    
    On Error GoTo gconvb01
    res = ""
    wn = CDec(n)
    Do
        If wn Mod v2 = v1 Then
            res = "1" + res
            wn = wn - v1
        Else
            res = "0" + res
        End If
        wn = wn / v2
    Loop Until wn = 0
    
    GConvB = res
    On Error GoTo 0
    Exit Function
    
gconvb01:
    On Error GoTo 0
    
    wna = n
    res = ""
    Do
        If GMod(wna, "2") = "1" Then
            res = "1" + res
            wna = GSub(wna, "1")
        Else
            res = "0" + res
        End If
        wna = GDiv(wna, "2")
    Loop Until wna = "0"
    
    GConvB = res
        
End Function

'----------------------------------------------------------------------------------------------
'       conversion de nombre écrit en base1 vers un nombre écrit en base2
'                       nombre              string
'                       base1, base2        integer
'               base <= 16  les nombres sont écrits avec les chiffres de 0 à F
'               base >16    les nombres sont écrits avec les valeurs décimales des chiffres
'                           séparés par des virgules
'                           en base 60 nombre = 12,1,59  = 12*60^2 + 1*60 + 59
'----------------------------------------------------------------------------------------------
Function GConvBase(nombre, base1, base2) As String

    Dim n10 As String
    Dim p As Integer, i As Integer, nb As Integer
    Dim na As String, r As String
    Dim b1 As String, b2 As String, b As String
    Dim ch(5000) As Integer
    
    GConvBase = ""                       ' assume erreur
    
    b1 = Str(base1)
    b2 = Str(base2)
    na = Trim(nombre)
    
    If base1 <= 16 Then
        
        nb = Len(na)
        For i = 1 To nb
            ch(i) = InStr("0123456789ABCDEF", Mid(na, i, 1)) - 1
            If ch(i) = -1 Then Exit Function
        Next i
        
    Else
        
        nb = 0
        na = na + ","
        Do
            nb = nb + 1
            p = InStr(na, ",")
            ch(nb) = Val(Mid(na, p - 1))
            If ch(nb) >= base1 Then Exit Function
            na = Trim(Mid(na, p + 1))
        Loop While na > ""
        
    End If
    
                                            ' conversion en base 10
                                            
    n10 = "0"
    b = "1"
    For i = nb To 1 Step -1
        r = GMult(Str(ch(i)), b)
        n10 = GAdd(n10, r)
        b = GMult(b, b1)
    Next i
    
                                            ' conversion en base2
                                            
    Erase ch
    nb = 0
    Do
        nb = nb + 1
        ch(nb) = Val(GMod(n10, b2))
        n10 = GDiv(n10, b2)
    Loop Until n10 = "0"
    
                                            ' écriture du nombre
                                            
    res = ""
    If base2 <= 16 Then
    
        For i = nb To 1 Step -1
            res = res + Mid("0123456789ABCDEF", ch(i) + 1, 1)
        Next i
        
    Else
    
        For i = nb To 1 Step -1
            res = res + Trim(Str(ch(i))) + ","
        Next i
        res = Left(res, Len(res) - 1)
        
    End If
    
    GConvBase = res

End Function

Sub xxxx_gconvbas()

    Dim aaa As String
    a = 11001
    b1 = 10
    b2 = 2
    
    aaa = GConvBase(Str(a), b2, b1)
    

End Sub

'-----------------------------------------------------------------------------
'       Calcul de a^n modulo m
'-----------------------------------------------------------------------------
Function GModP(a, n, m)

    Dim nb As String
    Dim a1 As String, a2 As String, a3 As String
    Dim r As String
    
    nb = GConvB(n)
    
    r = "1"
    
    For i = 1 To Len(nb)
        If Val(Mid(nb, i, 1)) = "0" Then a1 = "1" Else a1 = a
        a2 = GMult(r, r)
        a3 = GMult(a1, a2)
        r = GMod(a3, m)
    Next i

    GModP = r

End Function

'-----------------------------------------------------------------------------
'       test de primalité   ---> Miller-Bach (1985)
'-----------------------------------------------------------------------------
Function GPremier(n, Optional precision = 0)

    Dim q As String
    Dim r As String
    Dim a As String
    Dim amax As String
    Dim m As String
    Dim m0 As String
    Dim d1 As Double, d2 As Double
    Dim n1 As String

    n1 = GSub(n, "1")
'                               q tq n-1 = 2^r*q
    q = n1
    r = "0"
    While GMod(q, "2") = "0"
        q = GDiv(q, "2")
        r = GAdd(r, "1")
    Wend
    
    a = "2"
    
    d1 = GConvD(n)
    d2 = Fix(2 * (Log(d1)) ^ 2 + 0.5)
    amax = GConvA(d2)
    If GInfEq(n, amax) Then amax = n1
    If precision = 0 Then
        pas = amax
    Else
        pas = GSub(amax, a)
        pas = GDiv(pas, Str(precision))
        If pas = "0" Then pas = "1"
    End If
    
    While GInfEq(a, amax)
    
        m = GModP(a, q, n)
        
        If m <> "1" Then
            If r <> "1" Then
                ir = "1"
                While Not GEq(m, n1)
                    m = GMult(m, m)
                    m = GMod(m, n)
                    ir = GAdd(ir, 1)
                    If GInf(r, ir) Then GPremier = False: Exit Function
                Wend
            Else
                If Not GEq(m, n1) Then GPremier = False: Exit Function
            End If
        End If
        
        a = GAdd(a, pas)
        If GMod(a, "2") Then a = GAdd(a, "1")
        
    Wend
    
    GPremier = True
    
End Function

Sub Gtest_xxxxx_Miller()

    For n = 123456792 To 123456799
        pr = GPremier(Str(n))
        If pr Then
            ll = ll + 1
            Cells(ll, 1) = n
            Cells(ll, 2) = pr
        Else
            ll = ll + 1
            Cells(ll, 1) = n
            Cells(ll, 2) = "composé"
        End If
    Next n
    MsgBox "fin"

End Sub

'--------------------------------------------------------------------------------------------------------
Public Function GEq(x, y)

    wx = GNormalise(x)
    wy = GNormalise(y)

    If wx = wy Then GEq = True Else GEq = False

End Function

'--------------------------------------------------------------------------------------------------------
Public Function GSup(x, y)

    wx = GNormalise(x)
    wy = GNormalise(y)
    
    Call GDecimale(wx, xent, xdec)
    Call GDecimale(wy, yent, ydec)
    
    xd = Len(xdec)
    yd = Len(ydec)
    If xd < yd Then
        xdec = xdec + String(yd - xd, "0")
    Else
        ydec = ydec + String(xd - yd, "0")
    End If
        
    wx = xent + xdec
    wy = yent + ydec
    
    wx = GNormalise(wx)
    wy = GNormalise(wy)

    If wx = wy Then GSup = False: Exit Function

    If Left(wx, 1) = "-" Then sgx = -1: wx = Mid(wx, 2) Else sgx = 1
    If Left(wy, 1) = "-" Then sgy = -1: wy = Mid(wy, 2) Else sgy = 1
    
    If sgx = 1 And sgy = -1 Then GSup = True: Exit Function
    If sgx = -1 And sgy = 1 Then GSup = False: Exit Function
    
    lgx = Len(wx)
    lgy = Len(wy)
    
    If lgx > lgy Then
        If sgx = 1 Then GSup = True Else GSup = False
        Exit Function
    End If
    
    If lgx < lgy Then
        If sgx = 1 Then GSup = False Else GSup = True
        Exit Function
    End If

    For i = 1 To lgx
        If Mid(wx, i, 1) > Mid(wy, i, 1) Then GSup = True: Exit Function
        If Mid(wx, i, 1) < Mid(wy, i, 1) Then GSup = False: Exit Function
    Next i
    
    GSup = False
        
End Function

'--------------------------------------------------------------------------------------------------------
Public Function GInf(x, y)

    If GEq(x, y) Then GInf = False: Exit Function
    If GSup(x, y) Then GInf = False Else GInf = True
        
End Function

'--------------------------------------------------------------------------------------------------------
Public Function GSupEq(x, y)

    GSupEq = False
    If Not GInf(x, y) Then GSupEq = True

End Function

'--------------------------------------------------------------------------------------------------------
Public Function GInfEq(x, y)

    GInfEq = False
    If Not GSup(x, y) Then GInfEq = True

End Function

Public Function GComp(x, y)

    If GEq(x, y) Then GComp = 0: Exit Function
    If GSup(x, y) Then GComp = 1 Else GComp = -1

End Function

'--------------------------------------------------------------------------------------------------------
Public Function GNormalise(x)

    wx = Trim(x)
    If Left(wx, 1) = "-" Then sg = -1: wx = Mid(wx, 2) Else sg = 1
    While Left(wx, 1) = "0"
        wx = Mid(wx, 2)
    Wend
    If Left(wx, 1) = "." Then wx = "0" + wx
    If wx = "" Then wx = "0"
    If sg = -1 And wx <> "0" Then wx = "-" + wx
    If InStr(wx, ".") > 0 Then
        While Right(wx, 1) = "0"
            wx = Left(wx, Len(wx) - 1)
        Wend
        If Right(wx, 1) = "." Then wx = Left(wx, Len(wx) - 1)
    End If
    GNormalise = wx
    
End Function

'--------------------------------------------------------------------------------------------------------
Public Sub GDecimale(x, Optional xe, Optional xd)

            ' renvoie partie entière et partie décimale
            
    p = InStr(x, ".")
    If p = 0 Then p = InStr(x, ",")
    If p = 0 Then
        xe = x
        xd = ""
    Else
        xe = Left(x, p - 1)
        xd = Mid(x, p + 1)
        While Right(xd, 1) = "0"
            xd = Left(xd, Len(xd) - 1)
        Wend
    End If
        

End Sub

'--------------------------------------------------------------------------------------------------------
Public Function GDecimale2(x, Nbdecimales)

            ' insère la marque décimale
    Nbdecimales = Val(Nbdecimales)
    
    If Nbdecimales = 0 Then GDecimale2 = x: Exit Function
    wx = x
    lg = Len(wx)
    
    If Nbdecimales >= lg Then
        wx = "0." + String(Nbdecimales - lg, "0") + wx
    Else
        wx = Left(wx, lg - Nbdecimales) + "." + Mid(wx, lg - Nbdecimales + 1)
    End If
    GDecimale2 = wx

End Function

'--------------------------------------------------------------------------------------------------------
Public Function GDecimale3(x, Nbdecimales)

        ' tronque les décimales superflues

    wx = x
    Call GDecimale(wx, we, wd)
    If Nbdecimales = 0 Then
        wx = we
    Else
        wd = Left(wd, Nbdecimales)
        wx = we + "." + wd
    End If
    
    GDecimale3 = wx
    
End Function

'--------------------------------------------------------------------------------------------------------
Public Function GInt(x)

    wx = GNormalise(x)
    Call GDecimale(wx, xe, xd)
    GInt = xe
    
End Function

'--------------------------------------------------------------------------------------------------------
Public Function GDec(x)

    wx = GNormalise(x)
    Call GDecimale(wx, xe, xd)
    GDec = xd
    
End Function

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Messages postés
9
Date d'inscription
dimanche 13 janvier 2008
Statut
Membre
Dernière intervention
6 octobre 2014

Sa aurai été plus facile à comprendre avec des commentaire, sa aide pour une optimisation.
Messages postés
2065
Date d'inscription
lundi 11 avril 2005
Statut
Membre
Dernière intervention
14 mars 2016
8
Salut,

Un encouragement est une remarque constructive !?
Une remarque pour optimiser est non constructif !?

Comprendra qui peut... En fouillant un peu VBF, on trouve des codes plus aboutis pour une bonne base de départ...

A bon entendeur...

Amicalement,
Us.
Messages postés
5
Date d'inscription
mercredi 21 janvier 2004
Statut
Membre
Dernière intervention
28 janvier 2010

Enfin une remarque constructive.
Merci.
Messages postés
18
Date d'inscription
jeudi 3 juin 2004
Statut
Membre
Dernière intervention
4 janvier 2012

Il est vrai que le code est loin d'être parfait mais sur le principe c'est une bonne base de départ
Messages postés
30
Date d'inscription
lundi 9 octobre 2000
Statut
Membre
Dernière intervention
16 février 2010

Optimiser, optimiser... bien grand mot lorsqu'on ne prend pas la peine de déclarer ses variables...

Peut-être faudrait-il commencer par là... ;)
Afficher les 7 commentaires

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.