crypto-enigma (empty) → 0.0.1.3
raw patch · 6 files changed
+868/−0 lines, 6 filesdep +MissingHdep +basedep +containerssetup-changed
Dependencies added: MissingH, base, containers, split
Files
- Crypto/Enigma.hs +486/−0
- Crypto/Enigma/Display.hs +274/−0
- Crypto/Enigma/Utils.hs +36/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- crypto-enigma.cabal +40/−0
+ Crypto/Enigma.hs view
@@ -0,0 +1,486 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-|+Module : Crypto.Enigma+Description : Enigma machine simulator.+License : BSD3+Maintainer : royl@aldaron.com+Stability : experimental+Portability : POSIX++An enigma machine simulator with rudimentary display. Richer display is provided by "Crypto.Enigma.Display".+-}+--{-# LANGUAGE MultiWayIf #-}+--{-# LANGUAGE Trustworthy #-}+--{-# LANGUAGE Safe #-}+module Crypto.Enigma (+ -- * Machine components+ Component,+ name,+ wiring,+ turnovers,+ Name,+ Wiring,+ Turnovers,+ component,+ -- * Machine configurations and transitions+ EnigmaConfig,+ configEnigma,+ stages,+ components,+ positions,+ rings,+ windows,+ Position,+ Stage,+ step,+ -- * Mappings+ -- | The encodings established by the machine and its components.+ Mapping,+ Direction (..),+ componentMapping,+ stageMappingList,+ enigmaMappingList,+ enigmaMapping,+ -- * Encoding+ -- | Encoding messages.+ Message,+ enigmaEncoding+) where++import Control.Arrow+import Control.Exception (assert)+import Data.Monoid+import Data.List+import Data.List.Split (splitOn)+import qualified Data.Map as M+import Data.Maybe+import Text.Printf (printf)++import Crypto.Enigma.Utils+--import Data.Map (Map)++{-# ANN module ("HLint: ignore Use infix"::String) #-}+{-# ANN module ("HLint: ignore Use mappend"::String) #-}+{-# ANN module ("HLint: ignore Use fmap"::String) #-}+{-# ANN module ("HLint: error Redundant $"::String) #-}+{-# ANN module ("HLint: ignore Use ."::String) #-}++-- TBD - Use lenses - <http://hackage.haskell.org/package/lens> <http://dev.stephendiehl.com/hask/#lenses>+-- TBD - Use modular arithmetic package - http://hackage.haskell.org/package/modular-arithmetic+-- TBD - Use Arrow more?+-- TBD - EnigmaMachine as Monad instance?+-- TBD - SPELLCHECK <<<+-- TBD - Remove or properly handle Main and Test <<<+-- TBD - Proper testing script - <http://dev.stephendiehl.com/hask/#testing> <<<+-- TBD - Place under source control <<<+-- TBD - Code review <<<+-- TBD - Upload to Hackage <<<+-- REV - Move plugboard last (it's 'optional'?)?+-- TBD - Note how this implementation differs by preserving all letters and full mappings so they can be examined. <<<+-- TBD - Use 'length.nub $ take n $ (iterate step cfg)' for all combinations of rotors to show num of unique states for all combinations of rotors (or numbers of rotor turnovers).+-- ASK - Another approach other than 'length.nub' and 'iterate' to test all configs?+-- REV - Have lists and display omit plugboard stage if not used or present; distinguishing non-use and absence?+-- REV - Show degenerate case in list and display examples?++++-- Enigma mechanics ==========================================================+++-- Machine components --------------------------------------------------------++-- REV - Actually any string that does not contain periods will be taken as no plugboard; see 'component'.+-- | A string identifying a 'Component' of an Enigma machine.+-- For rotors (including the reflector) this is one of the conventional letter or roman numeral designations+-- (e.g., @\"IV\"@ or @\"β\"@). For the plugboard this is the conventional string of letter pairs (separated by periods),+-- indicating letters wired together by plugging (e.g., @\"AU.ZM.ZL.RQ\"@).+-- Absence or non-use of a plugboard can be indicated with a lone "~". See 'name'.+type Name = String++-- | The 'Mapping' established by the physical wiring of a 'Component', when 01 is at the window position for rotors,+-- and by the plug arrangement for the plugboard. See 'wiring'.+type Wiring = Mapping++-- | The list of letters on the rotor's ring that appear at the window when a 'Component''s ring is in the turnover+-- position.+-- Not applicable (and empty) for the plugboard and for reflectors. See 'turnovers'.+type Turnovers = String++-- | A component used to construct an Enigma machine (embodied in an 'EnigmaConfig') identified by its 'name', and+-- characterized by its physical 'wiring' and additionally — for rotors other than the reflector — by 'turnovers'+-- which govern the 'step'ping of the machine in which it is installed.+data Component = Component {+ name :: !Name, -- ^ The component's 'Name'.+ wiring :: !Wiring, -- ^ The component's 'Wiring'.+ turnovers :: !Turnovers -- ^ The component's 'Turnovers'.+}++-- REV - \c -> (name c, c) instead of (name &&& id) ?+-- Definitions of rotor Components; people died for this information+--comps :: [(Name,Component)]+comps = M.fromList $ (name &&& id) <$> [+ -- rotors+ Component "I" "EKMFLGDQVZNTOWYHXUSPAIBRCJ" "Q",+ Component "II" "AJDKSIRUXBLHWTMCQGZNPYFVOE" "E",+ Component "III" "BDFHJLCPRTXVZNYEIWGAKMUSQO" "V",+ Component "IV" "ESOVPZJAYQUIRHXLNFTGKDCMWB" "J",+ Component "V" "VZBRGITYUPSDNHLXAWMJQOFECK" "Z",+ Component "VI" "JPGVOUMFYQBENHZRDKASXLICTW" "ZM",+ Component "VII" "NZJHGRCXMYSWBOUFAIVLPEKQDT" "ZM",+ Component "VIII" "FKQHTLXOCBJSPDZRAMEWNIUYGV" "ZM",+ Component "β" "LEYJVCNIXWPBQMDRTAKZGFUHOS" "",+ Component "γ" "FSOKANUERHMBTIYCWLQPZXVGJD" "",+ -- reflectors+ Component "A" "EJMZALYXVBWFCRQUONTSPIKHGD" "",+ Component "B" "YRUHQSLDPXNGOKMIEBFZCWVJAT" "",+ Component "C" "FVPJIAOYEDRZXWGCTKUQSBNMHL" "",+ Component "b" "ENKQAUYWJICOPBLMDXZVFTHRGS" "",+ Component "c" "RDOBJNTKVEHMLFCWZAXGYIPSUQ" "",+ -- base case (e.g. for "unplugged" plugboard, or the keyboard)+ Component "" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ""]++-- | The 'Component' with the specified 'Name'.+component :: Name -> Component+component n = fromMaybe (Component n (foldr plug letters (splitOn "." n)) "") (M.lookup n comps)+ -- Either lookup the rotor or reflector by name, or use the plugboard spec to+ -- generate a component with wiring in which the specified letter pairs are exchanged.+ where+ c = find ((== n).name) comps+ plug [p1,p2] = map (\ch -> if ch == p1 then p2 else if ch == p2 then p1 else ch)+ plug _ = id -- Anything but a .-separated pair will have no effect+++-- Machine configurations and transitions ------------------------------------++-- | The (zero-based) index of the processing stage occupied by a 'Component' in an 'EngmaConfig'. See 'stages'.+type Stage = Int++-- | The generalized rotational position of a 'Component'. For rotors, this is denoted by number on the rotor+-- (not letter ring) that is at the "window position". For other components the only meaningful position is @1@+-- (see 'positions').+--+-- This (alone) determines the permutations applied to the component's+-- 'Wiring' to produce its current 'Mapping' (see 'componentMapping').+type Position = Int++-- | The complete description of the state of an Enigma machine, consisting 'components', 'positions', and 'rings'.+data EnigmaConfig = EnigmaConfig {+ -- | The 'Name' of each 'Component' in an 'EnigmaConfig', in processing order.+ -- Unchanged by 'step'.+ --+ -- >>> components $ configEnigma "c-β-V-III-II" "LQVI" "AM.EU.ZL" "16.01.21.11"+ -- ["AM.EU.ZL","II","III","V","\946","c"]+ --+ -- (Note that any Unicode charcters are+ -- <http://stackoverflow.com/a/24953885/656912 stored by Haskell> as their Unicode value:+ -- here @"\\946" == "β"@.)+ components :: ![Name],+ -- | The 'Position' of each 'Component' in an 'EnigmaConfig', in machine processing order.+ -- May be changed by 'step'.+ --+ -- >>> positions $ configEnigma "c-β-V-III-II" "LQVI" "AM.EU.ZL" "16.01.21.11"+ -- [1,25,2,17,23,1]+ --+ -- For plugboard and reflector, this will always be @1@ since the former cannot rotate,+ -- and the latter does not (neither will be changed by 'step'):+ --+ -- prop> head (positions cfg) == 1+ -- prop> last (positions cfg) == 1+ --+ -- This determines the encoding performed by a component (see 'componentMapping').+ positions :: ![Position],+ -- | The location of ring letter 'A' on the rotor for each 'Component' in an 'EnigmaConfig',+ -- in machine processing order.+ -- Unchanged by 'step'.+ --+ -- >>> rings $ configEnigma "c-β-V-III-II" "LQVI" "AM.EU.ZL" "16.01.21.11"+ -- [1,11,21,1,16,1]+ --+ -- For plugboard and reflector, this will always be @1@ since the former lacks a ring,+ -- and for latter ring position is irrelevant (the letter ring is not visible, and has+ -- no effect on turnovers):+ --+ -- prop> head (rings cfg) == 1+ -- prop> last (rings cfg) == 1+ rings :: ![Int]+ } deriving Eq++-- | The sequential, (forward) processing-order, 'Stage' occupied by each 'Component' in an 'EnigmaConfig', starting+-- with @0@ for the plugboard and ending with the reflector.+--+-- >>> stages $ configEnigma "c-β-V-III-II" "LQVI" "AM.EU.ZL" "16.01.21.11"+-- [0,1,2,3,4,5]+--+-- prop> components cfg == ((components cfg !!) <$> stages cfg)+--+-- The term \'stage\' (lowercase) is also used here to encompass subsequent reverse processing order stages+-- (see, for example, 'stageMappingList').+stages :: EnigmaConfig -> [Stage]+stages ec = [0..(length $ components ec)-1]++-- REV - Could take a ring and a position and dispense with st+-- TBD - Some properties showing only 'position' changes?+-- The letter at the window for a given stage.+-- Used in 'windows', and in 'step' to identify when a rotor ring is in the turnover position+windowLetter :: EnigmaConfig -> Stage -> Char+windowLetter ec st = chrA0 $ mod (positions ec !! st + rings ec !! st - 2) 26++-- | Step the machine to a new 'EnigmaConfig' by rotating the rightmost (first) rotor one position, and other rotors+-- as determined by the 'positions' of rotors in the machine.+-- In the physical machine, a step occurs in response to each operator keypress,+-- prior to processing that key's letter. (See 'enigmaEncoding'.)+--+-- Stepping leaves the 'components', 'stages' and 'rings' of a configuration unchanged, changing only 'positions',+-- which is manifest in changes of the letters at the 'windows':+--+-- >>> let cfg = configEnigma "c-γ-V-I-II" "LXZO" "UX.MO.KZ.AY.EF.PL" "03.17.04.01"+-- >>> putStr $ unlines $ show <$> take 5 (iterate step cfg)+-- c-γ-V-I-II LXZO UX.MO.KZ.AY.EF.PL 03.17.04.01+-- c-γ-V-I-II LXZP UX.MO.KZ.AY.EF.PL 03.17.04.01+-- c-γ-V-I-II LXZQ UX.MO.KZ.AY.EF.PL 03.17.04.01+-- c-γ-V-I-II LXZR UX.MO.KZ.AY.EF.PL 03.17.04.01+-- c-γ-V-I-II LXZS UX.MO.KZ.AY.EF.PL 03.17.04.01+--+-- >>> let cfg = configEnigma "c-γ-V-I-II" "LXZO" "UX.MO.KZ.AY.EF.PL" "03.17.04.01"+-- >>> take 5 $ map windows $ iterate step cfg+-- ["LXZO","LXZP","LXZQ","LXZR","LXZS"]+--+-- >>> let cfg = configEnigma "c-γ-V-I-II" "LXZO" "UX.MO.KZ.AY.EF.PL" "03.17.04.01"+-- >>> take 5 $ map positions $ iterate step cfg+-- [[1,15,23,8,10,1],[1,16,23,8,10,1],[1,17,23,8,10,1],[1,18,23,8,10,1],[1,19,23,8,10,1]]+step :: EnigmaConfig -> EnigmaConfig+step ec = EnigmaConfig {+ components = components ec,+ positions = steppedPosition <$> stages ec, -- Stepping changes only the rotor positions+ rings = rings ec+ }+ where+ -- explicit factoring to expose stepping logic+ steppedPosition :: Stage -> Position+ steppedPosition i = (mod (positions ec !! i + di - 1) 26) + 1+ where+ di | i == 0 = 0 -- plugboard does not step+ | i > 3 = 0 -- only the first three rotors can step+ | i == 1 = 1 -- the first rotor always steps+ | i == 2 && isTurn 2 = 1 -- the second rotor steps if it is in a turnover position+ | isTurn (i-1) = 1 -- other rotors (<=3) step if the previous component is in a turnover position+ | otherwise = 0+ isTurn :: Stage -> Bool+ isTurn j = elem (windowLetter ec j) (turnovers $ component (components ec !! j))+++-- REV - Plugboard omission happens more generally; see 'Name'.+-- Instantiation, display, and reading ---------------------------------------++-- | The letters at the window in an 'EnigmaConfig', in physical, conventional order.+-- This is the (only) visible manifestations of configuration changes during operation.+--+-- >>> windows $ configEnigma "c-β-V-III-II" "LQVI" "AM.EU.ZL" "16.01.21.11"+-- "LQVI"+windows :: EnigmaConfig -> String+windows ec = reverse $ tail.init $ windowLetter ec <$> (stages ec)++-- | A (safe plublic, <https://wiki.haskell.org/Smart_constructors "smart">) constructor that does validation and takes a conventional specification as input, in the+-- form of four strings:+--+-- * The rotor 'Name's, separated by dashes (e.g. @\"C-V-I-II\"@); see 'Name'.+-- * The letters visible at the windows (e.g. @\"MQR\"@); see 'windows'.+-- * The plugboard specification (which may me omitted with @\"~\"@); see 'Name'.+-- * The position of the letter ring on each rotor, separated by periods (e.g. @\"22.11.16\"@); see 'rings'.+--+-- Following convention, the elements of these specifications are in physical machine order as the operator sees+-- them, which is the reverse of the order in which they are encountered in processing (see 'stages').+--+-- Validation is permissive, allowing for ahistorical collections and numbers of rotors (including reflectors+-- at the rotor stage, and trivial degenerate machines;+-- e.g., @configEnigma "-" \"A\" "" "01"@), and any number of (non-contradictory) plugboard wirings (including none).+configEnigma :: String -> String -> String -> String -> EnigmaConfig+configEnigma rots winds plug rngs = assert ((and $ (==(length components')) <$> [length winds', length rngs']) &&+ (and $ [(>=1),(<=26)] <*> rngs') &&+ (and $ (`elem` letters) <$> winds') &&+ (plug == "" || ((and $ (==2).length <$> splitOn "." plug) &&+ (and $ (`elem` letters) <$> filter (/='.') plug) &&+ ((\s -> s == nub s) $ filter (/='.') plug))+ ) &&+ (and $ (`M.member` comps) <$> tail components'))+ EnigmaConfig {+ components = components',+ positions = zipWith (\w r -> (mod (numA0 w - r + 1) 26) + 1) winds' rngs',+ rings = rngs'+ }+ where+ -- Order is reversed, from physical to processing order+ -- Rings and windows are padded with values for the plugboard and reflector+ rngs' = reverse $ (read <$> (splitOn "." $ "01." ++ rngs ++ ".01") :: [Int])+ winds' = "A" ++ reverse winds ++ "A"+ components' = reverse $ splitOn "-" $ rots ++ "-" ++ plug+++-- TBD - Some checking, e.g. that four "words" have been provided?+-- | Read the elements of a conventional specification (see 'configEnigma') joined by spaces into a single string.+--+-- >>> let cfg = configEnigma "b-β-V-VIII-III" "XQVI" "UX.MO.KZ.AY.EF.PL" "03.17.24.11"+-- >>> let cfg' = read "b-β-V-VIII-III XQVI UX.MO.KZ.AY.EF.PL 03.17.24.11" :: EnigmaConfig+-- >>> cfg == cfg'+-- True+instance Read EnigmaConfig where+ readsPrec _ i = [(configEnigma c w s r, "")] where [c, w, s, r] = words i++-- | Show the elements of a conventional specification (see 'configEnigma') joined by spaces into a single string.+--+-- >>> configEnigma "b-β-V-VIII-II" "XQVI" "UX.MO.KZ.AY.EF.PL" "03.17.24.11"+-- "b-β-V-VIII-III XQVI UX.MO.KZ.AY.EF.PL 03.17.24.11"+instance Show EnigmaConfig where+ show ec = unwords [intercalate "-" $ reverse.tail $ components ec,+ windows ec,+ head $ components ec,+ intercalate "." $ reverse.tail.init $ (printf "%02d") <$> (rings ec)]++-- | Show a 'Component' as a formatted string consisting of its 'name', 'wiring', and 'turnovers' (if any).+instance Show Component where+ show c = printf "%-5.5s" (name c) ++ " " ++ wiring c ++ " " ++ turnovers c++++-- Mapping ==================================================================+++-- | The mapping used by a component (see 'wiring' and 'componentMapping')+-- or by the machine (see 'enigmaMapping') to perform a+-- <https://en.wikipedia.org/wiki/Substitution_cipher#Simple_substitution simple substitution encoding>.+-- This is expressed as a string of letters indicating the mapped-to letter+-- for the letter at that position in the alphabet — i.e., as a permutation of the alphabet.+-- For example, the mapping @EKMFLGDQVZNTOWYHXUSPAIBRCJ@ encodes @A@ to @E@, @B@ to @K@, @C@ to @M@, ...+-- @Y@ to @C@, and @Z@ to @J@.+type Mapping = String+++-- Enigma encoding logic -----------------------------------------------------++-- REV - These only need to be exposed to allow componentMapping to be exposed; necessary? <<<+-- | The direction that a signal flows through a 'Component'. During encoding of a character, the signal+-- passes first through every component in a forward ('Fwd') direction, then through the reflector, and then, in+-- revers order, through each component again, in reverse ('Rev').+-- This direction affects the encoding preformed by the component (see 'componentMapping').+data Direction = Fwd | Rev++-- REV - Add assertion to make sure plugboard is not rotated ; assert not in keys?+-- | The 'Mapping' performed by a 'Component' as a function of its 'Position' and the 'Direction' of the+-- signal passing through it.+--+-- The base encoding of a 'Component', performed with rotor position @1@ at the window, is set by its 'wiring'.+--+-- prop> componentMapping Fwd comp 1 == wiring comp+--+-- For all other positions, the encoding is a cyclic permutation this mapping's inputs (backward)+-- and outputs (forward) by the rotational offset of the rotor away from the @1@ position+-- (though in an actual 'EmigmaConfig' such positions occur only for rotors; see 'positions').+--+-- Note that because the wiring of reflectors generates mappings that consist entirely of paired exchanges+-- of letters, reflectors (at any position) produce the same mapping in both directions (the same is true+-- of the plugboard):+--+-- >>> let tst c n = componentMapping Fwd (component c) n == componentMapping Rev (component c) n+-- >>> and $ tst <$> ["A","B","C","b","c"] <*> [1..26]+-- True+componentMapping:: Direction -> Component -> Position -> Mapping+componentMapping d c p = case d of+ Fwd -> map (\ch -> rotMap (1-p) letters !! (numA0 ch)) (rotMap (p-1) (wiring c))+ Rev -> chrA0 <$> (ordering $ componentMapping Fwd c p)+ where+ rotMap :: Int -> Wiring -> Mapping+ rotMap o w = take 26 . drop (mod o 26) . cycle $ w++-- | The list of 'Mapping's for each stage of an 'EnigmaConfig': the encoding performed by the+-- 'Component' /at that point/ in the progress through the machine.+--+-- These are arranged in processing order, beginning with the encoding performed by the plugboard,+-- followed by the forward encoding performed by each rotor (see 'componentMapping'), then the reflector,+-- followed by the reverse encodings by each rotor, and finally by the plugboard again.+--+-- >>> putStr $ unlines $ stageMappingList (configEnigma "b-γ-V-VIII-II" "LFAQ" "UX.MO.KZ.AY.EF.PL" "03.17.04.11")+-- YBCDFEGHIJZPONMLQRSTXVWUAK+-- LORVFBQNGWKATHJSZPIYUDXEMC+-- BJYINTKWOARFEMVSGCUDPHZQLX+-- ILHXUBZQPNVGKMCRTEJFADOYSW+-- YDSKZPTNCHGQOMXAUWJFBRELVI+-- ENKQAUYWJICOPBLMDXZVFTHRGS+-- PUIBWTKJZSDXNHMFLVCGQYROAE+-- UFOVRTLCASMBNJWIHPYQEKZDXG+-- JARTMLQVDBGYNEIUXKPFSOHZCW+-- LFZVXEINSOKAYHBRGCPMUDJWTQ+-- YBCDFEGHIJZPONMLQRSTXVWUAK+--+-- Note that, because plugboard 'Mapping' is established by paired exchanges of letters+-- (see 'componentMapping'),+--+-- prop> head (stageMappingList cfg) == last (stageMappingList cfg)+--+-- As noted (see 'stages') the term \'stage\' here encompasses reverse processing:+--+-- prop> length (stageMappingList cfg) == 2 * length (stages cfg) - 1+--+-- A richer example of how this list is used, and how it can be interpreted,+-- can be found in "Crypto.Enigma.Display#showEnigmaConfigInternalEG".+stageMappingList:: EnigmaConfig -> [Mapping]+stageMappingList ec = ((stageMapping Fwd) <$>) <> ((stageMapping Rev) <$>).tail.reverse $ stages ec+ where+ stageMapping :: Direction -> Stage -> Mapping+ stageMapping d sn = componentMapping d (component $ components ec !! sn) (positions ec !! sn)++-- | The list of 'Mapping's an 'EnigmaConfig' has performed by each stage:+-- the encoding performed by the 'EnigmaConfig' /up to that point/ in the progress through the machine.+--+-- >>> putStr $ unlines $ enigmaMappingList (configEnigma "b-γ-V-VIII-II" "LFAQ" "UX.MO.KZ.AY.EF.PL" "03.17.04.11")+-- YBCDFEGHIJZPONMLQRSTXVWUAK+-- MORVBFQNGWCSJHTAZPIYEDXULK+-- EVCHJTGMKZYUAWDBXSOLNIQPFR+-- UDHQNFZKVWSAIOXLYJCGMPTRBE+-- BKNUMPIGREJYCXLQVHSTOAFWDZ+-- NCBFPMJYXAIGKRODTWZVLEUHQS+-- HIUTFNSAOPZKDVMBGREYXWQJLC+-- CAEQTJYUWIGMVKNFLPRXDZHSBO+-- RJMXFBCSHDQNOGELYUKZTWVPAI+-- COYWEFZPNVGHBIXATUKQMJDRLS+-- CMAWFEKLNVGHBIUYTXZQOJDRPS+--+-- Since these may be thought of as cumulative encodings,+--+-- prop> enigmaMapping cfg == last (enigmaMappingList cfg)+enigmaMappingList :: EnigmaConfig -> [Mapping]+enigmaMappingList ec = scanl1 (flip encode') (stageMappingList ec)++-- | The 'Mapping' preformed by the Enigma machine.+--+-- >>> enigmaMapping (configEnigma "b-γ-V-VIII-II" "LFAQ" "UX.MO.KZ.AY.EF.PL" "03.17.04.11")+-- "CMAWFEKLNVGHBIUYTXZQOJDRPS"+--+-- A example of a richer display of this information can be found in "Crypto.Enigma.Display#showEnigmaConfigEG".+enigmaMapping :: EnigmaConfig -> Mapping+enigmaMapping ec = last $ enigmaMappingList ec -- The final stage's progressive encoding++-- TBD - Keep? Not enforced except by assertion in 'enigmaEncoding', and by substitution of ' ' in showEnigmaConfigS+-- BUG - Why does this assertion seem to pass and generate an out of bounds error with e.g., '.' in a msg? <<<+-- | A valid keyboard entry into an Enigma machine: a string of uppercase characters.+type Message = String++-- REV -- Move preprocessing back; move assertion out?+-- | Encode a 'Message' using a given (starting) machine configuration, by 'step'ping the configuration prior to+-- processing each character of the message. This produces a new configuration (with new 'positions' only)+-- for encoding each character, which serves as the "starting" configuration for subsequent+-- processing of the message.+--+-- >>> enigmaEncoding (configEnigma "b-γ-V-VIII-II" "LFAP" "UX.MO.KZ.AY.EF.PL" "03.17.04.11") "KRIEG"+-- "GOWNW"+--+-- The details of this encoding and its relationship to stepping from one configuration to another are+-- illustrated in "Crypto.Enigma.Display#showEnigmaOperationEG".+--+-- Note that because of the way the Enigma machine is designed, it is always the case that+--+-- prop> enigmaEncoding cfg (enigmaEncoding cfg msg) == msg+enigmaEncoding :: EnigmaConfig -> Message -> String+enigmaEncoding ec msg = assert (and $ (`elem` letters) <$> msg) $+ -- The encoding of a string is the sequence encodings performed by sequentially+ -- stepped configurations (preceded by a step)+ zipWith encode (enigmaMapping <$> (iterate step (step ec))) msg
+ Crypto/Enigma/Display.hs view
@@ -0,0 +1,274 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-|+Module : Crypto.Enigma.Display+Description : Display of Enigma machine state and encoding.+License : BSD3+Maintainer : royl@aldaron.com+Stability : experimental+Portability : POSIX++A module for rich display of the state state of and encoding performed by Enigma machines defined in "Crypto.Enigma".+-}++module Crypto.Enigma.Display (+ -- * Configuration display+ showEnigmaConfig,+ showEnigmaConfigInternal,+ -- * Operation display+ showEnigmaOperation,+ showEnigmaOperationInternal,+ -- * Encoding display+ showEnigmaEncoding+) where++import Data.Monoid+import Data.Char+import Data.List+import Data.List.Split (chunksOf)+import Data.String.Utils (replace)+import Text.Printf (printf)++import Crypto.Enigma.Utils+import Crypto.Enigma++{-# ANN module ("HLint: ignore Use infix"::String) #-}+{-# ANN module ("HLint: ignore Use mappend"::String) #-}+{-# ANN module ("HLint: error Redundant $"::String) #-}+{-# ANN module ("HLint: ignore Use ."::String) #-}++-- TBD - SPELLCHECK <<<+-- TBD - Fix name of more detaild display -> ..EnigmConfigSchematic ? <<<+-- REV - Final newline in show... functions is a bit inconsistent++++-- Helpers ===================================================================+++-- Message entry -------------------------------------------------------------++-- Some standard substitions performed by (Kriegsmarine) operators+preproc :: String -> Message+preproc s = filter (`elem` ['A'..'Z']) $ foldl1 fmap (uncurry replace <$> subs) $ toUpper <$> s+ where+ subs = [(" ",""),(".","X"),(",","Y"),("'","J"),(">","J"),("<","J"),("!","X"),+ ("?","UD"),("-","YY"),(":","XX"),("(","KK"),(")","KK"),+ ("1","YQ"),("2","YW"),("3","YE"),("4","YR"),("5","YT"),+ ("6","YZ"),("7","YU"),("8","YI"),("9","YO"),("0","YP")]+++-- Message display -----------------------------------------------------------++-- TBD - Don't remove spaces (at least in showEnigmaOperation and instead put a blank line?)+-- Standard formatting of encoded messages+postproc :: String -> String+postproc = unlines . chunksOf 60 . unwords . chunksOf 4+++-- Mapping markup -----------------------------------------------------------++-- TBD Move up (closer to encoding?)+-- TBD - Can't use below unless encode handles ch == ' '+-- locate the index of the encoding with enc of ch, in s+locCar :: Char -> String -> Mapping -> Maybe Int+locCar ch s enc = elemIndex (encode enc ch) s++decorate :: Char -> String+decorate ch = ch:"\818\773"+--decorate ch = ['[',ch,']'] -- version that works when Unicode fails to display properly (e.g. IHaskell as of 0.7.1.0)++markedMapping :: Maybe Int -> Mapping -> String+markedMapping (Just loc) e = take loc <> decorate.(!!loc) <> drop (loc + 1) $ e+markedMapping Nothing e = e++++-- Machine operation display =================================================++-- Preprocess a message and produce a configuration display for the starting configuraiton+-- and for each character of the message, using the provied configuration display function.+showEnigmaOperation_ :: (EnigmaConfig -> Char -> String) -> EnigmaConfig -> String -> String+showEnigmaOperation_ df ec msg = unlines $ zipWith df (iterate step ec) (' ':(preproc msg))+++-- Configuration display -----------------------------------------------------++-- | Display a summary of the Enigma machine configuration as its encoding (see 'Mapping'),+-- the letters at the windows (see 'windows'), and the 'Position's of the rotors (see 'positions').+--+-- If a valid 'Message' character is provided, indicate that as input and mark the encoded letter.+--+-- For example, #showEnigmaConfigEG#+--+-- >>> putStr $ showEnigmaConfig (configEnigma "b-γ-V-VIII-II" "LFAQ" "UX.MO.KZ.AY.EF.PL" "03.17.04.11") 'K'+-- K > CMAWFEKLNVG̲̅HBIUYTXZQOJDRPS LFAQ 10 16 24 07+--+-- shows the process of encoding of the letter __@\'K\'@__ to __@\'G\'@__.+showEnigmaConfig :: EnigmaConfig -> Char -> String+showEnigmaConfig ec ch = fmt ch' (markedMapping (locCar ch' enc enc) enc) (windows ec) (reverse $ tail.init $ positions ec)+ where+ ch' = if ch `elem` letters then ch else ' '+ enc = enigmaMapping ec+ fmt ch e ws ps = lbl ++ " " ++ e ++ " " ++ ws ++ " "++ ps'+ where+ lbl = if ch == ' ' then " " else ch:" >"+ ps' = unwords $ (printf "%02d") <$> ps++-- TBD - Add figure from MMA tool showing mapping+-- | Display a summary of the Enigma machine configuration as a schematic showing the encoding (see 'Mapping')+-- performed by each stage (see 'stageMappingList'), along with an indication of the stage+-- (rotor number, @\"P\"@ for plugboard, or @\"R\"@ for reflector), window letter (see 'windows'),+-- 'Position' (see 'positions') and 'Name',+-- followed by the encoding for the machine, and preceeded by a (trivial, no-op) keyboard \"encoding\"+-- for reference.+--+-- If a valid 'Message' character is provided, indicate that as input and mark the letter it is encoded to at+-- each stage; mark its encoding as output.+--+-- For example, #showEnigmaConfigInternalEG#+--+-- >>> putStr $ showEnigmaConfigInternal (configEnigma "b-γ-V-VIII-II" "LFAQ" "UX.MO.KZ.AY.EF.PL" "03.17.04.11") 'K'+-- K > ABCDEFGHIJK̲̅LMNOPQRSTUVWXYZ+-- P YBCDFEGHIJZ̲̅PONMLQRSTXVWUAK UX.MO.KZ.AY.EF.PL+-- 1 LORVFBQNGWKATHJSZPIYUDXEMC̲̅ Q 07 II+-- 2 BJY̲̅INTKWOARFEMVSGCUDPHZQLX A 24 VIII+-- 3 ILHXUBZQPNVGKMCRTEJFADOYS̲̅W F 16 V+-- 4 YDSKZPTNCHGQOMXAUWJ̲̅FBRELVI L 10 γ+-- R ENKQAUYWJI̲̅COPBLMDXZVFTHRGS b+-- 4 PUIBWTKJZ̲̅SDXNHMFLVCGQYROAE γ+-- 3 UFOVRTLCASMBNJWIHPYQEKZDXG̲̅ V+-- 2 JARTMLQ̲̅VDBGYNEIUXKPFSOHZCW VIII+-- 1 LFZVXEINSOKAYHBRG̲̅CPMUDJWTQ II+-- P YBCDFEG̲̅HIJZPONMLQRSTXVWUAK UX.MO.KZ.AY.EF.PL+-- G < CMAWFEKLNVG̲̅HBIUYTXZQOJDRPS+--+-- shows the process of encoding of the letter __@\'K\'@__ to __@\'G\'@__:+--+-- * __@\'K\'@__ is entered at the keyboard, which is then+-- * encoded by the plugboard (@\'P\'@), which includes @\"KZ\"@ in its specification (see 'Name'),+-- to __@\'Z\'@__, which is then+-- * encoded by the first rotor (@\'1\'@), a @\"II\"@ rotor in the @06@ position (and @\'Q\'@ at the window),+-- to __@\'C\'@__, which is then+-- * encoded by the second rotor (@\'2\'@), a @\"VIII\"@ rotor in the @24@ position (and @\'A\'@ at the window),+-- to __@\'Y\'@__, which is then+-- * encoded by the third rotor (@\'3\'@), a @\"V\"@ rotor in the @16@ position (and @\'F\'@ at the window),+-- to __@\'S\'@__, which is then+-- * encoded by the fourth rotor (@\'4\'@), a @\"γ\"@ rotor in the @10@ position (and @\'L\'@ at the window),+-- to __@\'J\'@__, which is then+-- * encoded by the reflector rotor (@\'U\'@), a @\"b\"@ reflector,+-- to __@\'I\'@__, which reverses the signal sending it back through the rotors, where it is then+-- * encoded in reverse by the fourth rotor (@\'4\'@),+-- to __@\'Z\'@__, which is then+-- * encoded in reverse by the third rotor (@\'3\'@),+-- to __@\'G\'@__, which is then+-- * encoded in reverse by the second rotor (@\'2\'@),+-- to __@\'Q\'@__, which is then+-- * encoded in reverse by the first rotor (@\'1\'@),+-- to __@\'G\'@__, which is then+-- * encoded left unchainged by the plugboard (@\'P\'@), and finally+-- * displayed as __@\'G\'@__+--+-- Note that (as follows from 'Mapping') the position of the marked letter at each stage is the alphabetic position+-- of the marked letter at the previous stage.+showEnigmaConfigInternal :: EnigmaConfig -> Char -> String+showEnigmaConfigInternal ec ch = unlines $+ [fmt (if ch' == ' ' then "" else ch':" >") (markedMapping (head charLocs) letters) ' ' 0 ""] +++ (zipWith5 fmt (init <> reverse $ ["P"] ++ (show <$> (tail.init $ stages ec)) ++ ["R"])+ (zipWith markedMapping (tail.init $ charLocs) (stageMappingList ec))+ (" " ++ (reverse $ windows ec) ++ replicate (length $ positions ec) ' ')+ ([0] ++ ((tail.init $ positions ec)) ++ replicate (length $ positions ec) 0 )+ (components ec ++ (tail $ reverse $ components ec))+ ) +++ [fmt (if ch' == ' ' then "" else (encode (enigmaMapping ec) ch'):" <") (markedMapping (last charLocs) (enigmaMapping ec)) ' ' 0 ""]+ where+ ch' = if ch `elem` letters then ch else ' '+ charLocs = zipWith (locCar ch') ([letters] ++ stageMappingList ec ++ [enigmaMapping ec]) ([letters] ++ enigmaMappingList ec ++ [enigmaMapping ec])+ fmt l e w p n = lbl ++ " " ++ e ++ " " ++ (w:[]) ++ " " ++ p' ++ " " ++ n+ where+ lbl = printf "%3.3s" l :: String+ p' = if p == 0 then " " else printf "%02d" (p::Int)+++-- Operation display ---------------------------------------------------------++-- | Show a summary of an Enigma machine configuration (see 'showEnigmaConfig')+-- and for each subsequent configuration as it processes each letter of a message. #showEnigmaOperationEG#+--+-- >>> putStr $ showEnigmaOperation (configEnigma "b-γ-V-VIII-II" "LFAP" "UX.MO.KZ.AY.EF.PL" "03.17.04.11") "KRIEG"+-- OHNKJYSBTEDMLCARWPGIXZQUFV LFAP 10 16 24 06+-- K > CMAWFEKLNVG̲̅HBIUYTXZQOJDRPS LFAQ 10 16 24 07+-- R > HXETCUMASQNZGKRYJO̲̅IDFWVBPL LFAR 10 16 24 08+-- I > FGRJUABYW̲̅DZSXVQTOCLPENIMHK LFAS 10 16 24 09+-- E > SJWYN̲̅UZPQBVXRETHIMAOFKCLDG LFAT 10 16 24 10+-- G > EOKPAQW̲̅JLHCISTBDFVMNXRGUZY LFAU 10 16 24 11+--+-- Note that the first line of the display represents the initial configuration of the machine, but does not+-- perform any encoding (as explained in 'step').+-- Note also that the second line of this display is the same as one displayed in the examle for 'showEnigmaConfig'.+showEnigmaOperation :: EnigmaConfig -> String -> String+showEnigmaOperation ec msg = showEnigmaOperation_ showEnigmaConfig ec msg++-- | Show a schematic of an Enigma machine's internal configuration (see 'showEnigmaConfigInternal')+-- and for each subsequent configuration as it processes each letter of a message.+--+-- >>> putStr $ showEnigmaOperationInternal (configEnigma "b-γ-V-VIII-II" "LFAP" "UX.MO.KZ.AY.EF.PL" "03.17.04.11") "KR"+-- ABCDEFGHIJKLMNOPQRSTUVWXYZ+-- P YBCDFEGHIJZPONMLQRSTXVWUAK UX.MO.KZ.AY.EF.PL+-- 1 DMPSWGCROHXLBUIKTAQJZVEYFN P 06 II+-- 2 BJYINTKWOARFEMVSGCUDPHZQLX A 24 VIII+-- 3 ILHXUBZQPNVGKMCRTEJFADOYSW F 16 V+-- 4 YDSKZPTNCHGQOMXAUWJFBRELVI L 10 γ+-- R ENKQAUYWJICOPBLMDXZVFTHRGS b+-- 4 PUIBWTKJZSDXNHMFLVCGQYROAE γ+-- 3 UFOVRTLCASMBNJWIHPYQEKZDXG V+-- 2 JARTMLQVDBGYNEIUXKPFSOHZCW VIII+-- 1 RMGAWYFJOTPLBZICSHDQNVEKXU II+-- P YBCDFEGHIJZPONMLQRSTXVWUAK UX.MO.KZ.AY.EF.PL+-- OHNKJYSBTEDMLCARWPGIXZQUFV+-- <BLANKLINE>+-- K > ABCDEFGHIJK̲̅LMNOPQRSTUVWXYZ+-- P YBCDFEGHIJZ̲̅PONMLQRSTXVWUAK UX.MO.KZ.AY.EF.PL+-- 1 LORVFBQNGWKATHJSZPIYUDXEMC̲̅ Q 07 II+-- 2 BJY̲̅INTKWOARFEMVSGCUDPHZQLX A 24 VIII+-- 3 ILHXUBZQPNVGKMCRTEJFADOYS̲̅W F 16 V+-- 4 YDSKZPTNCHGQOMXAUWJ̲̅FBRELVI L 10 γ+-- R ENKQAUYWJI̲̅COPBLMDXZVFTHRGS b+-- 4 PUIBWTKJZ̲̅SDXNHMFLVCGQYROAE γ+-- 3 UFOVRTLCASMBNJWIHPYQEKZDXG̲̅ V+-- 2 JARTMLQ̲̅VDBGYNEIUXKPFSOHZCW VIII+-- 1 LFZVXEINSOKAYHBRG̲̅CPMUDJWTQ II+-- P YBCDFEG̲̅HIJZPONMLQRSTXVWUAK UX.MO.KZ.AY.EF.PL+-- G < CMAWFEKLNVG̲̅HBIUYTXZQOJDRPS+-- <BLANKLINE>+-- R > ABCDEFGHIJKLMNOPQR̲̅STUVWXYZ+-- P YBCDFEGHIJZPONMLQR̲̅STXVWUAK UX.MO.KZ.AY.EF.PL+-- 1 NQUEAPMFVJZSGIRYOH̲̅XTCWDLBK R 08 II+-- 2 BJYINTKW̲̅OARFEMVSGCUDPHZQLX A 24 VIII+-- 3 ILHXUBZQPNVGKMCRTEJFADO̲̅YSW F 16 V+-- 4 YDSKZPTNCHGQOMX̲̅AUWJFBRELVI L 10 γ+-- R ENKQAUYWJICOPBLMDXZVFTHR̲̅GS b+-- 4 PUIBWTKJZSDXNHMFLV̲̅CGQYROAE γ+-- 3 UFOVRTLCASMBNJWIHPYQEK̲̅ZDXG V+-- 2 JARTMLQVDBG̲̅YNEIUXKPFSOHZCW VIII+-- 1 EYUWDHM̲̅RNJZXGAQFBOLTCIVSPK II+-- P YBCDFEGHIJZPO̲̅NMLQRSTXVWUAK UX.MO.KZ.AY.EF.PL+-- O < HXETCUMASQNZGKRYJO̲̅IDFWVBPL+--+-- Note that the first block of the display represents the initial configuration of the machine, but does not+-- perform any encoding (as explained in 'step'). Note also that the second block of this display is the same+-- as one displayed in the examle for 'showEnigmaConfigInternal'.+showEnigmaOperationInternal :: EnigmaConfig -> String -> String+showEnigmaOperationInternal ec msg = showEnigmaOperation_ showEnigmaConfigInternal ec msg++++-- Encoding display ==========================================================++-- | Show the conventionally formatted encoding of a mssage by an (initial) Enigma machine configuration.+--+-- >>> let cfg = configEnigma "c-β-V-VI-VIII" "CDTJ" "AE.BF.CM.DQ.HU.JN.LX.PR.SZ.VW" "05.16.05.12"+-- >>> putStr $ showEnigmaEncoding cfg "FOLGENDES IST SOFORT BEKANNTZUGEBEN"+-- RBBF PMHP HGCZ XTDY GAHG UFXG EWKB LKGJ+showEnigmaEncoding :: EnigmaConfig -> String -> String+showEnigmaEncoding ec msg = postproc $ enigmaEncoding ec (preproc msg)+
+ Crypto/Enigma/Utils.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_HADDOCK hide, prune #-}+{-|+Module : Crypto.Enigma.Utils+-}+module Crypto.Enigma.Utils where++import Data.Char (chr, ord)+import Data.List (sort)+++-- Some character utilities --------------------------------------------------++-- REV - Could make this [MsgChar]+letters :: String+letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"++numA0 :: Char -> Int+numA0 ch = ord ch - ord 'A'++chrA0 :: Int -> Char+chrA0 i = chr (i + ord 'A')++ordering :: Ord a => [a] -> [Int]+ordering xs = snd <$> sort (zip xs [0..])+++-- General encoding logic ----------------------------------------------------++-- encode a single character+encode :: String -> Char -> Char+encode e ' ' = ' '+encode e ch = e !! (numA0 ch)++-- standard simple-substitution cypher encoding+encode' :: String -> String -> String+encode' e s = (encode e) <$> s
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Roy Levien++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Roy Levien nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ crypto-enigma.cabal view
@@ -0,0 +1,40 @@+name: crypto-enigma+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.0.1.3+synopsis: An Enigma machine simulator with display.+description: The crypto-enigma package is an Enigma machine simulator+ with rich display and machine state details.+ .+ For basic functionality, including some introspection of machine state+ and the mappings proformed, simply+ .+ > > import Crypto.Enigma+ .+ For richer display functionality additionally+ .+ > > import Crypto.Enigma.Display+license: BSD3+license-file: LICENSE+author: Roy Levien+maintainer: royl@aldaron.com+-- copyright: +category: Cryptography, Education+build-type: Simple+-- extra-source-files: +cabal-version: >= 1.22.1.1++library+ -- default-extensions: Trustworthy+ exposed-modules: Crypto.Enigma,+ Crypto.Enigma.Display+ other-modules: Crypto.Enigma.Utils+ -- other-extensions:+ build-depends: base >= 4.8.1.0 && <4.9,+ containers >= 0.5.5.1,+ split >= 0.2.2,+ MissingH >= 1.3.0.1+ -- hs-source-dirs:+ default-language: Haskell2010