From c38f3da80b0ea5ccfca25444bb82b75be4a4eeb5 Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Mon, 7 Jan 2008 15:59:17 +0000
Subject: [PATCH] finnish Swadesh verbs

---
 examples/uusisuomi/Makefile |  5 ++--
 src/GF/Devel/Compute.hs     | 56 ++++++++++++++++++++++++++-----------
 src/GF/Grammar/Compute.hs   | 22 ++++++++++-----
 3 files changed, 58 insertions(+), 25 deletions(-)

diff --git a/examples/uusisuomi/Makefile b/examples/uusisuomi/Makefile
index 5b0d3133e..0df65f1b1 100644
--- a/examples/uusisuomi/Makefile
+++ b/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=VSwadesh ; make -e tests
 	export CAT=V ; export LEX=VDictionary ; make -e tests
 	cat all-diff-V* >all-differences-V
 	cat all-differences-V
diff --git a/src/GF/Devel/Compute.hs b/src/GF/Devel/Compute.hs
index 61efbd5c2..f92da26c9 100644
--- a/src/GF/Devel/Compute.hs
+++ b/src/GF/Devel/Compute.hs
@@ -76,25 +76,29 @@ 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
-         (QC _ _,_)  -> returnC $ App f' a'
 
-         (Alias _ _ d, _) -> comp g (App d a')
+     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
+          _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as')
+          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'
 
-         (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
+          Abs _ _ -> do
+            let (xs,b) = termFormCnc h'
+            let g' = (zip xs as') ++ g
+            let as2 = drop (length xs) as'
+            let xs2 = drop (length as') xs
+            b' <- comp g' (mkAbs xs2 b)
+            if null as2 then return b' else comp g (mkApp b' as2)
 
-	 _ -> 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 +323,26 @@ 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
diff --git a/src/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs
index f2377f12e..c76058cc2 100644
--- a/src/GF/Grammar/Compute.hs
+++ b/src/GF/Grammar/Compute.hs
@@ -45,9 +45,9 @@ computeTerm = computeTermOpt False
 -- have already been computed (mainly with -optimize=noexpand in .gfr)
 
 computeTermOpt :: Bool -> SourceGrammar -> Substitution -> Term -> Err Term
-computeTermOpt rec gr = comp where
+computeTermOpt rec gr = comput True where
 
-   comp g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging 
+   comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging 
               case t of
 
      Q (IC "Predef") _ -> return t
@@ -62,9 +62,14 @@ computeTermOpt rec gr = comp where
          _ | t == t' -> return t
          _ -> comp g t'
 
-     Abs x b -> do 
-       b' <- comp (ext x (Vr x) g) b
-       return $ Abs x b'
+     -- Abs x@(IA _) b -> do 
+     Abs x b | full -> do 
+       let (xs,b1) = termFormCnc t   
+       b' <- comp ([(x,Vr x) | x <- xs] ++ g) b1
+       return $ mkAbs xs b'
+     --  b' <- comp (ext x (Vr x) g) b
+     --  return $ Abs x b'
+     Abs _ _ -> return t -- hnf
 
      Let (x,(_,a)) b -> do
        a' <- comp g a
@@ -78,7 +83,7 @@ computeTermOpt rec gr = comp where
      -- beta-convert
      App f a -> case appForm t of
       (h,as) | length as > 1 -> do
-        h' <- comp g h
+        h' <- hnf g h
         as' <- mapM (comp g) as
         case h' of
           _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as')
@@ -322,7 +327,7 @@ computeTermOpt rec gr = comp where
     where
 
      compApp g (App f a) = do
-       f' <- comp g f
+       f' <- hnf g f
        a' <- comp g a
        case (f',a') of
          (Abs x b, FV as) -> 
@@ -342,6 +347,9 @@ computeTermOpt rec gr = comp where
            (t',b) <- appPredefined (App f' a')
            if b then return t' else comp g t'
 
+     hnf  = comput False
+     comp = comput True
+
      look p c
        | rec       = lookupResDef gr p c >>= comp []
        | otherwise = lookupResDef gr p c