real parser for Alvey grammar: new version of BigLexEng

examples/big/MAP/Lisp.cf

@@ -0,0 +1,20 @@
+-- Lisp as used in the Alvey grammar
+
+entrypoints Prog, Exp ;
+
+Pro.    Prog ::= [Exp] ;
+
+App.    Exp ::= "(" [Exp] ")" ;
+At.     Exp ::= Id ;
+IdPlus. Exp ::= IdPl ;
+IdStr.  Exp ::= String ;
+Plus.   Exp ::= "+" ;
+Minus.  Exp ::= "-" ;
+Num.    Exp ::= Integer ;
+
+token IdPl ('+' letter (letter | digit | '-' | '_')*) ;
+token Id (letter (letter | digit | '-' | '_')*) ;
+
+terminator Exp "" ;
+
+comment ";;" ;

examples/big/MAP/Makefile

@@ -0,0 +1,20 @@
+all: 
+	make big
+	make gf
+	mv Big*.gf ..
+gf:
+	./mkBig
+
+big:
+	ghc --make MkBig -o mkBig
+parser:
+	happy -gca ParLisp.y
+	alex -g LexLisp.x
+	latex DocLisp.tex; dvips DocLisp.dvi -o DocLisp.ps
+	ghc --make TestLisp.hs -o TestLisp
+clean:
+	-rm -f *.log *.aux *.hi *.o *.dvi
+	-rm -f DocLisp.ps
+distclean: clean
+	-rm -f DocLisp.* LexLisp.* ParLisp.* LayoutLisp.* SkelLisp.* PrintLisp.* TestLisp.* AbsLisp.* TestLisp ErrM.* SharedString.* Lisp.dtd XMLLisp.* Makefile*
+

examples/big/MAP/MkBig.hs

@@ -0,0 +1,42 @@
+module Main where
+
+import TransBig
+
+import IO ( stdin, hGetContents )
+import System ( getArgs, getProgName )
+
+import LexLisp
+import ParLisp
+import SkelLisp
+import PrintLisp
+import AbsLisp
+import ErrM
+
+type ParseFun a = [Token] -> Err a
+
+myLLexer = myLexer
+
+type Verbosity = Int
+
+putStrV :: Verbosity -> String -> IO ()
+putStrV v s = if v > 1 then putStrLn s else return ()
+
+runFile :: Verbosity -> ParseFun Prog -> FilePath -> IO ()
+runFile v p f = putStrLn f >> readFile f >>= run v p
+
+run :: Verbosity -> ParseFun Prog -> String -> IO ()
+run v p s = let ts = myLLexer s in case p ts of
+           Bad s    -> do putStrLn "\nParse              Failed...\n"
+                          putStrV v "Tokens:"
+                          putStrV v $ show ts
+                          putStrLn s
+           Ok  tree -> do putStrLn "\nParse Successful!"
+                          transTree tree
+
+
+
+main :: IO ()
+main = do 
+  runFile 0 pProg infile
+
+infile = "bigwordlist.en"

examples/big/MAP/TransBig.hs

@@ -0,0 +1,148 @@
+module TransBig where
+
+import AbsLisp
+import PrintLisp
+
+import Char
+
+abstrgf = "BigLexEngAbs.gf"
+concrgf = "BigLexEng.gf"
+
+transTree :: Prog -> IO ()
+transTree (Pro ts) = do
+  writeFile abstrgf "abstract BigLexEngAbs = Cat **{\n"
+  writeFile concrgf 
+    "concrete BigLexEng of BigLexEngAbs = CatEng ** open ParadigmsEng, IrregEng in {\n"
+  mapM_ transRule ts
+  appendFile abstrgf "}\n"
+  addOpers
+  appendFile concrgf "}\n"
+
+transRule :: Exp -> IO ()
+transRule e = case e of
+  App (At f : _ : cat : _) | not (discardCat cat) -> catRule (hyph f) cat
+  _ -> notConsidered $ "--! " ++ printTree e
+ where
+  hyph (Id f) = Id (map unhyph f)
+  unhyph '-' = '_'
+  unhyph c = c
+
+discardCat (App cs) = any (flip elem cs) discarded where
+  discarded = [
+    App [At (Id "AUX"),Plus],
+    App [At (Id "PAST"),Plus],
+    App [At (Id "QUA"),Plus],
+    App [At (Id "VFORM"),At (Id "EN")],
+    App [At (Id "AFORM"),At (Id "ER")],
+    App [At (Id "AFORM"),At (Id "EST")]
+    ]
+discardCat _ = False
+
+
+catRule :: Id -> Exp -> IO ()
+catRule (Id f) e = case cleanCat e of
+  App (App [At (Id "V"), Minus] : App [At (Id "N"), Plus] : more) -> case more of 
+    [App [At (Id "SUBCAT"),sub]] -> 
+      let prep = prepSub sub in
+      putRule (f ++ "_N2" ++ prep) "N2" "prepN2" [show f, show prep]
+    [App [At (Id "PLU"),Minus],App [At (Id "SUBCAT"),sub]] -> 
+      let prep = prepSub sub in
+      putRule (f ++ "_N2" ++ prep) "N2" "irregN2" [show f, show f, show prep]
+    [App [At (Id "PLU"),Minus]] -> 
+      putRule (f ++ "_N") "N" "irregN" [show f, show f] --- could find the forms
+    [App [At (Id "PLU"),_]] -> 
+      notConsidered $ "--! " ++ f ++ " " ++ printTree e
+    (App [At (Id "PRO"),Plus]:_) -> 
+      notConsidered $ "--! " ++ f ++ " " ++ printTree e
+    [App [At (Id "COUNT"),Minus]] -> 
+      putRule (f ++ "_N") "N" "massN" [show f]
+    [App [At (Id "PN"),Plus]] -> 
+      putRule (f ++ "_PN") "PN" "regPN" [show f]
+    [] ->
+      putRule (f ++ "_N") "N" "regN" [show f]
+    _ -> putStrLn $ "---- " ++ f ++ " " ++ printTree e
+  App (App [At (Id "V"), Plus] : App [At (Id "N"), Plus] : more) -> case more of 
+    (App [At (Id "ADV"), Plus]:_) -> 
+      putRule (f ++ "_Adv") "Adv" "mkAdv" [show f]
+    [App [At (Id "SUBCAT"),sub]] -> 
+      let prep = prepSub sub in
+      putRule (f ++ "_A2" ++ prep) "A2" "regA2" [show f,show prep]
+    [App [At (Id "AFORM"),At (Id "NONE")],App [At (Id "SUBCAT"),sub]] -> 
+      let prep = prepSub sub in
+      putRule (f ++ "_A2" ++ prep) "A2" "longA2" [show f,show prep]
+    [App [At (Id "SUBCAT"),sub],App [At (Id "AFORM"),At (Id "NONE")]] -> 
+      let prep = prepSub sub in
+      putRule (f ++ "_A2" ++ prep) "A2" "longA2" [show f,show prep]
+    (App [At (Id "AFORM"),At (Id "NONE")]:_) -> 
+      putRule (f ++ "_A") "A" "longA" [show f]
+    [] ->
+      putRule (f ++ "_A") "A" "regA" [show f]
+    _ -> putStrLn $ "---- " ++ f ++ " " ++ printTree e
+  App (App [At (Id "V"), Plus] : App [At (Id "N"), Minus] : more) -> case more of 
+    App [At (Id "SUBCAT"),At (Id "NP_NP")]:form -> 
+      putRule (f ++ "_V3") "V3" "dirdirV3" [verbForm form f]
+    App [At (Id "SUBCAT"),At (Id ('N':'P':'_':sub))]:form -> 
+      let prep = map toLower (drop 2 sub) in
+      putRule (f ++ "_V3" ++ prep) "V3" "dirprepV3" [verbForm form f, show prep]
+    App [At (Id "SUBCAT"),At (Id "SFIN")]:form -> 
+      putRule (f ++ "_VS") "VS" "mkVS" [verbForm form f]
+    App [At (Id "SUBCAT"),At (Id "SE1")]:form -> 
+      putRule (f ++ "_VV") "VV" "mkVV" [verbForm form f]
+    App [At (Id "SUBCAT"),sub]:form -> 
+      let prep = prepSub sub in
+      putRule (f ++ "_V2" ++ prep) "V2" "prepV2" [verbForm form f, show prep]
+    form | length form < 2 ->
+      putRule (f ++ "_V") "V" "useV" [verbForm form f]
+    _ -> putStrLn $ "---- " ++ f ++ " " ++ printTree e
+  App (App [At (Id "V"), Minus] : App [At (Id "N"), Minus] : more) -> case more of 
+    [App [At (Id "SUBCAT"), At (Id "BARE_S")]] -> 
+      putRule (f ++ "_Subj") "Subj" "mkSubj" [show f]
+    [App [At (Id "SUBCAT"), At (Id "NP")]] -> 
+      putRule (f ++ "_Prep") "Prep" "mkPrep" [show f]
+    App [At (Id "PRO"), Plus] : _ ->
+      putRule (f ++ "_Adv") "Adv" "proAdv" [show f]
+    _ -> putStrLn $ "---- " ++ f ++ " " ++ printTree e
+  App (App [At (Id "PRO"), Plus] : 
+    App [At (Id "V"), Minus] : App [At (Id "N"), Minus] :_) ->
+      putRule (f ++ "_Adv") "Adv" "proAdv" [show f]
+  _ -> notConsidered $ "--! " ++ f ++ " " ++ printTree e
+
+cleanCat (App es) = App $ filter (not . irrelevant) es where
+  irrelevant c = elem c [
+    App [At (Id "SUBCAT"), At (Id "NULL")],
+    App [At (Id "AT"), Minus], --- ?
+    App [At (Id "LAT"), Minus],
+    App [At (Id "LAT"), Plus]
+    ]
+cleanCat c = c
+
+notConsidered r = return () --- putStrLn
+
+putRule :: String -> String -> String -> [String] -> IO ()
+putRule fun cat oper args = do
+  appendFile abstrgf $ unwords ["fun",fun,":",cat,";\n"]
+  appendFile concrgf $ unwords $ ["lin",fun,"=",oper] ++ args ++ [";\n"]
+
+prepSub :: Exp -> String
+prepSub s = case s of
+  At (Id ('P':'P':cs)) -> map toLower cs
+  _ -> ""
+
+verbForm form f
+   | elem (App [At (Id "REG"),Minus]) form = "IrregEng." ++ f ++ "_V"
+   | otherwise = "(regV " ++ show f ++ ")"
+
+addOpers = mapM_ (appendFile concrgf) [
+  "oper proAdv : Str -> Adv = \\s -> mkAdv s ;\n",
+  "oper useV : V -> V = \\v -> v ;\n",
+  "oper massN : Str -> N = \\s -> regN s ;\n",
+  "longA : Str -> A = \\s -> compoundADeg (regA s) ;\n",
+  "mkSubj : Str -> Subj = \\s -> {s = s ; lock_Subj = <>} ;\n",
+  "irregN : Str -> Str -> N = \x,y -> mk2N x y ;\",
+  "irregN2 : Str -> Str -> Str -> N2 = \x,y,p -> mkN2 (irregN x y) (mkPrep p) ;\n",
+  "longA2 : Str -> Str -> A2 = \s,p -> mkA2 (compoundADeg (regA s)) (mkPrep p) ;\n",
+  "regA2 : Str -> Str -> A2 = \s,p -> mkA2 (regA s) (mkPrep p) ;\n",
+  "prepV2 : V -> Str -> V2 = \s,p -> mkV2 s (mkPrep p) ;\n",
+  "prepN2 : Str -> Str -> N2 = \s,p -> mkN2 (regN s) (mkPrep p) ;\n",
+  "dirprepV3 : V -> Str -> V3 = \s,p -> dirV3 s (mkPrep p) ;\n"
+  ]

examples/big/MAP/log.txt

@@ -0,0 +1,14 @@
+7/11/2006
+
+14.10 write Lisp.cf
+
+14.20 able to parse biglex
+
+14.30 MkBig main program compiles
+
+16.25 writing 5842 lemmas in files
+
+17.15 compiles fine but get conflicts with Irreg and Structural
+
+17.37 compiles fine in BigShallowEng, but not BigEnglish, because the latter
+imports too much conflicting lexicon to remove manually

examples/shallow/BigShallowEng.gf

@@ -3,7 +3,7 @@
 concrete BigShallowEng of BigShallowEngAbs = 
   ShallowEng,
   BigLexEng,
-  IrregEng,
+--  IrregEng,
   ExtraEng-[
     ComplBareVS,MkVPI
   ]

examples/shallow/BigShallowEngAbs.gf

@@ -3,7 +3,7 @@
 abstract BigShallowEngAbs = 
   Shallow,
   BigLexEngAbs,
-  IrregEngAbs,
+--  IrregEngAbs,
   ExtraEngAbs-[
     ComplBareVS, -- : VS -> S -> VP ;     -- know you go
     MkVPI        -- : VP -> VPI ;