Coded

Coded.hs

module Main where

import Control.Monad
import Control.Monad.Logic
import Control.Monad.State.Strict
import qualified Data.Map as M

type BindingT k v = StateT (M.Map k v)

bind :: (Ord k, Eq v, Monad m) => k -> v -> BindingT k v m ()
bind k v = do
  m <- bindings
  let (mv, m') = M.insertLookupWithKey (\_ _ v -> v) k v m
  case mv of
    (Just v') | v /= v'   -> fail $ "Cannot bind to a different value"
              | otherwise -> return ()
    Nothing               -> put m'


bindings :: (Monad m) => BindingT k v m (M.Map k v)
bindings = get

runBindingT :: (Monad m) => BindingT k v m a -> m (M.Map k v)
runBindingT a = execStateT a M.empty

type Solver = BindingT Char Char Logic

main :: IO ()
main = print $ solve ["funk", "nuts", "stun"] ["6348", "8342", "8436", "2481"]

solve :: [String] -> [String] -> [(Char, Char)]
solve ws cs = M.toList . observe . runBindingT $ solveAll ws cs

solveAll :: [String] -> [String] -> Solver ()
solveAll ws cs = mapM_ (solveWord cs) ws

solveWord :: [String] -> String -> Solver ()
solveWord cs w = do
  c <- member cs
  sequence_ $ zipWith bind w c

member :: (MonadLogic m) => [a] -> m a
member = msum . map return