module ExampleDemo (Environ,initial,getNext, provideExample, testThis,mkFuncWithArg,searchGoodTree,isMeta)
  where

import PGF
--import System.IO
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 System.Random (RandomGen) --newStdGen


type MyType = CId                                -- name of the categories from the program
type ConcType = CId                              -- categories from the resource grammar, that we parse on
type MyFunc = CId                                -- functions that we need to implement
--type FuncWithArg = ((MyFunc, MyType), Expr)    -- function with arguments  
type InterInstr = [String]                       -- lincats that were generated but not written to the file



data FuncWithArg = FuncWithArg 
                      {FuncWithArg -> MyFunc
getName :: MyFunc,        -- name of the function to generate
                       FuncWithArg -> MyFunc
getType :: MyType,        -- return type of the function
                       FuncWithArg -> [MyFunc]
getTypeArgs :: [MyType]  -- types of arguments 
                       }
       deriving (Int -> FuncWithArg -> ShowS
[FuncWithArg] -> ShowS
FuncWithArg -> String
(Int -> FuncWithArg -> ShowS)
-> (FuncWithArg -> String)
-> ([FuncWithArg] -> ShowS)
-> Show FuncWithArg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FuncWithArg] -> ShowS
$cshowList :: [FuncWithArg] -> ShowS
show :: FuncWithArg -> String
$cshow :: FuncWithArg -> String
showsPrec :: Int -> FuncWithArg -> ShowS
$cshowsPrec :: Int -> FuncWithArg -> ShowS
Show,FuncWithArg -> FuncWithArg -> Bool
(FuncWithArg -> FuncWithArg -> Bool)
-> (FuncWithArg -> FuncWithArg -> Bool) -> Eq FuncWithArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FuncWithArg -> FuncWithArg -> Bool
$c/= :: FuncWithArg -> FuncWithArg -> Bool
== :: FuncWithArg -> FuncWithArg -> Bool
$c== :: FuncWithArg -> FuncWithArg -> Bool
Eq,Eq FuncWithArg
Eq FuncWithArg
-> (FuncWithArg -> FuncWithArg -> Ordering)
-> (FuncWithArg -> FuncWithArg -> Bool)
-> (FuncWithArg -> FuncWithArg -> Bool)
-> (FuncWithArg -> FuncWithArg -> Bool)
-> (FuncWithArg -> FuncWithArg -> Bool)
-> (FuncWithArg -> FuncWithArg -> FuncWithArg)
-> (FuncWithArg -> FuncWithArg -> FuncWithArg)
-> Ord FuncWithArg
FuncWithArg -> FuncWithArg -> Bool
FuncWithArg -> FuncWithArg -> Ordering
FuncWithArg -> FuncWithArg -> FuncWithArg
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FuncWithArg -> FuncWithArg -> FuncWithArg
$cmin :: FuncWithArg -> FuncWithArg -> FuncWithArg
max :: FuncWithArg -> FuncWithArg -> FuncWithArg
$cmax :: FuncWithArg -> FuncWithArg -> FuncWithArg
>= :: FuncWithArg -> FuncWithArg -> Bool
$c>= :: FuncWithArg -> FuncWithArg -> Bool
> :: FuncWithArg -> FuncWithArg -> Bool
$c> :: FuncWithArg -> FuncWithArg -> Bool
<= :: FuncWithArg -> FuncWithArg -> Bool
$c<= :: FuncWithArg -> FuncWithArg -> Bool
< :: FuncWithArg -> FuncWithArg -> Bool
$c< :: FuncWithArg -> FuncWithArg -> Bool
compare :: FuncWithArg -> FuncWithArg -> Ordering
$ccompare :: FuncWithArg -> FuncWithArg -> Ordering
$cp1Ord :: Eq FuncWithArg
Ord)

-- we assume that it's for English for the moment


type TypeMap = Map.Map MyType ConcType           -- mapping found from a file

type ConcMap = Map.Map MyFunc Expr               -- concrete expression after parsing

data Environ = Env {Environ -> TypeMap
getTypeMap :: TypeMap,                  -- mapping between a category in the grammar and a concrete type from RGL
                    Environ -> ConcMap
getConcMap :: ConcMap,                  -- concrete expression after parsing          
                    Environ -> Map MyFunc [FuncWithArg]
getSigs :: Map.Map MyType [FuncWithArg], -- functions for which we have the concrete syntax already with args 
                    Environ -> [FuncWithArg]
getAll :: [FuncWithArg]           -- all the functions with arguments  
                    }


getNext :: Environ -> Environ -> ([MyFunc],[MyFunc])
getNext :: Environ -> Environ -> ([MyFunc], [MyFunc])
getNext Environ
env Environ
example_env = 
  let sgs :: Map MyFunc [FuncWithArg]
sgs = Environ -> Map MyFunc [FuncWithArg]
getSigs Environ
env
      allfuncs :: [FuncWithArg]
allfuncs  = Environ -> [FuncWithArg]
getAll Environ
env
      names :: Set MyFunc
names = [MyFunc] -> Set MyFunc
forall a. Ord a => [a] -> Set a
Set.fromList ([MyFunc] -> Set MyFunc) -> [MyFunc] -> Set MyFunc
forall a b. (a -> b) -> a -> b
$ (FuncWithArg -> MyFunc) -> [FuncWithArg] -> [MyFunc]
forall a b. (a -> b) -> [a] -> [b]
map FuncWithArg -> MyFunc
getName ([FuncWithArg] -> [MyFunc]) -> [FuncWithArg] -> [MyFunc]
forall a b. (a -> b) -> a -> b
$ [[FuncWithArg]] -> [FuncWithArg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FuncWithArg]] -> [FuncWithArg])
-> [[FuncWithArg]] -> [FuncWithArg]
forall a b. (a -> b) -> a -> b
$ Map MyFunc [FuncWithArg] -> [[FuncWithArg]]
forall k a. Map k a -> [a]
Map.elems Map MyFunc [FuncWithArg]
sgs
      exampleable :: [MyFunc]
exampleable = (MyFunc -> Bool) -> [MyFunc] -> [MyFunc]
forall a. (a -> Bool) -> [a] -> [a]
filter (\MyFunc
x -> (Maybe Expr -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Expr -> Bool) -> Maybe Expr -> Bool
forall a b. (a -> b) -> a -> b
$ MyFunc -> Environ -> Maybe Expr
getNameExpr MyFunc
x Environ
env) 
                               Bool -> Bool -> Bool
&&
                               (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ MyFunc -> Set MyFunc -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member MyFunc
x Set MyFunc
names) -- maybe drop this if you want to also rewrite from examples...
                            ) ([MyFunc] -> [MyFunc]) -> [MyFunc] -> [MyFunc]
forall a b. (a -> b) -> a -> b
$ (FuncWithArg -> MyFunc) -> [FuncWithArg] -> [MyFunc]
forall a b. (a -> b) -> [a] -> [b]
map FuncWithArg -> MyFunc
getName [FuncWithArg]
allfuncs
      testeable :: [MyFunc]
testeable = (MyFunc -> Bool) -> [MyFunc] -> [MyFunc]
forall a. (a -> Bool) -> [a] -> [a]
filter (\MyFunc
x -> (Maybe Expr -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Expr -> Bool) -> Maybe Expr -> Bool
forall a b. (a -> b) -> a -> b
$ MyFunc -> Environ -> Maybe Expr
getNameExpr MyFunc
x Environ
env ) 
                              Bool -> Bool -> Bool
&& 
                               (MyFunc -> Set MyFunc -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member MyFunc
x Set MyFunc
names)
                          ) ([MyFunc] -> [MyFunc]) -> [MyFunc] -> [MyFunc]
forall a b. (a -> b) -> a -> b
$ (FuncWithArg -> MyFunc) -> [FuncWithArg] -> [MyFunc]
forall a b. (a -> b) -> [a] -> [b]
map FuncWithArg -> MyFunc
getName [FuncWithArg]
allfuncs    

     in ([MyFunc]
exampleable,[MyFunc]
testeable)


provideExample :: RandomGen gen => gen -> Environ -> MyFunc -> PGF -> PGF -> Language -> Maybe (Expr,String)
provideExample :: gen
-> Environ
-> MyFunc
-> PGF
-> PGF
-> MyFunc
-> Maybe (Expr, String)
provideExample gen
gen Environ
env MyFunc
myfunc PGF
parsePGF PGF
pgfFile MyFunc
lang = 
      (Expr -> (Expr, String)) -> Maybe Expr -> Maybe (Expr, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr -> (Expr, String)
giveExample (Maybe Expr -> Maybe (Expr, String))
-> Maybe Expr -> Maybe (Expr, String)
forall a b. (a -> b) -> a -> b
$ MyFunc -> Environ -> Maybe Expr
getNameExpr MyFunc
myfunc Environ
env
 where 
   giveExample :: Expr -> (Expr, String)
giveExample Expr
e_ = 
     let newexpr :: Expr
newexpr = [Expr] -> Expr
forall a. [a] -> a
head ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ gen -> PGF -> Expr -> Maybe Int -> [Expr]
forall g. RandomGen g => g -> PGF -> Expr -> Maybe Int -> [Expr]
generateRandomFromDepth gen
gen PGF
pgfFile Expr
e_ (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
5) -- change here with the new random generator
         ty :: MyFunc
ty = FuncWithArg -> MyFunc
getType (FuncWithArg -> MyFunc) -> FuncWithArg -> MyFunc
forall a b. (a -> b) -> a -> b
$ [FuncWithArg] -> FuncWithArg
forall a. [a] -> a
head ([FuncWithArg] -> FuncWithArg) -> [FuncWithArg] -> FuncWithArg
forall a b. (a -> b) -> a -> b
$ (FuncWithArg -> Bool) -> [FuncWithArg] -> [FuncWithArg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FuncWithArg
x -> FuncWithArg -> MyFunc
getName FuncWithArg
x MyFunc -> MyFunc -> Bool
forall a. Eq a => a -> a -> Bool
== MyFunc
myfunc) ([FuncWithArg] -> [FuncWithArg]) -> [FuncWithArg] -> [FuncWithArg]
forall a b. (a -> b) -> a -> b
$ Environ -> [FuncWithArg]
getAll Environ
env
         embeddedExpr :: String
embeddedExpr = String -> (Expr -> String) -> Maybe Expr -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expr
x -> String
", as in: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
q (PGF -> MyFunc -> Expr -> String
linearize PGF
pgfFile MyFunc
lang Expr
x)) ([FuncWithArg] -> ConcMap -> Maybe Expr
embedInStart (Environ -> [FuncWithArg]
getAll Environ
env) ([(MyFunc, Expr)] -> ConcMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(MyFunc
ty,Expr
e_)]))
         lexpr :: String
lexpr = PGF -> MyFunc -> Expr -> String
linearize PGF
pgfFile MyFunc
lang Expr
newexpr  
         q :: ShowS
q String
s = String
sqString -> ShowS
forall a. [a] -> [a] -> [a]
++String
sString -> ShowS
forall a. [a] -> [a] -> [a]
++String
sq
         sq :: String
sq = String
"\""
       in (Expr
newexpr,ShowS
q String
lexpr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
embeddedExpr)
-- question, you need the IO monad for the random generator, how to do otherwise ??
-- question can you make the expression bold/italic - somehow distinguishable from the rest ?



testThis :: Environ -> MyFunc -> PGF -> Language -> Maybe String  
testThis :: Environ -> MyFunc -> PGF -> MyFunc -> Maybe String
testThis Environ
env MyFunc
myfunc PGF
parsePGF MyFunc
lang = 
    (Expr -> String) -> Maybe Expr -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PGF -> MyFunc -> Expr -> String
linearize PGF
parsePGF MyFunc
lang (Expr -> String) -> (Expr -> Expr) -> Expr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> Expr -> Expr
mapToResource Environ
env (Expr -> Expr) -> (Expr -> Expr) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> Expr -> Expr
llin Environ
env) (Maybe Expr -> Maybe String) -> Maybe Expr -> Maybe String
forall a b. (a -> b) -> a -> b
$
    MyFunc -> Environ -> Maybe Expr
getNameExpr MyFunc
myfunc Environ
env  


-- we assume that even the functions linearized by the user will still be in getSigs along with their linearization 


-- fill in the blancs of an expression that we want to linearize for testing purposes
---------------------------------------------------------------------------

llin :: Environ -> Expr -> Expr 
llin :: Environ -> Expr -> Expr
llin Environ
env Expr
expr = 
     let 
         (MyFunc
id,[Expr]
args) = Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr])
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr]))
-> Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr])
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe (MyFunc, [Expr])
unApp Expr
expr
       --cexpr = fromJust $ Map.lookup id (getConcMap env)
     in 
         if (Expr -> Bool) -> [Expr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Expr -> Bool
isMeta [Expr]
args 
              then let 
                       sigs :: [FuncWithArg]
sigs = [[FuncWithArg]] -> [FuncWithArg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FuncWithArg]] -> [FuncWithArg])
-> [[FuncWithArg]] -> [FuncWithArg]
forall a b. (a -> b) -> a -> b
$ Map MyFunc [FuncWithArg] -> [[FuncWithArg]]
forall k a. Map k a -> [a]
Map.elems (Map MyFunc [FuncWithArg] -> [[FuncWithArg]])
-> Map MyFunc [FuncWithArg] -> [[FuncWithArg]]
forall a b. (a -> b) -> a -> b
$ Environ -> Map MyFunc [FuncWithArg]
getSigs Environ
env
                       tys :: [MyFunc]
tys = [FuncWithArg] -> MyFunc -> [MyFunc]
findExprWhich [FuncWithArg]
sigs MyFunc
id
                    in  Int -> [MyFunc] -> Expr -> Environ -> Expr
replaceConcArg Int
1 [MyFunc]
tys Expr
expr Environ
env 
           else MyFunc -> [Expr] -> Expr
mkApp MyFunc
id ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr) -> [Expr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Environ -> Expr -> Expr
llin Environ
env) [Expr]
args


-- argument of the meta variable to replace, list of arguments left, expression to replace, environment, current replace expression 
replaceConcArg :: Int -> [MyType] -> Expr -> Environ -> Expr
replaceConcArg :: Int -> [MyFunc] -> Expr -> Environ -> Expr
replaceConcArg Int
i [] Expr
expr Environ
env = Expr
expr
replaceConcArg Int
i (MyFunc
t:[MyFunc]
ts) Expr
expr Environ
env =      -- TO DO : insert randomness here !!
   let ss :: [FuncWithArg]
ss = Maybe [FuncWithArg] -> [FuncWithArg]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [FuncWithArg] -> [FuncWithArg])
-> Maybe [FuncWithArg] -> [FuncWithArg]
forall a b. (a -> b) -> a -> b
$ MyFunc -> Map MyFunc [FuncWithArg] -> Maybe [FuncWithArg]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MyFunc
t (Map MyFunc [FuncWithArg] -> Maybe [FuncWithArg])
-> Map MyFunc [FuncWithArg] -> Maybe [FuncWithArg]
forall a b. (a -> b) -> a -> b
$ Environ -> Map MyFunc [FuncWithArg]
getSigs Environ
env 
       args :: [FuncWithArg]
args = (FuncWithArg -> Bool) -> [FuncWithArg] -> [FuncWithArg]
forall a. (a -> Bool) -> [a] -> [a]
filter ([MyFunc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([MyFunc] -> Bool)
-> (FuncWithArg -> [MyFunc]) -> FuncWithArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FuncWithArg -> [MyFunc]
getTypeArgs) [FuncWithArg]
ss 
       finArg :: Expr
finArg = if [FuncWithArg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FuncWithArg]
args then let l :: FuncWithArg
l = [FuncWithArg] -> FuncWithArg
forall a. [a] -> a
last [FuncWithArg]
ss in Environ -> Expr -> Expr
llin Environ
env (MyFunc -> [Expr] -> Expr
mkApp (FuncWithArg -> MyFunc
getName FuncWithArg
l) [Int -> Expr
mkMeta Int
j | Int
j <- [Int
1..([MyFunc] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([MyFunc] -> Int) -> [MyFunc] -> Int
forall a b. (a -> b) -> a -> b
$ FuncWithArg -> [MyFunc]
getTypeArgs FuncWithArg
l)]]) 
                   else MyFunc -> [Expr] -> Expr
mkApp (FuncWithArg -> MyFunc
getName (FuncWithArg -> MyFunc) -> FuncWithArg -> MyFunc
forall a b. (a -> b) -> a -> b
$ [FuncWithArg] -> FuncWithArg
forall a. [a] -> a
last [FuncWithArg]
args) [] 
    in   
                     let newe :: Expr
newe = Int -> Expr -> Expr -> Expr
replaceOne Int
i Expr
finArg Expr
expr
                               in Int -> [MyFunc] -> Expr -> Environ -> Expr
replaceConcArg (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [MyFunc]
ts Expr
newe Environ
env       
                   
-- replace a certain metavariable with a certain expression in another expression - return updated expression
replaceOne :: Int -> Expr -> Expr -> Expr                               
replaceOne :: Int -> Expr -> Expr -> Expr
replaceOne Int
i Expr
erep Expr
expr = 
      if Expr -> Bool
isMeta Expr
expr Bool -> Bool -> Bool
&& ((Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Int
unMeta Expr
expr) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i) 
               then Expr
erep
        else if Expr -> Bool
isMeta Expr
expr then Expr
expr
              else let (MyFunc
id,[Expr]
args) = Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr])
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr]))
-> Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr])
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe (MyFunc, [Expr])
unApp Expr
expr
                       in  
                        MyFunc -> [Expr] -> Expr
mkApp MyFunc
id ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr) -> [Expr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Expr -> Expr -> Expr
replaceOne Int
i Expr
erep) [Expr]
args


findExprWhich :: [FuncWithArg] -> MyFunc -> [MyType]
findExprWhich :: [FuncWithArg] -> MyFunc -> [MyFunc]
findExprWhich [FuncWithArg]
lst MyFunc
f = FuncWithArg -> [MyFunc]
getTypeArgs (FuncWithArg -> [MyFunc]) -> FuncWithArg -> [MyFunc]
forall a b. (a -> b) -> a -> b
$ [FuncWithArg] -> FuncWithArg
forall a. [a] -> a
head ([FuncWithArg] -> FuncWithArg) -> [FuncWithArg] -> FuncWithArg
forall a b. (a -> b) -> a -> b
$ (FuncWithArg -> Bool) -> [FuncWithArg] -> [FuncWithArg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FuncWithArg
x -> FuncWithArg -> MyFunc
getName FuncWithArg
x MyFunc -> MyFunc -> Bool
forall a. Eq a => a -> a -> Bool
== MyFunc
f) [FuncWithArg]
lst 


mapToResource :: Environ -> Expr -> Expr 
mapToResource :: Environ -> Expr -> Expr
mapToResource Environ
env Expr
expr = 
      let (MyFunc
id,[Expr]
args) =  (MyFunc, [Expr])
-> ((MyFunc, [Expr]) -> (MyFunc, [Expr]))
-> Maybe (MyFunc, [Expr])
-> (MyFunc, [Expr])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> (MyFunc, [Expr])
forall a. HasCallStack => String -> a
error (String -> (MyFunc, [Expr])) -> String -> (MyFunc, [Expr])
forall a b. (a -> b) -> a -> b
$ String
"tried to unwrap " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [MyFunc] -> Expr -> String
showExpr [] Expr
expr) (\(MyFunc, [Expr])
x -> (MyFunc, [Expr])
x) (Expr -> Maybe (MyFunc, [Expr])
unApp Expr
expr)
          cmap :: ConcMap
cmap      = Environ -> ConcMap
getConcMap Environ
env
          cexp :: Expr
cexp      = Expr -> (Expr -> Expr) -> Maybe Expr -> Expr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Expr
forall a. HasCallStack => String -> a
error (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String
"didn't find " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MyFunc -> String
showCId MyFunc
id String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in  "String -> ShowS
forall a. [a] -> [a] -> [a]
++ ConcMap -> String
forall a. Show a => a -> String
show ConcMap
cmap) (\Expr
x -> Expr
x)  (MyFunc -> ConcMap -> Maybe Expr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MyFunc
id ConcMap
cmap)
        in 
        if [Expr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr]
args then Expr
cexp
             else let newargs :: [Expr]
newargs = (Expr -> Expr) -> [Expr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Environ -> Expr -> Expr
mapToResource Environ
env) [Expr]
args
                   in Expr -> Int -> [Expr] -> Expr
replaceAllArgs Expr
cexp Int
1 [Expr]
newargs
      where 
      replaceAllArgs :: Expr -> Int -> [Expr] -> Expr
replaceAllArgs Expr
expr Int
i []     = Expr
expr 
      replaceAllArgs Expr
expr Int
i (Expr
x:[Expr]
xs) = Expr -> Int -> [Expr] -> Expr
replaceAllArgs (Int -> Expr -> Expr -> Expr
replaceOne Int
i Expr
x Expr
expr) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Expr]
xs 
   
         

-----------------------------------------------

-- embed expression in another one from the start category

embedInStart :: [FuncWithArg] -> Map.Map MyType Expr -> Maybe Expr 
embedInStart :: [FuncWithArg] -> ConcMap -> Maybe Expr
embedInStart [FuncWithArg]
fss ConcMap
cs =
  let currset :: [(MyFunc, Expr)]
currset = ConcMap -> [(MyFunc, Expr)]
forall k a. Map k a -> [(k, a)]
Map.toList ConcMap
cs 
      nextset :: ConcMap
nextset = [(MyFunc, Expr)] -> ConcMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(MyFunc, Expr)] -> ConcMap) -> [(MyFunc, Expr)] -> ConcMap
forall a b. (a -> b) -> a -> b
$ [[(MyFunc, Expr)]] -> [(MyFunc, Expr)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ if MyFunc -> [MyFunc] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem MyFunc
myt (FuncWithArg -> [MyFunc]
getTypeArgs FuncWithArg
farg) 
                     then (MyFunc, Expr) -> FuncWithArg -> [(MyFunc, Expr)]
connectWithArg (MyFunc
myt,Expr
exp) FuncWithArg
farg else [] 
                        | (MyFunc
myt,Expr
exp) <- [(MyFunc, Expr)]
currset, FuncWithArg
farg <- [FuncWithArg]
fss]
      nextmap :: ConcMap
nextmap = ConcMap -> ConcMap -> ConcMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ConcMap
cs ConcMap
nextset
      maybeExpr :: Maybe Expr
maybeExpr = MyFunc -> ConcMap -> Maybe Expr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MyFunc
startCateg ConcMap
nextset
     in if Maybe Expr -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Expr
maybeExpr then 
               if ConcMap -> Int
forall k a. Map k a -> Int
Map.size ConcMap
nextmap Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ConcMap -> Int
forall k a. Map k a -> Int
Map.size ConcMap
cs then Maybe Expr
forall a. Maybe a
Nothing --error $ "could't build " ++ show startCateg ++ "with " ++ show fss 
                  else [FuncWithArg] -> ConcMap -> Maybe Expr
embedInStart [FuncWithArg]
fss ConcMap
nextmap
       else Expr -> Maybe Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ Maybe Expr -> Expr
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Expr
maybeExpr
   where 
      connectWithArg :: (MyFunc, Expr) -> FuncWithArg -> [(MyFunc, Expr)]
connectWithArg (MyFunc
myt,Expr
exp) FuncWithArg
farg = 
             let ind :: Int
ind = [Int] -> Int
forall a. [a] -> a
head ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ MyFunc -> [MyFunc] -> [Int]
forall a. Eq a => a -> [a] -> [Int]
elemIndices MyFunc
myt (FuncWithArg -> [MyFunc]
getTypeArgs FuncWithArg
farg)
              in [(FuncWithArg -> MyFunc
getType FuncWithArg
farg, MyFunc -> [Expr] -> Expr
mkApp (FuncWithArg -> MyFunc
getName FuncWithArg
farg) ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ [Int -> Expr
mkMeta Int
i | Int
i <- [Int
1..Int
ind]] [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [Expr
exp] [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [Int -> Expr
mkMeta Int
i | Int
i <- [(Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)..(([MyFunc] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([MyFunc] -> Int) -> [MyFunc] -> Int
forall a b. (a -> b) -> a -> b
$ FuncWithArg -> [MyFunc]
getTypeArgs FuncWithArg
farg) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]])]
               




-----------------------------------------------
{-
updateConcMap :: Environ -> MyFunc -> Expr -> Environ
updateConcMap env myf expr = 
     Env (getTypeMap env) (Map.insert myf expr (getConcMap env)) (getSigs env) (getAll env)

 
updateInterInstr :: Environ -> MyType -> FuncWithArg -> Environ
updateInterInstr env myt myf  = 
  let  ii = getSigs env
       newInterInstr = 
         maybe (Map.insert myt [myf] ii) (\x -> Map.insert myt (myf:x) ii) $ Map.lookup myt ii
      in Env (getTypeMap env) (getConcMap env) newInterInstr (getAll env)


putSignatures :: Environ -> [FuncWithArg] -> Environ
putSignatures env fss = 
     Env (getTypeMap env) (getConcMap env) (mkSigs fss) (getAll env)
      
      
updateEnv :: Environ -> FuncWithArg -> MyType -> Expr -> Environ 
updateEnv env myf myt expr =  
  let  ii = getSigs env
       nn = getName myf
       newInterInstr = 
         maybe (Map.insert myt [myf] ii) (\x -> Map.insert myt (myf:x) ii) $ Map.lookup myt ii
      in Env (getTypeMap env) (Map.insert nn expr (getConcMap env)) newInterInstr (getAll env)
-}

mkSigs :: [FuncWithArg] -> Map.Map MyType [FuncWithArg]
mkSigs :: [FuncWithArg] -> Map MyFunc [FuncWithArg]
mkSigs [FuncWithArg]
fss = ([FuncWithArg] -> [FuncWithArg] -> [FuncWithArg])
-> [(MyFunc, [FuncWithArg])] -> Map MyFunc [FuncWithArg]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [FuncWithArg] -> [FuncWithArg] -> [FuncWithArg]
forall a. [a] -> [a] -> [a]
(++) ([(MyFunc, [FuncWithArg])] -> Map MyFunc [FuncWithArg])
-> [(MyFunc, [FuncWithArg])] -> Map MyFunc [FuncWithArg]
forall a b. (a -> b) -> a -> b
$ [MyFunc] -> [[FuncWithArg]] -> [(MyFunc, [FuncWithArg])]
forall a b. [a] -> [b] -> [(a, b)]
zip ((FuncWithArg -> MyFunc) -> [FuncWithArg] -> [MyFunc]
forall a b. (a -> b) -> [a] -> [b]
map FuncWithArg -> MyFunc
getType [FuncWithArg]
fss) ((FuncWithArg -> [FuncWithArg]) -> [FuncWithArg] -> [[FuncWithArg]]
forall a b. (a -> b) -> [a] -> [b]
map (\FuncWithArg
x -> [FuncWithArg
x]) [FuncWithArg]
fss)



{------------------------------------
lang :: String 
lang = "Eng"


parseLang :: Language
parseLang = fromJust $ readLanguage "ParseEng"


parsePGFfile :: String
parsePGFfile = "ParseEngAbs.pgf"
------------------------------------}




                 
searchGoodTree :: Environ -> Expr -> [Expr] -> IO (Maybe (Expr,Expr))
searchGoodTree :: Environ -> Expr -> [Expr] -> IO (Maybe (Expr, Expr))
searchGoodTree Environ
env Expr
expr [] = Maybe (Expr, Expr) -> IO (Maybe (Expr, Expr))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Expr, Expr)
forall a. Maybe a
Nothing
searchGoodTree Environ
env Expr
expr (Expr
e:[Expr]
es) = 
     do Maybe Expr
val <- Expr -> Expr -> Environ -> IO (Maybe Expr)
debugReplaceArgs Expr
expr Expr
e Environ
env
        IO (Maybe (Expr, Expr))
-> (Expr -> IO (Maybe (Expr, Expr)))
-> Maybe Expr
-> IO (Maybe (Expr, Expr))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Environ -> Expr -> [Expr] -> IO (Maybe (Expr, Expr))
searchGoodTree Environ
env Expr
expr [Expr]
es) (\Expr
x -> Maybe (Expr, Expr) -> IO (Maybe (Expr, Expr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Expr, Expr) -> IO (Maybe (Expr, Expr)))
-> Maybe (Expr, Expr) -> IO (Maybe (Expr, Expr))
forall a b. (a -> b) -> a -> b
$ (Expr, Expr) -> Maybe (Expr, Expr)
forall a. a -> Maybe a
Just (Expr
x,Expr
e)) Maybe Expr
val 



getNameExpr :: MyFunc -> Environ -> Maybe Expr
getNameExpr :: MyFunc -> Environ -> Maybe Expr
getNameExpr MyFunc
myfunc Environ
env = 
    let allfunc :: [FuncWithArg]
allfunc = (FuncWithArg -> Bool) -> [FuncWithArg] -> [FuncWithArg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FuncWithArg
x -> FuncWithArg -> MyFunc
getName FuncWithArg
x MyFunc -> MyFunc -> Bool
forall a. Eq a => a -> a -> Bool
== MyFunc
myfunc) ([FuncWithArg] -> [FuncWithArg]) -> [FuncWithArg] -> [FuncWithArg]
forall a b. (a -> b) -> a -> b
$ Environ -> [FuncWithArg]
getAll Environ
env
            in 
        if [FuncWithArg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FuncWithArg]
allfunc then Maybe Expr
forall a. Maybe a
Nothing
            else FuncWithArg -> Environ -> Maybe Expr
getExpr ([FuncWithArg] -> FuncWithArg
forall a. [a] -> a
head [FuncWithArg]
allfunc) Environ
env

-- find an expression to generate where we have all the other elements available
getExpr :: FuncWithArg -> Environ -> Maybe Expr 
getExpr :: FuncWithArg -> Environ -> Maybe Expr
getExpr FuncWithArg
farg Environ
env =  
  let tys :: [MyFunc]
tys = FuncWithArg -> [MyFunc]
getTypeArgs FuncWithArg
farg
      ctx :: Map MyFunc [FuncWithArg]
ctx = Environ -> Map MyFunc [FuncWithArg]
getSigs Environ
env 
      lst :: [Maybe Expr]
lst = Map MyFunc [FuncWithArg] -> [MyFunc] -> Int -> [Maybe Expr]
forall a.
Ord a =>
Map a [FuncWithArg] -> [a] -> Int -> [Maybe Expr]
getConcTypes Map MyFunc [FuncWithArg]
ctx [MyFunc]
tys Int
1
    in if ((Maybe Expr -> Bool) -> [Maybe Expr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Expr -> Bool
forall a. Maybe a -> Bool
isJust [Maybe Expr]
lst) then  Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ MyFunc -> [Expr] -> Expr
mkApp (FuncWithArg -> MyFunc
getName FuncWithArg
farg) ((Maybe Expr -> Expr) -> [Maybe Expr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Maybe Expr -> Expr
forall a. HasCallStack => Maybe a -> a
fromJust [Maybe Expr]
lst)
            else  Maybe Expr
forall a. Maybe a
Nothing    
     where getConcTypes :: Map a [FuncWithArg] -> [a] -> Int -> [Maybe Expr]
getConcTypes Map a [FuncWithArg]
context [] Int
i = []
           getConcTypes Map a [FuncWithArg]
context (a
ty:[a]
types) Int
i =  
                let pos :: Maybe [FuncWithArg]
pos = a -> Map a [FuncWithArg] -> Maybe [FuncWithArg]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
ty Map a [FuncWithArg]
context
                   in 
                    if Maybe [FuncWithArg] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [FuncWithArg]
pos  Bool -> Bool -> Bool
|| ([FuncWithArg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([FuncWithArg] -> Bool) -> [FuncWithArg] -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe [FuncWithArg] -> [FuncWithArg]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [FuncWithArg]
pos) then [Maybe Expr
forall a. Maybe a
Nothing]                                                
                          else  
                             let mm :: FuncWithArg
mm = [FuncWithArg] -> FuncWithArg
forall a. [a] -> a
last ([FuncWithArg] -> FuncWithArg) -> [FuncWithArg] -> FuncWithArg
forall a b. (a -> b) -> a -> b
$ Maybe [FuncWithArg] -> [FuncWithArg]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [FuncWithArg]
pos
                                 mmargs :: [MyFunc]
mmargs = FuncWithArg -> [MyFunc]
getTypeArgs FuncWithArg
mm
                                 newi :: Int
newi = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [MyFunc] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MyFunc]
mmargs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1  
                                 lst :: [Maybe Expr]
lst = Map a [FuncWithArg] -> [a] -> Int -> [Maybe Expr]
getConcTypes (a -> [FuncWithArg] -> Map a [FuncWithArg] -> Map a [FuncWithArg]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
ty ([FuncWithArg] -> [FuncWithArg]
forall a. [a] -> [a]
init ([FuncWithArg] -> [FuncWithArg]) -> [FuncWithArg] -> [FuncWithArg]
forall a b. (a -> b) -> a -> b
$ (Maybe [FuncWithArg] -> [FuncWithArg]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [FuncWithArg]
pos)) Map a [FuncWithArg]
context) [a]
types (Int
newiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                                  in                      
                                  if ((Maybe Expr -> Bool) -> [Maybe Expr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Expr -> Bool
forall a. Maybe a -> Bool
isJust [Maybe Expr]
lst) then                     -- i..newi
                                         (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ MyFunc -> [Expr] -> Expr
mkApp (FuncWithArg -> MyFunc
getName FuncWithArg
mm) [Int -> Expr
mkMeta Int
j | Int
j <- [Int
1..([MyFunc] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MyFunc]
mmargs)]]) Maybe Expr -> [Maybe Expr] -> [Maybe Expr]
forall a. a -> [a] -> [a]
: [Maybe Expr]
lst 
                                       else  [Maybe Expr
forall a. Maybe a
Nothing]
      




-- only covers simple expressions with meta variables, not the rest...
isGeneralizationOf :: Expr -> Expr -> Bool
isGeneralizationOf :: Expr -> Expr -> Bool
isGeneralizationOf Expr
genExpr Expr
testExpr = 
  if Expr -> Bool
isMeta Expr
genExpr then Bool
True
   else if Expr -> Bool
isMeta Expr
testExpr then Bool
False
    else let genUnwrap :: Maybe (MyFunc, [Expr])
genUnwrap = Expr -> Maybe (MyFunc, [Expr])
unApp Expr
genExpr 
             testUnwrap :: Maybe (MyFunc, [Expr])
testUnwrap = Expr -> Maybe (MyFunc, [Expr])
unApp Expr
testExpr
       in if Maybe (MyFunc, [Expr]) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (MyFunc, [Expr])
genUnwrap Bool -> Bool -> Bool
|| Maybe (MyFunc, [Expr]) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (MyFunc, [Expr])
testUnwrap then Bool
False -- see if you can generalize here
           else let (MyFunc
gencid, [Expr]
genargs) = Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr])
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (MyFunc, [Expr])
genUnwrap 
                    (MyFunc
testcid, [Expr]
testargs) = Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr])
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (MyFunc, [Expr])
testUnwrap
                in 
                   (MyFunc
gencid MyFunc -> MyFunc -> Bool
forall a. Eq a => a -> a -> Bool
== MyFunc
testcid) Bool -> Bool -> Bool
&& ([Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
genargs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
testargs)       
                       Bool -> Bool -> Bool
&& ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Expr -> Expr -> Bool
isGeneralizationOf Expr
g Expr
t | (Expr
g,Expr
t) <- ([Expr] -> [Expr] -> [(Expr, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expr]
genargs [Expr]
testargs)])

{-do lst <- getConcTypes context types (i+1)
     return $ mkMeta i : lst -} 

debugReplaceArgs :: Expr -> Expr -> Environ -> IO (Maybe Expr)
debugReplaceArgs :: Expr -> Expr -> Environ -> IO (Maybe Expr)
debugReplaceArgs Expr
aexpr Expr
cexpr Environ
env = 
  if Maybe (MyFunc, [Expr]) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (MyFunc, [Expr]) -> Bool) -> Maybe (MyFunc, [Expr]) -> Bool
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe (MyFunc, [Expr])
unApp Expr
aexpr then Maybe Expr -> IO (Maybe Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Expr
forall a. Maybe a
Nothing
       else if (Maybe (MyFunc, [Expr]) -> Bool)
-> [Maybe (MyFunc, [Expr])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe (MyFunc, [Expr]) -> Bool
forall a. Maybe a -> Bool
isNothing ([Maybe (MyFunc, [Expr])] -> Bool)
-> [Maybe (MyFunc, [Expr])] -> Bool
forall a b. (a -> b) -> a -> b
$ (Expr -> Maybe (MyFunc, [Expr]))
-> [Expr] -> [Maybe (MyFunc, [Expr])]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Maybe (MyFunc, [Expr])
unApp ([Expr] -> [Maybe (MyFunc, [Expr])])
-> [Expr] -> [Maybe (MyFunc, [Expr])]
forall a b. (a -> b) -> a -> b
$ (MyFunc, [Expr]) -> [Expr]
forall a b. (a, b) -> b
snd ((MyFunc, [Expr]) -> [Expr]) -> (MyFunc, [Expr]) -> [Expr]
forall a b. (a -> b) -> a -> b
$ Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr])
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr]))
-> Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr])
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe (MyFunc, [Expr])
unApp Expr
aexpr then Maybe Expr -> IO (Maybe Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Expr
forall a. Maybe a
Nothing
     else
       let args :: [MyFunc]
args = (Expr -> MyFunc) -> [Expr] -> [MyFunc]
forall a b. (a -> b) -> [a] -> [b]
map ((MyFunc, [Expr]) -> MyFunc
forall a b. (a, b) -> a
fst((MyFunc, [Expr]) -> MyFunc)
-> (Expr -> (MyFunc, [Expr])) -> Expr -> MyFunc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr])
forall a. HasCallStack => Maybe a -> a
fromJust(Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr]))
-> (Expr -> Maybe (MyFunc, [Expr])) -> Expr -> (MyFunc, [Expr])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Expr -> Maybe (MyFunc, [Expr])
unApp) ([Expr] -> [MyFunc]) -> [Expr] -> [MyFunc]
forall a b. (a -> b) -> a -> b
$ (MyFunc, [Expr]) -> [Expr]
forall a b. (a, b) -> b
snd ((MyFunc, [Expr]) -> [Expr]) -> (MyFunc, [Expr]) -> [Expr]
forall a b. (a -> b) -> a -> b
$ Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr])
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr]))
-> Maybe (MyFunc, [Expr]) -> (MyFunc, [Expr])
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe (MyFunc, [Expr])
unApp Expr
aexpr
           concExprs :: [Expr]
concExprs = (MyFunc -> Expr) -> [MyFunc] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (\MyFunc
x -> Maybe Expr -> Expr
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Expr -> Expr) -> Maybe Expr -> Expr
forall a b. (a -> b) -> a -> b
$ MyFunc -> ConcMap -> Maybe Expr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MyFunc
x (ConcMap -> Maybe Expr) -> ConcMap -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ Environ -> ConcMap
getConcMap Environ
env) [MyFunc]
args
         in Int -> Expr -> [Expr] -> IO (Maybe Expr)
startReplace Int
1 Expr
cexpr [Expr]
concExprs
        where 
          startReplace :: Int -> Expr -> [Expr] -> IO (Maybe Expr)
startReplace Int
i Expr
cex []        = Maybe Expr -> IO (Maybe Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Expr -> IO (Maybe Expr)) -> Maybe Expr -> IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
cex
          startReplace Int
i Expr
cex (Expr
a:[Expr]
as)    = do Maybe Expr
val <- Expr -> Int -> Expr -> IO (Maybe Expr)
debugReplaceConc Expr
cex Int
i Expr
a
                                            IO (Maybe Expr)
-> (Expr -> IO (Maybe Expr)) -> Maybe Expr -> IO (Maybe Expr)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ( --do putStrLn $ "didn't find "++ showExpr [] a ++ " in " ++showExpr [] cexpr
                                                       Maybe Expr -> IO (Maybe Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Expr
forall a. Maybe a
Nothing) 
                                                  (\Expr
x -> --do putStrLn $ "found it, the current expression is "++ showExpr [] x
                                                            Int -> Expr -> [Expr] -> IO (Maybe Expr)
startReplace (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Expr
x [Expr]
as) 
                                                     Maybe Expr
val 
                      
debugReplaceConc :: Expr -> Int -> Expr -> IO (Maybe Expr)
debugReplaceConc :: Expr -> Int -> Expr -> IO (Maybe Expr)
debugReplaceConc Expr
expr Int
i Expr
e = 
       let (Expr
newe,Bool
isThere) = Expr -> (Expr, Bool)
searchArg Expr
expr 
          in if Bool
isThere then Maybe Expr -> IO (Maybe Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Expr -> IO (Maybe Expr)) -> Maybe Expr -> IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
newe else Maybe Expr -> IO (Maybe Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Expr -> IO (Maybe Expr)) -> Maybe Expr -> IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$ Maybe Expr
forall a. Maybe a
Nothing 
     where   
      searchArg :: Expr -> (Expr, Bool)
searchArg Expr
e_  =  
            if Expr -> Expr -> Bool
isGeneralizationOf Expr
e Expr
e_ then (Int -> Expr
mkMeta Int
i, Bool
True)
              else (Expr, Bool)
-> ((MyFunc, [Expr]) -> (Expr, Bool))
-> Maybe (MyFunc, [Expr])
-> (Expr, Bool)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Expr
e_,Bool
False) (\(MyFunc
cid,[Expr]
args) -> let repargs :: [(Expr, Bool)]
repargs = (Expr -> (Expr, Bool)) -> [Expr] -> [(Expr, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> (Expr, Bool)
searchArg [Expr]
args
                                         in (MyFunc -> [Expr] -> Expr
mkApp MyFunc
cid (((Expr, Bool) -> Expr) -> [(Expr, Bool)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map  (Expr, Bool) -> Expr
forall a b. (a, b) -> a
fst [(Expr, Bool)]
repargs), [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ ((Expr, Bool) -> Bool) -> [(Expr, Bool)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Expr, Bool) -> Bool
forall a b. (a, b) -> b
snd [(Expr, Bool)]
repargs)) (Maybe (MyFunc, [Expr]) -> (Expr, Bool))
-> Maybe (MyFunc, [Expr]) -> (Expr, Bool)
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe (MyFunc, [Expr])
unApp Expr
e_  
 

{-
-- replaceArgs : Original expression to parse (from abstract syntax) -> Concrete expression (parsed) 
replaceArgs :: Expr -> Expr -> Environ -> Maybe Expr
replaceArgs aexpr cexpr env =
  if isNothing $ unApp aexpr then error $ "could't unwrap this "++ show aexpr 
      else if any isNothing $ map unApp $ snd $ fromJust $ unApp aexpr then error $ "couldn't unwrap more this : "++ show aexpr
  else 
   let  args = map (fst.fromJust.unApp) $ snd $ fromJust $ unApp aexpr
        concExprs = map (\x -> fromJust $ Map.lookup x $ getConcMap env) args
          in startReplace 1 cexpr concExprs
    where 
      startReplace i cex []       = return cex 
      startReplace i cex (a:as)   = maybe Nothing (\x -> startReplace (i+1) x as) $ replaceConc cex i a



replaceConc :: Expr -> Int -> Expr -> Maybe Expr
replaceConc expr i e = 
       let (newe,isThere) = searchArg expr 
          in if isThere then return newe else Nothing 
     where   
      searchArg e_  =  
            if isGeneralizationOf e e_ then (mkMeta i, True)
              else maybe (e_,False) (\(cid,args) -> let repargs = map searchArg args
                                         in (mkApp cid (map  fst repargs), or $ map snd repargs)) $ unApp e_  



writeResults :: Environ -> String -> IO ()
writeResults env fileName = 
   let cmap = getConcMap env
       lincats = unlines $ map (\(x,y) -> "lincat " ++ showCId x ++ " = " ++ showCId y ++ " ; " ) $ Map.toList $ getTypeMap env 
       sigs = unlines $ map 
                  (\x -> let n = getName x 
                             no = length $ getTypeArgs x
                             oargs = unwords $ ("lin " ++ showCId n) : ["o"++show i | i <- [1..no]]     
                         in (oargs ++ " = " ++ (simpleReplace $ showExpr [] $ fromJust $ Map.lookup n cmap) ++ " ; ")) $ concat $ Map.elems $ getSigs env
    in 
          writeFile fileName ("\n" ++ lincats ++ "\n\n" ++  sigs)  
         

simpleReplace :: String -> String 
simpleReplace [] = []
simpleReplace ('?':xs) = 'o' : simpleReplace xs
simpleReplace (x:xs) = x : simpleReplace xs
-}

isMeta :: Expr -> Bool
isMeta :: Expr -> Bool
isMeta = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust(Maybe Int -> Bool) -> (Expr -> Maybe Int) -> Expr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Expr -> Maybe Int
unMeta 

-- works with utf-8 characters also, as it seems


mkFuncWithArg ::  ((CId,CId),[CId]) -> FuncWithArg
mkFuncWithArg :: ((MyFunc, MyFunc), [MyFunc]) -> FuncWithArg
mkFuncWithArg ((MyFunc
c1,MyFunc
c2),[MyFunc]
cids) = MyFunc -> MyFunc -> [MyFunc] -> FuncWithArg
FuncWithArg MyFunc
c1 MyFunc
c2 [MyFunc]
cids


---------------------------------------------------------------------------------

initial :: TypeMap -> ConcMap -> [FuncWithArg] -> [FuncWithArg] -> Environ
initial :: TypeMap -> ConcMap -> [FuncWithArg] -> [FuncWithArg] -> Environ
initial TypeMap
tm ConcMap
cm [FuncWithArg]
fss [FuncWithArg]
allfs = TypeMap
-> ConcMap -> Map MyFunc [FuncWithArg] -> [FuncWithArg] -> Environ
Env TypeMap
tm ConcMap
cm ([FuncWithArg] -> Map MyFunc [FuncWithArg]
mkSigs [FuncWithArg]
fss) [FuncWithArg]
allfs
{-
testInit :: [FuncWithArg] -> Environ
testInit allfs = initial lTypes Map.empty [] allfs

lTypes = Map.fromList [(mkCId "Comment", mkCId "S"),(mkCId "Item", mkCId "NP"), (mkCId "Kind", mkCId "CN"), (mkCId "Quality", mkCId "AP")]
-}
startCateg :: MyFunc
startCateg = String -> MyFunc
mkCId String
"Comment"
-- question about either to give the startcat or not ...





----------------------------------------------------------------------------------------------------------
{-
main = 
 do args <- getArgs
    case args of 
      [pgfFile] -> 
         do pgf <- readPGF pgfFile
            parsePGF <- readPGF parsePGFfile
            fsWithArg <- forExample pgf
            let funcsWithArg = map (map mkFuncWithArg) fsWithArg
            let morpho = buildMorpho parsePGF parseLang
            let fss = concat funcsWithArg
            let fileName = takeWhile (/='.') pgfFile ++ lang ++ ".gf"
            env <- start parsePGF pgf morpho (testInit fss) fss
            putStrLn $ "Should I write the results to a file ? yes/no"
            ans <-getLine 
            if ans == "yes" then do writeResults env fileName
                                    putStrLn $ "Wrote file " ++ fileName
             else return ()  
      _ ->  fail "usage : Testing <path-to-pgf> "


  
start :: PGF -> PGF -> Morpho -> Environ -> [FuncWithArg] -> IO Environ
start parsePGF pgfFile morpho env lst = 
  do putStrLn "Do you want examples from another language ? (no/concrete syntax name otherwise)"
     ans1 <- getLine
     putStrLn "Do you want testing mode ? (yes/no)"
     ans2 <- getLine
     case (ans1,ans2) of
       ("no","no")    -> do putStrLn "no extra language, just the abstract syntax tree"
                            interact env lst False Nothing 
       (_,"no")       -> interact env lst False (readLanguage ans1)
       ("no","yes")   -> do putStrLn "no extra language, just the abstract syntax tree"
                            interact env lst True Nothing
       (_,"yes")    -> interact env lst True (readLanguage ans1)
       ("no",_)       -> do putStrLn "no extra language, just the abstract syntax tree"
                            putStrLn $ "I assume you don't want the testing mode ... " 
                            interact env lst False Nothing
       (_,_)          -> do putStrLn $ "I assume you don't want the testing mode ... " 
                            interact env lst False (readLanguage ans1)             
  where 

   interact environ [] func _ = return environ
   interact environ (farg:fargs) boo otherLang = 
             do 
                maybeEnv <- basicInter farg otherLang environ boo
                if isNothing maybeEnv then return environ
                 else interact (fromJust maybeEnv) fargs boo otherLang                

   basicInter farg js environ False = 
       let e_ = getExpr farg environ in 
        if isNothing e_ then return $ Just environ
             else parseAndBuild farg js environ (getType farg) e_ Nothing 
   basicInter farg js environ True = 
        let (e_,e_test) = get2Expr farg environ in 
         if isNothing e_ then return $ Just environ 
          else if isNothing e_test then do putStrLn $ "not enough arguments "++ (showCId $ getName farg)
                                           parseAndBuild farg js environ (getType farg) e_ Nothing  
                    else parseAndBuild farg js environ (getType farg) e_ e_test

-- . head . generateRandomFrom gen2 pgfFile
   parseAndBuild farg js environ ty e_ e_test =
           do let expr = fromJust e_
              gen1 <- newStdGen
              gen2 <- newStdGen
              let newexpr = head $ generateRandomFrom gen1 pgfFile expr
              let embeddedExpr = maybe "***" (showExpr [] ) (embedInStart (getAll environ) (Map.fromList [(ty,expr)])) 
              let lexpr = if isNothing js then "" else "\n-- " ++ linearize pgfFile (fromJust js) newexpr ++ " --" 
              putStrLn $ "Give an example for " ++ (showExpr [] expr)    
                               ++ lexpr ++ "and now"
                               ++ "\n\nas in " ++ embeddedExpr ++ "\n\n"
              --
              ex <- getLine 
              if (ex == ":q") then return Nothing  
                    else 
                      let ctype = fromJust $ Map.lookup (getType farg) (getTypeMap environ) in
                         do env' <- decypher farg ex expr environ (fromJust $ readType $ showCId ctype) e_test
                            return (Just env')
       
   decypher farg ex expr environ ty e_test =  
     --do putStrLn $ "We need to parse " ++ ex ++ " as " ++ show ctype
        let pTrees = parse parsePGF (fromJust $ readLanguage "ParseEng") ty ex  in 
             pickTree farg expr environ ex e_test pTrees 
             
 --  putStrLn $ "And now for testing, \n is this also correct yes/no \n ## " ++  (linearize parsePGF parseLang $ mapToResource newenv $ llin newenv e_test) ++ " ##"
                                               
   -- select the right tree among the options given by the parser 
   pickTree farg expr environ ex e_test [] =  
                let miswords = morphoMissing morpho (words ex) 
                   in 
                if null miswords then do putStrLn $ "all words known, but some syntactic construction is not covered by the grammar..."
                                         return environ
                    else do putStrLn $ "the following words are unknown, please add them to the lexicon: " ++ show miswords
                            return environ
   pickTree farg expr environ ex e_test [tree] = 
                do val <- searchGoodTree environ expr [tree]  -- maybe order here after the probabilities for better precision
                   maybe (do putStrLn $ "none of the trees is consistent with the rest of the grammar, please check arguments "
                             return environ) 
                         (\(x,newtree) -> let newenv = updateEnv environ farg (getType farg) x in
                                              do putStrLn $ "the result is "++showExpr [] x
                                                 newtestenv <- testTest newenv e_test -- question ? should it belong there - there is just one possibility of a tree... 
                                                 return newenv) val
   pickTree farg expr environ ex e_test parseTrees = 
                do putStrLn $ "There is more than one possibility, do you want to choose the right tree yourself ? yes/no "
                   putStr "  >"
                   ans <- getLine
                   if ans == "yes" then do pTree <- chooseRightTree parseTrees
                                           processTree farg environ expr pTree e_test
                     else processTree farg environ expr parseTrees e_test

   -- introduce testing function, if it doesn't work, then reparse, take that tree
   testTree envv e_test = return envv -- TO DO - add testing here
   
   testTest envv Nothing = return envv
   testTest envv (Just exxpr) = testTree envv exxpr   
 

   -- allows the user to pick his own tree
   chooseRightTree trees = return trees -- TO DO - add something clever here     
   
   -- selects the tree from where one can abstract over the original arguments 
   processTree farg environ expr lsTrees e_test =
     let trmes = if length lsTrees == 1 then "the tree is not consistent " else "none of the trees is consistent " in
     do val <- searchGoodTree environ expr lsTrees
        maybe (do putStrLn $ trmes ++ "with the rest of the grammar, please check arguments! "
                  return environ) 
                         (\(x,newtree) -> let newenv = updateEnv environ farg (getType farg) x in
                                              do putStrLn $ "the result is "++showExpr [] x
                                                 newtestenv <- testTest newenv e_test 
                                                 return newenv) val



-------------------------------

get2Expr :: FuncWithArg -> Environ -> (Maybe Expr, Maybe Expr)
get2Expr farg env =
  let tys = getTypeArgs farg
      ctx = getSigs env
      (lst1,lst2) = getConcTypes2 ctx tys 1
      arg1 = if (all isJust lst1) then Just $ mkApp (getName farg) (map fromJust lst1) else Nothing
      arg2 = if (all isJust lst2) then Just $ mkApp (getName farg) (map fromJust lst2) else Nothing
   in if arg1 == arg2 then (arg1, Nothing)
         else (arg1,arg2)
  where 
           getConcTypes2 context [] i = ([],[])
           getConcTypes2 context (ty:types) i =  
                let pos = Map.lookup ty context
                   in 
                    if isNothing pos  || (null $ fromJust pos) then ([Nothing],[Nothing])                                                
                          else  
                             let (mm,tt) = (last $ fromJust pos, head $ fromJust pos)
                                 mmargs = getTypeArgs mm
                                 newi = i + length mmargs - 1  
                                 (lst1,lst2) = getConcTypes2 (Map.insert ty (init (fromJust pos)) context) types (newi+1)
                                 ttargs = getTypeArgs tt
                                 newtti = i + length ttargs - 1
                                 fstArg = if (all isJust lst1) then               -- i..newi  
                                             (Just $ mkApp (getName mm) [mkMeta j | j <- [1..(length mmargs)]]) : lst1 
                                            else [Nothing]
                                 sndArg = if (all isJust lst2) then 
                                             (Just $ mkApp (getName tt) [mkMeta j | j <- [1..(length ttargs)]]) : lst2
                                            else [Nothing]
                              in 
                                (fstArg,sndArg)   


-}