{- - Simple, unoptimized regex inverter - Given a regex like .*(hi|t).*, will output a - grep command that matches its opposite (without -v) - - By Vidar Holen, 2012 - http://www.vidarholen.net -} import Control.Monad.State import Text.ParserCombinators.Parsec hiding (State) import Data.List import Debug.Trace import Maybe data Node = Node String deriving (Show, Eq, Ord) data Edge = Edge Node Node String deriving (Show, Eq) -- Graph Nodes Edges Initial Final data Graph = Graph [Node] [Edge] String [String] deriving (Show, Eq) data Element = Atom String | Choice [Element] | Group [Element] | Repeat Element deriving (Show, Eq) -- Accessor stuff edgeSource (Edge a _ _) = a edgeTarget (Edge _ a _) = a edgeString (Edge _ _ a) = a graphNodes (Graph a _ _ _) = a graphEdges (Graph _ a _ _) = a graphInitialNode (Graph nodes _ s _) = head $ filter (\x -> (nodeName x) == s) nodes graphFinalNodes (Graph nodes _ _ s) = filter (\x -> (nodeName x) `elem` s) nodes graphFinals (Graph nodes _ _ s) = s nodeName (Node a) = a -- Regex parsing stuff allChars = ['a'..'z'] invert s = filter (not . (flip elem) s) allChars normalize = sort . filter ((flip elem) allChars) parseAtomDot = do x <- char '.' return (Atom allChars) parseAtomSingle = do x <- oneOf allChars return (Atom [x]) parseAtomGroup = do char '[' f <- optionMaybe (char '^') s <- many1 (oneOf allChars) char ']' return $ case f of Nothing -> Atom s Just _ -> Atom (invert s) parseAtom = parseAtomDot <|> parseAtomSingle <|> parseAtomGroup parseGrouping = do char '(' x <- parseChoice char ')' return $ x parseSingleElement = parseAtom <|> parseGrouping parseElement = do x <- parseSingleElement r <- optionMaybe (char '*') return $ case r of Nothing -> x Just _ -> Repeat x parseGroup :: GenParser Char st Element parseGroup = do x <- many parseElement return $ Group x parseChoice :: GenParser Char st Element parseChoice = do x <- sepBy parseGroup (char '|') return $ Choice x parseRegex = fmap fullSimplify $ do { a <- parseChoice; eof; return a; } simplify (Group [x]) = simplify x simplify (Choice [x]) = simplify x simplify (Repeat (Choice xs)) = case simplify (Choice xs) of Choice sxs -> Repeat . Choice . filter (/= Group []) $ sxs f -> Repeat f simplify (Repeat x) = Repeat $ simplify x simplify (Group l) = Group $ map simplify l simplify (Choice l) = Choice $ map simplify l simplify (Atom f) = Atom (normalize f) fullSimplify = fixedPoint simplify stuff s = parse parseRegex "stuff" s reToString :: Element -> String reToString (Choice xs) = "(" ++ (concat . intersperse "|" $ map reToString xs) ++ ")" reToString (Repeat x) = reToString x ++ "*" reToString (Group xs) = "(" ++ (concatMap reToString xs) ++ ")" reToString (Atom f) = lettersToRE f simplifyRegex s = do x <- parse parseRegex "input" s return $ reToString x --------- newGraph = let first = makeNode 0 in Graph [first] [] (nodeName first) [] newNode :: State Graph Node newNode = do n <- get let (Graph nodes edges s ss) = n; node = makeNode (length nodes) in do put (Graph (node:nodes) edges s ss) return node addNode :: Node -> State Graph Node addNode v = do n <- get let (Graph nodes edges s ss) = n in do put (Graph (v:nodes) edges s ss) return v markFinal (Node s) = do modify (\(Graph nodes edges is ss) -> (Graph nodes edges is (nub $ s:ss))) connect :: Node -> Node -> String -> State Graph () connect a b s= do n <- get let (Graph nodes edges s1 ss) = n in put (Graph nodes ((Edge a b s):edges) s1 ss) return () makeNode n = Node $ "N"++(show n) buildnfa :: Node -> Element -> State Graph Node buildnfa x (Atom s) = do n <- newNode connect x n s return n buildnfa x (Group l) = foldM buildnfa x l buildnfa x (Choice l) = do n <- newNode list <- mapM (buildnfa x) l mapM (\x -> connect x n "") list return n buildnfa x (Repeat m) = do last <- buildnfa x m connect last x "" return x unique = nub --unique [] = [] --unique (a:r) = a : (filter (/= a) r) nfa x = let (final, (Graph a b s ss)) = runState (buildnfa (graphInitialNode newGraph) x) newGraph in Graph a b s (nodeName final:ss) reToNfa :: String -> Maybe Graph reToNfa s = case (stuff s) of (Right x) -> Just (nfa x) (Left y) -> Nothing normalizeGraph :: Graph -> Graph normalizeGraph (Graph nodes edges s ss) = (Graph (unique nodes) (mergeEdges edges) s (sort . nub $ ss)) mergeEdges [] = [] mergeEdges ((Edge from to s):r) = let (same, other) = partition (\(Edge a b _) -> a==from && b==to) r in (Edge from to (normalize $ concat (s:(map edgeString same)))):(mergeEdges other) -- Printing stuff printGraph f@(Graph nodes edges _ _) = "digraph G { \n" ++ (printNodes f) ++ (unlines . map printEdge $ edges) ++"}" printEdge (Edge (Node a) (Node b) c) = a ++ " -> " ++ b ++ " [label=\"" ++ (if c == "" then "eps" else c) ++"\"] " printNodes g = let finals = concatMap (\(Node a) -> a ++ "[shape=doublecircle];\n") (graphFinalNodes g) initial = (nodeName $ graphInitialNode g) ++ "[shape=octagon];\n" in initial ++ finals -- Epsilon elimination f2States f1@(Graph nodes edges initial finals) = nub $ (Node initial) : (map edgeTarget $ filter (\x -> (edgeString x) /= "") edges) f2Finals f1@(Graph nodes edges initial finals) = nub $ map fst $ filter (not . null . intersect finals . snd) $ map (\x -> (x, map nodeName $ epsilonNeighbors f1 x)) nodes epsilonElimination :: Graph -> Graph epsilonElimination f1 = let states = f2States f1 finals = map nodeName $ intersect (f2Finals f1) states in Graph states (catMaybes $ map (uncurry (findEdge f1)) $ getPairs states states) (nodeName $ graphInitialNode f1) finals findEdge :: Graph -> Node -> Node -> Maybe Edge findEdge f1 source target = let string = epsilonNeighbors f1 source >>= (\neighbor -> filter (\y -> edgeTarget y == target && edgeSource y == neighbor) (graphEdges f1)) >>= (\x -> edgeString x) in if string == "" then Nothing else Just (Edge source target (normalize string)) -- Epsilon base stuff directEpsilonNeighbors :: Graph -> Node -> [Node] directEpsilonNeighbors (Graph _ edges _ _) node = map (\(Edge _ b _) -> b) $ filter (\(Edge a b c) -> c == "" && a == node) $ edges fixedPoint :: (Eq a) => (a -> a) -> a -> a fixedPoint f x = let x' = f x in if x == x' then x else fixedPoint f x' reachableNeighbors graph nodes = nub $ nodes ++ (concatMap (\x -> directEpsilonNeighbors graph x) nodes) epsilonNeighbors g x = fixedPoint (reachableNeighbors g) [x] getPairs l1 l2 = do x <- l1 y <- l2 return (x,y) -- Add failure state addFailState :: Graph -> Graph addFailState (Graph nodes edges start finish) = Graph ((Node "FAIL"):nodes) (edges++failures) start finish where failures = (Edge (Node "FAIL") (Node "FAIL") allChars):(concatMap findFailure nodes) findEdges v = filter (\(Edge from to label) -> from == v) edges valids = concatMap (\(Edge _ _ s) -> s) . findEdges invalids = invert . valids findFailure v = case invalids v of "" -> []; s -> [Edge v (Node "FAIL") s] -- NFA to DFA nfaToDfa :: Graph -> Graph nfaToDfa graph = let firstNode = graphInitialNode graph (result, state) = runState (buildDfa [firstNode] graph) (Graph [firstNode] [] (nodeName firstNode) []) in state buildDfa :: [Node] -> Graph -> State Graph () buildDfa nodes graph = do forM allChars (\x -> followDfa x nodes graph) return () followDfa c nodes graph = do x <- haveTried c nodes if x then return () else let next = reachables c nodes graph in if next == [] then return () else let thisState = stateFor nodes; nextState = stateFor next in do addNode thisState addNode nextState when (isFinal nodes (graphFinals graph)) (markFinal thisState) when (isFinal next (graphFinals graph)) (markFinal nextState) connect thisState nextState [c] buildDfa next graph haveTried c nodes = do (Graph _ edges _ _) <- get return (any (\(Edge f _ s) -> s == [c] && f == (stateFor nodes)) edges) isFinal nodelist finals = any (\x -> x `elem` finals) $ map nodeName nodelist stateFor nodes = Node $ intercalate "_" (map nodeName . sort . nub $ nodes ) reachables c nodes graph = sort . nub $ concatMap (\x -> reachable c x graph) nodes where reachable c node (Graph _ edges _ _) = map edgeTarget $ filter (\x -> (edgeSource x == node) && c `elem` edgeString x) edges -- DFA to RE baseREGraph :: Graph -> Graph baseREGraph (Graph nodes edges start end) = Graph nodes (map (\x -> changeEdgeString x (lettersToRE $ edgeString x)) edges) start end getRE g = let s0 = graphInitialNode g finals = graphFinalNodes g in intercalate "|" $ map (\x -> getREFor s0 x g) finals getREFor s0 sF g = let graph = eliminateFor s0 sF $ baseREGraph g edges = graphEdges graph r1 = edgesByEndpoints edges s0 s0 r2 = edgesByEndpoints edges s0 sF r3 = edgesByEndpoints edges sF sF r4 = edgesByEndpoints edges sF s0 r1s = if null r1 then "" else (paren $ getEdgeRE r1) ++ "*" r2s = if null r2 then error "no possible solution" else (paren $ getEdgeRE r2) r3s = if null r3 then "" else (paren $ getEdgeRE r3) ++ "|" r4s = if null r4 then "" else (paren $ getEdgeRE r4) ++ r1s ++ r2s rs = r1s ++ r2s ++ (if null r3s && null r4s then "" else (paren (r3s ++ r4s)) ++ "*" ) in if s0 == sF then r1s else rs eliminateFor s0 sF graph = let otherNodes = filter (\x -> x /= s0 && x /= sF) (graphNodes graph) killedGraph = foldr eliminate graph otherNodes in killedGraph eliminate :: Node -> Graph -> Graph --eliminate node graph | trace ("Eliminating " ++ (show node) ++ "\n" ++ (show graph)) False = error "cow" eliminate node graph = let otherNodes = filter (/= node) $ graphNodes graph; pairs = getPairs otherNodes otherNodes in foldr (\(f,t) g -> reroute f t node g) graph pairs reroute from to node graph@(Graph n e s ss) = let edges = graphEdges graph r1 = edgesByEndpoints edges from node r2 = edgesByEndpoints edges node node r3 = edgesByEndpoints edges node to r4 = edgesByEndpoints edges from to in if null r1 || null r3 then graph else Graph (filter (/= node) n) ((Edge from to $ makeEdgeString r1 r2 r3 r4):(killEdges e from to node)) s (filter (/= (nodeName node)) ss) makeEdgeString r1 r2 r3 r4 = let mainString = (paren $ getEdgeRE r1) ++ (if null r2 then "" else (paren $ getEdgeRE r2) ++ "*") ++ (paren $ getEdgeRE r3) in mainString ++ if null r4 then "" else "|" ++ (paren $ getEdgeRE r4) paren :: String -> String --paren x = "(" ++ x ++ ")" paren x = if needsParen x then "(" ++ x ++ ")" else x needsParen s = case parse (parseSingleElement >> eof) "" s of Right x -> False Left x -> True getEdgeRE [] = error "no edges to make RE from" --getEdgeRE [x] = edgeString x getEdgeRE xs = intercalate "|" $ map edgeString xs --getEdgeRE xs = "(" ++ (intercalate "|" $ map edgeString xs) ++ ")" -- killEdges edges _ _ _ = edges killEdges edges from to node = killEdges' from to edges -- $ killEdges' from node $ (const id $ killEdges' node to) $ edges where killEdges' from to edges = filter (not . \(Edge a b _) -> a == from && b == to) edges --edgesByEndpoints edges from to = let foo = edgesByEndpoints' edges from to in trace ((show from) ++ " -> " ++ (show to) ++ ": " ++ (show foo)) foo edgesByEndpoints edges from to = filter (\(Edge a b s) -> a == from && b == to) edges changeEdgeString (Edge from to string) newString = Edge from to newString lettersToRE [x] = [x] lettersToRE x | x == allChars = "." lettersToRE x | (length allChars) - (length x) < (length allChars) `div` 2 = "[^" ++ (invert x) ++ "]" lettersToRE s = "["++s++"]" -- Invert DFA invertDfa (Graph nodes edges init finals) = Graph nodes edges init ((nub $ map nodeName nodes) \\ finals) -- Lol fromRight (Right a) = a -- The good stuff safeMakeDfa = fmap (normalizeGraph . nfaToDfa . addFailState . epsilonElimination) . reToNfa makeDfa = fromJust . safeMakeDfa invertRE = fmap (getRE . invertDfa) . safeMakeDfa grepAntiRE x = fmap (\s -> "^(" ++ s ++ ")$") $ invertRE x simpleGrepAntiRE x = "^" ++ (fromRight $ simplifyRegex . fromJust $ invertRE x) ++ "$" -- Test stuff graph2 = Graph [Node "N0", Node "N1", Node "N2"] [Edge (Node "N0") (Node "N2") "t", Edge (Node "N0") (Node "N1") "", Edge (Node "N1") (Node "N2") "a"] "N0" ["N2"] graph = fromJust $ reToNfa "ab.*c|de*" ngraph = epsilonElimination graph dgraph = nfaToDfa ngraph ndgraph = normalizeGraph dgraph showGraph = putStrLn . printGraph halfgraph = foldr (\x g -> eliminate (Node x) g) (baseREGraph ndgraph) ["N7", "N6", "N4", "N3", "N2"] main = do putStrLn "Enter an implicitly anchored regular expression" putStrLn "matching only lowercase letters, such as .*hi.*" x <- getLine case invertRE x of Just re -> putStrLn $ "grep -E '^(" ++ (re) ++ ")$'" Nothing -> putStrLn $ "No parse"