From bdc77bf0e4c4b705a3deb5976271dc1fd3df3baf Mon Sep 17 00:00:00 2001
From: "ra.monique" <ra.monique@gmail.com>
Date: Thu, 15 Sep 2011 16:32:49 +0000
Subject: [PATCH] added topological sort module to PGF - to be used in example
 based grammar writing

---
 gf.cabal                           |  1 +
 src/runtime/haskell/PGF.hs         |  7 ++-
 src/runtime/haskell/PGF/SortTop.hs | 96 ++++++++++++++++++++++++++++++
 3 files changed, 103 insertions(+), 1 deletion(-)
 create mode 100644 src/runtime/haskell/PGF/SortTop.hs

diff --git a/gf.cabal b/gf.cabal
index 2172b4560..deb64faa8 100644
--- a/gf.cabal
+++ b/gf.cabal
@@ -49,6 +49,7 @@ library
     PGF.Generate
     PGF.Linearize
     PGF.Parse
+    PGF.SortTop
     PGF.Expr
     PGF.Type
     PGF.Tree
diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index 8530d9a71..cff225f08 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -109,7 +109,8 @@ module PGF(
            -- ** Morphological Analysis
            Lemma, Analysis, Morpho,
            lookupMorpho, buildMorpho, fullFormLexicon,
-           
+           morphoMissing,
+
            -- ** Tokenizing
            mkTokenizer,
 
@@ -128,12 +129,16 @@ module PGF(
            showProbabilities,
            readProbabilitiesFromFile,
            
+           -- ** SortTop
+           forExample,
+
            -- * Browsing
            browse
           ) where
 
 import PGF.CId
 import PGF.Linearize
+import PGF.SortTop
 import PGF.Generate
 import PGF.TypeCheck
 import PGF.Paraphrase
diff --git a/src/runtime/haskell/PGF/SortTop.hs b/src/runtime/haskell/PGF/SortTop.hs
new file mode 100644
index 000000000..275698af6
--- /dev/null
+++ b/src/runtime/haskell/PGF/SortTop.hs
@@ -0,0 +1,96 @@
+module PGF.SortTop
+    ( forExample
+     ) where
+
+import PGF.Linearize
+import PGF.Macros
+import System.IO
+import PGF.CId
+import PGF.Data
+import PGF.Macros
+import PGF.Expr
+import Data.Array.IArray
+import Data.List
+import Control.Monad
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+import qualified Data.Set as Set
+import Data.Maybe
+import System.Environment (getArgs)
+import Data.Binary
+
+
+
+
+
+arguments :: Type -> [CId]
+arguments (DTyp [] _ _) = []
+arguments (DTyp hypos _ _) = [ t |  (_,_, DTyp _ t _) <- hypos]
+
+-- topological order of functions
+-- in the order that they should be tested and generated in an example-based system
+
+showInOrder :: Abstr -> Set.Set CId -> Set.Set CId -> Set.Set CId  -> IO [[((CId,CId),[CId])]]
+showInOrder abs fset remset avset = 
+    let mtypes = typesInterm abs fset
+        nextsetWithArgs = Set.map (\(x,y) -> ((x, returnCat abs x), fromJust y)) $ Set.filter (isJust.snd) $ Set.map (\x -> (x, isArg abs mtypes avset x)) remset
+        nextset = Set.map (fst.fst) nextsetWithArgs
+        nextcat = Set.map (returnCat abs) nextset
+        diffset = Set.difference remset nextset
+              in 
+            if Set.null diffset then do 
+                                        return [Set.toList nextsetWithArgs]
+               else if Set.null nextset then do 
+                                                putStrLn $ "not comparable : "  ++ show diffset
+                                                return []
+                      else do 
+                               
+                              rest <- showInOrder abs (Set.union fset nextset) (Set.difference remset nextset) (Set.union avset nextcat)
+                              return $ (Set.toList nextsetWithArgs) : rest 
+
+  
+isArg :: Abstr -> Map.Map CId CId -> Set.Set CId -> CId -> Maybe [CId]
+isArg abs mtypes scid cid = 
+   let p = Map.lookup cid $ funs abs
+       (ty,_,_,_) = fromJust p 
+       args  = arguments ty  
+       setargs = Set.fromList args
+       cond = Set.null $ Set.difference setargs scid
+      in     
+        if isNothing p then error $ "not found " ++ show cid ++ "here !!"
+             else if cond then return args
+                   else Nothing 
+
+typesInterm :: Abstr -> Set.Set CId -> Map.Map CId CId
+typesInterm abs fset = 
+          let fs = funs abs
+              fsetTypes = Set.map (\x -> 
+                                    let (DTyp _ c _,_,_,_)=fromJust $ Map.lookup x fs
+                                     in (x,c)) fset
+              in Map.fromList $ Set.toList fsetTypes             
+
+
+takeArgs :: Map.Map CId CId -> Map.Map CId Expr -> CId -> Expr
+takeArgs mtypes mexpr ty = 
+     let xarg = head $ Map.keys $ Map.filter (==ty) mtypes
+          in fromJust $ Map.lookup xarg mexpr               
+
+doesReturnCat :: Type -> CId -> Bool
+doesReturnCat (DTyp _ c _) cat = c == cat                                  
+                         
+returnCat :: Abstr -> CId -> CId 
+returnCat abs cid = 
+      let p = Map.lookup cid $ funs abs           
+          (DTyp _ c _,_,_,_) = fromJust p  
+        in if isNothing p then error $ "not found "++ show cid ++ " in abstract "
+                   else c
+
+-- topological order of the categories
+forExample :: PGF -> IO [[((CId,CId),[CId])]]
+forExample pgf = let abs = abstract pgf 
+       in showInOrder abs Set.empty (Set.fromList $ Map.keys $ funs abs) Set.empty 
+
+
+
+
+