Vigenère cipher cracker

gistfile1.hs

-- DISCLAIMER:
-- I wrote this when I was just beginning to learn Haskell.
-- I recently found it again and wanted to preserve it.
-- It's probably terrible code. I haven't looked it over.

import Data.Char
import Data.List
import Data.Maybe
import Data.Function

test = "zf fvrkgbafdf ge apblycf ... ge buta pmqgim, gal nrbdk ws vhctpeiicaf ltuyzvrw zfci nvzsxjeipl kpnm ase nyg ws t ztnhjv xehctndc twixypd ufv actjp og ye mampce dgkg, ngk ehf krx by ase fkgqex pesfjw ia xueisc gzbopycf. ge bux jzusqv ws mpxe, ufvar xeeeoqzdr fhas xcim shbyd tmdmuhd haorzvt, tuo sp rym phswehc fn ptyeohprxuxyd ewmcdrw h xaq mw bux lxpjpv buta hat mw bux zlmf qtiyx hd tic vucbyp aob kpnm tltdfvl vm wzior wwe ivtnu. jvaf taeeorzdr mv ehf qkcqr vq cbpkwtkhahz, qlkpxloioe xmaxyltjmea pttp tp hlltx h xaq mw ahvo xahlzbhwl nunzvzfhtp, aob, ewg ppehpsk qeklgescekr, mopy bzrvqhupd jr kw gal cihmlzf hm duo yel etpy. io rym jxzeesl umfxyes, uykbrklo fsyxurgad og rym ztw lrf qkqye az bf dfcaw, zsemrvzvgn ln patifbvyam zvifm vc bfexie; bu ehf uywyx ultjme, vb hases pvtvv pd lfdk ws mop djqtqcepye pd xmbzylpiw."

-- cracks any vigenere-encrpted cipher-text s, for key lengths up to n
vigenereCrack :: Int -> String -> String
vigenereCrack n s = map (\x -> letterAtPos x) $
                    [ bestCaesarShift x | x <- columnize key (toAbc s) ]
                    where key = bestKeyLength n s

------------------------------------------------------------------------------

-- estimates the most likely key length for a cipher text by examining the
-- index of coincidences for key lengths up to n
bestKeyLength :: Int -> String -> Int
bestKeyLength n s = fst $ head $ sortBy (compare `on` snd) $
                    [ (i, abs ((indexOfCoincidence i s) - 0.0667)) | i <- [0..n] ]

-- calucaltes the index of coincidence for some text by comparing some
-- text s against itself shifted n times
indexOfCoincidence :: Int -> String -> Float
indexOfCoincidence n s = fromIntegral (coincidences s' (shiftl n s')) / 
                         fromIntegral (length s')
                         where s' = toAbc s

-- number of matching letters between two texts
coincidences :: String -> String -> Int
coincidences [] _               = 0
coincidences (x:xs) (y:ys)
        | x == y                = 1 + coincidences xs ys
        | otherwise             = coincidences xs ys

-- shift string to the left
shiftl :: Int -> String -> String
shiftl i s = drop i s ++ take i s 

------------------------------------------------------------------------------

-- employs frequency analysis to compute the most likely caesar shift of a text
bestCaesarShift :: String -> Int
bestCaesarShift s
        | bestShift == 0        = 0
        | otherwise             = 26 - bestShift
        where bestShift = fst $ head $ sortBy (compare `on` snd) $
                          [ (n, freqDiff $ caesarShift n s) | n <- [0..25] ] 

-- computes the difference of a text's letter frequencies to the common
-- english letter distribution
freqDiff :: String -> Double
freqDiff s = residualSumOfSquares (snd $ unzip $ engLetterFreqs) 
                                  (scaleFreqs $ snd $ unzip $ letterFreqs s)

-- scales all frequencies relative to the english letter distribution
scaleFreqs :: [Double] -> [Double]
scaleFreqs fs = map (\x -> x * scaleFactor) fs
                where scaleFactor = 12.702 / (maximum fs)

-- calculates the RSS between two lists of doubles
residualSumOfSquares :: [Double] -> [Double] -> Double
residualSumOfSquares xs ys = sum [ ((fst z) - (snd z)) ** 2 | z <- zip xs ys ]
 
-- letter frequencies of a text
letterFreqs :: String -> [(Char,Double)]
letterFreqs s = [ (c, fromIntegral (count c s)) | c <- ['a'..'z'] ]

-- count occurences of a letter
count :: Char -> String -> Int
count _ []              = 0
count c (x:xs)
        | x == c        = 1 + count c xs
        | otherwise     = count c xs

-- relative letter frequencies of the english language (in %)
engLetterFreqs = [('a',8.167),('b',1.492),('c',2.782),('d',4.253),('e',12.702),('f',2.228),('g',2.015),('h',6.094),('i',6.966),('j',0.153),('k',0.772),('l',4.025),('m',2.406),('n',6.749),('o',7.507),('p',1.929),('q',0.095),('r',5.987),('s',6.327),('t',9.056),('u',2.758),('v',0.978),('w',2.360),('x',0.150),('y',1.974),('z',0.074)]

------------------------------------------------------------------------------

-- decrypts Vigenere cipher
vigenereDecrypt :: String -> String -> String
vigenereDecrypt [] _            = []
vigenereDecrypt (c:cs) (k:ks)
        | isAbc c               = [letterAtPos $ fromJust $ elemIndex c (tabulaRecta !! posOfLetter k)] ++
                                  vigenereDecrypt cs (ks ++ [k])
        | otherwise             = [c] ++ vigenereDecrypt cs (k:ks)

-- encrypts Vigenere cipher
vigenereEncrypt :: String -> String -> String
vigenereEncrypt [] _            = []
vigenereEncrypt (p:ps) (k:ks)
        | isAbc p               = [(tabulaRecta !! posOfLetter k) !! posOfLetter p] ++
                                  vigenereEncrypt ps (ks ++ [k])
        | otherwise             = [p] ++ vigenereEncrypt ps (k:ks)

-- encrypts/decrypts Beaufort cipher
beaufort :: String -> String -> String
beaufort [] _           = []
beaufort (p:ps) (k:ks)
        | isAbc p       = [letterAtPos $ fromJust $ elemIndex k (tabulaRecta !! posOfLetter p)] ++
                          beaufort ps (ks ++ [k])
        | otherwise     = [p] ++ beaufort ps (k:ks)

-- alphabet table used by Vigenere & Beaufort ciphers
tabulaRecta = [ caesarShift i ['a'..'z'] | i <- [0..25] ]

-- shifts all (letter) characters of a supplied string by n places
caesarShift :: Int -> String -> String
caesarShift _ []          = []
caesarShift n (x:xs)
        | isAbc x       = [letterAtPos (((posOfLetter x) + n) `mod` 26)]
                          ++ caesarShift n xs
        | otherwise     = [x] ++ caesarShift n xs

------------------------------------------------------------------------------

-- reverses columnization
decolumnize :: [String] -> String
decolumnize s = concat $ transpose s

-- assumes a text to be n columns wide and returns each column
columnize :: Int -> String -> [String]
columnize n s = transpose $ splitEvery n s

-- split a string every n chars
splitEvery :: Int -> String -> [String]
splitEvery _ [] = []
splitEvery n xs = [take n xs] ++ splitEvery n (drop n xs)

-- a letter's position in the alphabet (0-based)
posOfLetter :: Char -> Int
posOfLetter c = fromJust $ elemIndex (toLower c) ['a'..'z']

-- letter at position (0-based)
letterAtPos :: Int -> Char
letterAtPos n = ['a'..'z'] !! n

-- strips all non-letter chars from a string and lowercases it
toAbc :: String -> String
toAbc []        = []
toAbc (x:xs)
        | isAbc x       = [toLower x] ++ toAbc xs
        | otherwise     = toAbc xs

-- selects only letters of the alphabet
isAbc :: Char -> Bool
isAbc c = (toLower c) `elem` ['a'..'z']