{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
module Crypto.Classical.Cipher.Enigma where
import Control.Monad.Trans.State.Strict
import Crypto.Classical.Types
import Crypto.Classical.Util
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Char
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromJust)
import Data.Modular
newtype Enigma a = Enigma { _enigma :: a } deriving (Eq, Show, Functor)
instance Applicative Enigma where
pure = Enigma
Enigma f <*> Enigma a = Enigma $ f a
instance Monad Enigma where
return = pure
Enigma a >>= f = f a
instance Cipher EnigmaKey Enigma where
decrypt = encrypt
encrypt k m = pure . B.pack $ evalState (traverse f $ B.unpack m) k'
where
k' :: EnigmaKey
k' = withInitPositions k
f :: Char -> State EnigmaKey Char
f c | not $ isLetter c = return c
| isLower c = f $ toUpper c
| otherwise = do
modify (\x -> x { _rotors = turn $ _rotors x })
EnigmaKey rots _ rl pl <- get
let rs = map _circuit rots
rs' = reverse $ map mapInverse rs
pl' = mapInverse pl
cmp = foldl1 compose
e = pl |.| cmp rs |.| rl |.| cmp rs' |.| pl'
pure . letter . fromJust . flip M.lookup e $ int c
withInitPositions :: EnigmaKey -> EnigmaKey
withInitPositions k = k { _rotors = zipWith f (_rotors k) (_settings k) }
where
f :: Rotor -> Char -> Rotor
f r s = r { _circuit = rotate (int s) $ _circuit r
, _turnover = (\n -> n - int s) $ _turnover r }
turn :: [Rotor] -> [Rotor]
turn [] = []
turn (r:rs) = if _turnover r' == 25 then r' : turn rs else r' : rs
where
r' :: Rotor
r' = r { _circuit = rotate 1 $ _circuit r
, _turnover = pred $ _turnover r }
rotate :: ℤ/26 -> Map (ℤ/26) (ℤ/26) -> Map (ℤ/26) (ℤ/26)
rotate n r = M.fromList . map (both (\n' -> n' - n)) $ M.toList r