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.
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 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'
do var'a'; var'b'; var 'b'; var 'a'
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
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 (ie 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 a
s for different split combinations. The combinations are tried lazily as long as g
produces Nothing
in h
.
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.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.