353 lines
14 KiB
Fortran
353 lines
14 KiB
Fortran
!
|
|
! Playfer Cipher
|
|
! tested with Intel ifx (IFX) 2025.2.1 20250806 on Kubuntu 25.10
|
|
! GNU Fortran (Ubuntu 15.2.0-4ubuntu4) 15.2.0 on Kubuntu 25.10
|
|
! VSI Fortran x86-64 V8.6-001 on OpenVMS x86_64 V9.2-3
|
|
!
|
|
! U.B., October 2025
|
|
!==============================================================================
|
|
|
|
program PlayferCipher
|
|
|
|
implicit none
|
|
|
|
integer, parameter :: nTests = 2 ! Number of different test messages
|
|
integer, parameter :: maxLen=100 ! Maximum length of any test message (including extensions as 'X')
|
|
|
|
! The complete alphabet of capital letters as used in most western languages
|
|
character (len=*), parameter :: Alphabet ='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
|
|
|
|
character (len=maxLen) :: MsgToEncrypt (nTests), EncryptedMsg, DecryptedMsg
|
|
logical :: Omit_Q ! True: omit Q in alphabet, False: use I for both I and J
|
|
character (len=25) :: PassPhrase(nTests)
|
|
|
|
integer, parameter :: ColWidth =5 ! depends on length of the used alphabet but we use only 25 letters
|
|
|
|
integer :: i
|
|
|
|
! The message to encrypt - for 1 test case
|
|
! the additional message as presented in the task description
|
|
MsgToEncrypt(1) = 'Hide the gold ... in the tree stump!!!'
|
|
PassPhrase(1) = 'playfair example'
|
|
|
|
MsgToEncrypt(2) = 'This is another simple test message.'
|
|
PassPhrase(2) = 'This is top secret'
|
|
|
|
do i=1, nTests
|
|
Omit_Q = (i .ne. 1) ! to see both variants: dont use Q or convert J to I
|
|
call encode (MsgToEncrypt(i) , EncryptedMsg, Alphabet, Omit_Q, PassPhrase(i))
|
|
call decode (EncryptedMsg, DecryptedMsg, Alphabet, Omit_Q, PassPhrase(i))
|
|
call printResult (MsgToEncrypt(i), EncryptedMsg, DecryptedMsg)
|
|
enddo
|
|
|
|
|
|
contains
|
|
|
|
! =======================================================================
|
|
! 2 Jacket routines for encode and decode - they end up in the same crypt
|
|
! routine with an additional argument for the direction
|
|
! =======================================================================
|
|
subroutine encode (argInString, outString, argAlphabet, argOmit_Q, argPassPhrase)
|
|
character (len=*), intent(in) :: argInString
|
|
character (len=*), intent(out) :: outString
|
|
character (len=*), intent(in) :: argAlphabet
|
|
logical, intent(in) :: argOmit_Q
|
|
character (len=*), intent(in) :: argPassPhrase
|
|
|
|
call crypt (argInString, outString, argAlphabet, argOmit_Q, argPassPhrase, 1)
|
|
|
|
end subroutine encode
|
|
|
|
subroutine decode (argInString, outString, argAlphabet, argOmit_Q, argPassPhrase)
|
|
character (len=*), intent(in) :: argInString
|
|
character (len=*), intent(out) :: outString
|
|
character (len=*), intent(in) :: argAlphabet
|
|
logical, intent(in) :: argOmit_Q
|
|
character (len=*), intent(in) :: argPassPhrase
|
|
|
|
call crypt (argInString, outString, argAlphabet, argOmit_Q, argPassPhrase, -1)
|
|
|
|
end subroutine decode
|
|
|
|
|
|
!=========================================================================
|
|
! Encode or decode a given string. Direction is 1 to encode, -1 to decode.
|
|
! ========================================================================
|
|
subroutine crypt (argInString, outString, argAlphabet, argOmit_Q, argPassPhrase, direction)
|
|
|
|
character (len=*), intent(in) :: argInString
|
|
character (len=*), intent(out) :: outString
|
|
character (len=*), intent(in) :: argAlphabet
|
|
logical, intent(in) :: argOmit_Q
|
|
character (len=*), intent(in) :: argPassPhrase
|
|
integer , intent(in) :: direction
|
|
|
|
character (len=100) :: LocalAlphabet
|
|
character (len=MaxLen) :: inString
|
|
|
|
integer :: idxLine(2*maxLen)
|
|
integer :: l, ii, idx, jdx, row, col
|
|
|
|
inString = argInString ! have a mutable copy or intent(in) argument
|
|
outString = ' '
|
|
|
|
call changeAllToUpcase (inString)
|
|
|
|
call setupAlphabet (argAlphabet, LocalAlphabet, argOmit_Q, argPassPhrase)
|
|
if (direction .eq. 1) call PrintSquare (LocalAlphabet) ! when encoding, show the Polybius square
|
|
if (.not. argOmit_Q) then
|
|
call FixJ_I (inString) ! Replace all J by I.
|
|
endif
|
|
|
|
l = len_trim (inString)
|
|
if (l .gt. len(outString)) stop 'ERROR: not enough storage space for encrypt result string.'
|
|
|
|
! En/Decode every group of two characters
|
|
idx = 1
|
|
jdx = 1
|
|
do while (idx .le. l)
|
|
if (idx .lt. l) then
|
|
if (inString (idx:idx) .ne. inString (idx+1:idx+1)) then
|
|
outString(jdx:jdx+1) = decode2Group (inString (idx:idx),inString (idx+1:idx+1), LocalAlphabet, direction)
|
|
idx = idx + 2
|
|
jdx = jdx+2
|
|
else
|
|
outString(jdx:jdx+1) = decode2Group (inString (idx:idx), 'X', LocalAlphabet, direction)
|
|
idx = idx + 1
|
|
jdx = jdx+2
|
|
endif
|
|
else if (idx .eq. l) then
|
|
outString(jdx:jdx+1) = decode2Group (inString (idx:idx), 'X', LocalAlphabet, direction)
|
|
idx = idx + 1
|
|
jdx = jdx+2
|
|
end if
|
|
end do
|
|
|
|
end subroutine crypt
|
|
|
|
! =======================================
|
|
! Modify input string, replace all J by I
|
|
! =======================================
|
|
subroutine FixJ_I (inString)
|
|
character (len=*), intent(inout) :: inString
|
|
integer :: l, ii
|
|
l = len_trim (inString)
|
|
do ii=1,l
|
|
if (inString (ii:ii) .eq. 'J') inString (ii:ii) = 'I'
|
|
enddo
|
|
end subroutine FixJ_I
|
|
|
|
! ================================================================================
|
|
! Encode or Decode a group of 2 letters according to the rules for Playfair Cipher
|
|
! ================================================================================
|
|
function decode2Group (ch1, ch2, argAlphabet, direction) result (res)
|
|
character, intent(in) :: ch1, ch2 ! 2 characters to decode
|
|
character (len=*), intent(in) :: argAlphabet ! Argument to use for encoding
|
|
integer, intent(in) :: direction ! 1 for encode, -1 for decode
|
|
character (len=2) :: res ! resultant group of 2 chars
|
|
|
|
integer :: r1,r2,c1,c2 ! row, col of ch1 and ch2
|
|
integer :: idx
|
|
|
|
call getRC (ch1,r1,c1,argAlphabet)
|
|
call getRC (ch2,r2,c2,argAlphabet)
|
|
|
|
if (r1 .ne. r2 .and. c1 .ne. c2) then ! c1 and c2 form a rectangle
|
|
res(1:1) = getChar (r1,c2,argAlphabet) ! Same rows, opposite corner
|
|
res(2:2) = getChar (r2,c1,argAlphabet)
|
|
else if (r1 .eq. r2 .and. c1 .ne. c2) then ! c1 and c2 in horizontal line
|
|
! pick item to right (left) of each, wrap if required
|
|
c1 = c1 + direction ! Easier to read...
|
|
if (c1 .gt. ColWidth) c1 = 1 ! than a fancy formula...
|
|
if (c1 .lt. 1) c1 = ColWidth ! with modulus and offset
|
|
c2 = c2 + direction
|
|
if (c2 .gt. ColWidth) c2 = 1
|
|
if (c2 .lt. 1) c2 = ColWidth
|
|
res(1:1)=getChar (r1,c1,argAlphabet)
|
|
res(2:2)=getChar (r2,c2,argAlphabet)
|
|
else if (c1 .eq. c2 .and. r1 .ne. r2) then ! c1 and c2 in vertical line
|
|
! pick item to below (above) each, wrap if required
|
|
r1 = r1 + direction
|
|
r2 = r2 + direction
|
|
if (r1 .gt. ColWidth) r1 = 1
|
|
if (r1 .lt. 1) r1 = ColWidth
|
|
if (r2 .gt. ColWidth) r2 = 1
|
|
if (r2 .lt. 1) r2 = ColWidth
|
|
res(1:1) = getChar (r1,c1,argAlphabet)
|
|
res(2:2) = getChar (r2,c1,argAlphabet)
|
|
else
|
|
! should be impossible: c1 .eq. c2
|
|
stop 'duplicate letter in group of 2 letters: BUG CHECK'
|
|
endif
|
|
end function decode2Group
|
|
|
|
! ======================================================
|
|
! Get Row and Column of a letter in the Polybius square
|
|
! ======================================================
|
|
subroutine getRC (c,row,col, argAlphabet)
|
|
character, intent(in) :: c
|
|
integer, intent(out) :: row,col
|
|
character (len=*), intent(in) :: argAlphabet ! Argument to use for encoding
|
|
integer :: idx
|
|
|
|
idx = index (argAlphabet, c) - 1
|
|
|
|
row = 1 + idx / ColWidth
|
|
col = 1 + mod (idx, ColWidth)
|
|
|
|
end subroutine getRC
|
|
|
|
! ==================================================
|
|
! Return letter in row column of the Polybius square
|
|
! ==================================================
|
|
function getChar (row,column,argAlphabet) result (chr)
|
|
integer, intent(in) :: row, column
|
|
character (len=*), intent(in) :: argAlphabet ! Argument to use for encoding
|
|
character :: chr
|
|
integer :: idx
|
|
|
|
idx = (row-1) * ColWidth + column
|
|
chr = argAlphabet (idx:idx)
|
|
|
|
end function getChar
|
|
|
|
|
|
! ===============================================================================
|
|
! Modify string: convert lower case to upper case, skip whitespace or punctuation
|
|
! ===============================================================================
|
|
subroutine changeAllToUpcase (str)
|
|
character (len=*), intent(inout) :: str
|
|
integer :: ii, jj, l
|
|
|
|
l = len_trim (str)
|
|
jj = 1
|
|
ii = 1
|
|
do while (ii .le. l)
|
|
if (str(ii:ii) .ge. 'a' .and. str(ii:ii) .le. 'z') then
|
|
! lower case -> upper case
|
|
str(ii:ii) = char (ichar(str(ii:ii)) - ichar('a') + ichar('A'))
|
|
else if (str(ii:ii) .ge. 'A' .and. str(ii:ii) .le. 'Z') then
|
|
! Upper case: OK, nothing to do
|
|
else
|
|
! Anything else: ignore, and do not use
|
|
str = str (:ii-1) // str (ii+1:) ! Skip the space
|
|
l = l - 1 ! reduce total length
|
|
cycle ! without increment index ii.
|
|
endif
|
|
ii = ii + 1
|
|
end do
|
|
end subroutine changeAllToUpcase
|
|
|
|
|
|
! ===========================================================================
|
|
! Prepare the Alphabet to use: it is the pass phrase, followed by the normal
|
|
! upper case alphabet, always avoiding duplicate letters
|
|
! ===========================================================================
|
|
subroutine setupAlphabet (argAlphabet, ResultAlphabet, argOmit_Q, argPassPhrase)
|
|
|
|
character (len=*), intent(in) :: argAlphabet
|
|
character (len=*), intent(out) :: ResultAlphabet
|
|
logical, intent(in) :: argOmit_Q ! True: ompit Q in alphabet, , False: use I for both I and J
|
|
character (len=*), intent(in) :: argPassPhrase
|
|
integer :: ii, jj, l
|
|
character :: cWork
|
|
|
|
ResultAlphabet = ' ' ! Initialize result string
|
|
call appendString (ResultAlphabet, argPassPhrase, argOmit_Q) ! First use passprase
|
|
call appendString (ResultAlphabet, argAlphabet, argOmit_Q) ! and then use remaining letters from alphabet
|
|
|
|
end subroutine setupAlphabet
|
|
|
|
|
|
! ==================================================================================
|
|
! Append a string to an existing (possibly empty) string, avoiding duplicate letters
|
|
! ==================================================================================
|
|
subroutine appendString (ResultAlphabet, stringToAppend, argOmit_Q)
|
|
|
|
character (len=*), intent(inout) :: ResultAlphabet
|
|
logical, intent(in) :: argOmit_Q ! True: omit Q in alphabet, , False: use I for both I and J
|
|
character (len=*), intent(in) :: stringToAppend
|
|
integer :: ii,jj,l
|
|
character :: cWork
|
|
|
|
jj = len_trim(ResultAlphabet) + 1 ! here we start appending letters
|
|
l = len_trim (stringToAppend) ! count letters to add
|
|
do ii = 1, l
|
|
if (jj .gt. l) exit ! Do not exceed resultant length
|
|
cWork = stringToAppend (ii:ii)
|
|
|
|
! First make sure it's all in UPPER CASE.
|
|
if (cWork .ge. 'a' .and. cWork .le. 'z') then ! lower case letter?
|
|
cWork = char (ichar(cWork) -ichar('a') + ichar('A'))
|
|
endif
|
|
|
|
! Now cWork is either in upper case or it is invalid (i.e. not in alphabet)
|
|
if (cWork .ge. 'A' .and. cWork .le. 'Z') then ! Valid?
|
|
if (argOmit_Q) then ! Q is not part of the valid applicable alphabet
|
|
if (cWork .eq. 'Q') cycle ! skip Q but conserve both I and J
|
|
else
|
|
! dont omit Q, so use 'I' for both 'I' and 'J'
|
|
if (cWork .eq. 'J') cWork = 'I'
|
|
endif
|
|
|
|
if (jj .eq. 1) then
|
|
! filling very first letter of result alphabet
|
|
ResultAlphabet (jj:jj) = cWork
|
|
jj = jj + 1
|
|
else if (index (ResultAlphabet (:jj), cWork) .eq. 0) then
|
|
! current work letter not yet contained in alphabet
|
|
ResultAlphabet (jj:jj) = cWork
|
|
jj = jj + 1
|
|
else
|
|
! Nothing, just skip letters that are already known in result alphabet.
|
|
endif
|
|
else
|
|
! Nothing, just skip characters other than [A...Z]
|
|
endif
|
|
end do
|
|
|
|
end subroutine appendString
|
|
|
|
! ===========================================
|
|
! Print original, encoded and decoded strings
|
|
! ===========================================
|
|
subroutine printResult (m1,m2,m3)
|
|
character (len=*), intent(in) :: m1,m2,m3
|
|
write (*,'("Original: ", A)') m1 ! original string unmodified
|
|
call print1 (' Encoded: ', m2) ! result of encode or decode:
|
|
call print1 (' Decoded: ', m3) ! print all groups of 2 letters
|
|
print *
|
|
end subroutine printResult
|
|
|
|
! ===================================================================
|
|
! separate input string into groups of 2 letters and print all groups
|
|
! ===================================================================
|
|
subroutine print1 (comment, m)
|
|
character (len=*), intent(in) :: comment, m
|
|
integer :: ii
|
|
write (*, '(A, X)', advance='no') comment
|
|
do ii=1, len_trim (m)-1,2
|
|
write (*, '(A2,x)', advance = 'no') m(ii:ii+1)
|
|
end do
|
|
print *
|
|
end subroutine print1
|
|
|
|
! ================================================================================
|
|
! Print the resulting Polybius square based on the alphabet used for encode/decode
|
|
! ================================================================================
|
|
subroutine PrintSquare (Alphabet)
|
|
character (len=*), intent(in) :: Alphabet
|
|
integer:: ii, l
|
|
|
|
l = len_trim(alphabet)
|
|
write (*,'(/,"Using this Polybius square for encode/decode:",/)')
|
|
|
|
do ii=1, ColWidth*ColWidth
|
|
write (*, '(A2)', advance='no') Alphabet(ii:ii)
|
|
if (mod (ii, ColWidth) .eq. 0) print * ! End of line
|
|
end do
|
|
print * ! one extra blank line
|
|
end subroutine PrintSquare
|
|
|
|
|
|
end program PlayferCipher
|