Implementing Backtracking on Haskell

Question

I have a problem making Backtracking on Haskell, I know how to do recursive functions but I get troubles when I try to get multiple solutions or the best one (backtracking).

There's a list with some strings, then I need to get the solutions to get from a string to another one changing one letter from the string, I will get the list, the first string and the last one. If there is solution return the count of steps that it did, if there is not solution it returns -1. here's an example:

wordF ["spice","stick","smice","stock","slice","slick","stock"] "spice" "stock"

Then I have my list and I need to start with "spice" and get to "stock" and the best solution is ["spice","slice","slick","stick","stock"] with four steps to get from "spice" to "stock". then it return 4.

Another solution is ["spice","smice","slice","slick","stick","stock"] with five steps to get to "stock" then it return `5. But this is a wrong solution because there's another one that's better with lesser steps than this one.

I'm having troubles making a backtracking to get the best solution, because I don't know how to make that my code search another solutions and just not one..

Here's a code that i tried to make but i get some errors, btw i dont know if my way to "make" backtracking is good or if there are some mistakes that im not seeing..

  wordF :: [String] -> String -> String -> (String, String, Int)
  wordF [] a b = (a, b, -1)
  wordF list a b | (notElem a list || notElem b list) = (a, b, -1)
           | otherwise = (a, b, (wordF2 list a b [a] 0 (length list)))
  wordF2 :: [String] -> String -> String -> [String] -> Int -> Int -> Int
  wordF2 list a b list_aux cont maxi | (cont==maxi) = 1000
                               | (a==b) = length list_aux
                               | (a/=b) && (cont<maxi) && notElemFound && (checkin /= "ThisWRONG") && (wording1<=wording2) = wording1
                               | (a/=b) && (cont<maxi) && notElemFound && (checkin /= "ThisWRONG") && (wording1>wording2) = wording2
                               | (a/=b) && (checkin == "ThisWRONG") = wordF2 list a b list_aux (cont+1) maxi
                               where 
                               checkin = (check_word2 a (list!!cont) (list!!cont) 0)
                               wording1 = (wordF2 list checkin b (list_aux++[checkin]) 0 maxi)
                               wording2 = (wordF2 list checkin b (list_aux++[checkin]) 1 maxi)
                               notElemFound = ((any (==(list!!cont)) list_aux) == False)
 check_word2 :: String -> String -> String -> Int -> String
 check_word2 word1 word2 word3 dif | (dif > 1) = "ThisWRONG"
                              | ((length word1 == 1) && (length word2 == 1) && (head word1 == head word2)) = word3
                              | ((length word1 == 1) && (length word2 == 1) && (head word1 /= head word2) && (dif<1)) = word3
                              | ((head word1) == (head word2)) = check_word2 (tail word1) (tail word2) word3 dif
                              | otherwise = check_word2 (tail word1) (tail word2) word3 (dif+1)

My first function wordF2 get the list, the start, the end, an auxiliary list to get the current solution with the first element that always will be there ([a]), a counter with 0, and the max size of the counter (length list)..

and the second function check_word2 it checks if a word can pass to another word, like "spice" to "slice" if it cant like "spice" to "spoca" it returns "ThisWRONG".

This solution gets an error of pattern match failure

  Program error: pattern match failure: wordF2 ["slice","slick"] "slice" "slick" ["slice"] 0 1

I was trying with little cases and nothing, and I'm restricting that i get a wrong position of the list with the count and the max.

Or may be I dont know how to implement backtracking on haskell to get multiple solutions, the best solution, etc..

UPDATE: I did a solution but its not backtracking

wordF :: [String] -> String -> String -> (String, String, Int)
wordF [] a b = (a, b, -1)
wordF list a b | (notElem a list || notElem b list) = (a, b, -1)
           | otherwise = (a, b, (wordF1 list a b))

wordF1 :: [String] -> String -> String -> Int
wordF1 list a b | ((map length (wordF2 (subconjuntos2 (subconjuntos list) a b))) == []) = -1
            | (calculo > 0) = calculo
            | otherwise = -1
             where
             calculo = (minimum (map length (wordF2 (subconjuntos2 (subconjuntos list) a b))))-1

wordF2 :: [[String]] -> [[String]]
wordF2 [[]] = []
wordF2 (x:xs) | ((length xs == 1) && ((check_word x) == True) && ((check_word (head xs)) == True)) = x:xs
          | ((length xs == 1) && ((check_word x) == False) && ((check_word (head xs)) == True)) = xs
          | ((length xs == 1) && ((check_word x) == True) && ((check_word (head xs)) == False)) = [x]
          | ((length xs == 1) && ((check_word x) == False) && ((check_word (head xs)) == False)) = []
          | ((check_word x) == True) = x:wordF2 xs
          | ((check_word x) == False ) = wordF2 xs

check_word :: [String] -> Bool
check_word [] = False
check_word (x:xs) | ((length xs == 1) && ((check_word2 x (head xs) 0) == True)) = True
              | ((length xs >1) && ((check_word2 x (head xs) 0) == True)) = True && (check_word xs)
              | otherwise = False 

check_word2 :: String -> String -> Int -> Bool
check_word2 word1 word2 dif | (dif > 1) = False
                        | ((length word1 == 1) && (length word2 == 1) && (head word1 == head word2)) = True
                        | ((length word1 == 1) && (length word2 == 1) && (head word1 /= head word2) && (dif<1)) = True
                        | ((head word1) == (head word2)) = check_word2 (tail word1) (tail word2) dif
                        | otherwise = check_word2 (tail word1) (tail word2) (dif+1)

subconjuntos2 :: [[String]] -> String -> String -> [[String]]
subconjuntos2 [] a b     = []
subconjuntos2 (x:xs) a b | (length x <= 1) = subconjuntos2 xs a b
                     | ((head x == a) && (last x == b)) = (x:subconjuntos2 xs a b)
                     | ((head x /= a) || (last x /= b)) = (subconjuntos2 xs a b)

subconjuntos :: [a] -> [[a]]
subconjuntos []     = [[]]
subconjuntos (x:xs) = [x:ys | ys <- sub] ++ sub
where sub = subconjuntos xs

Mmm may be its inefficient but at least it does the solution.. i search all posible solutions, i compare head == "slice" and last == "stock", then i filter the ones that are solution and print the shorter one, thanks and if you guys have any suggest say it :)

Answer 1

Not thoroughly tested, but this hopefully will help:

import Data.Function (on)
import Data.List (minimumBy, delete)
import Control.Monad (guard)

type Word = String
type Path = [String]

wordF :: [Word] -> Word -> Word -> Path
wordF words start end = 
    start : minimumBy (compare `on` length) (generatePaths words start end)

-- Use the list monad to do the nondeterminism and backtracking.
-- Returns a list of all paths that lead from `start` to `end` 
-- in steps that `differByOne`.
generatePaths :: [Word] -> Word -> Word -> [Path]
generatePaths words start end = do
  -- Choose one of the words, nondeterministically
  word <- words

  -- If the word doesn't `differByOne` from `start`, reject the choice
  -- and backtrack.
  guard $ differsByOne word start

  if word == end
  then return [word]
  else do 
        next <- generatePaths (delete word words) word end
        return $ word : next

differsByOne :: Word -> Word -> Bool
differsByOne "" "" = False
differsByOne (a:as) (b:bs) 
    | a == b = differsByOne as bs
    | otherwise = as == bs

Example run:

>>> wordF ["spice","stick","smice","stock","slice","slick","stock"] "spice" "stock"
["spice","slice","slick","stick","stock"]

The list monad in Haskell is commonly described as a form of nondeterministic, backtracking computation. What the code above is doing is allowing the list monad to take on the responsibility of generating alternatives, testing whether they satisfy criteria, and backtracking on failure to the most recent choice point. The bind of the list monad, e.g. word <- words, means "nondeterministically pick one of the words. guard means "if the choices so far don't satisfy this condition, backtrack and make a different choice. The result of a list monad computation is the list of all the results that stem from choices that did not violate any guards.

If this looks like list comprehensions, well, list comprehensions are the same thing as the list monad—I chose to express it with the monad instead of comprehensions.

Answer 2

There have been several articles published recently on classic brute-force search problems.

• Mark Dominus published a simple example of using lists for a simple exhaustive search.
• Justin Le followed up with a small modification to the previous article that simplified tracking the current state of the search.
• I followed up with a further modification that allowed measuring the gains from early rejection of part of the search tree.

Note that the code in my article is quite slow because it's measuring the amount of work done as well as doing it. My article has good examples for how to quickly reject parts of the search tree, but it should be considered only an illustration - not production code.

Answer 3

A brute force approach using recursion:

import Data.List (filter, (\\), reverse, delete, sortBy)
import Data.Ord  (comparing)

neighbour :: String -> String -> Bool
neighbour word = (1 ==) . length . (\\ word)

process :: String -> String -> [String] -> [(Int, [String])]
process start end dict = 
  let 
    loop :: String -> String -> [String] -> [String] -> [(Int,[String])] -> [(Int,[String])]
    loop start end dict path results = 
      case next of
        [] -> results
        xs ->
          if   elem end xs
          then (length solution, solution) : results
          else results ++ branches xs
      where
        next        = filter (neighbour start) dict'
        dict'       = delete start dict
        path'       = start : path
        branches xs = [a | x <- xs, a <- loop x end dict' path' results]
        solution    = reverse (end : path')
  in
  loop start end dict [] []

shortestSolution :: Maybe Int
shortestSolution = shortest solutions
  where 
    solutions  = process start end dict
    shortest s = 
      case s of
        [] -> Nothing
        xs -> Just $ fst $ head $ sortBy (comparing fst) xs

start = "spice"
end   = "stock"
dict  = ["spice","stick","smice","slice","slick","stock"]

Notes:

• This code computes all possibles solutions (process) and select the shortest one (shortestSolution), as Carl said, you might want to prune parts of the search tree for better performance.

• Using a Maybe instead of returning -1 when a function can fail to return results is preferred.

---

Another way using a tree with breadth-first search:

import Data.Tree
import Data.List( filter, (\\), delete )
import Data.Maybe

node :: String -> [String] -> Tree String
node label dict = Node{ rootLabel = label, subForest = branches label (delete label dict) }

branches :: String -> [String] -> [Tree String]
branches start dict = map (flip node dict) (filter (neighbour start) dict)

neighbour :: String -> String -> Bool
neighbour word = (1 ==) . length . (\\ word)

-- breadth first traversal
shortestBF tree end = find [tree] end 0
  where 
    find ts end depth 
      | null ts = Nothing
      | elem end (map rootLabel ts) = Just depth
      | otherwise = find (concat (map subForest ts)) end (depth+1)

result = shortestBF tree end

tree :: Tree String
tree = node start dict

start = "spice"
end   = "stock"
dict  = ["spice","stick","smice","slice","slick","stock"]