Main.hs

module VigenereCipher where

import Data.Char
import Data.Function

type Key = String

baseOrdinal = ord 'a'

-- | Compute ordinal relative to 'a'
debaseOrdinal c = ord c - baseOrdinal

-- | Rotate a character by a given number of places
rotate amount char = chr $
    debaseOrdinal char
    & (+ amount)
    & (`mod` 26)
    & (+ baseOrdinal)

-- | Cycle key by 1, return tip and cycled key
cycleKey key = (keyChar, newKey) where
    (keyChar:restKey) = key
    newKey = restKey ++ [keyChar]

-- | Crypt a valid character using the given key and offset function
handleChar offsetFun key input output =
    State key' input' output'
    where
        char : input' = input
        (keyChar, key') = cycleKey key
        offset = offsetFun keyChar
        char' = rotate offset char
        output' = output ++ [char']

-- | Skip the current character since it's not a valid character
skipChar key input output =
    State key rest $ output ++ [char]
    where char:rest = input

data State = State {
    key :: Key,
    input :: String,
    output :: String
} deriving (Show)

-- | Encrypt a single character in the State
worker offsetFun (State key input output) =
    if isAlpha $ head input then
        handleChar offsetFun key input output
    else
        skipChar key input output

-- | Process input until it's empty
work f (State key input output)
    | input == "" = State key input output
    | otherwise = work f $ f (State key input output)

-- | Crypt a string using the given key
crypt processor key input =
    work processor (State key input "") & output

-- | Encrypt a string using the given key
encrypt = crypt $ worker debaseOrdinal

-- | Decrypt a string using the given key
decrypt = crypt $ worker (negate . debaseOrdinal)

main =
    let key = "ally"
        plaintext = "meet at dawn"
        ciphertext = encrypt key plaintext
        decrypted = decrypt key ciphertext
    in do
        putStrLn $ "Key: " ++ key
        putStrLn $ "Plaintext: " ++ plaintext
        putStrLn $ "Ciphertext: " ++ ciphertext
        putStrLn $ "Decrypted: " ++ decrypted

output

Key: ally
Plaintext: meet at dawn
Ciphertext: mppr ae oywy
Decrypted: meet at dawn