Document and reorganize some functions

This commit is contained in:
Joscha 2017-11-13 16:01:30 +00:00
parent 6cf3c70a44
commit 705df975b0

View file

@ -1,17 +1,25 @@
import Data.List
{-
- The Expression type
-}
data Expression s = ESymbol s
| EReference Int
| EExpr (Expression s) (Expression s)
| ELambda s (Expression s)
-- list of names -> name -> unique name
-- Find a unique name not in the list of names.
-- Appends apostrophes until name is unique.
makeUnique :: [String] -> String -> String
makeUnique context s =
let apostrophes = iterate ('\'' :) ""
modified = zipWith (++) (repeat s) apostrophes
available = filter (not . (`elem` context)) modified
in head available
in head available -- list of available names is infinite
-- Expression -> Expression with unique symbol names
renameUniquely :: (Show s) => Expression s -> Expression String
renameUniquely = rename_ []
-- rename_ :: (Show s) => [String] -> Expression s -> Expression String
@ -40,30 +48,56 @@ instance Eq (Expression s) where
(ELambda _ a) == (ELambda _ b) = a == b
_ == _ = False
insertExpr :: Expression s -> Expression s -> Expression s
insertExpr = insert_ 0
where insert_ level replace ref@(EReference n)
| n == level = replace
| otherwise = ref
insert_ level replace (EExpr a b) = EExpr (insert_ level replace a) (insert_ level replace b)
insert_ level replace (ELambda s e) = ELambda s (insert_ (level + 1) replace e)
insert_ _ _ symbol = symbol
{-
- Evaluating expressions
-}
-- Expression to be inserted -> Expression to be inserted into -> result
-- TODO: Make clearer what insert does - better description, ...
insertExpr :: Int -> Expression s -> Expression s -> Expression s
insertExpr level replace ref@(EReference n)
| n == level = replace
| otherwise = ref
insertExpr level replace (EExpr a b) = EExpr (insertExpr level replace a)
(insertExpr level replace b)
insertExpr level replace (ELambda s e) = ELambda s (insertExpr (level + 1) replace e)
insertExpr _ _ symbol = symbol
apply :: Expression s -> Expression s
apply (EExpr l@(ELambda s e) b) = insertExpr b e
apply (EExpr l@(ELambda s e) b) = insertExpr 0 b e
apply (EExpr e@(EExpr _ _) b) = EExpr (apply e) b
apply e = e
takeWhileUnique :: (Eq a) => [a] -> [a]
takeWhileUnique l = map fst $ takeWhile (\a -> not $ fst a `elem` snd a) $ zip l (inits l)
takeWhileUnique l = map fst
$ takeWhile (\a -> not $ fst a `elem` snd a)
$ zip l (inits l)
evaluate :: Expression s -> [Expression s]
evaluate = takeWhileUnique . iterate apply
{-
- Parsing expressions
-}
-- TODO
-- Helper type for using arbitrary strings as symbols
newtype StrSymbol = StrSymbol String
instance Show StrSymbol where
show (StrSymbol s) = s
--instance Read StrSymbol where
-- read s = StrSymbol s
_s = ESymbol
_e = EExpr
_r = EReference
_l = ELambda
_ss = StrSymbol
main = do
putStrLn "Test nested expressions and parentheses"
@ -77,11 +111,25 @@ main = do
print (_l 1 (_e (_l 2 (_r 0)) (_l 3 (_r 1))))
print ((_r 0) :: Expression Int) -- should also fail in some way
putStrLn "Test insertion"
putStrLn "Testing Ints as symbols..."
let t = (_l 1 (_l 2 (_r 1)))
f = (_l 1 (_l 2 (_r 0)))
n = (_l 1 (_e (_e (_r 0) f) t))
print t
print f
print n
putStrLn "Evaluating..."
putStrLn "Evaluating... N T"
mapM_ print . evaluate $ (_e n t)
putStrLn "Evaluating... N F"
mapM_ print . evaluate $ (_e n f)
putStrLn "Testing StrSymbols as symbols..."
let st = (_l (_ss "a") (_l (_ss "b") (_r 1)))
sf = (_l (_ss "a") (_l (_ss "b") (_r 0)))
sn = (_l (_ss "n") (_e (_e (_r 0) sf) st))
print st
print sf
print sn
putStrLn "Evaluating... N T"
mapM_ print . evaluate $ (_e sn st)
putStrLn "Evaluating... N F"
mapM_ print . evaluate $ (_e sn sf)