Calculs sur de grands nombres (plusieurs milliers de chiffres)
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)
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
- Calculs sur de grands nombres (plusieurs milliers de chiffres)
- Rib maroc 24 chiffres - Forum Visual Basic 6
- Générateur de nombre ✓ - Forum PHP
- Clé rib - Forum Visual Basic
- Calcul nombre de parpaing ✓ - Forum VB.NET
- Controle et génération d'une clé RIB - Forum Delphi / Pascal
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.