module PGF.Probabilistic
( Probabilities(..)
, mkProbabilities
, defaultProbabilities
, getProbabilities
, setProbabilities
, showProbabilities
, readProbabilitiesFromFile
, 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)
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)])
}
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
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
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)
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
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
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
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)