Create a gist now

Instantly share code, notes, and snippets.

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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment