Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0788: Secret Sharing

VB 5/6-Tipp 0788: Secret Sharing

 von Dario

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [5,13 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Modul "Module1" alias Module1.bas ---------
Option Explicit

' Zusammensetzen
Public Function Assemble(ByVal Shares As Collection) As Double
   Dim Grade      As Long
   Dim tmp        As Participant
   Dim i          As Long
   Dim Equation() As Double
   Dim Solver     As New LinearEquationSystem
   
   Grade = Shares(1).NumRequired
   ReDim Equation(Grade) As Double
   Call Solver.Initialize(Grade)
   
   For Each tmp In Shares
      For i = Grade - 1 To 0 Step -1
         Equation((Grade - 1) - i) = tmp.x ^ i
      Next i
      
      Equation(Grade) = tmp.y
      Call Solver.AddEquation(Equation)
   Next tmp
   
   Assemble = Solver.SolveForLast
End Function

' Geheimnis aufteilen
Public Function Deal(k As Double, ByVal NumShares As Long, ByVal NumRequired As Long) As Collection
   Dim Shares           As New Collection
   Dim tmp              As Participant
   Dim CryptFunction()  As Double
   Dim x                As Double
   Dim PrevXes          As New Collection
   Dim i                As Long
   
   Call Randomize
   
   CryptFunction = CreateFunction(k, NumRequired)
   Call PrevXes.Add(0)
      
   For i = 1 To NumShares
      Set tmp = New Participant
      
      Do
         x = Int(Rnd * (2 + NumShares)) - NumShares
      Loop While IsInCollection(x, PrevXes)
         
      With tmp
         .NumRequired = NumRequired
         .x = x
         .y = Eval(x, CryptFunction)
      End With
      
      Call PrevXes.Add(x)
      Call Shares.Add(tmp)
   Next i
   
   Set Deal = Shares
End Function

' Funktion erstellen
Public Function CreateFunction(k As Double, ByVal NumShares As Long) As Double()
   Dim Coefficients()   As Double
   Dim i                As Long
   
   ReDim Coefficients(NumShares - 1) As Double
   
   Call Randomize
   
   For i = 1 To NumShares - 1
      Coefficients(i) = Int(Rnd * (2 + NumShares)) - NumShares
   Next i
   
   Coefficients(0) = k
   
   CreateFunction = Coefficients
End Function

' Funktion ausrechnen
Public Function Eval(x As Double, Coefficients() As Double) As Double
   Dim i    As Long
   Dim Res  As Double
   
   For i = 0 To UBound(Coefficients)
      Res = Res + Coefficients(i) * x ^ i
   Next i
   
   Eval = Res
End Function


' Befindet sich ein Wert bereits in einer Collection?
Private Function IsInCollection(x As Double, ByVal Coll As Collection) As Boolean
   Dim tmp As Variant
   
   IsInCollection = True
   
   For Each tmp In Coll
      If tmp = x Then Exit Function
   Next tmp
   
   IsInCollection = False
End Function
'---------- Ende Modul "Module1" alias Module1.bas ----------
'---- Anfang Klasse "Participant" alias Participant.cls  ----
Option Explicit

' Repräsentation eines Mitwissers

Public x             As Double   ' x-Wert
Public y             As Double   ' y-Wert (Funktionswert)
Public NumRequired   As Long     ' Zahl der zum Entschlüsseln benötigten Mitwisser

'----- Ende Klasse "Participant" alias Participant.cls  -----
'--- Anfang Klasse "LinearEquationSystem" alias clsLGS.cls  ---
Option Explicit

' Angepasste Version der LGS-Klasse aus Upload Nr. 81

Private mMatrix()       As Double
Private mNumVariables   As Integer

Public Sub Initialize(ByVal NumVariables As Integer)
   mNumVariables = NumVariables
   ReDim mMatrix(1 To NumVariables + 1, 1 To NumVariables) As Double
End Sub

Public Sub AddEquation(ByRef Coefficients() As Double)
   Static Counter As Integer
   Dim i          As Integer
   
   Counter = Counter + 1
  
   For i = 0 To UBound(Coefficients)
      mMatrix(i + 1, Counter) = CDbl(Coefficients(i))
   Next i
End Sub


Private Sub CombineLine(ByVal LineFrom As Integer, ByVal LineTo As Integer, ByVal Distance As Integer)
   Dim FactorA    As Double
   Dim FactorB    As Double
   Dim x          As Integer
   
   FactorA = mMatrix(Distance, LineFrom)
   FactorB = mMatrix(Distance, LineTo)
  
   For x = Distance To mNumVariables + 1
      mMatrix(x, LineTo) = FactorA * mMatrix(x, LineTo) - FactorB * mMatrix(x, LineFrom)
   Next
End Sub

Private Sub CombineColumn(ByVal Line As Integer, ByVal Distance As Integer)
   Dim y As Integer
   
   For y = Line + 1 To mNumVariables
      Call CombineLine(Line, y, Distance)
   Next y
End Sub

Private Sub CombineMatrix()
   Dim x As Integer
   
   For x = 1 To mNumVariables - 1
      Call CombineColumn(x, x)
   Next x
End Sub

Public Function SolveForLast() As Double
   Call CombineMatrix
   
   SolveForLast = mMatrix(mNumVariables + 1, mNumVariables) / mMatrix(mNumVariables, mNumVariables)
End Function
'--- Ende Klasse "LinearEquationSystem" alias clsLGS.cls  ---
'------- Anfang Formular "frmShare" alias frmMain.frm -------
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Textfeld "txtRequired" auf Frame1
' Steuerelement: Textfeld "txtCreate" auf Frame1
' Steuerelement: Textfeld "txtSecret" auf Frame1
' Steuerelement: Schaltfläche "Command1" auf Frame1
' Steuerelement: Beschriftungsfeld "Label4" auf Frame1
' Steuerelement: Beschriftungsfeld "Label3" auf Frame1
' Steuerelement: Beschriftungsfeld "Label2" auf Frame1
' Steuerelement: Listen-Steuerelement "lstShares"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit

' Achtung: Bei zu großen Mitwisserzahlen kann es zu Überläufen kommen!

Private Shares As New Collection                ' Die einzelnen Mitwisser
Private NumShares As Long, NumRequired As Long  ' Zahl der Mitwisser und der benötigten Anzahl zum Entschlüsseln

' Aufteilen
Private Sub Command1_Click()
On Error Goto ExceptionHandler
   Dim Secret As Double
   Dim tmp    As Participant
   Dim i      As Long
   
   Secret = CDbl(txtSecret.Text)
   NumShares = CLng(txtCreate.Text)
   NumRequired = CLng(txtRequired.Text)
   
   If NumRequired > NumShares Or NumRequired < 2 Then
ExceptionHandler:
      Call MsgBox("Fehler, falsche Werte", vbCritical)
      Exit Sub
   End If
   
   On Error Goto 0
   
   Set Shares = Deal(Secret, NumShares, NumRequired)
   
   Call lstShares.Clear
   For Each tmp In Shares
      Call lstShares.AddItem(CStr(i + 1) & ": ( " & CStr(tmp.x) & " | " & CStr(tmp.y) & " )")
      i = i + 1
   Next
   
   lstShares.Enabled = True
End Sub

' Zusammensetzen
Private Sub Command2_Click()
   Dim Participants  As New Collection
   Dim i             As Long
   
   For i = 0 To lstShares.ListCount - 1
      If lstShares.Selected(i) = True Then Call Participants.Add(Shares(i + 1))
   Next i
   
   Call MsgBox("Wert " & Assemble(Participants) & " ermittelt", vbInformation, "Ergebnis erhalten")
End Sub

' Entladen
Private Sub Command3_Click()
   Call Unload(Me)
   Set frmShare = Nothing
End Sub


' Formfunktionen wie NumOnly-Eingabe oder Aktivierung von Steuerelementen
Private Sub lstShares_Click()
   Command2.Enabled = (lstShares.SelCount = NumRequired)
End Sub

Private Sub txtCreate_KeyPress(KeyAscii As Integer)
   KeyAscii = IIf(KeyAscii < Asc("0") Or KeyAscii > Asc("9") Or Len(txtCreate.Text) > 1 Xor KeyAscii = 8, 0, KeyAscii)
End Sub

Private Sub txtRequired_KeyPress(KeyAscii As Integer)
   KeyAscii = IIf(KeyAscii < Asc("0") Or KeyAscii > Asc("9") Or Len(txtRequired.Text) > 0 Xor KeyAscii = 8, 0, KeyAscii)
End Sub

Private Sub txtSecret_KeyPress(KeyAscii As Integer)
   KeyAscii = IIf(KeyAscii < Asc("0") Or KeyAscii > Asc("9") Or Len(txtSecret.Text) > 1 Xor KeyAscii = 8, 0, KeyAscii)
End Sub

'-------- Ende Formular "frmShare" alias frmMain.frm --------
'-------------- Ende Projektdatei Projekt1.vbp --------------