Is there any way to not use explicit recursion in this algorithm?

Question

So the problem I'm working on matching a pattern to a list, such like this: match "abba" "redbluebluered" -> True or match "abba" "redblueblue" -> False, etc. I wrote up an algorithm that works, and I think it's reasonable understandable, but I'm not sure if there's a better way to do this without explicit recursion.

import Data.HashMap.Strict as M
match :: (Eq a, Eq k, Hashable k) => [k] -> [a] -> HashMap k [a] -> Bool
match []     [] _ = True
match []     _  _ = False
match _      [] _ = False
match (p:ps) s  m =
  case M.lookup p m of
    Just v ->
      case stripPrefix v s of
        Just post -> match ps post m
        Nothing   -> False
    Nothing -> any f . tail . splits $ s
      where f (pre, post) = match ps post $ M.insert p pre m
            splits xs = zip (inits xs) (tails xs)

I would call this like match "abba" "redbluebluered" empty. The actual algorithm is simple. The map contains the patterns already matched. At the end it is [a - > "red", b -> "blue"]. If the next pattern is one we've seen before, just try matching it and recurse down if we can. Otherwise fail and return false.

If the next pattern is new, just try mapping the new pattern to every single prefix in the string and recursing down.

Answer 1

This is very similar to a parsing problem, so let's take a hint from the parser monad:

• match should return a list of all of the possible continuations of the parse
• if matching fails it should return the empty list
• the current set of assignments will be state that has to carried through the computation

To see where we are headed, let's suppose we have this magic monad. Attempting to match "abba" against a string will look like:

matchAbba = do
  var 'a'
  var 'b'
  var 'b'
  var 'a'
  return ()  -- or whatever you want to return

test = runMatch matchAbba "redbluebluered"

It turns out this monad is the State monad over the List monad. The List monad provides for backtracking and the State monad carries the current assignments and input around.

Here's the code:

import Data.List
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans
import Data.Maybe
import qualified Data.Map as M
import Data.Monoid

type Assigns = M.Map Char String

splits xs = tail $ zip (inits xs) (tails xs)

var p = do
  (assigns,input) <- get
  guard $ (not . null) input
  case M.lookup p assigns of
    Nothing -> do (a,b) <- lift $ splits input
                  let assigns' = M.insert p a assigns
                  put (assigns', b)
                  return a
    Just t  -> do guard $ isPrefixOf t input
                  let inp' = drop (length t) input
                  put (assigns, inp')
                  return t

matchAbba :: StateT (Assigns, String) [] Assigns
matchAbba = do
  var 'a'
  var 'b'
  var 'b'
  var 'a'
  (assigns,_) <- get
  return assigns

test1 = evalStateT matchAbba (M.empty, "xyyx") 
test2 = evalStateT matchAbba (M.empty, "xyy") 
test3 = evalStateT matchAbba (M.empty, "redbluebluered") 

matches :: String -> String -> [Assigns]
matches pattern input = evalStateT monad (M.empty,input)
  where monad :: StateT (Assigns, String) [] Assigns
        monad = do sequence $ map var pattern
                   (assigns,_) <- get
                   return assigns

Try, for instance:

matches "ab" "xyz"
-- [fromList [('a',"x"),('b',"y")],fromList [('a',"x"),('b',"yz")],fromList [('a',"xy"),('b',"z")]]

Another thing to point out is that code which transforms a string like "abba" to the monadic value do var'a'; var'b'; var 'b'; var 'a' is simply:

sequence $ map var "abba"

Update: As @Sassa NF points out, to match the end of input you'll want to define:

matchEnd :: StateT (Assigns,String) [] ()
matchEnd = do
  (assigns,input) <- get
  guard $ null input

and then insert it into the monad:

        monad = do sequence $ map var pattern
                   matchEnd
                   (assigns,_) <- get
                   return assigns

Answer 2

Here is another solution, more readable, I think, and as inefficient as other solutions:

import Data.Either
import Data.List
import Data.Maybe
import Data.Functor

splits xs = zip (inits xs) (tails xs)

subst :: Char -> String -> Either Char String -> Either Char String
subst p xs (Left q) | p == q = Right xs
subst p xs       q           = q

match' :: [Either Char String] -> String -> Bool
match'            []  [] = True
match' (Left  p : ps) xs = or [ match' (map (subst p ixs) ps) txs
                              | (ixs, txs) <- tail $ splits xs]
match' (Right s : ps) xs = fromMaybe False $ match' ps <$> stripPrefix s xs
match'            _   _  = False

match = match' . map Left

main = mapM_ (print . uncurry match)
    [ ("abba"    , "redbluebluered"                    ) -- True
    , ("abba"    , "redblueblue"                       ) -- False
    , ("abb"     , "redblueblue"                       ) -- True
    , ("aab"     , "redblueblue"                       ) -- False
    , ("cbccadbd", "greenredgreengreenwhiteblueredblue") -- True
    ]

The idea is simple: instead of having a Map, store both patterns and matched substrings in a list. So when we encounter a pattern (Left p), then we substitute all occurrences of this pattern with a substring and call match' recursively with this substring being striped, and repeat this for each substring, that belongs to inits of a processed string. If we encounter already matched substring (Right s), then we just try to strip this substring, and call match' recursively on a successive attempt or return False otherwise.

Answer 3

I would like to modify your signature and return more than Bool. Your solution then becomes:

match :: (Eq a, Ord k) => [k] -> [a] -> Maybe (M.Map k [a])
match = m M.empty where
  m kvs (k:ks) vs@(v:_) = let splits xs = zip (inits xs) (tails xs)
                           f (pre, post) t =
                               case m (M.insert k pre kvs) ks post of
                                 Nothing -> t
                                 x       -> x
                          in case M.lookup k kvs of
                                Nothing -> foldr f Nothing . tail . splits $ vs
                                Just p -> stripPrefix p vs >>= m kvs ks
  m kvs [] [] = Just kvs
  m _   _  _  = Nothing

Using the known trick of folding to produce a function we can obtain:

match ks vs = foldr f end ks M.empty vs where
  end m [] = Just m
  end _ _  = Nothing
  splits xs = zip (inits xs) (tails xs)
  f k g kvs vs = let h (pre, post) = (g (M.insert k pre kvs) post <|>)
                 in case M.lookup k kvs of
                   Nothing -> foldr h Nothing $ tail $ splits vs
                   Just p  -> stripPrefix p vs >>= g kvs

Here match is the function folding all keys to produce a function taking a Map and a string of a, which returns a Map of matches of the keys to substrings. The condition for matching the string of a in its entirety is tracked by the last function applied by foldr - end. If end is supplied with a map and an empty string of a, then the match is successful.

The list of keys is folded using function f, which is given four arguments: the current key, the function g matching the remainder of the list of keys (i.e. either f folded, or end), the map of keys already matched, and the remainder of the string of a. If the key is already found in the map, then just strip the prefix and feed the map and the remainder to g. Otherwise, try to feed the modified map and remainder of as for different split combinations. The combinations are tried lazily as long as g produces Nothing in h.