Data update
This commit is contained in:
Ingy döt Net
parent
4bb20c9b71
commit
cbaf4c4b64
12390 changed files with 318560 additions and 27248 deletions
102
Task/Playfair-cipher/EasyLang/playfair-cipher.easy
Normal file
102
Task/Playfair-cipher/EasyLang/playfair-cipher.easy
Normal file
|
|
@ -0,0 +1,102 @@
|
|||
len pos[] 26
|
||||
len tbl$[] 25
|
||||
global iforj .
|
||||
proc inittbl key$ ifj .
|
||||
iforj = ifj
|
||||
for c$ in strchars key$
|
||||
c = strcode c$
|
||||
if c >= 97 : c -= 32
|
||||
if c >= 65 and c <= 90 : alph$ &= strchar c
|
||||
.
|
||||
for i to 26
|
||||
pos[i] = -1
|
||||
c$ = strchar (i + 64)
|
||||
if c$ <> "J" and c$ <> "Q"
|
||||
alph$ &= c$
|
||||
elif c$ = "J" and ifj = 0
|
||||
alph$ &= c$
|
||||
elif c$ = "Q" and ifj = 1
|
||||
alph$ &= c$
|
||||
.
|
||||
.
|
||||
k = 1
|
||||
for ch$ in strchars alph$
|
||||
ch = strcode ch$ - 64
|
||||
if pos[ch] = -1
|
||||
tbl$[k] = ch$
|
||||
pos[ch] = k - 1
|
||||
k += 1
|
||||
.
|
||||
.
|
||||
.
|
||||
func$ codec txt$ dir .
|
||||
txt$[] = strchars txt$
|
||||
for i = 1 step 2 to len txt$
|
||||
ch1 = strcode txt$[i] - 64
|
||||
ch2 = strcode txt$[i + 1] - 64
|
||||
col1 = pos[ch1] mod 5
|
||||
row1 = pos[ch1] div 5
|
||||
col2 = pos[ch2] mod 5
|
||||
row2 = pos[ch2] div 5
|
||||
if row1 = row2
|
||||
col1 = (col1 + dir) mod 5
|
||||
col2 = (col2 + dir) mod 5
|
||||
elif col1 = col2
|
||||
row1 = (row1 + dir) mod 5
|
||||
row2 = (row2 + dir) mod 5
|
||||
else
|
||||
swap col1 col2
|
||||
.
|
||||
r$ &= tbl$[row1 * 5 + col1 + 1]
|
||||
r$ &= tbl$[row2 * 5 + col2 + 1]
|
||||
.
|
||||
return r$
|
||||
.
|
||||
func$ preptxt txt$ .
|
||||
for c$ in strchars txt$
|
||||
c = strcode c$
|
||||
if c >= 97 : c -= 32
|
||||
if c >= 65 and c <= 90
|
||||
c$ = strchar c
|
||||
if c$ = "J" and iforj = 1 : c$ = "I"
|
||||
if c$ = "Q" and iforj = 0 : c$ = ""
|
||||
txt$[] &= c$
|
||||
.
|
||||
.
|
||||
i = 1
|
||||
while i <= len txt$[]
|
||||
cur$ = txt$[i]
|
||||
i += 1
|
||||
if i <= len txt$[]
|
||||
nxt$ = txt$[i]
|
||||
else
|
||||
nxt$ = "X"
|
||||
.
|
||||
r$ &= cur$
|
||||
if nxt$ = cur$
|
||||
r$ &= "X"
|
||||
else
|
||||
r$ &= nxt$
|
||||
i += 1
|
||||
.
|
||||
.
|
||||
return r$
|
||||
.
|
||||
func$ encode txt$ .
|
||||
return codec preptxt txt$ 1
|
||||
.
|
||||
func$ decode txt$ .
|
||||
return codec txt$ 4
|
||||
.
|
||||
func$ digraph s$ .
|
||||
for c$ in strchars s$
|
||||
r$ &= c$
|
||||
cnt += 1
|
||||
if cnt mod 2 = 0 : r$ &= " "
|
||||
.
|
||||
return r$
|
||||
.
|
||||
inittbl "Playfair example" 1
|
||||
enc$ = encode "Hide the gold in...the TREESTUMP!!"
|
||||
print digraph enc$
|
||||
print digraph decode enc$
|
||||
353
Task/Playfair-cipher/Fortran/playfair-cipher.f
Normal file
353
Task/Playfair-cipher/Fortran/playfair-cipher.f
Normal file
|
|
@ -0,0 +1,353 @@
|
|||
!
|
||||
! 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
|
||||
Loading…
Add table
Add a link
Reference in a new issue