经典密码工具箱:凯撒，维根雷和ADFGVX密码

Question

我用Haskell编写了一个程序，目的是让用户在haskell中对前机电时代的密码进行加密、解密和破解/密码分析。我想知道你对它的看法，因为这是我的第一个Haskell项目，所以我的方法与我在其他语言上的方法略有不同。

它目前支持凯撒，Vigenere和ADFGVX密码，让用户破解前两个。它还允许用户执行一些密码分析方法，如计数字母/子串频率和替换字母，直到用户对结果满意为止。

我的代码有很多在顶层定义的函数，所以我开始担心是否应该在本地定义其中的一些函数。我也有点担心我的函数的类型，因为它们中的一些可能会更一般化。

请记住，Vigenere破解和ADFGVX实现还有一些工作要做。至于Vigenere破解，用户必须手动输入要搜索的密文上重复的单词的最小和最大大小(Kasiski算法)，ADFGVX加密和解密仍然不能100%工作，因为我正在用字母'a‘填充密文，直到它完全符合网格。

我将向您展示从CLI开始的所有模块(因为它是主要的方法)。

import Control.Monad
import System.Exit
import System.IO
import MyUtils
import Ciphers.Caesar
import Ciphers.Vigenere
import Ciphers.ADFGVX
import Codebreaking.Cryptanalysis
import Codebreaking.VigenereCrack

caesarEncryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Enter the shift number:"
  shift <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let shift_int = (read shift :: Int) --convert input to int
  let ciphertext = caesarShift shift_int message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Ciphertext:"
  print (ciphertext)
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input <- getLine
  main

vigenereEncryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Enter the desired keyword:"
  key <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let ciphertext = vigenereEncrypt key message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn ("Ciphertext:")
  print (ciphertext)
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input <- getLine
  main

adfgvxEncryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "The program will now read the substitution key from my_grid.txt."
  putStrLn "Do you want to change it (y/n)?"
  input1 <- getLine
  when (input1 == "y") (do createSubstitutionKey; putStrLn "Substitution key created.")
  handle <- openFile "my_grid.txt" ReadMode
  substitution_key <- hGetContents handle
  putStrLn "Enter the desired keyword:"
  key <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let ciphertext = adfgvxEncrypt substitution_key key message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn ("Ciphertext:")
  print (ciphertext)
  putStrLn "\nDon't forget to share the substitution key with the recipient"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input2 <- getLine
  main

caesar_decryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Enter the shift number:"
  shift <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let shift_int = (read shift :: Int) --convert input to int
  let plaintext = caesarShift (-shift_int) message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Plaintext:"
  print (plaintext)
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input <- getLine
  main

vigenereDecryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Enter the keyword:"
  key <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let plaintext = vigenereDecrypt key message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn ("Plaintext:")
  print (plaintext)
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input <- getLine
  main

adfgvxDecryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "The program will now read the substitution key from my_grid.txt."
  handle <- openFile "my_grid.txt" ReadMode
  substitution_key <- hGetContents handle
  putStrLn "Enter the keyword:"
  key <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let plaintext = adfgvxDecrypt substitution_key key message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn ("Plaintext:")
  print (plaintext)
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input <- getLine
  main

decryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::1 - Caesar's cipher                                                          ::"
  putStrLn "::2 - Vigenere's cipher                                                        ::"
  putStrLn "::3 - ADFGVX                                                                   ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::r - Return   e - Exit                                                        ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  input <- getLine
  case input of
    "1" -> caesar_decryption
    "2" -> vigenereDecryption
    "3" -> adfgvxDecryption
    "r" -> main
    "e" -> exitSuccess
    otherwise -> do
      putStrLn ""
      putStrLn ("Please enter a valid option")
      encryption

encryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::1 - Caesar's cipher                                                          ::"
  putStrLn "::2 - Vigenere's cipher                                                        ::"
  putStrLn "::3 - ADFGVX                                                                   ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::r - Return   e - Exit                                                        ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  input <- getLine
  case input of
    "1" -> caesarEncryption
    "2" -> vigenereEncryption
    "3" -> adfgvxEncryption
    "r" -> main
    "e" -> exitSuccess
    otherwise -> do
      putStrLn ""
      putStrLn ("Please enter a valid option")
      encryption

tools :: String -> String -> IO()
tools ciphertext guess = forever $ do
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Ciphertext:"
  print (ciphertext)
  putStrLn ""
  putStrLn "My guess:"
  print (guess)
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::0 - Display the letter frequency in descending order                         ::"
  putStrLn "::1 - Break Caesar's cipher                                                    ::"
  putStrLn "::2 - Break Vigenere's cipher (Babbage/Kasiski Algorithm)                      ::"
  putStrLn "::3 - Get repeated substrings                                                  ::"
  putStrLn "::4 - Count the occurrences of a substring                                     ::"
  putStrLn "::5 - Count the occurrences of a letter immediately before/after other letters ::"
  putStrLn "::6 - Count the occurrences of a letter immediately before other letters       ::"
  putStrLn "::7 - Count the occurrences of a letter immediately after other letters        ::"
  putStrLn "::8 - Substitute a letter by another in the ciphertext                         ::"
  putStrLn "::r - Return                                                                   ::"
  putStrLn "::e - Exit                                                                     ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  input <- getLine
  case input of
    "0" -> do
      putStrLn ""
      putStrLn "Letter frequency:"
      print (sortAlphabetCount ciphertext)
      putStrLn ""
    "1" -> do
      putStrLn ""
      print(breakCaesar ciphertext)
      putStrLn ""
    "2" -> do
      putStrLn ""
      putStrLn "For this tool to work it is necessary to find some substrings that have multiple occurrences along the ciphertext."
      crackVigenere ciphertext
    "3" -> do
      putStrLn ""
      putStrLn "Enter the minimum size of the substrings to be searched for:"
      min_size <- getLine
      putStrLn "Enter the maximum size of the substrings to be searched for:"
      max_size <- getLine
      let min_size_int = (read min_size :: Int)
          max_size_int = (read max_size :: Int)
      putStrLn "Repeated substrings:"
      print (repeatedSubs min_size_int max_size_int ciphertext)
    "4" -> do
      putStrLn ""
      putStrLn "Enter the substring:"
      substring <- getLine
      putStrLn "Occurrences:"
      print(countSubstring substring ciphertext)
      putStrLn ""
    "5" -> do
      putStrLn ""
      putStrLn "Enter the letter(between ''):"
      letter <- getLine
      let letter_char = (read letter :: Char)
      putStrLn "Occurrences:"
      print(countAllNeighbours letter_char ciphertext)
      putStrLn ""
    "6" -> do
      putStrLn ""
      putStrLn "Enter the letter(between ''):"
      letter <- getLine
      let letter_char = (read letter :: Char)
      putStrLn "Occurrences:"
      print(countAllBefore letter_char ciphertext)
      putStrLn ""
    "7" -> do
      putStrLn ""
      putStrLn "Enter the letter(between ''):"
      letter <- getLine
      let letter_char = (read letter :: Char)
      putStrLn "Occurrences:"
      print(countAllAfter letter_char ciphertext)
      putStrLn ""
    "8" -> do
      putStrLn ""
      putStrLn "Enter the letter(between '') you wish to substitute:"
      letter1 <- getLine
      let letter1_char = (read letter1 :: Char)
      putStrLn "Enter the letter(beween '') to substitute by:"
      letter2 <- getLine
      let letter2_char = (read letter2 :: Char)
          new_ciphertext = substitute letter1_char letter2_char guess
      putStrLn "New ciphertext:"
      print(new_ciphertext)
      tools ciphertext new_ciphertext
    "r" -> main
    "e" -> exitSuccess
    otherwise -> do
      putStrLn ""
      putStrLn ("Please enter a valid option")
      tools ciphertext guess

crack = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Enter the message:"
  ciphertext <- getLine
  tools ciphertext ciphertext

main = forever $ do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::  /$#qcStackCode#           /#qcStackCode#$#qcStackCode#       /$#qcStackCode#$#qcStackCode#                                  ::"
  putStrLn ":: /__  #qcStackCode#         /__  #qcStackCode#     |__  __/                                  ::"
  putStrLn "::| #qcStackCode#  __/ / /#qcStackCode# |   __/  /#qcStackCode# /| #qcStackCode#                                     ::"
  putStrLn "::|       |__/|__/| #qcStackCode#      |__/|__/|                                      ::"
  putStrLn "::| #qcStackCode#              |               | #qcStackCode#                                     ::"
  putStrLn "::|     #qcStackCode# / /#qcStackCode#|     #qcStackCode# / /#qcStackCode#|                                      ::"
  putStrLn "::|  #qcStackCode#$#qcStackCode#/|__/|__/|  $#qcStackCode#/|__/|__/| #qcStackCode#                                     ::"
  putStrLn ":: |______/           |______/         |__/                                    ::"
  putStrLn "::::::::Classic Cryptography Toolbox:::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::                                                                             ::"
  putStrLn "::What would you like to do?                                                   ::"
  putStrLn "::                                                                             ::"
  putStrLn "::1 - Encrypt a message                                                        ::"
  putStrLn "::2 - Decrypt a message                                                        ::"
  putStrLn "::3 - Cryptanalyse an encrypted message                                        ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::e - Exit                                                                     ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  input <- getLine
  case input of
    "1" -> encryption
    "2" -> decryption
    "3" -> crack
    "e" -> exitSuccess
    otherwise -> do
      putStrLn ""
      putStrLn ("Please enter a valid option")
      main

<#>MyUtils.hs

module MyUtils where

import Data.Char
import Data.List
import System.Console.ANSI
import System.Random

--lowercase letter to int conversion
let2int :: Char -> Int
let2int c = ord c - ord 'a'

--int to lowercase letter conversion
int2let :: Int -> Char
int2let n = chr(ord 'a' + n)

--converts an entire string an array of ints (each char -> int)
text2ints :: String -> [Int]
text2ints xs = map (let2int) xs

--convrets an array of ints into a string (each int -> char)
ints2text :: [Int] -> String
ints2text xs = map (int2let) xs

--shifts the given lowercase letter n positions
shift :: Int -> Char -> Char
shift n c |isLower c = int2let((let2int c + n) `mod` 26)
          |otherwise = c

--gets the factors of n
factors :: Int -> [Int]
factors n = [x |x<-[2..n], n`mod`x == 0]

--deletes all occurrences of an element within a list
deleteAll :: Eq a => a -> [a] -> [a]
deleteAll x s = filter (/=x) s

--gives a list of all the elements that have multiple occurrences within a list
equals :: Eq a => [a] -> [a]
equals [] = []
equals (x:xs)
  |elem x xs = x : equals (deleteAll x xs)
  |otherwise = equals xs

--gives a list of all the elements that are common to all the lists within a list of lists
commonElems :: Eq a => [[a]] -> [a]
commonElems l = equals [x | y<-l, x<-y, length (filter (elem x) l) == length l]

--gives a list of all the factors in common to all the integers in a list
commonFactors :: [Int] -> [Int]
commonFactors xs
  |length xs == 1 = factors (head (xs))
  |otherwise = commonElems [factors x | x<-xs]

--gives a list of the indexes of each occurrence of a substring within a string
matchIndices :: (Eq a, Num b, Enum b) => [a] -> [a] -> [b]
matchIndices needle = map fst . filter (isPrefixOf needle . snd) . zip [0..] . tails

--gives a list of the lengths between each consecutive occurrences of a substring within a string
spaceBetween :: String -> String -> [Int]
spaceBetween needle = diffs . matchIndices needle -- calculates the difference between each consecutive index
  where diffs xs = zipWith (flip(-)) xs (tail xs)

--count the space between the first occurrence of a subtring and the next occurrence within a string
repeatSpacing :: String -> String -> Int
repeatSpacing substring ciphertext
  |spaceBetween substring ciphertext == [] = 0
  |otherwise = head (spaceBetween (substring) (ciphertext))

--gives a list of the lengths between the first occurrence of multiple substrings and the next respective occurrence
multRepeatSpacing :: [String] -> String -> [Int]
multRepeatSpacing substrings ciphertext = [y | x<-substrings, y<-[repeatSpacing x ciphertext]]

--gets all chars n chars away from each other
getSpacedLetters :: Int -> String -> String
getSpacedLetters n (x:xs)
  |n > length xs = [x]
  |otherwise = x : getSpacedLetters n (drop (n-1) xs)

--gets all chars "size" chars away from each other starting from the nth position
getNthSpacedLetters :: Int -> Int -> String -> String
getNthSpacedLetters size n s
  |n > length s = ""
  |otherwise = getSpacedLetters size (drop (n-1) s)

--removes all tuples with x as fst
removeAllTuplesByInt :: Int -> [(a,Int)] -> [(a,Int)]
removeAllTuplesByInt x [] = []
removeAllTuplesByInt x list
  |snd (head list) /= x = head list : removeAllTuplesByInt x (tail list)
  |otherwise = removeAllTuplesByInt x (tail list)

--gets the index of a char in a dictionary of type [(Char,Integer)]
getDictIndex :: Eq a => a -> [(a,Integer)] -> Integer
getDictIndex c [key]
  |c == fst key = snd key
  |otherwise = error "no such element"
getDictIndex c dict
  |c == fst (head dict) = snd (head dict)
  |otherwise = getDictIndex c (tail dict)

--gives a list of the elements in a list withou repeating them
delRepeated :: Eq a => [a] -> [a]
delRepeated [] = []
delRepeated list = x : delRepeated (deleteAll x (tail list))
  where x = head list

--clears the terminal and sets the cursor position to 0 0
clearAll :: IO()
clearAll = do
  clearScreen
  setCursorPosition 0 0

--converts something of type a into the corresponding value of type b in a dictionary of the type [(b,a)]
convertTo :: Eq a => a -> [(b,a)]-> b
convertTo x [] = error ("int not found in the dict")
convertTo x dict
  |x == (snd (head dict)) = fst (head dict)
  |otherwise = convertTo x (tail dict)

convertFrom :: Eq a => a -> [(a,b)] -> b
convertFrom x [] = error ("not found in the dict")
convertFrom x dict
  |x == (fst (head dict)) = snd (head dict)
  |otherwise = convertFrom x (tail dict)

--converts an entire list into the corresponding dictionary values
toDictValue :: Eq a => [a] -> [(b,a)] -> [b]
toDictValue ns dict = map (\x -> convertTo x dict) ns

--generates a list of different random integers from n1 to n2 of size n2
genRandNrs :: Integer -> Integer -> IO([Integer])
genRandNrs n1 n2 = do
  g <- newStdGen
  return (take (fromIntegral n2) (nub (randomRs (n1,n2) g :: [Integer])))

--groups the given list in a list of lists in, n by n
groupN:: Int -> [a] -> [[a]]
groupN 0 _ = []
groupN size [] = []
groupN size s = (take (size) s) : groupN size (drop size s)

密码分析.

module Codebreaking.Cryptanalysis where

import Data.Char
import Data.List
import Data.Function
import MyUtils

alphabet = "abcdefghijklmnopqrstuvwxyz"

--most to least frequent letters in english with respective index
etaoin = zip "etaoinshrdlcumwfgypbvkjxqz" [1..]

en_letter_most_freq = "etaoin" --most frequent english letters
en_letter_least_freq = "vkjxqz" --least frequent english letters

--counts the number of ocurrences of a char in a string
count :: Char -> String -> Int
count a [x]
  |a == x = 1
  |otherwise = 0
count a (x:xs)
  |a == x = 1 + count a xs
  |otherwise = count a xs

--counts the numbers of ocurrences of a string in another string
countSubstring :: String -> String -> Int
countSubstring s1 s2
  |length s1 > length s2 = 0
  |take (length s1) s2 == s1 = 1 + countSubstring s1 (drop 1 s2)
  |otherwise = countSubstring s1 (drop 1 s2)

--given a number m and a string, finds all the substrings with size n that have multiple occurrences on the given string
repeatedSubsBySize :: Int -> String -> [String]
repeatedSubsBySize n [] = []
repeatedSubsBySize n s
  |countSubstring (take n s) s > 1 = (take n s) : repeatedSubsBySize n (drop 1 s)
  |otherwise = repeatedSubsBySize n (drop 1 s)

--finds all the substrings with sizes between n1 and n2 that have multiple occurrences on the given string
repeatedSubs :: Int -> Int -> String -> [String]
repeatedSubs n1 n2 [] = []
repeatedSubs n1 n2 s = [sub | n<-[n1..n2], sub<-repeatedSubsBySize n s]

--counts the number of ocurrences of each letter of the alphabet in a string
countAlphabet :: String -> [(Char, Int)]
countAlphabet s = [(letter,occurs) | letter<-alphabet, occurs<-[count letter s]]

--outputs the result of count alphabet from the most frequent letter to the least
sortAlphabetCount :: String -> [(Char, Int)]
sortAlphabetCount s = reverse (sortOn (snd) (countAlphabet s))

--substitutes all occurrences of c1 by c2 on the given string
substitute :: Char -> Char -> String -> String
substitute c1 c2 [] = []
substitute c1 c2 (x:xs)
  |c1 == x = toUpper c2 : substitute c1 c2 xs
  |otherwise = x : substitute c1 c2 xs

--counts the occurrences of c1 immediately before c2
countBefore :: Char -> Char -> String -> Int
countBefore c1 c2 [x] = 0
countBefore c1 c2 (x:xs)
  |head xs == c2 && x == c1 = 1 + countBefore c1 c2 xs
  |otherwise = 0 + countBefore c1 c2 xs

--counts the occurrences of c1 immediately after c2
countAfter :: Char -> Char -> String -> Int
countAfter c1 c2 [x] = 0
countAfter c1 c2 (x:xs)
  |x == c2 && head xs == c1 = 1 + countAfter c1 c2 xs
  |otherwise = 0 + countAfter c1 c2 xs

-- counts the ocurrences of c1 immediately before or after c2
countNeighbours :: Char -> Char -> String -> Int
countNeighbours c1 c2 s = (countBefore c1 c2 s) + (countAfter c1 c2 s)

--counts the occurrences of c immediately before or after every letter of the alphabet
countAllNeighbours :: Char -> String -> [(Char, Int)]
countAllNeighbours c s = [(letter, occurs) | letter<-alphabet, occurs<-[countNeighbours c letter s]]

--counts the occurrences of c immediately before every letter of the alphabet
countAllBefore :: Char -> String -> [(Char, Int)]
countAllBefore c s = [(letter, occurs) | letter<-alphabet, occurs<-[countBefore c letter s]]

--counts the occurrences of c immediately after every letter of the alphabet
countAllAfter :: Char -> String -> [(Char, Int)]
countAllAfter c s = [(letter, occurs) | letter<-alphabet, occurs<-[countAfter c letter s]]

--attributes a letter frequency score to the first 6 letters in a string
matchFreqScoreFirst :: String -> Int
matchFreqScoreFirst [] = 0
matchFreqScoreFirst s
  |elem (head sorted_first) en_letter_most_freq = 1 + matchFreqScoreFirst (drop 1 sorted_first)
  |otherwise = 0 + matchFreqScoreFirst (drop 1 sorted_first)
    where sorted_first = take 6 s

--attributes a letter frequency score to the last 6 letters in a string
matchFreqScoreLast :: String -> Int
matchFreqScoreLast [] = 0
matchFreqScoreLast s
  |elem (head sorted_last) en_letter_least_freq = 1 + matchFreqScoreLast (drop 1 sorted_last)
  |otherwise = 0 + matchFreqScoreLast (drop 1 sorted_last)
    where sorted_last = take 6 (reverse s)

--sorts the strings in the tuple in reverse ETAOIN order
reverseEtaoinSortFreqs :: [(Int, String)] -> [(Int, String)]
reverseEtaoinSortFreqs [] = []
reverseEtaoinSortFreqs [x]
  |length (snd x) > 1 = [(fst x, reverseEtaoinSort (snd x))]
  |otherwise = [x]
reverseEtaoinSortFreqs (x:xs)
  |length (snd x) > 1 = (fst x, reverseEtaoinSort (snd x)) : reverseEtaoinSortFreqs xs
  |otherwise = x : reverseEtaoinSortFreqs xs

--gives a list of frequencies and the respective group of letters
sortFreqToLetters :: String -> [(Int, String)]
sortFreqToLetters s = reverseEtaoinSortFreqs [(snd (head gr), map fst gr) | gr <- groupBy ((==) `on` snd) (sorted_freqs)]
    where
      sorted_freqs = (sortAlphabetCount s)

--inserts a letter in a "reverse_etaoin" ordered string keeping its order
reverseEtaoinInsert :: Char -> String -> String
reverseEtaoinInsert c [] = [c]
reverseEtaoinInsert c (x:xs)
  |(getDictIndex c etaoin) > (getDictIndex x etaoin) = c : x : xs
  |otherwise = x : reverseEtaoinInsert c xs

--sorts a string in reverse ETAOIN order
reverseEtaoinSort :: String -> String
reverseEtaoinSort [] = []
reverseEtaoinSort (x:xs) = reverseEtaoinInsert x (reverseEtaoinSort xs)

--gives the 2 highest ints in lust of (Char,Int)
getHighestFreqScores :: [(Char,Int)] -> [Int]
getHighestFreqScores scores = [maximum (map (snd) scores),maximum (map (snd) rest)]
  where rest = removeAllTuplesByInt (maximum (map (snd) scores)) scores

--outputs the letters corresponding to the given highest freq scores
getHighestLetters :: [Int] -> [(Char,Int)] -> String
getHighestLetters highest_scores [] = []
getHighestLetters highest_scores scores
  |elem (snd (head scores)) highest_scores = fst (head scores) : getHighestLetters highest_scores (tail scores)
  |otherwise = getHighestLetters highest_scores (tail scores)

--given a reverse_etaoin sorted string, attributes a frequency match score
matchFreqScore :: String -> Int
matchFreqScore s = matchFreqScoreFirst s + matchFreqScoreLast s

--gets the reverse etaoin sorted string of a string
sortedEtaoinString :: String -> String
sortedEtaoinString x = concat (map (snd) (init (sortFreqToLetters x)))

凯撒

module Ciphers.Caesar where

import MyUtils
import Data.Char

--encrypts(n) or decrypts(-n)
caesarShift :: Int -> String -> String
caesarShift n xs = [shift n x | x <- map (toLower) xs]

--given a string, shifts it 26 times and generates a list with all of the shifted strings
--one of the elements might mean something
breakCaesar :: String -> [String]
breakCaesar xs = [s | n<-[(0)..(25)], s<- [caesarShift (-n) (map (toLower) xs)]]

<#>Vigenere.hs

module Ciphers.Vigenere where

import MyUtils
import Data.Char

--encrypts the plaintext with the given key
vigenereEncrypt :: String -> String -> String
vigenereEncrypt key plaintext = ints2text result
  where result = map (`mod` 26) (zipWith (+)  keyCycle intPlainText)
        keyCycle = (cycle(text2ints key))
        intPlainText = text2ints (map (toLower) (filter (isAlphaNum) plaintext))

--decrypts the ciphertext with the given key
vigenereDecrypt :: String -> String -> String
vigenereDecrypt key ciphertext = ints2text result
  where result = map (`mod` 26) (zipWith (-)  intciphertext keyCycle)
        keyCycle = (cycle(text2ints key))
        intciphertext = text2ints (map (toLower)(filter (isAlphaNum) ciphertext))

ADFGVX.hs

module Ciphers.ADFGVX where

import Control.Monad
import System.Directory
import Data.List
import Data.Char
import Data.Maybe
import MyUtils

grid = sequence ["adfgvx","adfgvx"]
alpha_nums = zip ['a'..'z'] [1..] ++ zip ['0'..'9'] [27..]

--creates a file with a random substitution key
createSubstitutionKey :: IO()
createSubstitutionKey = do
  let filename = "my_grid.txt"
  fileExists <- doesFileExist (filename)
  when fileExists (removeFile filename)
  rands <- genRandNrs 1 36--random list of alpha_nums indexes
  writeFile filename (toDictValue rands alpha_nums)

--fills the ADFGVX grid with the given string
fillGrid :: String -> [(String,Char)]
fillGrid s = zip grid s

--substitutes all chars in a string for their respecive value in the ADFGVX grid
substitutionStep :: String -> [(String,Char)] -> String
substitutionStep plaintext filled_grid = concat (toDictValue plaintext filled_grid)

--attributes each letter in the ciphertext to each letter of the key in a cyclic fashion
--if the the ciphertext leaves blank spaces on the gird, fills it with encrypted 'a's
createKeyGrid :: String -> String -> [(Char,Char)]
createKeyGrid key ciphertext = zip (cycle key) fit_ciphertext
  where fit_ciphertext = if length (ciphertext) `mod` length (key) == 0 then ciphertext else ciphertext ++ replicate (rest) 'a'
        rest = length key - length (ciphertext) `mod` length (key)

--sorts the key grid columns in alphabetical order
sortKeyGrid :: String -> [(Char,Char)] -> [(Char,Char)]
sortKeyGrid key [] = []
sortKeyGrid key keygrid = sortOn (fst) (take (length key) keygrid) ++ (sortKeyGrid key (drop (length key) keygrid))

--ouputs the key grid with the columns as lines
groupByCols :: Eq a => [(a,b)] -> [(a,b)]
groupByCols [] = []
groupByCols [x] = [x]
groupByCols (x:xs) = [x] ++ (filter (\t -> fst(t) == fst(x)) xs) ++ groupByCols (filter (\t2 -> fst(t2) /= fst(x)) xs)

--gives the elements of the key grid as a string
transpositionStep :: String -> [(Char,Char)] -> String
transpositionStep key keygrid = map (snd) (groupByCols sorted_keygrid)
  where sorted_keygrid = sortKeyGrid key keygrid

--given a key, sorts the key and fills the grid the same way it was on the encryption process
recreateKeyGrid :: String -> String -> [(Char,String)]
recreateKeyGrid key ciphertext = zip (sorted_key) (groupN nrows ciphertext)
  where nrows = cipher_text_size `div` key_size
        sorted_key = sort key
        cipher_text_size = length ciphertext
        key_size = length key

--sorts the columns of the grid by the order of the password
unSortKeyGrid :: String -> [(Char,String)] -> [(Char,String)]
unSortKeyGrid key [] = []
unSortKeyGrid key keygrid = found : unSortKeyGrid (drop 1 key) (delete found keygrid)
  where found = fromJust (find (\x -> fst(x) == head key) keygrid)

--get the untransposed text from the unsorted grid
getPreCipherText :: [(Char,String)] -> [String]
getPreCipherText keygrid = groupN 2 [s | n<-[1..nrows], s<-getNthSpacedLetters (nrows) n gridstring]--(map (head) (map (snd) keygrid)) ++ getPreCipherText (map (tail) (map (snd) keygrid))
  where gridstring = concat (map (snd) keygrid)
        nrows = length (snd (head keygrid))

--converts the untransposed text into plaintext
getPlainText :: [String] -> [(String,Char)] -> String
getPlainText preciphertext adfgvxgrid = map (\x -> convertFrom x adfgvxgrid) preciphertext

--encryption algorithm
adfgvxEncrypt :: String -> String -> String -> String
adfgvxEncrypt substitution_key key plaintext = transpositionStep key keygrid
  where keygrid = createKeyGrid key ciphertext1
        ciphertext1 = substitutionStep (filter (isAlphaNum) (map (toLower) plaintext)) my_grid
        my_grid = fillGrid substitution_key

--decryption algorithm
adfgvxDecrypt :: String -> String -> String -> String
adfgvxDecrypt substitution_key key ciphertext = getPlainText preciphertext my_grid
  where my_grid = fillGrid substitution_key
        preciphertext = getPreCipherText (unSortKeyGrid key keygrid)
        keygrid = recreateKeyGrid key ciphertext

<#>VigenereCrack.hs

module Codebreaking.VigenereCrack where

import Ciphers.Caesar
import Ciphers.Vigenere
import Codebreaking.Cryptanalysis
import MyUtils
import Control.Monad
import System.Exit
import System.Console.ANSI
import Control.Concurrent
import Data.Function

--given two numbers representing the min and max size of the substrings that may repeat along the ciphertext and the ciphertext gives a list of all the possible lengths of the vigenere key
guessKeyLength :: Int -> Int -> String -> [Int]
guessKeyLength n1 n2 ciphertext = commonFactors (multRepeatSpacing (repeatedSubs n1 n2 ciphertext) ciphertext)

--given a list of possible keysizes and the ciphertext, splits the ciphertext into subkey parts for each possible keysize
groupBySubkeys :: [Int] -> String -> [(Int,String)]
groupBySubkeys sizes ciphertext = [(keysize,x) | keysize<-sizes, n<-[1..keysize], x<-[getNthSpacedLetters keysize n ciphertext]]

--attributes a frequency score to each caesar shift of the string
subkeyScores :: String -> [(Char,Int)]
subkeyScores s = zip alphabet [matchFreqScore shifted | shifted <- map (sortedEtaoinString) (breakCaesar s)]

--filters the most likely subkeys out of the string
filterSubkey :: (Int,String) -> (Int,String)
filterSubkey subkey_group = (keysize, candidates)
  where keysize = fst subkey_group
        string = snd subkey_group
        candidates = getHighestLetters (getHighestFreqScores (subkeyScores (string))) (subkeyScores (string))

--outputs the possible subkeys for each position of each possible key size
possibleSubkeys :: [(Int,String)] -> [(Int,String)]
possibleSubkeys subkey_groups = map (filterSubkey) subkey_groups

--given a keysize, ouputs the components of the key
getKeysizeGroup :: Int -> [(Int,String)] -> [(Int,String)]
getKeysizeGroup x group = filter (\i -> fst i == x) group

--given a list of possible subkeys and the respective keysize, gives a list of all the keys for all the possible keysizes
possibleKeys :: [(Int,String)] -> [String]
possibleKeys subkeys = [ key | keysize <- keysizes, key<-keys keysize]
  where keysizes = delRepeated (map (fst) subkeys)
        keys x = sequence (map (snd) (getKeysizeGroup x subkeys))

--tries all the keys
bruteForceKeys :: [String] -> String -> IO()
bruteForceKeys [] ciphertext = putStrLn "\nDone"
bruteForceKeys keys ciphertext = do
  let key = head keys
  putStrLn ""
  putStrLn ("Attempting with key: " ++ key ++ " :")
  threadDelay 500000
  print(vigenereDecrypt key ciphertext)
  bruteForceKeys (drop 1 keys) ciphertext

--kasiski Algorithm
--user interaction
crackVigenere :: String -> IO()
crackVigenere ciphertext = do
  putStrLn "Enter min size of repeated words:"
  readMin <- getLine
  putStrLn "Enter max size of repeated words:"
  readMax <- getLine
  let minsize = (read readMin :: Int)
      maxsize = (read readMax :: Int)
  let key_lengths = guessKeyLength minsize maxsize ciphertext
  --putStrLn "Possible key lengths:"
  clearAll
  putStrLn "Possible keys:"
  putStrLn "Calculating possible key lengths..."
  --print (key_lengths)
  let subkey_groups = groupBySubkeys key_lengths ciphertext
  --putStrLn "Subkey groups for each possible key size:"
  --print (subkey_groups)
  let subkeys = possibleSubkeys subkey_groups
  --putStrLn "Possible subkeys:"
  --print (subkeys)
  let keys = possibleKeys subkeys
  print (keys)
  forever $ do
  putStrLn "1 - Try a key"
  putStrLn "2 - Brute-force attack"
  putStrLn "r - Retry"
  putStrLn "e - Exit"
  input <- getLine
  case input of
    "1" -> do
      key <- getLine
      let plaintext = vigenereDecrypt key ciphertext
      print (plaintext)
    "2" -> bruteForceKeys keys ciphertext
    "r" -> crackVigenere ciphertext
    "e" -> exitSuccess
    otherwise -> do
      putStrLn "Please enter a valid option."
      exitFailure
```#qcStackCode#

Answer 1

Answer 2

我可能还会建议让助手函数漂亮地打印到终端。

screenLength :: Int
screenLength = 82

colons :: Int -> String
colons = flip replicate ':'

printFill :: IO ()
printFill = putStrLn $ colons screenLength

printFillT :: String -> IO ()
printFillT s = do
    putStrLn $ begin ++ fillSpace ++ end
    when (not $ null rest) $ printFillT rest
  where (fstStr, rest) = splitAt (screenLength - 6) s
        begin = ":: " ++ fstStr
        end = "::"
        fillSpace = replicate (screenlength - length begin - length end) ' '

printTitle :: String -> IO ()
printTitle s = putStrLn $ begin ++ s ++ end
  where begin = colons 8
        end = colons $ screenLength - length begin - length s

这样，您的主要功能看起来就更干净了，而且它们在任何地方都是可重用的，因此填充代码的putStrLns就更少了：

logo :: [String]
logo =
  [ "  /$#qcStackCode#           /#qcStackCode#$#qcStackCode#       /$#qcStackCode#$#qcStackCode#"
  , " /__  #qcStackCode#         /__  #qcStackCode#     |__  __/"
  , "| #qcStackCode#  __/ / /#qcStackCode# |   __/  /#qcStackCode# /| #qcStackCode#"
  , "|       |__/|__/| #qcStackCode#      |__/|__/| "
  , "| #qcStackCode#              |               | #qcStackCode#"
  , "|     #qcStackCode# / /#qcStackCode#|     #qcStackCode# / /#qcStackCode#| "
  , "|  #qcStackCode#$#qcStackCode#/|__/|__/|  $#qcStackCode#/|__/|__/| #qcStackCode#"
  , " \______/          \______/         |__/"
  ]

printMenu :: IO ()
printMenu = do
    putStrLn ""
    printFill
    mapM_ printFillT logo
    printTitle "Classic Cryptography Toolbox
    mapM_ printFillT menu
    printFill
    printFillT "e - Exit"
    printFill
  where menu =
          [ ""
          , "What would you like to do?"
          , ""
          , "1 - Encrypt a message"
          , "2 - Decrypt a message"
          , "3 - Cryptanalyse an encrypted message"
          , ""
          ]


main = forever $ do
  clearAll
  printMenu
  input <- getLine
  case input of
    "1" -> encryption
    "2" -> decryption
    "3" -> crack
    "e" -> exitSuccess
    otherwise -> do
      putStrLn ""
      putStrLn $ "Please enter a valid option"
```#qcStackCode#

Answer 3

一些快速的初步评论-将编辑我的移动。对于您的cct.hs文件，您可能希望在列表中放置不同的提示符行，并将打印结果映射到该列表上，例如：

import Control.Monad

mainMenuText = ["Line 1",
    "Line 2",
    "Line 3",
    ...]

main = mapM_ putStrLn mainMenuText

或者使用QuasiQuuotes

{-# LANGUAGE QuasiQuotes #-}
import Data.String.QQ

main = putStrLn [s|
Line 1
Line 2
Line 3|]

或者使用多行字符串：

main = putStrLn "Line 1 \n \
                \ Line 2 \n \
                \ Line 3"

您还可能希望为每个case语句菜单提供一个枚举，因此，如果需要，您可以在所有地方传递该值，这是有意义的。在您的例子中，"1"加密很快就丢失了。我建议为命令添加一个数据类型：

data Command = ENCRYPTION | DECRYPTION | ...

因此，您有一个函数可以同时执行加密和解密：

type Message = String
type Shift = Int

caesarCipher :: Command -> Message -> Shift -> String 

或者那种性质的东西。它会让界面变得更干净。

在使用camelCase时也要保持一致。

这是很多代码，但请让我谈谈我认为值得讨论的部分。

commonElems函数看起来效率很低。检查每个项目是否出现在每个列表中，进行长度检查，然后删除重复项，这似乎让人费解。我认为更简单的算法是取正在运行的交叉口的联合。

import Data.List

commonElems xs = foldr intersect intialElement xs
  where initialElement = if (null xs) then [] else (head xs) 

使用显式递归，matchIndices看起来会更好。

matchIndices needle haystack = go needle haystack 0
  where go _ [] _        = []
        go n (x:xs)@h i  = if n `isPrefixOf` h then i : (go n xs (i + 1)) else (go n xs (i + 1))