prefix and variants restored in linearization

3 files changed, 34 insertions, 18 deletions

diff --git a/src-3.0/PGF.hs b/src-3.0/PGF.hs
index 0739815be..87f186573 100644
--- a/src-3.0/PGF.hs
+++ b/src-3.0/PGF.hs
@@ -55,8 +55,7 @@ module PGF(
           ) where
 
 import PGF.CId
-import PGF.Linearize hiding (linearize)
-import qualified PGF.Linearize (linearize)
+import PGF.Linearize
 import PGF.Generate
 import PGF.Macros
 import PGF.Data
@@ -177,7 +176,7 @@ readPGF f = do
   g <- parseGrammar s
   return $! toPGF g
 
-linearize pgf lang = PGF.Linearize.linearize pgf (mkCId lang)
+linearize pgf lang = concat . take 1 . PGF.Linearize.linearizes pgf (mkCId lang)
 
 parse pgf lang cat s = 
   case Map.lookup (mkCId lang) (concretes pgf) of
diff --git a/src-3.0/PGF/Linearize.hs b/src-3.0/PGF/Linearize.hs
index c3341698f..5bc40438f 100644
--- a/src-3.0/PGF/Linearize.hs
+++ b/src-3.0/PGF/Linearize.hs
@@ -1,8 +1,9 @@
-module PGF.Linearize where
+module PGF.Linearize (linearizes,realize,realizes,linTree) where
 
 import PGF.CId
 import PGF.Data
 import PGF.Macros
+
 import qualified Data.Map as Map
 import Data.List
 
@@ -10,20 +11,35 @@ import Debug.Trace
 
 -- linearization and computation of concrete PGF Terms
 
-linearize :: PGF -> CId -> Tree -> String
-linearize pgf lang = realize . linTree pgf lang
+linearizes :: PGF -> CId -> Tree -> [String]
+linearizes pgf lang = realizes . linTree pgf lang
 
 realize :: Term -> String
-realize trm = case trm of
-  R ts     -> realize (ts !! 0)
-  S ss     -> unwords $ map realize ss
-  K t -> case t of
-    KS s -> s
-    KP s _ -> unwords s ---- prefix choice TODO
-  W s t    -> s ++ realize t
-  FV ts    -> realize (ts !! 0)  ---- other variants TODO
-  TM s     -> s
-  _ -> "ERROR " ++ show trm ---- debug
+realize = concat . take 1 . realizes
+
+realizes :: Term -> [String]
+realizes = map (unwords . untokn) . realizest
+
+realizest :: Term -> [[Tokn]]
+realizest trm = case trm of
+  R ts     -> realizest (ts !! 0)
+  S ss     -> map concat $ combinations $ map realizest ss
+  K t      -> [[t]]
+  W s t    -> [[KS (s ++ r)] | [KS r] <- realizest t]
+  FV ts    -> concatMap realizest ts
+  TM s     -> [[KS s]]
+  _ -> [[KS $ "REALIZE_ERROR " ++ show trm]] ---- debug
+
+untokn :: [Tokn] -> [String]
+untokn ts = case ts of
+  KP d _  : [] -> d
+  KP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss
+  KS s    : ws -> s : untokn ws
+  []           -> []
+ where
+   sel d vs w = case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of
+     v:_ -> v
+     _   -> d
 
 linTree :: PGF -> CId -> Tree -> Term
 linTree pgf lang = lin
diff --git a/src-3.0/PGF/ShowLinearize.hs b/src-3.0/PGF/ShowLinearize.hs
index ae1385d98..aeb711b7a 100644
--- a/src-3.0/PGF/ShowLinearize.hs
+++ b/src-3.0/PGF/ShowLinearize.hs
@@ -43,11 +43,12 @@ prRecord = prr where
 -- uses the encoding of record types in PGF.paramlincat
 mkRecord :: Term -> Term -> Record
 mkRecord typ trm = case (typ,trm) of
-  (R rs,      R ts) -> RR [(str lab, mkRecord ty t) | (P lab ty, t) <- zip rs ts]
+  (_,         FV ts)  -> RFV $ map (mkRecord typ) ts
+  (R rs,      R ts)   -> RR [(str lab, mkRecord ty t) | (P lab ty, t) <- zip rs ts]
   (S [FV ps,ty],R ts) -> RT [(str par, mkRecord ty t) | (par,    t) <- zip ps ts]
   (_,W s (R ts))      -> mkRecord typ (R [K (KS (s ++ u)) | K (KS u) <- ts])
   (FV ps,       C i)  -> RCon $ str $ ps !! i
-  (S [],        _)    -> RS $ realize trm
+  (S [],        _)    -> RS $ str trm
   _                   -> RS $ show trm ---- printTree trm
  where
    str = realize