Anonymous user
Playfair cipher: Difference between revisions
no edit summary
(Added Sidef) |
No edit summary |
||
Line 2,186:
Decoded: HI DE TH EG OL DI NT HE TR EX ST UM PZ
</pre>
=={{header|VBA}}==
<lang vb>
Option Explicit
Private Type Adress
Row As Integer
Column As Integer
End Type
Private myTable() As String
Sub Main()
Dim keyw As String, boolQ As Boolean, text As String, test As Long
Dim res As String
keyw = InputBox("Enter your keyword : ", "KeyWord", "Playfair example")
If keyw = "" Then GoTo ErrorHand
Debug.Print "Enter your keyword : " & keyw
boolQ = MsgBox("Ignore Q when buiding table y/n : ", vbYesNo) = vbYes
Debug.Print "Ignore Q when buiding table y/n : " & IIf(boolQ, "Y", "N")
Debug.Print ""
Debug.Print "Table : "
myTable = CreateTable(keyw, boolQ)
On Error GoTo ErrorHand
test = UBound(myTable)
On Error GoTo 0
text = InputBox("Enter your text", "Encode", "hide the gold in the TRRE stump")
If text = "" Then GoTo ErrorHand
Debug.Print ""
Debug.Print "Text to encode : " & text
Debug.Print "-------------------------------------------------"
res = Encode(text)
Debug.Print "Encoded text is : " & res
res = Decode(res)
Debug.Print "Decoded text is : " & res
text = InputBox("Enter your text", "Encode", "hide the gold in the TREE stump")
If text = "" Then GoTo ErrorHand
Debug.Print ""
Debug.Print "Text to encode : " & text
Debug.Print "-------------------------------------------------"
res = Encode(text)
Debug.Print "Encoded text is : " & res
res = Decode(res)
Debug.Print "Decoded text is : " & res
Exit Sub
ErrorHand:
Debug.Print "error"
End Sub
Private Function CreateTable(strKeyword As String, Q As Boolean) As String()
Dim r As Integer, c As Integer, temp(1 To 5, 1 To 5) As String, t, cpt As Integer
Dim strT As String, coll As New Collection
Dim s As String
strKeyword = UCase(Replace(strKeyword, " ", ""))
If Q Then
If InStr(strKeyword, "J") > 0 Then
Debug.Print "Your keyword isn't available with your choice : Not Q (==> J) !"
Exit Function
End If
Else
If InStr(strKeyword, "Q") > 0 Then
Debug.Print "Your keyword isn't available with your choice : Q (==> Not J) !"
Exit Function
End If
End If
strT = IIf(Not Q, "ABCDEFGHIKLMNOPQRSTUVWXYZ", "ABCDEFGHIJKLMNOPRSTUVWXYZ")
t = Split(StrConv(strKeyword, vbUnicode), Chr(0))
For c = LBound(t) To UBound(t) - 1
strT = Replace(strT, t(c), "")
On Error Resume Next
coll.Add t(c), t(c)
On Error GoTo 0
Next
strKeyword = vbNullString
For c = 1 To coll.Count
strKeyword = strKeyword & coll(c)
Next
t = Split(StrConv(strKeyword & strT, vbUnicode), Chr(0))
c = 1: r = 1
For cpt = LBound(t) To UBound(t) - 1
temp(r, c) = t(cpt)
s = s & " " & t(cpt)
c = c + 1
If c = 6 Then c = 1: r = r + 1: Debug.Print " " & s: s = ""
Next
CreateTable = temp
End Function
Private Function Encode(s As String) As String
Dim i&, t() As String, cpt&
s = UCase(Replace(s, " ", ""))
'insert "X"
For i = 1 To Len(s) - 1
If Mid(s, i, 1) = Mid(s, i + 1, 1) Then s = Left(s, i) & "X" & Right(s, Len(s) - i)
Next
'Do the pairs
For i = 1 To Len(s) Step 2
ReDim Preserve t(cpt)
t(cpt) = Mid(s, i, 2)
cpt = cpt + 1
Next i
If Len(t(UBound(t))) = 1 Then t(UBound(t)) = t(UBound(t)) & "X"
Debug.Print "[the pairs : " & Join(t, " ") & "]"
'swap the pairs
For i = LBound(t) To UBound(t)
t(i) = SwapPairsEncoding(t(i))
Next
Encode = Join(t, " ")
End Function
Private Function SwapPairsEncoding(s As String) As String
Dim r As Integer, c As Integer, d1 As String, d2 As String
Dim addD1 As Adress, addD2 As Adress, resD1 As Adress, resD2 As Adress
d1 = Left(s, 1): d2 = Right(s, 1)
For r = 1 To 5
For c = 1 To 5
If d1 = myTable(r, c) Then addD1.Row = r: addD1.Column = c
If d2 = myTable(r, c) Then addD2.Row = r: addD2.Column = c
Next
Next
Select Case True
Case addD1.Row = addD2.Row And addD1.Column <> addD2.Column
'same row, different columns
resD1.Column = IIf(addD1.Column + 1 = 6, 1, addD1.Column + 1)
resD2.Column = IIf(addD2.Column + 1 = 6, 1, addD2.Column + 1)
SwapPairsEncoding = myTable(addD1.Row, resD1.Column) & myTable(addD2.Row, resD2.Column)
Case addD1.Row <> addD2.Row And addD1.Column = addD2.Column
'same columns, different rows
resD1.Row = IIf(addD1.Row + 1 = 6, 1, addD1.Row + 1)
resD2.Row = IIf(addD2.Row + 1 = 6, 1, addD2.Row + 1)
SwapPairsEncoding = myTable(resD1.Row, addD1.Column) & myTable(resD2.Row, addD2.Column)
Case addD1.Row <> addD2.Row And addD1.Column <> addD2.Column
'different rows, different columns
resD1.Row = addD1.Row
resD2.Row = addD2.Row
resD1.Column = addD2.Column
resD2.Column = addD1.Column
SwapPairsEncoding = myTable(resD1.Row, resD1.Column) & myTable(resD2.Row, resD2.Column)
End Select
End Function
Private Function Decode(s As String) As String
Dim t, i&, j&, e&
t = Split(s, " ")
e = UBound(t) - 1
'swap the pairs
For i = LBound(t) To UBound(t)
t(i) = SwapPairsDecoding(CStr(t(i)))
Next
'remove "X"
For i = LBound(t) To e
If Right(t(i), 1) = "X" And Left(t(i), 1) = Left(t(i + 1), 1) Then
t(i) = Left(t(i), 1) & Left(t(i + 1), 1)
For j = i + 1 To UBound(t) - 1
t(j) = Right(t(j), 1) & Left(t(j + 1), 1)
Next j
If Right(t(j), 1) = "X" Then
ReDim Preserve t(j - 1)
Else
t(j) = Right(t(j), 1) & "X"
End If
ElseIf Left(t(i + 1), 1) = "X" And Right(t(i), 1) = Right(t(i + 1), 1) Then
For j = i + 1 To UBound(t) - 1
t(j) = Right(t(j), 1) & Left(t(j + 1), 1)
Next j
If Right(t(j), 1) = "X" Then
ReDim Preserve t(j - 1)
Else
t(j) = Right(t(j), 1) & "X"
End If
End If
Next
Decode = Join(t, " ")
End Function
Private Function SwapPairsDecoding(s As String) As String
Dim r As Integer, c As Integer, d1 As String, d2 As String, Flag As Boolean
Dim addD1 As Adress, addD2 As Adress, resD1 As Adress, resD2 As Adress
d1 = Left(s, 1): d2 = Right(s, 1)
For r = 1 To 5
For c = 1 To 5
If d1 = myTable(r, c) Then addD1.Row = r: addD1.Column = c
If d2 = myTable(r, c) Then addD2.Row = r: addD2.Column = c
If addD1.Row <> 0 And addD2.Row <> 0 Then Flag = True: Exit For
Next
If Flag Then Exit For
Next
Select Case True
Case addD1.Row = addD2.Row And addD1.Column <> addD2.Column
'same row, different columns
resD1.Column = IIf(addD1.Column - 1 = 0, 5, addD1.Column - 1)
resD2.Column = IIf(addD2.Column - 1 = 0, 5, addD2.Column - 1)
SwapPairsDecoding = myTable(addD1.Row, resD1.Column) & myTable(addD2.Row, resD2.Column)
Case addD1.Row <> addD2.Row And addD1.Column = addD2.Column
'same columns, different rows
resD1.Row = IIf(addD1.Row - 1 = 0, 5, addD1.Row - 1)
resD2.Row = IIf(addD2.Row - 1 = 0, 5, addD2.Row - 1)
SwapPairsDecoding = myTable(resD1.Row, addD1.Column) & myTable(resD2.Row, addD2.Column)
Case addD1.Row <> addD2.Row And addD1.Column <> addD2.Column
'different rows, different columns
resD1.Row = addD1.Row
resD2.Row = addD2.Row
resD1.Column = addD2.Column
resD2.Column = addD1.Column
SwapPairsDecoding = myTable(resD1.Row, resD1.Column) & myTable(resD2.Row, resD2.Column)
End Select
End Function</lang>
{{out}}
<pre>Enter your keyword : Playfair example
Ignore Q when buiding table y/n : N
Table :
P L A Y F
I R E X M
B C D G H
K N O Q S
T U V W Z
Text to encode : hide the gold in the TRRE stump
-------------------------------------------------
[the pairs : HI DE TH EG OL DI NT HE TR XR ES TU MP]
Encoded text is : BM OD ZB XD NA BE KU DM UI ME MO UV IF
Decoded text is : HI DE TH EG OL DI NT HE TR RE ST UM PX
Text to encode : hide the gold in the TREE stump
-------------------------------------------------
[the pairs : HI DE TH EG OL DI NT HE TR EX ES TU MP]
Encoded text is : BM OD ZB XD NA BE KU DM UI XM MO UV IF
Decoded text is : HI DE TH EG OL DI NT HE TR EE ST UM PX</pre>
=={{header|zkl}}==
| |||