Experiment with symbol name simplification

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 = simplifyExpr []
-makeUnique context (EExpr a b) = EExpr (makeUnique context a) (makeUnique context b)
+
-makeUnique context (ELambda l e) = ELambda (findName context l) (makeUnique context e)
+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 --