module PGF.Probabilistic
         ( Probabilities(..)
         , mkProbabilities                 -- :: PGF -> M.Map CId Double -> Probabilities
         , defaultProbabilities            -- :: PGF -> Probabilities
         , getProbabilities
         , setProbabilities
         , showProbabilities               -- :: Probabilities -> String
         , readProbabilitiesFromFile       -- :: FilePath -> PGF -> IO Probabilities

         , probTree
         , rankTreesByProbs
         , mkProbDefs
         ) where

import PGF.CId
import PGF.Data
import PGF.Macros

import qualified Data.Map as Map
import Data.List (sortBy,partition,nub,mapAccumL)
import Data.Maybe (fromMaybe) --, fromJust

-- | An abstract data structure which represents
-- the probabilities for the different functions in a grammar.
data Probabilities = Probs {
  Probabilities -> Map CId Double
funProbs :: Map.Map CId Double,
  Probabilities -> Map CId (Double, [(Double, CId)])
catProbs :: Map.Map CId (Double, [(Double, CId)])
  }

-- | Renders the probability structure as string
showProbabilities :: Probabilities -> String
showProbabilities :: Probabilities -> String
showProbabilities = [String] -> String
unlines ([String] -> String)
-> (Probabilities -> [String]) -> Probabilities -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CId, (Double, [(Double, CId)])) -> [String])
-> [(CId, (Double, [(Double, CId)]))] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CId, (Double, [(Double, CId)])) -> [String]
forall a a. (Show a, Show a) => (CId, (a, [(a, CId)])) -> [String]
prProb ([(CId, (Double, [(Double, CId)]))] -> [String])
-> (Probabilities -> [(CId, (Double, [(Double, CId)]))])
-> Probabilities
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CId (Double, [(Double, CId)])
-> [(CId, (Double, [(Double, CId)]))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map CId (Double, [(Double, CId)])
 -> [(CId, (Double, [(Double, CId)]))])
-> (Probabilities -> Map CId (Double, [(Double, CId)]))
-> Probabilities
-> [(CId, (Double, [(Double, CId)]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Probabilities -> Map CId (Double, [(Double, CId)])
catProbs where
  prProb :: (CId, (a, [(a, CId)])) -> [String]
prProb (CId
c,(a
p,[(a, CId)]
fns)) = (a, CId) -> String
forall a. Show a => (a, CId) -> String
pr (a
p,CId
c) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((a, CId) -> String) -> [(a, CId)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (a, CId) -> String
forall a. Show a => (a, CId) -> String
pr [(a, CId)]
fns
  pr :: (a, CId) -> String
pr (a
p,CId
f) = CId -> String
showCId CId
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
p

-- | Reads the probabilities from a file.
-- This should be a text file where on every line
-- there is a function name followed by a real number.
-- The number represents the probability mass allocated for that function.
-- The function name and the probability should be separated by a whitespace.
readProbabilitiesFromFile :: FilePath -> PGF -> IO Probabilities
readProbabilitiesFromFile :: String -> PGF -> IO Probabilities
readProbabilitiesFromFile String
file PGF
pgf = do
  String
s <- String -> IO String
readFile String
file
  let ps0 :: Map CId Double
ps0 = [(CId, Double)] -> Map CId Double
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String -> CId
mkCId String
f,String -> Double
forall a. Read a => String -> a
read String
p) | String
f:String
p:[String]
_ <- (String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words (String -> [String]
lines String
s)]
  Probabilities -> IO Probabilities
forall (m :: * -> *) a. Monad m => a -> m a
return (Probabilities -> IO Probabilities)
-> Probabilities -> IO Probabilities
forall a b. (a -> b) -> a -> b
$ PGF -> Map CId Double -> Probabilities
mkProbabilities PGF
pgf Map CId Double
ps0

-- | Builds probability tables. The second argument is a map
-- which contains the know probabilities. If some function is
-- not in the map then it gets assigned some probability based
-- on the even distribution of the unallocated probability mass
-- for the result category.
mkProbabilities :: PGF -> Map.Map CId Double -> Probabilities
mkProbabilities :: PGF -> Map CId Double -> Probabilities
mkProbabilities PGF
pgf Map CId Double
probs =
  let funs1 :: Map CId Double
funs1 = [(CId, Double)] -> Map CId Double
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(CId
f,Double
p) | (CId
_,(Double
_,[(Double, CId)]
fns)) <- Map CId (Double, [(Double, CId)])
-> [(CId, (Double, [(Double, CId)]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map CId (Double, [(Double, CId)])
cats1, (Double
p,CId
f) <- [(Double, CId)]
fns]
      cats1 :: Map CId (Double, [(Double, CId)])
cats1 = (CId
 -> ([Hypo], [(Double, CId)], Double) -> (Double, [(Double, CId)]))
-> Map CId ([Hypo], [(Double, CId)], Double)
-> Map CId (Double, [(Double, CId)])
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\CId
c ([Hypo]
_,[(Double, CId)]
fns,Double
_) -> 
                                 let p' :: Double
p'   = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (CId -> Map CId Double -> Maybe Double
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
c Map CId Double
probs)
                                     fns' :: [(Double, CId)]
fns' = ((Double, CId) -> (Double, CId) -> Ordering)
-> [(Double, CId)] -> [(Double, CId)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Double, CId) -> (Double, CId) -> Ordering
forall a b b. Ord a => (a, b) -> (a, b) -> Ordering
cmpProb ([(Double, CId)] -> [(Double, CId)]
forall a. [(a, CId)] -> [(Double, CId)]
fill [(Double, CId)]
fns)
                                 in (Double
p', [(Double, CId)]
fns'))
                             (Abstr -> Map CId ([Hypo], [(Double, CId)], Double)
cats (PGF -> Abstr
abstract PGF
pgf))
  in Map CId Double
-> Map CId (Double, [(Double, CId)]) -> Probabilities
Probs Map CId Double
funs1 Map CId (Double, [(Double, CId)])
cats1
  where
    cmpProb :: (a, b) -> (a, b) -> Ordering
cmpProb (a
p1,b
_) (a
p2,b
_) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
p2 a
p1

    fill :: [(a, CId)] -> [(Double, CId)]
fill [(a, CId)]
fs = [(Maybe Double, CId)] -> [(Double, CId)]
forall a. [(Maybe Double, a)] -> [(Double, a)]
pad [(CId -> Map CId Double -> Maybe Double
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
f Map CId Double
probs,CId
f) | (a
_,CId
f) <- [(a, CId)]
fs]
      where
        pad :: [(Maybe Double,a)] -> [(Double,a)]
        pad :: [(Maybe Double, a)] -> [(Double, a)]
pad [(Maybe Double, a)]
pfs = [(Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
deflt Maybe Double
mb_p,a
f) | (Maybe Double
mb_p,a
f) <- [(Maybe Double, a)]
pfs]
          where
            deflt :: Double
deflt = case [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a
f | (Maybe Double
Nothing,a
f) <- [(Maybe Double, a)]
pfs] of
                      Int
0 -> Double
0
                      Int
n -> Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 ((Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double
d | (Just Double
d,a
f) <- [(Maybe Double, a)]
pfs]) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

-- | Returns the default even distibution.
defaultProbabilities :: PGF -> Probabilities
defaultProbabilities :: PGF -> Probabilities
defaultProbabilities PGF
pgf = PGF -> Map CId Double -> Probabilities
mkProbabilities PGF
pgf Map CId Double
forall k a. Map k a
Map.empty

getProbabilities :: PGF -> Probabilities
getProbabilities :: PGF -> Probabilities
getProbabilities PGF
pgf = Probs :: Map CId Double
-> Map CId (Double, [(Double, CId)]) -> Probabilities
Probs {
  funProbs :: Map CId Double
funProbs = ((Type, Int, Maybe ([Equation], [[Instr]]), Double) -> Double)
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Map CId Double
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(Type
_,Int
_,Maybe ([Equation], [[Instr]])
_,Double
p) -> Double
p      ) (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs (PGF -> Abstr
abstract PGF
pgf)),
  catProbs :: Map CId (Double, [(Double, CId)])
catProbs = (([Hypo], [(Double, CId)], Double) -> (Double, [(Double, CId)]))
-> Map CId ([Hypo], [(Double, CId)], Double)
-> Map CId (Double, [(Double, CId)])
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\([Hypo]
_,[(Double, CId)]
fns,Double
p) -> (Double
p,[(Double, CId)]
fns)) (Abstr -> Map CId ([Hypo], [(Double, CId)], Double)
cats (PGF -> Abstr
abstract PGF
pgf))
  }

setProbabilities :: Probabilities -> PGF -> PGF
setProbabilities :: Probabilities -> PGF -> PGF
setProbabilities Probabilities
probs PGF
pgf = PGF
pgf {
  abstract :: Abstr
abstract = (PGF -> Abstr
abstract PGF
pgf) {
    funs :: Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs = ((Type, Int, Maybe ([Equation], [[Instr]]), Double)
 -> Double -> (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Map CId Double
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall k b a.
Ord k =>
(b -> a -> b) -> Map k b -> Map k a -> Map k b
mapUnionWith (\(Type
ty,Int
a,Maybe ([Equation], [[Instr]])
df,Double
_) Double
p       -> (Type
ty,Int
a,Maybe ([Equation], [[Instr]])
df,  Double
p)) (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs (PGF -> Abstr
abstract PGF
pgf)) (Probabilities -> Map CId Double
funProbs Probabilities
probs),
    cats :: Map CId ([Hypo], [(Double, CId)], Double)
cats = (([Hypo], [(Double, CId)], Double)
 -> (Double, [(Double, CId)]) -> ([Hypo], [(Double, CId)], Double))
-> Map CId ([Hypo], [(Double, CId)], Double)
-> Map CId (Double, [(Double, CId)])
-> Map CId ([Hypo], [(Double, CId)], Double)
forall k b a.
Ord k =>
(b -> a -> b) -> Map k b -> Map k a -> Map k b
mapUnionWith (\([Hypo]
hypos,[(Double, CId)]
_,Double
_) (Double
p,[(Double, CId)]
fns) -> ([Hypo]
hypos,[(Double, CId)]
fns,Double
p)) (Abstr -> Map CId ([Hypo], [(Double, CId)], Double)
cats (PGF -> Abstr
abstract PGF
pgf)) (Probabilities -> Map CId (Double, [(Double, CId)])
catProbs Probabilities
probs)
  }}
  where
    mapUnionWith :: (b -> a -> b) -> Map k b -> Map k a -> Map k b
mapUnionWith b -> a -> b
f Map k b
map1 Map k a
map2 = 
      (k -> b -> b) -> Map k b -> Map k b
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\k
k b
v -> b -> (a -> b) -> Maybe a -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
v (b -> a -> b
f b
v) (k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k a
map2)) Map k b
map1

-- | compute the probability of a given tree
probTree :: PGF -> Expr -> Double
probTree :: PGF -> Expr -> Double
probTree PGF
pgf Expr
t = case Expr
t of
  EApp Expr
f Expr
e -> PGF -> Expr -> Double
probTree PGF
pgf Expr
f Double -> Double -> Double
forall a. Num a => a -> a -> a
* PGF -> Expr -> Double
probTree PGF
pgf Expr
e
  EFun CId
f   -> case 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
f (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs (PGF -> Abstr
abstract PGF
pgf)) of
                Just (Type
_,Int
_,Maybe ([Equation], [[Instr]])
_,Double
p) -> Double
p
                Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
Nothing        -> Double
1
  Expr
_ -> Double
1

-- | rank from highest to lowest probability
rankTreesByProbs :: PGF -> [Expr] -> [(Expr,Double)]
rankTreesByProbs :: PGF -> [Expr] -> [(Expr, Double)]
rankTreesByProbs PGF
pgf [Expr]
ts = ((Expr, Double) -> (Expr, Double) -> Ordering)
-> [(Expr, Double)] -> [(Expr, Double)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\ (Expr
_,Double
p) (Expr
_,Double
q) -> Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
q Double
p) 
  [(Expr
t, PGF -> Expr -> Double
probTree PGF
pgf Expr
t) | Expr
t <- [Expr]
ts]


mkProbDefs :: PGF -> ([[CId]],[(CId,Type,[Equation])])
mkProbDefs :: PGF -> ([[CId]], [(CId, Type, [Equation])])
mkProbDefs PGF
pgf =
  let cs :: [(CId, [Hypo], [(CId, Type)])]
cs = [(CId
c,[Hypo]
hyps,[(CId, Type)]
fns) | (CId
c,([Hypo]
hyps0,[(Double, CId)]
fs,Double
_)) <- Map CId ([Hypo], [(Double, CId)], Double)
-> [(CId, ([Hypo], [(Double, CId)], Double))]
forall k a. Map k a -> [(k, a)]
Map.toList (Abstr -> Map CId ([Hypo], [(Double, CId)], Double)
cats (PGF -> Abstr
abstract PGF
pgf)),
                           Bool -> Bool
not (CId -> [CId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem CId
c [CId
cidString,CId
cidInt,CId
cidFloat]),
                           let hyps :: [Hypo]
hyps = (Hypo -> Integer -> Hypo) -> [Hypo] -> [Integer] -> [Hypo]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(BindType
bt,CId
_,Type
ty) Integer
n -> (BindType
bt,String -> CId
mkCId (Char
'v'Char -> String -> String
forall a. a -> [a] -> [a]
:Integer -> String
forall a. Show a => a -> String
show Integer
n),Type
ty))
                                              [Hypo]
hyps0
                                              [Integer
1..]
                               fns :: [(CId, Type)]
fns  = [(CId
f,Type
ty) | (Double
_,CId
f) <- [(Double, CId)]
fs, 
                                               let Just (Type
ty,Int
_,Maybe ([Equation], [[Instr]])
_,Double
_) = 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
f (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs (PGF -> Abstr
abstract PGF
pgf))]
           ]
      ((Integer
_,[[[CId]]]
css),[[(CId, Type, [Equation])]]
eqss) = ((Integer, [[[CId]]])
 -> (CId, [Hypo], [(CId, Type)])
 -> ((Integer, [[[CId]]]), [(CId, Type, [Equation])]))
-> (Integer, [[[CId]]])
-> [(CId, [Hypo], [(CId, Type)])]
-> ((Integer, [[[CId]]]), [[(CId, Type, [Equation])]])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\(Integer
ngen,[[[CId]]]
css) (CId
c,[Hypo]
hyps,[(CId, Type)]
fns) -> 
              let st0 :: (Int, Map k a)
st0      = (Int
1,Map k a
forall k a. Map k a
Map.empty)
                  ((Int
_,Map CId [Equation]
eqs_map),[[CId]]
cs) = PGF
-> (Int, Map CId [Equation])
-> [(CId, [Patt], [Expr])]
-> ((Int, Map CId [Equation]), [[CId]])
computeConstrs PGF
pgf (Int, Map CId [Equation])
forall k a. (Int, Map k a)
st0 [(CId
fn,[],[Expr]
es) | (CId
fn,(DTyp [Hypo]
_ CId
_ [Expr]
es)) <- [(CId, Type)]
fns]
                  (Integer
ngen', [Equation]
eqs) = (Integer -> (CId, Type) -> (Integer, Equation))
-> Integer -> [(CId, Type)] -> (Integer, [Equation])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (Map CId [Equation]
-> [Hypo] -> Integer -> (CId, Type) -> (Integer, Equation)
forall a (t :: * -> *) a p.
(Num a, Show a, Foldable t) =>
Map CId (t a) -> p -> a -> (CId, Type) -> (a, Equation)
mkEquation Map CId [Equation]
eqs_map [Hypo]
hyps) Integer
ngen [(CId, Type)]
fns
                  ceqs :: [(CId, Type, [Equation])]
ceqs     = [(CId
id,[Hypo] -> CId -> [Expr] -> Type
DTyp [] CId
cidFloat [],[Equation] -> [Equation]
forall a. [a] -> [a]
reverse [Equation]
eqs) | (CId
id,[Equation]
eqs) <- Map CId [Equation] -> [(CId, [Equation])]
forall k a. Map k a -> [(k, a)]
Map.toList Map CId [Equation]
eqs_map, Bool -> Bool
not ([Equation] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Equation]
eqs)]
              in ((Integer
ngen',[[CId]]
cs[[CId]] -> [[[CId]]] -> [[[CId]]]
forall a. a -> [a] -> [a]
:[[[CId]]]
css),(CId -> CId
p_f CId
c, CId -> [Hypo] -> Type
mkType CId
c [Hypo]
hyps, [Equation]
eqs)(CId, Type, [Equation])
-> [(CId, Type, [Equation])] -> [(CId, Type, [Equation])]
forall a. a -> [a] -> [a]
:[(CId, Type, [Equation])]
ceqs)) (Integer
1,[]) [(CId, [Hypo], [(CId, Type)])]
cs
  in ([[CId]] -> [[CId]]
forall a. [a] -> [a]
reverse ([[[CId]]] -> [[CId]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[CId]]]
css),[[(CId, Type, [Equation])]] -> [(CId, Type, [Equation])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(CId, Type, [Equation])]]
eqss)
  where
    mkEImplArg :: BindType -> Expr -> Expr
mkEImplArg BindType
bt Expr
e
      | BindType
bt BindType -> BindType -> Bool
forall a. Eq a => a -> a -> Bool
== BindType
Explicit = Expr
e
      | Bool
otherwise      = Expr -> Expr
EImplArg Expr
e
      
    mkPImplArg :: BindType -> Patt -> Patt
mkPImplArg BindType
bt Patt
p
      | BindType
bt BindType -> BindType -> Bool
forall a. Eq a => a -> a -> Bool
== BindType
Explicit = Patt
p
      | Bool
otherwise      = Patt -> Patt
PImplArg Patt
p

    mkType :: CId -> [Hypo] -> Type
mkType CId
c [Hypo]
hyps =
      [Hypo] -> CId -> [Expr] -> Type
DTyp ([Hypo]
hyps[Hypo] -> [Hypo] -> [Hypo]
forall a. [a] -> [a] -> [a]
++[Type -> Hypo
mkHypo ([Hypo] -> CId -> [Expr] -> Type
DTyp [] CId
c [Expr]
es)]) CId
cidFloat []
      where
        is :: [Int]
is = [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0..[Hypo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Hypo]
hypsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
        es :: [Expr]
es = [BindType -> Expr -> Expr
mkEImplArg BindType
bt (Int -> Expr
EVar Int
i) | (Int
i,(BindType
bt,CId
_,Type
_)) <- [Int] -> [Hypo] -> [(Int, Hypo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
is [Hypo]
hyps]

    sig :: (Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double),
 p -> Maybe a)
sig = (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs (PGF -> Abstr
abstract PGF
pgf), \p
_ -> Maybe a
forall a. Maybe a
Nothing)
    
    mkEquation :: Map CId (t a) -> p -> a -> (CId, Type) -> (a, Equation)
mkEquation Map CId (t a)
ceqs p
hyps a
ngen (CId
fn,ty :: Type
ty@(DTyp [Hypo]
args CId
_ [Expr]
es)) =
      let fs1 :: [Expr]
fs1         = case CId -> Map CId (t a) -> Maybe (t a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (CId -> CId
p_f CId
fn) Map CId (t a)
ceqs of
                          Maybe (t a)
Nothing              -> [CId -> [Expr] -> Expr
mkApp (CId -> CId
k_f CId
fn) (((Int, Type) -> Expr) -> [(Int, Type)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i,Type
_) -> Int -> Expr
EVar (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) [(Int, Type)]
vs1)]
                          Just t a
eqs | t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
eqs  -> []
                                   | Bool
otherwise -> [CId -> [Expr] -> Expr
mkApp (CId -> CId
p_f CId
fn) (((Int, Type) -> Expr) -> [(Int, Type)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i,Type
_) -> Int -> Expr
EVar (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) [(Int, Type)]
vs1)]
          (a
ngen',[Expr]
fs2) = (a -> ([(Int, Type)], [Int]) -> (a, Expr))
-> a -> [([(Int, Type)], [Int])] -> (a, [Expr])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL a -> ([(Int, Type)], [Int]) -> (a, Expr)
forall a b b. (Num a, Show a) => a -> ([(Int, b)], b) -> (a, Expr)
mkFactor2 a
ngen [([(Int, Type)], [Int])]
vs2
          fs3 :: [Expr]
fs3         = ((Int, Type) -> Expr) -> [(Int, Type)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Type) -> Expr
mkFactor3 [(Int, Type)]
vs3
          eq :: Equation
eq = [Patt] -> Expr -> Equation
Equ ((Expr -> Patt) -> [Expr] -> [Patt]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Patt
mkTildeP [Expr]
xes[Patt] -> [Patt] -> [Patt]
forall a. [a] -> [a] -> [a]
++[CId -> [Patt] -> Patt
PApp CId
fn ((Integer -> Hypo -> Patt) -> [Integer] -> [Hypo] -> [Patt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> Hypo -> Patt
forall a b c. Show a => a -> (BindType, b, c) -> Patt
mkArgP [Integer
1..] [Hypo]
args)])
                   ([Expr] -> Expr
mkMult ([Expr]
fs1[Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++[Expr]
fs2[Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++[Expr]
fs3))
      in (a
ngen',Equation
eq)
      where
        xes :: [Expr]
xes = (Expr -> Expr) -> [Expr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Sig -> Int -> Env -> Expr -> Expr
normalForm Sig
forall p a.
(Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double),
 p -> Maybe a)
sig Int
k Env
env) [Expr]
es

        mkTildeP :: Expr -> Patt
mkTildeP Expr
e =
          case Expr
e of
            EImplArg Expr
e -> Patt -> Patt
PImplArg (Expr -> Patt
PTilde Expr
e)
            Expr
e          ->           Expr -> Patt
PTilde Expr
e

        mkArgP :: a -> (BindType, b, c) -> Patt
mkArgP a
n (BindType
bt,b
_,c
_) = BindType -> Patt -> Patt
mkPImplArg BindType
bt (CId -> Patt
PVar (String -> CId
mkCId (Char
'v'Char -> String -> String
forall a. a -> [a] -> [a]
:a -> String
forall a. Show a => a -> String
show a
n)))

        mkMult :: [Expr] -> Expr
mkMult []  = Literal -> Expr
ELit (Double -> Literal
LFlt Double
1)
        mkMult [Expr
e] = Expr
e
        mkMult [Expr]
es  = CId -> [Expr] -> Expr
mkApp (String -> CId
mkCId String
"mult") [Expr]
es

        mkFactor2 :: a -> ([(Int, b)], b) -> (a, Expr)
mkFactor2 a
ngen ([(Int, b)]
src,b
dst) =
          let vs :: [Expr]
vs = [Int -> Expr
EVar (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) | (Int
i,b
ty) <- [(Int, b)]
src]
          in (a
ngena -> a -> a
forall a. Num a => a -> a -> a
+a
1,CId -> [Expr] -> Expr
mkApp (a -> CId
forall a. Show a => a -> CId
p_i a
ngen) [Expr]
vs)

        mkFactor3 :: (Int, Type) -> Expr
mkFactor3 (Int
i,DTyp [Hypo]
_ CId
c [Expr]
es) =
          let v :: Expr
v = Int -> Expr
EVar (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
          in CId -> [Expr] -> Expr
mkApp (CId -> CId
p_f CId
c) ((Expr -> Expr) -> [Expr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Sig -> Int -> Env -> Expr -> Expr
normalForm Sig
forall p a.
(Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double),
 p -> Maybe a)
sig Int
k Env
env) [Expr]
es[Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++[Expr
v])

        (Int
k,Env
env,[(Int, Type)]
vs1,[([(Int, Type)], [Int])]
vs2,[(Int, Type)]
vs3) = Type
-> (Int, Env, [(Int, Type)], [([(Int, Type)], [Int])],
    [(Int, Type)])
mkDeps Type
ty

        mkDeps :: Type
-> (Int, Env, [(Int, Type)], [([(Int, Type)], [Int])],
    [(Int, Type)])
mkDeps (DTyp [Hypo]
args CId
_ [Expr]
es) =
          let (Int
k,[Int]
env,[([(Int, Type)], [Int])]
dep1) = Int
-> [Int]
-> [([(Int, Type)], [Int])]
-> [Hypo]
-> (Int, [Int], [([(Int, Type)], [Int])])
forall a.
Int
-> [Int]
-> [([(Int, Type)], [Int])]
-> [(a, CId, Type)]
-> (Int, [Int], [([(Int, Type)], [Int])])
updateArgs Int
0 [] [] [Hypo]
args
              dep2 :: [([(Int, Type)], [Int])]
dep2         = ([([(Int, Type)], [Int])] -> Expr -> [([(Int, Type)], [Int])])
-> [([(Int, Type)], [Int])] -> [Expr] -> [([(Int, Type)], [Int])]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Int
-> [Int]
-> [([(Int, Type)], [Int])]
-> Expr
-> [([(Int, Type)], [Int])]
forall a a. a -> [Int] -> [(a, [a])] -> Expr -> [(a, [a])]
update Int
k [Int]
env) [([(Int, Type)], [Int])]
dep1 [Expr]
es
              ([([(Int, Type)], [Int])]
vs2,[(Int, Type)]
vs3)    = Int
-> [([(Int, Type)], [Int])]
-> [([(Int, Type)], [Int])]
-> [(Int, Type)]
-> ([([(Int, Type)], [Int])], [(Int, Type)])
forall a b.
(Eq b, Eq a) =>
a
-> [([(a, b)], [a])]
-> [([(a, b)], [a])]
-> [(a, b)]
-> ([([(a, b)], [a])], [(a, b)])
closure Int
k [([(Int, Type)], [Int])]
dep2 [] []
              vs1 :: [(Int, Type)]
vs1          = [[(Int, Type)]] -> [(Int, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, Type)]
src | ([(Int, Type)]
src,[Int]
dst) <- [([(Int, Type)], [Int])]
dep2, Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Int
k [Int]
dst]
          in (Int
k,(Int -> Value) -> [Int] -> Env
forall a b. (a -> b) -> [a] -> [b]
map (\Int
k -> Int -> Env -> Value
VGen Int
k []) [Int]
env,[(Int, Type)]
vs1,[([(Int, Type)], [Int])] -> [([(Int, Type)], [Int])]
forall a. [a] -> [a]
reverse [([(Int, Type)], [Int])]
vs2,[(Int, Type)]
vs3)
          where
            updateArgs :: Int
-> [Int]
-> [([(Int, Type)], [Int])]
-> [(a, CId, Type)]
-> (Int, [Int], [([(Int, Type)], [Int])])
updateArgs Int
k [Int]
env [([(Int, Type)], [Int])]
dep []                              = (Int
k,[Int]
env,[([(Int, Type)], [Int])]
dep)
            updateArgs Int
k [Int]
env [([(Int, Type)], [Int])]
dep ((a
_,CId
x,ty :: Type
ty@(DTyp [Hypo]
_ CId
_ [Expr]
es)) : [(a, CId, Type)]
args) =
              let dep1 :: [([(Int, Type)], [Int])]
dep1 = ([([(Int, Type)], [Int])] -> Expr -> [([(Int, Type)], [Int])])
-> [([(Int, Type)], [Int])] -> [Expr] -> [([(Int, Type)], [Int])]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Int
-> [Int]
-> [([(Int, Type)], [Int])]
-> Expr
-> [([(Int, Type)], [Int])]
forall a a. a -> [Int] -> [(a, [a])] -> Expr -> [(a, [a])]
update Int
k [Int]
env) [([(Int, Type)], [Int])]
dep [Expr]
es [([(Int, Type)], [Int])]
-> [([(Int, Type)], [Int])] -> [([(Int, Type)], [Int])]
forall a. [a] -> [a] -> [a]
++ [([(Int
k,Type
ty)],[])]
                  env1 :: [Int]
env1 | CId
x CId -> CId -> Bool
forall a. Eq a => a -> a -> Bool
== CId
wildCId =     [Int]
env
                       | Bool
otherwise    = Int
k Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
env
              in Int
-> [Int]
-> [([(Int, Type)], [Int])]
-> [(a, CId, Type)]
-> (Int, [Int], [([(Int, Type)], [Int])])
updateArgs (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Int]
env1 [([(Int, Type)], [Int])]
dep1 [(a, CId, Type)]
args

            update :: a -> [Int] -> [(a, [a])] -> Expr -> [(a, [a])]
update a
k [Int]
env [(a, [a])]
dep Expr
e =
              case Expr
e of
                EApp Expr
e1 Expr
e2 -> a -> [Int] -> [(a, [a])] -> Expr -> [(a, [a])]
update a
k [Int]
env (a -> [Int] -> [(a, [a])] -> Expr -> [(a, [a])]
update a
k [Int]
env [(a, [a])]
dep Expr
e1) Expr
e2
                EFun CId
_     -> [(a, [a])]
dep
                EVar Int
i     -> let ([(a, [a])]
dep1,(a
src,[a]
dst):[(a, [a])]
dep2) = Int -> [(a, [a])] -> ([(a, [a])], [(a, [a])])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Int]
env [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
i) [(a, [a])]
dep
                              in [(a, [a])]
dep1[(a, [a])] -> [(a, [a])] -> [(a, [a])]
forall a. [a] -> [a] -> [a]
++(a
src,a
ka -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
dst)(a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
:[(a, [a])]
dep2

            closure :: a
-> [([(a, b)], [a])]
-> [([(a, b)], [a])]
-> [(a, b)]
-> ([([(a, b)], [a])], [(a, b)])
closure a
k []               [([(a, b)], [a])]
vs2 [(a, b)]
vs3 = ([([(a, b)], [a])]
vs2,[(a, b)]
vs3)
            closure a
k (([(a, b)]
src,[a]
dst):[([(a, b)], [a])]
deps) [([(a, b)], [a])]
vs2 [(a, b)]
vs3
              | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
dst   = a
-> [([(a, b)], [a])]
-> [([(a, b)], [a])]
-> [(a, b)]
-> ([([(a, b)], [a])], [(a, b)])
closure a
k [([(a, b)], [a])]
deps [([(a, b)], [a])]
vs2 ([(a, b)]
vs3[(a, b)] -> [(a, b)] -> [(a, b)]
forall a. [a] -> [a] -> [a]
++[(a, b)]
src)
              | Bool
otherwise  =
                  let ([([(a, b)], [a])]
deps1,[([(a, b)], [a])]
deps2) = (([(a, b)], [a]) -> Bool)
-> [([(a, b)], [a])] -> ([([(a, b)], [a])], [([(a, b)], [a])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\([(a, b)]
src',[a]
dst') -> Bool -> Bool
not ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a
v1 | a
v1 <- [a]
dst, a
v2 <- [a]
dst', a
v1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v2])) [([(a, b)], [a])]
deps
                      deps3 :: [([(a, b)], [a])]
deps3 = ([(a, b)]
src,[a]
dst)([(a, b)], [a]) -> [([(a, b)], [a])] -> [([(a, b)], [a])]
forall a. a -> [a] -> [a]
:[([(a, b)], [a])]
deps1
                      src2 :: [(a, b)]
src2  = (([(a, b)], [a]) -> [(a, b)]) -> [([(a, b)], [a])] -> [(a, b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(a, b)], [a]) -> [(a, b)]
forall a b. (a, b) -> a
fst [([(a, b)], [a])]
deps3
                      dst2 :: [a]
dst2  = [a
v | a
v <- (([(a, b)], [a]) -> [a]) -> [([(a, b)], [a])] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(a, b)], [a]) -> [a]
forall a b. (a, b) -> b
snd [([(a, b)], [a])]
deps3
                                 , a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
v [(a, b)]
src2 Maybe b -> Maybe b -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe b
forall a. Maybe a
Nothing]
                      dep2 :: ([(a, b)], [a])
dep2  = ([(a, b)]
src2,[a]
dst2)
                      dst' :: [a]
dst'  = [a] -> [a]
forall a. Eq a => [a] -> [a]
nub [a]
dst
                  in if [([(a, b)], [a])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([(a, b)], [a])]
deps1
                       then if [a]
dst' [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a
k]
                              then a
-> [([(a, b)], [a])]
-> [([(a, b)], [a])]
-> [(a, b)]
-> ([([(a, b)], [a])], [(a, b)])
closure a
k [([(a, b)], [a])]
deps2 [([(a, b)], [a])]
vs2 [(a, b)]
vs3
                              else a
-> [([(a, b)], [a])]
-> [([(a, b)], [a])]
-> [(a, b)]
-> ([([(a, b)], [a])], [(a, b)])
closure a
k [([(a, b)], [a])]
deps2 (([(a, b)]
src,[a]
dst') ([(a, b)], [a]) -> [([(a, b)], [a])] -> [([(a, b)], [a])]
forall a. a -> [a] -> [a]
: [([(a, b)], [a])]
vs2) [(a, b)]
vs3
                       else a
-> [([(a, b)], [a])]
-> [([(a, b)], [a])]
-> [(a, b)]
-> ([([(a, b)], [a])], [(a, b)])
closure a
k (([(a, b)], [a])
dep2 ([(a, b)], [a]) -> [([(a, b)], [a])] -> [([(a, b)], [a])]
forall a. a -> [a] -> [a]
: [([(a, b)], [a])]
deps2) [([(a, b)], [a])]
vs2 [(a, b)]
vs3
{-
        mkNewSig src =
          DTyp (mkArgs 0 0 [] src) cidFloat []
          where
            mkArgs k l env []                      = []
            mkArgs k l env ((i,DTyp _ c es) : src)
               | i == k    = let ty = DTyp [] c (map (normalForm sig k env) es)
                             in (Explicit,wildCId,ty) : mkArgs (k+1) (l+1) (VGen l [] : env) src
               | otherwise = mkArgs (k+1) l (VMeta 0 env [] : env) src
-}
type CState = (Int,Map.Map CId [Equation])

computeConstrs :: PGF -> CState -> [(CId,[Patt],[Expr])] -> (CState,[[CId]])
computeConstrs :: PGF
-> (Int, Map CId [Equation])
-> [(CId, [Patt], [Expr])]
-> ((Int, Map CId [Equation]), [[CId]])
computeConstrs PGF
pgf (Int
ngen,Map CId [Equation]
eqs_map) fns :: [(CId, [Patt], [Expr])]
fns@((CId
id,[Patt]
pts,[]):[(CId, [Patt], [Expr])]
rest)
  | [(CId, [Patt], [Expr])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CId, [Patt], [Expr])]
rest =
     let eqs_map' :: Map CId [Equation]
eqs_map' = 
           ([Equation] -> [Equation] -> [Equation])
-> CId -> [Equation] -> Map CId [Equation] -> Map CId [Equation]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [Equation] -> [Equation] -> [Equation]
forall a. [a] -> [a] -> [a]
(++) (CId -> CId
p_f CId
id)
                               (if [Patt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Patt]
pts
                                  then []
                                  else [[Patt] -> Expr -> Equation
Equ [Patt]
pts (Literal -> Expr
ELit (Double -> Literal
LFlt Double
1.0))])
                               Map CId [Equation]
eqs_map
     in ((Int
ngen,Map CId [Equation]
eqs_map'),[])
  | Bool
otherwise =
     let ((Int, Map CId [Equation])
st,[CId]
ks) = ((Int, Map CId [Equation])
 -> (CId, [Patt], [Expr]) -> ((Int, Map CId [Equation]), CId))
-> (Int, Map CId [Equation])
-> [(CId, [Patt], [Expr])]
-> ((Int, Map CId [Equation]), [CId])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (Int, Map CId [Equation])
-> (CId, [Patt], [Expr]) -> ((Int, Map CId [Equation]), CId)
forall a a.
(Num a, Show a) =>
(a, Map CId [Equation])
-> (CId, [Patt], [a]) -> ((a, Map CId [Equation]), CId)
mk_k (Int
ngen,Map CId [Equation]
eqs_map) [(CId, [Patt], [Expr])]
fns

         mk_k :: (a, Map CId [Equation])
-> (CId, [Patt], [a]) -> ((a, Map CId [Equation]), CId)
mk_k (a
ngen,Map CId [Equation]
eqs_map) (CId
id,[Patt]
pts,[])
           | [Patt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Patt]
pts  = ((a
ngen,Map CId [Equation]
eqs_map),CId -> CId
k_f CId
id)
           | Bool
otherwise = let eqs_map' :: Map CId [Equation]
eqs_map' = 
                               ([Equation] -> [Equation] -> [Equation])
-> CId -> [Equation] -> Map CId [Equation] -> Map CId [Equation]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [Equation] -> [Equation] -> [Equation]
forall a. [a] -> [a] -> [a]
(++) 
                                              (CId -> CId
p_f CId
id) 
                                              [[Patt] -> Expr -> Equation
Equ [Patt]
pts (CId -> Expr
EFun (a -> CId
forall a. Show a => a -> CId
k_i a
ngen))]
                                              Map CId [Equation]
eqs_map
                         in ((a
ngena -> a -> a
forall a. Num a => a -> a -> a
+a
1,Map CId [Equation]
eqs_map'),a -> CId
forall a. Show a => a -> CId
k_i a
ngen)

     in ((Int, Map CId [Equation])
st,[[CId]
ks])
computeConstrs PGF
pgf (Int, Map CId [Equation])
st [(CId, [Patt], [Expr])]
fns =
  let ((Int, Map CId [Equation])
st',[[[CId]]]
res) = ((Int, Map CId [Equation])
 -> (Patt, [(CId, [Patt], [Expr])])
 -> ((Int, Map CId [Equation]), [[CId]]))
-> (Int, Map CId [Equation])
-> [(Patt, [(CId, [Patt], [Expr])])]
-> ((Int, Map CId [Equation]), [[[CId]]])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\(Int, Map CId [Equation])
st (Patt
p,[(CId, [Patt], [Expr])]
fns) -> PGF
-> (Int, Map CId [Equation])
-> [(CId, [Patt], [Expr])]
-> ((Int, Map CId [Equation]), [[CId]])
computeConstrs PGF
pgf (Int, Map CId [Equation])
st [(CId, [Patt], [Expr])]
fns)
                            (Int, Map CId [Equation])
st
                            ([(CId, [Patt], [Expr])] -> [(Patt, [(CId, [Patt], [Expr])])]
forall a. [(a, [Patt], [Expr])] -> [(Patt, [(a, [Patt], [Expr])])]
computeConstr [(CId, [Patt], [Expr])]
fns)
  in ((Int, Map CId [Equation])
st',[[[CId]]] -> [[CId]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[CId]]]
res)
  where
    computeConstr :: [(a, [Patt], [Expr])] -> [(Patt, [(a, [Patt], [Expr])])]
computeConstr [(a, [Patt], [Expr])]
fns = (Map CId [(a, [Patt], [Expr])], [(a, [Patt], [Expr])])
-> [(Patt, [(a, [Patt], [Expr])])]
merge ([(a, [Patt], [Expr])]
-> (Map CId [(a, [Patt], [Expr])], [(a, [Patt], [Expr])])
-> (Map CId [(a, [Patt], [Expr])], [(a, [Patt], [Expr])])
forall a b.
[(a, b, [Expr])]
-> (Map CId [(a, b, [Expr])], [(a, b, [Expr])])
-> (Map CId [(a, b, [Expr])], [(a, b, [Expr])])
split [(a, [Patt], [Expr])]
fns (Map CId [(a, [Patt], [Expr])]
forall k a. Map k a
Map.empty,[]))

    merge :: (Map CId [(a, [Patt], [Expr])], [(a, [Patt], [Expr])])
-> [(Patt, [(a, [Patt], [Expr])])]
merge (Map CId [(a, [Patt], [Expr])]
cns,[(a, [Patt], [Expr])]
vrs) =
      [(Patt
p,[(a, [Patt], [Expr])]
fns[(a, [Patt], [Expr])]
-> [(a, [Patt], [Expr])] -> [(a, [Patt], [Expr])]
forall a. [a] -> [a] -> [a]
++[(a
id,[Patt]
ps[Patt] -> [Patt] -> [Patt]
forall a. [a] -> [a] -> [a]
++[Patt
p],[Expr]
es) | (a
id,[Patt]
ps,[Expr]
es) <- [(a, [Patt], [Expr])]
vrs])
                                | (Patt
p,[(a, [Patt], [Expr])]
fns) <- ((CId, [(a, [Patt], [Expr])]) -> [(Patt, [(a, [Patt], [Expr])])])
-> [(CId, [(a, [Patt], [Expr])])]
-> [(Patt, [(a, [Patt], [Expr])])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CId, [(a, [Patt], [Expr])]) -> [(Patt, [(a, [Patt], [Expr])])]
addArgs (Map CId [(a, [Patt], [Expr])] -> [(CId, [(a, [Patt], [Expr])])]
forall k a. Map k a -> [(k, a)]
Map.toList Map CId [(a, [Patt], [Expr])]
cns)]
      [(Patt, [(a, [Patt], [Expr])])]
-> [(Patt, [(a, [Patt], [Expr])])]
-> [(Patt, [(a, [Patt], [Expr])])]
forall a. [a] -> [a] -> [a]
++
      if [(a, [Patt], [Expr])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, [Patt], [Expr])]
vrs 
        then []
        else [(Patt
PWild,[(a
id,[Patt]
ps[Patt] -> [Patt] -> [Patt]
forall a. [a] -> [a] -> [a]
++[Patt
PWild],[Expr]
es) | (a
id,[Patt]
ps,[Expr]
es) <- [(a, [Patt], [Expr])]
vrs])]
      where
        addArgs :: (CId, [(a, [Patt], [Expr])]) -> [(Patt, [(a, [Patt], [Expr])])]
addArgs (CId
cn,[(a, [Patt], [Expr])]
fns) = Int
-> CId
-> [Patt]
-> [(a, [Patt], [Expr])]
-> [(Patt, [(a, [Patt], [Expr])])]
forall t.
(Eq t, Num t) =>
t
-> CId
-> [Patt]
-> [(a, [Patt], [Expr])]
-> [(Patt, [(a, [Patt], [Expr])])]
addArg ([Hypo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Hypo]
args) CId
cn [] [(a, [Patt], [Expr])]
fns
          where
            Just (DTyp [Hypo]
args CId
_ [Expr]
_es,Int
_,Maybe ([Equation], [[Instr]])
_,Double
_) = 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
cn (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs (PGF -> Abstr
abstract PGF
pgf))

        addArg :: t
-> CId
-> [Patt]
-> [(a, [Patt], [Expr])]
-> [(Patt, [(a, [Patt], [Expr])])]
addArg t
0 CId
cn [Patt]
ps [(a, [Patt], [Expr])]
fns = [(CId -> [Patt] -> Patt
PApp CId
cn ([Patt] -> [Patt]
forall a. [a] -> [a]
reverse [Patt]
ps),[(a, [Patt], [Expr])]
fns)]
        addArg t
n CId
cn [Patt]
ps [(a, [Patt], [Expr])]
fns = [[(Patt, [(a, [Patt], [Expr])])]]
-> [(Patt, [(a, [Patt], [Expr])])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [t
-> CId
-> [Patt]
-> [(a, [Patt], [Expr])]
-> [(Patt, [(a, [Patt], [Expr])])]
addArg (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) CId
cn (Patt
argPatt -> [Patt] -> [Patt]
forall a. a -> [a] -> [a]
:[Patt]
ps) [(a, [Patt], [Expr])]
fns' | (Patt
arg,[(a, [Patt], [Expr])]
fns') <- [(a, [Patt], [Expr])] -> [(Patt, [(a, [Patt], [Expr])])]
computeConstr [(a, [Patt], [Expr])]
fns]

    split :: [(a, b, [Expr])]
-> (Map CId [(a, b, [Expr])], [(a, b, [Expr])])
-> (Map CId [(a, b, [Expr])], [(a, b, [Expr])])
split []                   (Map CId [(a, b, [Expr])]
cns,[(a, b, [Expr])]
vrs) = (Map CId [(a, b, [Expr])]
cns,[(a, b, [Expr])]
vrs)
    split ((a
id, b
ps, Expr
e:[Expr]
es):[(a, b, [Expr])]
fns) (Map CId [(a, b, [Expr])]
cns,[(a, b, [Expr])]
vrs) = [(a, b, [Expr])]
-> (Map CId [(a, b, [Expr])], [(a, b, [Expr])])
-> (Map CId [(a, b, [Expr])], [(a, b, [Expr])])
split [(a, b, [Expr])]
fns (Expr -> [Expr] -> (Map CId [(a, b, [Expr])], [(a, b, [Expr])])
extract Expr
e [])
      where
        extract :: Expr -> [Expr] -> (Map CId [(a, b, [Expr])], [(a, b, [Expr])])
extract (EFun CId
cn)     [Expr]
args = (([(a, b, [Expr])] -> [(a, b, [Expr])] -> [(a, b, [Expr])])
-> CId
-> [(a, b, [Expr])]
-> Map CId [(a, b, [Expr])]
-> Map CId [(a, b, [Expr])]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [(a, b, [Expr])] -> [(a, b, [Expr])] -> [(a, b, [Expr])]
forall a. [a] -> [a] -> [a]
(++) CId
cn [(a
id,b
ps,[Expr]
args[Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++[Expr]
es)] Map CId [(a, b, [Expr])]
cns, [(a, b, [Expr])]
vrs)
        extract (EVar Int
i)      [Expr]
args = (Map CId [(a, b, [Expr])]
cns, (a
id,b
ps,[Expr]
es)(a, b, [Expr]) -> [(a, b, [Expr])] -> [(a, b, [Expr])]
forall a. a -> [a] -> [a]
:[(a, b, [Expr])]
vrs)
        extract (EApp Expr
e1 Expr
e2)  [Expr]
args = Expr -> [Expr] -> (Map CId [(a, b, [Expr])], [(a, b, [Expr])])
extract Expr
e1 (Expr
e2Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
:[Expr]
args)
        extract (ETyped Expr
e Type
ty) [Expr]
args = Expr -> [Expr] -> (Map CId [(a, b, [Expr])], [(a, b, [Expr])])
extract Expr
e [Expr]
args
        extract (EImplArg Expr
e)  [Expr]
args = Expr -> [Expr] -> (Map CId [(a, b, [Expr])], [(a, b, [Expr])])
extract Expr
e [Expr]
args

p_f :: CId -> CId
p_f CId
c = String -> CId
mkCId (String
"p_"String -> String -> String
forall a. [a] -> [a] -> [a]
++CId -> String
showCId CId
c)
p_i :: a -> CId
p_i a
i = String -> CId
mkCId (String
"p_"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
i)
k_f :: CId -> CId
k_f CId
f = String -> CId
mkCId (String
"k_"String -> String -> String
forall a. [a] -> [a] -> [a]
++CId -> String
showCId CId
f)
k_i :: a -> CId
k_i a
i = String -> CId
mkCId (String
"k_"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
i)