dictionary experiment with Finnish verbs

examples/uusisuomi/Declensions.gf

@@ -466,7 +466,7 @@ resource Declensions = ResFin ** open MorphoFin,CatFin,Prelude in {
       "mm" + e => "mp" + e ;
       "rr" + e => "rt" + e ;
       "ll" + a => "lt" + a ;
-      h@("h" | "l") + "j" + e => h + "k" + e ; -- pohje/lahje impossible
+      h@("h" | "l") + "je" + e => h + "ke" ; -- pohje/lahje impossible
       ("tk" | "hk" | "sk" | "sp" | "st") + _ => nke ;       -- viuhke,kuiske 
       a + k@("k"|"p"|"t") + e@("e"|"a"|"ä"|"u"|"i"|"o"|"ö")  => a + k + k + e ;
       a + "d" + e@("e"|"a"|"ä"|"u"|"i"|"o"|"ö")  => a + "t" + e ; 

examples/uusisuomi/Makefile

@@ -4,8 +4,9 @@ CAT=N
 all: nouns
 
 verbs: 
-	export CAT=V ; export LEX=VNSSK ; make -e tests
-	export CAT=V ; export LEX=VOmat ; make -e tests
+#	export CAT=V ; export LEX=VNSSK ; make -e tests
+#	export CAT=V ; export LEX=VOmat ; make -e tests
+	export CAT=V ; export LEX=VDictionary ; make -e tests
 	cat all-diff-V* >all-differences-V
 	cat all-differences-V
 

examples/uusisuomi/MkLex.hs

@@ -57,7 +57,7 @@ mkLex "V" _ line = case words line of
   num:sana:_:_:_:_:_:_:sanan:_ -> do
     let nimi = "n" ++ init num ++ "_" ++ sana 
     putStrLn $ "lin " ++ nimi ++ 
-      "_V = mk2V <\"" ++ sana ++ "\", \"" ++ sanan ++ "\"> ;"
+      "_V = mkV \"" ++ sana ++ "\" \"" ++ sanan ++ "\" ;"
   _ -> return ()
 
 mkLex "N" 2 line = case words line of

examples/uusisuomi/Verbal.gf

@@ -9,7 +9,7 @@ resource Verbal = ResFin **
 
   mkV = overload {
     mkV : (huutaa : Str) -> V = mk1V ;
-    mkV : (huutaa,huusi : Str) -> V = \s,t -> mk2V <s,t> ;
+    mkV : (huutaa,huusi : Str) -> V = mk2V ;
   } ;
 
   showV : V -> Utt = \v -> ss (
@@ -27,8 +27,7 @@ resource Verbal = ResFin **
    ) ** {lock_Utt = <>} ;
 
   mk1V : Str -> V = \s -> vforms2V (vForms1 s) ;
-  mk2V : (_ : Str * Str) -> V = \st -> 
-    vforms2V (vForms2 st.p1 st.p2) ;
+  mk2V : (_,_ : Str) -> V = \s,t -> vforms2V (vForms2 s t) ;
 
   vForms1 : Str -> VForms = \ottaa ->
     let
@@ -45,6 +44,9 @@ resource Verbal = ResFin **
         cHukkua ottaa (ota + "n") ;
       _ + ("l" | "n" | "r") + ("taa" | "tää") => 
         cOttaa ottaa (ota + "n") (ots + "in") (ots + "i") ;
+      ("" | C_) + ("a" | "e" | "i" | "o" | "u") + C_ + _ + 
+        ("a" | "e" | "i" | "o" | "u") + _ + "aa" => 
+        cOttaa ottaa (ota + "n") (ot + "in") (ott + "i") ;
       ("" | C_) + ("a" | "e" | "i") + _ + "aa" => 
         cOttaa ottaa (ota + "n") (ot + "oin") (ott + "oi") ;
       _ + ("aa" | "ää") => 

examples/uusisuomi/correct-VDictionary.txt

@@ -0,0 +1,100 @@
+aikoa aion aikoo aikovat aikokaa aiotaan aioin aikoi aikoisi aikonut aiottu
+
+alentaa alennan alentaa alentavat alentakaa alennetaan alensin alensi alentaisi alentanut alennettu
+
+ansioitua ansioidun ansioituu ansioituvat ansioitukaa ansioidutaan ansioiduin ansioitui ansioituisi ansioitunut ansioiduttu
+
+arvostaa arvostan arvostaa arvostavat arvostakaa arvostetaan arvostin arvosti arvostaisi arvostanut arvostettu
+
+avustaa avustan avustaa avustavat avustakaa avustetaan avustin avusti avustaisi avustanut avustettu
+
+dominoida dominoin dominoi dominoivat dominoikaa dominoidaan dominoin dominoi dominoisi dominoinut dominoitu
+
+elämöidä elämöin elämöi elämöivät elämöikää elämöidään elämöin elämöi elämöisi elämöinyt elämöity
+
+epäilyttää epäilytän epäilyttää epäilyttävät epäilyttäkää epäilytetään epäilytin epäilytti epäilyttäisi epäilyttänyt epäilytetty
+
+esitellä esittelen esittelee esittelevät esitelkää esitellään esittelin esitteli esittelisi esitellyt esitelty
+
+fakturoida fakturoin fakturoi fakturoivat fakturoikaa fakturoidaan fakturoin fakturoi fakturoisi fakturoinut fakturoitu
+
+halata halaan halaa halaavat halatkaa halataan halasin halasi halaisi halannut halattu
+
+harjata harjaan harjaa harjaavat harjatkaa harjataan harjasin harjasi harjaisi harjannut harjattu
+
+hengittää hengitän hengittää hengittävät hengittäkää hengitetään hengitin hengitti hengittäisi hengittänyt hengitetty
+
+hihittää hihitän hihittää hihittävät hihittäkää hihitetään hihitin hihitti hihittäisi hihittänyt hihitetty
+
+hullutella hulluttelen hulluttelee hulluttelevat hullutelkaa hullutellaan hulluttelin hullutteli hulluttelisi hullutellut hulluteltu
+
+huuhtoutua huuhtoudun huuhtoutuu huuhtoutuvat huuhtoutukaa huuhtoudutaan huuhtouduin huuhtoutui huuhtoutuisi huuhtoutunut huuhtouduttu
+
+häpäistä häpäisen häpäisee häpäisevät häpäiskää häpäistään häpäisin häpäisi häpäisisi häpäissyt häpäisty
+
+ikävystyttää ikävystytän ikävystyttää ikävystyttävät ikävystyttäkää ikävystytetään ikävystytin ikävystytti ikävystyttäisi ikävystyttänyt ikävystytetty
+
+isännöidä isännöin isännöi isännöivät isännöikää isännöidään isännöin isännöi isännöisi isännöinyt isännöity
+
+jatkua jatkun jatkuu jatkuvat jatkukaa jatkutaan jatkuin jatkui jatkuisi jatkunut jatkuttu
+
+jupista jupisen jupisee jupisevat jupiskaa jupistaan jupisin jupisi jupisisi jupissut jupistu
+
+jätättää jätätän jätättää jätättävät jätättäkää jätätetään jätätin jätätti jätättäisi jätättänyt jätätetty
+
+kalastaa kalastan kalastaa kalastavat kalastakaa kalastetaan kalastin kalasti kalastaisi kalastanut kalastettu
+
+kansoittaa kansoitan kansoittaa kansoittavat kansoittakaa kansoitetaan kansoitin kansoitti kansoittaisi kansoittanut kansoitettu
+
+kaulia kaulin kaulii kaulivat kaulikaa kaulitaan kaulin kauli kaulisi kaulinut kaulittu
+
+kellua kellun kelluu kelluvat kellukaa kellutaan kelluin kellui kelluisi kellunut kelluttu
+
+kierittää kieritän kierittää kierittävät kierittäkää kieritetään kieritin kieritti kierittäisi kierittänyt kieritetty
+
+kipinöidä kipinöin kipinöi kipinöivät kipinöikää kipinöidään kipinöin kipinöi kipinöisi kipinöinyt kipinöity
+
+kokkaroitua kokkaroidun kokkaroituu kokkaroituvat kokkaroitukaa kokkaroidutaan kokkaroiduin kokkaroitui kokkaroituisi kokkaroitunut kokkaroiduttu
+
+korjauttaa korjautan korjauttaa korjauttavat korjauttakaa korjautetaan korjautin korjautti korjauttaisi korjauttanut korjautettu
+
+kukistaa kukistan kukistaa kukistavat kukistakaa kukistetaan kukistin kukisti kukistaisi kukistanut kukistettu
+
+kuntouttaa kuntoutan kuntouttaa kuntouttavat kuntouttakaa kuntoutetaan kuntoutin kuntoutti kuntouttaisi kuntouttanut kuntoutettu
+
+kyllästyttää kyllästytän kyllästyttää kyllästyttävät kyllästyttäkää kyllästytetään kyllästytin kyllästytti kyllästyttäisi kyllästyttänyt kyllästytetty
+
+käskeä käsken käskee käskevät käskekää käsketään käskin käski käskisi käskenyt käsketty
+
+lainata lainaan lainaa lainaavat lainatkaa lainataan lainasin lainasi lainaisi lainannut lainattu
+
+laskostaa laskostan laskostaa laskostavat laskostakaa laskostetaan laskostin laskosti laskostaisi laskostanut laskostettu
+
+lihoa lihon lihoo lihovat lihokaa lihotaan lihoin lihoi lihoisi lihonut lihottu
+
+liuottaa liuotan liuottaa liuottavat liuottakaa liuotetaan liuotin liuotti liuottaisi liuottanut liuotettu
+
+luotsata luotsaan luotsaa luotsaavat luotsatkaa luotsataan luotsasin luotsasi luotsaisi luotsannut luotsattu
+
+läpäistä läpäisen läpäisee läpäisevät läpäiskää läpäistään läpäisin läpäisi läpäisisi läpäissyt läpäisty
+
+maksoittaa maksoitan maksoittaa maksoittavat maksoittakaa maksoitetaan maksoitin maksoitti maksoittaisi maksoittanut maksoitettu
+
+menestyä menestyn menestyy menestyvät menestykää menestytään menestyin menestyi menestyisi menestynyt menestytty
+
+mitätöidä mitätöin mitätöi mitätöivät mitätöikää mitätöidään mitätöin mitätöi mitätöisi mitätöinyt mitätöity
+
+muokata muokkaan muokkaa muokkaavat muokatkaa muokataan muokkasin muokkasi muokkaisi muokannut muokattu
+
+naamioida naamioin naamioi naamioivat naamioikaa naamioidaan naamioin naamioi naamioisi naamioinut naamioitu
+
+niiskuttaa niiskutan niiskuttaa niiskuttavat niiskuttakaa niiskutetaan niiskutin niiskutti niiskuttaisi niiskuttanut niiskutettu
+
+nähdä näen näkee näkevät nähkää nähdään näin näki näkisi nähnyt nähty
+
+ohjata ohjaan ohjaa ohjaavat ohjatkaa ohjataan ohjasin ohjasi ohjaisi ohjannut ohjattu
+
+opiskella opiskelen opiskelee opiskelevat opiskelkaa opiskellaan opiskelin opiskeli opiskelisi opiskellut opiskeltu
+
+paaduttaa paadutan paaduttaa paaduttavat paaduttakaa paadutetaan paadutin paadutti paaduttaisi paaduttanut paadutettu
+

src/GF/Grammar/Compute.hs

@@ -76,26 +76,27 @@ computeTermOpt rec gr = comp where
        return $ Prod x a' b'
 
      -- beta-convert
-     App f a -> do
-       f' <- comp g f
-       a' <- comp g a
-       case (f',a') of
-         (Abs x b, FV as) -> 
-           mapM (\c -> comp (ext x c g) b) as >>= return . variants
-         (_, FV as)  -> mapM (\c -> comp g (App f' c)) as >>= return . variants
-         (FV fs, _)  -> mapM (\c -> comp g (App c a')) fs >>= return . variants
-         (Abs x b,_) -> comp (ext x a' g) b
+     App f a -> case appForm t of
+      (h,as) | length as > 1 -> do
+        h' <- comp g h
+        as' <- mapM (comp g) as
+        case h' of
 
-         (QC _ _,_)  -> returnC $ App f' a'
+          c@(QC _ _) -> do
+            return $ mkApp c as'
+          Q (IC "Predef") f -> do     
+            (t',b) <- appPredefined (mkApp h' as')
+            if b then return t' else comp g t'
 
-         (Alias _ _ d, _) -> comp g (App d a')
+          Abs _ _ -> do
+            let (xs,b) = termFormCnc h'
+            let g' = (zip xs as') ++ g
+            let as2 = drop (length xs) as'
+            b' <- comp g' b
+            if null as2 then return b' else comp g (mkApp b' as2)
 
-         (S (T i cs) e,_) -> prawitz g i (flip App a') cs e
-         (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
-
-	 _ -> do
-           (t',b) <- appPredefined (App f' a')
-           if b then return t' else comp g t'
+          _ -> compApp g (mkApp h' as')
+      _ -> compApp g t
 
      P t l | isLockLabel l -> return $ R [] 
      ---- a workaround 18/2/2005: take this away and find the reason
@@ -319,6 +320,27 @@ computeTermOpt rec gr = comp where
 
     where
 
+     compApp g (App f a) = do
+       f' <- comp g f
+       a' <- comp g a
+       case (f',a') of
+         (Abs x b, FV as) -> 
+           mapM (\c -> comp (ext x c g) b) as >>= return . variants
+         (_, FV as)  -> mapM (\c -> comp g (App f' c)) as >>= return . variants
+         (FV fs, _)  -> mapM (\c -> comp g (App c a')) fs >>= return . variants
+         (Abs x b,_) -> comp (ext x a' g) b
+
+         (QC _ _,_)  -> returnC $ App f' a'
+
+         (Alias _ _ d, _) -> comp g (App d a')
+
+         (S (T i cs) e,_) -> prawitz g i (flip App a') cs e
+         (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
+
+	 _ -> do
+           (t',b) <- appPredefined (App f' a')
+           if b then return t' else comp g t'
+
      look p c
        | rec       = lookupResDef gr p c >>= comp []
        | otherwise = lookupResDef gr p c