TreeAutomata.hs

import qualified Data.Map as M

type State = String
type Symbol = (String, Int)

data TreeAutomaton = TreeAutomaton
    { symbols :: [Symbol]
    , states :: [State]
    , finalStates :: [State]
    , delta :: M.Map (Symbol, [State]) State
    } deriving Show

data Tree = Tree (Symbol, [Tree]) deriving Show

evalTree :: TreeAutomaton -> Tree -> State
evalTree a (Tree (sym@(_, n), children)) =
        if n /= length children then error "Symbol arity of " ++ show sym ++
                             " does not match number of children"
        else
            let childStates = map (evalTree a) children
            in  case M.lookup (sym, childStates) (delta a) of
                    Just x -> x
                    Nothing -> error ("No applicable rule for " ++ show sym)

isDeterministic :: TreeAutomaton -> Bool
isDeterministic TreeAutomaton {delta=delta} = M.foldl isDuplicate False delta
  where hasDuplicates e = (>1) . length . fst . M.partition (==e)
        isDuplicate acc e = if hasDuplicates e delta then True else acc

trueSymb = ("True", 0)
falseSymb = ("False", 0)
andSymb = ("And", 2)
orSymb = ("Or", 2)
notSymb = ("Not", 1)

mySymbols = [trueSymb, falseSymb, andSymb, orSymb, notSymb]

trueState = "t"
falseState = "f"

myAutomaton = TreeAutomaton
        { symbols = mySymbols
        , states = [trueState, falseState]
        , finalStates = [trueState]
        , delta = M.fromList
            [ ((trueSymb, []), trueState)
            , ((falseSymb, []), falseState)
            , ((andSymb, [trueState, trueState]), trueState)
            , ((andSymb, [trueState, falseState]), falseState)
            , ((andSymb, [falseState, trueState]), falseState)
            , ((andSymb, [falseState, falseState]), falseState)
            , ((orSymb, [trueState, trueState]), trueState)
            , ((orSymb, [trueState, falseState]), trueState)
            , ((orSymb, [falseState, trueState]), trueState)
            , ((orSymb, [falseState, falseState]), falseState)
            , ((notSymb, [falseState]), trueState)
            , ((notSymb, [trueState]), falseState)
            ]
        }

myTree = Tree (andSymb,
              [ Tree (notSymb,
                    [ Tree (falseSymb, []) ])
              , Tree (orSymb,
                    [ Tree (falseSymb, [])
                    , Tree (trueSymb, []) ])
              ])


main :: IO ()
main = do
        putStrLn "myTree:"
        print myTree
        putStrLn "myAutomaton:"
        print myAutomaton
        putStrLn "eval result:"
        print (evalTree myAutomaton myTree)