Experiment with symbol name simplification
This commit is contained in:
Joscha
parent
7ea64c86b7
commit
2bacb8f9d6
1 changed files with 84 additions and 12 deletions
96
lambda.hs
96
lambda.hs
|
|
@ -32,6 +32,10 @@ instance (Show s) => Show (Expression s) where
|
|||
show (EExpr a b) = "(" ++ show a ++ " " ++ show b ++ ")"
|
||||
show (ELambda s e) = "\\" ++ show s ++ "." ++ show e
|
||||
|
||||
showTopLevel :: (Show s) => Expression s -> String
|
||||
showTopLevel e@(EExpr _ _) = tail . init . show $ e
|
||||
showTopLevel e = show e
|
||||
|
||||
{-
|
||||
Apply a function
|
||||
Insert an expression into another expression:
|
||||
|
|
@ -39,10 +43,20 @@ Insert an expression into another expression:
|
|||
change all symbols within that expression to be unique in the expression's new context
|
||||
simplify all symbols
|
||||
-}
|
||||
simplifyExpr :: [(Symbol, Symbol)] -> [Symbol] -> Expression Symbol -> Expression Symbol
|
||||
simplifyExpr mapping context (ESymbol s) = ESymbol $ fromMaybe (findName context s) $ lookup s mapping
|
||||
simplifyExpr mapping context (EExpr a b) = EExpr (simplifyExpr mapping context a) (simplifyExpr mapping context b)
|
||||
simplifyExpr mapping context (ELambda l e) =
|
||||
let newl = findName context l
|
||||
newmapping = (l, newl) : mapping
|
||||
newcontext = newl : context
|
||||
in ELambda newl (simplifyExpr newmapping newcontext e)
|
||||
|
||||
makeUnique :: [Symbol] -> Expression Symbol -> Expression Symbol
|
||||
makeUnique context (ESymbol s) = ESymbol (findName context s)
|
||||
makeUnique context (EExpr a b) = EExpr (makeUnique context a) (makeUnique context b)
|
||||
makeUnique context (ELambda l e) = ELambda (findName context l) (makeUnique context e)
|
||||
makeUnique = simplifyExpr []
|
||||
|
||||
simplify :: Expression Symbol -> Expression Symbol
|
||||
simplify = makeUnique []
|
||||
|
||||
insertExpr :: Symbol -> Expression Symbol -> [Symbol] -> Expression Symbol -> Expression Symbol
|
||||
insertExpr r new context old@(ESymbol s)
|
||||
|
|
@ -51,19 +65,49 @@ insertExpr r new context old@(ESymbol s)
|
|||
insertExpr r new context (EExpr a b) = EExpr (insertExpr r new context a) (insertExpr r new context b)
|
||||
insertExpr r new context (ELambda l e) = ELambda l (insertExpr r new (l : context) e)
|
||||
|
||||
simplify :: [Symbol] -> [(Symbol, Symbol)] -> Expression Symbol -> Expression Symbol
|
||||
simplify context mapping (ESymbol s) = ESymbol $ fromMaybe (findName context s) $ lookup s mapping
|
||||
simplify context mapping (EExpr a b) = EExpr (simplify context mapping a) (simplify context mapping b)
|
||||
simplify context mapping (ELambda l e) =
|
||||
let newl = findName context l
|
||||
in ELambda newl (simplify (l : context) ((l, newl) : mapping) e)
|
||||
|
||||
apply :: Expression Symbol -> Expression Symbol
|
||||
apply (EExpr (ELambda s l) b) = insertExpr s b [] l -- [], not [s]
|
||||
apply (EExpr a@(EExpr _ _) b) = EExpr (apply a) b
|
||||
apply e = e
|
||||
|
||||
step = simplify [] [] . apply
|
||||
step = simplify . apply
|
||||
|
||||
-- EXPERIMENT ZONE START --
|
||||
letters = ['a'..'z']
|
||||
namesN :: Int -> [String]
|
||||
namesN 0 = [""]
|
||||
namesN n = [n ++ [l] | n <- namesN (n-1), l <- letters]
|
||||
names :: [String]
|
||||
names = concatMap namesN [1..]
|
||||
findNewName :: [Symbol] -> Symbol
|
||||
findNewName other =
|
||||
let bases = map symBase other
|
||||
freeBases = names \\ (nub bases)
|
||||
in Symbol (head freeBases) 0
|
||||
simplifyExpr_ :: [(Symbol, Symbol)] -> [Symbol] -> Expression Symbol -> Expression Symbol
|
||||
simplifyExpr_ mapping context (ESymbol s) = ESymbol $ fromMaybe (findNewName context) $ lookup s mapping
|
||||
simplifyExpr_ mapping context (EExpr a b) = EExpr (simplifyExpr_ mapping context a) (simplifyExpr_ mapping context b)
|
||||
simplifyExpr_ mapping context (ELambda l e) =
|
||||
let newl = findNewName context
|
||||
newmapping = (l, newl) : mapping
|
||||
newcontext = newl : context
|
||||
in ELambda newl (simplifyExpr_ newmapping newcontext e)
|
||||
makeUnique_ :: [Symbol] -> Expression Symbol -> Expression Symbol
|
||||
makeUnique_ = simplifyExpr_ []
|
||||
simplify_ :: Expression Symbol -> Expression Symbol
|
||||
simplify_ = makeUnique_ []
|
||||
insertExpr_ :: Symbol -> Expression Symbol -> [Symbol] -> Expression Symbol -> Expression Symbol
|
||||
insertExpr_ r new context old@(ESymbol s)
|
||||
| r == s = makeUnique_ context new
|
||||
| otherwise = old
|
||||
insertExpr_ r new context (EExpr a b) = EExpr (insertExpr_ r new context a) (insertExpr_ r new context b)
|
||||
insertExpr_ r new context (ELambda l e) = ELambda l (insertExpr_ r new (l : context) e)
|
||||
apply_ :: Expression Symbol -> Expression Symbol
|
||||
apply_ (EExpr (ELambda s l) b) = insertExpr_ s b [] l -- [], not [s]
|
||||
apply_ (EExpr a@(EExpr _ _) b) = EExpr (apply_ a) b
|
||||
apply_ e = e
|
||||
step_ = simplify_ . apply_
|
||||
-- EXPERIMENT ZONE END --
|
||||
|
||||
_s :: String -> Expression Symbol
|
||||
_s s = ESymbol $ _ss s
|
||||
|
|
@ -88,18 +132,30 @@ main = do
|
|||
print $ findName [(Symbol "a" 0), (Symbol "b" 0), (Symbol "a" 1)] (Symbol "b" 3)
|
||||
print $ findName [(Symbol "a" 0), (Symbol "b" 0), (Symbol "a" 1)] (Symbol "c" 2)
|
||||
print $ findName [(Symbol "a" 1), (Symbol "a" 3), (Symbol "a" 0)] (Symbol "a" 1)
|
||||
-- EXPERIMENT ZONE START --
|
||||
print $ findNewName [(Symbol "a" 0), (Symbol "b" 0), (Symbol "a" 1)]
|
||||
print $ findNewName [(Symbol "a" 0), (Symbol "b" 0), (Symbol "a" 1)]
|
||||
print $ findNewName [(Symbol "a" 0), (Symbol "b" 0), (Symbol "a" 1)]
|
||||
print $ findNewName [(Symbol "a" 1), (Symbol "a" 3), (Symbol "a" 0)]
|
||||
-- EXPERIMENT ZONE END --
|
||||
putStrLn ""
|
||||
|
||||
putStrLn "Testing: Applying expressions"
|
||||
let t = (ELambda (_ss "a") (ELambda (_ss "b") (ESymbol (_ss "a"))))
|
||||
f = (ELambda (_ss "a") (ELambda (_ss "b") (ESymbol (_ss "b"))))
|
||||
n = (ELambda (_ss "a") (EExpr (EExpr (ESymbol (_ss "a")) (makeUnique [(_ss "a")] f)) (makeUnique [(_ss "a")] t)))
|
||||
-- EXPERIMENT ZONE START --
|
||||
n_ = (ELambda (_ss "a") (EExpr (EExpr (ESymbol (_ss "a")) (makeUnique_ [(_ss "a")] f)) (makeUnique_ [(_ss "a")] t)))
|
||||
-- EXPERIMENT ZONE END --
|
||||
print t
|
||||
print f
|
||||
print n
|
||||
print $ simplify [] [] $ (ELambda (Symbol "a" 1) (ESymbol (Symbol "a" 1)))
|
||||
print $ simplify $ (ELambda (Symbol "a" 1) (ESymbol (Symbol "a" 1)))
|
||||
print (EExpr n f)
|
||||
putStrLn $ showTopLevel (EExpr n f)
|
||||
putStrLn ""
|
||||
|
||||
putStrLn "Replacing symbols: apostrophe"
|
||||
putStrLn "Running: not false"
|
||||
print (EExpr n f)
|
||||
print . step $ (EExpr n f)
|
||||
|
|
@ -112,3 +168,19 @@ main = do
|
|||
print . step . step $ (EExpr n t)
|
||||
print . step . step . step $ (EExpr n t)
|
||||
putStrLn ""
|
||||
|
||||
-- EXPERIMENT ZONE START --
|
||||
putStrLn "Replacing symbols: new base"
|
||||
putStrLn "Running: not false"
|
||||
print (EExpr n_ f)
|
||||
print . step_ $ (EExpr n_ f)
|
||||
print . step_ . step_ $ (EExpr n_ f)
|
||||
print . step_ . step_ . step_ $ (EExpr n_ f)
|
||||
|
||||
putStrLn "Running: not true"
|
||||
print (EExpr n_ t)
|
||||
print . step_ $ (EExpr n_ t)
|
||||
print . step_ . step_ $ (EExpr n_ t)
|
||||
print . step_ . step_ . step_ $ (EExpr n_ t)
|
||||
putStrLn ""
|
||||
-- EXPERIMENT ZONE END --
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue