Initial commit

CipherSuite/Affine.fs

@@ -0,0 +1,59 @@
+namespace CipherSuite
+
+#if DEBUG
+#else
+#nowarn "9"
+#endif
+
+open System.Text
+
+[<RequireQualifiedAccess>]
+module Affine =
+
+    let private hcf (i : int) (j : int) =
+        let rec go (bigger : int) (smaller : int) =
+            if smaller = 0 then
+                bigger
+            else
+                go smaller (bigger % smaller)
+
+        if i < 0 || j < 0 then
+            failwithf "HCF only implemented for positive numbers, got %i %i" i j
+
+        go (max i j) (min i j)
+
+    /// multiplier must be coprime to 26.
+    let encrypt (multiplier : int) (add : int) (s : string) : string =
+        if hcf multiplier 26 <> 1 then
+            failwithf "multiplier must be coprime to 26, got %i" multiplier
+
+        let sb = StringBuilder ()
+
+        for c in s do
+            if 'A' <= c && c <= 'Z' then
+                sb.Append (((int c - int 'A') * multiplier + add) % 26 + int 'A' |> char)
+            elif 'a' <= c && c <= 'z' then
+                sb.Append (((int c - int 'a') * multiplier + add) % 26 + int 'a' |> char)
+            else
+                sb.Append c
+            |> ignore
+
+        sb.ToString ()
+
+    /// Returns the inverse of the correct key, because I'm lazy.
+    let crack (s : string) =
+#if DEBUG
+        let fitness = Fitness.fromEmbedded ()
+#else
+        let arr = Fitness.allocate ()
+        use ptr = fixed arr
+        let fitness = Fitness.fromEmbedded ptr
+#endif
+        seq {
+            for mul in 1..2..25 do
+                if mul <> 13 then
+                    for add in 0..25 do
+                        let encrypt = encrypt mul add s
+                        yield (mul, add), encrypt, Fitness.get encrypt fitness
+        }
+        |> Seq.maxBy (fun (_, _, fitness) -> fitness)

CipherSuite/Arr4D.fs

@@ -0,0 +1,135 @@
+namespace CipherSuite
+
+#if DEBUG
+#else
+#nowarn "9"
+#endif
+
+open Microsoft.FSharp.NativeInterop
+
+[<Struct>]
+#if DEBUG
+type Arr4D<'a> =
+    {
+        Elements : 'a array
+        Width : int
+        WidthTimesHeight : int
+        WidthTimesHeightTimesDepth : int
+    }
+
+    member this.Depth = this.Elements.Length / this.WidthTimesHeightTimesDepth
+#else
+type Arr4D<'a when 'a : unmanaged> =
+    {
+        Elements : nativeptr<'a>
+        Length : int
+        Width : int
+        WidthTimesHeight : int
+        WidthTimesHeightTimesDepth : int
+    }
+
+    member this.Depth = this.Length / this.WidthTimesHeightTimesDepth
+#endif
+
+[<RequireQualifiedAccess>]
+module Arr4D =
+
+    /// It's faster to iterate forward over the first argument, `x`, and then the
+    /// second argument, `y`, and then the third argument, `z`.
+    let inline get (arr : Arr4D<'a>) (x : int) (y : int) (z : int) (i : int) : 'a =
+#if DEBUG
+        arr.Elements.[i * arr.WidthTimesHeightTimesDepth
+                      + z * arr.WidthTimesHeight
+                      + y * arr.Width
+                      + x]
+#else
+        NativePtr.get
+            arr.Elements
+            (i * arr.WidthTimesHeightTimesDepth
+             + z * arr.WidthTimesHeight
+             + y * arr.Width
+             + x)
+#endif
+
+    let inline set (arr : Arr4D<'a>) (x : int) (y : int) (z : int) (i : int) (newVal : 'a) : unit =
+#if DEBUG
+        arr.Elements.[i * arr.WidthTimesHeightTimesDepth
+                      + z * arr.WidthTimesHeight
+                      + y * arr.Width
+                      + x] <- newVal
+#else
+        NativePtr.write
+            (NativePtr.add
+                arr.Elements
+                (i * arr.WidthTimesHeightTimesDepth
+                 + z * arr.WidthTimesHeight
+                 + y * arr.Width
+                 + x))
+            newVal
+#endif
+
+#if DEBUG
+    /// In lieu of a meaningful name for the ana-kata axis, I am just going to call it katana.
+    let create (width : int) (height : int) (depth : int) (katana : int) (value : 'a) : Arr4D<'a> =
+        let arr = Array.create (width * height * depth * katana) value
+
+        {
+            Width = width
+            WidthTimesHeight = width * height
+            WidthTimesHeightTimesDepth = width * height * depth
+            Elements = arr
+        }
+#else
+    /// In lieu of a meaningful name for the ana-kata axis, I am just going to call it katana.
+    /// The input array must be at least of size width * height * depth * katana.
+    let create
+        (arr : nativeptr<'a>)
+        (width : int)
+        (height : int)
+        (depth : int)
+        (katana : int)
+        (value : 'a)
+        : Arr4D<'a>
+        =
+        {
+            Width = width
+            Elements = arr
+            Length = width * height * depth * katana
+            WidthTimesHeight = width * height
+            WidthTimesHeightTimesDepth = width * height * depth
+        }
+#endif
+
+    [<RequiresExplicitTypeArguments>]
+#if DEBUG
+    let zeroCreate<'a when 'a : unmanaged> (width : int) (height : int) (depth : int) (katana : int) : Arr4D<'a> =
+        {
+            Elements = Array.zeroCreate (width * height * depth * katana)
+            Width = width
+            WidthTimesHeight = width * height
+            WidthTimesHeightTimesDepth = width * height * depth
+        }
+#else
+    let zeroCreate<'a when 'a : unmanaged>
+        (elts : nativeptr<'a>)
+        (width : int)
+        (height : int)
+        (depth : int)
+        (katana : int)
+        : Arr4D<'a>
+        =
+        {
+            Elements = elts
+            Width = width
+            WidthTimesHeight = width * height
+            WidthTimesHeightTimesDepth = width * height * depth
+            Length = width * height * depth * katana
+        }
+#endif
+
+    let inline clear (a : Arr4D<'a>) : unit =
+#if DEBUG
+        System.Array.Clear a.Elements
+#else
+        NativePtr.initBlock a.Elements 0uy (uint32 sizeof<'a> * uint32 a.Length)
+#endif

CipherSuite/Assembly.fs

@@ -0,0 +1,22 @@
+namespace CipherSuite
+
+open System.IO
+
+[<RequireQualifiedAccess>]
+module internal Assembly =
+    let loadResource (name : string) =
+        let assembly = System.Reflection.Assembly.GetExecutingAssembly ()
+
+        if not (assembly.GetManifestResourceNames () |> Array.contains name) then
+            assembly.GetManifestResourceNames ()
+            |> String.concat ", "
+            |> failwithf "bad name %s, had: %s" name
+
+        seq {
+            use sr = new StreamReader (assembly.GetManifestResourceStream name)
+            let mutable line = sr.ReadLine ()
+
+            while not (obj.ReferenceEquals (null, line)) do
+                yield line
+                line <- sr.ReadLine ()
+        }

CipherSuite/Caesar.fs

@@ -0,0 +1,38 @@
+namespace CipherSuite
+
+#if DEBUG
+#else
+#nowarn "9"
+#endif
+
+[<RequireQualifiedAccess>]
+module Caesar =
+
+    let shift (s : string) (i : int) : string =
+        Array.init
+            s.Length
+            (fun index ->
+                let c = s.[index]
+
+                if 'A' <= c && c <= 'Z' then
+                    char ((int c - int 'A' + i) % 26 + int 'A')
+                elif 'a' <= c && c <= 'z' then
+                    char ((int c - int 'a' + i) % 26 + int 'a')
+                else
+                    c
+            )
+        |> System.String
+
+    let crack (s : string) =
+#if DEBUG
+        let fitness = Fitness.fromEmbedded ()
+#else
+        let arr = Fitness.allocate ()
+        use ptr = fixed arr
+        let fitness = Fitness.fromEmbedded ptr
+#endif
+
+        seq { 0..25 }
+        |> Seq.map (fun i -> 25 - i, shift s i)
+        |> Seq.map (fun (shift, text) -> (shift, text, Fitness.get text fitness))
+        |> Seq.maxBy (fun (_, _, fitness) -> fitness)

CipherSuite/CipherSuite.fsproj

@@ -0,0 +1,19 @@
+<Project Sdk="Microsoft.NET.Sdk">
+
+    <PropertyGroup>
+        <TargetFramework>net7.0</TargetFramework>
+        <GenerateDocumentationFile>true</GenerateDocumentationFile>
+        <TreatWarningsAsErrors>true</TreatWarningsAsErrors>
+    </PropertyGroup>
+
+    <ItemGroup>
+        <Compile Include="Arr4D.fs" />
+        <Compile Include="Assembly.fs" />
+        <Compile Include="FitnessAnalyser.fs" />
+        <Compile Include="Caesar.fs" />
+        <Compile Include="Affine.fs" />
+        <Compile Include="Monoalphabetic.fs" />
+        <EmbeddedResource Include="tetragraphs.txt" />
+    </ItemGroup>
+
+</Project>

CipherSuite/FitnessAnalyser.fs

@@ -0,0 +1,83 @@
+namespace CipherSuite
+
+open System
+
+type Fitness =
+    private
+        {
+            Quadruplets : Arr4D<int>
+            Total : int
+        }
+
+[<RequireQualifiedAccess>]
+module Fitness =
+
+    let inline private toIndex (c : char) : int = int (System.Char.ToUpper c) - 65
+
+#if DEBUG
+    let fromEmbedded () : Fitness =
+        let frequencies = Arr4D.zeroCreate<_> 26 26 26 26
+#else
+
+    let allocate () =
+        Array.zeroCreate<int> (26 * 26 * 26 * 26)
+
+    /// Pass in a pointer to an array of length 26*26*26*26, e.g. a pointer to
+    /// the output of `allocate`.
+    let fromEmbedded (arr : nativeptr<int>) : Fitness =
+        let frequencies = Arr4D.zeroCreate<_> arr 26 26 26 26
+#endif
+        let tetragraphs = Assembly.loadResource "CipherSuite.tetragraphs.txt"
+
+        let mutable total = 0
+
+        for line in tetragraphs do
+            if line.[0] <> '#' then
+                let line = line.AsSpan ()
+                let i = Int32.Parse (line.Slice (line.IndexOf (' ') + 1))
+                total <- total + i
+                let w = toIndex line.[0]
+                let x = toIndex line.[1]
+                let y = toIndex line.[2]
+                let z = toIndex line.[3]
+
+                if w < 0 || x < 0 || y < 0 || z < 0 then
+                    failwith "negative"
+
+                if w > 25 || x > 25 || y > 25 || z > 25 then
+                    failwith "too big"
+
+                Arr4D.set frequencies w x y z i
+
+        {
+            Quadruplets = frequencies
+            Total = total
+        }
+
+    /// Assumes the input is characters 0..25, where "a" is 0.
+    /// This fitness can meaningfully be compared across strings
+    /// with different lengths.
+    let get' (s : int[]) (f : Fitness) : float =
+        let mutable score = 0
+
+        for j = 0 to s.Length - 4 do
+            let first = s.[j]
+            let second = s.[j + 1]
+            let third = s.[j + 2]
+            let fourth = s.[j + 3]
+
+            score <- score + Arr4D.get f.Quadruplets first second third fourth
+
+        float score / float s.Length
+
+    let get (s : string) (f : Fitness) : float =
+        let s =
+            s.ToUpper().ToCharArray ()
+            |> Array.choose (fun c ->
+                if 'A' <= c && c <= 'Z' then
+                    Some (int c - int 'A')
+                else
+                    None
+            )
+
+        get' s f

CipherSuite/Monoalphabetic.fs

@@ -0,0 +1,118 @@
+namespace CipherSuite
+
+#if DEBUG
+#else
+#nowarn "9"
+#endif
+
+[<RequireQualifiedAccess>]
+module Monoalphabetic =
+
+    /// The hill climber is allowed to accept a worse solution sometimes
+    /// (in the name of escaping local optima). This is a table of probabilities
+    /// for how much worse the solution is allowed to be; for example, there is a
+    /// 5 in 20 chance that we don't accept any worse solution, and a 2 in 20 chance
+    /// we accept a solution that is 8-or-more worse.
+    /// I have completely lost the source of these numbers, and it appears that
+    /// by sheer coincidence the scale I chose for the built-in fitness function
+    /// happens to be very compatible with these perturbations.
+    let private perturbations =
+        [|
+            0
+            0
+            0
+            0
+            0
+            1
+            1
+            1
+            1
+            1
+            2
+            2
+            2
+            3
+            4
+            4
+            5
+            6
+            8
+            15
+        |]
+        |> Array.map float
+
+    let private decrypt (key : int[]) (ciphertext : int[]) (output : int[]) : unit =
+        for i = 0 to ciphertext.Length - 1 do
+            output.[i] <- key.[ciphertext.[i]]
+
+    let inline private swap (arr : int[]) (p1 : int) (p2 : int) : unit =
+        let temp = arr.[p1]
+        arr.[p1] <- arr.[p2]
+        arr.[p2] <- temp
+
+    let rec private backToString (text : int[]) : string =
+        text |> Array.map ((+) (int 'a') >> char) |> System.String
+
+    // I *think* this may originally be an algorithm described in
+    // http://web.archive.org/web/20110210123730/http://web.mac.com/mikejcowan/Ciphers/Churn_Algorithm.html
+    // But it was over a decade ago and I've simply forgotten the source.
+    let crack (rand : System.Random) (keysLimit : int) (ciphertext : string) : int[] * string * float =
+        let ciphertext = ciphertext.ToUpperInvariant ()
+#if DEBUG
+        let fitness = Fitness.fromEmbedded ()
+#else
+        let arr = Fitness.allocate ()
+        use ptr = fixed arr
+        let fitness = Fitness.fromEmbedded ptr
+#endif
+        let plaintext =
+            Array.init
+                ciphertext.Length
+                (fun i ->
+                    let output = int ciphertext.[i] - int 'A'
+
+                    if output < 0 || output > 25 then
+                        failwith "non-alphabetic character"
+
+                    output
+                )
+
+        let ciphertext = Array.copy plaintext
+        let currentKey = [| 0..25 |]
+        let bestKey = Array.copy currentKey
+        decrypt currentKey ciphertext plaintext
+        let mutable currentFitness = Fitness.get' plaintext fitness
+        let mutable bestFitness = currentFitness
+        let mutable keyCount = 0
+
+        while keyCount < keysLimit do
+            let swap1 = rand.Next (0, 26)
+            let swap2 = rand.Next (0, 25)
+            let swap2 = if swap2 < swap1 then swap2 else swap2 + 1
+
+            swap currentKey swap1 swap2
+
+            // We could do better here, because the plaintext changes
+            // only in well-defined ways from loop to loop.
+            // I'm lazy.
+            decrypt currentKey ciphertext plaintext
+
+            let newFitness = Fitness.get' plaintext fitness
+
+            if newFitness > bestFitness then
+                bestFitness <- newFitness
+                currentFitness <- newFitness
+                Array.blit currentKey 0 bestKey 0 currentKey.Length
+            elif newFitness > currentFitness - perturbations.[rand.Next (0, perturbations.Length)] then
+                // This guess wasn't the best we've had, but it's good enough when we
+                // add in a bit of jitter to get us out of local optima.
+                currentFitness <- newFitness
+            else
+                // Revert this guess, it wasn't sufficiently high fitness
+                swap currentKey swap1 swap2
+
+            keyCount <- keyCount + 1
+
+        decrypt bestKey ciphertext plaintext
+        let plaintext = backToString plaintext
+        bestKey, plaintext, bestFitness