SortTop.hs

module PGF.SortTop
    ( forExample
     ) where

import PGF.CId
import PGF.Data
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe


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