diff --git a/Crypto/Enigma.hs b/Crypto/Enigma.hs new file mode 100644 --- /dev/null +++ b/Crypto/Enigma.hs @@ -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 - +-- 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 - <<< +-- 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 + -- 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, ) 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 +-- . +-- 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 diff --git a/Crypto/Enigma/Display.hs b/Crypto/Enigma/Display.hs new file mode 100644 --- /dev/null +++ b/Crypto/Enigma/Display.hs @@ -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 +-- +-- 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 +-- +-- 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) + diff --git a/Crypto/Enigma/Utils.hs b/Crypto/Enigma/Utils.hs new file mode 100644 --- /dev/null +++ b/Crypto/Enigma/Utils.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/crypto-enigma.cabal b/crypto-enigma.cabal new file mode 100644 --- /dev/null +++ b/crypto-enigma.cabal @@ -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