summaryrefslogtreecommitdiff
path: root/old-examples/uusisuomi/MkLex.hs
diff options
context:
space:
mode:
authoraarne <aarne@cs.chalmers.se>2008-06-25 16:54:35 +0000
committeraarne <aarne@cs.chalmers.se>2008-06-25 16:54:35 +0000
commite9e80fc389365e24d4300d7d5390c7d833a96c50 (patch)
treef0b58473adaa670bd8fc52ada419d8cad470ee03 /old-examples/uusisuomi/MkLex.hs
parentb96b36f43de3e2f8b58d5f539daa6f6d47f25870 (diff)
changed names of resource-1.3; added a note on homepage on release
Diffstat (limited to 'old-examples/uusisuomi/MkLex.hs')
-rw-r--r--old-examples/uusisuomi/MkLex.hs118
1 files changed, 118 insertions, 0 deletions
diff --git a/old-examples/uusisuomi/MkLex.hs b/old-examples/uusisuomi/MkLex.hs
new file mode 100644
index 000000000..0e63a5e62
--- /dev/null
+++ b/old-examples/uusisuomi/MkLex.hs
@@ -0,0 +1,118 @@
+module Main where
+
+import System
+import Char
+
+-- generate Finnish lexicon implementations with 1 or more
+-- characteristic arguments
+-- usage: runghc MkLex.hs 3 cat name
+
+main = do
+ i:cat:tgt:_ <- getArgs
+ let src = "correct-" ++ tgt ++ ".txt"
+ ss <- readFile src >>= return . filter (not . (all isSpace)) . lines
+ initiate tgt cat i
+ mapM_ (mkLex cat (read i) . uncurry (++)) (zip nums ss)
+ putStrLn "}"
+
+initiate tgt cat i = mapM_ putStrLn [
+ "--# -path=.:alltenses",
+ "",
+ header i,
+ ""
+ ]
+ where
+ header i = case i of
+ "0" -> unlines [
+ "abstract " ++ tgt ++ "Abs = Cat ** {",
+ "fun testN : N -> Utt ;",
+ "fun testV : V -> Utt ;"
+ ]
+ _ -> unlines [
+ "concrete " ++ tgt ++ i ++
+ " of " ++ tgt ++
+ "Abs = CatFin ** open Nominal, Verbal, ResFin, Prelude in {",
+ "",
+ "lin testN = showN ;",
+ "lin testV = showV ;"
+ ]
+
+nums = map prt [10001 ..] where
+---- prt i = (if i < 10 then "0" else "") ++ show i ++ ". "
+ prt i = show i ++ ". "
+
+-- W is the flag for mixed-class word lists
+mkLex "W" 0 line = case words line of
+ num:cat:sana:_ -> do
+ let nimi = "n" ++ init num ++ "_" ++ sana
+ putStrLn $ "fun " ++ nimi ++ "_" ++ cat ++ " : " ++ cat ++ " ;"
+ _ -> return ()
+
+mkLex "W" 1 line = case words line of
+ num:cat:sanat@(sana:_) -> do
+ let nimi = "n" ++ init num ++ "_" ++ sana
+ putStrLn $ "lin " ++ nimi ++
+ "_" ++ cat ++ " = mk" ++ cat ++ " " ++
+ unwords (map prQuoted sanat) ++" ;"
+ _ -> return ()
+
+mkLex cat 0 line = case words line of
+ num:sana:_ -> do
+ let nimi = "n" ++ init num ++ "_" ++ sana
+ putStrLn $ "fun " ++ nimi ++ "_" ++ cat ++ " : " ++ cat ++ " ;"
+ _ -> return ()
+
+mkLex cat 1 line = case words line of
+ num:sana:_ -> do
+ let nimi = "n" ++ init num ++ "_" ++ sana
+ putStrLn $ "lin " ++ nimi ++
+ "_" ++ cat ++ " = mk" ++ cat ++ " \"" ++ sana ++ "\" ;"
+ _ -> return ()
+
+mkLex "V" _ line = case words line of
+ num:sana:_:_:_:_:_:_:sanan:_ -> do
+ let nimi = "n" ++ init num ++ "_" ++ sana
+ putStrLn $ "lin " ++ nimi ++
+ "_V = mkV \"" ++ sana ++ "\" \"" ++ sanan ++ "\" ;"
+ _ -> return ()
+
+mkLex "N" 2 line = case words line of
+-- num:sana:sanan:_ -> do
+ num:sana:_:_:_:_:_:sanan:_ -> do
+ let nimi = "n" ++ init num ++ "_" ++ sana
+ putStrLn $ "lin " ++ nimi ++
+ "_N = mkN \"" ++ sana ++ "\" \"" ++ sanan ++ "\" ;"
+ _ -> return ()
+
+mkLex "N" 3 line = case words line of
+---- num:sana:sanan:sanoja:_ -> do
+ num:sana:sanan:_:_:_:_:sanoja:_ -> do
+ let nimi = "n" ++ init num ++ "_" ++ sana
+ putStrLn $ "lin " ++ nimi ++
+ "_N = mkN \"" ++ sana ++ "\" \"" ++ sanan ++ "\" \"" ++ sanoja ++ "\" ;"
+ _ -> return ()
+
+mkLex "N" 4 line = case words line of
+ num:sana:sanan:sanaa:_:_:_:sanoja:_ -> do
+ let nimi = "n" ++ init num ++ "_" ++ sana
+ putStrLn $ "lin " ++ nimi ++
+ "_N = mkN \"" ++ sana ++ "\" \"" ++ sanan ++
+ "\" \"" ++ sanoja ++ "\" \"" ++ sanaa ++ "\" ;"
+ _ -> return ()
+
+-- to initiate from a noun list that has compounds
+
+mkLex "N" 11 line = case words line of
+ _:"--":_ -> return ()
+ num:sana0:_ -> do
+ let sana = uncompound sana0
+ let nimi = "n" ++ init num ++ "_" ++ sana
+ putStrLn $ "fun " ++ nimi ++ "_N : N ;"
+ putStrLn $ "lin " ++ nimi ++ "_N = mkN \"" ++ sana ++ "\" ;"
+ _ -> return ()
+
+prQuoted s = concat ["\"",s,"\""]
+
+-- from sora+tie to tie
+
+uncompound = reverse . takeWhile (/= '+') . reverse