1 files changed, 78 insertions, 0 deletions
diff --git a/old-examples/gfcc/compiler/Trees.hs b/old-examples/gfcc/compiler/Trees.hs
new file mode 100644
index 000000000..57fbfd966
--- /dev/null
+++ b/old-examples/gfcc/compiler/Trees.hs
@@ -0,0 +1,78 @@
+module Trees where
+
+data Exp =
+   EApp  Exp Exp
+ | EAbs  Ident Exp
+ | EAtom Atom
+  deriving (Eq,Ord,Show)
+
+newtype CFTree = CFTree (CFFun,[CFTree]) deriving (Eq, Show)
+
+type CFCat = Ident
+
+newtype Ident = Ident String deriving (Eq, Ord, Show)
+
+-- to build trees: the Atom contains a GF function, Cn | Meta | Vr | Literal
+newtype CFFun = CFFun (Atom, Profile) deriving (Eq,Ord,Show) 
+
+type Profile  = [([[Int]],[Int])]
+
+data Atom =
+   AC Ident
+ | AV Ident
+ | AM
+ | AS String
+ | AI Integer
+  deriving (Eq,Ord,Show)
+
+-- printing
+
+class Prt a where
+  prt :: a -> String
+
+instance Prt Exp where
+  prt e = case e of
+    EApp f a -> unwords [prt f, prt1 a]
+    EAbs x a -> "\\" ++ prt x ++ " -> " ++ prt a
+    EAtom a  -> prt a
+   where
+     prt1 e = case e of
+       EAtom _ -> prt e
+       _ -> "(" ++ prt e ++ ")"
+
+instance Prt Atom where
+  prt a = case a of
+    AC x -> prt x
+    AV x -> prt x
+    AM   -> "?"
+    AS s -> show s ----
+    AI i -> show i
+
+instance Prt Ident where
+  prt (Ident x) = x
+
+-- printing trees
+
+prCFTree :: CFTree -> String
+prCFTree (CFTree (fun, trees)) = prCFFun fun ++ prs trees where
+ prs [] = ""
+ prs ts = " " ++ unwords (map ps ts)
+ ps t@(CFTree (_,[])) = prCFTree t
+ ps t = "(" ++ prCFTree t ++ ")"
+
+prCFFun :: CFFun -> String
+prCFFun = prCFFun' True ---- False -- print profiles for debug
+
+prCFFun' :: Bool -> CFFun -> String
+prCFFun' profs (CFFun (t, p)) = prt t ++ pp p where
+    pp p = if (not profs || normal p) then "" else "_" ++ concat (map show p)
+    normal p = and [x==y && null b | ((b,x),y) <- zip p (map (:[]) [0..])]
+
+prCFCat :: CFCat -> String
+prCFCat c = prt c
+
+mkFunTree :: String -> Profile -> [CFTree] -> CFTree
+mkFunTree f p ts = CFTree (CFFun (AC (Ident f),p), ts)
+
+mkAtTree :: Atom -> CFTree
+mkAtTree a = CFTree (CFFun (a,[]), [])