Fin modules of NDTrans in place, but refactoring in needed

lib/src/experimental/LiftFin.gf

@@ -0,0 +1,60 @@
+concrete LiftFin of Lift =
+   RGLBaseFin - [Pol,Tense]
+  ,PredFin
+
+              ** open ResFin, 
+                      PredInstanceFin, 
+                      Prelude in {
+
+--flags literal=Symb ;
+
+{-
+oper
+  liftV = PredInstanceFin.liftV ;
+
+lin
+  LiftV  v = liftV v ;
+  LiftV2 v = <liftV <v : Verb> : PrVerb> ** {c1 = v.c2.s} ;
+  LiftVS v = liftV v ;
+  LiftVQ v = liftV v ;
+  LiftVA v = liftV v ; ---- c1?
+  LiftVN v = liftV v ; ---- c1?
+  LiftVV v = <liftV <v : Verb> : PrVerb> ** {c1 = v.c2.s} ;
+
+  LiftV3  v = <liftV <v : Verb> : PrVerb> ** {c1 = v.c2.s ; c2 = v.c3.s} ;
+
+  LiftV2S v = <liftV <v : Verb> : PrVerb> ** {c1 = v.c2.s} ;
+  LiftV2Q v = <liftV <v : Verb> : PrVerb> ** {c1 = v.c2.s} ;
+  LiftV2V v = <liftV <v : Verb> : PrVerb> ** {c1 = v.c2.s ; c2 = v.c3.s} ;
+  LiftV2A v = <liftV <v : Verb> : PrVerb> ** {c1 = v.c2.s} ;
+  LiftV2N v = <liftV <v : Verb> : PrVerb> ** {c1 = v.c2.s} ;
+
+  LiftAP ap = {s = \\a => ap.s ! agr2aformpos a ; c1,c2 = [] ; obj1 = \\_ => []} ;  --- isPre
+  LiftA2 ap = {s = \\a => ap.s ! AF (APosit (agr2aformpos a)) Nom ; c1 = ap.c2.s ; c2 = [] ; obj1 = \\_ => []} ;  --- isPre
+
+  LiftCN cn = {s = \\n => cn.s ! n ! DIndef ! Nom ; c1,c2 = [] ; obj1 = \\_ => []} ; 
+  LiftN2 cn = {s = \\n => cn.s ! n ! specDet DIndef ! Nom ; c1 = cn.c2.s ; c2 = [] ; obj1 = \\_ => []} ; 
+
+  AppAPCN ap cn = 
+    {s = \\n,d,c => 
+         let 
+            agr = {n = n ; g = cn.g ; p = P3}
+         in (cn.s ! n ! d ! c) ++ (ap.s ! agr ++ ap.obj1 ! agr) ;  -- flicka älskad av alla
+         g = cn.g ; 
+         isMod = True
+    } 
+  | {s = \\n,d,c => 
+         let 
+            agr = {n = n ; g = cn.g ; p = P3}
+         in (ap.obj1 ! agr ++ ap.s ! agr) ++ (cn.s ! n ! d ! c) ;  -- av alla älskad flicka
+         g = cn.g ; 
+         isMod = True
+    } ; 
+
+  LiftAdv  a = a ** {isAdV = False ; c1 = []} ;
+  LiftAdV  a = a ** {isAdV = True ; c1 = []} ;
+  LiftPrep p = {s = [] ; isAdV = False ; c1 = p.s} ;
+-}
+
+}
+

lib/src/experimental/NDLiftFin.gf

@@ -0,0 +1,5 @@
+concrete NDLiftFin of NDLift =
+   RGLBaseFin - [Pol,Tense]
+  ,NDPredFin 
+
+    ** NDLiftFunctor with (Lift = LiftFin) ;

lib/src/experimental/NDPredFin.gf

@@ -0,0 +1,6 @@
+concrete NDPredFin of Pred = 
+  CatFin [Ant,NP,Utt,IP,IAdv,Conj] ** 
+    NDPredFunctor 
+     with 
+      (PredInterface = PredInstanceFin),
+      (Pred = PredFin) ;

lib/src/experimental/NDTransFin.gf

@@ -0,0 +1,14 @@
+--# -path=.:../finnish/stemmed:../finnish:../translator:alltenses
+
+concrete NDTransFin of NDTrans =
+   NDLiftFin
+  ,ExtensionsFin [CN,NP,AdA,AdV,CompoundCN,AdAdV,UttAdV,ApposNP]
+  ,DictionaryFin - [Pol,Tense]
+
+              ** {
+
+flags 
+  literal=Symb ;
+
+}
+

lib/src/experimental/PredFin.gf

@@ -0,0 +1,12 @@
+concrete PredFin of Pred = 
+  CatFin [Ant,NP,Utt,IP,IAdv,Conj] ** 
+    PredFunctor - [StartVPC, ContVPC, ---- need generalization
+                   AgentPassUseV,AgentPastPartAP]     ---- moreover slow
+      with 
+      (PredInterface = PredInstanceFin) 
+
+  ** {
+
+lin StartVPC, ContVPC, AgentPassUseV, AgentPastPartAP = variants {} ; ---- just to make it compile as instance of Pred
+
+} 

lib/src/experimental/PredFunctor.gf

@@ -33,7 +33,7 @@ lincat
     c3 : ComplCase ;
     } ;
 
-  PrAdv   = {s : Str ; isAdV : Bool ; c1 : Str} ;
+  PrAdv   = {s : Str ; isAdV : Bool ; c1 : ComplCase} ;
   PrS     = {s : Str} ;
 
   PrAP = {
@@ -62,7 +62,7 @@ linref
  
   PrCl  = \cl  -> declCl cl ;
   PrQCl = \qcl -> questCl qcl ;
-  PrAdv = \adv -> adv.c1 ++ adv.s ;
+  PrAdv = \adv -> strComplCase adv.c1 ++ adv.s ;
   PrAP  = \ap  -> ap.s ! defaultAgr ++ ap.obj1 ! defaultAgr ;  
   PrCN  = \cn  -> cn.s ! Sg ++ cn.obj1 ! defaultAgr ; 
   
@@ -197,8 +197,8 @@ lin
     v    = vp.v ! agr2vagr np.a ;
     subj = np.s ! subjCase ;
     adj  = vp.adj ! np.a ;
-    obj1 = vp.part ++ vp.c1 ++ vp.obj1.p1 ! np.a ;  ---- apply complCase ---- place of part depends on obj
+    obj1 = vp.part ++ strComplCase vp.c1 ++ vp.obj1.p1 ! np.a ;  ---- apply complCase ---- place of part depends on obj
-    obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => np.a ; False => vp.obj1.p2}) ;   ---- apply complCase
+    obj2 = strComplCase vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => np.a ; False => vp.obj1.p2}) ;   ---- apply complCase
     c3   = noComplCase ;      -- for one more prep to build ClSlash 
     qforms = vp.qforms ! agr2vagr np.a ;
     } ;
@@ -221,8 +221,8 @@ lin
     focType = FocSubj ;
     subj = [] ;
     adj  = vp.adj ! ipa ;
-    obj1 = vp.part ++ vp.c1 ++ vp.obj1.p1 ! ipa ; ---- appComplCase
+    obj1 = vp.part ++ strComplCase vp.c1 ++ vp.obj1.p1 ! ipa ; ---- appComplCase
-    obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => ipa ; False => vp.obj1.p2}) ; ---- appComplCase
+    obj2 = strComplCase vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => ipa ; False => vp.obj1.p2}) ; ---- appComplCase
     c3   = noComplCase ;      -- for one more prep to build ClSlash ---- ever needed for QCl?
     adv  = vp.adv ;
     adV  = vp.adV ;
@@ -237,7 +237,7 @@ lin
       ips  = ip.s ! objCase ;                     -- in Cl/NP, c3 is the only prep ---- appComplCase for ip
       focobj = case cl.focType of {
         NoFoc => <ips, [], FocObj,prep> ;         -- put ip object to focus  if there is no focus yet
-        t     => <[], prep ++ ips, t,noComplCase> -- put ip object in situ   if there already is a focus
+        t     => <[], strComplCase prep ++ ips, t,noComplCase> -- put ip object in situ   if there already is a focus
         } ;
     in 
     cl ** {     -- preposition stranding
@@ -310,8 +310,8 @@ lin
           w.c1 ++ w.obj1.p1 ! vpa ++ w.c2 ++ w.obj2.p1 ! vpa ++ w.adv ++ w.ext ;
     inf = \\a => 
             infVP v.vvtype a v ++ c.s2 ++ infVP w.vvtype a w ;
-    c1 = [] ; ---- w.c1 ? --- the full story is to unify v and w...
+    c1 = noComplCase ; ---- w.c1 ? --- the full story is to unify v and w...
-    c2 = [] ; ---- w.c2 ? 
+    c2 = noComplCase ; ---- w.c2 ? 
     } ;
 
   ContVPC x v w = {  ---- some loss of quality seems inevitable
@@ -327,8 +327,8 @@ lin
           wv ;
     inf = \\a => 
             infVP v.vvtype a v ++ "," ++ w.inf ! a ;
-    c1 = [] ; ---- w.c1 ? --- the full story is to unify v and w...
+    c1 = noComplCase ; ---- w.c1 ? --- the full story is to unify v and w...
-    c2 = [] ; ---- w.c2 ? 
+    c2 = noComplCase ; ---- w.c2 ? 
     } ;
 
   UseVPC x vpc = { ---- big loss of quality (overgeneration) seems inevitable
@@ -370,6 +370,6 @@ lin
     qforms = <[],[]> ; ---- qforms
     } ;
 
-  ComplAdv x p np = {s = p.c1 ++ np.s ! objCase ; isAdV = p.isAdV ; c1 = []} ;
+  ComplAdv x p np = {s = appComplCase p.c1 np ; isAdV = p.isAdV ; c1 = noComplCase} ;
 
 }

lib/src/experimental/PredInstanceEng.gf

@@ -34,6 +34,7 @@ oper
 
   appComplCase  : ComplCase -> NounPhrase -> Str = \p,np -> p ++ np.s ! objCase ;
   noComplCase   : ComplCase = [] ;
+  strComplCase  : ComplCase -> Str = \c -> c ;
 
   noObj : Agr => Str = \\_ => [] ;
 

lib/src/experimental/PredInstanceFin.gf

@@ -0,0 +1,153 @@
+instance PredInstanceFin of PredInterface - [NounPhrase,PrVerb] = 
+  open ResFin, (P = ParadigmsFin), (S = StemFin), (X = ParamX), Prelude in {
+
+-- overrides
+
+oper
+  NounPhrase = ResFin.NP ;
+  PrVerb = StemFin.SVerb1 ** {
+    c1 : ComplCase ; 
+    c2 : ComplCase ;
+    isSubjectControl : Bool ;
+    vtype : VType ;  
+    vvtype : VVType ;
+    } ; 
+
+---------------------
+-- parameters -------
+---------------------
+
+oper
+  Agr    = ResFin.Agr ;
+  Case   = ResFin.Case ;
+  NPCase = ResFin.NPForm ;
+  VForm  = S.SVForm ;
+  VVType = ResFin.InfForm ;
+  VType  = Unit ; ----
+  Gender = Unit ; ----
+
+  VAgr   = Agr ;
+
+  SVoice = Voice ;
+
+oper
+  active = Act ;
+  passive = Pass ;
+
+  subjCase : NPCase = ResFin.NPCase Nom ;
+  objCase  : NPCase = NPAcc ;
+
+  ComplCase = ResFin.Compl ; -- preposition
+  agentCase : ComplCase = P.postGenPrep "toimesta" ;
+  strComplCase : ComplCase -> Str = \c -> c.s ! False ;
+
+  appComplCase  : ComplCase -> NounPhrase -> Str = \p,np -> appCompl True Pos p np ;
+  noComplCase   : ComplCase = P.postGenPrep [] ; ----
+
+  noObj : Agr => Str = \\_ => [] ;
+
+  NAgr = Number ; 
+  IPAgr = Number ; --- two separate fields in RGL
+
+  defaultAgr : Agr = Ag Sg P3 ;
+
+-- omitting rich Agr information
+  agr2vagr : Agr -> VAgr = \a -> a ;
+
+  agr2aagr : Agr -> AAgr = \a -> a ;
+
+  agr2nagr : Agr -> NAgr = \a -> case a of {Ag n _ => n ; AgPol => Sg} ; -- minä olen pomo / te olette pomoja / te olette pomo
+
+-- restoring full Agr
+  ipagr2agr : IPAgr -> Agr = \a -> Ag a P3 ;
+
+  ipagr2vagr : IPAgr -> VAgr = \n -> Ag n P3 ;
+
+--- this is only needed in VPC formation
+  vagr2agr : VAgr -> Agr = \a -> a ;
+
+  vPastPart : PrVerb -> AAgr -> Str = \v,a -> (S.sverb2verbSep v).s ! PastPartPass (AN (NCase Sg Part)) ; ---- case
+  vPresPart : PrVerb -> AAgr -> Str = \v,a -> (S.sverb2verbSep v).s ! PresPartAct (AN (NCase Sg Part)) ; ---- case
+
+  vvInfinitive : VVType = Inf1 ;
+
+  isRefl : PrVerb -> Bool = \_ -> False ; ----
+
+
+------------------
+--- opers --------
+------------------
+
+oper 
+  reflPron : Agr -> Str = \a -> (ResFin.reflPron a).s ! NPAcc ; ---- case
+
+  infVP : VVType -> Agr -> PrVerbPhrase -> Str = \vt, a,vp -> 
+    let 
+      a2 = case vp.obj2.p2 of {True => a ; False => vp.obj1.p2} 
+    in
+      vp.adV ++ vp.inf ! vt ++ 
+      vp.adj ! a ++ vp.obj1.p1 ! a ++ vp.obj2.p1 ! a2 ++ vp.adv ++ vp.ext ;
+
+  qformsV : Str -> STense -> Anteriority -> Polarity -> VAgr -> PrVerb -> Str * Str = 
+    \sta,t,a,p,agr,v -> <[],[]> ; ----- not needed in Finnish
+ 
+
+  declCl       : PrClause -> Str = \cl -> cl.subj ++ cl.v.p1 ++ cl.adV ++ cl.v.p2 ++ restCl cl ;
+  declSubordCl : PrClause -> Str = \cl -> cl.subj ++ cl.adV ++ cl.v.p1 ++ (cl.v.p2 | []) ++ restCl cl ;
+  declInvCl    : PrClause -> Str = \cl -> cl.v.p1 ++ cl.subj ++ cl.adV ++ cl.v.p2 ++ restCl cl ;
+
+  questCl      : PrQuestionClause -> Str = \cl -> cl.foc ++ cl.v.p1 ++ cl.subj ++ cl.adV ++ cl.v.p2 ++ restCl cl ;
+
+  questSubordCl : PrQuestionClause -> Str = questCl ;
+
+  that_Compl : Str = "että" ;
+
+  -- this part is usually the same in all reconfigurations
+  restCl : PrClause -> Str = \cl -> cl.v.p3 ++ cl.adj ++ cl.obj1 ++ cl.obj2 ++ cl.adv ++ cl.ext ++ cl.c3.s ! False ; ---- c3
+
+  negAdV :  {s : Str ; p : Polarity} -> Str = \p -> p.s ;
+
+  tenseV : Str -> STense -> Anteriority -> Polarity -> SVoice -> VAgr -> PrVerb -> Str * Str * Str = 
+       \sta,t,a,pol,o,agr,v -> 
+   let 
+     ovps = (S.vp2old_vp (S.predV v)).s ! VIFin t ! a ! pol ! agr ; -- VIForm => Anteriority => Polarity => Agr => {fin, inf : Str} ;
+     act = Act 
+   in
+   <sta ++ ovps.fin, ovps.inf, []> ;
+
+  tenseInfV : Str -> Anteriority -> Polarity -> SVoice -> PrVerb -> VVType -> Str = 
+      \sa,a,pol,o,v,vt ->
+   let 
+     ovps = (S.vp2old_vp (S.predV v)).s ! VIInf vt ! a ! pol ! defaultAgr ; -- VIForm => Anteriority => Polarity => Agr => {fin, inf : Str} ;
+   in
+   sa ++ ovps.fin ++ ovps.inf ;
+
+  tenseCopula : Str -> STense -> Anteriority -> Polarity -> VAgr -> Str * Str * Str =
+    \s,t,a,p,agr -> tenseV s t a p Act agr (liftV P.olla_V) ;
+  tenseInfCopula : Str -> Anteriority -> Polarity -> VVType -> Str =
+    \s,a,p,vt -> tenseInfV s a p Act (liftV P.olla_V) vt ;
+
+  noObj : Agr => Str = \\_ => [] ;
+
+  addObj2VP : PrVerbPhrase -> (Agr => Str) -> PrVerbPhrase = \vp,obj -> vp ** {
+    obj2 = <\\a => vp.obj2.p1 ! a ++ obj ! a, vp.obj2.p2> ;
+    } ;
+
+  addExtVP : PrVerbPhrase -> Str -> PrVerbPhrase = \vp,ext -> vp ** {
+    ext = ext ;
+    } ;
+
+  not_Str : Polarity -> Str = \p -> case p of {Pos => [] ; Neg => "inte"} ;
+
+  liftV : S.SVerb1 -> PrVerb = \v -> 
+    v ** {c1,c2 = noComplCase ; isSubjectControl = False ; vtype = UUnit ; vvtype = vvInfinitive} ; 
+
+--- junk
+
+  qformsV : Str -> STense -> Anteriority -> Polarity -> VAgr -> PrVerb -> Str * Str = 
+    \sta,t,a,p,agr,v -> <[],[]> ;
+  qformsCopula : Str -> STense -> Anteriority -> Polarity -> VAgr -> Str * Str = 
+    \sta,t,a,p,agr -> <[],[]> ;
+
+
+}

lib/src/experimental/PredInstanceSwe.gf

@@ -30,6 +30,7 @@ oper
 
   appComplCase  : ComplCase -> NounPhrase -> Str = \p,np -> p ++ np.s ! objCase ;
   noComplCase   : ComplCase = [] ;
+  strComplCase  : ComplCase -> Str = \c -> c ;
 
   noObj : Agr => Str = \\_ => [] ;
 

lib/src/experimental/PredInterface.gf

@@ -46,7 +46,7 @@ oper
 
   ComplCase : Type ; -- e.g. preposition
   agentCase : ComplCase ;
-
+  strComplCase : ComplCase -> Str ;
 
   NounPhrase : Type = {s : NPCase => Str ; a : Agr} ;
 
@@ -173,8 +173,8 @@ oper
     \a,t,p -> {
     v   = \\agr => tenseCopula (a.s ++ t.s ++ p.s) t.t a.a p.p agr ;
     inf = \\vt => tenseInfCopula a.s a.a p.p vt ;
-    c1 = [] ;
+    c1 = noComplCase ;
-    c2 = [] ;
+    c2 = noComplCase ;
     part = [] ;
     adj = \\_ => [] ;
     obj1 = <noObj,defaultAgr> ;

lib/src/experimental/RGLBaseFin.gf

@@ -0,0 +1,20 @@
+concrete RGLBaseFin of RGLBase = 
+
+-- modules in Grammar, excluding Structural, Verb, Sentence, Question
+----  Tense,
+  NounFin - [PPartNP],               -- to be generalized
+  AdjectiveFin,
+  NumeralFin,
+  ConjunctionFin,
+  AdverbFin,
+  PhraseFin - [UttS],
+----  Sentence,
+----  Question,
+  RelativeFin,
+----  Idiom [NP, VP, Cl, Tense, ProgrVP, ExistNP, SelfAdvVP, SelfAdVVP, SelfNP], ---- why only these?
+
+  SymbolFin [PN, Symb, String, CN, Card, NP, MkSymb, SymbPN, CNNumNP] ;          ---- why only these?
+
+----  Construction,
+----  Extensions,
+----  Documentation ;

lib/src/experimental/TestFin.gf

@@ -0,0 +1,8 @@
+--# -path=.:../finnish/stemmed:../finnish:../common:alltenses
+
+concrete TestFin of Test =
+   LiftFin - [MkSymb]
+  ,LexiconFin - [Pol,Tense]
+  ,StructuralFin - [Pol,Tense]
+  ;
+