use Data.Map

This commit is contained in:
hi 2025-08-15 15:20:40 +00:00
parent 87adb51806
commit b0e98b0e51

View file

@ -6,6 +6,9 @@ import Logic.Statement.Parse (stmt)
import Logic.Statement.Serialize (serialize, SerializeFormat(Plain)) import Logic.Statement.Serialize (serialize, SerializeFormat(Plain))
import Logic.Graph (bfs, verifyPath, VerifyPathError) import Logic.Graph (bfs, verifyPath, VerifyPathError)
import Data.Map (Map)
import qualified Data.Map as Map (empty, insert, lookup)
import Data.Either (fromRight, rights) import Data.Either (fromRight, rights)
import Data.Maybe (fromJust, listToMaybe) import Data.Maybe (fromJust, listToMaybe)
@ -72,15 +75,15 @@ match
-- ^ pattern -- ^ pattern
-> Statement -> Statement
-- ^ statement to search within -- ^ statement to search within
-> Maybe [(String, Statement)] -> Maybe (Map String Statement)
-- ^ mapping from pattern-statement atoms to search-statement parts -- ^ mapping from pattern-statement atoms to search-statement parts
match = aux [] match = aux Map.empty
where where
aux aux
:: [(String, Statement)] :: Map String Statement
-> Statement -> Statement
-> Statement -> Statement
-> Maybe [(String, Statement)] -> Maybe (Map String Statement)
aux mapping (Atom key) s = add mapping (key, s) aux mapping (Atom key) s = add mapping (key, s)
aux mapping (Not p) (Not s) = aux mapping p s aux mapping (Not p) (Not s) = aux mapping p s
aux mapping (And p1 p2) (And s1 s2) = binary mapping (p1, s1) (p2, s2) aux mapping (And p1 p2) (And s1 s2) = binary mapping (p1, s1) (p2, s2)
@ -90,21 +93,21 @@ match = aux []
aux mapping pattern s = Nothing aux mapping pattern s = Nothing
add add
:: [(String, Statement)] :: Map String Statement
-> (String, Statement) -> (String, Statement)
-> Maybe [(String, Statement)] -> Maybe (Map String Statement)
add mapping entry@(key, s') = add mapping entry@(key, s') =
case lookup key mapping of case Map.lookup key mapping of
Nothing -> Just (entry:mapping) Nothing -> Just $ Map.insert key s' mapping
Just existing Just existing
| existing == s' -> Just mapping | existing == s' -> Just mapping
| otherwise -> Nothing | otherwise -> Nothing
binary binary
:: [(String, Statement)] :: Map String Statement
-> (Statement, Statement) -> (Statement, Statement)
-> (Statement, Statement) -> (Statement, Statement)
-> Maybe [(String, Statement)] -> Maybe (Map String Statement)
binary mapping (p1, s1) (p2, s2) = do binary mapping (p1, s1) (p2, s2) = do
mapping' <- aux mapping p1 s1 mapping' <- aux mapping p1 s1
aux mapping' p2 s2 aux mapping' p2 s2
@ -142,8 +145,8 @@ swap p1 p2 s = do
mapping <- maybe (Left NonMatchingPattern) Right $ match p1 s mapping <- maybe (Left NonMatchingPattern) Right $ match p1 s
maybe (Left IndeterminateSwap) Right $ aux mapping p2 maybe (Left IndeterminateSwap) Right $ aux mapping p2
where where
aux :: [(String, Statement)] -> Statement -> Maybe Statement aux :: Map String Statement -> Statement -> Maybe Statement
aux mapping (Atom key) = lookup key mapping aux mapping (Atom key) = Map.lookup key mapping
aux mapping (Not p) = Not <$> aux mapping p aux mapping (Not p) = Not <$> aux mapping p
aux mapping (And p1 p2) = And <$> aux mapping p1 <*> aux mapping p2 aux mapping (And p1 p2) = And <$> aux mapping p1 <*> aux mapping p2
aux mapping (Or p1 p2) = Or <$> aux mapping p1 <*> aux mapping p2 aux mapping (Or p1 p2) = Or <$> aux mapping p1 <*> aux mapping p2
@ -190,6 +193,7 @@ data ReplaceError
= IndeterminateReplace = IndeterminateReplace
deriving Show deriving Show
-- Replace pattern p1 with pattern p2 at all possible depths
replace :: Statement -> Statement -> Statement -> Either ReplaceError [Statement] replace :: Statement -> Statement -> Statement -> Either ReplaceError [Statement]
replace p1 p2 = firstLeft . aux replace p1 p2 = firstLeft . aux
where where