linref is now used by the linearizer. The visible change is that the 'l' command in the shell now can linearize discontinuous phrases

1 files changed, 25 insertions, 20 deletions

diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index 7ff7d9c7a..1e3aee02e 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -23,7 +23,9 @@ import qualified Data.Set as Set
 
 -- | Linearizes given expression as string in the language
 linearize :: PGF -> Language -> Tree -> String
-linearize pgf lang = concat . take 1 . map (unwords . concatMap flattenBracketedString . snd . untokn Nothing . firstLin) . linTree pgf lang
+linearize pgf lang = concat . take 1 . map (unwords . concatMap flattenBracketedString . snd . untokn Nothing . firstLin cnc) . linTree pgf cnc
+  where
+    cnc = lookMap (error "no lang") lang (concretes pgf)
 
 -- | The same as 'linearizeAllLang' but does not return
 -- the language.
@@ -36,24 +38,29 @@ linearizeAllLang :: PGF -> Tree -> [(Language,String)]
 linearizeAllLang pgf t = [(lang,linearize pgf lang t) | lang <- Map.keys (concretes pgf)]
 
 -- | Linearizes given expression as a bracketed string in the language
-bracketedLinearize :: PGF -> Language -> Tree -> BracketedString
-bracketedLinearize pgf lang = head . concat . map (snd . untokn Nothing . firstLin) . linTree pgf lang
+bracketedLinearize :: PGF -> Language -> Tree -> [BracketedString]
+bracketedLinearize pgf lang = concat . map (snd . untokn Nothing . firstLin cnc) . linTree pgf cnc
   where
+    cnc = lookMap (error "no lang") lang (concretes pgf)
+
 --  head []       = error "cannot linearize"
     head []       = Leaf ""
             -- so that linearize = flattenBracketedString . bracketedLinearize
     head (bs:bss) = bs
 
-firstLin (_,arr)
-  | inRange (bounds arr) 0 = arr ! 0
-  | otherwise              = LeafKS []
+firstLin cnc arg@(ct@(cat,n_fid),fid,fun,es,(xs,lin)) =
+  case IntMap.lookup fid (linrefs cnc) of
+    Just (funid:_) -> snd (mkLinTable cnc (const True) [] funid [arg]) ! 0
+    _              -> [LeafKS []]
 
 -- | Creates a table from feature name to linearization. 
 -- The outher list encodes the variations
 tabularLinearizes :: PGF -> Language -> Expr -> [[(String,String)]]
-tabularLinearizes pgf lang e = map cnv (linTree pgf lang e)
+tabularLinearizes pgf lang e = map cnv (linTree pgf cnc e)
   where
-    cnv ((cat,_),lin) = zip (lbls cat) $ map (unwords . concatMap flattenBracketedString . snd . untokn Nothing) (elems lin)
+    cnc = lookMap (error "no lang") lang (concretes pgf)
+
+    cnv (ct@(cat,_),_,_,_,(_,lin)) = zip (lbls cat) $ map (unwords . concatMap flattenBracketedString . snd . untokn Nothing) (elems lin)
 
     lbls cat = case Map.lookup cat (cnccats (lookConcr pgf lang)) of
                  Just (CncCat _ _ lbls) -> elems lbls
@@ -63,11 +70,9 @@ tabularLinearizes pgf lang e = map cnv (linTree pgf lang e)
 -- Implementation
 --------------------------------------------------------------------
 
-linTree :: PGF -> Language -> Expr -> [(CncType, Array LIndex BracketedTokn)]
-linTree pgf lang e = 
-  nub [(ct,amapWithIndex (\label -> Bracket_ cat fid label fun es) lin) | (_,(ct@(cat,fid),fun,es,(xs,lin))) <- lin Nothing 0 e [] [] e []]
+linTree :: PGF -> Concr -> Expr -> [(CncType, FId, CId, [Expr], LinTable)]
+linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] e []))
   where
-    cnc   = lookMap (error "no lang") lang (concretes pgf)
     lp    = lproductions cnc
 
     lin mb_cty n_fid e0 ys xs (EAbs _ x e) es = lin   mb_cty n_fid e0 ys (x:xs) e      es
@@ -78,18 +83,18 @@ linTree pgf lang e =
     lin mb_cty n_fid e0 ys xs (EMeta i)    es = def   mb_cty n_fid e0 ys    xs  ('?':show i)
     lin mb_cty n_fid e0 ys xs (EVar  i)    _  = def   mb_cty n_fid e0 ys    xs  (showCId ((xs++ys) !! i))
     lin mb_cty n_fid e0 ys xs (ELit l)     [] = case l of
-                                                   LStr s -> return (n_fid+1,((cidString,n_fid),wildCId,[e0],([],ss s)))
-                                                   LInt n -> return (n_fid+1,((cidInt,   n_fid),wildCId,[e0],([],ss (show n))))
-                                                   LFlt f -> return (n_fid+1,((cidFloat, n_fid),wildCId,[e0],([],ss (show f))))
+                                                   LStr s -> return (n_fid+1,((cidString,n_fid),fidString,wildCId,[e0],([],ss s)))
+                                                   LInt n -> return (n_fid+1,((cidInt,   n_fid),fidInt,   wildCId,[e0],([],ss (show n))))
+                                                   LFlt f -> return (n_fid+1,((cidFloat, n_fid),fidFloat, wildCId,[e0],([],ss (show f))))
 
     ss s = listArray (0,0) [[LeafKS s]]
 
-    apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, CId, [Expr], LinTable))]
+    apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, FId, CId, [Expr], LinTable))]
     apply mb_cty n_fid e0 ys xs f es =
       case Map.lookup f lp of
         Just prods -> do (funid,(cat,fid),ctys) <- getApps prods
                          (n_fid,args) <- descend n_fid (zip ctys es)
-                         return (n_fid+1,((cat,n_fid),f,[e0],mkLinTable cnc (const True) xs funid args))
+                         return (n_fid+1,((cat,n_fid),fid,f,[e0],mkLinTable cnc (const True) xs funid args))
         Nothing    -> def mb_cty n_fid e0 ys xs ("[" ++ showCId f ++ "]")  -- fun without lin
       where
         getApps prods =
@@ -112,10 +117,10 @@ linTree pgf lang e =
     def (Just (cat,fid)) n_fid e0 ys xs s =
       case IntMap.lookup fid (lindefs cnc) of
         Just funs           -> do funid <- funs
-                                  let args = [((wildCId, n_fid),wildCId,[e0],([],ss s))]
-                                  return (n_fid+2,((cat,n_fid+1),wildCId,[e0],mkLinTable cnc (const True) xs funid args))
+                                  let args = [((wildCId, n_fid),fidString,wildCId,[e0],([],ss s))]
+                                  return (n_fid+2,((cat,n_fid+1),fid,wildCId,[e0],mkLinTable cnc (const True) xs funid args))
         Nothing
-          | isPredefFId fid -> return (n_fid+2,((cat,n_fid+1),wildCId,[e0],(xs,listArray (0,0) [[LeafKS s]])))
+          | isPredefFId fid -> return (n_fid+2,((cat,n_fid+1),fid,wildCId,[e0],(xs,listArray (0,0) [[LeafKS s]])))
           | otherwise       -> do PCoerce fid <- maybe [] Set.toList (IntMap.lookup fid (pproductions cnc))
                                   def (Just (cat,fid)) n_fid e0 ys xs s
     def Nothing          n_fid e0 ys xs s = []