5
\$\begingroup\$

There are two ciphers, Caesar and Vigenère, both with an encoder and a decoder. Both work with spaces and can be passed any case (the output will be always lowercased, though). I'm a complete Haskell beginner and so my implementations are quite ugly and wordy. I'd welcome any help which would help me refactor the code, making it simpler, elegant and more readable.

I think it could be possible to more reuse and reduce this code. I can't think of any way to do that, though.

EDIT: Zeta's answer is great. I've refactored the following code according to his advice and added a new 'cipher' function which allows the user to create new ciphers. I raised a new question with the updated code, you can see it here.

import Data.Char (toLower, ord, chr)

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'

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

I feel there should be a way to not handle the spaces like this, manually. Maybe zipping over a cycled key, somehow?

import Data.Char (toLower, ord, chr)

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 = flip (-) base . ord
    assign str i
        | null str = ""
        | head str == ' ' = ' ' : assign (tail str) i
        | otherwise = (k !! i) : assign (tail str) (mod (i + 1) (length k))

unVigenere :: String -> String -> String
unVigenere k s = unwords $ map (map chr) decoded
  where
    decoded = zipWith (zipWith helper) (words s) (words $ assign s 0)
    helper x y = base - mod (base - ord (toLower x) + diff (toLower y)) 26
    base = ord 'z'
    diff = flip (-) (ord 'a') . ord
    assign str i
        | null str = ""
        | head str == ' ' = ' ' : assign (tail str) i
        | otherwise = (k !! i) : assign (tail str) (mod (i + 1) (length k))
\$\endgroup\$
  • \$\begingroup\$ Since you have two ciphers, you might want to split the code into two reviews. But I'm not sure about that. Alternatively you might want join both code snippets, so that you have a single "library". \$\endgroup\$ – Zeta Mar 24 '17 at 6:53
  • \$\begingroup\$ The way to make the code better will likely be really similar for each of those, so I grouped them. \$\endgroup\$ – Sh4rP EYE Mar 24 '17 at 6:54
5
\$\begingroup\$

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 n xs) == xs

Indeed, only the following property holds:

let xs' = unwords (words xs) in unCaesar n (caesar n 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.

\$\endgroup\$
  • \$\begingroup\$ This is an exceptional answer, thank you. \$\endgroup\$ – Sh4rP EYE Mar 25 '17 at 7:01
  • \$\begingroup\$ @Sh4rPEYE thank you. To be honest, I wanted to end with ciper :: (k -> a -> (k,a)) - > k -> [a] -> [a] for a generic framework, but that would have been out of scope. Feel free to ask for a follow-up review after you've modified your functions in a way you're comfortable with. Or try to implement cipher yourself, it's an interesting exercise. \$\endgroup\$ – Zeta Mar 25 '17 at 9:12
  • \$\begingroup\$ That sounds interesting, I'll try it. I can't think of any more things I could generalize or abstract-out, though... Maybe just that Ceasar's cipher is just a special case of Vigenère's? What was your idea roughly about? \$\endgroup\$ – Sh4rP EYE Mar 26 '17 at 14:27
  • \$\begingroup\$ I tried to do something, but I couldn't figure out what you meant by (k,a). I did it my way, you can see how on this link. Be sure to check it out :-) \$\endgroup\$ – Sh4rP EYE Mar 27 '17 at 16:04

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.