ischain.hs

ischain.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Main where
import qualified Control.Monad as C
import qualified Data.Char as CH
import qualified Data.Maybe as M
import qualified Data.List as L
import qualified Network.Memcache as MC
import qualified Network.Memcache.Protocol as MCP
import qualified Network.Memcache.Key as MCK

-- note: we are trying to find any wordchain, not the optimal one

type Chain = Maybe [String]
type Pair  = (String,String)

tests = [("A","A"),("cat","dog"),("cat","let"),("cat","lot")] :: [Pair]

-- is the word in memcache?
keyExists :: (MC.Memcache a, MCK.Key k) => a -> k -> IO Bool
keyExists conn word = do
  word_v <- MC.get conn word
  case word_v of
    Nothing            -> return False
    Just (s :: String) -> return True

-- a heuristic for measuring the distance between two words
wordDist :: String -> String -> Int
wordDist src tgt =  
  let lsrc   = length src
      ltgt   = length tgt
      ldiff  = abs $ lsrc - ltgt
      shortl = minimum [lsrc,ltgt] in
  case (ldiff == 0) of 
    True  -> f src tgt
    False -> ldiff + (wordDist (take shortl src) (take shortl tgt))
  where f s t = sum $ zipWith (\a b -> if (a == b) then 0 else 1) s t

-- will build try-words by moving left to right, changing letters with 
-- substitutions from the alphabet that form new strings. we don't know
-- if the words are valid in the dictionary, and hopefully as they are
-- lazily consumed, a word with a superior wordDist to the src word can
-- be found
letterSwaps :: String -> [String]
letterSwaps s = f s 0 where
  f s l = 
    let r    = l + 1
        subs = filter (\x -> x /= "") $ 
               map (\c -> if (c == s!!l) then "" 
                          else take l s ++ [c] ++ drop r s) ['a'..'z']
    in 
     if (r == length s) then subs else subs ++ f s (l+1)

-- try to find a word that is in the dictionary and has a lower wordDist
tryWord conn chain src tgt = 
  let dist = wordDist src tgt 
      swaps = filter (\s -> not $ elem s chain) (letterSwaps src)
      betterStrings = L.sortBy (\x y -> compare (fst x) (fst y)) $ 
          map (\s -> ((wordDist s tgt),s)) (swaps)
  in
  do 
    -- remove the tuples that have swapstrs not in the dict
    betterWords <- C.filterM ((keyExists conn) . snd) betterStrings
    return $ (snd . head) betterWords

wordChain :: MC.Memcache a => a -> [String] -> String -> String -> Int 
             -> IO (Chain)
wordChain conn chain src tgt i = 
  if (i > 9) then (return Nothing) else
    case (src == tgt) of
      True -> return (Just chain)
      False -> 
        do
          src' <- tryWord conn chain src tgt
          wordChain conn (chain ++ [src']) src' tgt (i+1)

-- strChain serves to do some basic checking (are both strs actually words?)
-- and set up the args to call wordChain
strChain :: MC.Memcache a => a -> Pair -> IO (Pair,Chain)
strChain conn pair = 
  let src = map CH.toLower $ fst pair
      tgt = map CH.toLower $ snd pair in
  do
    inDict <- C.liftM (and) $ C.mapM (keyExists conn) [src,tgt]
    case inDict of 
      False -> return (pair,Nothing)
      True  -> do
        areChained <- wordChain conn [src] src tgt 0
        case areChained of
          Nothing -> return (pair,Nothing)
          Just chain -> return (pair,Just chain)

main :: IO ()
main = do
  conn <- MCP.connect "127.0.0.1" 11212
  r <- C.mapM (strChain conn) tests
  print r
  MCP.disconnect conn
  return ()