Data commit

Task/Playfair-cipher/Haskell/playfair-cipher.hs

@@ -0,0 +1,101 @@
+import Control.Monad     (guard)
+import Data.Array        (Array, assocs, elems, listArray, (!))
+import Data.Char         (toUpper)
+import Data.List         (nub, (\\))
+import Data.List.Split   (chunksOf)
+import Data.Maybe        (listToMaybe)
+import Data.String.Utils (replace)
+
+type Square a = Array (Int, Int) a
+
+-- | Turns a list into an n*m-array.
+array2D ::
+       (Int, Int) -- ^ n * m
+    -> [e] -> Square e
+array2D maxCoord = listArray ((1, 1), maxCoord)
+
+-- | Generates a playfair table starting with the specified string.
+--
+-- >>> makeTable "hello"
+-- "HELOABCDFGIKMNPQRSTUVWXYZ"
+makeTable :: String -> String
+makeTable k = nub key ++ (alpha \\ key)
+    where
+      alpha = ['A' .. 'Z'] \\ "J"
+      key = map toUpper =<< words k
+
+-- | Turns a playfair table into a 5*5 alphabet square.
+makeSquare :: [a] -> Square a
+makeSquare = array2D (5, 5)
+
+-- | Displays a playfair square, formatted as a square.
+showSquare :: Square Char -> String
+showSquare d = unlines $ chunksOf 5 (elems d)
+
+-- | Given a value and an association list of x-coordinate * y-coordinate * value, returns the coordinates
+getIndex' :: (Eq a) => a -> [((Int, Int), a)] -> Maybe (Int, Int)
+getIndex' el = fmap fst . listToMaybe . filter ((== el) . snd)
+
+encodePair, decodePair :: Eq a => Square a -> (a, a) -> Maybe (a, a)
+encodePair = pairHelper (\x -> if x == 5 then 1 else x + 1)
+decodePair = pairHelper (\x -> if x == 1 then 5 else x - 1)
+
+pairHelper :: (Eq t)
+    => (Int -> Int) -- ^ a function used for wrapping around the square
+    -> Square t -- ^ a playfair square
+    -> (t, t) -- ^ two characters
+    -> Maybe (t, t) -- ^ the two resulting/encoded characters
+pairHelper adjust sqr (c1, c2) =
+    do let ps = assocs sqr
+       -- assigns an association list of (x-coord * y-coord) * value to ps
+       (x1, y1) <- getIndex' c1 ps
+       (x2, y2) <- getIndex' c2 ps
+       -- returns the coordinates of two values in the square
+       -- these will later be swapped
+       guard $ c1 /= c2
+       -- the characters (and coordinates) cannot be the same
+       let get x = sqr ! x
+       -- a small utility function for extracting a value from the square
+       Just $
+           -- wrap the coordinates around and find the encrypted characters
+           case () of
+             () | y1 == y2 ->
+                    (get (adjust x1, y1), get (adjust x2, y2))
+                | x1 == x2 ->
+                    (get (x1, adjust y1), get (x2, adjust y2))
+                | otherwise ->
+                    (get (x1, y2), get (x2, y1))
+
+-- | Turns two characters into a tuple.
+parsePair :: String -> [(Char, Char)]
+parsePair = fmap (\[x, y] -> (x, y)) . words . fmap toUpper
+
+-- | Turns a tuple of two characters into a string.
+unparsePair :: [(Char, Char)] -> String
+unparsePair = unwords . fmap (\(x, y) -> [x, y])
+
+codeHelper :: (Square Char -> (Char, Char) -> Maybe (Char, Char))
+    -> String -> String -> Maybe String
+codeHelper subs key =
+    fmap unparsePair .
+    mapM (subs (makeSquare $ makeTable key)) .
+    parsePair
+
+playfair, unplayfair :: String -> String -> Maybe String
+playfair key = codeHelper encodePair key . formatEncode
+unplayfair = codeHelper decodePair
+
+formatEncode :: String -> String
+formatEncode =
+    map toUpper .
+    unwords .
+    map (\[x, y] -> if x == y then [x, 'x'] else [x, y]) .
+    chunksOf 2 .
+    replace "j" "i" .
+    concatMap adjustLength .
+    words .
+    filter (\n -> n `elem` (['A'..'Z'] ++ ['a'..'z']))
+    where
+      adjustLength str
+          | odd (length str) = str ++ "x"
+          | otherwise = str