Skip to main content
added 4 characters in body
Source Link
Zeta
  • 19.3k
  • 2
  • 55
  • 89
unCaesar n (caesar n xs) == xs
let xs' = unwords (words xs) in unCaesar n (caesar n xs') == xs'
unCaesar n (caesar xs) == xs
let xs' = unwords (words xs) in unCaesar n (caesar xs') == xs'
unCaesar n (caesar n xs) == xs
let xs' = unwords (words xs) in unCaesar n (caesar n xs') == xs'
Source Link
Zeta
  • 19.3k
  • 2
  • 55
  • 89

My issue with both your ciphers is that they don't preserve whitespace. Even for a lower-case only string, the following property does not hold:

unCaesar n (caesar xs) == xs

Indeed, only the following property holds:

let xs' = unwords (words xs) in unCaesar n (caesar xs') == xs'

But that might be your design, so let us ignore that for now. Instead, let us have a look at your first cipher.

Caesar

The nice property about Caesar is that you can encrypt the same way you decrypt. If you move a character n characters forward, how many characters do you need to move it to get back the original one? 26 - n.

With that in mind, we can heavily reduce the size of unCaesar:

unCaesar :: Int -> String -> String
unCaesar n = caesar (26 - n)

We could also use caesar (-n) since we're using mod, but that's not important. It would fail if we used rem, though.

Now that we've reused unCaesar, let us have a look at caesar:

caesar :: Int -> String -> String
caesar n s = unwords $ map (map chr) coded
  where
    coded = map (map helper) $ words s
    helper = (+) base . flip mod 26 . (+) n . flip (-) base . ord . toLower
    base = ord 'a'

Point-free programming isn't always best practices. It's clever, but you really don't want to fix something like that in the middle of the night. Compare your code to

caesar :: Int -> String -> String
caesar n s = unwords $ map (map chr) coded
  where
    coded    = map (map helper) $ words s
    helper c = (ord (toLower c) - base + n) `mod` 26  + base
    base     = ord 'a' 

It is even shorter. It is easier to read than the point-free version, too. No flip. But if we want to preserve whitespace, it is still not optimal. Since we're handling a single character in helper either way, let us just keep spaces and handle all other characters:

caesar :: Int -> String -> String
caesar n = map helper
  where
    helper ' ' = ' ' 
    helper c   = chr $ (ord (toLower c) - base + n) `mod` 26  + base
    base       = ord 'a'

We've lost all applications of unwords and words, and instead of the map (map …) we only have a single map.

Being able to advance a lower-case ASCII character seems somewhat important, so let us refactor that:

caesar :: Int -> String -> String
caesar n = map helper
  where
    helper ' ' = ' ' 
    helper c   = asciiAdvance n c

asciiAdvance :: Int -> Char -> Char
asciiAdvance n c = chr $ (ord (toLower c) - base + n) `mod` 26  + base
  where
    base = ord 'a'

We will revisit Caesar later.

Vigenère

First of all, let us apply the point-free to non-pointfree conversion and use pattern-matching in assign:

vigenere :: String -> String -> String
vigenere k s = unwords $ map (map chr) coded
  where
    coded      = zipWith (zipWith helper) (words s) (words $ assign s 0)
    helper x y = base + mod (diff (toLower x) + diff (toLower y)) 26
    base       = ord 'a'
    diff c     = ord c - base                     
    
    assign ""     _ = ""
    assign (x:xs) i            
        | x == ' '  = ' '      : assign xs i
        | otherwise = (k !! i) : assign xs (mod (i + 1) (length k))

Hm. assign just cycles through k and skips spaces. We can implement it without length and !! if we hand it two lists: our secret, and our cycled key:

vigenere k s = unwords $ map (map chr) coded
  where
    coded      = zipWith (zipWith helper) (words s) (words $ assign s (cylce k))
    …
    assign ""     _      = ""
    assign (x:xs) (y:ys)            
        | x == ' '  = ' ' : assign xs (y:ys)
        | otherwise = y   : assign xs ys

But for a second, let us again say that you want to keep the whitespace. How would that look like?

vigenere :: String -> String -> String
vigenere k s = map chr coded
  where
    coded          = zipWith helper s (assign s (cycle k)
    base           = ord 'a'
    diff c         = ord c - base                     


    helper ' ' ' ' = ' '
    helper x   y   = base + mod (diff (toLower x) + diff (toLower y)) 26
   
    assign ""     _ = ""
    assign (x:xs) i            
        | x == ' '  = ' '      : assign xs i
        | otherwise = (k !! i) : assign xs (mod (i + 1) (length k))

Hm. zipWith helper and assign have the same type. Maybe we can fuse them?

vigenere :: String -> String -> String
vigenere k s = map chr $ helper (cycle k) s
  where
    base   = ord 'a'
    diff c = ord c - base

    helper _      []     = []
    helper (y:ys) (x:xs)
      | x == ' '  = ' '          : helper xs (y:ys)
      | otherwise = modify x y   : helper xs ys

    modify x y = base + mod (diff (toLower x) + diff (toLower y)) 26

In order to share code between vigenere and unVigenere, we need one last step. Let us change modify's type to Char -> Char -> Char:

vigenere :: String -> String -> String
vigenere k s = helper (cycle k) s
  where
    base   = ord 'a'
    diff c = ord c - base

    helper _      []     = []
    helper (y:ys) (x:xs)
      | x == ' '  = ' '          : helper (y:ys) xs
      | otherwise = modify x y   : helper ys     xs

    modify x y = chr $ base + mod (diff (toLower x) + diff (toLower y)) 26

If we rewrite unVigenere the same way, we'll notice that it looks very similar:

unVigenere :: String -> String -> String
unVigenere k s = helper (cycle k) s
  where
    base   = ord 'a'
    diff c = ord c - base

    helper _      []     = []
    helper (y:ys) (x:xs)
      | x == ' '  = ' '          : helper (y:ys) xs
      | otherwise = modify x y   : helper ys     xs

    modify x y = chr $ base + mod (diff (toLower x) - diff (toLower y)) 26

Note that I've used the properties of mod again, just as in Caesar.

Everything is the same. Except for the modification. In unViginere, we subtract the key, and in vigenere we add it. So let us move that into another function:

withKey :: (Char -> Char -> Char) -> String -> String -> String
withKey f k s = helper (cycle k) s
  where
    helper _      []     = []
    helper (y:ys) (x:xs)
      | x == ' '  = ' '   : helper (y:ys) xs
      | otherwise = f y x : helper ys     xs

vigenere :: String -> String -> String
vigenere = withKey modify
  where
    modify k v = asciiAdvance (ord k - ord 'a') v

unVigenere :: String -> String -> String
unVigenere = withKey modify
  where
    modify k v = asciiAdvance (26 - (ord k - ord 'a')) v

And we're done.