Haskell recursive datatype with state

Question

I am trying to work out how to calculate the following.

given a root value, find all values that begin with last character of that value. Obviously no element can be repeated if it is already used in the path. Find the max depth (longest route)

so for example with the seed "sip" and words:

t1 = ["sour","piss","rune","profit","today","rat"]

we would see that the max path is 5.

 siP 1 ---
  |       |
  |       |
  pisS 2  profiT 2
  |       |
  |       |
  |       todaY 3
  | 
  souR 3 ---
  |        |
  |        |
  runE 4   raT 4
           |
           |
           todaY 5

I think I am on the right track with the following - but I can not work out how to actually recursively call it.

type Depth = Int
type History = Set.Set String
type AllVals = Set.Set String
type NodeVal = Char

data Tree a h d = Empty | Node a h d [Tree a h d] deriving (Show, Read, Eq, Ord)

singleton :: String -> History -> Depth -> Tree NodeVal History Depth
singleton x parentSet depth = Node (last x) (Set.insert x parentSet) (depth + 1) [Empty]

makePaths :: AllVals -> Tree NodeVal History Depth -> [Tree NodeVal History Depth]
makePaths valSet (Node v histSet depth trees) = newPaths
    where paths = Set.toList $ findPaths valSet v histSet
          newPaths = fmap (\x -> singleton x histSet depth) paths

findPaths :: AllVals -> NodeVal -> History -> History
findPaths valSet v histSet = Set.difference possible histSet
    where possible = Set.filter (\x -> head x == v) valSet

so...

setOfAll = Set.fromList xs
tree = singleton "sip" (Set.empty) 0

Node 'p' (fromList ["sip"]) 1 [Empty]


makePaths setOfAll tree

gives:

[Node 's' (fromList ["piss","sip"]) 2 [Empty],Node 't' (fromList ["profit","sip"]) 2 [Empty]]

but now I can not work out how to continue.

Answer 1

You need to actually continue recursively. In your code as it is now, makePaths calls findPaths but neither findPaths nor makePaths ever calls makePaths or findPaths recursively. It's a bit hard to see the mechanics of the algorithm, too, for two reasons: first, you're annotating the tree with a lot of temporary state and, second, you're dealing unnecessarily with Sets.

Let's strip some of that stuff away.

---

Let's begin with the tree. Ultimately, we only need an n-ary tree which has values at nodes.

data Tree a = Empty | Node a [Tree a] deriving (Show, Read, Eq, Ord)

To be clear, this Tree is equivalent to your Tree

type OldTree a h d = Tree (a, h, d)

That said, since the ultimate goal tree is one that's only decorated at the nodes with Strings we're going to aim for a function like this:

makeTree :: String -> [String] -> Tree String

Here, the first string is the seed value, the list of strings are the possible continuation strings remaining, and the tree is our fully-built tree of strings. The function can be written directly, too. It proceeds recursively based off the fact that given a seed we immediately know the root of our tree:

makeTree seed vals = Node seed children where
  children = ...

The children proceed recursively by building their own subtrees. This is an exact copy of the algorithm we've run so far, except we use the strings in vals as new seeds. To do this, we'd like an algorithm that splits a list into a list of "selected values". Something like

selectEach :: [a] -> [(a, [a])]

such that for each value (c, extras) such that elem (c, extras) (selectEach lst) the list c:extras has all the same values as lst if perhaps in a different order. I'm going to write this function a little differently, however, as

selectEach :: [a] -> [([a], a, [a])]

where the results are broken into three pieces such that if (before, here, after) is a value where elem (before, here, after) (selectEach lst) then lst == reverse before ++ [here] ++ after. This will turn out to be a little easier

selectEach []     = []
selectEach (a:as) = go ([], a, as) where
  go (before, here, [])    = [(before, here, [])]
  go (before, here, after@(a:as)) = (before, here, after) : go (here:before, a, as)

> selectEach "foo"
[("",'f',"oo"),("f",'o',"o"),("of",'o',"")]

with this auxiliary function we can easily generate children of our tree, however we will end up creating too many.

makeTree seed vals = Node seed children where
  children = map (\(before, here, after) -> makeTree here (before ++ after)) 
                 (selectEach vals)

Way too many in fact. If we were to run

makeTree "sip" ["sour","piss","rune","profit","today","rat"]

we're produce a tree of size 1957 instead of the nice handy tree of size 8 we'd like. This is because we've so far elided the constraint that the last letter in the seed must be the first letter in the value chosen to continue on. We'll fix that by filtering out bad trees.

goodTree :: String -> Tree String -> Bool

In particular, we'll call a tree "good" if it follows this constraint. Given a seed value, if the root node of the tree has a value whose first letter is the same as the last letter of the seed then it is good.

goodTree []   _              = False
goodTree seed Empty          = False
goodTree seed (Node "" _)    = False
goodTree seed (Node (h:_) _) = last seed == h

and we'll simply filter the children based on this criterium

makeTree seed vals = Node seed children where
  children = 
    filter goodTree
    $ map (\(before, here, after) -> makeTree here (before ++ after)) 
    $ selectEach 
    $ vals

And now we're done!

> makeTree "sip" ["sour","piss","rune","profit","today","rat"]
Node "sip" 
  [ Node "piss" [ Node "sour" [ Node "rune" []
                              , Node "rat" [ Node "today" [] ]
                              ]
                ]
  , Node "profit" [ Node "today" [] ]
  ]

The complete code is:

selectEach :: [a] -> [([a], a, [a])]
selectEach []     = []
selectEach (a:as) = go ([], a, as) where
  go (before, here, [])    = [(before, here, [])]
  go (before, here, after@(a:as)) = (before, here, after) : go (here:before, a, as)

data Tree a = Empty | Node a [Tree a] deriving Show

goodTree :: Eq a => [a] -> Tree [a] -> Bool
goodTree []   _              = False
goodTree seed Empty          = False
goodTree seed (Node [] _)    = False
goodTree seed (Node (h:_) _) = last seed == h

makeTree :: Eq a => [a] -> [[a]] -> Tree [a]
makeTree seed vals = Node seed children where
  children =
    filter (goodTree seed)
    $ map (\(before, here, after) -> makeTree here (before ++ after))
    $ selectEach
    $ vals

And it'd be worth reading up on how selectEach uses what's called a list zipper and how makeTree is operating in the Reader monad. Both of those are intermediate topics which solidify the methods I used here.