import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.List
import Control.Monad.State

data Queue a = Queue (Seq.Seq a) deriving (Eq)

instance (Show a) => Show (Queue a) where
  show (Queue s) = "Queue " ++ (drop (length "fromList ") (show s))

enqueue :: a -> Queue a -> Queue a
enqueue a (Queue q) = Queue(q Seq.|> a)

dequeue :: Queue a -> Maybe (a,Queue a)
dequeue (Queue q) = if isEmpty (Queue q) then Nothing else Just (Seq.index q 0,Queue $ Seq.drop 1 q)

emptyQueue = Queue $ Seq.empty

isEmpty (Queue q) = (Seq.length q) == 0

enqueueEach :: (Queue a) -> [a] -> Queue a
enqueueEach q ls = foldl (flip enqueue) q ls


wordsSetIO :: IO (Set.Set String)
wordsSetIO = fmap (Set.fromList.words) (readFile "/usr/share/dict/words")
                                                   
type BFSState a b = State (Queue [a], Set.Set a) b

bfsEnqueue :: (Ord a) => [a] -> BFSState a ()
bfsEnqueue (x:xs) = get >>= 
                   (\(q,s) -> if Set.member x s
                              then return ()
                              else put (enqueue (x:xs) q, Set.insert x s))
                               
bfsDequeue :: BFSState a (Maybe [a])
bfsDequeue = get >>=
             \(q,s)->(if isEmpty q then return Nothing  else 
                        let (res,q') = dequeue q in put (q',s) >> (return (Just res)))
                     
breadthFirstSearch :: (Ord a) => (a -> Bool) -> (a -> [a]) -> a -> Maybe [a]
breadthFirstSearch winFun nextsFun x = evalState bfs (enqueue [x] emptyQueue,Set.singleton x)
  where bfs = bfsDequeue >>= 
              \d -> case d of 
                Nothing     -> return Nothing 
                Just (y:ys) -> if winFun y  
                               then return (Just(reverse (y:ys)))
                               else mapM_ (\z->bfsEnqueue (z:y:ys)) (nextsFun y) >> bfs
                                    
replaceAt i a lst = (take i lst) ++ [a] ++ (drop (i+1) lst)                 
wordLadderNext wrd = concatMap (\i-> map (\a->replaceAt i a wrd) ['a'..'z']) [0..(length wrd)-1]
                                    
wordLadder :: Set.Set String -> String -> String -> Maybe [String]
wordLadder wrdst a b =(breadthFirstSearch (==b) 
                       (\wrd -> filter ((flip Set.member) wrdst) (wordLadderNext wrd))
                       a)

wordLadderIOLoop :: IO ()
wordLadderIOLoop = wordsSetIO >>= wll
  where wll wst = putStrLn "What word would you like to do Word Ladder one?" >>                  
                  getLine >>= \a -> getLine >>= \b -> 
                  case wordLadder wst a b of
                    Nothing -> putStrLn "Can't find a word ladder" >> (wll wst)
                    Just (ladder) -> putStrLn "Found it!" >> (mapM_ putStrLn ladder) >> (wll wst)