エニグマ暗号器

enigma.fsx

#!/bin/sh
#if run_with_bin_sh
  exec dotnet fsi $0 "$@"
#endif

// 実装の参考資料 : http://users.telenet.be/d.rijmenants/Enigma%20Sim%20Manual.pdf
// テストに使用したシミュレータ : https://www.101computing.net/enigma-machine-emulator/

#r "nuget: FSharpPlus"
#r "nuget: Argu"

open System.Text
open System.Collections.Generic
open FSharpPlus
open Argu

[<AutoOpen>]
module EnigmaToken =
  type [<Struct>] EnigmaToken = private EnigmaToken of char with
    static member create token =
      if 'A' <= token && token <= 'Z' then token |> EnigmaToken
      else invalidArg $"{nameof token}" "A～Zのいずれかを指定してください"
    override x.ToString() = let (EnigmaToken token) = x in string token

  module EnigmaToken =
    let listToString (tokens: EnigmaToken list) =
      (StringBuilder(), tokens |> Seq.indexed) ||> fold (fun state (i, token) ->
        if 0 < i && i % 5 = 0 then state.Append " " |> ignore
        state.Append token)
      |> string

  let (|EnigmaToken|) (EnigmaToken token) = token

[<AutoOpen>]
module Mod26 =
  type [<Struct>] Mod26 = private Mod26 of int with
    static member modulus = 26
    static member minValue = 0
    static member maxValue = Mod26.modulus - 1
    static member create n = (n % Mod26.modulus + Mod26.modulus) % Mod26.modulus |> Mod26
    static member (+) (Mod26 x, Mod26 y) = x + y |> Mod26.create
    static member (-) (Mod26 x, Mod26 y) = x - y |> Mod26.create
    static member op_Explicit (Mod26 x) = x
    override x.ToString() = let (Mod26 i) = x in i |> string

  let (|Mod26|) (Mod26 x) = x
open Mod26
let tokenToIndex (EnigmaToken token) = int token - int 'A' |> Mod26.create
let indexToToken (index: Mod26) = int index + int 'A' |> char |> EnigmaToken.create
let distinctList = List.init Mod26.modulus Mod26.create

[<AutoOpen>]
module Rotor =
  type [<Struct>] Rotor = private Rotor of {| Position: Mod26; TurnoverPosition: Mod26; RingSetting: Mod26; ForwardMapping: Mod26[]; BackwardMapping: Mod26[] |} with
    static member create(forwardMapping: Mod26 list, turnoverPosition, ringSetting, position) =
      if length forwardMapping <> Mod26.modulus || forwardMapping |> sort |> (<>) distinctList then
        invalidArg $"{nameof forwardMapping}" $"{Mod26.minValue}～{Mod26.maxValue}が1つずつ出現する配列を指定してください"
      else
        let backwardMapping = Array.zeroCreate<Mod26> Mod26.modulus
        forwardMapping |> iteri (fun i x -> backwardMapping.[int x] <- Mod26.create i)
        {| Position = position; TurnoverPosition = turnoverPosition; RingSetting = ringSetting; ForwardMapping = forwardMapping |> List.toArray; BackwardMapping = backwardMapping |} |> Rotor
    member x.Offset =
      let (Rotor rotor) = x in rotor.Position - rotor.RingSetting

  module Rotor =
    let replace rotorMap offset token =
      let replacedIndex = tokenToIndex token + offset |> int |> Array.get rotorMap
      replacedIndex - offset |> indexToToken
    let replaceForward ((Rotor r) as rotor) token = replace r.ForwardMapping rotor.Offset token
    let replaceBackward ((Rotor r) as rotor) token = replace r.BackwardMapping rotor.Offset token
    let rotate (Rotor rotor) = {| rotor with Position = rotor.Position + Mod26.create 1 |} |> Rotor
    let replaceForwardAll rotors token = (token, rotors) ||> fold (flip replaceForward)
    let replaceBackwardAll rotors token = (token, rotors |> List.rev) ||> fold (flip replaceBackward)

  let (|Rotor|) (Rotor rotor) =
    {| rotor with ForwardMapping = rotor.ForwardMapping |> Array.toList; BackwardMapping = rotor.BackwardMapping |> Array.toList |}

[<AutoOpen>]
module Plugboard =
  type [<Struct>] Plugboard = private Plugboard of IDictionary<Mod26, Mod26> with
    static member create (swaps: (Mod26 * Mod26) list) =
      let swapAll = ([], swaps) ||> fold (fun state (x, y) -> x::y::state)
      if length (distinct swapAll) <> length swapAll then invalidArg $"{nameof swaps}" "すべて違う数値を指定してください"
      else swaps >>= (fun (x, y) -> [x, y; y, x]) |> dict |> Plugboard

  module Plugboard =
    let replace (Plugboard plugboard) token =
      match token |> tokenToIndex |> plugboard.TryGetValue with
      | true, replaced -> replaced  |> indexToToken
      | false, _ -> token

  let (|Plugboard|) (Plugboard plugboard) = plugboard

[<AutoOpen>]
module Reflector =
  type [<Struct>] Reflector = private Reflector of Plugboard with
    static member create (reflectorMapping: Mod26 list) =
      if length reflectorMapping <> Mod26.modulus || reflectorMapping |> sort |> (<>) distinctList then
        invalidArg $"{nameof reflectorMapping}" $"{Mod26.minValue}～{Mod26.maxValue}が1つずつ出現する配列を指定してください"
      else
        (Map.empty, reflectorMapping |> Seq.indexed) ||> fold (fun state (index, reflectionIndex) ->
          let index = index |> Mod26.create
          match state |> Map.tryFind index with
          | None -> state |> Map.add reflectionIndex index
          | Some value when value = reflectionIndex -> state
          | Some value -> invalidArg $"{nameof reflectorMapping}" $"{index}に対しては{value}が指定されなければならないのに{reflectionIndex}が指定されました")
        |> Map.toList |> Plugboard.create |> Reflector

  module Reflector =
    let reflect (Reflector plugboard) token = Plugboard.replace plugboard token

  let (|Reflector|) (Reflector (Plugboard plugboard)) = plugboard

module EnigmaString =
  let kriegsmarine (str: string) =
      str |> String.replace "." "X" |> String.replace "," "Y" |> String.replace "?" "UD" |> String.replace ":" "XX"
      |> String.replace "-" "YY" |> String.replace "(" "KK" |> String.replace ")" "KK"
      |> String.toUpper
      |> Seq.map (fun c -> try c |> EnigmaToken.create with _ -> invalidArg $"{nameof str}" $"エニグマに入力できない文字です : {c}")
      |> Seq.toList

type [<Struct>] Enigma = { Plugboard: Plugboard; Rotors: Rotor list; Reflector: Reflector }

module Enigma =
  let cipherToken (rotate: Rotor list -> Rotor list) enigma token =
    let rotors = enigma.Rotors |> rotate
    let resultToken =
      token |> Plugboard.replace enigma.Plugboard |> Rotor.replaceForwardAll rotors
      |> Reflector.reflect enigma.Reflector |> Rotor.replaceBackwardAll rotors |> Plugboard.replace enigma.Plugboard
    resultToken, { enigma with Rotors = rotors }

  let cipherTokens rotate enigma tokens = (enigma, tokens) ||> List.mapFold (cipherToken rotate)

  let rotate rotors =
    let rec loop rotatedRotors = function
      | [] -> rotatedRotors |> List.rev
      | ((Rotor r) as rotor)::rest ->
        let rotatedRotor = rotor |> Rotor.rotate
        if r.Position = r.TurnoverPosition then loop (rotatedRotor::rotatedRotors) rest
        else (rotatedRotor::rotatedRotors |> List.rev) @ rest
    loop [] rotors

let toRotorMapping (str: string) = str |> Seq.map (EnigmaToken.create >> tokenToIndex) |> Seq.toList
let toReflector (str: string) = str |> Seq.map (EnigmaToken.create >> tokenToIndex) |> Seq.toList |> Reflector.create
let toPlugboard pairs = pairs |> List.map (fun (x, y) -> x |> EnigmaToken.create |> tokenToIndex, y |> EnigmaToken.create |> tokenToIndex) |> Plugboard.create

module EnigmaM3 =
  [<RequireQualifiedAccess>]
  type ReflectorType = UKW_B | UKW_C

  let createRotor rotorMapping turnover ringSetting initialPosition =
    Rotor.create(rotorMapping |> toRotorMapping, EnigmaToken.create turnover |> tokenToIndex, EnigmaToken.create ringSetting |> tokenToIndex, EnigmaToken.create initialPosition |> tokenToIndex)
  let rotor1 = createRotor "EKMFLGDQVZNTOWYHXUSPAIBRCJ" 'Q'
  let rotor2 = createRotor "AJDKSIRUXBLHWTMCQGZNPYFVOE" 'E'
  let rotor3 = createRotor "BDFHJLCPRTXVZNYEIWGAKMUSQO" 'V'
  let rotor4 = createRotor "ESOVPZJAYQUIRHXLNFTGKDCMWB" 'J'
  let rotor5 = createRotor "VZBRGITYUPSDNHLXAWMJQOFECK" 'Z'
  let rotorMap = [rotor1; rotor2; rotor3; rotor4; rotor5] |> List.indexed |> map (fun (i, r) -> i + 1, r) |> Map.ofList

  let reflectorB = "YRUHQSLDPXNGOKMIEBFZCWVJAT" |> toReflector
  let reflectorC = "FVPJIAOYEDRZXWGCTKUQSBNMHL" |> toReflector
  let reflectorMap = [ReflectorType.UKW_B, reflectorB; ReflectorType.UKW_C, reflectorC] |> Map.ofList

  let rotate (rotors: Rotor list) =
    match rotors with
    | [Rotor rotor3; Rotor rotor2; _] ->
      if rotor3.Position = rotor3.TurnoverPosition + Mod26.create 1 && rotor2.Position = rotor2.TurnoverPosition then rotors |> map Rotor.rotate
      else Enigma.rotate rotors
    | _ -> failwith "ローターは3つでなければなりません"

[<RequireQualifiedAccess>]
type EnigmaType = M3

[<RequireQualifiedAccess>]
type Arguments =
  | Enigma_Type of EnigmaType
  | [<Mandatory>] Reflection of EnigmaM3.ReflectorType
  | [<Mandatory>] Plugboard of string list
  | [<Mandatory>] Rotor of int * int * int
  | [<Mandatory>] Ring_Setting of char * char * char
  | [<Mandatory>] Position of char * char * char
  | First of char * char * char
  | [<MainCommand>] Input of string
with
  interface IArgParserTemplate with
    member x.Usage =
      match x with
      | Enigma_Type _ -> "エニグマの種類を指定。現時点ではM3のみ"
      | Reflection _ -> "Reflectionを指定"
      | Plugboard _ -> "Plugboardを指定"
      | Rotor _ -> "Rotorを指定"
      | Ring_Setting _ -> "RotorのRing Settingを指定"
      | Position _ -> "Rotorの初期位置を指定"
      | First _ -> "最初に入力した結果を本文の暗号化の際の初期位置にします。省略時は--positionで指定したのがそのまま本文の際の初期位置になります"
      | Input _ -> "入力する文"

let main() =
  let argParser = ArgumentParser.Create<Arguments>(programName = fsi.CommandLineArgs.[0], errorHandler = ProcessExiter())
  let parseResult = argParser.ParseCommandLine fsi.CommandLineArgs.[1 ..]
  let reflectorType = parseResult.GetResult Arguments.Reflection
  let plugboardPairs = parseResult.GetResult Arguments.Plugboard
  let rotor1, rotor2, rotor3 = parseResult.GetResult Arguments.Rotor
  let ring1, ring2, ring3 = parseResult.GetResult Arguments.Ring_Setting
  let pos1, pos2, pos3 = parseResult.GetResult Arguments.Position
  let maybeFirst = parseResult.TryGetResult Arguments.First
  let input = parseResult.GetResult Arguments.Input |> EnigmaString.kriegsmarine
  if plugboardPairs |> exists (fun x -> x.Length <> 2) then invalidArg "--plugboard" "アルファベット2文字のペアのリストを指定してください"

  let reflector = EnigmaM3.reflectorMap.[reflectorType]
  let rotors =
    [rotor3, ring3, pos3; rotor2, ring2, pos2; rotor1, ring1, pos1]
    |> map (fun (rotor, ring, pos) -> EnigmaM3.rotorMap.[rotor] ring pos)
  let plugboard = plugboardPairs |> List.map (fun x -> x.[0], x.[1]) |> toPlugboard
  let firstEnigma = { Reflector = reflector; Rotors = rotors; Plugboard = plugboard }
  let enigma =
    match maybeFirst with
    | None -> firstEnigma
    | Some(first1, first2, first3) ->
      let firstTokens = [first1; first2; first3] |> map EnigmaToken.create
      match Enigma.cipherTokens EnigmaM3.rotate firstEnigma firstTokens |> fst with
      | [EnigmaToken pos1; EnigmaToken pos2; EnigmaToken pos3] ->
        let rotors =
          [rotor3, ring3, pos3; rotor2, ring2, pos2; rotor1, ring1, pos1]
          |> map (fun (rotor, ring, pos) -> EnigmaM3.rotorMap.[rotor] ring pos)
        { Reflector = reflector; Rotors = rotors; Plugboard = plugboard }
      | _ -> failwith "プログラムのバグです"
  Enigma.cipherTokens EnigmaM3.rotate enigma input |> fst |> EnigmaToken.listToString |> printfn "%s"

main()

リフレクターは UKW-B
プラグボードは月野から T-U, K-I, N-O
ローターの種類指定は2020/5/1にきいぼーど開始したので左から II, V, I
リングの設定はハレレちゃんから H R R
ローターの初期位置はまままから M M M
最初に ADA を入力して出てきた結果をローターの初期位置に設定し直して、本文の「おはいえろー」を入力した結果の暗号文を出力
https://www.101computing.net/enigma-machine-emulator/ で同じ操作をして出力結果が一致することを確認
さらに同じ設定で暗号文を入力した場合は復号化されて元の「おはいえろー」が出力されることを確認

$ ./enigma.fsx --reflection ukw-b --plugboard TU KI NO --rotor 2 5 1 --ring-setting H R R --position M M M --first A D A OHAYELLOW
CJPIP ZITM
$ ./enigma.fsx --reflection ukw-b --plugboard TU KI NO --rotor 2 5 1 --ring-setting H R R --position M M M --first A D A CJPIPZITM
OHAYE LLOW