https://wiki.haskell.org/index.php?title=Haskell_Quiz/Cryptograms/Solution_Abhinav&feed=atom&action=history
Haskell Quiz/Cryptograms/Solution Abhinav - Revision history
2024-03-28T07:55:59Z
Revision history for this page on the wiki
MediaWiki 1.35.5
https://wiki.haskell.org/index.php?title=Haskell_Quiz/Cryptograms/Solution_Abhinav&diff=53807&oldid=prev
Abhinav.sarkar at 04:57, 20 September 2012
2012-09-20T04:57:36Z
<p></p>
<table class="diff diff-contentalign-left diff-editfont-monospace" data-mw="interface">
<col class="diff-marker" />
<col class="diff-content" />
<col class="diff-marker" />
<col class="diff-content" />
<tr class="diff-title" lang="en">
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">← Older revision</td>
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">Revision as of 04:57, 20 September 2012</td>
</tr><tr>
<td colspan="2" class="diff-lineno">Line 185:</td>
<td colspan="2" class="diff-lineno">Line 185:</td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>Source: https://github.com/abhin4v/rubyquiz/blob/master/Cryptograms.hs</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>Source: https://github.com/abhin4v/rubyquiz/blob/master/Cryptograms.hs</div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"></td>
</tr>
<tr>
<td class="diff-marker">−</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #ffe49c; vertical-align: top; white-space: pre-wrap;"><div>[Category:Code]]</div></td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"><div><ins class="diffchange diffchange-inline">[</ins>[Category:Code]]</div></td>
</tr>
</table>
Abhinav.sarkar
https://wiki.haskell.org/index.php?title=Haskell_Quiz/Cryptograms/Solution_Abhinav&diff=50001&oldid=prev
Abhinav.sarkar: added category:code
2012-08-23T14:34:42Z
<p>added category:code</p>
<table class="diff diff-contentalign-left diff-editfont-monospace" data-mw="interface">
<col class="diff-marker" />
<col class="diff-content" />
<col class="diff-marker" />
<col class="diff-content" />
<tr class="diff-title" lang="en">
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">← Older revision</td>
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">Revision as of 14:34, 23 August 2012</td>
</tr><tr>
<td colspan="2" class="diff-lineno">Line 184:</td>
<td colspan="2" class="diff-lineno">Line 184:</td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>Source: https://github.com/abhin4v/rubyquiz/blob/master/Cryptograms.hs</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>Source: https://github.com/abhin4v/rubyquiz/blob/master/Cryptograms.hs</div></td>
</tr>
<tr>
<td colspan="2" class="diff-empty"> </td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"></td>
</tr>
<tr>
<td colspan="2" class="diff-empty"> </td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"><div>[Category:Code]]</div></td>
</tr>
</table>
Abhinav.sarkar
https://wiki.haskell.org/index.php?title=Haskell_Quiz/Cryptograms/Solution_Abhinav&diff=49996&oldid=prev
Abhinav.sarkar: New page: <haskell> {- Decrypts a cryptogram (a substitution cypher). A solution to rubyquiz 13 (http://rubyquiz.com/quiz13.html). Usage: ./Cryptograms dictionary_file encrypted_file num_max_m...
2012-08-23T14:25:46Z
<p>New page: <haskell> {- Decrypts a cryptogram (a substitution cypher). A solution to rubyquiz 13 (http://rubyquiz.com/quiz13.html). Usage: ./Cryptograms dictionary_file encrypted_file num_max_m...</p>
<p><b>New page</b></p><div><haskell><br />
{-<br />
Decrypts a cryptogram (a substitution cypher).<br />
A solution to rubyquiz 13 (http://rubyquiz.com/quiz13.html).<br />
Usage: ./Cryptograms dictionary_file encrypted_file num_max_mappings<br />
<br />
Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net><br />
-}<br />
<br />
{-# LANGUAGE BangPatterns #-}<br />
<br />
module Cryptograms where<br />
<br />
import qualified Data.Map as M<br />
import qualified Data.Set as S<br />
import Control.Monad (foldM)<br />
import Data.Char (toLower, isAlpha)<br />
import Data.List (foldl', find, sortBy, nub)<br />
import Data.Maybe (isJust, fromJust, mapMaybe, catMaybes, fromMaybe)<br />
import Data.Ord (comparing)<br />
import System.Environment (getArgs)<br />
import Text.Printf (printf)<br />
-- import Debug.Trace (trace)<br />
<br />
trace :: String -> a -> a<br />
trace _ x = x<br />
<br />
type Mapping = M.Map Char Char<br />
<br />
type Dict = M.Map Int (S.Set String)<br />
<br />
-- reads the dictionary from the given file. must contain one word per line.<br />
readDict :: FilePath -> IO Dict<br />
readDict filePath = do<br />
!dictWords <- fmap (filter (all isAlpha) . map (map toLower) . lines)<br />
$ readFile filePath<br />
return $<br />
foldl' (\dict w -> M.insertWith S.union (length w) (S.singleton w) dict)<br />
M.empty dictWords<br />
<br />
-- translates the token using the given mapping.<br />
-- return Nothing if unable to translate.<br />
translateToken :: Mapping -> String -> Maybe String<br />
translateToken mapping = fmap reverse<br />
. foldM (\acc char -> M.lookup char mapping >>= Just . (:acc)) ""<br />
<br />
-- translates all tokens using the given mapping.<br />
-- translates the token to '---' if unable to translate.<br />
translateTokens :: Mapping -> [String] -> [String]<br />
translateTokens mapping =<br />
map (\token -><br />
fromMaybe (replicate (length token ) '-') . translateToken mapping $ token)<br />
<br />
-- checks if the given word is in the dictionary.<br />
inDict :: Dict -> String -> Bool<br />
inDict dict word =<br />
case M.lookup (length word) dict of<br />
Nothing -> False<br />
Just ws -> word `S.member` ws<br />
<br />
-- scores a mapping by counting the number of translated tokens that are<br />
-- in the dictionary.<br />
scoreMapping :: Dict -> Mapping -> [String] -> Int<br />
scoreMapping dict mapping =<br />
length . filter (inDict dict) . mapMaybe (translateToken mapping)<br />
<br />
-- scores multiple mappings and returns an assoc list sorted by descending score.<br />
scoreMappings :: Dict -> [String] -> [Mapping] -> [(Mapping, Int)]<br />
scoreMappings dict tokens =<br />
reverse . sortBy (comparing snd)<br />
. map (\mapping -> (mapping, scoreMapping dict mapping tokens))<br />
<br />
-- finds maximum num mappings which have best scores for the given tokens.<br />
findBestMappings :: Dict -> Int -> [String] -> [Mapping]<br />
findBestMappings dict num tokens = let<br />
mappings = scoreMappings dict tokens<br />
. S.toList<br />
. foldl' (\mappings -> -- find the best num mappings<br />
S.fromList . take num<br />
. map fst . scoreMappings dict tokens . S.toList<br />
. findMappingsForToken dict mappings)<br />
S.empty<br />
. nub . reverse . sortBy (comparing (\x -> (length x, x)))<br />
$ tokens<br />
maxScore = if not (null mappings) then snd . head $ mappings else 0<br />
in map fst . takeWhile ((== maxScore) . snd) $ mappings<br />
<br />
-- finds the merged mappings for a token<br />
findMappingsForToken :: Dict -> S.Set Mapping -> String -> S.Set Mapping<br />
findMappingsForToken dict mappings token =<br />
case find (inDict dict) . mapMaybe (flip translateToken token)<br />
. reverse . sortBy (comparing M.size)<br />
. S.toList $ mappings of<br />
-- the token is already translatable. return current mappings.<br />
Just dtoken -> trace (printf "Translated %s -> %s" token dtoken) mappings<br />
<br />
-- the token is not translatable yet. return current mappings merged<br />
-- with the mappings for the token.<br />
Nothing -> mergeMappingLists mappings (createMappingsForToken dict token)<br />
<br />
-- merges mapping lists. discards conflicting mappings while merging.<br />
mergeMappingLists :: S.Set Mapping -> S.Set Mapping -> S.Set Mapping<br />
mergeMappingLists mappings1 mappings2<br />
| mappings1 == S.empty = mappings2<br />
| mappings2 == S.empty = mappings1<br />
| otherwise =<br />
trace (printf "Merging %s x %s mappings" (show . S.size $ mappings1) (show . S.size $ mappings2)) $<br />
let<br />
merged = -- union current mappings and their merged result mappings<br />
S.unions [mappings1, mappings2,<br />
S.fromList . catMaybes $<br />
[mergeMappings m1 m2 | m1 <- S.toList mappings1, m2 <- S.toList mappings2]]<br />
in trace (printf "Merged to %s mappings" (show $ S.size merged)) merged<br />
<br />
-- merges two mappings. returns Nothing if mappings conflict.<br />
mergeMappings :: Mapping -> Mapping -> Maybe Mapping<br />
mergeMappings mapping1 mapping2 =<br />
foldM<br />
(\acc (k, v) -><br />
if M.member k acc<br />
then if (fromJust . M.lookup k $ acc) == v then Just acc else Nothing<br />
else Just $ M.insert k v acc)<br />
mapping1 $ M.toList mapping2<br />
<br />
-- creates mappings for a token by finding words of same form from the dictionary.<br />
createMappingsForToken :: Dict -> String -> S.Set Mapping<br />
createMappingsForToken dict token =<br />
case M.lookup (length token) dict of<br />
Nothing -> S.empty<br />
Just words -> let<br />
tokenF = tokenForm token<br />
matches = S.fromList . map (getMapping token)<br />
. filter ((== tokenF) . tokenForm) . S.toList $ words<br />
in trace (printf "%s -> %s matches" token (show . S.size $ matches)) matches<br />
<br />
-- returns form of a token. for example, the form of "abc" is [1,2,3]<br />
-- while the form of "aba" is [1,2,1].<br />
tokenForm :: String -> [Int]<br />
tokenForm token = let<br />
(_, form, _) =<br />
foldl' (\(formMap, form, lf) char -><br />
case M.lookup char formMap of<br />
Nothing -> (M.insert char (lf + 1) formMap, (lf + 1) : form, lf + 1)<br />
Just f -> (formMap, f : form, lf))<br />
(M.empty, [], 0) token<br />
in reverse form<br />
<br />
-- creates the mapping between two strings of same length.<br />
getMapping :: String -> String -> Mapping<br />
getMapping t1 t2 = M.fromList $ zip t1 t2<br />
<br />
-- returns text representation of a mapping.<br />
showMapping :: Mapping -> String<br />
showMapping mapping =<br />
map snd . sortBy (comparing fst) . M.toList<br />
. foldl' (\acc c -> M.insertWith (\_ l -> l) c '.' acc) mapping $ ['a'..'z']<br />
<br />
main :: IO()<br />
main = do<br />
(dictFile : cryptTextFile : num : _) <- getArgs<br />
-- read the dictionary<br />
!dict <- readDict dictFile<br />
-- read the encrypted tokens<br />
!tokens <- fmap (map (map toLower) . lines) $ readFile cryptTextFile<br />
<br />
let mappings = findBestMappings dict (read num) tokens<br />
<br />
if not (null mappings)<br />
then do<br />
putStrLn $ printf "%s best mappings found with score %s/%s"<br />
(show $ length mappings)<br />
(show $ scoreMapping dict (head mappings) tokens)<br />
(show $ length tokens)<br />
putStrLn . unlines $<br />
map (\mapping -> printf "%s -> %s"<br />
(showMapping mapping)<br />
(unwords . translateTokens mapping $ tokens))<br />
mappings<br />
else<br />
putStrLn "No mappings found"<br />
</haskell><br />
<br />
'''Description:''' The program decrypts the cryptogram by finding all the possible mappings by matching the encrypted tokens with words of same form from the dictionary and merging the resulting mappings.<br />
<br />
Source: https://github.com/abhin4v/rubyquiz/blob/master/Cryptograms.hs</div>
Abhinav.sarkar