Skip to content

Instantly share code, notes, and snippets.

@llelf
Created April 9, 2012 00:59
Show Gist options
  • Save llelf/2340625 to your computer and use it in GitHub Desktop.
Save llelf/2340625 to your computer and use it in GitHub Desktop.
fpfp-april
-- MIND YOUR EYES! DIRTY CODE AHEAD.
import Control.Monad
import qualified Data.Map as M
import qualified Data.Set as S
import Data.List
import System
import System.IO
import Data.List
import Data.Ord
import Data.Maybe
letters = ['а'..'я'] ++ ['ё']
--letters = ['a'..'z']
possibleAdjWords w = (\\[w]) . nub . sort . concat . zipWith mutate (inits w) $ tails w
where mutate _ [] = []
mutate a (x:b) = [ a ++ y:b | y <- letters ]
type Mutations = M.Map String [String]
add (w,w') dict
| w' `S.member` dict
= M.updateWithKey (\_ v -> Just (w:v)) w' . M.updateWithKey (\_ v -> Just (w':v)) w
| otherwise
= id
vocBy cons file = readFile file >>= return . cons . lines
voc = vocBy construct
vocAdj = (M.!)
constructBy adj ws = foldl addMutated scratch ws
where scratch = foldr (flip M.insert []) M.empty ws
addMutated muts w = foldr (\m -> add (w,m) dict) muts $ adj w
dict = S.fromList ws
construct = constructBy possibleAdjWords
construct3 = constructBy (\w -> possibleAdjWords w ++ to3 w ++ to4 w)
where to3 w = concat $ zipWith f (inits w) (tails w)
f w1 [] = []
f w1 (w:w2) = [w1++w2]
to4 w = [ c:w | c <- letters ]
bfs adj target src = go [src] (S.singleton src) M.empty
where go [] vis r = maybe (Just r) (const Nothing) target
go (v:q) vis r | Just t <- target, t==v = Just r'
| otherwise = go (q ++ tos) vis' r'
where (r',tos,vis') = visit (adj v) r [] vis
visit [] r' tos vis' = (r', tos, S.insert v vis')
visit (q:qs) r' tos vis'
| q `S.notMember` vis' = visit qs (M.insert q v r') (q:tos) (S.insert q vis')
| otherwise = visit qs r' tos vis'
mutations voc a b
| Just tree <- bfs (vocAdj voc) (Just b) a
= Just . (a:) . reverse . takeWhile (/=a) . iterate (tree M.!) $ b
| otherwise
= Nothing
revTree = M.fromListWith (++) . map (\(k,v) -> (v,[k])) . M.toList
farthestFrom voc from = go [from] 0
where go vs level = maximumBy (comparing fst) $ map go' vs
where go' v | v `M.member` tree' = go (tree' M.! v) (level+1)
| otherwise = (level,v)
tree' = revTree . fromJust . bfs (vocAdj voc) Nothing $ from
maxMutations voc = (lev + 1, mutations voc from to)
where (from,(lev,to)) = maximumBy (comparing $ fst.snd) . map (ap (,) $ farthestFrom voc) $ words
words = M.keys voc
printMuts = putStrLn . out
where out (Just vs) = unwords . intersperse "→" $ vs
out Nothing = "NO WAY!"
solve voc from to
= do
hSetEncoding stdout utf8
printMuts $ mutations voc from to
print $ maxMutations voc
main = do v1 <- voc "voc1.txt"
let (n,mut) = maxMutations v1
print n
printMuts mut
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment