HaskellでCaesar暗号をぶち破る

最近、Haskellを勉強し始めた。Pythonもまともに出来ない人間だが函数プログラミングと数学、特に圏論の関係が気になり始め思い切って勉強してみることにした。今日の題材としては

プログラミングHaskell

の演習問題であるCaesar暗号の解読を選んだ。詳細は説明するよりも上記の本を読んでいただいたほうが早いと思う。

-- 演習問題5.8
import Data.Char

-- 文字のシフト
letLow2int :: Char -> Int
letLow2int c = ord c - ord 'a'

letUpp2int :: Char -> Int
letUpp2int c = ord c - ord 'A'

int2letLow :: Int -> Char
int2letLow n = chr (ord 'a' + n)

int2letUpp :: Int -> Char
int2letUpp n = chr (ord 'A' + n)


shift :: Int -> Char -> Char
shift n c | isLower c = int2letLow ((letLow2int c + n) `mod` 26)
          | isUpper c = int2letUpp ((letUpp2int c + n) `mod` 26)
	  | otherwise = c


encode :: Int -> String -> String
encode n xs = [shift n x | x <- xs]

-- 頻度の推定

percent :: Int -> Int -> Float
percent n m = (fromIntegral n / fromIntegral m) * 100

count :: Char -> String -> Int
count x xs = length [x' | x' <- xs, x == x']

alphas :: String -> Int
alphas xs = length [x | x <- xs, isAlpha x]

freqs :: String -> [Float]
freqs xs = [percent (count x xs') n | x <- ['a'..'z']]
           where
	   xs' = map toLower xs
	   n = alphas xs

chisqr :: [Float] -> [Float] -> Float
chisqr os es = sum [(( o - e)^2) / e | (o, e) <- zip os es]

rotate :: Int -> [a] -> [a]
rotate n xs = drop n xs ++ take n xs

positions :: Eq a => a -> [a] -> [Int]
positions x xs = [i | (x', i) <- zip xs [0..n], x == x']
               where n = length xs - 1

table :: [Float]
table = [8.2,1.2,2.8,4.3,12.7,2.2,2.0,6.1,7.0,0.2,0.8,4.0,2.4,
        6.7,7.5,1.9,0.1,6.0,6.3,9.1,2.8,1.0,2.4,0.2,2.0,0.1]

-- 解読
crack :: String -> String
crack xs = encode (-factor) xs
           where
	   factor = head (positions (minimum chitab) chitab)
	   chitab = [chisqr (rotate n table') table | n <- [0..25]]
	   table' = freqs xs

これで、例えば

"Gb gurfr uvtu cevapvcyrf naq checbfrf jr, gur Wncnarfr Crbcyr, cyrqtr bhe angvbany ubabe, qrgrezvarq jvyy naq shyy erfbheprf."

という暗号文が存在するとき、

$ ghci 5-8.hs
GHCi, version 7.6.3: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
[1 of 1] Compiling Main             ( 5-8.hs, interpreted )
Ok, modules loaded: Main.
*Main> crack "Gb gurfr uvtu cevapvcyrf naq checbfrf jr, gur Wncnarfr Crbcyr, cyr
qtr bhe angvbany ubabe, qrgrezvarq jvyy naq shyy erfbheprf."
"To these high principles and purposes we, the Japanese People, pledge our natio
nal honor, determined will and full resources."
*Main> 

となり、日本国憲法の前文の一部であったとわかる。