module Language.Grammars.ZipperAG.Examples.DESK.DESK_circular where
import Data.Maybe
import Data.Data
import Prelude
import Data.Generics.Zipper
import Language.Grammars.ZipperAG
data Root = Root Program
deriving (Show, Typeable, Data)
data Program = PRINT Expression ConstPart
deriving (Show, Typeable, Data)
data Expression = Add Expression Factor
| Fact Factor
deriving (Show, Typeable, Data)
data Factor = Name ConstName
| Number Int
deriving (Show, Typeable, Data)
data ConstName = Id String
deriving (Show, Typeable, Data)
data ConstPart = EmptyConstPart
| WHERE ConstDefList
deriving (Show, Typeable, Data)
data ConstDefList = Comma ConstDefList ConstDef
| Def ConstDef
deriving (Show, Typeable, Data)
data ConstDef = EqualInt ConstName Int
| EqualString ConstName String
deriving (Show, Typeable, Data)
envi :: Zipper Root -> Zipper Root_HO
envi t = case (constructor t) of
"PRINT" -> let h_o = toZipper (Root_HO (envs $ t.$2) )
in solve h_o
autocopy -> envi (parent t)
code :: Zipper Root -> String
code t = case (constructor t) of
"Root" -> code ( t.$1 )
"PRINT" -> if ok ( t.$2 )
then code ( t.$1 ) ++ "PRINT, 0\n" ++ "HALT, 0\n"
else "HALT, 0\n"
"Add" -> if (ok ( t.$2 ))
then code ( t.$1 ) ++ "ADD, " ++ show (value ( t.$2 )) ++ "\n"
else "HALT, 0\n"
"Fact" -> if (ok ( t.$1 ))
then "LOAD, " ++ show (value ( t.$1 )) ++ "\n"
else "HALT, 0\n"
value :: Zipper Root -> Int
value t = case (constructor t) of
"Name" -> getValue (name $ t.$1) (envi t)
"Number" -> lexeme_Number t
ok :: Zipper Root -> Bool
ok t = case (constructor t) of
"Name" -> isInST (name $ t.$1) (envi t)
"Number" -> True
"EmptyConstPart" -> True
"WHERE" -> ok ( t.$1 )
"Comma" -> ok ( t.$1 ) && not ( isInST (name $ t.$2) (toZipper ( Root_HO (envs $ t.$1)) ) )
"Def" -> True
name :: Zipper Root -> String
name t = case (constructor t) of
"Id" -> lexeme_Id t
"EqualInt" -> name ( t.$1 )
"EqualString" -> name ( t.$1 )
envs :: Zipper Root -> SymbolTable
envs t = case (constructor t) of
"EmptyConstPart" -> NilST
"WHERE" -> envs( t.$1 )
"Comma" -> ConsST (extract $ t.$2) (envs $ t.$1)
"Def" -> ConsST (extract $ t.$1) NilST
extract :: Zipper Root -> Tuple
extract t = case (constructor t) of
"EqualInt" -> TupleInt (name $ t.$1) (lexeme_Equal_Int t)
"EqualString" -> TupleString (name $ t.$1) (lexeme_Equal_String t)
data Root_HO = Root_HO SymbolTable
deriving (Data, Show, Typeable)
data SymbolTable = NilST
| ConsST Tuple SymbolTable
deriving (Show, Typeable, Data)
data Tuple = TupleInt String Int
| TupleString String String
deriving (Show, Typeable, Data)
isInST :: String -> Zipper Root_HO -> Bool
isInST var z = case (constructor_HO z) of
"Root_HO" -> isInST var (z.$1)
"NilST" -> False
"ConsST" -> (isInST var (z.$1)) || (isInST var (z.$2))
"TupleInt" -> lexeme_Tuple_name z == var
"TupleString" -> lexeme_Tuple_name z == var
getValue :: String -> Zipper Root_HO -> Int
getValue var z = case (constructor_HO z) of
"Root_HO" -> getValue var (z.$1)
"ConsST" -> if (lexeme_Tuple_name $ z.$1) == var
then (lexeme_Tuple_Int_Value $ z.$1)
else getValue (var) (z.$2)
solve :: Zipper Root_HO -> Zipper Root_HO
solve z = case (constructor_HO z) of
"Root_HO" -> if (isSolved z)
then z
else solve $ toZipper ( Root_HO (auxSolve $ z.$1))
autocopy -> solve $ parent z
auxSolve :: Zipper Root_HO -> SymbolTable
auxSolve z = case (constructor_HO z) of
"Root_HO" -> auxSolve $ z.$1
"NilST" -> NilST
"ConsST" -> ConsST (check $ z.$1) (auxSolve $ z.$2)
check :: Zipper Root_HO -> Tuple
check z = case (constructor_HO z) of
"TupleInt" -> lexeme_Tuple_Int z
"TupleString" -> apply (solvedSymbols z) (lexeme_Tuple_String z)
apply :: [(String, Int)] -> Tuple -> Tuple
apply [] t = t
apply ((a,b):xs) t@(TupleString name assign) = if (a == assign)
then (TupleInt name b)
else apply xs t
solvedSymbols :: Zipper Root_HO -> [(String, Int)]
solvedSymbols z = case (constructor_HO z) of
"Root_HO" -> auxSolvedSymbols $ z.$1
autocopy -> solvedSymbols $ parent z
auxSolvedSymbols :: Zipper Root_HO -> [(String, Int)]
auxSolvedSymbols z = case (constructor_HO z) of
"ConsST" -> auxSolvedSymbols (z.$1) ++ auxSolvedSymbols (z.$2)
"NilST" -> []
"TupleInt" -> [(lexeme_Tuple_name z, lexeme_Tuple_Int_Value z)]
"TupleString" -> []
isSolved :: Zipper Root_HO -> Bool
isSolved z = case (constructor_HO z) of
"Root_HO" -> auxIsSolved $ z.$1
autocopy -> isSolved $ parent z
auxIsSolved :: Zipper Root_HO -> Bool
auxIsSolved z = case (constructor_HO z) of
"Root_HO" -> auxIsSolved $ z.$1
"ConsST" -> (auxIsSolved $ z.$1) && (auxIsSolved $ z.$2)
"NilST" -> True
"TupleInt" -> True
"TupleString" -> False
expr = Add (Add (Fact (Name (Id "x"))) (Name (Id "y"))) (Number 1)
deflst = WHERE (Comma (Comma (Def ((EqualString (Id "x") "y"))) (EqualInt (Id "z") 2)) (EqualString (Id "y") "z"))
program = Root (PRINT expr deflst)
semantics t = putStrLn ("\n" ++ (code (toZipper t)))
constructor :: (Typeable a) => Zipper a -> String
constructor a = case ( getHole a :: Maybe Program ) of
Just (PRINT _ _) -> "PRINT"
otherwise -> case ( getHole a :: Maybe Expression ) of
Just (Add _ _) -> "Add"
Just (Fact _) -> "Fact"
otherwise -> case ( getHole a :: Maybe Factor ) of
Just (Name _) -> "Name"
Just (Number _) -> "Number"
otherwise -> case ( getHole a :: Maybe ConstName ) of
Just (Id _) -> "Id"
otherwise -> case ( getHole a :: Maybe ConstPart ) of
Just (EmptyConstPart) -> "EmptyConstPart"
Just (WHERE _) -> "WHERE"
otherwise -> case ( getHole a :: Maybe ConstDefList ) of
Just (Comma _ _) -> "Comma"
Just (Def _) -> "Def"
otherwise -> case ( getHole a :: Maybe ConstDef ) of
Just (EqualInt _ _) -> "EqualInt"
Just (EqualString _ _) -> "EqualString"
otherwise -> case ( getHole a :: Maybe Root) of
Just (Root _) -> "Root"
_ -> "That production does not exist!"
lexeme_Id t = case ( getHole t :: Maybe ConstName ) of
Just (Id x) -> x
lexeme_Number t = case ( getHole t :: Maybe Factor ) of
Just (Number x) -> x
lexeme_Equal_Int t = case ( getHole t :: Maybe ConstDef ) of
Just (EqualInt _ x) -> x
lexeme_Equal_String t = case ( getHole t :: Maybe ConstDef ) of
Just (EqualString _ x) -> x
constructor_HO :: (Typeable a) => Zipper a -> String
constructor_HO a = case ( getHole a :: Maybe SymbolTable) of
Just (NilST) -> "NilST"
Just (ConsST _ _) -> "ConsST"
otherwise -> case ( getHole a :: Maybe Tuple) of
Just (TupleInt _ _) -> "TupleInt"
Just (TupleString _ _) -> "TupleString"
otherwise -> case ( getHole a :: Maybe Root_HO ) of
Just (Root_HO _) -> "Root_HO"
_ -> error "Ups!!"
lexeme_Root z = case ( getHole z :: Maybe Root_HO ) of
Just(Root_HO a) -> a
lexeme_Tuple_name z = case ( getHole z :: Maybe Tuple ) of
Just(TupleInt a b) -> a
Just(TupleString a b) -> a
lexeme_Tuple_Int z = case ( getHole z :: Maybe Tuple ) of
Just(TupleInt a b) -> TupleInt a b
lexeme_Tuple_String z = case ( getHole z :: Maybe Tuple ) of
Just(TupleString a b) -> TupleString a b
lexeme_Tuple_Int_Value z = case ( getHole z :: Maybe Tuple ) of
Just(TupleInt a b) -> b
lexeme_Tuple_String_Value z = case ( getHole z :: Maybe Tuple ) of
Just(TupleString a b) -> b