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 :: Type -> [CId]
arguments (DTyp [] CId
_ [Expr]
_) = []
arguments (DTyp [Hypo]
hypos CId
_ [Expr]
_) = [ CId
t |  (BindType
_,CId
_, DTyp [Hypo]
_ CId
t [Expr]
_) <- [Hypo]
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 :: Abstr
-> Set CId -> Set CId -> Set CId -> IO [[((CId, CId), [CId])]]
showInOrder Abstr
abs Set CId
fset Set CId
remset Set CId
avset = 
    let mtypes :: Map CId CId
mtypes = Abstr -> Set CId -> Map CId CId
typesInterm Abstr
abs Set CId
fset
        nextsetWithArgs :: Set ((CId, CId), [CId])
nextsetWithArgs = ((CId, Maybe [CId]) -> ((CId, CId), [CId]))
-> Set (CId, Maybe [CId]) -> Set ((CId, CId), [CId])
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\(CId
x,Maybe [CId]
y) -> ((CId
x, Abstr -> CId -> CId
returnCat Abstr
abs CId
x), Maybe [CId] -> [CId]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [CId]
y)) (Set (CId, Maybe [CId]) -> Set ((CId, CId), [CId]))
-> Set (CId, Maybe [CId]) -> Set ((CId, CId), [CId])
forall a b. (a -> b) -> a -> b
$ ((CId, Maybe [CId]) -> Bool)
-> Set (CId, Maybe [CId]) -> Set (CId, Maybe [CId])
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Maybe [CId] -> Bool
forall a. Maybe a -> Bool
isJust(Maybe [CId] -> Bool)
-> ((CId, Maybe [CId]) -> Maybe [CId])
-> (CId, Maybe [CId])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CId, Maybe [CId]) -> Maybe [CId]
forall a b. (a, b) -> b
snd) (Set (CId, Maybe [CId]) -> Set (CId, Maybe [CId]))
-> Set (CId, Maybe [CId]) -> Set (CId, Maybe [CId])
forall a b. (a -> b) -> a -> b
$ (CId -> (CId, Maybe [CId])) -> Set CId -> Set (CId, Maybe [CId])
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\CId
x -> (CId
x, Abstr -> Map CId CId -> Set CId -> CId -> Maybe [CId]
isArg Abstr
abs Map CId CId
mtypes Set CId
avset CId
x)) Set CId
remset
        nextset :: Set CId
nextset = (((CId, CId), [CId]) -> CId) -> Set ((CId, CId), [CId]) -> Set CId
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((CId, CId) -> CId
forall a b. (a, b) -> a
fst((CId, CId) -> CId)
-> (((CId, CId), [CId]) -> (CId, CId))
-> ((CId, CId), [CId])
-> CId
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((CId, CId), [CId]) -> (CId, CId)
forall a b. (a, b) -> a
fst) Set ((CId, CId), [CId])
nextsetWithArgs
        nextcat :: Set CId
nextcat = (CId -> CId) -> Set CId -> Set CId
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Abstr -> CId -> CId
returnCat Abstr
abs) Set CId
nextset
        diffset :: Set CId
diffset = Set CId -> Set CId -> Set CId
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set CId
remset Set CId
nextset
              in 
            if Set CId -> Bool
forall a. Set a -> Bool
Set.null Set CId
diffset then do 
                                        [[((CId, CId), [CId])]] -> IO [[((CId, CId), [CId])]]
forall (m :: * -> *) a. Monad m => a -> m a
return [Set ((CId, CId), [CId]) -> [((CId, CId), [CId])]
forall a. Set a -> [a]
Set.toList Set ((CId, CId), [CId])
nextsetWithArgs]
               else if Set CId -> Bool
forall a. Set a -> Bool
Set.null Set CId
nextset then do 
                                                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"not comparable : "  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Set CId -> String
forall a. Show a => a -> String
show Set CId
diffset
                                                [[((CId, CId), [CId])]] -> IO [[((CId, CId), [CId])]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                      else do 
                               
                              [[((CId, CId), [CId])]]
rest <- Abstr
-> Set CId -> Set CId -> Set CId -> IO [[((CId, CId), [CId])]]
showInOrder Abstr
abs (Set CId -> Set CId -> Set CId
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set CId
fset Set CId
nextset) (Set CId -> Set CId -> Set CId
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set CId
remset Set CId
nextset) (Set CId -> Set CId -> Set CId
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set CId
avset Set CId
nextcat)
                              [[((CId, CId), [CId])]] -> IO [[((CId, CId), [CId])]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[((CId, CId), [CId])]] -> IO [[((CId, CId), [CId])]])
-> [[((CId, CId), [CId])]] -> IO [[((CId, CId), [CId])]]
forall a b. (a -> b) -> a -> b
$ (Set ((CId, CId), [CId]) -> [((CId, CId), [CId])]
forall a. Set a -> [a]
Set.toList Set ((CId, CId), [CId])
nextsetWithArgs) [((CId, CId), [CId])]
-> [[((CId, CId), [CId])]] -> [[((CId, CId), [CId])]]
forall a. a -> [a] -> [a]
: [[((CId, CId), [CId])]]
rest 

  
isArg :: Abstr -> Map.Map CId CId -> Set.Set CId -> CId -> Maybe [CId]
isArg :: Abstr -> Map CId CId -> Set CId -> CId -> Maybe [CId]
isArg Abstr
abs Map CId CId
mtypes Set CId
scid CId
cid = 
   let p :: Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
p = CId
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
cid (Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
 -> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall a b. (a -> b) -> a -> b
$ Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs Abstr
abs
       (Type
ty,Int
_,Maybe ([Equation], [[Instr]])
_,Double
_) = Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
p 
       args :: [CId]
args  = Type -> [CId]
arguments Type
ty  
       setargs :: Set CId
setargs = [CId] -> Set CId
forall a. Ord a => [a] -> Set a
Set.fromList [CId]
args
       cond :: Bool
cond = Set CId -> Bool
forall a. Set a -> Bool
Set.null (Set CId -> Bool) -> Set CId -> Bool
forall a b. (a -> b) -> a -> b
$ Set CId -> Set CId -> Set CId
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set CId
setargs Set CId
scid
      in     
        if Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
p then String -> Maybe [CId]
forall a. HasCallStack => String -> a
error (String -> Maybe [CId]) -> String -> Maybe [CId]
forall a b. (a -> b) -> a -> b
$ String
"not found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CId -> String
forall a. Show a => a -> String
show CId
cid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"here !!"
             else if Bool
cond then [CId] -> Maybe [CId]
forall (m :: * -> *) a. Monad m => a -> m a
return [CId]
args
                   else Maybe [CId]
forall a. Maybe a
Nothing 

typesInterm :: Abstr -> Set.Set CId -> Map.Map CId CId
typesInterm :: Abstr -> Set CId -> Map CId CId
typesInterm Abstr
abs Set CId
fset = 
          let fs :: Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
fs = Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs Abstr
abs
              fsetTypes :: Set (CId, CId)
fsetTypes = (CId -> (CId, CId)) -> Set CId -> Set (CId, CId)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\CId
x -> 
                                    let (DTyp [Hypo]
_ CId
c [Expr]
_,Int
_,Maybe ([Equation], [[Instr]])
_,Double
_)=Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
 -> (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall a b. (a -> b) -> a -> b
$ CId
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
x Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
fs
                                     in (CId
x,CId
c)) Set CId
fset
              in [(CId, CId)] -> Map CId CId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CId, CId)] -> Map CId CId) -> [(CId, CId)] -> Map CId CId
forall a b. (a -> b) -> a -> b
$ Set (CId, CId) -> [(CId, CId)]
forall a. Set a -> [a]
Set.toList Set (CId, CId)
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 :: Abstr -> CId -> CId
returnCat Abstr
abs CId
cid = 
      let p :: Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
p = CId
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
cid (Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
 -> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall a b. (a -> b) -> a -> b
$ Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs Abstr
abs           
          (DTyp [Hypo]
_ CId
c [Expr]
_,Int
_,Maybe ([Equation], [[Instr]])
_,Double
_) = Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
p  
        in if Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
p then String -> CId
forall a. HasCallStack => String -> a
error (String -> CId) -> String -> CId
forall a b. (a -> b) -> a -> b
$ String
"not found "String -> String -> String
forall a. [a] -> [a] -> [a]
++ CId -> String
forall a. Show a => a -> String
show CId
cid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in abstract "
                   else CId
c

-- topological order of the categories
forExample :: PGF -> IO [[((CId,CId),[CId])]]
forExample :: PGF -> IO [[((CId, CId), [CId])]]
forExample PGF
pgf = let abs :: Abstr
abs = PGF -> Abstr
abstract PGF
pgf 
       in Abstr
-> Set CId -> Set CId -> Set CId -> IO [[((CId, CId), [CId])]]
showInOrder Abstr
abs Set CId
forall a. Set a
Set.empty ([CId] -> Set CId
forall a. Ord a => [a] -> Set a
Set.fromList ([CId] -> Set CId) -> [CId] -> Set CId
forall a b. (a -> b) -> a -> b
$ Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double) -> [CId]
forall k a. Map k a -> [k]
Map.keys (Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
 -> [CId])
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> [CId]
forall a b. (a -> b) -> a -> b
$ Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs Abstr
abs) Set CId
forall a. Set a
Set.empty