Instantly share code, notes, and snippets.

# willtim/Coded.hs Created Mar 20, 2012

Cracking codes using backtracking
 import Control.Applicative import Control.Monad import Control.Monad.State import Control.Monad.Logic import Data.List import qualified Data.Map as M type BindingT k v = StateT (M.Map k v) bind :: (MonadPlus m, Ord k, Eq v) => k -> v -> BindingT k v m () bind k v = do m <- get case M.lookup k m of Just v' | v' /= v -> mzero _ -> put \$ M.insert k v m -- gives [('f','2'),('k','1'),('n','8'),('s','6'),('t','3'),('u','4')] main :: IO () main = print \$ solve ["funk", "nuts", "stun"] ["6348", "8342", "8436", "2481"] type Solver a = BindingT Char Char Logic a solve :: [String] -> [String] -> [(Char, Char)] solve ws cs = M.toList . snd \$ observe (runStateT (solveWords ws cs) M.empty) -- | Solves for all supplied words and codes. Assumes one incorrect dummy code. solveWords :: [String] -> [String] -> Solver () solveWords ws cs = foldr1 mplus \$ map (go ws) (selections cs) where go ws cs = sequence_ \$ map (flip solveWord cs) ws selections [] = [] selections (x:xs) = xs : [ x:ys | ys <- selections xs] solveWord :: String -> [String] -> Solver () solveWord w cs = foldr1 mplus \$ map (sequence_ . zipWith bind w) cs