more on the Susanne treebank

1 files changed, 62 insertions, 23 deletions

diff --git a/treebanks/susanne/SusanneFormat.hs b/treebanks/susanne/SusanneFormat.hs
index 052f95978..3eb3187e2 100644
--- a/treebanks/susanne/SusanneFormat.hs
+++ b/treebanks/susanne/SusanneFormat.hs
@@ -1,43 +1,82 @@
-module SusanneFormat(Tag,Id,Word,Lemma,ParseTree(..),readTreebank) where
+module SusanneFormat(Tag,Id,Word,Lemma,ParseTree(..),readTreebank,readTag) where
 
+import PGF(CId)
 import Data.Char
 
 type Tag   = String
+type Mods  = String
+type Fn    = String
+type Index = Int
 type Id    = String
 type Word  = String
 type Lemma = String
 
 data ParseTree
- = Phrase Tag [ParseTree]
+ = Phrase Tag Mods Fn Index [ParseTree]
  | Word   Id Tag Word Lemma
+ | App CId [ParseTree]
 
 data ParseTreePos
  = Root
- | At ParseTreePos Tag [ParseTree]
+ | At ParseTreePos ([ParseTree] -> ParseTree) [ParseTree]
 
 instance Show ParseTree where
-  show (Phrase tag ts)  = "["++tag++" "++unwords (map show ts)++"]"
-  show (Word _ tag w _) = "["++tag++" "++w++"]"
+  show (Phrase tag mods fn idx ts)
+    | tag == ""            = "["++fn++show idx++" "++unwords (map show ts)++"]"
+    | fn == "" && idx == 0 = "["++tag++mods++" "++unwords (map show ts)++"]"
+    | otherwise            = "["++tag++mods++":"++fn++show idx++" "++unwords (map show ts)++"]"
+  show (Word _ tag w _)    = "["++tag++" "++w++"]"
+  show (App f ts)           
+    | null ts              = show f
+    | otherwise            = "("++show f++" "++unwords (map show ts)++")"
 
 readTreebank ls = readLines Root (map words ls)
 
 readLines p []                        = []
 readLines p ([id,_,tag,w,l,parse]:ls) =
-  readParse p (Word id tag w l) parse ls
-
-readParse p    w []       ls = readLines p ls
-readParse p    w ('[':cs) ls =
-  case break (not . isTagChar) cs of
-    (tag,cs) -> readParse (At p tag []) w cs ls
-readParse (At p tag ts) w ('.':cs) ls =
-  readParse (At p tag (w:ts)) w cs ls
-readParse (At p tag ts) w cs ls =
-  case break (not . isTagChar) cs of
-    (tag,']':cs) -> let t = Phrase tag (reverse ts)
-                    in case p of
-                         Root        -> t : readLines p ls
-                         At p tag ts -> readParse (At p tag (t:ts)) w cs ls
-    _            -> error cs
-
-isTagChar c =
-  isLetter c || isDigit c || elem c ":&+-%@=?\"*!"
+  readParse (Word id tag w l) p parse ls
+
+readParse w p []       ls = readLines p ls
+readParse w p ('[':cs) ls =
+  case readTag w cs of
+    (fn,cs) -> readParse w (At p fn []) cs ls
+readParse w (At p fn ts) ('.':cs) ls =
+  readParse w (At p fn (w:ts)) cs ls
+readParse w (At p fn ts) cs ls =
+  case readTag w cs of
+    (_,']':cs) -> let t = fn (reverse ts)
+                  in case p of
+                       Root       -> t : readLines p ls
+                       At p fn ts -> readParse w (At p fn (t:ts)) cs ls
+    _          -> readError w
+
+readTag w cs@(c1:c2:_)             -- word tag on phrase level
+  | isUpper c1 && isUpper c2 =
+      case break (\c -> not (isLetter c || isDigit c)) cs of
+        (tag,cs) -> case break (\c -> not (elem c "?*%!\"=+-&@")) cs of
+                      (mods,cs) -> case cs of
+                                    (':':c:cs) | isLetter c -> case break (not . isDigit) cs of
+                                                                 (ds,cs) -> (Phrase tag mods [c] (if null ds then 0 else read ds),cs)
+                                               | isDigit  c -> case break (not . isDigit) (c:cs) of
+                                                                 (ds,cs) -> (Phrase tag mods "" (if null ds then 0 else read ds),cs)
+                                    _                       -> (Phrase tag mods "" 0,cs)
+readTag w (c:cs)                -- phrase tag
+  | isUpper c = let tag = [c]
+                in case break (\c -> not (isLetter c || isDigit c || elem c "?*%!\"=+-&@")) cs of
+                     (mods,cs) -> case cs of
+                                    (':':c:cs) | isLetter c -> case break (not . isDigit) cs of
+                                                                 (ds,cs) -> (Phrase tag mods [c] (if null ds then 0 else read ds),cs)
+                                               | isDigit  c -> case break (not . isDigit) (c:cs) of
+                                                                 (ds,cs) -> (Phrase tag mods "" (if null ds then 0 else read ds),cs)
+                                    _                       -> (Phrase tag mods "" 0,cs)
+  | isLower c = let tag  = []
+                    mods = []
+                in case break (not . isDigit) cs of
+                     (ds,cs) -> (Phrase tag mods [c] (if null ds then 0 else read ds),cs)
+  | isDigit c = let tag  = []
+                    mods = []
+                in case break (not . isDigit) cs of
+                     (ds,cs) -> (Phrase tag mods [] (read ds),cs)
+readTag w cs = readError w
+
+readError (Word id _ _ _) = error id