public
Created

Cracking codes using backtracking

  • Download Gist
Coded.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35
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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.